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

Functions

subroutine zggsvp (jobu, jobv, jobq, m, p, n, a, lda, b, ldb, tola, tolb, k, l, u, ldu, v, ldv, q, ldq, iwork, rwork, tau, work, info)
 ZGGSVP
subroutine zlatzm (side, m, n, v, incv, tau, c1, c2, ldc, work)
 ZLATZM
subroutine ztzrqf (m, n, a, lda, tau, info)
 ZTZRQF
subroutine zbbcsd (jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta, phi, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, rwork, lrwork, info)
 ZBBCSD
subroutine zbdsqr (uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, rwork, info)
 ZBDSQR
subroutine zgghd3 (compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, work, lwork, info)
 ZGGHD3
subroutine zgghrd (compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, info)
 ZGGHRD
subroutine zggqrf (n, m, p, a, lda, taua, b, ldb, taub, work, lwork, info)
 ZGGQRF
subroutine zggrqf (m, p, n, a, lda, taua, b, ldb, taub, work, lwork, info)
 ZGGRQF
subroutine zggsvp3 (jobu, jobv, jobq, m, p, n, a, lda, b, ldb, tola, tolb, k, l, u, ldu, v, ldv, q, ldq, iwork, rwork, tau, work, lwork, info)
 ZGGSVP3
subroutine zgsvj0 (jobv, m, n, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
  ZGSVJ0 pre-processor for the routine zgesvj.
subroutine zgsvj1 (jobv, m, n, n1, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
 ZGSVJ1 pre-processor for the routine zgesvj, applies Jacobi rotations targeting only particular pivots.
subroutine zhbgst (vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x, ldx, work, rwork, info)
 ZHBGST
subroutine zhbtrd (vect, uplo, n, kd, ab, ldab, d, e, q, ldq, work, info)
 ZHBTRD
subroutine zhetrd_hb2st (stage1, vect, uplo, n, kd, ab, ldab, d, e, hous, lhous, work, lwork, info)
 ZHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric tridiagonal form T
subroutine zhfrk (transr, uplo, trans, n, k, alpha, a, lda, beta, c)
 ZHFRK performs a Hermitian rank-k operation for matrix in RFP format.
subroutine zhpcon (uplo, n, ap, ipiv, anorm, rcond, work, info)
 ZHPCON
subroutine zhpgst (itype, uplo, n, ap, bp, info)
 ZHPGST
subroutine zhprfs (uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 ZHPRFS
subroutine zhptrd (uplo, n, ap, d, e, tau, info)
 ZHPTRD
subroutine zhptrf (uplo, n, ap, ipiv, info)
 ZHPTRF
subroutine zhptri (uplo, n, ap, ipiv, work, info)
 ZHPTRI
subroutine zhptrs (uplo, n, nrhs, ap, ipiv, b, ldb, info)
 ZHPTRS
subroutine zhsein (side, eigsrc, initv, select, n, h, ldh, w, vl, ldvl, vr, ldvr, mm, m, work, rwork, ifaill, ifailr, info)
 ZHSEIN
subroutine zhseqr (job, compz, n, ilo, ihi, h, ldh, w, z, ldz, work, lwork, info)
 ZHSEQR
subroutine zla_lin_berr (n, nz, nrhs, res, ayb, berr)
 ZLA_LIN_BERR computes a component-wise relative backward error.
subroutine zla_wwaddw (n, x, y, w)
 ZLA_WWADDW adds a vector into a doubled-single vector.
subroutine zlaed0 (qsiz, n, d, e, q, ldq, qstore, ldqs, rwork, iwork, info)
 ZLAED0 used by ZSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method.
subroutine zlaed7 (n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, ldq, rho, indxq, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, rwork, iwork, info)
 ZLAED7 used by ZSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense.
subroutine zlaed8 (k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda, q2, ldq2, w, indxp, indx, indxq, perm, givptr, givcol, givnum, info)
 ZLAED8 used by ZSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense.
subroutine zlals0 (icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx, perm, givptr, givcol, ldgcol, givnum, ldgnum, poles, difl, difr, z, k, c, s, rwork, info)
 ZLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd.
subroutine zlalsa (icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u, ldu, vt, k, difl, difr, z, poles, givptr, givcol, ldgcol, perm, givnum, c, s, rwork, iwork, info)
 ZLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd.
subroutine zlalsd (uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond, rank, work, rwork, iwork, info)
 ZLALSD uses the singular value decomposition of A to solve the least squares problem.
double precision function zlanhf (norm, transr, uplo, n, a, work)
 ZLANHF 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 matrix in RFP format.
subroutine zlarscl2 (m, n, d, x, ldx)
 ZLARSCL2 performs reciprocal diagonal scaling on a vector.
subroutine zlarz (side, m, n, l, v, incv, tau, c, ldc, work)
 ZLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix.
subroutine zlarzb (side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, c, ldc, work, ldwork)
 ZLARZB applies a block reflector or its conjugate-transpose to a general matrix.
subroutine zlarzt (direct, storev, n, k, v, ldv, tau, t, ldt)
 ZLARZT forms the triangular factor T of a block reflector H = I - vtvH.
subroutine zlascl2 (m, n, d, x, ldx)
 ZLASCL2 performs diagonal scaling on a vector.
subroutine zlatrz (m, n, l, a, lda, tau, work)
 ZLATRZ factors an upper trapezoidal matrix by means of unitary transformations.
subroutine zpbcon (uplo, n, kd, ab, ldab, anorm, rcond, work, rwork, info)
 ZPBCON
subroutine zpbequ (uplo, n, kd, ab, ldab, s, scond, amax, info)
 ZPBEQU
subroutine zpbrfs (uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 ZPBRFS
subroutine zpbstf (uplo, n, kd, ab, ldab, info)
 ZPBSTF
subroutine zpbtf2 (uplo, n, kd, ab, ldab, info)
 ZPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (unblocked algorithm).
subroutine zpbtrf (uplo, n, kd, ab, ldab, info)
 ZPBTRF
subroutine zpbtrs (uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
 ZPBTRS
subroutine zpftrf (transr, uplo, n, a, info)
 ZPFTRF
subroutine zpftri (transr, uplo, n, a, info)
 ZPFTRI
subroutine zpftrs (transr, uplo, n, nrhs, a, b, ldb, info)
 ZPFTRS
subroutine zppcon (uplo, n, ap, anorm, rcond, work, rwork, info)
 ZPPCON
subroutine zppequ (uplo, n, ap, s, scond, amax, info)
 ZPPEQU
subroutine zpprfs (uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 ZPPRFS
subroutine zpptrf (uplo, n, ap, info)
 ZPPTRF
subroutine zpptri (uplo, n, ap, info)
 ZPPTRI
subroutine zpptrs (uplo, n, nrhs, ap, b, ldb, info)
 ZPPTRS
subroutine zpstf2 (uplo, n, a, lda, piv, rank, tol, work, info)
 ZPSTF2 computes the Cholesky factorization with complete pivoting of a complex Hermitian positive semidefinite matrix.
subroutine zpstrf (uplo, n, a, lda, piv, rank, tol, work, info)
 ZPSTRF computes the Cholesky factorization with complete pivoting of a complex Hermitian positive semidefinite matrix.
subroutine zspcon (uplo, n, ap, ipiv, anorm, rcond, work, info)
 ZSPCON
subroutine zsprfs (uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 ZSPRFS
subroutine zsptrf (uplo, n, ap, ipiv, info)
 ZSPTRF
subroutine zsptri (uplo, n, ap, ipiv, work, info)
 ZSPTRI
subroutine zsptrs (uplo, n, nrhs, ap, ipiv, b, ldb, info)
 ZSPTRS
subroutine zstedc (compz, n, d, e, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
 ZSTEDC
subroutine zstegr (jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
 ZSTEGR
subroutine zstein (n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
 ZSTEIN
subroutine zstemr (jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
 ZSTEMR
subroutine zsteqr (compz, n, d, e, z, ldz, work, info)
 ZSTEQR
subroutine ztbcon (norm, uplo, diag, n, kd, ab, ldab, rcond, work, rwork, info)
 ZTBCON
subroutine ztbrfs (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 ZTBRFS
subroutine ztbtrs (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, info)
 ZTBTRS
subroutine ztfsm (transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
 ZTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
subroutine ztftri (transr, uplo, diag, n, a, info)
 ZTFTRI
subroutine ztfttp (transr, uplo, n, arf, ap, info)
 ZTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed format (TP).
subroutine ztfttr (transr, uplo, n, arf, a, lda, info)
 ZTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full format (TR).
subroutine ztgsen (ijob, wantq, wantz, select, n, a, lda, b, ldb, alpha, beta, q, ldq, z, ldz, m, pl, pr, dif, work, lwork, iwork, liwork, info)
 ZTGSEN
subroutine ztgsja (jobu, jobv, jobq, m, p, n, k, l, a, lda, b, ldb, tola, tolb, alpha, beta, u, ldu, v, ldv, q, ldq, work, ncycle, info)
 ZTGSJA
subroutine ztgsna (job, howmny, select, n, a, lda, b, ldb, vl, ldvl, vr, ldvr, s, dif, mm, m, work, lwork, iwork, info)
 ZTGSNA
subroutine ztpcon (norm, uplo, diag, n, ap, rcond, work, rwork, info)
 ZTPCON
subroutine ztpmqrt (side, trans, m, n, k, l, nb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
 ZTPMQRT
subroutine ztpqrt (m, n, l, nb, a, lda, b, ldb, t, ldt, work, info)
 ZTPQRT
subroutine ztpqrt2 (m, n, l, a, lda, b, ldb, t, ldt, info)
 ZTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q.
subroutine ztprfs (uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 ZTPRFS
subroutine ztptri (uplo, diag, n, ap, info)
 ZTPTRI
subroutine ztptrs (uplo, trans, diag, n, nrhs, ap, b, ldb, info)
 ZTPTRS
subroutine ztpttf (transr, uplo, n, ap, arf, info)
 ZTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed format (TF).
subroutine ztpttr (uplo, n, ap, a, lda, info)
 ZTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (TR).
subroutine ztrcon (norm, uplo, diag, n, a, lda, rcond, work, rwork, info)
 ZTRCON
subroutine ztrevc (side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, rwork, info)
 ZTREVC
subroutine ztrevc3 (side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, lwork, rwork, lrwork, info)
 ZTREVC3
subroutine ztrexc (compq, n, t, ldt, q, ldq, ifst, ilst, info)
 ZTREXC
subroutine ztrrfs (uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 ZTRRFS
subroutine ztrsen (job, compq, select, n, t, ldt, q, ldq, w, m, s, sep, work, lwork, info)
 ZTRSEN
subroutine ztrsna (job, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, s, sep, mm, m, work, ldwork, rwork, info)
 ZTRSNA
subroutine ztrti2 (uplo, diag, n, a, lda, info)
 ZTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
subroutine ztrtri (uplo, diag, n, a, lda, info)
 ZTRTRI
subroutine ztrtrs (uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
 ZTRTRS
subroutine ztrttf (transr, uplo, n, a, lda, arf, info)
 ZTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed format (TF).
subroutine ztrttp (uplo, n, a, lda, ap, info)
 ZTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (TP).
subroutine ztzrzf (m, n, a, lda, tau, work, lwork, info)
 ZTZRZF
subroutine zunbdb (trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, lwork, info)
 ZUNBDB
subroutine zunbdb1 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 ZUNBDB1
subroutine zunbdb2 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 ZUNBDB2
subroutine zunbdb3 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 ZUNBDB3
subroutine zunbdb4 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, phantom, work, lwork, info)
 ZUNBDB4
subroutine zunbdb5 (m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
 ZUNBDB5
subroutine zunbdb6 (m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
 ZUNBDB6
recursive subroutine zuncsd (jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, work, lwork, rwork, lrwork, iwork, info)
 ZUNCSD
subroutine zuncsd2by1 (jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, rwork, lrwork, iwork, info)
 ZUNCSD2BY1
subroutine zung2l (m, n, k, a, lda, tau, work, info)
 ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm).
subroutine zung2r (m, n, k, a, lda, tau, work, info)
 ZUNG2R
subroutine zunghr (n, ilo, ihi, a, lda, tau, work, lwork, info)
 ZUNGHR
subroutine zungl2 (m, n, k, a, lda, tau, work, info)
 ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (unblocked algorithm).
subroutine zunglq (m, n, k, a, lda, tau, work, lwork, info)
 ZUNGLQ
subroutine zungql (m, n, k, a, lda, tau, work, lwork, info)
 ZUNGQL
subroutine zungqr (m, n, k, a, lda, tau, work, lwork, info)
 ZUNGQR
subroutine zungr2 (m, n, k, a, lda, tau, work, info)
 ZUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cgerqf (unblocked algorithm).
subroutine zungrq (m, n, k, a, lda, tau, work, lwork, info)
 ZUNGRQ
subroutine zungtr (uplo, n, a, lda, tau, work, lwork, info)
 ZUNGTR
subroutine zungtsqr (m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
 ZUNGTSQR
subroutine zungtsqr_row (m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
 ZUNGTSQR_ROW
subroutine zunhr_col (m, n, nb, a, lda, t, ldt, d, info)
 ZUNHR_COL
subroutine zunm2l (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf (unblocked algorithm).
subroutine zunm2r (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm).
subroutine zunmbr (vect, side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 ZUNMBR
subroutine zunmhr (side, trans, m, n, ilo, ihi, a, lda, tau, c, ldc, work, lwork, info)
 ZUNMHR
subroutine zunml2 (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 ZUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf (unblocked algorithm).
subroutine zunmlq (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 ZUNMLQ
subroutine zunmql (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 ZUNMQL
subroutine zunmqr (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 ZUNMQR
subroutine zunmr2 (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 ZUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf (unblocked algorithm).
subroutine zunmr3 (side, trans, m, n, k, l, a, lda, tau, c, ldc, work, info)
 ZUNMR3 multiplies a general matrix by the unitary matrix from a RZ factorization determined by ctzrzf (unblocked algorithm).
subroutine zunmrq (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 ZUNMRQ
subroutine zunmrz (side, trans, m, n, k, l, a, lda, tau, c, ldc, work, lwork, info)
 ZUNMRZ
subroutine zunmtr (side, uplo, trans, m, n, a, lda, tau, c, ldc, work, lwork, info)
 ZUNMTR
subroutine zupgtr (uplo, n, ap, tau, q, ldq, work, info)
 ZUPGTR
subroutine zupmtr (side, uplo, trans, m, n, ap, tau, c, ldc, work, info)
 ZUPMTR

Detailed Description

This is the group of complex16 other Computational routines

Function Documentation

◆ zbbcsd()

subroutine zbbcsd ( character jobu1,
character jobu2,
character jobv1t,
character jobv2t,
character trans,
integer m,
integer p,
integer q,
double precision, dimension( * ) theta,
double precision, dimension( * ) phi,
complex*16, dimension( ldu1, * ) u1,
integer ldu1,
complex*16, dimension( ldu2, * ) u2,
integer ldu2,
complex*16, dimension( ldv1t, * ) v1t,
integer ldv1t,
complex*16, dimension( ldv2t, * ) v2t,
integer ldv2t,
double precision, dimension( * ) b11d,
double precision, dimension( * ) b11e,
double precision, dimension( * ) b12d,
double precision, dimension( * ) b12e,
double precision, dimension( * ) b21d,
double precision, dimension( * ) b21e,
double precision, dimension( * ) b22d,
double precision, dimension( * ) b22e,
double precision, dimension( * ) rwork,
integer lrwork,
integer info )

ZBBCSD

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

Purpose:
!>
!> ZBBCSD computes the CS decomposition of a unitary matrix in
!> bidiagonal-block form,
!>
!>
!>     [ B11 | B12 0  0 ]
!>     [  0  |  0 -I  0 ]
!> X = [----------------]
!>     [ B21 | B22 0  0 ]
!>     [  0  |  0  0  I ]
!>
!>                               [  C | -S  0  0 ]
!>                   [ U1 |    ] [  0 |  0 -I  0 ] [ V1 |    ]**H
!>                 = [---------] [---------------] [---------]   .
!>                   [    | U2 ] [  S |  C  0  0 ] [    | V2 ]
!>                               [  0 |  0  0  I ]
!>
!> X is M-by-M, its top-left block is P-by-Q, and Q must be no larger
!> than P, M-P, or M-Q. (If Q is not the smallest index, then X must be
!> transposed and/or permuted. This can be done in constant time using
!> the TRANS and SIGNS options. See ZUNCSD for details.)
!>
!> The bidiagonal matrices B11, B12, B21, and B22 are represented
!> implicitly by angles THETA(1:Q) and PHI(1:Q-1).
!>
!> The unitary matrices U1, U2, V1T, and V2T are input/output.
!> The input matrices are pre- or post-multiplied by the appropriate
!> singular vector matrices.
!>
Parameters
[in]JOBU1
!>          JOBU1 is CHARACTER
!>          = 'Y':      U1 is updated;
!>          otherwise:  U1 is not updated.
!>
[in]JOBU2
!>          JOBU2 is CHARACTER
!>          = 'Y':      U2 is updated;
!>          otherwise:  U2 is not updated.
!>
[in]JOBV1T
!>          JOBV1T is CHARACTER
!>          = 'Y':      V1T is updated;
!>          otherwise:  V1T is not updated.
!>
[in]JOBV2T
!>          JOBV2T is CHARACTER
!>          = 'Y':      V2T is updated;
!>          otherwise:  V2T is not updated.
!>
[in]TRANS
!>          TRANS is CHARACTER
!>          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major
!>                      order;
!>          otherwise:  X, U1, U2, V1T, and V2T are stored in column-
!>                      major order.
!>
[in]M
!>          M is INTEGER
!>          The number of rows and columns in X, the unitary matrix in
!>          bidiagonal-block form.
!>
[in]P
!>          P is INTEGER
!>          The number of rows in the top-left block of X. 0 <= P <= M.
!>
[in]Q
!>          Q is INTEGER
!>          The number of columns in the top-left block of X.
!>          0 <= Q <= MIN(P,M-P,M-Q).
!>
[in,out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (Q)
!>          On entry, the angles THETA(1),...,THETA(Q) that, along with
!>          PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block
!>          form. On exit, the angles whose cosines and sines define the
!>          diagonal blocks in the CS decomposition.
!>
[in,out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>          The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,
!>          THETA(Q), define the matrix in bidiagonal-block form.
!>
[in,out]U1
!>          U1 is COMPLEX*16 array, dimension (LDU1,P)
!>          On entry, a P-by-P matrix. On exit, U1 is postmultiplied
!>          by the left singular vector matrix common to [ B11 ; 0 ] and
!>          [ B12 0 0 ; 0 -I 0 0 ].
!>
[in]LDU1
!>          LDU1 is INTEGER
!>          The leading dimension of the array U1, LDU1 >= MAX(1,P).
!>
[in,out]U2
!>          U2 is COMPLEX*16 array, dimension (LDU2,M-P)
!>          On entry, an (M-P)-by-(M-P) matrix. On exit, U2 is
!>          postmultiplied by the left singular vector matrix common to
!>          [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].
!>
[in]LDU2
!>          LDU2 is INTEGER
!>          The leading dimension of the array U2, LDU2 >= MAX(1,M-P).
!>
[in,out]V1T
!>          V1T is COMPLEX*16 array, dimension (LDV1T,Q)
!>          On entry, a Q-by-Q matrix. On exit, V1T is premultiplied
!>          by the conjugate transpose of the right singular vector
!>          matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].
!>
[in]LDV1T
!>          LDV1T is INTEGER
!>          The leading dimension of the array V1T, LDV1T >= MAX(1,Q).
!>
[in,out]V2T
!>          V2T is COMPLEX*16 array, dimension (LDV2T,M-Q)
!>          On entry, an (M-Q)-by-(M-Q) matrix. On exit, V2T is
!>          premultiplied by the conjugate transpose of the right
!>          singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and
!>          [ B22 0 0 ; 0 0 I ].
!>
[in]LDV2T
!>          LDV2T is INTEGER
!>          The leading dimension of the array V2T, LDV2T >= MAX(1,M-Q).
!>
[out]B11D
!>          B11D is DOUBLE PRECISION array, dimension (Q)
!>          When ZBBCSD converges, B11D contains the cosines of THETA(1),
!>          ..., THETA(Q). If ZBBCSD fails to converge, then B11D
!>          contains the diagonal of the partially reduced top-left
!>          block.
!>
[out]B11E
!>          B11E is DOUBLE PRECISION array, dimension (Q-1)
!>          When ZBBCSD converges, B11E contains zeros. If ZBBCSD fails
!>          to converge, then B11E contains the superdiagonal of the
!>          partially reduced top-left block.
!>
[out]B12D
!>          B12D is DOUBLE PRECISION array, dimension (Q)
!>          When ZBBCSD converges, B12D contains the negative sines of
!>          THETA(1), ..., THETA(Q). If ZBBCSD fails to converge, then
!>          B12D contains the diagonal of the partially reduced top-right
!>          block.
!>
[out]B12E
!>          B12E is DOUBLE PRECISION array, dimension (Q-1)
!>          When ZBBCSD converges, B12E contains zeros. If ZBBCSD fails
!>          to converge, then B12E contains the subdiagonal of the
!>          partially reduced top-right block.
!>
[out]B21D
!>          B21D is DOUBLE PRECISION array, dimension (Q)
!>          When ZBBCSD converges, B21D contains the negative sines of
!>          THETA(1), ..., THETA(Q). If ZBBCSD fails to converge, then
!>          B21D contains the diagonal of the partially reduced bottom-left
!>          block.
!>
[out]B21E
!>          B21E is DOUBLE PRECISION array, dimension (Q-1)
!>          When ZBBCSD converges, B21E contains zeros. If ZBBCSD fails
!>          to converge, then B21E contains the subdiagonal of the
!>          partially reduced bottom-left block.
!>
[out]B22D
!>          B22D is DOUBLE PRECISION array, dimension (Q)
!>          When ZBBCSD converges, B22D contains the negative sines of
!>          THETA(1), ..., THETA(Q). If ZBBCSD fails to converge, then
!>          B22D contains the diagonal of the partially reduced bottom-right
!>          block.
!>
[out]B22E
!>          B22E is DOUBLE PRECISION array, dimension (Q-1)
!>          When ZBBCSD converges, B22E contains zeros. If ZBBCSD fails
!>          to converge, then B22E contains the subdiagonal of the
!>          partially reduced bottom-right block.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
!>          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
!>
[in]LRWORK
!>          LRWORK is INTEGER
!>          The dimension of the array RWORK. LRWORK >= MAX(1,8*Q).
!>
!>          If LRWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the RWORK array,
!>          returns this value as the first entry of the work array, and
!>          no error message related to LRWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if ZBBCSD did not converge, INFO specifies the number
!>                of nonzero entries in PHI, and B11D, B11E, etc.,
!>                contain the partially reduced matrix.
!>
Internal Parameters:
!>  TOLMUL  DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8)))
!>          TOLMUL controls the convergence criterion of the QR loop.
!>          Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they
!>          are within TOLMUL*EPS of either bound.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 328 of file zbbcsd.f.

332*
333* -- LAPACK computational routine --
334* -- LAPACK is a software package provided by Univ. of Tennessee, --
335* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
336*
337* .. Scalar Arguments ..
338 CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS
339 INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LRWORK, M, P, Q
340* ..
341* .. Array Arguments ..
342 DOUBLE PRECISION B11D( * ), B11E( * ), B12D( * ), B12E( * ),
343 $ B21D( * ), B21E( * ), B22D( * ), B22E( * ),
344 $ PHI( * ), THETA( * ), RWORK( * )
345 COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
346 $ V2T( LDV2T, * )
347* ..
348*
349* ===================================================================
350*
351* .. Parameters ..
352 INTEGER MAXITR
353 parameter( maxitr = 6 )
354 DOUBLE PRECISION HUNDRED, MEIGHTH, ONE, TEN, ZERO
355 parameter( hundred = 100.0d0, meighth = -0.125d0,
356 $ one = 1.0d0, ten = 10.0d0, zero = 0.0d0 )
357 COMPLEX*16 NEGONECOMPLEX
358 parameter( negonecomplex = (-1.0d0,0.0d0) )
359 DOUBLE PRECISION PIOVER2
360 parameter( piover2 = 1.57079632679489661923132169163975144210d0 )
361* ..
362* .. Local Scalars ..
363 LOGICAL COLMAJOR, LQUERY, RESTART11, RESTART12,
364 $ RESTART21, RESTART22, WANTU1, WANTU2, WANTV1T,
365 $ WANTV2T
366 INTEGER I, IMIN, IMAX, ITER, IU1CS, IU1SN, IU2CS,
367 $ IU2SN, IV1TCS, IV1TSN, IV2TCS, IV2TSN, J,
368 $ LRWORKMIN, LRWORKOPT, MAXIT, MINI
369 DOUBLE PRECISION B11BULGE, B12BULGE, B21BULGE, B22BULGE, DUMMY,
370 $ EPS, MU, NU, R, SIGMA11, SIGMA21,
371 $ TEMP, THETAMAX, THETAMIN, THRESH, TOL, TOLMUL,
372 $ UNFL, X1, X2, Y1, Y2
373*
374 EXTERNAL dlartgp, dlartgs, dlas2, xerbla, zlasr, zscal,
375 $ zswap
376* ..
377* .. External Functions ..
378 DOUBLE PRECISION DLAMCH
379 LOGICAL LSAME
380 EXTERNAL lsame, dlamch
381* ..
382* .. Intrinsic Functions ..
383 INTRINSIC abs, atan2, cos, max, min, sin, sqrt
384* ..
385* .. Executable Statements ..
386*
387* Test input arguments
388*
389 info = 0
390 lquery = lrwork .EQ. -1
391 wantu1 = lsame( jobu1, 'Y' )
392 wantu2 = lsame( jobu2, 'Y' )
393 wantv1t = lsame( jobv1t, 'Y' )
394 wantv2t = lsame( jobv2t, 'Y' )
395 colmajor = .NOT. lsame( trans, 'T' )
396*
397 IF( m .LT. 0 ) THEN
398 info = -6
399 ELSE IF( p .LT. 0 .OR. p .GT. m ) THEN
400 info = -7
401 ELSE IF( q .LT. 0 .OR. q .GT. m ) THEN
402 info = -8
403 ELSE IF( q .GT. p .OR. q .GT. m-p .OR. q .GT. m-q ) THEN
404 info = -8
405 ELSE IF( wantu1 .AND. ldu1 .LT. p ) THEN
406 info = -12
407 ELSE IF( wantu2 .AND. ldu2 .LT. m-p ) THEN
408 info = -14
409 ELSE IF( wantv1t .AND. ldv1t .LT. q ) THEN
410 info = -16
411 ELSE IF( wantv2t .AND. ldv2t .LT. m-q ) THEN
412 info = -18
413 END IF
414*
415* Quick return if Q = 0
416*
417 IF( info .EQ. 0 .AND. q .EQ. 0 ) THEN
418 lrworkmin = 1
419 rwork(1) = lrworkmin
420 RETURN
421 END IF
422*
423* Compute workspace
424*
425 IF( info .EQ. 0 ) THEN
426 iu1cs = 1
427 iu1sn = iu1cs + q
428 iu2cs = iu1sn + q
429 iu2sn = iu2cs + q
430 iv1tcs = iu2sn + q
431 iv1tsn = iv1tcs + q
432 iv2tcs = iv1tsn + q
433 iv2tsn = iv2tcs + q
434 lrworkopt = iv2tsn + q - 1
435 lrworkmin = lrworkopt
436 rwork(1) = lrworkopt
437 IF( lrwork .LT. lrworkmin .AND. .NOT. lquery ) THEN
438 info = -28
439 END IF
440 END IF
441*
442 IF( info .NE. 0 ) THEN
443 CALL xerbla( 'ZBBCSD', -info )
444 RETURN
445 ELSE IF( lquery ) THEN
446 RETURN
447 END IF
448*
449* Get machine constants
450*
451 eps = dlamch( 'Epsilon' )
452 unfl = dlamch( 'Safe minimum' )
453 tolmul = max( ten, min( hundred, eps**meighth ) )
454 tol = tolmul*eps
455 thresh = max( tol, maxitr*q*q*unfl )
456*
457* Test for negligible sines or cosines
458*
459 DO i = 1, q
460 IF( theta(i) .LT. thresh ) THEN
461 theta(i) = zero
462 ELSE IF( theta(i) .GT. piover2-thresh ) THEN
463 theta(i) = piover2
464 END IF
465 END DO
466 DO i = 1, q-1
467 IF( phi(i) .LT. thresh ) THEN
468 phi(i) = zero
469 ELSE IF( phi(i) .GT. piover2-thresh ) THEN
470 phi(i) = piover2
471 END IF
472 END DO
473*
474* Initial deflation
475*
476 imax = q
477 DO WHILE( imax .GT. 1 )
478 IF( phi(imax-1) .NE. zero ) THEN
479 EXIT
480 END IF
481 imax = imax - 1
482 END DO
483 imin = imax - 1
484 IF ( imin .GT. 1 ) THEN
485 DO WHILE( phi(imin-1) .NE. zero )
486 imin = imin - 1
487 IF ( imin .LE. 1 ) EXIT
488 END DO
489 END IF
490*
491* Initialize iteration counter
492*
493 maxit = maxitr*q*q
494 iter = 0
495*
496* Begin main iteration loop
497*
498 DO WHILE( imax .GT. 1 )
499*
500* Compute the matrix entries
501*
502 b11d(imin) = cos( theta(imin) )
503 b21d(imin) = -sin( theta(imin) )
504 DO i = imin, imax - 1
505 b11e(i) = -sin( theta(i) ) * sin( phi(i) )
506 b11d(i+1) = cos( theta(i+1) ) * cos( phi(i) )
507 b12d(i) = sin( theta(i) ) * cos( phi(i) )
508 b12e(i) = cos( theta(i+1) ) * sin( phi(i) )
509 b21e(i) = -cos( theta(i) ) * sin( phi(i) )
510 b21d(i+1) = -sin( theta(i+1) ) * cos( phi(i) )
511 b22d(i) = cos( theta(i) ) * cos( phi(i) )
512 b22e(i) = -sin( theta(i+1) ) * sin( phi(i) )
513 END DO
514 b12d(imax) = sin( theta(imax) )
515 b22d(imax) = cos( theta(imax) )
516*
517* Abort if not converging; otherwise, increment ITER
518*
519 IF( iter .GT. maxit ) THEN
520 info = 0
521 DO i = 1, q
522 IF( phi(i) .NE. zero )
523 $ info = info + 1
524 END DO
525 RETURN
526 END IF
527*
528 iter = iter + imax - imin
529*
530* Compute shifts
531*
532 thetamax = theta(imin)
533 thetamin = theta(imin)
534 DO i = imin+1, imax
535 IF( theta(i) > thetamax )
536 $ thetamax = theta(i)
537 IF( theta(i) < thetamin )
538 $ thetamin = theta(i)
539 END DO
540*
541 IF( thetamax .GT. piover2 - thresh ) THEN
542*
543* Zero on diagonals of B11 and B22; induce deflation with a
544* zero shift
545*
546 mu = zero
547 nu = one
548*
549 ELSE IF( thetamin .LT. thresh ) THEN
550*
551* Zero on diagonals of B12 and B22; induce deflation with a
552* zero shift
553*
554 mu = one
555 nu = zero
556*
557 ELSE
558*
559* Compute shifts for B11 and B21 and use the lesser
560*
561 CALL dlas2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,
562 $ dummy )
563 CALL dlas2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,
564 $ dummy )
565*
566 IF( sigma11 .LE. sigma21 ) THEN
567 mu = sigma11
568 nu = sqrt( one - mu**2 )
569 IF( mu .LT. thresh ) THEN
570 mu = zero
571 nu = one
572 END IF
573 ELSE
574 nu = sigma21
575 mu = sqrt( 1.0 - nu**2 )
576 IF( nu .LT. thresh ) THEN
577 mu = one
578 nu = zero
579 END IF
580 END IF
581 END IF
582*
583* Rotate to produce bulges in B11 and B21
584*
585 IF( mu .LE. nu ) THEN
586 CALL dlartgs( b11d(imin), b11e(imin), mu,
587 $ rwork(iv1tcs+imin-1), rwork(iv1tsn+imin-1) )
588 ELSE
589 CALL dlartgs( b21d(imin), b21e(imin), nu,
590 $ rwork(iv1tcs+imin-1), rwork(iv1tsn+imin-1) )
591 END IF
592*
593 temp = rwork(iv1tcs+imin-1)*b11d(imin) +
594 $ rwork(iv1tsn+imin-1)*b11e(imin)
595 b11e(imin) = rwork(iv1tcs+imin-1)*b11e(imin) -
596 $ rwork(iv1tsn+imin-1)*b11d(imin)
597 b11d(imin) = temp
598 b11bulge = rwork(iv1tsn+imin-1)*b11d(imin+1)
599 b11d(imin+1) = rwork(iv1tcs+imin-1)*b11d(imin+1)
600 temp = rwork(iv1tcs+imin-1)*b21d(imin) +
601 $ rwork(iv1tsn+imin-1)*b21e(imin)
602 b21e(imin) = rwork(iv1tcs+imin-1)*b21e(imin) -
603 $ rwork(iv1tsn+imin-1)*b21d(imin)
604 b21d(imin) = temp
605 b21bulge = rwork(iv1tsn+imin-1)*b21d(imin+1)
606 b21d(imin+1) = rwork(iv1tcs+imin-1)*b21d(imin+1)
607*
608* Compute THETA(IMIN)
609*
610 theta( imin ) = atan2( sqrt( b21d(imin)**2+b21bulge**2 ),
611 $ sqrt( b11d(imin)**2+b11bulge**2 ) )
612*
613* Chase the bulges in B11(IMIN+1,IMIN) and B21(IMIN+1,IMIN)
614*
615 IF( b11d(imin)**2+b11bulge**2 .GT. thresh**2 ) THEN
616 CALL dlartgp( b11bulge, b11d(imin), rwork(iu1sn+imin-1),
617 $ rwork(iu1cs+imin-1), r )
618 ELSE IF( mu .LE. nu ) THEN
619 CALL dlartgs( b11e( imin ), b11d( imin + 1 ), mu,
620 $ rwork(iu1cs+imin-1), rwork(iu1sn+imin-1) )
621 ELSE
622 CALL dlartgs( b12d( imin ), b12e( imin ), nu,
623 $ rwork(iu1cs+imin-1), rwork(iu1sn+imin-1) )
624 END IF
625 IF( b21d(imin)**2+b21bulge**2 .GT. thresh**2 ) THEN
626 CALL dlartgp( b21bulge, b21d(imin), rwork(iu2sn+imin-1),
627 $ rwork(iu2cs+imin-1), r )
628 ELSE IF( nu .LT. mu ) THEN
629 CALL dlartgs( b21e( imin ), b21d( imin + 1 ), nu,
630 $ rwork(iu2cs+imin-1), rwork(iu2sn+imin-1) )
631 ELSE
632 CALL dlartgs( b22d(imin), b22e(imin), mu,
633 $ rwork(iu2cs+imin-1), rwork(iu2sn+imin-1) )
634 END IF
635 rwork(iu2cs+imin-1) = -rwork(iu2cs+imin-1)
636 rwork(iu2sn+imin-1) = -rwork(iu2sn+imin-1)
637*
638 temp = rwork(iu1cs+imin-1)*b11e(imin) +
639 $ rwork(iu1sn+imin-1)*b11d(imin+1)
640 b11d(imin+1) = rwork(iu1cs+imin-1)*b11d(imin+1) -
641 $ rwork(iu1sn+imin-1)*b11e(imin)
642 b11e(imin) = temp
643 IF( imax .GT. imin+1 ) THEN
644 b11bulge = rwork(iu1sn+imin-1)*b11e(imin+1)
645 b11e(imin+1) = rwork(iu1cs+imin-1)*b11e(imin+1)
646 END IF
647 temp = rwork(iu1cs+imin-1)*b12d(imin) +
648 $ rwork(iu1sn+imin-1)*b12e(imin)
649 b12e(imin) = rwork(iu1cs+imin-1)*b12e(imin) -
650 $ rwork(iu1sn+imin-1)*b12d(imin)
651 b12d(imin) = temp
652 b12bulge = rwork(iu1sn+imin-1)*b12d(imin+1)
653 b12d(imin+1) = rwork(iu1cs+imin-1)*b12d(imin+1)
654 temp = rwork(iu2cs+imin-1)*b21e(imin) +
655 $ rwork(iu2sn+imin-1)*b21d(imin+1)
656 b21d(imin+1) = rwork(iu2cs+imin-1)*b21d(imin+1) -
657 $ rwork(iu2sn+imin-1)*b21e(imin)
658 b21e(imin) = temp
659 IF( imax .GT. imin+1 ) THEN
660 b21bulge = rwork(iu2sn+imin-1)*b21e(imin+1)
661 b21e(imin+1) = rwork(iu2cs+imin-1)*b21e(imin+1)
662 END IF
663 temp = rwork(iu2cs+imin-1)*b22d(imin) +
664 $ rwork(iu2sn+imin-1)*b22e(imin)
665 b22e(imin) = rwork(iu2cs+imin-1)*b22e(imin) -
666 $ rwork(iu2sn+imin-1)*b22d(imin)
667 b22d(imin) = temp
668 b22bulge = rwork(iu2sn+imin-1)*b22d(imin+1)
669 b22d(imin+1) = rwork(iu2cs+imin-1)*b22d(imin+1)
670*
671* Inner loop: chase bulges from B11(IMIN,IMIN+2),
672* B12(IMIN,IMIN+1), B21(IMIN,IMIN+2), and B22(IMIN,IMIN+1) to
673* bottom-right
674*
675 DO i = imin+1, imax-1
676*
677* Compute PHI(I-1)
678*
679 x1 = sin(theta(i-1))*b11e(i-1) + cos(theta(i-1))*b21e(i-1)
680 x2 = sin(theta(i-1))*b11bulge + cos(theta(i-1))*b21bulge
681 y1 = sin(theta(i-1))*b12d(i-1) + cos(theta(i-1))*b22d(i-1)
682 y2 = sin(theta(i-1))*b12bulge + cos(theta(i-1))*b22bulge
683*
684 phi(i-1) = atan2( sqrt(x1**2+x2**2), sqrt(y1**2+y2**2) )
685*
686* Determine if there are bulges to chase or if a new direct
687* summand has been reached
688*
689 restart11 = b11e(i-1)**2 + b11bulge**2 .LE. thresh**2
690 restart21 = b21e(i-1)**2 + b21bulge**2 .LE. thresh**2
691 restart12 = b12d(i-1)**2 + b12bulge**2 .LE. thresh**2
692 restart22 = b22d(i-1)**2 + b22bulge**2 .LE. thresh**2
693*
694* If possible, chase bulges from B11(I-1,I+1), B12(I-1,I),
695* B21(I-1,I+1), and B22(I-1,I). If necessary, restart bulge-
696* chasing by applying the original shift again.
697*
698 IF( .NOT. restart11 .AND. .NOT. restart21 ) THEN
699 CALL dlartgp( x2, x1, rwork(iv1tsn+i-1),
700 $ rwork(iv1tcs+i-1), r )
701 ELSE IF( .NOT. restart11 .AND. restart21 ) THEN
702 CALL dlartgp( b11bulge, b11e(i-1), rwork(iv1tsn+i-1),
703 $ rwork(iv1tcs+i-1), r )
704 ELSE IF( restart11 .AND. .NOT. restart21 ) THEN
705 CALL dlartgp( b21bulge, b21e(i-1), rwork(iv1tsn+i-1),
706 $ rwork(iv1tcs+i-1), r )
707 ELSE IF( mu .LE. nu ) THEN
708 CALL dlartgs( b11d(i), b11e(i), mu, rwork(iv1tcs+i-1),
709 $ rwork(iv1tsn+i-1) )
710 ELSE
711 CALL dlartgs( b21d(i), b21e(i), nu, rwork(iv1tcs+i-1),
712 $ rwork(iv1tsn+i-1) )
713 END IF
714 rwork(iv1tcs+i-1) = -rwork(iv1tcs+i-1)
715 rwork(iv1tsn+i-1) = -rwork(iv1tsn+i-1)
716 IF( .NOT. restart12 .AND. .NOT. restart22 ) THEN
717 CALL dlartgp( y2, y1, rwork(iv2tsn+i-1-1),
718 $ rwork(iv2tcs+i-1-1), r )
719 ELSE IF( .NOT. restart12 .AND. restart22 ) THEN
720 CALL dlartgp( b12bulge, b12d(i-1), rwork(iv2tsn+i-1-1),
721 $ rwork(iv2tcs+i-1-1), r )
722 ELSE IF( restart12 .AND. .NOT. restart22 ) THEN
723 CALL dlartgp( b22bulge, b22d(i-1), rwork(iv2tsn+i-1-1),
724 $ rwork(iv2tcs+i-1-1), r )
725 ELSE IF( nu .LT. mu ) THEN
726 CALL dlartgs( b12e(i-1), b12d(i), nu,
727 $ rwork(iv2tcs+i-1-1), rwork(iv2tsn+i-1-1) )
728 ELSE
729 CALL dlartgs( b22e(i-1), b22d(i), mu,
730 $ rwork(iv2tcs+i-1-1), rwork(iv2tsn+i-1-1) )
731 END IF
732*
733 temp = rwork(iv1tcs+i-1)*b11d(i) + rwork(iv1tsn+i-1)*b11e(i)
734 b11e(i) = rwork(iv1tcs+i-1)*b11e(i) -
735 $ rwork(iv1tsn+i-1)*b11d(i)
736 b11d(i) = temp
737 b11bulge = rwork(iv1tsn+i-1)*b11d(i+1)
738 b11d(i+1) = rwork(iv1tcs+i-1)*b11d(i+1)
739 temp = rwork(iv1tcs+i-1)*b21d(i) + rwork(iv1tsn+i-1)*b21e(i)
740 b21e(i) = rwork(iv1tcs+i-1)*b21e(i) -
741 $ rwork(iv1tsn+i-1)*b21d(i)
742 b21d(i) = temp
743 b21bulge = rwork(iv1tsn+i-1)*b21d(i+1)
744 b21d(i+1) = rwork(iv1tcs+i-1)*b21d(i+1)
745 temp = rwork(iv2tcs+i-1-1)*b12e(i-1) +
746 $ rwork(iv2tsn+i-1-1)*b12d(i)
747 b12d(i) = rwork(iv2tcs+i-1-1)*b12d(i) -
748 $ rwork(iv2tsn+i-1-1)*b12e(i-1)
749 b12e(i-1) = temp
750 b12bulge = rwork(iv2tsn+i-1-1)*b12e(i)
751 b12e(i) = rwork(iv2tcs+i-1-1)*b12e(i)
752 temp = rwork(iv2tcs+i-1-1)*b22e(i-1) +
753 $ rwork(iv2tsn+i-1-1)*b22d(i)
754 b22d(i) = rwork(iv2tcs+i-1-1)*b22d(i) -
755 $ rwork(iv2tsn+i-1-1)*b22e(i-1)
756 b22e(i-1) = temp
757 b22bulge = rwork(iv2tsn+i-1-1)*b22e(i)
758 b22e(i) = rwork(iv2tcs+i-1-1)*b22e(i)
759*
760* Compute THETA(I)
761*
762 x1 = cos(phi(i-1))*b11d(i) + sin(phi(i-1))*b12e(i-1)
763 x2 = cos(phi(i-1))*b11bulge + sin(phi(i-1))*b12bulge
764 y1 = cos(phi(i-1))*b21d(i) + sin(phi(i-1))*b22e(i-1)
765 y2 = cos(phi(i-1))*b21bulge + sin(phi(i-1))*b22bulge
766*
767 theta(i) = atan2( sqrt(y1**2+y2**2), sqrt(x1**2+x2**2) )
768*
769* Determine if there are bulges to chase or if a new direct
770* summand has been reached
771*
772 restart11 = b11d(i)**2 + b11bulge**2 .LE. thresh**2
773 restart12 = b12e(i-1)**2 + b12bulge**2 .LE. thresh**2
774 restart21 = b21d(i)**2 + b21bulge**2 .LE. thresh**2
775 restart22 = b22e(i-1)**2 + b22bulge**2 .LE. thresh**2
776*
777* If possible, chase bulges from B11(I+1,I), B12(I+1,I-1),
778* B21(I+1,I), and B22(I+1,I-1). If necessary, restart bulge-
779* chasing by applying the original shift again.
780*
781 IF( .NOT. restart11 .AND. .NOT. restart12 ) THEN
782 CALL dlartgp( x2, x1, rwork(iu1sn+i-1), rwork(iu1cs+i-1),
783 $ r )
784 ELSE IF( .NOT. restart11 .AND. restart12 ) THEN
785 CALL dlartgp( b11bulge, b11d(i), rwork(iu1sn+i-1),
786 $ rwork(iu1cs+i-1), r )
787 ELSE IF( restart11 .AND. .NOT. restart12 ) THEN
788 CALL dlartgp( b12bulge, b12e(i-1), rwork(iu1sn+i-1),
789 $ rwork(iu1cs+i-1), r )
790 ELSE IF( mu .LE. nu ) THEN
791 CALL dlartgs( b11e(i), b11d(i+1), mu, rwork(iu1cs+i-1),
792 $ rwork(iu1sn+i-1) )
793 ELSE
794 CALL dlartgs( b12d(i), b12e(i), nu, rwork(iu1cs+i-1),
795 $ rwork(iu1sn+i-1) )
796 END IF
797 IF( .NOT. restart21 .AND. .NOT. restart22 ) THEN
798 CALL dlartgp( y2, y1, rwork(iu2sn+i-1), rwork(iu2cs+i-1),
799 $ r )
800 ELSE IF( .NOT. restart21 .AND. restart22 ) THEN
801 CALL dlartgp( b21bulge, b21d(i), rwork(iu2sn+i-1),
802 $ rwork(iu2cs+i-1), r )
803 ELSE IF( restart21 .AND. .NOT. restart22 ) THEN
804 CALL dlartgp( b22bulge, b22e(i-1), rwork(iu2sn+i-1),
805 $ rwork(iu2cs+i-1), r )
806 ELSE IF( nu .LT. mu ) THEN
807 CALL dlartgs( b21e(i), b21e(i+1), nu, rwork(iu2cs+i-1),
808 $ rwork(iu2sn+i-1) )
809 ELSE
810 CALL dlartgs( b22d(i), b22e(i), mu, rwork(iu2cs+i-1),
811 $ rwork(iu2sn+i-1) )
812 END IF
813 rwork(iu2cs+i-1) = -rwork(iu2cs+i-1)
814 rwork(iu2sn+i-1) = -rwork(iu2sn+i-1)
815*
816 temp = rwork(iu1cs+i-1)*b11e(i) + rwork(iu1sn+i-1)*b11d(i+1)
817 b11d(i+1) = rwork(iu1cs+i-1)*b11d(i+1) -
818 $ rwork(iu1sn+i-1)*b11e(i)
819 b11e(i) = temp
820 IF( i .LT. imax - 1 ) THEN
821 b11bulge = rwork(iu1sn+i-1)*b11e(i+1)
822 b11e(i+1) = rwork(iu1cs+i-1)*b11e(i+1)
823 END IF
824 temp = rwork(iu2cs+i-1)*b21e(i) + rwork(iu2sn+i-1)*b21d(i+1)
825 b21d(i+1) = rwork(iu2cs+i-1)*b21d(i+1) -
826 $ rwork(iu2sn+i-1)*b21e(i)
827 b21e(i) = temp
828 IF( i .LT. imax - 1 ) THEN
829 b21bulge = rwork(iu2sn+i-1)*b21e(i+1)
830 b21e(i+1) = rwork(iu2cs+i-1)*b21e(i+1)
831 END IF
832 temp = rwork(iu1cs+i-1)*b12d(i) + rwork(iu1sn+i-1)*b12e(i)
833 b12e(i) = rwork(iu1cs+i-1)*b12e(i) -
834 $ rwork(iu1sn+i-1)*b12d(i)
835 b12d(i) = temp
836 b12bulge = rwork(iu1sn+i-1)*b12d(i+1)
837 b12d(i+1) = rwork(iu1cs+i-1)*b12d(i+1)
838 temp = rwork(iu2cs+i-1)*b22d(i) + rwork(iu2sn+i-1)*b22e(i)
839 b22e(i) = rwork(iu2cs+i-1)*b22e(i) -
840 $ rwork(iu2sn+i-1)*b22d(i)
841 b22d(i) = temp
842 b22bulge = rwork(iu2sn+i-1)*b22d(i+1)
843 b22d(i+1) = rwork(iu2cs+i-1)*b22d(i+1)
844*
845 END DO
846*
847* Compute PHI(IMAX-1)
848*
849 x1 = sin(theta(imax-1))*b11e(imax-1) +
850 $ cos(theta(imax-1))*b21e(imax-1)
851 y1 = sin(theta(imax-1))*b12d(imax-1) +
852 $ cos(theta(imax-1))*b22d(imax-1)
853 y2 = sin(theta(imax-1))*b12bulge + cos(theta(imax-1))*b22bulge
854*
855 phi(imax-1) = atan2( abs(x1), sqrt(y1**2+y2**2) )
856*
857* Chase bulges from B12(IMAX-1,IMAX) and B22(IMAX-1,IMAX)
858*
859 restart12 = b12d(imax-1)**2 + b12bulge**2 .LE. thresh**2
860 restart22 = b22d(imax-1)**2 + b22bulge**2 .LE. thresh**2
861*
862 IF( .NOT. restart12 .AND. .NOT. restart22 ) THEN
863 CALL dlartgp( y2, y1, rwork(iv2tsn+imax-1-1),
864 $ rwork(iv2tcs+imax-1-1), r )
865 ELSE IF( .NOT. restart12 .AND. restart22 ) THEN
866 CALL dlartgp( b12bulge, b12d(imax-1),
867 $ rwork(iv2tsn+imax-1-1),
868 $ rwork(iv2tcs+imax-1-1), r )
869 ELSE IF( restart12 .AND. .NOT. restart22 ) THEN
870 CALL dlartgp( b22bulge, b22d(imax-1),
871 $ rwork(iv2tsn+imax-1-1),
872 $ rwork(iv2tcs+imax-1-1), r )
873 ELSE IF( nu .LT. mu ) THEN
874 CALL dlartgs( b12e(imax-1), b12d(imax), nu,
875 $ rwork(iv2tcs+imax-1-1),
876 $ rwork(iv2tsn+imax-1-1) )
877 ELSE
878 CALL dlartgs( b22e(imax-1), b22d(imax), mu,
879 $ rwork(iv2tcs+imax-1-1),
880 $ rwork(iv2tsn+imax-1-1) )
881 END IF
882*
883 temp = rwork(iv2tcs+imax-1-1)*b12e(imax-1) +
884 $ rwork(iv2tsn+imax-1-1)*b12d(imax)
885 b12d(imax) = rwork(iv2tcs+imax-1-1)*b12d(imax) -
886 $ rwork(iv2tsn+imax-1-1)*b12e(imax-1)
887 b12e(imax-1) = temp
888 temp = rwork(iv2tcs+imax-1-1)*b22e(imax-1) +
889 $ rwork(iv2tsn+imax-1-1)*b22d(imax)
890 b22d(imax) = rwork(iv2tcs+imax-1-1)*b22d(imax) -
891 $ rwork(iv2tsn+imax-1-1)*b22e(imax-1)
892 b22e(imax-1) = temp
893*
894* Update singular vectors
895*
896 IF( wantu1 ) THEN
897 IF( colmajor ) THEN
898 CALL zlasr( 'R', 'V', 'F', p, imax-imin+1,
899 $ rwork(iu1cs+imin-1), rwork(iu1sn+imin-1),
900 $ u1(1,imin), ldu1 )
901 ELSE
902 CALL zlasr( 'L', 'V', 'F', imax-imin+1, p,
903 $ rwork(iu1cs+imin-1), rwork(iu1sn+imin-1),
904 $ u1(imin,1), ldu1 )
905 END IF
906 END IF
907 IF( wantu2 ) THEN
908 IF( colmajor ) THEN
909 CALL zlasr( 'R', 'V', 'F', m-p, imax-imin+1,
910 $ rwork(iu2cs+imin-1), rwork(iu2sn+imin-1),
911 $ u2(1,imin), ldu2 )
912 ELSE
913 CALL zlasr( 'L', 'V', 'F', imax-imin+1, m-p,
914 $ rwork(iu2cs+imin-1), rwork(iu2sn+imin-1),
915 $ u2(imin,1), ldu2 )
916 END IF
917 END IF
918 IF( wantv1t ) THEN
919 IF( colmajor ) THEN
920 CALL zlasr( 'L', 'V', 'F', imax-imin+1, q,
921 $ rwork(iv1tcs+imin-1), rwork(iv1tsn+imin-1),
922 $ v1t(imin,1), ldv1t )
923 ELSE
924 CALL zlasr( 'R', 'V', 'F', q, imax-imin+1,
925 $ rwork(iv1tcs+imin-1), rwork(iv1tsn+imin-1),
926 $ v1t(1,imin), ldv1t )
927 END IF
928 END IF
929 IF( wantv2t ) THEN
930 IF( colmajor ) THEN
931 CALL zlasr( 'L', 'V', 'F', imax-imin+1, m-q,
932 $ rwork(iv2tcs+imin-1), rwork(iv2tsn+imin-1),
933 $ v2t(imin,1), ldv2t )
934 ELSE
935 CALL zlasr( 'R', 'V', 'F', m-q, imax-imin+1,
936 $ rwork(iv2tcs+imin-1), rwork(iv2tsn+imin-1),
937 $ v2t(1,imin), ldv2t )
938 END IF
939 END IF
940*
941* Fix signs on B11(IMAX-1,IMAX) and B21(IMAX-1,IMAX)
942*
943 IF( b11e(imax-1)+b21e(imax-1) .GT. 0 ) THEN
944 b11d(imax) = -b11d(imax)
945 b21d(imax) = -b21d(imax)
946 IF( wantv1t ) THEN
947 IF( colmajor ) THEN
948 CALL zscal( q, negonecomplex, v1t(imax,1), ldv1t )
949 ELSE
950 CALL zscal( q, negonecomplex, v1t(1,imax), 1 )
951 END IF
952 END IF
953 END IF
954*
955* Compute THETA(IMAX)
956*
957 x1 = cos(phi(imax-1))*b11d(imax) +
958 $ sin(phi(imax-1))*b12e(imax-1)
959 y1 = cos(phi(imax-1))*b21d(imax) +
960 $ sin(phi(imax-1))*b22e(imax-1)
961*
962 theta(imax) = atan2( abs(y1), abs(x1) )
963*
964* Fix signs on B11(IMAX,IMAX), B12(IMAX,IMAX-1), B21(IMAX,IMAX),
965* and B22(IMAX,IMAX-1)
966*
967 IF( b11d(imax)+b12e(imax-1) .LT. 0 ) THEN
968 b12d(imax) = -b12d(imax)
969 IF( wantu1 ) THEN
970 IF( colmajor ) THEN
971 CALL zscal( p, negonecomplex, u1(1,imax), 1 )
972 ELSE
973 CALL zscal( p, negonecomplex, u1(imax,1), ldu1 )
974 END IF
975 END IF
976 END IF
977 IF( b21d(imax)+b22e(imax-1) .GT. 0 ) THEN
978 b22d(imax) = -b22d(imax)
979 IF( wantu2 ) THEN
980 IF( colmajor ) THEN
981 CALL zscal( m-p, negonecomplex, u2(1,imax), 1 )
982 ELSE
983 CALL zscal( m-p, negonecomplex, u2(imax,1), ldu2 )
984 END IF
985 END IF
986 END IF
987*
988* Fix signs on B12(IMAX,IMAX) and B22(IMAX,IMAX)
989*
990 IF( b12d(imax)+b22d(imax) .LT. 0 ) THEN
991 IF( wantv2t ) THEN
992 IF( colmajor ) THEN
993 CALL zscal( m-q, negonecomplex, v2t(imax,1), ldv2t )
994 ELSE
995 CALL zscal( m-q, negonecomplex, v2t(1,imax), 1 )
996 END IF
997 END IF
998 END IF
999*
1000* Test for negligible sines or cosines
1001*
1002 DO i = imin, imax
1003 IF( theta(i) .LT. thresh ) THEN
1004 theta(i) = zero
1005 ELSE IF( theta(i) .GT. piover2-thresh ) THEN
1006 theta(i) = piover2
1007 END IF
1008 END DO
1009 DO i = imin, imax-1
1010 IF( phi(i) .LT. thresh ) THEN
1011 phi(i) = zero
1012 ELSE IF( phi(i) .GT. piover2-thresh ) THEN
1013 phi(i) = piover2
1014 END IF
1015 END DO
1016*
1017* Deflate
1018*
1019 IF (imax .GT. 1) THEN
1020 DO WHILE( phi(imax-1) .EQ. zero )
1021 imax = imax - 1
1022 IF (imax .LE. 1) EXIT
1023 END DO
1024 END IF
1025 IF( imin .GT. imax - 1 )
1026 $ imin = imax - 1
1027 IF (imin .GT. 1) THEN
1028 DO WHILE (phi(imin-1) .NE. zero)
1029 imin = imin - 1
1030 IF (imin .LE. 1) EXIT
1031 END DO
1032 END IF
1033*
1034* Repeat main iteration loop
1035*
1036 END DO
1037*
1038* Postprocessing: order THETA from least to greatest
1039*
1040 DO i = 1, q
1041*
1042 mini = i
1043 thetamin = theta(i)
1044 DO j = i+1, q
1045 IF( theta(j) .LT. thetamin ) THEN
1046 mini = j
1047 thetamin = theta(j)
1048 END IF
1049 END DO
1050*
1051 IF( mini .NE. i ) THEN
1052 theta(mini) = theta(i)
1053 theta(i) = thetamin
1054 IF( colmajor ) THEN
1055 IF( wantu1 )
1056 $ CALL zswap( p, u1(1,i), 1, u1(1,mini), 1 )
1057 IF( wantu2 )
1058 $ CALL zswap( m-p, u2(1,i), 1, u2(1,mini), 1 )
1059 IF( wantv1t )
1060 $ CALL zswap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t )
1061 IF( wantv2t )
1062 $ CALL zswap( m-q, v2t(i,1), ldv2t, v2t(mini,1),
1063 $ ldv2t )
1064 ELSE
1065 IF( wantu1 )
1066 $ CALL zswap( p, u1(i,1), ldu1, u1(mini,1), ldu1 )
1067 IF( wantu2 )
1068 $ CALL zswap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 )
1069 IF( wantv1t )
1070 $ CALL zswap( q, v1t(1,i), 1, v1t(1,mini), 1 )
1071 IF( wantv2t )
1072 $ CALL zswap( m-q, v2t(1,i), 1, v2t(1,mini), 1 )
1073 END IF
1074 END IF
1075*
1076 END DO
1077*
1078 RETURN
1079*
1080* End of ZBBCSD
1081*
dlas2
subroutine dlas2(f, g, h, ssmin, ssmax)
DLAS2 computes singular values of a 2-by-2 triangular matrix.
Definition dlas2.f:107
dlartgp
subroutine dlartgp(f, g, cs, sn, r)
DLARTGP generates a plane rotation so that the diagonal is nonnegative.
Definition dlartgp.f:95
dlartgs
subroutine dlartgs(x, y, sigma, cs, sn)
DLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bid...
Definition dlartgs.f:90
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
zlasr
subroutine zlasr(side, pivot, direct, m, n, c, s, a, lda)
ZLASR applies a sequence of plane rotations to a general rectangular matrix.
Definition zlasr.f:200
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
zscal
subroutine zscal(n, za, zx, incx)
ZSCAL
Definition zscal.f:78
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ zbdsqr()

subroutine zbdsqr ( character uplo,
integer n,
integer ncvt,
integer nru,
integer ncc,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldvt, * ) vt,
integer ldvt,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
integer info )

ZBDSQR

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

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

Definition at line 220 of file zbdsqr.f.

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

◆ zgghd3()

subroutine zgghd3 ( character compq,
character compz,
integer n,
integer ilo,
integer ihi,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldz, * ) z,
integer ldz,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZGGHD3

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

Purpose:
!>
!> ZGGHD3 reduces a pair of complex matrices (A,B) to generalized upper
!> Hessenberg form using unitary transformations, where A is a
!> general matrix and B is upper triangular.  The form of the
!> generalized eigenvalue problem is
!>    A*x = lambda*B*x,
!> and B is typically made upper triangular by computing its QR
!> factorization and moving the unitary matrix Q to the left side
!> of the equation.
!>
!> This subroutine simultaneously reduces A to a Hessenberg matrix H:
!>    Q**H*A*Z = H
!> and transforms B to another upper triangular matrix T:
!>    Q**H*B*Z = T
!> in order to reduce the problem to its standard form
!>    H*y = lambda*T*y
!> where y = Z**H*x.
!>
!> The unitary matrices Q and Z are determined as products of Givens
!> rotations.  They may either be formed explicitly, or they may be
!> postmultiplied into input matrices Q1 and Z1, so that
!>      Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H
!>      Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H
!> If Q1 is the unitary matrix from the QR factorization of B in the
!> original equation A*x = lambda*B*x, then ZGGHD3 reduces the original
!> problem to generalized Hessenberg form.
!>
!> This is a blocked variant of CGGHRD, using matrix-matrix
!> multiplications for parts of the computation to enhance performance.
!>
Parameters
[in]COMPQ
!>          COMPQ is CHARACTER*1
!>          = 'N': do not compute Q;
!>          = 'I': Q is initialized to the unit matrix, and the
!>                 unitary matrix Q is returned;
!>          = 'V': Q must contain a unitary matrix Q1 on entry,
!>                 and the product Q1*Q is returned.
!>
[in]COMPZ
!>          COMPZ is CHARACTER*1
!>          = 'N': do not compute Z;
!>          = 'I': Z is initialized to the unit matrix, and the
!>                 unitary matrix Z is returned;
!>          = 'V': Z must contain a unitary matrix Z1 on entry,
!>                 and the product Z1*Z is returned.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
!>          ILO and IHI mark the rows and columns of A which are to be
!>          reduced.  It is assumed that A is already upper triangular
!>          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are
!>          normally set by a previous call to ZGGBAL; otherwise they
!>          should be set to 1 and N respectively.
!>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          On entry, the N-by-N general matrix to be reduced.
!>          On exit, the upper triangle and the first subdiagonal of A
!>          are overwritten with the upper Hessenberg matrix H, and the
!>          rest is set to zero.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          On entry, the N-by-N upper triangular matrix B.
!>          On exit, the upper triangular matrix T = Q**H B Z.  The
!>          elements below the diagonal are set to zero.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the unitary matrix Q1, typically
!>          from the QR factorization of B.
!>          On exit, if COMPQ='I', the unitary matrix Q, and if
!>          COMPQ = 'V', the product Q1*Q.
!>          Not referenced if COMPQ='N'.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
!>
[in,out]Z
!>          Z is COMPLEX*16 array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the unitary matrix Z1.
!>          On exit, if COMPZ='I', the unitary matrix Z, and if
!>          COMPZ = 'V', the product Z1*Z.
!>          Not referenced if COMPZ='N'.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.
!>          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= 1.
!>          For optimum performance LWORK >= 6*N*NB, where NB is the
!>          optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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.
Further Details:
!>
!>  This routine reduces A to Hessenberg form and maintains B in triangular form
!>  using a blocked variant of Moler and Stewart's original algorithm,
!>  as described by Kagstrom, Kressner, Quintana-Orti, and Quintana-Orti
!>  (BIT 2008).
!>

Definition at line 225 of file zgghd3.f.

227*
228* -- LAPACK computational routine --
229* -- LAPACK is a software package provided by Univ. of Tennessee, --
230* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
231*
232 IMPLICIT NONE
233*
234* .. Scalar Arguments ..
235 CHARACTER COMPQ, COMPZ
236 INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK
237* ..
238* .. Array Arguments ..
239 COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
240 $ Z( LDZ, * ), WORK( * )
241* ..
242*
243* =====================================================================
244*
245* .. Parameters ..
246 COMPLEX*16 CONE, CZERO
247 parameter( cone = ( 1.0d+0, 0.0d+0 ),
248 $ czero = ( 0.0d+0, 0.0d+0 ) )
249* ..
250* .. Local Scalars ..
251 LOGICAL BLK22, INITQ, INITZ, LQUERY, WANTQ, WANTZ
252 CHARACTER*1 COMPQ2, COMPZ2
253 INTEGER COLA, I, IERR, J, J0, JCOL, JJ, JROW, K,
254 $ KACC22, LEN, LWKOPT, N2NB, NB, NBLST, NBMIN,
255 $ NH, NNB, NX, PPW, PPWO, PW, TOP, TOPQ
256 DOUBLE PRECISION C
257 COMPLEX*16 C1, C2, CTEMP, S, S1, S2, TEMP, TEMP1, TEMP2,
258 $ TEMP3
259* ..
260* .. External Functions ..
261 LOGICAL LSAME
262 INTEGER ILAENV
263 EXTERNAL ilaenv, lsame
264* ..
265* .. External Subroutines ..
266 EXTERNAL zgghrd, zlartg, zlaset, zunm22, zrot, zgemm,
267 $ zgemv, ztrmv, zlacpy, xerbla
268* ..
269* .. Intrinsic Functions ..
270 INTRINSIC dble, dcmplx, dconjg, max
271* ..
272* .. Executable Statements ..
273*
274* Decode and test the input parameters.
275*
276 info = 0
277 nb = ilaenv( 1, 'ZGGHD3', ' ', n, ilo, ihi, -1 )
278 lwkopt = max( 6*n*nb, 1 )
279 work( 1 ) = dcmplx( lwkopt )
280 initq = lsame( compq, 'I' )
281 wantq = initq .OR. lsame( compq, 'V' )
282 initz = lsame( compz, 'I' )
283 wantz = initz .OR. lsame( compz, 'V' )
284 lquery = ( lwork.EQ.-1 )
285*
286 IF( .NOT.lsame( compq, 'N' ) .AND. .NOT.wantq ) THEN
287 info = -1
288 ELSE IF( .NOT.lsame( compz, 'N' ) .AND. .NOT.wantz ) THEN
289 info = -2
290 ELSE IF( n.LT.0 ) THEN
291 info = -3
292 ELSE IF( ilo.LT.1 ) THEN
293 info = -4
294 ELSE IF( ihi.GT.n .OR. ihi.LT.ilo-1 ) THEN
295 info = -5
296 ELSE IF( lda.LT.max( 1, n ) ) THEN
297 info = -7
298 ELSE IF( ldb.LT.max( 1, n ) ) THEN
299 info = -9
300 ELSE IF( ( wantq .AND. ldq.LT.n ) .OR. ldq.LT.1 ) THEN
301 info = -11
302 ELSE IF( ( wantz .AND. ldz.LT.n ) .OR. ldz.LT.1 ) THEN
303 info = -13
304 ELSE IF( lwork.LT.1 .AND. .NOT.lquery ) THEN
305 info = -15
306 END IF
307 IF( info.NE.0 ) THEN
308 CALL xerbla( 'ZGGHD3', -info )
309 RETURN
310 ELSE IF( lquery ) THEN
311 RETURN
312 END IF
313*
314* Initialize Q and Z if desired.
315*
316 IF( initq )
317 $ CALL zlaset( 'All', n, n, czero, cone, q, ldq )
318 IF( initz )
319 $ CALL zlaset( 'All', n, n, czero, cone, z, ldz )
320*
321* Zero out lower triangle of B.
322*
323 IF( n.GT.1 )
324 $ CALL zlaset( 'Lower', n-1, n-1, czero, czero, b(2, 1), ldb )
325*
326* Quick return if possible
327*
328 nh = ihi - ilo + 1
329 IF( nh.LE.1 ) THEN
330 work( 1 ) = cone
331 RETURN
332 END IF
333*
334* Determine the blocksize.
335*
336 nbmin = ilaenv( 2, 'ZGGHD3', ' ', n, ilo, ihi, -1 )
337 IF( nb.GT.1 .AND. nb.LT.nh ) THEN
338*
339* Determine when to use unblocked instead of blocked code.
340*
341 nx = max( nb, ilaenv( 3, 'ZGGHD3', ' ', n, ilo, ihi, -1 ) )
342 IF( nx.LT.nh ) THEN
343*
344* Determine if workspace is large enough for blocked code.
345*
346 IF( lwork.LT.lwkopt ) THEN
347*
348* Not enough workspace to use optimal NB: determine the
349* minimum value of NB, and reduce NB or force use of
350* unblocked code.
351*
352 nbmin = max( 2, ilaenv( 2, 'ZGGHD3', ' ', n, ilo, ihi,
353 $ -1 ) )
354 IF( lwork.GE.6*n*nbmin ) THEN
355 nb = lwork / ( 6*n )
356 ELSE
357 nb = 1
358 END IF
359 END IF
360 END IF
361 END IF
362*
363 IF( nb.LT.nbmin .OR. nb.GE.nh ) THEN
364*
365* Use unblocked code below
366*
367 jcol = ilo
368*
369 ELSE
370*
371* Use blocked code
372*
373 kacc22 = ilaenv( 16, 'ZGGHD3', ' ', n, ilo, ihi, -1 )
374 blk22 = kacc22.EQ.2
375 DO jcol = ilo, ihi-2, nb
376 nnb = min( nb, ihi-jcol-1 )
377*
378* Initialize small unitary factors that will hold the
379* accumulated Givens rotations in workspace.
380* N2NB denotes the number of 2*NNB-by-2*NNB factors
381* NBLST denotes the (possibly smaller) order of the last
382* factor.
383*
384 n2nb = ( ihi-jcol-1 ) / nnb - 1
385 nblst = ihi - jcol - n2nb*nnb
386 CALL zlaset( 'All', nblst, nblst, czero, cone, work, nblst )
387 pw = nblst * nblst + 1
388 DO i = 1, n2nb
389 CALL zlaset( 'All', 2*nnb, 2*nnb, czero, cone,
390 $ work( pw ), 2*nnb )
391 pw = pw + 4*nnb*nnb
392 END DO
393*
394* Reduce columns JCOL:JCOL+NNB-1 of A to Hessenberg form.
395*
396 DO j = jcol, jcol+nnb-1
397*
398* Reduce Jth column of A. Store cosines and sines in Jth
399* column of A and B, respectively.
400*
401 DO i = ihi, j+2, -1
402 temp = a( i-1, j )
403 CALL zlartg( temp, a( i, j ), c, s, a( i-1, j ) )
404 a( i, j ) = dcmplx( c )
405 b( i, j ) = s
406 END DO
407*
408* Accumulate Givens rotations into workspace array.
409*
410 ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1
411 len = 2 + j - jcol
412 jrow = j + n2nb*nnb + 2
413 DO i = ihi, jrow, -1
414 ctemp = a( i, j )
415 s = b( i, j )
416 DO jj = ppw, ppw+len-1
417 temp = work( jj + nblst )
418 work( jj + nblst ) = ctemp*temp - s*work( jj )
419 work( jj ) = dconjg( s )*temp + ctemp*work( jj )
420 END DO
421 len = len + 1
422 ppw = ppw - nblst - 1
423 END DO
424*
425 ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb
426 j0 = jrow - nnb
427 DO jrow = j0, j+2, -nnb
428 ppw = ppwo
429 len = 2 + j - jcol
430 DO i = jrow+nnb-1, jrow, -1
431 ctemp = a( i, j )
432 s = b( i, j )
433 DO jj = ppw, ppw+len-1
434 temp = work( jj + 2*nnb )
435 work( jj + 2*nnb ) = ctemp*temp - s*work( jj )
436 work( jj ) = dconjg( s )*temp + ctemp*work( jj )
437 END DO
438 len = len + 1
439 ppw = ppw - 2*nnb - 1
440 END DO
441 ppwo = ppwo + 4*nnb*nnb
442 END DO
443*
444* TOP denotes the number of top rows in A and B that will
445* not be updated during the next steps.
446*
447 IF( jcol.LE.2 ) THEN
448 top = 0
449 ELSE
450 top = jcol
451 END IF
452*
453* Propagate transformations through B and replace stored
454* left sines/cosines by right sines/cosines.
455*
456 DO jj = n, j+1, -1
457*
458* Update JJth column of B.
459*
460 DO i = min( jj+1, ihi ), j+2, -1
461 ctemp = a( i, j )
462 s = b( i, j )
463 temp = b( i, jj )
464 b( i, jj ) = ctemp*temp - dconjg( s )*b( i-1, jj )
465 b( i-1, jj ) = s*temp + ctemp*b( i-1, jj )
466 END DO
467*
468* Annihilate B( JJ+1, JJ ).
469*
470 IF( jj.LT.ihi ) THEN
471 temp = b( jj+1, jj+1 )
472 CALL zlartg( temp, b( jj+1, jj ), c, s,
473 $ b( jj+1, jj+1 ) )
474 b( jj+1, jj ) = czero
475 CALL zrot( jj-top, b( top+1, jj+1 ), 1,
476 $ b( top+1, jj ), 1, c, s )
477 a( jj+1, j ) = dcmplx( c )
478 b( jj+1, j ) = -dconjg( s )
479 END IF
480 END DO
481*
482* Update A by transformations from right.
483*
484 jj = mod( ihi-j-1, 3 )
485 DO i = ihi-j-3, jj+1, -3
486 ctemp = a( j+1+i, j )
487 s = -b( j+1+i, j )
488 c1 = a( j+2+i, j )
489 s1 = -b( j+2+i, j )
490 c2 = a( j+3+i, j )
491 s2 = -b( j+3+i, j )
492*
493 DO k = top+1, ihi
494 temp = a( k, j+i )
495 temp1 = a( k, j+i+1 )
496 temp2 = a( k, j+i+2 )
497 temp3 = a( k, j+i+3 )
498 a( k, j+i+3 ) = c2*temp3 + dconjg( s2 )*temp2
499 temp2 = -s2*temp3 + c2*temp2
500 a( k, j+i+2 ) = c1*temp2 + dconjg( s1 )*temp1
501 temp1 = -s1*temp2 + c1*temp1
502 a( k, j+i+1 ) = ctemp*temp1 + dconjg( s )*temp
503 a( k, j+i ) = -s*temp1 + ctemp*temp
504 END DO
505 END DO
506*
507 IF( jj.GT.0 ) THEN
508 DO i = jj, 1, -1
509 c = dble( a( j+1+i, j ) )
510 CALL zrot( ihi-top, a( top+1, j+i+1 ), 1,
511 $ a( top+1, j+i ), 1, c,
512 $ -dconjg( b( j+1+i, j ) ) )
513 END DO
514 END IF
515*
516* Update (J+1)th column of A by transformations from left.
517*
518 IF ( j .LT. jcol + nnb - 1 ) THEN
519 len = 1 + j - jcol
520*
521* Multiply with the trailing accumulated unitary
522* matrix, which takes the form
523*
524* [ U11 U12 ]
525* U = [ ],
526* [ U21 U22 ]
527*
528* where U21 is a LEN-by-LEN matrix and U12 is lower
529* triangular.
530*
531 jrow = ihi - nblst + 1
532 CALL zgemv( 'Conjugate', nblst, len, cone, work,
533 $ nblst, a( jrow, j+1 ), 1, czero,
534 $ work( pw ), 1 )
535 ppw = pw + len
536 DO i = jrow, jrow+nblst-len-1
537 work( ppw ) = a( i, j+1 )
538 ppw = ppw + 1
539 END DO
540 CALL ztrmv( 'Lower', 'Conjugate', 'Non-unit',
541 $ nblst-len, work( len*nblst + 1 ), nblst,
542 $ work( pw+len ), 1 )
543 CALL zgemv( 'Conjugate', len, nblst-len, cone,
544 $ work( (len+1)*nblst - len + 1 ), nblst,
545 $ a( jrow+nblst-len, j+1 ), 1, cone,
546 $ work( pw+len ), 1 )
547 ppw = pw
548 DO i = jrow, jrow+nblst-1
549 a( i, j+1 ) = work( ppw )
550 ppw = ppw + 1
551 END DO
552*
553* Multiply with the other accumulated unitary
554* matrices, which take the form
555*
556* [ U11 U12 0 ]
557* [ ]
558* U = [ U21 U22 0 ],
559* [ ]
560* [ 0 0 I ]
561*
562* where I denotes the (NNB-LEN)-by-(NNB-LEN) identity
563* matrix, U21 is a LEN-by-LEN upper triangular matrix
564* and U12 is an NNB-by-NNB lower triangular matrix.
565*
566 ppwo = 1 + nblst*nblst
567 j0 = jrow - nnb
568 DO jrow = j0, jcol+1, -nnb
569 ppw = pw + len
570 DO i = jrow, jrow+nnb-1
571 work( ppw ) = a( i, j+1 )
572 ppw = ppw + 1
573 END DO
574 ppw = pw
575 DO i = jrow+nnb, jrow+nnb+len-1
576 work( ppw ) = a( i, j+1 )
577 ppw = ppw + 1
578 END DO
579 CALL ztrmv( 'Upper', 'Conjugate', 'Non-unit', len,
580 $ work( ppwo + nnb ), 2*nnb, work( pw ),
581 $ 1 )
582 CALL ztrmv( 'Lower', 'Conjugate', 'Non-unit', nnb,
583 $ work( ppwo + 2*len*nnb ),
584 $ 2*nnb, work( pw + len ), 1 )
585 CALL zgemv( 'Conjugate', nnb, len, cone,
586 $ work( ppwo ), 2*nnb, a( jrow, j+1 ), 1,
587 $ cone, work( pw ), 1 )
588 CALL zgemv( 'Conjugate', len, nnb, cone,
589 $ work( ppwo + 2*len*nnb + nnb ), 2*nnb,
590 $ a( jrow+nnb, j+1 ), 1, cone,
591 $ work( pw+len ), 1 )
592 ppw = pw
593 DO i = jrow, jrow+len+nnb-1
594 a( i, j+1 ) = work( ppw )
595 ppw = ppw + 1
596 END DO
597 ppwo = ppwo + 4*nnb*nnb
598 END DO
599 END IF
600 END DO
601*
602* Apply accumulated unitary matrices to A.
603*
604 cola = n - jcol - nnb + 1
605 j = ihi - nblst + 1
606 CALL zgemm( 'Conjugate', 'No Transpose', nblst,
607 $ cola, nblst, cone, work, nblst,
608 $ a( j, jcol+nnb ), lda, czero, work( pw ),
609 $ nblst )
610 CALL zlacpy( 'All', nblst, cola, work( pw ), nblst,
611 $ a( j, jcol+nnb ), lda )
612 ppwo = nblst*nblst + 1
613 j0 = j - nnb
614 DO j = j0, jcol+1, -nnb
615 IF ( blk22 ) THEN
616*
617* Exploit the structure of
618*
619* [ U11 U12 ]
620* U = [ ]
621* [ U21 U22 ],
622*
623* where all blocks are NNB-by-NNB, U21 is upper
624* triangular and U12 is lower triangular.
625*
626 CALL zunm22( 'Left', 'Conjugate', 2*nnb, cola, nnb,
627 $ nnb, work( ppwo ), 2*nnb,
628 $ a( j, jcol+nnb ), lda, work( pw ),
629 $ lwork-pw+1, ierr )
630 ELSE
631*
632* Ignore the structure of U.
633*
634 CALL zgemm( 'Conjugate', 'No Transpose', 2*nnb,
635 $ cola, 2*nnb, cone, work( ppwo ), 2*nnb,
636 $ a( j, jcol+nnb ), lda, czero, work( pw ),
637 $ 2*nnb )
638 CALL zlacpy( 'All', 2*nnb, cola, work( pw ), 2*nnb,
639 $ a( j, jcol+nnb ), lda )
640 END IF
641 ppwo = ppwo + 4*nnb*nnb
642 END DO
643*
644* Apply accumulated unitary matrices to Q.
645*
646 IF( wantq ) THEN
647 j = ihi - nblst + 1
648 IF ( initq ) THEN
649 topq = max( 2, j - jcol + 1 )
650 nh = ihi - topq + 1
651 ELSE
652 topq = 1
653 nh = n
654 END IF
655 CALL zgemm( 'No Transpose', 'No Transpose', nh,
656 $ nblst, nblst, cone, q( topq, j ), ldq,
657 $ work, nblst, czero, work( pw ), nh )
658 CALL zlacpy( 'All', nh, nblst, work( pw ), nh,
659 $ q( topq, j ), ldq )
660 ppwo = nblst*nblst + 1
661 j0 = j - nnb
662 DO j = j0, jcol+1, -nnb
663 IF ( initq ) THEN
664 topq = max( 2, j - jcol + 1 )
665 nh = ihi - topq + 1
666 END IF
667 IF ( blk22 ) THEN
668*
669* Exploit the structure of U.
670*
671 CALL zunm22( 'Right', 'No Transpose', nh, 2*nnb,
672 $ nnb, nnb, work( ppwo ), 2*nnb,
673 $ q( topq, j ), ldq, work( pw ),
674 $ lwork-pw+1, ierr )
675 ELSE
676*
677* Ignore the structure of U.
678*
679 CALL zgemm( 'No Transpose', 'No Transpose', nh,
680 $ 2*nnb, 2*nnb, cone, q( topq, j ), ldq,
681 $ work( ppwo ), 2*nnb, czero, work( pw ),
682 $ nh )
683 CALL zlacpy( 'All', nh, 2*nnb, work( pw ), nh,
684 $ q( topq, j ), ldq )
685 END IF
686 ppwo = ppwo + 4*nnb*nnb
687 END DO
688 END IF
689*
690* Accumulate right Givens rotations if required.
691*
692 IF ( wantz .OR. top.GT.0 ) THEN
693*
694* Initialize small unitary factors that will hold the
695* accumulated Givens rotations in workspace.
696*
697 CALL zlaset( 'All', nblst, nblst, czero, cone, work,
698 $ nblst )
699 pw = nblst * nblst + 1
700 DO i = 1, n2nb
701 CALL zlaset( 'All', 2*nnb, 2*nnb, czero, cone,
702 $ work( pw ), 2*nnb )
703 pw = pw + 4*nnb*nnb
704 END DO
705*
706* Accumulate Givens rotations into workspace array.
707*
708 DO j = jcol, jcol+nnb-1
709 ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1
710 len = 2 + j - jcol
711 jrow = j + n2nb*nnb + 2
712 DO i = ihi, jrow, -1
713 ctemp = a( i, j )
714 a( i, j ) = czero
715 s = b( i, j )
716 b( i, j ) = czero
717 DO jj = ppw, ppw+len-1
718 temp = work( jj + nblst )
719 work( jj + nblst ) = ctemp*temp -
720 $ dconjg( s )*work( jj )
721 work( jj ) = s*temp + ctemp*work( jj )
722 END DO
723 len = len + 1
724 ppw = ppw - nblst - 1
725 END DO
726*
727 ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb
728 j0 = jrow - nnb
729 DO jrow = j0, j+2, -nnb
730 ppw = ppwo
731 len = 2 + j - jcol
732 DO i = jrow+nnb-1, jrow, -1
733 ctemp = a( i, j )
734 a( i, j ) = czero
735 s = b( i, j )
736 b( i, j ) = czero
737 DO jj = ppw, ppw+len-1
738 temp = work( jj + 2*nnb )
739 work( jj + 2*nnb ) = ctemp*temp -
740 $ dconjg( s )*work( jj )
741 work( jj ) = s*temp + ctemp*work( jj )
742 END DO
743 len = len + 1
744 ppw = ppw - 2*nnb - 1
745 END DO
746 ppwo = ppwo + 4*nnb*nnb
747 END DO
748 END DO
749 ELSE
750*
751 CALL zlaset( 'Lower', ihi - jcol - 1, nnb, czero, czero,
752 $ a( jcol + 2, jcol ), lda )
753 CALL zlaset( 'Lower', ihi - jcol - 1, nnb, czero, czero,
754 $ b( jcol + 2, jcol ), ldb )
755 END IF
756*
757* Apply accumulated unitary matrices to A and B.
758*
759 IF ( top.GT.0 ) THEN
760 j = ihi - nblst + 1
761 CALL zgemm( 'No Transpose', 'No Transpose', top,
762 $ nblst, nblst, cone, a( 1, j ), lda,
763 $ work, nblst, czero, work( pw ), top )
764 CALL zlacpy( 'All', top, nblst, work( pw ), top,
765 $ a( 1, j ), lda )
766 ppwo = nblst*nblst + 1
767 j0 = j - nnb
768 DO j = j0, jcol+1, -nnb
769 IF ( blk22 ) THEN
770*
771* Exploit the structure of U.
772*
773 CALL zunm22( 'Right', 'No Transpose', top, 2*nnb,
774 $ nnb, nnb, work( ppwo ), 2*nnb,
775 $ a( 1, j ), lda, work( pw ),
776 $ lwork-pw+1, ierr )
777 ELSE
778*
779* Ignore the structure of U.
780*
781 CALL zgemm( 'No Transpose', 'No Transpose', top,
782 $ 2*nnb, 2*nnb, cone, a( 1, j ), lda,
783 $ work( ppwo ), 2*nnb, czero,
784 $ work( pw ), top )
785 CALL zlacpy( 'All', top, 2*nnb, work( pw ), top,
786 $ a( 1, j ), lda )
787 END IF
788 ppwo = ppwo + 4*nnb*nnb
789 END DO
790*
791 j = ihi - nblst + 1
792 CALL zgemm( 'No Transpose', 'No Transpose', top,
793 $ nblst, nblst, cone, b( 1, j ), ldb,
794 $ work, nblst, czero, work( pw ), top )
795 CALL zlacpy( 'All', top, nblst, work( pw ), top,
796 $ b( 1, j ), ldb )
797 ppwo = nblst*nblst + 1
798 j0 = j - nnb
799 DO j = j0, jcol+1, -nnb
800 IF ( blk22 ) THEN
801*
802* Exploit the structure of U.
803*
804 CALL zunm22( 'Right', 'No Transpose', top, 2*nnb,
805 $ nnb, nnb, work( ppwo ), 2*nnb,
806 $ b( 1, j ), ldb, work( pw ),
807 $ lwork-pw+1, ierr )
808 ELSE
809*
810* Ignore the structure of U.
811*
812 CALL zgemm( 'No Transpose', 'No Transpose', top,
813 $ 2*nnb, 2*nnb, cone, b( 1, j ), ldb,
814 $ work( ppwo ), 2*nnb, czero,
815 $ work( pw ), top )
816 CALL zlacpy( 'All', top, 2*nnb, work( pw ), top,
817 $ b( 1, j ), ldb )
818 END IF
819 ppwo = ppwo + 4*nnb*nnb
820 END DO
821 END IF
822*
823* Apply accumulated unitary matrices to Z.
824*
825 IF( wantz ) THEN
826 j = ihi - nblst + 1
827 IF ( initq ) THEN
828 topq = max( 2, j - jcol + 1 )
829 nh = ihi - topq + 1
830 ELSE
831 topq = 1
832 nh = n
833 END IF
834 CALL zgemm( 'No Transpose', 'No Transpose', nh,
835 $ nblst, nblst, cone, z( topq, j ), ldz,
836 $ work, nblst, czero, work( pw ), nh )
837 CALL zlacpy( 'All', nh, nblst, work( pw ), nh,
838 $ z( topq, j ), ldz )
839 ppwo = nblst*nblst + 1
840 j0 = j - nnb
841 DO j = j0, jcol+1, -nnb
842 IF ( initq ) THEN
843 topq = max( 2, j - jcol + 1 )
844 nh = ihi - topq + 1
845 END IF
846 IF ( blk22 ) THEN
847*
848* Exploit the structure of U.
849*
850 CALL zunm22( 'Right', 'No Transpose', nh, 2*nnb,
851 $ nnb, nnb, work( ppwo ), 2*nnb,
852 $ z( topq, j ), ldz, work( pw ),
853 $ lwork-pw+1, ierr )
854 ELSE
855*
856* Ignore the structure of U.
857*
858 CALL zgemm( 'No Transpose', 'No Transpose', nh,
859 $ 2*nnb, 2*nnb, cone, z( topq, j ), ldz,
860 $ work( ppwo ), 2*nnb, czero, work( pw ),
861 $ nh )
862 CALL zlacpy( 'All', nh, 2*nnb, work( pw ), nh,
863 $ z( topq, j ), ldz )
864 END IF
865 ppwo = ppwo + 4*nnb*nnb
866 END DO
867 END IF
868 END DO
869 END IF
870*
871* Use unblocked code to reduce the rest of the matrix
872* Avoid re-initialization of modified Q and Z.
873*
874 compq2 = compq
875 compz2 = compz
876 IF ( jcol.NE.ilo ) THEN
877 IF ( wantq )
878 $ compq2 = 'V'
879 IF ( wantz )
880 $ compz2 = 'V'
881 END IF
882*
883 IF ( jcol.LT.ihi )
884 $ CALL zgghrd( compq2, compz2, n, jcol, ihi, a, lda, b, ldb, q,
885 $ ldq, z, ldz, ierr )
886 work( 1 ) = dcmplx( lwkopt )
887*
888 RETURN
889*
890* End of ZGGHD3
891*
zlartg
subroutine zlartg(f, g, c, s, r)
ZLARTG generates a plane rotation with real cosine and complex sine.
Definition zlartg.f90:118
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
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
zrot
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.
Definition zrot.f:103
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
zgghrd
subroutine zgghrd(compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, info)
ZGGHRD
Definition zgghrd.f:204
ztrmv
subroutine ztrmv(uplo, trans, diag, n, a, lda, x, incx)
ZTRMV
Definition ztrmv.f:147
zgemv
subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
ZGEMV
Definition zgemv.f:158
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187
zunm22
subroutine zunm22(side, trans, m, n, n1, n2, q, ldq, c, ldc, work, lwork, info)
ZUNM22 multiplies a general matrix by a banded unitary matrix.
Definition zunm22.f:162

◆ zgghrd()

subroutine zgghrd ( character compq,
character compz,
integer n,
integer ilo,
integer ihi,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldz, * ) z,
integer ldz,
integer info )

ZGGHRD

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

Purpose:
!>
!> ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper
!> Hessenberg form using unitary transformations, where A is a
!> general matrix and B is upper triangular.  The form of the
!> generalized eigenvalue problem is
!>    A*x = lambda*B*x,
!> and B is typically made upper triangular by computing its QR
!> factorization and moving the unitary matrix Q to the left side
!> of the equation.
!>
!> This subroutine simultaneously reduces A to a Hessenberg matrix H:
!>    Q**H*A*Z = H
!> and transforms B to another upper triangular matrix T:
!>    Q**H*B*Z = T
!> in order to reduce the problem to its standard form
!>    H*y = lambda*T*y
!> where y = Z**H*x.
!>
!> The unitary matrices Q and Z are determined as products of Givens
!> rotations.  They may either be formed explicitly, or they may be
!> postmultiplied into input matrices Q1 and Z1, so that
!>      Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H
!>      Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H
!> If Q1 is the unitary matrix from the QR factorization of B in the
!> original equation A*x = lambda*B*x, then ZGGHRD reduces the original
!> problem to generalized Hessenberg form.
!>
Parameters
[in]COMPQ
!>          COMPQ is CHARACTER*1
!>          = 'N': do not compute Q;
!>          = 'I': Q is initialized to the unit matrix, and the
!>                 unitary matrix Q is returned;
!>          = 'V': Q must contain a unitary matrix Q1 on entry,
!>                 and the product Q1*Q is returned.
!>
[in]COMPZ
!>          COMPZ is CHARACTER*1
!>          = 'N': do not compute Z;
!>          = 'I': Z is initialized to the unit matrix, and the
!>                 unitary matrix Z is returned;
!>          = 'V': Z must contain a unitary matrix Z1 on entry,
!>                 and the product Z1*Z is returned.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
!>          ILO and IHI mark the rows and columns of A which are to be
!>          reduced.  It is assumed that A is already upper triangular
!>          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are
!>          normally set by a previous call to ZGGBAL; otherwise they
!>          should be set to 1 and N respectively.
!>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          On entry, the N-by-N general matrix to be reduced.
!>          On exit, the upper triangle and the first subdiagonal of A
!>          are overwritten with the upper Hessenberg matrix H, and the
!>          rest is set to zero.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          On entry, the N-by-N upper triangular matrix B.
!>          On exit, the upper triangular matrix T = Q**H B Z.  The
!>          elements below the diagonal are set to zero.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the unitary matrix Q1, typically
!>          from the QR factorization of B.
!>          On exit, if COMPQ='I', the unitary matrix Q, and if
!>          COMPQ = 'V', the product Q1*Q.
!>          Not referenced if COMPQ='N'.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
!>
[in,out]Z
!>          Z is COMPLEX*16 array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the unitary matrix Z1.
!>          On exit, if COMPZ='I', the unitary matrix Z, and if
!>          COMPZ = 'V', the product Z1*Z.
!>          Not referenced if COMPZ='N'.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.
!>          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
!>
[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.
Further Details:
!>
!>  This routine reduces A to Hessenberg and B to triangular form by
!>  an unblocked reduction, as described in _Matrix_Computations_,
!>  by Golub and van Loan (Johns Hopkins Press).
!>

Definition at line 202 of file zgghrd.f.

204*
205* -- LAPACK computational routine --
206* -- LAPACK is a software package provided by Univ. of Tennessee, --
207* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
208*
209* .. Scalar Arguments ..
210 CHARACTER COMPQ, COMPZ
211 INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
212* ..
213* .. Array Arguments ..
214 COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
215 $ Z( LDZ, * )
216* ..
217*
218* =====================================================================
219*
220* .. Parameters ..
221 COMPLEX*16 CONE, CZERO
222 parameter( cone = ( 1.0d+0, 0.0d+0 ),
223 $ czero = ( 0.0d+0, 0.0d+0 ) )
224* ..
225* .. Local Scalars ..
226 LOGICAL ILQ, ILZ
227 INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
228 DOUBLE PRECISION C
229 COMPLEX*16 CTEMP, S
230* ..
231* .. External Functions ..
232 LOGICAL LSAME
233 EXTERNAL lsame
234* ..
235* .. External Subroutines ..
236 EXTERNAL xerbla, zlartg, zlaset, zrot
237* ..
238* .. Intrinsic Functions ..
239 INTRINSIC dconjg, max
240* ..
241* .. Executable Statements ..
242*
243* Decode COMPQ
244*
245 IF( lsame( compq, 'N' ) ) THEN
246 ilq = .false.
247 icompq = 1
248 ELSE IF( lsame( compq, 'V' ) ) THEN
249 ilq = .true.
250 icompq = 2
251 ELSE IF( lsame( compq, 'I' ) ) THEN
252 ilq = .true.
253 icompq = 3
254 ELSE
255 icompq = 0
256 END IF
257*
258* Decode COMPZ
259*
260 IF( lsame( compz, 'N' ) ) THEN
261 ilz = .false.
262 icompz = 1
263 ELSE IF( lsame( compz, 'V' ) ) THEN
264 ilz = .true.
265 icompz = 2
266 ELSE IF( lsame( compz, 'I' ) ) THEN
267 ilz = .true.
268 icompz = 3
269 ELSE
270 icompz = 0
271 END IF
272*
273* Test the input parameters.
274*
275 info = 0
276 IF( icompq.LE.0 ) THEN
277 info = -1
278 ELSE IF( icompz.LE.0 ) THEN
279 info = -2
280 ELSE IF( n.LT.0 ) THEN
281 info = -3
282 ELSE IF( ilo.LT.1 ) THEN
283 info = -4
284 ELSE IF( ihi.GT.n .OR. ihi.LT.ilo-1 ) THEN
285 info = -5
286 ELSE IF( lda.LT.max( 1, n ) ) THEN
287 info = -7
288 ELSE IF( ldb.LT.max( 1, n ) ) THEN
289 info = -9
290 ELSE IF( ( ilq .AND. ldq.LT.n ) .OR. ldq.LT.1 ) THEN
291 info = -11
292 ELSE IF( ( ilz .AND. ldz.LT.n ) .OR. ldz.LT.1 ) THEN
293 info = -13
294 END IF
295 IF( info.NE.0 ) THEN
296 CALL xerbla( 'ZGGHRD', -info )
297 RETURN
298 END IF
299*
300* Initialize Q and Z if desired.
301*
302 IF( icompq.EQ.3 )
303 $ CALL zlaset( 'Full', n, n, czero, cone, q, ldq )
304 IF( icompz.EQ.3 )
305 $ CALL zlaset( 'Full', n, n, czero, cone, z, ldz )
306*
307* Quick return if possible
308*
309 IF( n.LE.1 )
310 $ RETURN
311*
312* Zero out lower triangle of B
313*
314 DO 20 jcol = 1, n - 1
315 DO 10 jrow = jcol + 1, n
316 b( jrow, jcol ) = czero
317 10 CONTINUE
318 20 CONTINUE
319*
320* Reduce A and B
321*
322 DO 40 jcol = ilo, ihi - 2
323*
324 DO 30 jrow = ihi, jcol + 2, -1
325*
326* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
327*
328 ctemp = a( jrow-1, jcol )
329 CALL zlartg( ctemp, a( jrow, jcol ), c, s,
330 $ a( jrow-1, jcol ) )
331 a( jrow, jcol ) = czero
332 CALL zrot( n-jcol, a( jrow-1, jcol+1 ), lda,
333 $ a( jrow, jcol+1 ), lda, c, s )
334 CALL zrot( n+2-jrow, b( jrow-1, jrow-1 ), ldb,
335 $ b( jrow, jrow-1 ), ldb, c, s )
336 IF( ilq )
337 $ CALL zrot( n, q( 1, jrow-1 ), 1, q( 1, jrow ), 1, c,
338 $ dconjg( s ) )
339*
340* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
341*
342 ctemp = b( jrow, jrow )
343 CALL zlartg( ctemp, b( jrow, jrow-1 ), c, s,
344 $ b( jrow, jrow ) )
345 b( jrow, jrow-1 ) = czero
346 CALL zrot( ihi, a( 1, jrow ), 1, a( 1, jrow-1 ), 1, c, s )
347 CALL zrot( jrow-1, b( 1, jrow ), 1, b( 1, jrow-1 ), 1, c,
348 $ s )
349 IF( ilz )
350 $ CALL zrot( n, z( 1, jrow ), 1, z( 1, jrow-1 ), 1, c, s )
351 30 CONTINUE
352 40 CONTINUE
353*
354 RETURN
355*
356* End of ZGGHRD
357*

◆ zggqrf()

subroutine zggqrf ( integer n,
integer m,
integer p,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) taua,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( * ) taub,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZGGQRF

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

Purpose:
!>
!> ZGGQRF computes a generalized QR factorization of an N-by-M matrix A
!> and an N-by-P matrix B:
!>
!>             A = Q*R,        B = Q*T*Z,
!>
!> where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,
!> and R and T assume one of the forms:
!>
!> if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,
!>                 (  0  ) N-M                         N   M-N
!>                    M
!>
!> where R11 is upper triangular, and
!>
!> if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,
!>                  P-N  N                           ( T21 ) P
!>                                                      P
!>
!> where T12 or T21 is upper triangular.
!>
!> In particular, if B is square and nonsingular, the GQR factorization
!> of A and B implicitly gives the QR factorization of inv(B)*A:
!>
!>              inv(B)*A = Z**H * (inv(T)*R)
!>
!> where inv(B) denotes the inverse of the matrix B, and Z**H denotes the
!> conjugate transpose of matrix Z.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices A and B. N >= 0.
!>
[in]M
!>          M is INTEGER
!>          The number of columns of the matrix A.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of columns of the matrix B.  P >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,M)
!>          On entry, the N-by-M matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(N,M)-by-M upper trapezoidal matrix R (R is
!>          upper triangular if N >= M); the elements below the diagonal,
!>          with the array TAUA, represent the unitary matrix Q as a
!>          product of min(N,M) elementary reflectors (see Further
!>          Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!>
[out]TAUA
!>          TAUA is COMPLEX*16 array, dimension (min(N,M))
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix Q (see Further Details).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,P)
!>          On entry, the N-by-P matrix B.
!>          On exit, if N <= P, the upper triangle of the subarray
!>          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
!>          if N > P, the elements on and above the (N-P)-th subdiagonal
!>          contain the N-by-P upper trapezoidal matrix T; the remaining
!>          elements, with the array TAUB, represent the unitary
!>          matrix Z as a product of elementary reflectors (see Further
!>          Details).
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!>
[out]TAUB
!>          TAUB is COMPLEX*16 array, dimension (min(N,P))
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix Z (see Further Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,N,M,P).
!>          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
!>          where NB1 is the optimal blocksize for the QR factorization
!>          of an N-by-M matrix, NB2 is the optimal blocksize for the
!>          RQ factorization of an N-by-P matrix, and NB3 is the optimal
!>          blocksize for a call of ZUNMQR.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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.
Further Details:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = min(n,m).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - taua * v * v**H
!>
!>  where taua is a complex scalar, and v is a complex vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
!>  and taua in TAUA(i).
!>  To form Q explicitly, use LAPACK subroutine ZUNGQR.
!>  To use Q to update another matrix, use LAPACK subroutine ZUNMQR.
!>
!>  The matrix Z is represented as a product of elementary reflectors
!>
!>     Z = H(1) H(2) . . . H(k), where k = min(n,p).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - taub * v * v**H
!>
!>  where taub is a complex scalar, and v is a complex vector with
!>  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
!>  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
!>  To form Z explicitly, use LAPACK subroutine ZUNGRQ.
!>  To use Z to update another matrix, use LAPACK subroutine ZUNMRQ.
!>

Definition at line 213 of file zggqrf.f.

215*
216* -- LAPACK computational routine --
217* -- LAPACK is a software package provided by Univ. of Tennessee, --
218* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
219*
220* .. Scalar Arguments ..
221 INTEGER INFO, LDA, LDB, LWORK, M, N, P
222* ..
223* .. Array Arguments ..
224 COMPLEX*16 A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
225 $ WORK( * )
226* ..
227*
228* =====================================================================
229*
230* .. Local Scalars ..
231 LOGICAL LQUERY
232 INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
233* ..
234* .. External Subroutines ..
235 EXTERNAL xerbla, zgeqrf, zgerqf, zunmqr
236* ..
237* .. External Functions ..
238 INTEGER ILAENV
239 EXTERNAL ilaenv
240* ..
241* .. Intrinsic Functions ..
242 INTRINSIC int, max, min
243* ..
244* .. Executable Statements ..
245*
246* Test the input parameters
247*
248 info = 0
249 nb1 = ilaenv( 1, 'ZGEQRF', ' ', n, m, -1, -1 )
250 nb2 = ilaenv( 1, 'ZGERQF', ' ', n, p, -1, -1 )
251 nb3 = ilaenv( 1, 'ZUNMQR', ' ', n, m, p, -1 )
252 nb = max( nb1, nb2, nb3 )
253 lwkopt = max( n, m, p )*nb
254 work( 1 ) = lwkopt
255 lquery = ( lwork.EQ.-1 )
256 IF( n.LT.0 ) THEN
257 info = -1
258 ELSE IF( m.LT.0 ) THEN
259 info = -2
260 ELSE IF( p.LT.0 ) THEN
261 info = -3
262 ELSE IF( lda.LT.max( 1, n ) ) THEN
263 info = -5
264 ELSE IF( ldb.LT.max( 1, n ) ) THEN
265 info = -8
266 ELSE IF( lwork.LT.max( 1, n, m, p ) .AND. .NOT.lquery ) THEN
267 info = -11
268 END IF
269 IF( info.NE.0 ) THEN
270 CALL xerbla( 'ZGGQRF', -info )
271 RETURN
272 ELSE IF( lquery ) THEN
273 RETURN
274 END IF
275*
276* QR factorization of N-by-M matrix A: A = Q*R
277*
278 CALL zgeqrf( n, m, a, lda, taua, work, lwork, info )
279 lopt = dble( work( 1 ) )
280*
281* Update B := Q**H*B.
282*
283 CALL zunmqr( 'Left', 'Conjugate Transpose', n, p, min( n, m ), a,
284 $ lda, taua, b, ldb, work, lwork, info )
285 lopt = max( lopt, int( work( 1 ) ) )
286*
287* RQ factorization of N-by-P matrix B: B = T*Z.
288*
289 CALL zgerqf( n, p, b, ldb, taub, work, lwork, info )
290 work( 1 ) = max( lopt, int( work( 1 ) ) )
291*
292 RETURN
293*
294* End of ZGGQRF
295*
zgerqf
subroutine zgerqf(m, n, a, lda, tau, work, lwork, info)
ZGERQF
Definition zgerqf.f:139
zunmqr
subroutine zunmqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMQR
Definition zunmqr.f:167
zgeqrf
subroutine zgeqrf(m, n, a, lda, tau, work, lwork, info)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
Definition zgeqrf.f:151

◆ zggrqf()

subroutine zggrqf ( integer m,
integer p,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) taua,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( * ) taub,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZGGRQF

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

Purpose:
!>
!> ZGGRQF computes a generalized RQ factorization of an M-by-N matrix A
!> and a P-by-N matrix B:
!>
!>             A = R*Q,        B = Z*T*Q,
!>
!> where Q is an N-by-N unitary matrix, Z is a P-by-P unitary
!> matrix, and R and T assume one of the forms:
!>
!> if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,
!>                  N-M  M                           ( R21 ) N
!>                                                      N
!>
!> where R12 or R21 is upper triangular, and
!>
!> if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,
!>                 (  0  ) P-N                         P   N-P
!>                    N
!>
!> where T11 is upper triangular.
!>
!> In particular, if B is square and nonsingular, the GRQ factorization
!> of A and B implicitly gives the RQ factorization of A*inv(B):
!>
!>              A*inv(B) = (R*inv(T))*Z**H
!>
!> where inv(B) denotes the inverse of the matrix B, and Z**H denotes the
!> conjugate transpose of the matrix Z.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of rows of the matrix B.  P >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and B. N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, if M <= N, the upper triangle of the subarray
!>          A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
!>          if M > N, the elements on and above the (M-N)-th subdiagonal
!>          contain the M-by-N upper trapezoidal matrix R; the remaining
!>          elements, with the array TAUA, 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,M).
!>
[out]TAUA
!>          TAUA is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix Q (see Further Details).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          On entry, the P-by-N matrix B.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(P,N)-by-N upper trapezoidal matrix T (T is
!>          upper triangular if P >= N); the elements below the diagonal,
!>          with the array TAUB, represent the unitary matrix Z as a
!>          product of elementary reflectors (see Further Details).
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,P).
!>
[out]TAUB
!>          TAUB is COMPLEX*16 array, dimension (min(P,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix Z (see Further Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,N,M,P).
!>          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
!>          where NB1 is the optimal blocksize for the RQ factorization
!>          of an M-by-N matrix, NB2 is the optimal blocksize for the
!>          QR factorization of a P-by-N matrix, and NB3 is the optimal
!>          blocksize for a call of ZUNMRQ.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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.
Further Details:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - taua * v * v**H
!>
!>  where taua is a complex scalar, and v is a complex vector with
!>  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
!>  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
!>  To form Q explicitly, use LAPACK subroutine ZUNGRQ.
!>  To use Q to update another matrix, use LAPACK subroutine ZUNMRQ.
!>
!>  The matrix Z is represented as a product of elementary reflectors
!>
!>     Z = H(1) H(2) . . . H(k), where k = min(p,n).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - taub * v * v**H
!>
!>  where taub is a complex scalar, and v is a complex vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
!>  and taub in TAUB(i).
!>  To form Z explicitly, use LAPACK subroutine ZUNGQR.
!>  To use Z to update another matrix, use LAPACK subroutine ZUNMQR.
!>

Definition at line 212 of file zggrqf.f.

214*
215* -- LAPACK computational routine --
216* -- LAPACK is a software package provided by Univ. of Tennessee, --
217* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
218*
219* .. Scalar Arguments ..
220 INTEGER INFO, LDA, LDB, LWORK, M, N, P
221* ..
222* .. Array Arguments ..
223 COMPLEX*16 A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
224 $ WORK( * )
225* ..
226*
227* =====================================================================
228*
229* .. Local Scalars ..
230 LOGICAL LQUERY
231 INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
232* ..
233* .. External Subroutines ..
234 EXTERNAL xerbla, zgeqrf, zgerqf, zunmrq
235* ..
236* .. External Functions ..
237 INTEGER ILAENV
238 EXTERNAL ilaenv
239* ..
240* .. Intrinsic Functions ..
241 INTRINSIC int, max, min
242* ..
243* .. Executable Statements ..
244*
245* Test the input parameters
246*
247 info = 0
248 nb1 = ilaenv( 1, 'ZGERQF', ' ', m, n, -1, -1 )
249 nb2 = ilaenv( 1, 'ZGEQRF', ' ', p, n, -1, -1 )
250 nb3 = ilaenv( 1, 'ZUNMRQ', ' ', m, n, p, -1 )
251 nb = max( nb1, nb2, nb3 )
252 lwkopt = max( n, m, p )*nb
253 work( 1 ) = lwkopt
254 lquery = ( lwork.EQ.-1 )
255 IF( m.LT.0 ) THEN
256 info = -1
257 ELSE IF( p.LT.0 ) THEN
258 info = -2
259 ELSE IF( n.LT.0 ) THEN
260 info = -3
261 ELSE IF( lda.LT.max( 1, m ) ) THEN
262 info = -5
263 ELSE IF( ldb.LT.max( 1, p ) ) THEN
264 info = -8
265 ELSE IF( lwork.LT.max( 1, m, p, n ) .AND. .NOT.lquery ) THEN
266 info = -11
267 END IF
268 IF( info.NE.0 ) THEN
269 CALL xerbla( 'ZGGRQF', -info )
270 RETURN
271 ELSE IF( lquery ) THEN
272 RETURN
273 END IF
274*
275* RQ factorization of M-by-N matrix A: A = R*Q
276*
277 CALL zgerqf( m, n, a, lda, taua, work, lwork, info )
278 lopt = dble( work( 1 ) )
279*
280* Update B := B*Q**H
281*
282 CALL zunmrq( 'Right', 'Conjugate Transpose', p, n, min( m, n ),
283 $ a( max( 1, m-n+1 ), 1 ), lda, taua, b, ldb, work,
284 $ lwork, info )
285 lopt = max( lopt, int( work( 1 ) ) )
286*
287* QR factorization of P-by-N matrix B: B = Z*T
288*
289 CALL zgeqrf( p, n, b, ldb, taub, work, lwork, info )
290 work( 1 ) = max( lopt, int( work( 1 ) ) )
291*
292 RETURN
293*
294* End of ZGGRQF
295*
zunmrq
subroutine zunmrq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMRQ
Definition zunmrq.f:167

◆ zggsvp()

subroutine zggsvp ( character jobu,
character jobv,
character jobq,
integer m,
integer p,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision tola,
double precision tolb,
integer k,
integer l,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldv, * ) v,
integer ldv,
complex*16, dimension( ldq, * ) q,
integer ldq,
integer, dimension( * ) iwork,
double precision, dimension( * ) rwork,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer info )

ZGGSVP

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine ZGGSVP3.
!>
!> ZGGSVP computes unitary matrices U, V and Q such that
!>
!>                    N-K-L  K    L
!>  U**H*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;
!>                 L ( 0     0   A23 )
!>             M-K-L ( 0     0    0  )
!>
!>                  N-K-L  K    L
!>         =     K ( 0    A12  A13 )  if M-K-L < 0;
!>             M-K ( 0     0   A23 )
!>
!>                  N-K-L  K    L
!>  V**H*B*Q =   L ( 0     0   B13 )
!>             P-L ( 0     0    0  )
!>
!> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
!> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
!> otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective
!> numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H.
!>
!> This decomposition is the preprocessing step for computing the
!> Generalized Singular Value Decomposition (GSVD), see subroutine
!> ZGGSVD.
!>
Parameters
[in]JOBU
!>          JOBU is CHARACTER*1
!>          = 'U':  Unitary matrix U is computed;
!>          = 'N':  U is not computed.
!>
[in]JOBV
!>          JOBV is CHARACTER*1
!>          = 'V':  Unitary matrix V is computed;
!>          = 'N':  V is not computed.
!>
[in]JOBQ
!>          JOBQ is CHARACTER*1
!>          = 'Q':  Unitary matrix Q is computed;
!>          = 'N':  Q is not computed.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of rows of the matrix B.  P >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and B.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, A contains the triangular (or trapezoidal) matrix
!>          described in the Purpose section.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          On entry, the P-by-N matrix B.
!>          On exit, B contains the triangular matrix described in
!>          the Purpose section.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,P).
!>
[in]TOLA
!>          TOLA is DOUBLE PRECISION
!>
[in]TOLB
!>          TOLB is DOUBLE PRECISION
!>
!>          TOLA and TOLB are the thresholds to determine the effective
!>          numerical rank of matrix B and a subblock of A. Generally,
!>          they are set to
!>             TOLA = MAX(M,N)*norm(A)*MAZHEPS,
!>             TOLB = MAX(P,N)*norm(B)*MAZHEPS.
!>          The size of TOLA and TOLB may affect the size of backward
!>          errors of the decomposition.
!>
[out]K
!>          K is INTEGER
!>
[out]L
!>          L is INTEGER
!>
!>          On exit, K and L specify the dimension of the subblocks
!>          described in Purpose section.
!>          K + L = effective numerical rank of (A**H,B**H)**H.
!>
[out]U
!>          U is COMPLEX*16 array, dimension (LDU,M)
!>          If JOBU = 'U', U contains the unitary matrix U.
!>          If JOBU = 'N', U is not referenced.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U. LDU >= max(1,M) if
!>          JOBU = 'U'; LDU >= 1 otherwise.
!>
[out]V
!>          V is COMPLEX*16 array, dimension (LDV,P)
!>          If JOBV = 'V', V contains the unitary matrix V.
!>          If JOBV = 'N', V is not referenced.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= max(1,P) if
!>          JOBV = 'V'; LDV >= 1 otherwise.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          If JOBQ = 'Q', Q contains the unitary matrix Q.
!>          If JOBQ = 'N', Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= max(1,N) if
!>          JOBQ = 'Q'; LDQ >= 1 otherwise.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*N)
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (N)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (max(3*N,M,P))
!>
[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.
Further Details:
!>
!>  The subroutine uses LAPACK subroutine ZGEQPF for the QR factorization
!>  with column pivoting to detect the effective numerical rank of the
!>  a matrix. It may be replaced by a better rank determination strategy.
!>

Definition at line 262 of file zggsvp.f.

265*
266* -- LAPACK computational routine --
267* -- LAPACK is a software package provided by Univ. of Tennessee, --
268* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
269*
270* .. Scalar Arguments ..
271 CHARACTER JOBQ, JOBU, JOBV
272 INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
273 DOUBLE PRECISION TOLA, TOLB
274* ..
275* .. Array Arguments ..
276 INTEGER IWORK( * )
277 DOUBLE PRECISION RWORK( * )
278 COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
279 $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
280* ..
281*
282* =====================================================================
283*
284* .. Parameters ..
285 COMPLEX*16 CZERO, CONE
286 parameter( czero = ( 0.0d+0, 0.0d+0 ),
287 $ cone = ( 1.0d+0, 0.0d+0 ) )
288* ..
289* .. Local Scalars ..
290 LOGICAL FORWRD, WANTQ, WANTU, WANTV
291 INTEGER I, J
292 COMPLEX*16 T
293* ..
294* .. External Functions ..
295 LOGICAL LSAME
296 EXTERNAL lsame
297* ..
298* .. External Subroutines ..
299 EXTERNAL xerbla, zgeqpf, zgeqr2, zgerq2, zlacpy, zlapmt,
300 $ zlaset, zung2r, zunm2r, zunmr2
301* ..
302* .. Intrinsic Functions ..
303 INTRINSIC abs, dble, dimag, max, min
304* ..
305* .. Statement Functions ..
306 DOUBLE PRECISION CABS1
307* ..
308* .. Statement Function definitions ..
309 cabs1( t ) = abs( dble( t ) ) + abs( dimag( t ) )
310* ..
311* .. Executable Statements ..
312*
313* Test the input parameters
314*
315 wantu = lsame( jobu, 'U' )
316 wantv = lsame( jobv, 'V' )
317 wantq = lsame( jobq, 'Q' )
318 forwrd = .true.
319*
320 info = 0
321 IF( .NOT.( wantu .OR. lsame( jobu, 'N' ) ) ) THEN
322 info = -1
323 ELSE IF( .NOT.( wantv .OR. lsame( jobv, 'N' ) ) ) THEN
324 info = -2
325 ELSE IF( .NOT.( wantq .OR. lsame( jobq, 'N' ) ) ) THEN
326 info = -3
327 ELSE IF( m.LT.0 ) THEN
328 info = -4
329 ELSE IF( p.LT.0 ) THEN
330 info = -5
331 ELSE IF( n.LT.0 ) THEN
332 info = -6
333 ELSE IF( lda.LT.max( 1, m ) ) THEN
334 info = -8
335 ELSE IF( ldb.LT.max( 1, p ) ) THEN
336 info = -10
337 ELSE IF( ldu.LT.1 .OR. ( wantu .AND. ldu.LT.m ) ) THEN
338 info = -16
339 ELSE IF( ldv.LT.1 .OR. ( wantv .AND. ldv.LT.p ) ) THEN
340 info = -18
341 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) ) THEN
342 info = -20
343 END IF
344 IF( info.NE.0 ) THEN
345 CALL xerbla( 'ZGGSVP', -info )
346 RETURN
347 END IF
348*
349* QR with column pivoting of B: B*P = V*( S11 S12 )
350* ( 0 0 )
351*
352 DO 10 i = 1, n
353 iwork( i ) = 0
354 10 CONTINUE
355 CALL zgeqpf( p, n, b, ldb, iwork, tau, work, rwork, info )
356*
357* Update A := A*P
358*
359 CALL zlapmt( forwrd, m, n, a, lda, iwork )
360*
361* Determine the effective rank of matrix B.
362*
363 l = 0
364 DO 20 i = 1, min( p, n )
365 IF( cabs1( b( i, i ) ).GT.tolb )
366 $ l = l + 1
367 20 CONTINUE
368*
369 IF( wantv ) THEN
370*
371* Copy the details of V, and form V.
372*
373 CALL zlaset( 'Full', p, p, czero, czero, v, ldv )
374 IF( p.GT.1 )
375 $ CALL zlacpy( 'Lower', p-1, n, b( 2, 1 ), ldb, v( 2, 1 ),
376 $ ldv )
377 CALL zung2r( p, p, min( p, n ), v, ldv, tau, work, info )
378 END IF
379*
380* Clean up B
381*
382 DO 40 j = 1, l - 1
383 DO 30 i = j + 1, l
384 b( i, j ) = czero
385 30 CONTINUE
386 40 CONTINUE
387 IF( p.GT.l )
388 $ CALL zlaset( 'Full', p-l, n, czero, czero, b( l+1, 1 ), ldb )
389*
390 IF( wantq ) THEN
391*
392* Set Q = I and Update Q := Q*P
393*
394 CALL zlaset( 'Full', n, n, czero, cone, q, ldq )
395 CALL zlapmt( forwrd, n, n, q, ldq, iwork )
396 END IF
397*
398 IF( p.GE.l .AND. n.NE.l ) THEN
399*
400* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z
401*
402 CALL zgerq2( l, n, b, ldb, tau, work, info )
403*
404* Update A := A*Z**H
405*
406 CALL zunmr2( 'Right', 'Conjugate transpose', m, n, l, b, ldb,
407 $ tau, a, lda, work, info )
408 IF( wantq ) THEN
409*
410* Update Q := Q*Z**H
411*
412 CALL zunmr2( 'Right', 'Conjugate transpose', n, n, l, b,
413 $ ldb, tau, q, ldq, work, info )
414 END IF
415*
416* Clean up B
417*
418 CALL zlaset( 'Full', l, n-l, czero, czero, b, ldb )
419 DO 60 j = n - l + 1, n
420 DO 50 i = j - n + l + 1, l
421 b( i, j ) = czero
422 50 CONTINUE
423 60 CONTINUE
424*
425 END IF
426*
427* Let N-L L
428* A = ( A11 A12 ) M,
429*
430* then the following does the complete QR decomposition of A11:
431*
432* A11 = U*( 0 T12 )*P1**H
433* ( 0 0 )
434*
435 DO 70 i = 1, n - l
436 iwork( i ) = 0
437 70 CONTINUE
438 CALL zgeqpf( m, n-l, a, lda, iwork, tau, work, rwork, info )
439*
440* Determine the effective rank of A11
441*
442 k = 0
443 DO 80 i = 1, min( m, n-l )
444 IF( cabs1( a( i, i ) ).GT.tola )
445 $ k = k + 1
446 80 CONTINUE
447*
448* Update A12 := U**H*A12, where A12 = A( 1:M, N-L+1:N )
449*
450 CALL zunm2r( 'Left', 'Conjugate transpose', m, l, min( m, n-l ),
451 $ a, lda, tau, a( 1, n-l+1 ), lda, work, info )
452*
453 IF( wantu ) THEN
454*
455* Copy the details of U, and form U
456*
457 CALL zlaset( 'Full', m, m, czero, czero, u, ldu )
458 IF( m.GT.1 )
459 $ CALL zlacpy( 'Lower', m-1, n-l, a( 2, 1 ), lda, u( 2, 1 ),
460 $ ldu )
461 CALL zung2r( m, m, min( m, n-l ), u, ldu, tau, work, info )
462 END IF
463*
464 IF( wantq ) THEN
465*
466* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1
467*
468 CALL zlapmt( forwrd, n, n-l, q, ldq, iwork )
469 END IF
470*
471* Clean up A: set the strictly lower triangular part of
472* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
473*
474 DO 100 j = 1, k - 1
475 DO 90 i = j + 1, k
476 a( i, j ) = czero
477 90 CONTINUE
478 100 CONTINUE
479 IF( m.GT.k )
480 $ CALL zlaset( 'Full', m-k, n-l, czero, czero, a( k+1, 1 ), lda )
481*
482 IF( n-l.GT.k ) THEN
483*
484* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
485*
486 CALL zgerq2( k, n-l, a, lda, tau, work, info )
487*
488 IF( wantq ) THEN
489*
490* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**H
491*
492 CALL zunmr2( 'Right', 'Conjugate transpose', n, n-l, k, a,
493 $ lda, tau, q, ldq, work, info )
494 END IF
495*
496* Clean up A
497*
498 CALL zlaset( 'Full', k, n-l-k, czero, czero, a, lda )
499 DO 120 j = n - l - k + 1, n - l
500 DO 110 i = j - n + l + k + 1, k
501 a( i, j ) = czero
502 110 CONTINUE
503 120 CONTINUE
504*
505 END IF
506*
507 IF( m.GT.k ) THEN
508*
509* QR factorization of A( K+1:M,N-L+1:N )
510*
511 CALL zgeqr2( m-k, l, a( k+1, n-l+1 ), lda, tau, work, info )
512*
513 IF( wantu ) THEN
514*
515* Update U(:,K+1:M) := U(:,K+1:M)*U1
516*
517 CALL zunm2r( 'Right', 'No transpose', m, m-k, min( m-k, l ),
518 $ a( k+1, n-l+1 ), lda, tau, u( 1, k+1 ), ldu,
519 $ work, info )
520 END IF
521*
522* Clean up
523*
524 DO 140 j = n - l + 1, n
525 DO 130 i = j - n + k + l + 1, m
526 a( i, j ) = czero
527 130 CONTINUE
528 140 CONTINUE
529*
530 END IF
531*
532 RETURN
533*
534* End of ZGGSVP
535*
zgerq2
subroutine zgerq2(m, n, a, lda, tau, work, info)
ZGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition zgerq2.f:123
zgeqr2
subroutine zgeqr2(m, n, a, lda, tau, work, info)
ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition zgeqr2.f:130
zgeqpf
subroutine zgeqpf(m, n, a, lda, jpvt, tau, work, rwork, info)
ZGEQPF
Definition zgeqpf.f:148
zlapmt
subroutine zlapmt(forwrd, m, n, x, ldx, k)
ZLAPMT performs a forward or backward permutation of the columns of a matrix.
Definition zlapmt.f:104
zunm2r
subroutine zunm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...
Definition zunm2r.f:159
zunmr2
subroutine zunmr2(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf...
Definition zunmr2.f:159
zung2r
subroutine zung2r(m, n, k, a, lda, tau, work, info)
ZUNG2R
Definition zung2r.f:114

◆ zggsvp3()

subroutine zggsvp3 ( character jobu,
character jobv,
character jobq,
integer m,
integer p,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision tola,
double precision tolb,
integer k,
integer l,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldv, * ) v,
integer ldv,
complex*16, dimension( ldq, * ) q,
integer ldq,
integer, dimension( * ) iwork,
double precision, dimension( * ) rwork,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZGGSVP3

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

Purpose:
!>
!> ZGGSVP3 computes unitary matrices U, V and Q such that
!>
!>                    N-K-L  K    L
!>  U**H*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;
!>                 L ( 0     0   A23 )
!>             M-K-L ( 0     0    0  )
!>
!>                  N-K-L  K    L
!>         =     K ( 0    A12  A13 )  if M-K-L < 0;
!>             M-K ( 0     0   A23 )
!>
!>                  N-K-L  K    L
!>  V**H*B*Q =   L ( 0     0   B13 )
!>             P-L ( 0     0    0  )
!>
!> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
!> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
!> otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective
!> numerical rank of the (M+P)-by-N matrix (A**H,B**H)**H.
!>
!> This decomposition is the preprocessing step for computing the
!> Generalized Singular Value Decomposition (GSVD), see subroutine
!> ZGGSVD3.
!>
Parameters
[in]JOBU
!>          JOBU is CHARACTER*1
!>          = 'U':  Unitary matrix U is computed;
!>          = 'N':  U is not computed.
!>
[in]JOBV
!>          JOBV is CHARACTER*1
!>          = 'V':  Unitary matrix V is computed;
!>          = 'N':  V is not computed.
!>
[in]JOBQ
!>          JOBQ is CHARACTER*1
!>          = 'Q':  Unitary matrix Q is computed;
!>          = 'N':  Q is not computed.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of rows of the matrix B.  P >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and B.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, A contains the triangular (or trapezoidal) matrix
!>          described in the Purpose section.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          On entry, the P-by-N matrix B.
!>          On exit, B contains the triangular matrix described in
!>          the Purpose section.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,P).
!>
[in]TOLA
!>          TOLA is DOUBLE PRECISION
!>
[in]TOLB
!>          TOLB is DOUBLE PRECISION
!>
!>          TOLA and TOLB are the thresholds to determine the effective
!>          numerical rank of matrix B and a subblock of A. Generally,
!>          they are set to
!>             TOLA = MAX(M,N)*norm(A)*MAZHEPS,
!>             TOLB = MAX(P,N)*norm(B)*MAZHEPS.
!>          The size of TOLA and TOLB may affect the size of backward
!>          errors of the decomposition.
!>
[out]K
!>          K is INTEGER
!>
[out]L
!>          L is INTEGER
!>
!>          On exit, K and L specify the dimension of the subblocks
!>          described in Purpose section.
!>          K + L = effective numerical rank of (A**H,B**H)**H.
!>
[out]U
!>          U is COMPLEX*16 array, dimension (LDU,M)
!>          If JOBU = 'U', U contains the unitary matrix U.
!>          If JOBU = 'N', U is not referenced.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U. LDU >= max(1,M) if
!>          JOBU = 'U'; LDU >= 1 otherwise.
!>
[out]V
!>          V is COMPLEX*16 array, dimension (LDV,P)
!>          If JOBV = 'V', V contains the unitary matrix V.
!>          If JOBV = 'N', V is not referenced.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= max(1,P) if
!>          JOBV = 'V'; LDV >= 1 otherwise.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          If JOBQ = 'Q', Q contains the unitary matrix Q.
!>          If JOBQ = 'N', Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= max(1,N) if
!>          JOBQ = 'Q'; LDQ >= 1 otherwise.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*N)
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (N)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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.
Further Details:
!>
!>  The subroutine uses LAPACK subroutine ZGEQP3 for the QR factorization
!>  with column pivoting to detect the effective numerical rank of the
!>  a matrix. It may be replaced by a better rank determination strategy.
!>
!>  ZGGSVP3 replaces the deprecated subroutine ZGGSVP.
!>
!>

Definition at line 275 of file zggsvp3.f.

278*
279* -- LAPACK computational routine --
280* -- LAPACK is a software package provided by Univ. of Tennessee, --
281* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
282*
283 IMPLICIT NONE
284*
285* .. Scalar Arguments ..
286 CHARACTER JOBQ, JOBU, JOBV
287 INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P,
288 $ LWORK
289 DOUBLE PRECISION TOLA, TOLB
290* ..
291* .. Array Arguments ..
292 INTEGER IWORK( * )
293 DOUBLE PRECISION RWORK( * )
294 COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
295 $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
296* ..
297*
298* =====================================================================
299*
300* .. Parameters ..
301 COMPLEX*16 CZERO, CONE
302 parameter( czero = ( 0.0d+0, 0.0d+0 ),
303 $ cone = ( 1.0d+0, 0.0d+0 ) )
304* ..
305* .. Local Scalars ..
306 LOGICAL FORWRD, WANTQ, WANTU, WANTV, LQUERY
307 INTEGER I, J, LWKOPT
308* ..
309* .. External Functions ..
310 LOGICAL LSAME
311 EXTERNAL lsame
312* ..
313* .. External Subroutines ..
314 EXTERNAL xerbla, zgeqp3, zgeqr2, zgerq2, zlacpy, zlapmt,
315 $ zlaset, zung2r, zunm2r, zunmr2
316* ..
317* .. Intrinsic Functions ..
318 INTRINSIC abs, dble, dimag, max, min
319* ..
320* .. Executable Statements ..
321*
322* Test the input parameters
323*
324 wantu = lsame( jobu, 'U' )
325 wantv = lsame( jobv, 'V' )
326 wantq = lsame( jobq, 'Q' )
327 forwrd = .true.
328 lquery = ( lwork.EQ.-1 )
329 lwkopt = 1
330*
331* Test the input arguments
332*
333 info = 0
334 IF( .NOT.( wantu .OR. lsame( jobu, 'N' ) ) ) THEN
335 info = -1
336 ELSE IF( .NOT.( wantv .OR. lsame( jobv, 'N' ) ) ) THEN
337 info = -2
338 ELSE IF( .NOT.( wantq .OR. lsame( jobq, 'N' ) ) ) THEN
339 info = -3
340 ELSE IF( m.LT.0 ) THEN
341 info = -4
342 ELSE IF( p.LT.0 ) THEN
343 info = -5
344 ELSE IF( n.LT.0 ) THEN
345 info = -6
346 ELSE IF( lda.LT.max( 1, m ) ) THEN
347 info = -8
348 ELSE IF( ldb.LT.max( 1, p ) ) THEN
349 info = -10
350 ELSE IF( ldu.LT.1 .OR. ( wantu .AND. ldu.LT.m ) ) THEN
351 info = -16
352 ELSE IF( ldv.LT.1 .OR. ( wantv .AND. ldv.LT.p ) ) THEN
353 info = -18
354 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) ) THEN
355 info = -20
356 ELSE IF( lwork.LT.1 .AND. .NOT.lquery ) THEN
357 info = -24
358 END IF
359*
360* Compute workspace
361*
362 IF( info.EQ.0 ) THEN
363 CALL zgeqp3( p, n, b, ldb, iwork, tau, work, -1, rwork, info )
364 lwkopt = int( work( 1 ) )
365 IF( wantv ) THEN
366 lwkopt = max( lwkopt, p )
367 END IF
368 lwkopt = max( lwkopt, min( n, p ) )
369 lwkopt = max( lwkopt, m )
370 IF( wantq ) THEN
371 lwkopt = max( lwkopt, n )
372 END IF
373 CALL zgeqp3( m, n, a, lda, iwork, tau, work, -1, rwork, info )
374 lwkopt = max( lwkopt, int( work( 1 ) ) )
375 lwkopt = max( 1, lwkopt )
376 work( 1 ) = dcmplx( lwkopt )
377 END IF
378*
379 IF( info.NE.0 ) THEN
380 CALL xerbla( 'ZGGSVP3', -info )
381 RETURN
382 END IF
383 IF( lquery ) THEN
384 RETURN
385 ENDIF
386*
387* QR with column pivoting of B: B*P = V*( S11 S12 )
388* ( 0 0 )
389*
390 DO 10 i = 1, n
391 iwork( i ) = 0
392 10 CONTINUE
393 CALL zgeqp3( p, n, b, ldb, iwork, tau, work, lwork, rwork, info )
394*
395* Update A := A*P
396*
397 CALL zlapmt( forwrd, m, n, a, lda, iwork )
398*
399* Determine the effective rank of matrix B.
400*
401 l = 0
402 DO 20 i = 1, min( p, n )
403 IF( abs( b( i, i ) ).GT.tolb )
404 $ l = l + 1
405 20 CONTINUE
406*
407 IF( wantv ) THEN
408*
409* Copy the details of V, and form V.
410*
411 CALL zlaset( 'Full', p, p, czero, czero, v, ldv )
412 IF( p.GT.1 )
413 $ CALL zlacpy( 'Lower', p-1, n, b( 2, 1 ), ldb, v( 2, 1 ),
414 $ ldv )
415 CALL zung2r( p, p, min( p, n ), v, ldv, tau, work, info )
416 END IF
417*
418* Clean up B
419*
420 DO 40 j = 1, l - 1
421 DO 30 i = j + 1, l
422 b( i, j ) = czero
423 30 CONTINUE
424 40 CONTINUE
425 IF( p.GT.l )
426 $ CALL zlaset( 'Full', p-l, n, czero, czero, b( l+1, 1 ), ldb )
427*
428 IF( wantq ) THEN
429*
430* Set Q = I and Update Q := Q*P
431*
432 CALL zlaset( 'Full', n, n, czero, cone, q, ldq )
433 CALL zlapmt( forwrd, n, n, q, ldq, iwork )
434 END IF
435*
436 IF( p.GE.l .AND. n.NE.l ) THEN
437*
438* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z
439*
440 CALL zgerq2( l, n, b, ldb, tau, work, info )
441*
442* Update A := A*Z**H
443*
444 CALL zunmr2( 'Right', 'Conjugate transpose', m, n, l, b, ldb,
445 $ tau, a, lda, work, info )
446 IF( wantq ) THEN
447*
448* Update Q := Q*Z**H
449*
450 CALL zunmr2( 'Right', 'Conjugate transpose', n, n, l, b,
451 $ ldb, tau, q, ldq, work, info )
452 END IF
453*
454* Clean up B
455*
456 CALL zlaset( 'Full', l, n-l, czero, czero, b, ldb )
457 DO 60 j = n - l + 1, n
458 DO 50 i = j - n + l + 1, l
459 b( i, j ) = czero
460 50 CONTINUE
461 60 CONTINUE
462*
463 END IF
464*
465* Let N-L L
466* A = ( A11 A12 ) M,
467*
468* then the following does the complete QR decomposition of A11:
469*
470* A11 = U*( 0 T12 )*P1**H
471* ( 0 0 )
472*
473 DO 70 i = 1, n - l
474 iwork( i ) = 0
475 70 CONTINUE
476 CALL zgeqp3( m, n-l, a, lda, iwork, tau, work, lwork, rwork,
477 $ info )
478*
479* Determine the effective rank of A11
480*
481 k = 0
482 DO 80 i = 1, min( m, n-l )
483 IF( abs( a( i, i ) ).GT.tola )
484 $ k = k + 1
485 80 CONTINUE
486*
487* Update A12 := U**H*A12, where A12 = A( 1:M, N-L+1:N )
488*
489 CALL zunm2r( 'Left', 'Conjugate transpose', m, l, min( m, n-l ),
490 $ a, lda, tau, a( 1, n-l+1 ), lda, work, info )
491*
492 IF( wantu ) THEN
493*
494* Copy the details of U, and form U
495*
496 CALL zlaset( 'Full', m, m, czero, czero, u, ldu )
497 IF( m.GT.1 )
498 $ CALL zlacpy( 'Lower', m-1, n-l, a( 2, 1 ), lda, u( 2, 1 ),
499 $ ldu )
500 CALL zung2r( m, m, min( m, n-l ), u, ldu, tau, work, info )
501 END IF
502*
503 IF( wantq ) THEN
504*
505* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1
506*
507 CALL zlapmt( forwrd, n, n-l, q, ldq, iwork )
508 END IF
509*
510* Clean up A: set the strictly lower triangular part of
511* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
512*
513 DO 100 j = 1, k - 1
514 DO 90 i = j + 1, k
515 a( i, j ) = czero
516 90 CONTINUE
517 100 CONTINUE
518 IF( m.GT.k )
519 $ CALL zlaset( 'Full', m-k, n-l, czero, czero, a( k+1, 1 ), lda )
520*
521 IF( n-l.GT.k ) THEN
522*
523* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
524*
525 CALL zgerq2( k, n-l, a, lda, tau, work, info )
526*
527 IF( wantq ) THEN
528*
529* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**H
530*
531 CALL zunmr2( 'Right', 'Conjugate transpose', n, n-l, k, a,
532 $ lda, tau, q, ldq, work, info )
533 END IF
534*
535* Clean up A
536*
537 CALL zlaset( 'Full', k, n-l-k, czero, czero, a, lda )
538 DO 120 j = n - l - k + 1, n - l
539 DO 110 i = j - n + l + k + 1, k
540 a( i, j ) = czero
541 110 CONTINUE
542 120 CONTINUE
543*
544 END IF
545*
546 IF( m.GT.k ) THEN
547*
548* QR factorization of A( K+1:M,N-L+1:N )
549*
550 CALL zgeqr2( m-k, l, a( k+1, n-l+1 ), lda, tau, work, info )
551*
552 IF( wantu ) THEN
553*
554* Update U(:,K+1:M) := U(:,K+1:M)*U1
555*
556 CALL zunm2r( 'Right', 'No transpose', m, m-k, min( m-k, l ),
557 $ a( k+1, n-l+1 ), lda, tau, u( 1, k+1 ), ldu,
558 $ work, info )
559 END IF
560*
561* Clean up
562*
563 DO 140 j = n - l + 1, n
564 DO 130 i = j - n + k + l + 1, m
565 a( i, j ) = czero
566 130 CONTINUE
567 140 CONTINUE
568*
569 END IF
570*
571 work( 1 ) = dcmplx( lwkopt )
572 RETURN
573*
574* End of ZGGSVP3
575*
zgeqp3
subroutine zgeqp3(m, n, a, lda, jpvt, tau, work, lwork, rwork, info)
ZGEQP3
Definition zgeqp3.f:159

◆ zgsvj0()

subroutine zgsvj0 ( character*1 jobv,
integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( n ) d,
double precision, dimension( n ) sva,
integer mv,
complex*16, dimension( ldv, * ) v,
integer ldv,
double precision eps,
double precision sfmin,
double precision tol,
integer nsweep,
complex*16, dimension( lwork ) work,
integer lwork,
integer info )

ZGSVJ0 pre-processor for the routine zgesvj.

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

Purpose:
!>
!> ZGSVJ0 is called from ZGESVJ as a pre-processor and that is its main
!> purpose. It applies Jacobi rotations in the same way as ZGESVJ does, but
!> it does not check convergence (stopping criterion). Few tuning
!> parameters (marked by [TP]) are available for the implementer.
!>
Parameters
[in]JOBV
!>          JOBV is CHARACTER*1
!>          Specifies whether the output from this procedure is used
!>          to compute the matrix V:
!>          = 'V': the product of the Jacobi rotations is accumulated
!>                 by postmulyiplying the N-by-N array V.
!>                (See the description of V.)
!>          = 'A': the product of the Jacobi rotations is accumulated
!>                 by postmulyiplying the MV-by-N array V.
!>                (See the descriptions of MV and V.)
!>          = 'N': the Jacobi rotations are not accumulated.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the input matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the input matrix A.
!>          M >= N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, M-by-N matrix A, such that A*diag(D) represents
!>          the input matrix.
!>          On exit,
!>          A_onexit * diag(D_onexit) represents the input matrix A*diag(D)
!>          post-multiplied by a sequence of Jacobi rotations, where the
!>          rotation threshold and the total number of sweeps are given in
!>          TOL and NSWEEP, respectively.
!>          (See the descriptions of D, TOL and NSWEEP.)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in,out]D
!>          D is COMPLEX*16 array, dimension (N)
!>          The array D accumulates the scaling factors from the complex scaled
!>          Jacobi rotations.
!>          On entry, A*diag(D) represents the input matrix.
!>          On exit, A_onexit*diag(D_onexit) represents the input matrix
!>          post-multiplied by a sequence of Jacobi rotations, where the
!>          rotation threshold and the total number of sweeps are given in
!>          TOL and NSWEEP, respectively.
!>          (See the descriptions of A, TOL and NSWEEP.)
!>
[in,out]SVA
!>          SVA is DOUBLE PRECISION array, dimension (N)
!>          On entry, SVA contains the Euclidean norms of the columns of
!>          the matrix A*diag(D).
!>          On exit, SVA contains the Euclidean norms of the columns of
!>          the matrix A_onexit*diag(D_onexit).
!>
[in]MV
!>          MV is INTEGER
!>          If JOBV = 'A', then MV rows of V are post-multipled by a
!>                           sequence of Jacobi rotations.
!>          If JOBV = 'N',   then MV is not referenced.
!>
[in,out]V
!>          V is COMPLEX*16 array, dimension (LDV,N)
!>          If JOBV = 'V' then N rows of V are post-multipled by a
!>                           sequence of Jacobi rotations.
!>          If JOBV = 'A' then MV rows of V are post-multipled by a
!>                           sequence of Jacobi rotations.
!>          If JOBV = 'N',   then V is not referenced.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V,  LDV >= 1.
!>          If JOBV = 'V', LDV >= N.
!>          If JOBV = 'A', LDV >= MV.
!>
[in]EPS
!>          EPS is DOUBLE PRECISION
!>          EPS = DLAMCH('Epsilon')
!>
[in]SFMIN
!>          SFMIN is DOUBLE PRECISION
!>          SFMIN = DLAMCH('Safe Minimum')
!>
[in]TOL
!>          TOL is DOUBLE PRECISION
!>          TOL is the threshold for Jacobi rotations. For a pair
!>          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is
!>          applied only if ABS(COS(angle(A(:,p),A(:,q)))) > TOL.
!>
[in]NSWEEP
!>          NSWEEP is INTEGER
!>          NSWEEP is the number of sweeps of Jacobi rotations to be
!>          performed.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          LWORK is the dimension of WORK. LWORK >= M.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, then the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
ZGSVJ0 is used just to enable ZGESVJ to call a simplified version of itself to work on a submatrix of the original matrix.

Contributor: Zlatko Drmac (Zagreb, Croatia)

Bugs, Examples and Comments:
Please report all bugs and send interesting test examples and comments to drmac.nosp@m.@mat.nosp@m.h.hr. Thank you.

Definition at line 216 of file zgsvj0.f.

218*
219* -- LAPACK computational routine --
220* -- LAPACK is a software package provided by Univ. of Tennessee, --
221* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
222*
223 IMPLICIT NONE
224* .. Scalar Arguments ..
225 INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP
226 DOUBLE PRECISION EPS, SFMIN, TOL
227 CHARACTER*1 JOBV
228* ..
229* .. Array Arguments ..
230 COMPLEX*16 A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK )
231 DOUBLE PRECISION SVA( N )
232* ..
233*
234* =====================================================================
235*
236* .. Local Parameters ..
237 DOUBLE PRECISION ZERO, HALF, ONE
238 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0)
239 COMPLEX*16 CZERO, CONE
240 parameter( czero = (0.0d0, 0.0d0), cone = (1.0d0, 0.0d0) )
241* ..
242* .. Local Scalars ..
243 COMPLEX*16 AAPQ, OMPQ
244 DOUBLE PRECISION AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG,
245 $ BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,
246 $ ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,
247 $ THSIGN
248 INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
249 $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,
250 $ NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND
251 LOGICAL APPLV, ROTOK, RSVEC
252* ..
253* ..
254* .. Intrinsic Functions ..
255 INTRINSIC abs, max, conjg, dble, min, sign, sqrt
256* ..
257* .. External Functions ..
258 DOUBLE PRECISION DZNRM2
259 COMPLEX*16 ZDOTC
260 INTEGER IDAMAX
261 LOGICAL LSAME
262 EXTERNAL idamax, lsame, zdotc, dznrm2
263* ..
264* ..
265* .. External Subroutines ..
266* ..
267* from BLAS
268 EXTERNAL zcopy, zrot, zswap, zaxpy
269* from LAPACK
270 EXTERNAL zlascl, zlassq, xerbla
271* ..
272* .. Executable Statements ..
273*
274* Test the input parameters.
275*
276 applv = lsame( jobv, 'A' )
277 rsvec = lsame( jobv, 'V' )
278 IF( .NOT.( rsvec .OR. applv .OR. lsame( jobv, 'N' ) ) ) THEN
279 info = -1
280 ELSE IF( m.LT.0 ) THEN
281 info = -2
282 ELSE IF( ( n.LT.0 ) .OR. ( n.GT.m ) ) THEN
283 info = -3
284 ELSE IF( lda.LT.m ) THEN
285 info = -5
286 ELSE IF( ( rsvec.OR.applv ) .AND. ( mv.LT.0 ) ) THEN
287 info = -8
288 ELSE IF( ( rsvec.AND.( ldv.LT.n ) ).OR.
289 $ ( applv.AND.( ldv.LT.mv ) ) ) THEN
290 info = -10
291 ELSE IF( tol.LE.eps ) THEN
292 info = -13
293 ELSE IF( nsweep.LT.0 ) THEN
294 info = -14
295 ELSE IF( lwork.LT.m ) THEN
296 info = -16
297 ELSE
298 info = 0
299 END IF
300*
301* #:(
302 IF( info.NE.0 ) THEN
303 CALL xerbla( 'ZGSVJ0', -info )
304 RETURN
305 END IF
306*
307 IF( rsvec ) THEN
308 mvl = n
309 ELSE IF( applv ) THEN
310 mvl = mv
311 END IF
312 rsvec = rsvec .OR. applv
313
314 rooteps = sqrt( eps )
315 rootsfmin = sqrt( sfmin )
316 small = sfmin / eps
317 big = one / sfmin
318 rootbig = one / rootsfmin
319 bigtheta = one / rooteps
320 roottol = sqrt( tol )
321*
322* .. Row-cyclic Jacobi SVD algorithm with column pivoting ..
323*
324 emptsw = ( n*( n-1 ) ) / 2
325 notrot = 0
326*
327* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
328*
329
330 swband = 0
331*[TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective
332* if ZGESVJ is used as a computational routine in the preconditioned
333* Jacobi SVD algorithm ZGEJSV. For sweeps i=1:SWBAND the procedure
334* works on pivots inside a band-like region around the diagonal.
335* The boundaries are determined dynamically, based on the number of
336* pivots above a threshold.
337*
338 kbl = min( 8, n )
339*[TP] KBL is a tuning parameter that defines the tile size in the
340* tiling of the p-q loops of pivot pairs. In general, an optimal
341* value of KBL depends on the matrix dimensions and on the
342* parameters of the computer's memory.
343*
344 nbl = n / kbl
345 IF( ( nbl*kbl ).NE.n )nbl = nbl + 1
346*
347 blskip = kbl**2
348*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
349*
350 rowskip = min( 5, kbl )
351*[TP] ROWSKIP is a tuning parameter.
352*
353 lkahead = 1
354*[TP] LKAHEAD is a tuning parameter.
355*
356* Quasi block transformations, using the lower (upper) triangular
357* structure of the input matrix. The quasi-block-cycling usually
358* invokes cubic convergence. Big part of this cycle is done inside
359* canonical subspaces of dimensions less than M.
360*
361*
362* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
363*
364 DO 1993 i = 1, nsweep
365*
366* .. go go go ...
367*
368 mxaapq = zero
369 mxsinj = zero
370 iswrot = 0
371*
372 notrot = 0
373 pskipped = 0
374*
375* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs
376* 1 <= p < q <= N. This is the first step toward a blocked implementation
377* of the rotations. New implementation, based on block transformations,
378* is under development.
379*
380 DO 2000 ibr = 1, nbl
381*
382 igl = ( ibr-1 )*kbl + 1
383*
384 DO 1002 ir1 = 0, min( lkahead, nbl-ibr )
385*
386 igl = igl + ir1*kbl
387*
388 DO 2001 p = igl, min( igl+kbl-1, n-1 )
389*
390* .. de Rijk's pivoting
391*
392 q = idamax( n-p+1, sva( p ), 1 ) + p - 1
393 IF( p.NE.q ) THEN
394 CALL zswap( m, a( 1, p ), 1, a( 1, q ), 1 )
395 IF( rsvec )CALL zswap( mvl, v( 1, p ), 1,
396 $ v( 1, q ), 1 )
397 temp1 = sva( p )
398 sva( p ) = sva( q )
399 sva( q ) = temp1
400 aapq = d(p)
401 d(p) = d(q)
402 d(q) = aapq
403 END IF
404*
405 IF( ir1.EQ.0 ) THEN
406*
407* Column norms are periodically updated by explicit
408* norm computation.
409* Caveat:
410* Unfortunately, some BLAS implementations compute SNCRM2(M,A(1,p),1)
411* as SQRT(S=ZDOTC(M,A(1,p),1,A(1,p),1)), which may cause the result to
412* overflow for ||A(:,p)||_2 > SQRT(overflow_threshold), and to
413* underflow for ||A(:,p)||_2 < SQRT(underflow_threshold).
414* Hence, DZNRM2 cannot be trusted, not even in the case when
415* the true norm is far from the under(over)flow boundaries.
416* If properly implemented DZNRM2 is available, the IF-THEN-ELSE-END IF
417* below should be replaced with "AAPP = DZNRM2( M, A(1,p), 1 )".
418*
419 IF( ( sva( p ).LT.rootbig ) .AND.
420 $ ( sva( p ).GT.rootsfmin ) ) THEN
421 sva( p ) = dznrm2( m, a( 1, p ), 1 )
422 ELSE
423 temp1 = zero
424 aapp = one
425 CALL zlassq( m, a( 1, p ), 1, temp1, aapp )
426 sva( p ) = temp1*sqrt( aapp )
427 END IF
428 aapp = sva( p )
429 ELSE
430 aapp = sva( p )
431 END IF
432*
433 IF( aapp.GT.zero ) THEN
434*
435 pskipped = 0
436*
437 DO 2002 q = p + 1, min( igl+kbl-1, n )
438*
439 aaqq = sva( q )
440*
441 IF( aaqq.GT.zero ) THEN
442*
443 aapp0 = aapp
444 IF( aaqq.GE.one ) THEN
445 rotok = ( small*aapp ).LE.aaqq
446 IF( aapp.LT.( big / aaqq ) ) THEN
447 aapq = ( zdotc( m, a( 1, p ), 1,
448 $ a( 1, q ), 1 ) / aaqq ) / aapp
449 ELSE
450 CALL zcopy( m, a( 1, p ), 1,
451 $ work, 1 )
452 CALL zlascl( 'G', 0, 0, aapp, one,
453 $ m, 1, work, lda, ierr )
454 aapq = zdotc( m, work, 1,
455 $ a( 1, q ), 1 ) / aaqq
456 END IF
457 ELSE
458 rotok = aapp.LE.( aaqq / small )
459 IF( aapp.GT.( small / aaqq ) ) THEN
460 aapq = ( zdotc( m, a( 1, p ), 1,
461 $ a( 1, q ), 1 ) / aapp ) / aaqq
462 ELSE
463 CALL zcopy( m, a( 1, q ), 1,
464 $ work, 1 )
465 CALL zlascl( 'G', 0, 0, aaqq,
466 $ one, m, 1,
467 $ work, lda, ierr )
468 aapq = zdotc( m, a( 1, p ), 1,
469 $ work, 1 ) / aapp
470 END IF
471 END IF
472*
473* AAPQ = AAPQ * CONJG( CWORK(p) ) * CWORK(q)
474 aapq1 = -abs(aapq)
475 mxaapq = max( mxaapq, -aapq1 )
476*
477* TO rotate or NOT to rotate, THAT is the question ...
478*
479 IF( abs( aapq1 ).GT.tol ) THEN
480 ompq = aapq / abs(aapq)
481*
482* .. rotate
483*[RTD] ROTATED = ROTATED + ONE
484*
485 IF( ir1.EQ.0 ) THEN
486 notrot = 0
487 pskipped = 0
488 iswrot = iswrot + 1
489 END IF
490*
491 IF( rotok ) THEN
492*
493 aqoap = aaqq / aapp
494 apoaq = aapp / aaqq
495 theta = -half*abs( aqoap-apoaq )/aapq1
496*
497 IF( abs( theta ).GT.bigtheta ) THEN
498*
499 t = half / theta
500 cs = one
501
502 CALL zrot( m, a(1,p), 1, a(1,q), 1,
503 $ cs, conjg(ompq)*t )
504 IF ( rsvec ) THEN
505 CALL zrot( mvl, v(1,p), 1,
506 $ v(1,q), 1, cs, conjg(ompq)*t )
507 END IF
508
509 sva( q ) = aaqq*sqrt( max( zero,
510 $ one+t*apoaq*aapq1 ) )
511 aapp = aapp*sqrt( max( zero,
512 $ one-t*aqoap*aapq1 ) )
513 mxsinj = max( mxsinj, abs( t ) )
514*
515 ELSE
516*
517* .. choose correct signum for THETA and rotate
518*
519 thsign = -sign( one, aapq1 )
520 t = one / ( theta+thsign*
521 $ sqrt( one+theta*theta ) )
522 cs = sqrt( one / ( one+t*t ) )
523 sn = t*cs
524*
525 mxsinj = max( mxsinj, abs( sn ) )
526 sva( q ) = aaqq*sqrt( max( zero,
527 $ one+t*apoaq*aapq1 ) )
528 aapp = aapp*sqrt( max( zero,
529 $ one-t*aqoap*aapq1 ) )
530*
531 CALL zrot( m, a(1,p), 1, a(1,q), 1,
532 $ cs, conjg(ompq)*sn )
533 IF ( rsvec ) THEN
534 CALL zrot( mvl, v(1,p), 1,
535 $ v(1,q), 1, cs, conjg(ompq)*sn )
536 END IF
537 END IF
538 d(p) = -d(q) * ompq
539*
540 ELSE
541* .. have to use modified Gram-Schmidt like transformation
542 CALL zcopy( m, a( 1, p ), 1,
543 $ work, 1 )
544 CALL zlascl( 'G', 0, 0, aapp, one, m,
545 $ 1, work, lda,
546 $ ierr )
547 CALL zlascl( 'G', 0, 0, aaqq, one, m,
548 $ 1, a( 1, q ), lda, ierr )
549 CALL zaxpy( m, -aapq, work, 1,
550 $ a( 1, q ), 1 )
551 CALL zlascl( 'G', 0, 0, one, aaqq, m,
552 $ 1, a( 1, q ), lda, ierr )
553 sva( q ) = aaqq*sqrt( max( zero,
554 $ one-aapq1*aapq1 ) )
555 mxsinj = max( mxsinj, sfmin )
556 END IF
557* END IF ROTOK THEN ... ELSE
558*
559* In the case of cancellation in updating SVA(q), SVA(p)
560* recompute SVA(q), SVA(p).
561*
562 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
563 $ THEN
564 IF( ( aaqq.LT.rootbig ) .AND.
565 $ ( aaqq.GT.rootsfmin ) ) THEN
566 sva( q ) = dznrm2( m, a( 1, q ), 1 )
567 ELSE
568 t = zero
569 aaqq = one
570 CALL zlassq( m, a( 1, q ), 1, t,
571 $ aaqq )
572 sva( q ) = t*sqrt( aaqq )
573 END IF
574 END IF
575 IF( ( aapp / aapp0 ).LE.rooteps ) THEN
576 IF( ( aapp.LT.rootbig ) .AND.
577 $ ( aapp.GT.rootsfmin ) ) THEN
578 aapp = dznrm2( m, a( 1, p ), 1 )
579 ELSE
580 t = zero
581 aapp = one
582 CALL zlassq( m, a( 1, p ), 1, t,
583 $ aapp )
584 aapp = t*sqrt( aapp )
585 END IF
586 sva( p ) = aapp
587 END IF
588*
589 ELSE
590* A(:,p) and A(:,q) already numerically orthogonal
591 IF( ir1.EQ.0 )notrot = notrot + 1
592*[RTD] SKIPPED = SKIPPED + 1
593 pskipped = pskipped + 1
594 END IF
595 ELSE
596* A(:,q) is zero column
597 IF( ir1.EQ.0 )notrot = notrot + 1
598 pskipped = pskipped + 1
599 END IF
600*
601 IF( ( i.LE.swband ) .AND.
602 $ ( pskipped.GT.rowskip ) ) THEN
603 IF( ir1.EQ.0 )aapp = -aapp
604 notrot = 0
605 GO TO 2103
606 END IF
607*
608 2002 CONTINUE
609* END q-LOOP
610*
611 2103 CONTINUE
612* bailed out of q-loop
613*
614 sva( p ) = aapp
615*
616 ELSE
617 sva( p ) = aapp
618 IF( ( ir1.EQ.0 ) .AND. ( aapp.EQ.zero ) )
619 $ notrot = notrot + min( igl+kbl-1, n ) - p
620 END IF
621*
622 2001 CONTINUE
623* end of the p-loop
624* end of doing the block ( ibr, ibr )
625 1002 CONTINUE
626* end of ir1-loop
627*
628* ... go to the off diagonal blocks
629*
630 igl = ( ibr-1 )*kbl + 1
631*
632 DO 2010 jbc = ibr + 1, nbl
633*
634 jgl = ( jbc-1 )*kbl + 1
635*
636* doing the block at ( ibr, jbc )
637*
638 ijblsk = 0
639 DO 2100 p = igl, min( igl+kbl-1, n )
640*
641 aapp = sva( p )
642 IF( aapp.GT.zero ) THEN
643*
644 pskipped = 0
645*
646 DO 2200 q = jgl, min( jgl+kbl-1, n )
647*
648 aaqq = sva( q )
649 IF( aaqq.GT.zero ) THEN
650 aapp0 = aapp
651*
652* .. M x 2 Jacobi SVD ..
653*
654* Safe Gram matrix computation
655*
656 IF( aaqq.GE.one ) THEN
657 IF( aapp.GE.aaqq ) THEN
658 rotok = ( small*aapp ).LE.aaqq
659 ELSE
660 rotok = ( small*aaqq ).LE.aapp
661 END IF
662 IF( aapp.LT.( big / aaqq ) ) THEN
663 aapq = ( zdotc( m, a( 1, p ), 1,
664 $ a( 1, q ), 1 ) / aaqq ) / aapp
665 ELSE
666 CALL zcopy( m, a( 1, p ), 1,
667 $ work, 1 )
668 CALL zlascl( 'G', 0, 0, aapp,
669 $ one, m, 1,
670 $ work, lda, ierr )
671 aapq = zdotc( m, work, 1,
672 $ a( 1, q ), 1 ) / aaqq
673 END IF
674 ELSE
675 IF( aapp.GE.aaqq ) THEN
676 rotok = aapp.LE.( aaqq / small )
677 ELSE
678 rotok = aaqq.LE.( aapp / small )
679 END IF
680 IF( aapp.GT.( small / aaqq ) ) THEN
681 aapq = ( zdotc( m, a( 1, p ), 1,
682 $ a( 1, q ), 1 ) / max(aaqq,aapp) )
683 $ / min(aaqq,aapp)
684 ELSE
685 CALL zcopy( m, a( 1, q ), 1,
686 $ work, 1 )
687 CALL zlascl( 'G', 0, 0, aaqq,
688 $ one, m, 1,
689 $ work, lda, ierr )
690 aapq = zdotc( m, a( 1, p ), 1,
691 $ work, 1 ) / aapp
692 END IF
693 END IF
694*
695* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q)
696 aapq1 = -abs(aapq)
697 mxaapq = max( mxaapq, -aapq1 )
698*
699* TO rotate or NOT to rotate, THAT is the question ...
700*
701 IF( abs( aapq1 ).GT.tol ) THEN
702 ompq = aapq / abs(aapq)
703 notrot = 0
704*[RTD] ROTATED = ROTATED + 1
705 pskipped = 0
706 iswrot = iswrot + 1
707*
708 IF( rotok ) THEN
709*
710 aqoap = aaqq / aapp
711 apoaq = aapp / aaqq
712 theta = -half*abs( aqoap-apoaq )/ aapq1
713 IF( aaqq.GT.aapp0 )theta = -theta
714*
715 IF( abs( theta ).GT.bigtheta ) THEN
716 t = half / theta
717 cs = one
718 CALL zrot( m, a(1,p), 1, a(1,q), 1,
719 $ cs, conjg(ompq)*t )
720 IF( rsvec ) THEN
721 CALL zrot( mvl, v(1,p), 1,
722 $ v(1,q), 1, cs, conjg(ompq)*t )
723 END IF
724 sva( q ) = aaqq*sqrt( max( zero,
725 $ one+t*apoaq*aapq1 ) )
726 aapp = aapp*sqrt( max( zero,
727 $ one-t*aqoap*aapq1 ) )
728 mxsinj = max( mxsinj, abs( t ) )
729 ELSE
730*
731* .. choose correct signum for THETA and rotate
732*
733 thsign = -sign( one, aapq1 )
734 IF( aaqq.GT.aapp0 )thsign = -thsign
735 t = one / ( theta+thsign*
736 $ sqrt( one+theta*theta ) )
737 cs = sqrt( one / ( one+t*t ) )
738 sn = t*cs
739 mxsinj = max( mxsinj, abs( sn ) )
740 sva( q ) = aaqq*sqrt( max( zero,
741 $ one+t*apoaq*aapq1 ) )
742 aapp = aapp*sqrt( max( zero,
743 $ one-t*aqoap*aapq1 ) )
744*
745 CALL zrot( m, a(1,p), 1, a(1,q), 1,
746 $ cs, conjg(ompq)*sn )
747 IF( rsvec ) THEN
748 CALL zrot( mvl, v(1,p), 1,
749 $ v(1,q), 1, cs, conjg(ompq)*sn )
750 END IF
751 END IF
752 d(p) = -d(q) * ompq
753*
754 ELSE
755* .. have to use modified Gram-Schmidt like transformation
756 IF( aapp.GT.aaqq ) THEN
757 CALL zcopy( m, a( 1, p ), 1,
758 $ work, 1 )
759 CALL zlascl( 'G', 0, 0, aapp, one,
760 $ m, 1, work,lda,
761 $ ierr )
762 CALL zlascl( 'G', 0, 0, aaqq, one,
763 $ m, 1, a( 1, q ), lda,
764 $ ierr )
765 CALL zaxpy( m, -aapq, work,
766 $ 1, a( 1, q ), 1 )
767 CALL zlascl( 'G', 0, 0, one, aaqq,
768 $ m, 1, a( 1, q ), lda,
769 $ ierr )
770 sva( q ) = aaqq*sqrt( max( zero,
771 $ one-aapq1*aapq1 ) )
772 mxsinj = max( mxsinj, sfmin )
773 ELSE
774 CALL zcopy( m, a( 1, q ), 1,
775 $ work, 1 )
776 CALL zlascl( 'G', 0, 0, aaqq, one,
777 $ m, 1, work,lda,
778 $ ierr )
779 CALL zlascl( 'G', 0, 0, aapp, one,
780 $ m, 1, a( 1, p ), lda,
781 $ ierr )
782 CALL zaxpy( m, -conjg(aapq),
783 $ work, 1, a( 1, p ), 1 )
784 CALL zlascl( 'G', 0, 0, one, aapp,
785 $ m, 1, a( 1, p ), lda,
786 $ ierr )
787 sva( p ) = aapp*sqrt( max( zero,
788 $ one-aapq1*aapq1 ) )
789 mxsinj = max( mxsinj, sfmin )
790 END IF
791 END IF
792* END IF ROTOK THEN ... ELSE
793*
794* In the case of cancellation in updating SVA(q), SVA(p)
795* .. recompute SVA(q), SVA(p)
796 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
797 $ THEN
798 IF( ( aaqq.LT.rootbig ) .AND.
799 $ ( aaqq.GT.rootsfmin ) ) THEN
800 sva( q ) = dznrm2( m, a( 1, q ), 1)
801 ELSE
802 t = zero
803 aaqq = one
804 CALL zlassq( m, a( 1, q ), 1, t,
805 $ aaqq )
806 sva( q ) = t*sqrt( aaqq )
807 END IF
808 END IF
809 IF( ( aapp / aapp0 )**2.LE.rooteps ) THEN
810 IF( ( aapp.LT.rootbig ) .AND.
811 $ ( aapp.GT.rootsfmin ) ) THEN
812 aapp = dznrm2( m, a( 1, p ), 1 )
813 ELSE
814 t = zero
815 aapp = one
816 CALL zlassq( m, a( 1, p ), 1, t,
817 $ aapp )
818 aapp = t*sqrt( aapp )
819 END IF
820 sva( p ) = aapp
821 END IF
822* end of OK rotation
823 ELSE
824 notrot = notrot + 1
825*[RTD] SKIPPED = SKIPPED + 1
826 pskipped = pskipped + 1
827 ijblsk = ijblsk + 1
828 END IF
829 ELSE
830 notrot = notrot + 1
831 pskipped = pskipped + 1
832 ijblsk = ijblsk + 1
833 END IF
834*
835 IF( ( i.LE.swband ) .AND. ( ijblsk.GE.blskip ) )
836 $ THEN
837 sva( p ) = aapp
838 notrot = 0
839 GO TO 2011
840 END IF
841 IF( ( i.LE.swband ) .AND.
842 $ ( pskipped.GT.rowskip ) ) THEN
843 aapp = -aapp
844 notrot = 0
845 GO TO 2203
846 END IF
847*
848 2200 CONTINUE
849* end of the q-loop
850 2203 CONTINUE
851*
852 sva( p ) = aapp
853*
854 ELSE
855*
856 IF( aapp.EQ.zero )notrot = notrot +
857 $ min( jgl+kbl-1, n ) - jgl + 1
858 IF( aapp.LT.zero )notrot = 0
859*
860 END IF
861*
862 2100 CONTINUE
863* end of the p-loop
864 2010 CONTINUE
865* end of the jbc-loop
866 2011 CONTINUE
867*2011 bailed out of the jbc-loop
868 DO 2012 p = igl, min( igl+kbl-1, n )
869 sva( p ) = abs( sva( p ) )
870 2012 CONTINUE
871***
872 2000 CONTINUE
873*2000 :: end of the ibr-loop
874*
875* .. update SVA(N)
876 IF( ( sva( n ).LT.rootbig ) .AND. ( sva( n ).GT.rootsfmin ) )
877 $ THEN
878 sva( n ) = dznrm2( m, a( 1, n ), 1 )
879 ELSE
880 t = zero
881 aapp = one
882 CALL zlassq( m, a( 1, n ), 1, t, aapp )
883 sva( n ) = t*sqrt( aapp )
884 END IF
885*
886* Additional steering devices
887*
888 IF( ( i.LT.swband ) .AND. ( ( mxaapq.LE.roottol ) .OR.
889 $ ( iswrot.LE.n ) ) )swband = i
890*
891 IF( ( i.GT.swband+1 ) .AND. ( mxaapq.LT.sqrt( dble( n ) )*
892 $ tol ) .AND. ( dble( n )*mxaapq*mxsinj.LT.tol ) ) THEN
893 GO TO 1994
894 END IF
895*
896 IF( notrot.GE.emptsw )GO TO 1994
897*
898 1993 CONTINUE
899* end i=1:NSWEEP loop
900*
901* #:( Reaching this point means that the procedure has not converged.
902 info = nsweep - 1
903 GO TO 1995
904*
905 1994 CONTINUE
906* #:) Reaching this point means numerical convergence after the i-th
907* sweep.
908*
909 info = 0
910* #:) INFO = 0 confirms successful iterations.
911 1995 CONTINUE
912*
913* Sort the vector SVA() of column norms.
914 DO 5991 p = 1, n - 1
915 q = idamax( n-p+1, sva( p ), 1 ) + p - 1
916 IF( p.NE.q ) THEN
917 temp1 = sva( p )
918 sva( p ) = sva( q )
919 sva( q ) = temp1
920 aapq = d( p )
921 d( p ) = d( q )
922 d( q ) = aapq
923 CALL zswap( m, a( 1, p ), 1, a( 1, q ), 1 )
924 IF( rsvec )CALL zswap( mvl, v( 1, p ), 1, v( 1, q ), 1 )
925 END IF
926 5991 CONTINUE
927*
928 RETURN
929* ..
930* .. END OF ZGSVJ0
931* ..
zlassq
subroutine zlassq(n, x, incx, scl, sumsq)
ZLASSQ updates a sum of squares represented in scaled form.
Definition zlassq.f90:137
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71
zlascl
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.
Definition zlascl.f:143
zdotc
complex *16 function zdotc(n, zx, incx, zy, incy)
ZDOTC
Definition zdotc.f:83
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
zaxpy
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
Definition zaxpy.f:88
dznrm2
real(wp) function dznrm2(n, x, incx)
DZNRM2
Definition dznrm2.f90:90

◆ zgsvj1()

subroutine zgsvj1 ( character*1 jobv,
integer m,
integer n,
integer n1,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( n ) d,
double precision, dimension( n ) sva,
integer mv,
complex*16, dimension( ldv, * ) v,
integer ldv,
double precision eps,
double precision sfmin,
double precision tol,
integer nsweep,
complex*16, dimension( lwork ) work,
integer lwork,
integer info )

ZGSVJ1 pre-processor for the routine zgesvj, applies Jacobi rotations targeting only particular pivots.

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

Purpose:
!>
!> ZGSVJ1 is called from ZGESVJ as a pre-processor and that is its main
!> purpose. It applies Jacobi rotations in the same way as ZGESVJ does, but
!> it targets only particular pivots and it does not check convergence
!> (stopping criterion). Few tuning parameters (marked by [TP]) are
!> available for the implementer.
!>
!> Further Details
!> ~~~~~~~~~~~~~~~
!> ZGSVJ1 applies few sweeps of Jacobi rotations in the column space of
!> the input M-by-N matrix A. The pivot pairs are taken from the (1,2)
!> off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The
!> block-entries (tiles) of the (1,2) off-diagonal block are marked by the
!> [x]'s in the following scheme:
!>
!>    | *  *  * [x] [x] [x]|
!>    | *  *  * [x] [x] [x]|    Row-cycling in the nblr-by-nblc [x] blocks.
!>    | *  *  * [x] [x] [x]|    Row-cyclic pivoting inside each [x] block.
!>    |[x] [x] [x] *  *  * |
!>    |[x] [x] [x] *  *  * |
!>    |[x] [x] [x] *  *  * |
!>
!> In terms of the columns of A, the first N1 columns are rotated 'against'
!> the remaining N-N1 columns, trying to increase the angle between the
!> corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is
!> tiled using quadratic tiles of side KBL. Here, KBL is a tuning parameter.
!> The number of sweeps is given in NSWEEP and the orthogonality threshold
!> is given in TOL.
!>
Parameters
[in]JOBV
!>          JOBV is CHARACTER*1
!>          Specifies whether the output from this procedure is used
!>          to compute the matrix V:
!>          = 'V': the product of the Jacobi rotations is accumulated
!>                 by postmulyiplying the N-by-N array V.
!>                (See the description of V.)
!>          = 'A': the product of the Jacobi rotations is accumulated
!>                 by postmulyiplying the MV-by-N array V.
!>                (See the descriptions of MV and V.)
!>          = 'N': the Jacobi rotations are not accumulated.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the input matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the input matrix A.
!>          M >= N >= 0.
!>
[in]N1
!>          N1 is INTEGER
!>          N1 specifies the 2 x 2 block partition, the first N1 columns are
!>          rotated 'against' the remaining N-N1 columns of A.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, M-by-N matrix A, such that A*diag(D) represents
!>          the input matrix.
!>          On exit,
!>          A_onexit * D_onexit represents the input matrix A*diag(D)
!>          post-multiplied by a sequence of Jacobi rotations, where the
!>          rotation threshold and the total number of sweeps are given in
!>          TOL and NSWEEP, respectively.
!>          (See the descriptions of N1, D, TOL and NSWEEP.)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in,out]D
!>          D is COMPLEX*16 array, dimension (N)
!>          The array D accumulates the scaling factors from the fast scaled
!>          Jacobi rotations.
!>          On entry, A*diag(D) represents the input matrix.
!>          On exit, A_onexit*diag(D_onexit) represents the input matrix
!>          post-multiplied by a sequence of Jacobi rotations, where the
!>          rotation threshold and the total number of sweeps are given in
!>          TOL and NSWEEP, respectively.
!>          (See the descriptions of N1, A, TOL and NSWEEP.)
!>
[in,out]SVA
!>          SVA is DOUBLE PRECISION array, dimension (N)
!>          On entry, SVA contains the Euclidean norms of the columns of
!>          the matrix A*diag(D).
!>          On exit, SVA contains the Euclidean norms of the columns of
!>          the matrix onexit*diag(D_onexit).
!>
[in]MV
!>          MV is INTEGER
!>          If JOBV = 'A', then MV rows of V are post-multipled by a
!>                           sequence of Jacobi rotations.
!>          If JOBV = 'N',   then MV is not referenced.
!>
[in,out]V
!>          V is COMPLEX*16 array, dimension (LDV,N)
!>          If JOBV = 'V' then N rows of V are post-multipled by a
!>                           sequence of Jacobi rotations.
!>          If JOBV = 'A' then MV rows of V are post-multipled by a
!>                           sequence of Jacobi rotations.
!>          If JOBV = 'N',   then V is not referenced.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V,  LDV >= 1.
!>          If JOBV = 'V', LDV >= N.
!>          If JOBV = 'A', LDV >= MV.
!>
[in]EPS
!>          EPS is DOUBLE PRECISION
!>          EPS = DLAMCH('Epsilon')
!>
[in]SFMIN
!>          SFMIN is DOUBLE PRECISION
!>          SFMIN = DLAMCH('Safe Minimum')
!>
[in]TOL
!>          TOL is DOUBLE PRECISION
!>          TOL is the threshold for Jacobi rotations. For a pair
!>          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is
!>          applied only if ABS(COS(angle(A(:,p),A(:,q)))) > TOL.
!>
[in]NSWEEP
!>          NSWEEP is INTEGER
!>          NSWEEP is the number of sweeps of Jacobi rotations to be
!>          performed.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          LWORK is the dimension of WORK. LWORK >= M.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, then the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributor:
Zlatko Drmac (Zagreb, Croatia)

Definition at line 234 of file zgsvj1.f.

236*
237* -- LAPACK computational routine --
238* -- LAPACK is a software package provided by Univ. of Tennessee, --
239* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
240*
241 IMPLICIT NONE
242* .. Scalar Arguments ..
243 DOUBLE PRECISION EPS, SFMIN, TOL
244 INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP
245 CHARACTER*1 JOBV
246* ..
247* .. Array Arguments ..
248 COMPLEX*16 A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK )
249 DOUBLE PRECISION SVA( N )
250* ..
251*
252* =====================================================================
253*
254* .. Local Parameters ..
255 DOUBLE PRECISION ZERO, HALF, ONE
256 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0)
257* ..
258* .. Local Scalars ..
259 COMPLEX*16 AAPQ, OMPQ
260 DOUBLE PRECISION AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG,
261 $ BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG,
262 $ ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,
263 $ TEMP1, THETA, THSIGN
264 INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,
265 $ ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr,
266 $ p, PSKIPPED, q, ROWSKIP, SWBAND
267 LOGICAL APPLV, ROTOK, RSVEC
268* ..
269* ..
270* .. Intrinsic Functions ..
271 INTRINSIC abs, conjg, max, dble, min, sign, sqrt
272* ..
273* .. External Functions ..
274 DOUBLE PRECISION DZNRM2
275 COMPLEX*16 ZDOTC
276 INTEGER IDAMAX
277 LOGICAL LSAME
278 EXTERNAL idamax, lsame, zdotc, dznrm2
279* ..
280* .. External Subroutines ..
281* .. from BLAS
282 EXTERNAL zcopy, zrot, zswap, zaxpy
283* .. from LAPACK
284 EXTERNAL zlascl, zlassq, xerbla
285* ..
286* .. Executable Statements ..
287*
288* Test the input parameters.
289*
290 applv = lsame( jobv, 'A' )
291 rsvec = lsame( jobv, 'V' )
292 IF( .NOT.( rsvec .OR. applv .OR. lsame( jobv, 'N' ) ) ) THEN
293 info = -1
294 ELSE IF( m.LT.0 ) THEN
295 info = -2
296 ELSE IF( ( n.LT.0 ) .OR. ( n.GT.m ) ) THEN
297 info = -3
298 ELSE IF( n1.LT.0 ) THEN
299 info = -4
300 ELSE IF( lda.LT.m ) THEN
301 info = -6
302 ELSE IF( ( rsvec.OR.applv ) .AND. ( mv.LT.0 ) ) THEN
303 info = -9
304 ELSE IF( ( rsvec.AND.( ldv.LT.n ) ).OR.
305 $ ( applv.AND.( ldv.LT.mv ) ) ) THEN
306 info = -11
307 ELSE IF( tol.LE.eps ) THEN
308 info = -14
309 ELSE IF( nsweep.LT.0 ) THEN
310 info = -15
311 ELSE IF( lwork.LT.m ) THEN
312 info = -17
313 ELSE
314 info = 0
315 END IF
316*
317* #:(
318 IF( info.NE.0 ) THEN
319 CALL xerbla( 'ZGSVJ1', -info )
320 RETURN
321 END IF
322*
323 IF( rsvec ) THEN
324 mvl = n
325 ELSE IF( applv ) THEN
326 mvl = mv
327 END IF
328 rsvec = rsvec .OR. applv
329
330 rooteps = sqrt( eps )
331 rootsfmin = sqrt( sfmin )
332 small = sfmin / eps
333 big = one / sfmin
334 rootbig = one / rootsfmin
335* LARGE = BIG / SQRT( DBLE( M*N ) )
336 bigtheta = one / rooteps
337 roottol = sqrt( tol )
338*
339* .. Initialize the right singular vector matrix ..
340*
341* RSVEC = LSAME( JOBV, 'Y' )
342*
343 emptsw = n1*( n-n1 )
344 notrot = 0
345*
346* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
347*
348 kbl = min( 8, n )
349 nblr = n1 / kbl
350 IF( ( nblr*kbl ).NE.n1 )nblr = nblr + 1
351
352* .. the tiling is nblr-by-nblc [tiles]
353
354 nblc = ( n-n1 ) / kbl
355 IF( ( nblc*kbl ).NE.( n-n1 ) )nblc = nblc + 1
356 blskip = ( kbl**2 ) + 1
357*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
358
359 rowskip = min( 5, kbl )
360*[TP] ROWSKIP is a tuning parameter.
361 swband = 0
362*[TP] SWBAND is a tuning parameter. It is meaningful and effective
363* if ZGESVJ is used as a computational routine in the preconditioned
364* Jacobi SVD algorithm ZGEJSV.
365*
366*
367* | * * * [x] [x] [x]|
368* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks.
369* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block.
370* |[x] [x] [x] * * * |
371* |[x] [x] [x] * * * |
372* |[x] [x] [x] * * * |
373*
374*
375 DO 1993 i = 1, nsweep
376*
377* .. go go go ...
378*
379 mxaapq = zero
380 mxsinj = zero
381 iswrot = 0
382*
383 notrot = 0
384 pskipped = 0
385*
386* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs
387* 1 <= p < q <= N. This is the first step toward a blocked implementation
388* of the rotations. New implementation, based on block transformations,
389* is under development.
390*
391 DO 2000 ibr = 1, nblr
392*
393 igl = ( ibr-1 )*kbl + 1
394*
395
396*
397* ... go to the off diagonal blocks
398*
399 igl = ( ibr-1 )*kbl + 1
400*
401* DO 2010 jbc = ibr + 1, NBL
402 DO 2010 jbc = 1, nblc
403*
404 jgl = ( jbc-1 )*kbl + n1 + 1
405*
406* doing the block at ( ibr, jbc )
407*
408 ijblsk = 0
409 DO 2100 p = igl, min( igl+kbl-1, n1 )
410*
411 aapp = sva( p )
412 IF( aapp.GT.zero ) THEN
413*
414 pskipped = 0
415*
416 DO 2200 q = jgl, min( jgl+kbl-1, n )
417*
418 aaqq = sva( q )
419 IF( aaqq.GT.zero ) THEN
420 aapp0 = aapp
421*
422* .. M x 2 Jacobi SVD ..
423*
424* Safe Gram matrix computation
425*
426 IF( aaqq.GE.one ) THEN
427 IF( aapp.GE.aaqq ) THEN
428 rotok = ( small*aapp ).LE.aaqq
429 ELSE
430 rotok = ( small*aaqq ).LE.aapp
431 END IF
432 IF( aapp.LT.( big / aaqq ) ) THEN
433 aapq = ( zdotc( m, a( 1, p ), 1,
434 $ a( 1, q ), 1 ) / aaqq ) / aapp
435 ELSE
436 CALL zcopy( m, a( 1, p ), 1,
437 $ work, 1 )
438 CALL zlascl( 'G', 0, 0, aapp,
439 $ one, m, 1,
440 $ work, lda, ierr )
441 aapq = zdotc( m, work, 1,
442 $ a( 1, q ), 1 ) / aaqq
443 END IF
444 ELSE
445 IF( aapp.GE.aaqq ) THEN
446 rotok = aapp.LE.( aaqq / small )
447 ELSE
448 rotok = aaqq.LE.( aapp / small )
449 END IF
450 IF( aapp.GT.( small / aaqq ) ) THEN
451 aapq = ( zdotc( m, a( 1, p ), 1,
452 $ a( 1, q ), 1 ) / max(aaqq,aapp) )
453 $ / min(aaqq,aapp)
454 ELSE
455 CALL zcopy( m, a( 1, q ), 1,
456 $ work, 1 )
457 CALL zlascl( 'G', 0, 0, aaqq,
458 $ one, m, 1,
459 $ work, lda, ierr )
460 aapq = zdotc( m, a( 1, p ), 1,
461 $ work, 1 ) / aapp
462 END IF
463 END IF
464*
465* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q)
466 aapq1 = -abs(aapq)
467 mxaapq = max( mxaapq, -aapq1 )
468*
469* TO rotate or NOT to rotate, THAT is the question ...
470*
471 IF( abs( aapq1 ).GT.tol ) THEN
472 ompq = aapq / abs(aapq)
473 notrot = 0
474*[RTD] ROTATED = ROTATED + 1
475 pskipped = 0
476 iswrot = iswrot + 1
477*
478 IF( rotok ) THEN
479*
480 aqoap = aaqq / aapp
481 apoaq = aapp / aaqq
482 theta = -half*abs( aqoap-apoaq )/ aapq1
483 IF( aaqq.GT.aapp0 )theta = -theta
484*
485 IF( abs( theta ).GT.bigtheta ) THEN
486 t = half / theta
487 cs = one
488 CALL zrot( m, a(1,p), 1, a(1,q), 1,
489 $ cs, conjg(ompq)*t )
490 IF( rsvec ) THEN
491 CALL zrot( mvl, v(1,p), 1,
492 $ v(1,q), 1, cs, conjg(ompq)*t )
493 END IF
494 sva( q ) = aaqq*sqrt( max( zero,
495 $ one+t*apoaq*aapq1 ) )
496 aapp = aapp*sqrt( max( zero,
497 $ one-t*aqoap*aapq1 ) )
498 mxsinj = max( mxsinj, abs( t ) )
499 ELSE
500*
501* .. choose correct signum for THETA and rotate
502*
503 thsign = -sign( one, aapq1 )
504 IF( aaqq.GT.aapp0 )thsign = -thsign
505 t = one / ( theta+thsign*
506 $ sqrt( one+theta*theta ) )
507 cs = sqrt( one / ( one+t*t ) )
508 sn = t*cs
509 mxsinj = max( mxsinj, abs( sn ) )
510 sva( q ) = aaqq*sqrt( max( zero,
511 $ one+t*apoaq*aapq1 ) )
512 aapp = aapp*sqrt( max( zero,
513 $ one-t*aqoap*aapq1 ) )
514*
515 CALL zrot( m, a(1,p), 1, a(1,q), 1,
516 $ cs, conjg(ompq)*sn )
517 IF( rsvec ) THEN
518 CALL zrot( mvl, v(1,p), 1,
519 $ v(1,q), 1, cs, conjg(ompq)*sn )
520 END IF
521 END IF
522 d(p) = -d(q) * ompq
523*
524 ELSE
525* .. have to use modified Gram-Schmidt like transformation
526 IF( aapp.GT.aaqq ) THEN
527 CALL zcopy( m, a( 1, p ), 1,
528 $ work, 1 )
529 CALL zlascl( 'G', 0, 0, aapp, one,
530 $ m, 1, work,lda,
531 $ ierr )
532 CALL zlascl( 'G', 0, 0, aaqq, one,
533 $ m, 1, a( 1, q ), lda,
534 $ ierr )
535 CALL zaxpy( m, -aapq, work,
536 $ 1, a( 1, q ), 1 )
537 CALL zlascl( 'G', 0, 0, one, aaqq,
538 $ m, 1, a( 1, q ), lda,
539 $ ierr )
540 sva( q ) = aaqq*sqrt( max( zero,
541 $ one-aapq1*aapq1 ) )
542 mxsinj = max( mxsinj, sfmin )
543 ELSE
544 CALL zcopy( m, a( 1, q ), 1,
545 $ work, 1 )
546 CALL zlascl( 'G', 0, 0, aaqq, one,
547 $ m, 1, work,lda,
548 $ ierr )
549 CALL zlascl( 'G', 0, 0, aapp, one,
550 $ m, 1, a( 1, p ), lda,
551 $ ierr )
552 CALL zaxpy( m, -conjg(aapq),
553 $ work, 1, a( 1, p ), 1 )
554 CALL zlascl( 'G', 0, 0, one, aapp,
555 $ m, 1, a( 1, p ), lda,
556 $ ierr )
557 sva( p ) = aapp*sqrt( max( zero,
558 $ one-aapq1*aapq1 ) )
559 mxsinj = max( mxsinj, sfmin )
560 END IF
561 END IF
562* END IF ROTOK THEN ... ELSE
563*
564* In the case of cancellation in updating SVA(q), SVA(p)
565* .. recompute SVA(q), SVA(p)
566 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
567 $ THEN
568 IF( ( aaqq.LT.rootbig ) .AND.
569 $ ( aaqq.GT.rootsfmin ) ) THEN
570 sva( q ) = dznrm2( m, a( 1, q ), 1)
571 ELSE
572 t = zero
573 aaqq = one
574 CALL zlassq( m, a( 1, q ), 1, t,
575 $ aaqq )
576 sva( q ) = t*sqrt( aaqq )
577 END IF
578 END IF
579 IF( ( aapp / aapp0 )**2.LE.rooteps ) THEN
580 IF( ( aapp.LT.rootbig ) .AND.
581 $ ( aapp.GT.rootsfmin ) ) THEN
582 aapp = dznrm2( m, a( 1, p ), 1 )
583 ELSE
584 t = zero
585 aapp = one
586 CALL zlassq( m, a( 1, p ), 1, t,
587 $ aapp )
588 aapp = t*sqrt( aapp )
589 END IF
590 sva( p ) = aapp
591 END IF
592* end of OK rotation
593 ELSE
594 notrot = notrot + 1
595*[RTD] SKIPPED = SKIPPED + 1
596 pskipped = pskipped + 1
597 ijblsk = ijblsk + 1
598 END IF
599 ELSE
600 notrot = notrot + 1
601 pskipped = pskipped + 1
602 ijblsk = ijblsk + 1
603 END IF
604*
605 IF( ( i.LE.swband ) .AND. ( ijblsk.GE.blskip ) )
606 $ THEN
607 sva( p ) = aapp
608 notrot = 0
609 GO TO 2011
610 END IF
611 IF( ( i.LE.swband ) .AND.
612 $ ( pskipped.GT.rowskip ) ) THEN
613 aapp = -aapp
614 notrot = 0
615 GO TO 2203
616 END IF
617*
618 2200 CONTINUE
619* end of the q-loop
620 2203 CONTINUE
621*
622 sva( p ) = aapp
623*
624 ELSE
625*
626 IF( aapp.EQ.zero )notrot = notrot +
627 $ min( jgl+kbl-1, n ) - jgl + 1
628 IF( aapp.LT.zero )notrot = 0
629*
630 END IF
631*
632 2100 CONTINUE
633* end of the p-loop
634 2010 CONTINUE
635* end of the jbc-loop
636 2011 CONTINUE
637*2011 bailed out of the jbc-loop
638 DO 2012 p = igl, min( igl+kbl-1, n )
639 sva( p ) = abs( sva( p ) )
640 2012 CONTINUE
641***
642 2000 CONTINUE
643*2000 :: end of the ibr-loop
644*
645* .. update SVA(N)
646 IF( ( sva( n ).LT.rootbig ) .AND. ( sva( n ).GT.rootsfmin ) )
647 $ THEN
648 sva( n ) = dznrm2( m, a( 1, n ), 1 )
649 ELSE
650 t = zero
651 aapp = one
652 CALL zlassq( m, a( 1, n ), 1, t, aapp )
653 sva( n ) = t*sqrt( aapp )
654 END IF
655*
656* Additional steering devices
657*
658 IF( ( i.LT.swband ) .AND. ( ( mxaapq.LE.roottol ) .OR.
659 $ ( iswrot.LE.n ) ) )swband = i
660*
661 IF( ( i.GT.swband+1 ) .AND. ( mxaapq.LT.sqrt( dble( n ) )*
662 $ tol ) .AND. ( dble( n )*mxaapq*mxsinj.LT.tol ) ) THEN
663 GO TO 1994
664 END IF
665*
666 IF( notrot.GE.emptsw )GO TO 1994
667*
668 1993 CONTINUE
669* end i=1:NSWEEP loop
670*
671* #:( Reaching this point means that the procedure has not converged.
672 info = nsweep - 1
673 GO TO 1995
674*
675 1994 CONTINUE
676* #:) Reaching this point means numerical convergence after the i-th
677* sweep.
678*
679 info = 0
680* #:) INFO = 0 confirms successful iterations.
681 1995 CONTINUE
682*
683* Sort the vector SVA() of column norms.
684 DO 5991 p = 1, n - 1
685 q = idamax( n-p+1, sva( p ), 1 ) + p - 1
686 IF( p.NE.q ) THEN
687 temp1 = sva( p )
688 sva( p ) = sva( q )
689 sva( q ) = temp1
690 aapq = d( p )
691 d( p ) = d( q )
692 d( q ) = aapq
693 CALL zswap( m, a( 1, p ), 1, a( 1, q ), 1 )
694 IF( rsvec )CALL zswap( mvl, v( 1, p ), 1, v( 1, q ), 1 )
695 END IF
696 5991 CONTINUE
697*
698*
699 RETURN
700* ..
701* .. END OF ZGSVJ1
702* ..

◆ zhbgst()

subroutine zhbgst ( character vect,
character uplo,
integer n,
integer ka,
integer kb,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( ldbb, * ) bb,
integer ldbb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZHBGST

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

Purpose:
!>
!> ZHBGST reduces a complex Hermitian-definite banded generalized
!> eigenproblem  A*x = lambda*B*x  to standard form  C*y = lambda*y,
!> such that C has the same bandwidth as A.
!>
!> B must have been previously factorized as S**H*S by ZPBSTF, using a
!> split Cholesky factorization. A is overwritten by C = X**H*A*X, where
!> X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the
!> bandwidth of A.
!>
Parameters
[in]VECT
!>          VECT is CHARACTER*1
!>          = 'N':  do not form the transformation matrix X;
!>          = 'V':  form X.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!>
[in]KA
!>          KA is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
!>
[in]KB
!>          KB is INTEGER
!>          The number of superdiagonals of the matrix B if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.
!>
[in,out]AB
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          On entry, the upper or lower triangle of the Hermitian band
!>          matrix A, stored in the first ka+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(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
!>
!>          On exit, the transformed matrix X**H*A*X, stored in the same
!>          format as A.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KA+1.
!>
[in]BB
!>          BB is COMPLEX*16 array, dimension (LDBB,N)
!>          The banded factor S from the split Cholesky factorization of
!>          B, as returned by ZPBSTF, stored in the first kb+1 rows of
!>          the array.
!>
[in]LDBB
!>          LDBB is INTEGER
!>          The leading dimension of the array BB.  LDBB >= KB+1.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (LDX,N)
!>          If VECT = 'V', the n-by-n matrix X.
!>          If VECT = 'N', the array X is not referenced.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.
!>          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 163 of file zhbgst.f.

165*
166* -- LAPACK computational routine --
167* -- LAPACK is a software package provided by Univ. of Tennessee, --
168* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
169*
170* .. Scalar Arguments ..
171 CHARACTER UPLO, VECT
172 INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N
173* ..
174* .. Array Arguments ..
175 DOUBLE PRECISION RWORK( * )
176 COMPLEX*16 AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
177 $ X( LDX, * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 COMPLEX*16 CZERO, CONE
184 DOUBLE PRECISION ONE
185 parameter( czero = ( 0.0d+0, 0.0d+0 ),
186 $ cone = ( 1.0d+0, 0.0d+0 ), one = 1.0d+0 )
187* ..
188* .. Local Scalars ..
189 LOGICAL UPDATE, UPPER, WANTX
190 INTEGER I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K,
191 $ KA1, KB1, KBT, L, M, NR, NRT, NX
192 DOUBLE PRECISION BII
193 COMPLEX*16 RA, RA1, T
194* ..
195* .. External Functions ..
196 LOGICAL LSAME
197 EXTERNAL lsame
198* ..
199* .. External Subroutines ..
200 EXTERNAL xerbla, zdscal, zgerc, zgeru, zlacgv, zlar2v,
201 $ zlargv, zlartg, zlartv, zlaset, zrot
202* ..
203* .. Intrinsic Functions ..
204 INTRINSIC dble, dconjg, max, min
205* ..
206* .. Executable Statements ..
207*
208* Test the input parameters
209*
210 wantx = lsame( vect, 'V' )
211 upper = lsame( uplo, 'U' )
212 ka1 = ka + 1
213 kb1 = kb + 1
214 info = 0
215 IF( .NOT.wantx .AND. .NOT.lsame( vect, 'N' ) ) THEN
216 info = -1
217 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
218 info = -2
219 ELSE IF( n.LT.0 ) THEN
220 info = -3
221 ELSE IF( ka.LT.0 ) THEN
222 info = -4
223 ELSE IF( kb.LT.0 .OR. kb.GT.ka ) THEN
224 info = -5
225 ELSE IF( ldab.LT.ka+1 ) THEN
226 info = -7
227 ELSE IF( ldbb.LT.kb+1 ) THEN
228 info = -9
229 ELSE IF( ldx.LT.1 .OR. wantx .AND. ldx.LT.max( 1, n ) ) THEN
230 info = -11
231 END IF
232 IF( info.NE.0 ) THEN
233 CALL xerbla( 'ZHBGST', -info )
234 RETURN
235 END IF
236*
237* Quick return if possible
238*
239 IF( n.EQ.0 )
240 $ RETURN
241*
242 inca = ldab*ka1
243*
244* Initialize X to the unit matrix, if needed
245*
246 IF( wantx )
247 $ CALL zlaset( 'Full', n, n, czero, cone, x, ldx )
248*
249* Set M to the splitting point m. It must be the same value as is
250* used in ZPBSTF. The chosen value allows the arrays WORK and RWORK
251* to be of dimension (N).
252*
253 m = ( n+kb ) / 2
254*
255* The routine works in two phases, corresponding to the two halves
256* of the split Cholesky factorization of B as S**H*S where
257*
258* S = ( U )
259* ( M L )
260*
261* with U upper triangular of order m, and L lower triangular of
262* order n-m. S has the same bandwidth as B.
263*
264* S is treated as a product of elementary matrices:
265*
266* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
267*
268* where S(i) is determined by the i-th row of S.
269*
270* In phase 1, the index i takes the values n, n-1, ... , m+1;
271* in phase 2, it takes the values 1, 2, ... , m.
272*
273* For each value of i, the current matrix A is updated by forming
274* inv(S(i))**H*A*inv(S(i)). This creates a triangular bulge outside
275* the band of A. The bulge is then pushed down toward the bottom of
276* A in phase 1, and up toward the top of A in phase 2, by applying
277* plane rotations.
278*
279* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
280* of them are linearly independent, so annihilating a bulge requires
281* only 2*kb-1 plane rotations. The rotations are divided into a 1st
282* set of kb-1 rotations, and a 2nd set of kb rotations.
283*
284* Wherever possible, rotations are generated and applied in vector
285* operations of length NR between the indices J1 and J2 (sometimes
286* replaced by modified values NRT, J1T or J2T).
287*
288* The real cosines and complex sines of the rotations are stored in
289* the arrays RWORK and WORK, those of the 1st set in elements
290* 2:m-kb-1, and those of the 2nd set in elements m-kb+1:n.
291*
292* The bulges are not formed explicitly; nonzero elements outside the
293* band are created only when they are required for generating new
294* rotations; they are stored in the array WORK, in positions where
295* they are later overwritten by the sines of the rotations which
296* annihilate them.
297*
298* **************************** Phase 1 *****************************
299*
300* The logical structure of this phase is:
301*
302* UPDATE = .TRUE.
303* DO I = N, M + 1, -1
304* use S(i) to update A and create a new bulge
305* apply rotations to push all bulges KA positions downward
306* END DO
307* UPDATE = .FALSE.
308* DO I = M + KA + 1, N - 1
309* apply rotations to push all bulges KA positions downward
310* END DO
311*
312* To avoid duplicating code, the two loops are merged.
313*
314 update = .true.
315 i = n + 1
316 10 CONTINUE
317 IF( update ) THEN
318 i = i - 1
319 kbt = min( kb, i-1 )
320 i0 = i - 1
321 i1 = min( n, i+ka )
322 i2 = i - kbt + ka1
323 IF( i.LT.m+1 ) THEN
324 update = .false.
325 i = i + 1
326 i0 = m
327 IF( ka.EQ.0 )
328 $ GO TO 480
329 GO TO 10
330 END IF
331 ELSE
332 i = i + ka
333 IF( i.GT.n-1 )
334 $ GO TO 480
335 END IF
336*
337 IF( upper ) THEN
338*
339* Transform A, working with the upper triangle
340*
341 IF( update ) THEN
342*
343* Form inv(S(i))**H * A * inv(S(i))
344*
345 bii = dble( bb( kb1, i ) )
346 ab( ka1, i ) = ( dble( ab( ka1, i ) ) / bii ) / bii
347 DO 20 j = i + 1, i1
348 ab( i-j+ka1, j ) = ab( i-j+ka1, j ) / bii
349 20 CONTINUE
350 DO 30 j = max( 1, i-ka ), i - 1
351 ab( j-i+ka1, i ) = ab( j-i+ka1, i ) / bii
352 30 CONTINUE
353 DO 60 k = i - kbt, i - 1
354 DO 40 j = i - kbt, k
355 ab( j-k+ka1, k ) = ab( j-k+ka1, k ) -
356 $ bb( j-i+kb1, i )*
357 $ dconjg( ab( k-i+ka1, i ) ) -
358 $ dconjg( bb( k-i+kb1, i ) )*
359 $ ab( j-i+ka1, i ) +
360 $ dble( ab( ka1, i ) )*
361 $ bb( j-i+kb1, i )*
362 $ dconjg( bb( k-i+kb1, i ) )
363 40 CONTINUE
364 DO 50 j = max( 1, i-ka ), i - kbt - 1
365 ab( j-k+ka1, k ) = ab( j-k+ka1, k ) -
366 $ dconjg( bb( k-i+kb1, i ) )*
367 $ ab( j-i+ka1, i )
368 50 CONTINUE
369 60 CONTINUE
370 DO 80 j = i, i1
371 DO 70 k = max( j-ka, i-kbt ), i - 1
372 ab( k-j+ka1, j ) = ab( k-j+ka1, j ) -
373 $ bb( k-i+kb1, i )*ab( i-j+ka1, j )
374 70 CONTINUE
375 80 CONTINUE
376*
377 IF( wantx ) THEN
378*
379* post-multiply X by inv(S(i))
380*
381 CALL zdscal( n-m, one / bii, x( m+1, i ), 1 )
382 IF( kbt.GT.0 )
383 $ CALL zgerc( n-m, kbt, -cone, x( m+1, i ), 1,
384 $ bb( kb1-kbt, i ), 1, x( m+1, i-kbt ),
385 $ ldx )
386 END IF
387*
388* store a(i,i1) in RA1 for use in next loop over K
389*
390 ra1 = ab( i-i1+ka1, i1 )
391 END IF
392*
393* Generate and apply vectors of rotations to chase all the
394* existing bulges KA positions down toward the bottom of the
395* band
396*
397 DO 130 k = 1, kb - 1
398 IF( update ) THEN
399*
400* Determine the rotations which would annihilate the bulge
401* which has in theory just been created
402*
403 IF( i-k+ka.LT.n .AND. i-k.GT.1 ) THEN
404*
405* generate rotation to annihilate a(i,i-k+ka+1)
406*
407 CALL zlartg( ab( k+1, i-k+ka ), ra1,
408 $ rwork( i-k+ka-m ), work( i-k+ka-m ), ra )
409*
410* create nonzero element a(i-k,i-k+ka+1) outside the
411* band and store it in WORK(i-k)
412*
413 t = -bb( kb1-k, i )*ra1
414 work( i-k ) = rwork( i-k+ka-m )*t -
415 $ dconjg( work( i-k+ka-m ) )*
416 $ ab( 1, i-k+ka )
417 ab( 1, i-k+ka ) = work( i-k+ka-m )*t +
418 $ rwork( i-k+ka-m )*ab( 1, i-k+ka )
419 ra1 = ra
420 END IF
421 END IF
422 j2 = i - k - 1 + max( 1, k-i0+2 )*ka1
423 nr = ( n-j2+ka ) / ka1
424 j1 = j2 + ( nr-1 )*ka1
425 IF( update ) THEN
426 j2t = max( j2, i+2*ka-k+1 )
427 ELSE
428 j2t = j2
429 END IF
430 nrt = ( n-j2t+ka ) / ka1
431 DO 90 j = j2t, j1, ka1
432*
433* create nonzero element a(j-ka,j+1) outside the band
434* and store it in WORK(j-m)
435*
436 work( j-m ) = work( j-m )*ab( 1, j+1 )
437 ab( 1, j+1 ) = rwork( j-m )*ab( 1, j+1 )
438 90 CONTINUE
439*
440* generate rotations in 1st set to annihilate elements which
441* have been created outside the band
442*
443 IF( nrt.GT.0 )
444 $ CALL zlargv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1,
445 $ rwork( j2t-m ), ka1 )
446 IF( nr.GT.0 ) THEN
447*
448* apply rotations in 1st set from the right
449*
450 DO 100 l = 1, ka - 1
451 CALL zlartv( nr, ab( ka1-l, j2 ), inca,
452 $ ab( ka-l, j2+1 ), inca, rwork( j2-m ),
453 $ work( j2-m ), ka1 )
454 100 CONTINUE
455*
456* apply rotations in 1st set from both sides to diagonal
457* blocks
458*
459 CALL zlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),
460 $ ab( ka, j2+1 ), inca, rwork( j2-m ),
461 $ work( j2-m ), ka1 )
462*
463 CALL zlacgv( nr, work( j2-m ), ka1 )
464 END IF
465*
466* start applying rotations in 1st set from the left
467*
468 DO 110 l = ka - 1, kb - k + 1, -1
469 nrt = ( n-j2+l ) / ka1
470 IF( nrt.GT.0 )
471 $ CALL zlartv( nrt, ab( l, j2+ka1-l ), inca,
472 $ ab( l+1, j2+ka1-l ), inca, rwork( j2-m ),
473 $ work( j2-m ), ka1 )
474 110 CONTINUE
475*
476 IF( wantx ) THEN
477*
478* post-multiply X by product of rotations in 1st set
479*
480 DO 120 j = j2, j1, ka1
481 CALL zrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,
482 $ rwork( j-m ), dconjg( work( j-m ) ) )
483 120 CONTINUE
484 END IF
485 130 CONTINUE
486*
487 IF( update ) THEN
488 IF( i2.LE.n .AND. kbt.GT.0 ) THEN
489*
490* create nonzero element a(i-kbt,i-kbt+ka+1) outside the
491* band and store it in WORK(i-kbt)
492*
493 work( i-kbt ) = -bb( kb1-kbt, i )*ra1
494 END IF
495 END IF
496*
497 DO 170 k = kb, 1, -1
498 IF( update ) THEN
499 j2 = i - k - 1 + max( 2, k-i0+1 )*ka1
500 ELSE
501 j2 = i - k - 1 + max( 1, k-i0+1 )*ka1
502 END IF
503*
504* finish applying rotations in 2nd set from the left
505*
506 DO 140 l = kb - k, 1, -1
507 nrt = ( n-j2+ka+l ) / ka1
508 IF( nrt.GT.0 )
509 $ CALL zlartv( nrt, ab( l, j2-l+1 ), inca,
510 $ ab( l+1, j2-l+1 ), inca, rwork( j2-ka ),
511 $ work( j2-ka ), ka1 )
512 140 CONTINUE
513 nr = ( n-j2+ka ) / ka1
514 j1 = j2 + ( nr-1 )*ka1
515 DO 150 j = j1, j2, -ka1
516 work( j ) = work( j-ka )
517 rwork( j ) = rwork( j-ka )
518 150 CONTINUE
519 DO 160 j = j2, j1, ka1
520*
521* create nonzero element a(j-ka,j+1) outside the band
522* and store it in WORK(j)
523*
524 work( j ) = work( j )*ab( 1, j+1 )
525 ab( 1, j+1 ) = rwork( j )*ab( 1, j+1 )
526 160 CONTINUE
527 IF( update ) THEN
528 IF( i-k.LT.n-ka .AND. k.LE.kbt )
529 $ work( i-k+ka ) = work( i-k )
530 END IF
531 170 CONTINUE
532*
533 DO 210 k = kb, 1, -1
534 j2 = i - k - 1 + max( 1, k-i0+1 )*ka1
535 nr = ( n-j2+ka ) / ka1
536 j1 = j2 + ( nr-1 )*ka1
537 IF( nr.GT.0 ) THEN
538*
539* generate rotations in 2nd set to annihilate elements
540* which have been created outside the band
541*
542 CALL zlargv( nr, ab( 1, j2 ), inca, work( j2 ), ka1,
543 $ rwork( j2 ), ka1 )
544*
545* apply rotations in 2nd set from the right
546*
547 DO 180 l = 1, ka - 1
548 CALL zlartv( nr, ab( ka1-l, j2 ), inca,
549 $ ab( ka-l, j2+1 ), inca, rwork( j2 ),
550 $ work( j2 ), ka1 )
551 180 CONTINUE
552*
553* apply rotations in 2nd set from both sides to diagonal
554* blocks
555*
556 CALL zlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),
557 $ ab( ka, j2+1 ), inca, rwork( j2 ),
558 $ work( j2 ), ka1 )
559*
560 CALL zlacgv( nr, work( j2 ), ka1 )
561 END IF
562*
563* start applying rotations in 2nd set from the left
564*
565 DO 190 l = ka - 1, kb - k + 1, -1
566 nrt = ( n-j2+l ) / ka1
567 IF( nrt.GT.0 )
568 $ CALL zlartv( nrt, ab( l, j2+ka1-l ), inca,
569 $ ab( l+1, j2+ka1-l ), inca, rwork( j2 ),
570 $ work( j2 ), ka1 )
571 190 CONTINUE
572*
573 IF( wantx ) THEN
574*
575* post-multiply X by product of rotations in 2nd set
576*
577 DO 200 j = j2, j1, ka1
578 CALL zrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,
579 $ rwork( j ), dconjg( work( j ) ) )
580 200 CONTINUE
581 END IF
582 210 CONTINUE
583*
584 DO 230 k = 1, kb - 1
585 j2 = i - k - 1 + max( 1, k-i0+2 )*ka1
586*
587* finish applying rotations in 1st set from the left
588*
589 DO 220 l = kb - k, 1, -1
590 nrt = ( n-j2+l ) / ka1
591 IF( nrt.GT.0 )
592 $ CALL zlartv( nrt, ab( l, j2+ka1-l ), inca,
593 $ ab( l+1, j2+ka1-l ), inca, rwork( j2-m ),
594 $ work( j2-m ), ka1 )
595 220 CONTINUE
596 230 CONTINUE
597*
598 IF( kb.GT.1 ) THEN
599 DO 240 j = n - 1, j2 + ka, -1
600 rwork( j-m ) = rwork( j-ka-m )
601 work( j-m ) = work( j-ka-m )
602 240 CONTINUE
603 END IF
604*
605 ELSE
606*
607* Transform A, working with the lower triangle
608*
609 IF( update ) THEN
610*
611* Form inv(S(i))**H * A * inv(S(i))
612*
613 bii = dble( bb( 1, i ) )
614 ab( 1, i ) = ( dble( ab( 1, i ) ) / bii ) / bii
615 DO 250 j = i + 1, i1
616 ab( j-i+1, i ) = ab( j-i+1, i ) / bii
617 250 CONTINUE
618 DO 260 j = max( 1, i-ka ), i - 1
619 ab( i-j+1, j ) = ab( i-j+1, j ) / bii
620 260 CONTINUE
621 DO 290 k = i - kbt, i - 1
622 DO 270 j = i - kbt, k
623 ab( k-j+1, j ) = ab( k-j+1, j ) -
624 $ bb( i-j+1, j )*dconjg( ab( i-k+1,
625 $ k ) ) - dconjg( bb( i-k+1, k ) )*
626 $ ab( i-j+1, j ) + dble( ab( 1, i ) )*
627 $ bb( i-j+1, j )*dconjg( bb( i-k+1,
628 $ k ) )
629 270 CONTINUE
630 DO 280 j = max( 1, i-ka ), i - kbt - 1
631 ab( k-j+1, j ) = ab( k-j+1, j ) -
632 $ dconjg( bb( i-k+1, k ) )*
633 $ ab( i-j+1, j )
634 280 CONTINUE
635 290 CONTINUE
636 DO 310 j = i, i1
637 DO 300 k = max( j-ka, i-kbt ), i - 1
638 ab( j-k+1, k ) = ab( j-k+1, k ) -
639 $ bb( i-k+1, k )*ab( j-i+1, i )
640 300 CONTINUE
641 310 CONTINUE
642*
643 IF( wantx ) THEN
644*
645* post-multiply X by inv(S(i))
646*
647 CALL zdscal( n-m, one / bii, x( m+1, i ), 1 )
648 IF( kbt.GT.0 )
649 $ CALL zgeru( n-m, kbt, -cone, x( m+1, i ), 1,
650 $ bb( kbt+1, i-kbt ), ldbb-1,
651 $ x( m+1, i-kbt ), ldx )
652 END IF
653*
654* store a(i1,i) in RA1 for use in next loop over K
655*
656 ra1 = ab( i1-i+1, i )
657 END IF
658*
659* Generate and apply vectors of rotations to chase all the
660* existing bulges KA positions down toward the bottom of the
661* band
662*
663 DO 360 k = 1, kb - 1
664 IF( update ) THEN
665*
666* Determine the rotations which would annihilate the bulge
667* which has in theory just been created
668*
669 IF( i-k+ka.LT.n .AND. i-k.GT.1 ) THEN
670*
671* generate rotation to annihilate a(i-k+ka+1,i)
672*
673 CALL zlartg( ab( ka1-k, i ), ra1, rwork( i-k+ka-m ),
674 $ work( i-k+ka-m ), ra )
675*
676* create nonzero element a(i-k+ka+1,i-k) outside the
677* band and store it in WORK(i-k)
678*
679 t = -bb( k+1, i-k )*ra1
680 work( i-k ) = rwork( i-k+ka-m )*t -
681 $ dconjg( work( i-k+ka-m ) )*
682 $ ab( ka1, i-k )
683 ab( ka1, i-k ) = work( i-k+ka-m )*t +
684 $ rwork( i-k+ka-m )*ab( ka1, i-k )
685 ra1 = ra
686 END IF
687 END IF
688 j2 = i - k - 1 + max( 1, k-i0+2 )*ka1
689 nr = ( n-j2+ka ) / ka1
690 j1 = j2 + ( nr-1 )*ka1
691 IF( update ) THEN
692 j2t = max( j2, i+2*ka-k+1 )
693 ELSE
694 j2t = j2
695 END IF
696 nrt = ( n-j2t+ka ) / ka1
697 DO 320 j = j2t, j1, ka1
698*
699* create nonzero element a(j+1,j-ka) outside the band
700* and store it in WORK(j-m)
701*
702 work( j-m ) = work( j-m )*ab( ka1, j-ka+1 )
703 ab( ka1, j-ka+1 ) = rwork( j-m )*ab( ka1, j-ka+1 )
704 320 CONTINUE
705*
706* generate rotations in 1st set to annihilate elements which
707* have been created outside the band
708*
709 IF( nrt.GT.0 )
710 $ CALL zlargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),
711 $ ka1, rwork( j2t-m ), ka1 )
712 IF( nr.GT.0 ) THEN
713*
714* apply rotations in 1st set from the left
715*
716 DO 330 l = 1, ka - 1
717 CALL zlartv( nr, ab( l+1, j2-l ), inca,
718 $ ab( l+2, j2-l ), inca, rwork( j2-m ),
719 $ work( j2-m ), ka1 )
720 330 CONTINUE
721*
722* apply rotations in 1st set from both sides to diagonal
723* blocks
724*
725 CALL zlar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),
726 $ inca, rwork( j2-m ), work( j2-m ), ka1 )
727*
728 CALL zlacgv( nr, work( j2-m ), ka1 )
729 END IF
730*
731* start applying rotations in 1st set from the right
732*
733 DO 340 l = ka - 1, kb - k + 1, -1
734 nrt = ( n-j2+l ) / ka1
735 IF( nrt.GT.0 )
736 $ CALL zlartv( nrt, ab( ka1-l+1, j2 ), inca,
737 $ ab( ka1-l, j2+1 ), inca, rwork( j2-m ),
738 $ work( j2-m ), ka1 )
739 340 CONTINUE
740*
741 IF( wantx ) THEN
742*
743* post-multiply X by product of rotations in 1st set
744*
745 DO 350 j = j2, j1, ka1
746 CALL zrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,
747 $ rwork( j-m ), work( j-m ) )
748 350 CONTINUE
749 END IF
750 360 CONTINUE
751*
752 IF( update ) THEN
753 IF( i2.LE.n .AND. kbt.GT.0 ) THEN
754*
755* create nonzero element a(i-kbt+ka+1,i-kbt) outside the
756* band and store it in WORK(i-kbt)
757*
758 work( i-kbt ) = -bb( kbt+1, i-kbt )*ra1
759 END IF
760 END IF
761*
762 DO 400 k = kb, 1, -1
763 IF( update ) THEN
764 j2 = i - k - 1 + max( 2, k-i0+1 )*ka1
765 ELSE
766 j2 = i - k - 1 + max( 1, k-i0+1 )*ka1
767 END IF
768*
769* finish applying rotations in 2nd set from the right
770*
771 DO 370 l = kb - k, 1, -1
772 nrt = ( n-j2+ka+l ) / ka1
773 IF( nrt.GT.0 )
774 $ CALL zlartv( nrt, ab( ka1-l+1, j2-ka ), inca,
775 $ ab( ka1-l, j2-ka+1 ), inca,
776 $ rwork( j2-ka ), work( j2-ka ), ka1 )
777 370 CONTINUE
778 nr = ( n-j2+ka ) / ka1
779 j1 = j2 + ( nr-1 )*ka1
780 DO 380 j = j1, j2, -ka1
781 work( j ) = work( j-ka )
782 rwork( j ) = rwork( j-ka )
783 380 CONTINUE
784 DO 390 j = j2, j1, ka1
785*
786* create nonzero element a(j+1,j-ka) outside the band
787* and store it in WORK(j)
788*
789 work( j ) = work( j )*ab( ka1, j-ka+1 )
790 ab( ka1, j-ka+1 ) = rwork( j )*ab( ka1, j-ka+1 )
791 390 CONTINUE
792 IF( update ) THEN
793 IF( i-k.LT.n-ka .AND. k.LE.kbt )
794 $ work( i-k+ka ) = work( i-k )
795 END IF
796 400 CONTINUE
797*
798 DO 440 k = kb, 1, -1
799 j2 = i - k - 1 + max( 1, k-i0+1 )*ka1
800 nr = ( n-j2+ka ) / ka1
801 j1 = j2 + ( nr-1 )*ka1
802 IF( nr.GT.0 ) THEN
803*
804* generate rotations in 2nd set to annihilate elements
805* which have been created outside the band
806*
807 CALL zlargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,
808 $ rwork( j2 ), ka1 )
809*
810* apply rotations in 2nd set from the left
811*
812 DO 410 l = 1, ka - 1
813 CALL zlartv( nr, ab( l+1, j2-l ), inca,
814 $ ab( l+2, j2-l ), inca, rwork( j2 ),
815 $ work( j2 ), ka1 )
816 410 CONTINUE
817*
818* apply rotations in 2nd set from both sides to diagonal
819* blocks
820*
821 CALL zlar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),
822 $ inca, rwork( j2 ), work( j2 ), ka1 )
823*
824 CALL zlacgv( nr, work( j2 ), ka1 )
825 END IF
826*
827* start applying rotations in 2nd set from the right
828*
829 DO 420 l = ka - 1, kb - k + 1, -1
830 nrt = ( n-j2+l ) / ka1
831 IF( nrt.GT.0 )
832 $ CALL zlartv( nrt, ab( ka1-l+1, j2 ), inca,
833 $ ab( ka1-l, j2+1 ), inca, rwork( j2 ),
834 $ work( j2 ), ka1 )
835 420 CONTINUE
836*
837 IF( wantx ) THEN
838*
839* post-multiply X by product of rotations in 2nd set
840*
841 DO 430 j = j2, j1, ka1
842 CALL zrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,
843 $ rwork( j ), work( j ) )
844 430 CONTINUE
845 END IF
846 440 CONTINUE
847*
848 DO 460 k = 1, kb - 1
849 j2 = i - k - 1 + max( 1, k-i0+2 )*ka1
850*
851* finish applying rotations in 1st set from the right
852*
853 DO 450 l = kb - k, 1, -1
854 nrt = ( n-j2+l ) / ka1
855 IF( nrt.GT.0 )
856 $ CALL zlartv( nrt, ab( ka1-l+1, j2 ), inca,
857 $ ab( ka1-l, j2+1 ), inca, rwork( j2-m ),
858 $ work( j2-m ), ka1 )
859 450 CONTINUE
860 460 CONTINUE
861*
862 IF( kb.GT.1 ) THEN
863 DO 470 j = n - 1, j2 + ka, -1
864 rwork( j-m ) = rwork( j-ka-m )
865 work( j-m ) = work( j-ka-m )
866 470 CONTINUE
867 END IF
868*
869 END IF
870*
871 GO TO 10
872*
873 480 CONTINUE
874*
875* **************************** Phase 2 *****************************
876*
877* The logical structure of this phase is:
878*
879* UPDATE = .TRUE.
880* DO I = 1, M
881* use S(i) to update A and create a new bulge
882* apply rotations to push all bulges KA positions upward
883* END DO
884* UPDATE = .FALSE.
885* DO I = M - KA - 1, 2, -1
886* apply rotations to push all bulges KA positions upward
887* END DO
888*
889* To avoid duplicating code, the two loops are merged.
890*
891 update = .true.
892 i = 0
893 490 CONTINUE
894 IF( update ) THEN
895 i = i + 1
896 kbt = min( kb, m-i )
897 i0 = i + 1
898 i1 = max( 1, i-ka )
899 i2 = i + kbt - ka1
900 IF( i.GT.m ) THEN
901 update = .false.
902 i = i - 1
903 i0 = m + 1
904 IF( ka.EQ.0 )
905 $ RETURN
906 GO TO 490
907 END IF
908 ELSE
909 i = i - ka
910 IF( i.LT.2 )
911 $ RETURN
912 END IF
913*
914 IF( i.LT.m-kbt ) THEN
915 nx = m
916 ELSE
917 nx = n
918 END IF
919*
920 IF( upper ) THEN
921*
922* Transform A, working with the upper triangle
923*
924 IF( update ) THEN
925*
926* Form inv(S(i))**H * A * inv(S(i))
927*
928 bii = dble( bb( kb1, i ) )
929 ab( ka1, i ) = ( dble( ab( ka1, i ) ) / bii ) / bii
930 DO 500 j = i1, i - 1
931 ab( j-i+ka1, i ) = ab( j-i+ka1, i ) / bii
932 500 CONTINUE
933 DO 510 j = i + 1, min( n, i+ka )
934 ab( i-j+ka1, j ) = ab( i-j+ka1, j ) / bii
935 510 CONTINUE
936 DO 540 k = i + 1, i + kbt
937 DO 520 j = k, i + kbt
938 ab( k-j+ka1, j ) = ab( k-j+ka1, j ) -
939 $ bb( i-j+kb1, j )*
940 $ dconjg( ab( i-k+ka1, k ) ) -
941 $ dconjg( bb( i-k+kb1, k ) )*
942 $ ab( i-j+ka1, j ) +
943 $ dble( ab( ka1, i ) )*
944 $ bb( i-j+kb1, j )*
945 $ dconjg( bb( i-k+kb1, k ) )
946 520 CONTINUE
947 DO 530 j = i + kbt + 1, min( n, i+ka )
948 ab( k-j+ka1, j ) = ab( k-j+ka1, j ) -
949 $ dconjg( bb( i-k+kb1, k ) )*
950 $ ab( i-j+ka1, j )
951 530 CONTINUE
952 540 CONTINUE
953 DO 560 j = i1, i
954 DO 550 k = i + 1, min( j+ka, i+kbt )
955 ab( j-k+ka1, k ) = ab( j-k+ka1, k ) -
956 $ bb( i-k+kb1, k )*ab( j-i+ka1, i )
957 550 CONTINUE
958 560 CONTINUE
959*
960 IF( wantx ) THEN
961*
962* post-multiply X by inv(S(i))
963*
964 CALL zdscal( nx, one / bii, x( 1, i ), 1 )
965 IF( kbt.GT.0 )
966 $ CALL zgeru( nx, kbt, -cone, x( 1, i ), 1,
967 $ bb( kb, i+1 ), ldbb-1, x( 1, i+1 ), ldx )
968 END IF
969*
970* store a(i1,i) in RA1 for use in next loop over K
971*
972 ra1 = ab( i1-i+ka1, i )
973 END IF
974*
975* Generate and apply vectors of rotations to chase all the
976* existing bulges KA positions up toward the top of the band
977*
978 DO 610 k = 1, kb - 1
979 IF( update ) THEN
980*
981* Determine the rotations which would annihilate the bulge
982* which has in theory just been created
983*
984 IF( i+k-ka1.GT.0 .AND. i+k.LT.m ) THEN
985*
986* generate rotation to annihilate a(i+k-ka-1,i)
987*
988 CALL zlartg( ab( k+1, i ), ra1, rwork( i+k-ka ),
989 $ work( i+k-ka ), ra )
990*
991* create nonzero element a(i+k-ka-1,i+k) outside the
992* band and store it in WORK(m-kb+i+k)
993*
994 t = -bb( kb1-k, i+k )*ra1
995 work( m-kb+i+k ) = rwork( i+k-ka )*t -
996 $ dconjg( work( i+k-ka ) )*
997 $ ab( 1, i+k )
998 ab( 1, i+k ) = work( i+k-ka )*t +
999 $ rwork( i+k-ka )*ab( 1, i+k )
1000 ra1 = ra
1001 END IF
1002 END IF
1003 j2 = i + k + 1 - max( 1, k+i0-m+1 )*ka1
1004 nr = ( j2+ka-1 ) / ka1
1005 j1 = j2 - ( nr-1 )*ka1
1006 IF( update ) THEN
1007 j2t = min( j2, i-2*ka+k-1 )
1008 ELSE
1009 j2t = j2
1010 END IF
1011 nrt = ( j2t+ka-1 ) / ka1
1012 DO 570 j = j1, j2t, ka1
1013*
1014* create nonzero element a(j-1,j+ka) outside the band
1015* and store it in WORK(j)
1016*
1017 work( j ) = work( j )*ab( 1, j+ka-1 )
1018 ab( 1, j+ka-1 ) = rwork( j )*ab( 1, j+ka-1 )
1019 570 CONTINUE
1020*
1021* generate rotations in 1st set to annihilate elements which
1022* have been created outside the band
1023*
1024 IF( nrt.GT.0 )
1025 $ CALL zlargv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,
1026 $ rwork( j1 ), ka1 )
1027 IF( nr.GT.0 ) THEN
1028*
1029* apply rotations in 1st set from the left
1030*
1031 DO 580 l = 1, ka - 1
1032 CALL zlartv( nr, ab( ka1-l, j1+l ), inca,
1033 $ ab( ka-l, j1+l ), inca, rwork( j1 ),
1034 $ work( j1 ), ka1 )
1035 580 CONTINUE
1036*
1037* apply rotations in 1st set from both sides to diagonal
1038* blocks
1039*
1040 CALL zlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),
1041 $ ab( ka, j1 ), inca, rwork( j1 ), work( j1 ),
1042 $ ka1 )
1043*
1044 CALL zlacgv( nr, work( j1 ), ka1 )
1045 END IF
1046*
1047* start applying rotations in 1st set from the right
1048*
1049 DO 590 l = ka - 1, kb - k + 1, -1
1050 nrt = ( j2+l-1 ) / ka1
1051 j1t = j2 - ( nrt-1 )*ka1
1052 IF( nrt.GT.0 )
1053 $ CALL zlartv( nrt, ab( l, j1t ), inca,
1054 $ ab( l+1, j1t-1 ), inca, rwork( j1t ),
1055 $ work( j1t ), ka1 )
1056 590 CONTINUE
1057*
1058 IF( wantx ) THEN
1059*
1060* post-multiply X by product of rotations in 1st set
1061*
1062 DO 600 j = j1, j2, ka1
1063 CALL zrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,
1064 $ rwork( j ), work( j ) )
1065 600 CONTINUE
1066 END IF
1067 610 CONTINUE
1068*
1069 IF( update ) THEN
1070 IF( i2.GT.0 .AND. kbt.GT.0 ) THEN
1071*
1072* create nonzero element a(i+kbt-ka-1,i+kbt) outside the
1073* band and store it in WORK(m-kb+i+kbt)
1074*
1075 work( m-kb+i+kbt ) = -bb( kb1-kbt, i+kbt )*ra1
1076 END IF
1077 END IF
1078*
1079 DO 650 k = kb, 1, -1
1080 IF( update ) THEN
1081 j2 = i + k + 1 - max( 2, k+i0-m )*ka1
1082 ELSE
1083 j2 = i + k + 1 - max( 1, k+i0-m )*ka1
1084 END IF
1085*
1086* finish applying rotations in 2nd set from the right
1087*
1088 DO 620 l = kb - k, 1, -1
1089 nrt = ( j2+ka+l-1 ) / ka1
1090 j1t = j2 - ( nrt-1 )*ka1
1091 IF( nrt.GT.0 )
1092 $ CALL zlartv( nrt, ab( l, j1t+ka ), inca,
1093 $ ab( l+1, j1t+ka-1 ), inca,
1094 $ rwork( m-kb+j1t+ka ),
1095 $ work( m-kb+j1t+ka ), ka1 )
1096 620 CONTINUE
1097 nr = ( j2+ka-1 ) / ka1
1098 j1 = j2 - ( nr-1 )*ka1
1099 DO 630 j = j1, j2, ka1
1100 work( m-kb+j ) = work( m-kb+j+ka )
1101 rwork( m-kb+j ) = rwork( m-kb+j+ka )
1102 630 CONTINUE
1103 DO 640 j = j1, j2, ka1
1104*
1105* create nonzero element a(j-1,j+ka) outside the band
1106* and store it in WORK(m-kb+j)
1107*
1108 work( m-kb+j ) = work( m-kb+j )*ab( 1, j+ka-1 )
1109 ab( 1, j+ka-1 ) = rwork( m-kb+j )*ab( 1, j+ka-1 )
1110 640 CONTINUE
1111 IF( update ) THEN
1112 IF( i+k.GT.ka1 .AND. k.LE.kbt )
1113 $ work( m-kb+i+k-ka ) = work( m-kb+i+k )
1114 END IF
1115 650 CONTINUE
1116*
1117 DO 690 k = kb, 1, -1
1118 j2 = i + k + 1 - max( 1, k+i0-m )*ka1
1119 nr = ( j2+ka-1 ) / ka1
1120 j1 = j2 - ( nr-1 )*ka1
1121 IF( nr.GT.0 ) THEN
1122*
1123* generate rotations in 2nd set to annihilate elements
1124* which have been created outside the band
1125*
1126 CALL zlargv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),
1127 $ ka1, rwork( m-kb+j1 ), ka1 )
1128*
1129* apply rotations in 2nd set from the left
1130*
1131 DO 660 l = 1, ka - 1
1132 CALL zlartv( nr, ab( ka1-l, j1+l ), inca,
1133 $ ab( ka-l, j1+l ), inca, rwork( m-kb+j1 ),
1134 $ work( m-kb+j1 ), ka1 )
1135 660 CONTINUE
1136*
1137* apply rotations in 2nd set from both sides to diagonal
1138* blocks
1139*
1140 CALL zlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),
1141 $ ab( ka, j1 ), inca, rwork( m-kb+j1 ),
1142 $ work( m-kb+j1 ), ka1 )
1143*
1144 CALL zlacgv( nr, work( m-kb+j1 ), ka1 )
1145 END IF
1146*
1147* start applying rotations in 2nd set from the right
1148*
1149 DO 670 l = ka - 1, kb - k + 1, -1
1150 nrt = ( j2+l-1 ) / ka1
1151 j1t = j2 - ( nrt-1 )*ka1
1152 IF( nrt.GT.0 )
1153 $ CALL zlartv( nrt, ab( l, j1t ), inca,
1154 $ ab( l+1, j1t-1 ), inca,
1155 $ rwork( m-kb+j1t ), work( m-kb+j1t ),
1156 $ ka1 )
1157 670 CONTINUE
1158*
1159 IF( wantx ) THEN
1160*
1161* post-multiply X by product of rotations in 2nd set
1162*
1163 DO 680 j = j1, j2, ka1
1164 CALL zrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,
1165 $ rwork( m-kb+j ), work( m-kb+j ) )
1166 680 CONTINUE
1167 END IF
1168 690 CONTINUE
1169*
1170 DO 710 k = 1, kb - 1
1171 j2 = i + k + 1 - max( 1, k+i0-m+1 )*ka1
1172*
1173* finish applying rotations in 1st set from the right
1174*
1175 DO 700 l = kb - k, 1, -1
1176 nrt = ( j2+l-1 ) / ka1
1177 j1t = j2 - ( nrt-1 )*ka1
1178 IF( nrt.GT.0 )
1179 $ CALL zlartv( nrt, ab( l, j1t ), inca,
1180 $ ab( l+1, j1t-1 ), inca, rwork( j1t ),
1181 $ work( j1t ), ka1 )
1182 700 CONTINUE
1183 710 CONTINUE
1184*
1185 IF( kb.GT.1 ) THEN
1186 DO 720 j = 2, i2 - ka
1187 rwork( j ) = rwork( j+ka )
1188 work( j ) = work( j+ka )
1189 720 CONTINUE
1190 END IF
1191*
1192 ELSE
1193*
1194* Transform A, working with the lower triangle
1195*
1196 IF( update ) THEN
1197*
1198* Form inv(S(i))**H * A * inv(S(i))
1199*
1200 bii = dble( bb( 1, i ) )
1201 ab( 1, i ) = ( dble( ab( 1, i ) ) / bii ) / bii
1202 DO 730 j = i1, i - 1
1203 ab( i-j+1, j ) = ab( i-j+1, j ) / bii
1204 730 CONTINUE
1205 DO 740 j = i + 1, min( n, i+ka )
1206 ab( j-i+1, i ) = ab( j-i+1, i ) / bii
1207 740 CONTINUE
1208 DO 770 k = i + 1, i + kbt
1209 DO 750 j = k, i + kbt
1210 ab( j-k+1, k ) = ab( j-k+1, k ) -
1211 $ bb( j-i+1, i )*dconjg( ab( k-i+1,
1212 $ i ) ) - dconjg( bb( k-i+1, i ) )*
1213 $ ab( j-i+1, i ) + dble( ab( 1, i ) )*
1214 $ bb( j-i+1, i )*dconjg( bb( k-i+1,
1215 $ i ) )
1216 750 CONTINUE
1217 DO 760 j = i + kbt + 1, min( n, i+ka )
1218 ab( j-k+1, k ) = ab( j-k+1, k ) -
1219 $ dconjg( bb( k-i+1, i ) )*
1220 $ ab( j-i+1, i )
1221 760 CONTINUE
1222 770 CONTINUE
1223 DO 790 j = i1, i
1224 DO 780 k = i + 1, min( j+ka, i+kbt )
1225 ab( k-j+1, j ) = ab( k-j+1, j ) -
1226 $ bb( k-i+1, i )*ab( i-j+1, j )
1227 780 CONTINUE
1228 790 CONTINUE
1229*
1230 IF( wantx ) THEN
1231*
1232* post-multiply X by inv(S(i))
1233*
1234 CALL zdscal( nx, one / bii, x( 1, i ), 1 )
1235 IF( kbt.GT.0 )
1236 $ CALL zgerc( nx, kbt, -cone, x( 1, i ), 1, bb( 2, i ),
1237 $ 1, x( 1, i+1 ), ldx )
1238 END IF
1239*
1240* store a(i,i1) in RA1 for use in next loop over K
1241*
1242 ra1 = ab( i-i1+1, i1 )
1243 END IF
1244*
1245* Generate and apply vectors of rotations to chase all the
1246* existing bulges KA positions up toward the top of the band
1247*
1248 DO 840 k = 1, kb - 1
1249 IF( update ) THEN
1250*
1251* Determine the rotations which would annihilate the bulge
1252* which has in theory just been created
1253*
1254 IF( i+k-ka1.GT.0 .AND. i+k.LT.m ) THEN
1255*
1256* generate rotation to annihilate a(i,i+k-ka-1)
1257*
1258 CALL zlartg( ab( ka1-k, i+k-ka ), ra1,
1259 $ rwork( i+k-ka ), work( i+k-ka ), ra )
1260*
1261* create nonzero element a(i+k,i+k-ka-1) outside the
1262* band and store it in WORK(m-kb+i+k)
1263*
1264 t = -bb( k+1, i )*ra1
1265 work( m-kb+i+k ) = rwork( i+k-ka )*t -
1266 $ dconjg( work( i+k-ka ) )*
1267 $ ab( ka1, i+k-ka )
1268 ab( ka1, i+k-ka ) = work( i+k-ka )*t +
1269 $ rwork( i+k-ka )*ab( ka1, i+k-ka )
1270 ra1 = ra
1271 END IF
1272 END IF
1273 j2 = i + k + 1 - max( 1, k+i0-m+1 )*ka1
1274 nr = ( j2+ka-1 ) / ka1
1275 j1 = j2 - ( nr-1 )*ka1
1276 IF( update ) THEN
1277 j2t = min( j2, i-2*ka+k-1 )
1278 ELSE
1279 j2t = j2
1280 END IF
1281 nrt = ( j2t+ka-1 ) / ka1
1282 DO 800 j = j1, j2t, ka1
1283*
1284* create nonzero element a(j+ka,j-1) outside the band
1285* and store it in WORK(j)
1286*
1287 work( j ) = work( j )*ab( ka1, j-1 )
1288 ab( ka1, j-1 ) = rwork( j )*ab( ka1, j-1 )
1289 800 CONTINUE
1290*
1291* generate rotations in 1st set to annihilate elements which
1292* have been created outside the band
1293*
1294 IF( nrt.GT.0 )
1295 $ CALL zlargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,
1296 $ rwork( j1 ), ka1 )
1297 IF( nr.GT.0 ) THEN
1298*
1299* apply rotations in 1st set from the right
1300*
1301 DO 810 l = 1, ka - 1
1302 CALL zlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),
1303 $ inca, rwork( j1 ), work( j1 ), ka1 )
1304 810 CONTINUE
1305*
1306* apply rotations in 1st set from both sides to diagonal
1307* blocks
1308*
1309 CALL zlar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),
1310 $ ab( 2, j1-1 ), inca, rwork( j1 ),
1311 $ work( j1 ), ka1 )
1312*
1313 CALL zlacgv( nr, work( j1 ), ka1 )
1314 END IF
1315*
1316* start applying rotations in 1st set from the left
1317*
1318 DO 820 l = ka - 1, kb - k + 1, -1
1319 nrt = ( j2+l-1 ) / ka1
1320 j1t = j2 - ( nrt-1 )*ka1
1321 IF( nrt.GT.0 )
1322 $ CALL zlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,
1323 $ ab( ka1-l, j1t-ka1+l ), inca,
1324 $ rwork( j1t ), work( j1t ), ka1 )
1325 820 CONTINUE
1326*
1327 IF( wantx ) THEN
1328*
1329* post-multiply X by product of rotations in 1st set
1330*
1331 DO 830 j = j1, j2, ka1
1332 CALL zrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,
1333 $ rwork( j ), dconjg( work( j ) ) )
1334 830 CONTINUE
1335 END IF
1336 840 CONTINUE
1337*
1338 IF( update ) THEN
1339 IF( i2.GT.0 .AND. kbt.GT.0 ) THEN
1340*
1341* create nonzero element a(i+kbt,i+kbt-ka-1) outside the
1342* band and store it in WORK(m-kb+i+kbt)
1343*
1344 work( m-kb+i+kbt ) = -bb( kbt+1, i )*ra1
1345 END IF
1346 END IF
1347*
1348 DO 880 k = kb, 1, -1
1349 IF( update ) THEN
1350 j2 = i + k + 1 - max( 2, k+i0-m )*ka1
1351 ELSE
1352 j2 = i + k + 1 - max( 1, k+i0-m )*ka1
1353 END IF
1354*
1355* finish applying rotations in 2nd set from the left
1356*
1357 DO 850 l = kb - k, 1, -1
1358 nrt = ( j2+ka+l-1 ) / ka1
1359 j1t = j2 - ( nrt-1 )*ka1
1360 IF( nrt.GT.0 )
1361 $ CALL zlartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,
1362 $ ab( ka1-l, j1t+l-1 ), inca,
1363 $ rwork( m-kb+j1t+ka ),
1364 $ work( m-kb+j1t+ka ), ka1 )
1365 850 CONTINUE
1366 nr = ( j2+ka-1 ) / ka1
1367 j1 = j2 - ( nr-1 )*ka1
1368 DO 860 j = j1, j2, ka1
1369 work( m-kb+j ) = work( m-kb+j+ka )
1370 rwork( m-kb+j ) = rwork( m-kb+j+ka )
1371 860 CONTINUE
1372 DO 870 j = j1, j2, ka1
1373*
1374* create nonzero element a(j+ka,j-1) outside the band
1375* and store it in WORK(m-kb+j)
1376*
1377 work( m-kb+j ) = work( m-kb+j )*ab( ka1, j-1 )
1378 ab( ka1, j-1 ) = rwork( m-kb+j )*ab( ka1, j-1 )
1379 870 CONTINUE
1380 IF( update ) THEN
1381 IF( i+k.GT.ka1 .AND. k.LE.kbt )
1382 $ work( m-kb+i+k-ka ) = work( m-kb+i+k )
1383 END IF
1384 880 CONTINUE
1385*
1386 DO 920 k = kb, 1, -1
1387 j2 = i + k + 1 - max( 1, k+i0-m )*ka1
1388 nr = ( j2+ka-1 ) / ka1
1389 j1 = j2 - ( nr-1 )*ka1
1390 IF( nr.GT.0 ) THEN
1391*
1392* generate rotations in 2nd set to annihilate elements
1393* which have been created outside the band
1394*
1395 CALL zlargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),
1396 $ ka1, rwork( m-kb+j1 ), ka1 )
1397*
1398* apply rotations in 2nd set from the right
1399*
1400 DO 890 l = 1, ka - 1
1401 CALL zlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),
1402 $ inca, rwork( m-kb+j1 ), work( m-kb+j1 ),
1403 $ ka1 )
1404 890 CONTINUE
1405*
1406* apply rotations in 2nd set from both sides to diagonal
1407* blocks
1408*
1409 CALL zlar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),
1410 $ ab( 2, j1-1 ), inca, rwork( m-kb+j1 ),
1411 $ work( m-kb+j1 ), ka1 )
1412*
1413 CALL zlacgv( nr, work( m-kb+j1 ), ka1 )
1414 END IF
1415*
1416* start applying rotations in 2nd set from the left
1417*
1418 DO 900 l = ka - 1, kb - k + 1, -1
1419 nrt = ( j2+l-1 ) / ka1
1420 j1t = j2 - ( nrt-1 )*ka1
1421 IF( nrt.GT.0 )
1422 $ CALL zlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,
1423 $ ab( ka1-l, j1t-ka1+l ), inca,
1424 $ rwork( m-kb+j1t ), work( m-kb+j1t ),
1425 $ ka1 )
1426 900 CONTINUE
1427*
1428 IF( wantx ) THEN
1429*
1430* post-multiply X by product of rotations in 2nd set
1431*
1432 DO 910 j = j1, j2, ka1
1433 CALL zrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,
1434 $ rwork( m-kb+j ), dconjg( work( m-kb+j ) ) )
1435 910 CONTINUE
1436 END IF
1437 920 CONTINUE
1438*
1439 DO 940 k = 1, kb - 1
1440 j2 = i + k + 1 - max( 1, k+i0-m+1 )*ka1
1441*
1442* finish applying rotations in 1st set from the left
1443*
1444 DO 930 l = kb - k, 1, -1
1445 nrt = ( j2+l-1 ) / ka1
1446 j1t = j2 - ( nrt-1 )*ka1
1447 IF( nrt.GT.0 )
1448 $ CALL zlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,
1449 $ ab( ka1-l, j1t-ka1+l ), inca,
1450 $ rwork( j1t ), work( j1t ), ka1 )
1451 930 CONTINUE
1452 940 CONTINUE
1453*
1454 IF( kb.GT.1 ) THEN
1455 DO 950 j = 2, i2 - ka
1456 rwork( j ) = rwork( j+ka )
1457 work( j ) = work( j+ka )
1458 950 CONTINUE
1459 END IF
1460*
1461 END IF
1462*
1463 GO TO 490
1464*
1465* End of ZHBGST
1466*
zlargv
subroutine zlargv(n, x, incx, y, incy, c, incc)
ZLARGV generates a vector of plane rotations with real cosines and complex sines.
Definition zlargv.f:122
zlartv
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 p...
Definition zlartv.f:107
zlar2v
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 s...
Definition zlar2v.f:111
zlacgv
subroutine zlacgv(n, x, incx)
ZLACGV conjugates a complex vector.
Definition zlacgv.f:74
zgeru
subroutine zgeru(m, n, alpha, x, incx, y, incy, a, lda)
ZGERU
Definition zgeru.f:130
zgerc
subroutine zgerc(m, n, alpha, x, incx, y, incy, a, lda)
ZGERC
Definition zgerc.f:130

◆ zhbtrd()

subroutine zhbtrd ( character vect,
character uplo,
integer n,
integer kd,
complex*16, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( * ) work,
integer info )

ZHBTRD

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

Purpose:
!>
!> ZHBTRD reduces a complex Hermitian band matrix A to real symmetric
!> tridiagonal form T by a unitary similarity transformation:
!> Q**H * A * Q = T.
!>
Parameters
[in]VECT
!>          VECT is CHARACTER*1
!>          = 'N':  do not form Q;
!>          = 'V':  form Q;
!>          = 'U':  update a matrix X, by forming X*Q.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals 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 Hermitian 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, the diagonal elements of AB are overwritten by the
!>          diagonal elements of the tridiagonal matrix T; if KD > 0, the
!>          elements on the first superdiagonal (if UPLO = 'U') or the
!>          first subdiagonal (if UPLO = 'L') are overwritten by the
!>          off-diagonal elements of T; the rest of AB is overwritten by
!>          values generated during the reduction.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T.
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
!>
[in,out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          On entry, if VECT = 'U', then Q must contain an N-by-N
!>          matrix X; if VECT = 'N' or 'V', then Q need not be set.
!>
!>          On exit:
!>          if VECT = 'V', Q contains the N-by-N unitary matrix Q;
!>          if VECT = 'U', Q contains the product X*Q;
!>          if VECT = 'N', the array Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Modified by Linda Kaufman, Bell Labs.
!>

Definition at line 161 of file zhbtrd.f.

163*
164* -- LAPACK computational routine --
165* -- LAPACK is a software package provided by Univ. of Tennessee, --
166* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
167*
168* .. Scalar Arguments ..
169 CHARACTER UPLO, VECT
170 INTEGER INFO, KD, LDAB, LDQ, N
171* ..
172* .. Array Arguments ..
173 DOUBLE PRECISION D( * ), E( * )
174 COMPLEX*16 AB( LDAB, * ), Q( LDQ, * ), WORK( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 DOUBLE PRECISION ZERO
181 parameter( zero = 0.0d+0 )
182 COMPLEX*16 CZERO, CONE
183 parameter( czero = ( 0.0d+0, 0.0d+0 ),
184 $ cone = ( 1.0d+0, 0.0d+0 ) )
185* ..
186* .. Local Scalars ..
187 LOGICAL INITQ, UPPER, WANTQ
188 INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
189 $ J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
190 $ KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
191 DOUBLE PRECISION ABST
192 COMPLEX*16 T, TEMP
193* ..
194* .. External Subroutines ..
195 EXTERNAL xerbla, zlacgv, zlar2v, zlargv, zlartg, zlartv,
196 $ zlaset, zrot, zscal
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, dble, dconjg, max, min
200* ..
201* .. External Functions ..
202 LOGICAL LSAME
203 EXTERNAL lsame
204* ..
205* .. Executable Statements ..
206*
207* Test the input parameters
208*
209 initq = lsame( vect, 'V' )
210 wantq = initq .OR. lsame( vect, 'U' )
211 upper = lsame( uplo, 'U' )
212 kd1 = kd + 1
213 kdm1 = kd - 1
214 incx = ldab - 1
215 iqend = 1
216*
217 info = 0
218 IF( .NOT.wantq .AND. .NOT.lsame( vect, 'N' ) ) THEN
219 info = -1
220 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
221 info = -2
222 ELSE IF( n.LT.0 ) THEN
223 info = -3
224 ELSE IF( kd.LT.0 ) THEN
225 info = -4
226 ELSE IF( ldab.LT.kd1 ) THEN
227 info = -6
228 ELSE IF( ldq.LT.max( 1, n ) .AND. wantq ) THEN
229 info = -10
230 END IF
231 IF( info.NE.0 ) THEN
232 CALL xerbla( 'ZHBTRD', -info )
233 RETURN
234 END IF
235*
236* Quick return if possible
237*
238 IF( n.EQ.0 )
239 $ RETURN
240*
241* Initialize Q to the unit matrix, if needed
242*
243 IF( initq )
244 $ CALL zlaset( 'Full', n, n, czero, cone, q, ldq )
245*
246* Wherever possible, plane rotations are generated and applied in
247* vector operations of length NR over the index set J1:J2:KD1.
248*
249* The real cosines and complex sines of the plane rotations are
250* stored in the arrays D and WORK.
251*
252 inca = kd1*ldab
253 kdn = min( n-1, kd )
254 IF( upper ) THEN
255*
256 IF( kd.GT.1 ) THEN
257*
258* Reduce to complex Hermitian tridiagonal form, working with
259* the upper triangle
260*
261 nr = 0
262 j1 = kdn + 2
263 j2 = 1
264*
265 ab( kd1, 1 ) = dble( ab( kd1, 1 ) )
266 DO 90 i = 1, n - 2
267*
268* Reduce i-th row of matrix to tridiagonal form
269*
270 DO 80 k = kdn + 1, 2, -1
271 j1 = j1 + kdn
272 j2 = j2 + kdn
273*
274 IF( nr.GT.0 ) THEN
275*
276* generate plane rotations to annihilate nonzero
277* elements which have been created outside the band
278*
279 CALL zlargv( nr, ab( 1, j1-1 ), inca, work( j1 ),
280 $ kd1, d( j1 ), kd1 )
281*
282* apply rotations from the right
283*
284*
285* Dependent on the the number of diagonals either
286* ZLARTV or ZROT is used
287*
288 IF( nr.GE.2*kd-1 ) THEN
289 DO 10 l = 1, kd - 1
290 CALL zlartv( nr, ab( l+1, j1-1 ), inca,
291 $ ab( l, j1 ), inca, d( j1 ),
292 $ work( j1 ), kd1 )
293 10 CONTINUE
294*
295 ELSE
296 jend = j1 + ( nr-1 )*kd1
297 DO 20 jinc = j1, jend, kd1
298 CALL zrot( kdm1, ab( 2, jinc-1 ), 1,
299 $ ab( 1, jinc ), 1, d( jinc ),
300 $ work( jinc ) )
301 20 CONTINUE
302 END IF
303 END IF
304*
305*
306 IF( k.GT.2 ) THEN
307 IF( k.LE.n-i+1 ) THEN
308*
309* generate plane rotation to annihilate a(i,i+k-1)
310* within the band
311*
312 CALL zlartg( ab( kd-k+3, i+k-2 ),
313 $ ab( kd-k+2, i+k-1 ), d( i+k-1 ),
314 $ work( i+k-1 ), temp )
315 ab( kd-k+3, i+k-2 ) = temp
316*
317* apply rotation from the right
318*
319 CALL zrot( k-3, ab( kd-k+4, i+k-2 ), 1,
320 $ ab( kd-k+3, i+k-1 ), 1, d( i+k-1 ),
321 $ work( i+k-1 ) )
322 END IF
323 nr = nr + 1
324 j1 = j1 - kdn - 1
325 END IF
326*
327* apply plane rotations from both sides to diagonal
328* blocks
329*
330 IF( nr.GT.0 )
331 $ CALL zlar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),
332 $ ab( kd, j1 ), inca, d( j1 ),
333 $ work( j1 ), kd1 )
334*
335* apply plane rotations from the left
336*
337 IF( nr.GT.0 ) THEN
338 CALL zlacgv( nr, work( j1 ), kd1 )
339 IF( 2*kd-1.LT.nr ) THEN
340*
341* Dependent on the the number of diagonals either
342* ZLARTV or ZROT is used
343*
344 DO 30 l = 1, kd - 1
345 IF( j2+l.GT.n ) THEN
346 nrt = nr - 1
347 ELSE
348 nrt = nr
349 END IF
350 IF( nrt.GT.0 )
351 $ CALL zlartv( nrt, ab( kd-l, j1+l ), inca,
352 $ ab( kd-l+1, j1+l ), inca,
353 $ d( j1 ), work( j1 ), kd1 )
354 30 CONTINUE
355 ELSE
356 j1end = j1 + kd1*( nr-2 )
357 IF( j1end.GE.j1 ) THEN
358 DO 40 jin = j1, j1end, kd1
359 CALL zrot( kd-1, ab( kd-1, jin+1 ), incx,
360 $ ab( kd, jin+1 ), incx,
361 $ d( jin ), work( jin ) )
362 40 CONTINUE
363 END IF
364 lend = min( kdm1, n-j2 )
365 last = j1end + kd1
366 IF( lend.GT.0 )
367 $ CALL zrot( lend, ab( kd-1, last+1 ), incx,
368 $ ab( kd, last+1 ), incx, d( last ),
369 $ work( last ) )
370 END IF
371 END IF
372*
373 IF( wantq ) THEN
374*
375* accumulate product of plane rotations in Q
376*
377 IF( initq ) THEN
378*
379* take advantage of the fact that Q was
380* initially the Identity matrix
381*
382 iqend = max( iqend, j2 )
383 i2 = max( 0, k-3 )
384 iqaend = 1 + i*kd
385 IF( k.EQ.2 )
386 $ iqaend = iqaend + kd
387 iqaend = min( iqaend, iqend )
388 DO 50 j = j1, j2, kd1
389 ibl = i - i2 / kdm1
390 i2 = i2 + 1
391 iqb = max( 1, j-ibl )
392 nq = 1 + iqaend - iqb
393 iqaend = min( iqaend+kd, iqend )
394 CALL zrot( nq, q( iqb, j-1 ), 1, q( iqb, j ),
395 $ 1, d( j ), dconjg( work( j ) ) )
396 50 CONTINUE
397 ELSE
398*
399 DO 60 j = j1, j2, kd1
400 CALL zrot( n, q( 1, j-1 ), 1, q( 1, j ), 1,
401 $ d( j ), dconjg( work( j ) ) )
402 60 CONTINUE
403 END IF
404*
405 END IF
406*
407 IF( j2+kdn.GT.n ) THEN
408*
409* adjust J2 to keep within the bounds of the matrix
410*
411 nr = nr - 1
412 j2 = j2 - kdn - 1
413 END IF
414*
415 DO 70 j = j1, j2, kd1
416*
417* create nonzero element a(j-1,j+kd) outside the band
418* and store it in WORK
419*
420 work( j+kd ) = work( j )*ab( 1, j+kd )
421 ab( 1, j+kd ) = d( j )*ab( 1, j+kd )
422 70 CONTINUE
423 80 CONTINUE
424 90 CONTINUE
425 END IF
426*
427 IF( kd.GT.0 ) THEN
428*
429* make off-diagonal elements real and copy them to E
430*
431 DO 100 i = 1, n - 1
432 t = ab( kd, i+1 )
433 abst = abs( t )
434 ab( kd, i+1 ) = abst
435 e( i ) = abst
436 IF( abst.NE.zero ) THEN
437 t = t / abst
438 ELSE
439 t = cone
440 END IF
441 IF( i.LT.n-1 )
442 $ ab( kd, i+2 ) = ab( kd, i+2 )*t
443 IF( wantq ) THEN
444 CALL zscal( n, dconjg( t ), q( 1, i+1 ), 1 )
445 END IF
446 100 CONTINUE
447 ELSE
448*
449* set E to zero if original matrix was diagonal
450*
451 DO 110 i = 1, n - 1
452 e( i ) = zero
453 110 CONTINUE
454 END IF
455*
456* copy diagonal elements to D
457*
458 DO 120 i = 1, n
459 d( i ) = dble( ab( kd1, i ) )
460 120 CONTINUE
461*
462 ELSE
463*
464 IF( kd.GT.1 ) THEN
465*
466* Reduce to complex Hermitian tridiagonal form, working with
467* the lower triangle
468*
469 nr = 0
470 j1 = kdn + 2
471 j2 = 1
472*
473 ab( 1, 1 ) = dble( ab( 1, 1 ) )
474 DO 210 i = 1, n - 2
475*
476* Reduce i-th column of matrix to tridiagonal form
477*
478 DO 200 k = kdn + 1, 2, -1
479 j1 = j1 + kdn
480 j2 = j2 + kdn
481*
482 IF( nr.GT.0 ) THEN
483*
484* generate plane rotations to annihilate nonzero
485* elements which have been created outside the band
486*
487 CALL zlargv( nr, ab( kd1, j1-kd1 ), inca,
488 $ work( j1 ), kd1, d( j1 ), kd1 )
489*
490* apply plane rotations from one side
491*
492*
493* Dependent on the the number of diagonals either
494* ZLARTV or ZROT is used
495*
496 IF( nr.GT.2*kd-1 ) THEN
497 DO 130 l = 1, kd - 1
498 CALL zlartv( nr, ab( kd1-l, j1-kd1+l ), inca,
499 $ ab( kd1-l+1, j1-kd1+l ), inca,
500 $ d( j1 ), work( j1 ), kd1 )
501 130 CONTINUE
502 ELSE
503 jend = j1 + kd1*( nr-1 )
504 DO 140 jinc = j1, jend, kd1
505 CALL zrot( kdm1, ab( kd, jinc-kd ), incx,
506 $ ab( kd1, jinc-kd ), incx,
507 $ d( jinc ), work( jinc ) )
508 140 CONTINUE
509 END IF
510*
511 END IF
512*
513 IF( k.GT.2 ) THEN
514 IF( k.LE.n-i+1 ) THEN
515*
516* generate plane rotation to annihilate a(i+k-1,i)
517* within the band
518*
519 CALL zlartg( ab( k-1, i ), ab( k, i ),
520 $ d( i+k-1 ), work( i+k-1 ), temp )
521 ab( k-1, i ) = temp
522*
523* apply rotation from the left
524*
525 CALL zrot( k-3, ab( k-2, i+1 ), ldab-1,
526 $ ab( k-1, i+1 ), ldab-1, d( i+k-1 ),
527 $ work( i+k-1 ) )
528 END IF
529 nr = nr + 1
530 j1 = j1 - kdn - 1
531 END IF
532*
533* apply plane rotations from both sides to diagonal
534* blocks
535*
536 IF( nr.GT.0 )
537 $ CALL zlar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),
538 $ ab( 2, j1-1 ), inca, d( j1 ),
539 $ work( j1 ), kd1 )
540*
541* apply plane rotations from the right
542*
543*
544* Dependent on the the number of diagonals either
545* ZLARTV or ZROT is used
546*
547 IF( nr.GT.0 ) THEN
548 CALL zlacgv( nr, work( j1 ), kd1 )
549 IF( nr.GT.2*kd-1 ) THEN
550 DO 150 l = 1, kd - 1
551 IF( j2+l.GT.n ) THEN
552 nrt = nr - 1
553 ELSE
554 nrt = nr
555 END IF
556 IF( nrt.GT.0 )
557 $ CALL zlartv( nrt, ab( l+2, j1-1 ), inca,
558 $ ab( l+1, j1 ), inca, d( j1 ),
559 $ work( j1 ), kd1 )
560 150 CONTINUE
561 ELSE
562 j1end = j1 + kd1*( nr-2 )
563 IF( j1end.GE.j1 ) THEN
564 DO 160 j1inc = j1, j1end, kd1
565 CALL zrot( kdm1, ab( 3, j1inc-1 ), 1,
566 $ ab( 2, j1inc ), 1, d( j1inc ),
567 $ work( j1inc ) )
568 160 CONTINUE
569 END IF
570 lend = min( kdm1, n-j2 )
571 last = j1end + kd1
572 IF( lend.GT.0 )
573 $ CALL zrot( lend, ab( 3, last-1 ), 1,
574 $ ab( 2, last ), 1, d( last ),
575 $ work( last ) )
576 END IF
577 END IF
578*
579*
580*
581 IF( wantq ) THEN
582*
583* accumulate product of plane rotations in Q
584*
585 IF( initq ) THEN
586*
587* take advantage of the fact that Q was
588* initially the Identity matrix
589*
590 iqend = max( iqend, j2 )
591 i2 = max( 0, k-3 )
592 iqaend = 1 + i*kd
593 IF( k.EQ.2 )
594 $ iqaend = iqaend + kd
595 iqaend = min( iqaend, iqend )
596 DO 170 j = j1, j2, kd1
597 ibl = i - i2 / kdm1
598 i2 = i2 + 1
599 iqb = max( 1, j-ibl )
600 nq = 1 + iqaend - iqb
601 iqaend = min( iqaend+kd, iqend )
602 CALL zrot( nq, q( iqb, j-1 ), 1, q( iqb, j ),
603 $ 1, d( j ), work( j ) )
604 170 CONTINUE
605 ELSE
606*
607 DO 180 j = j1, j2, kd1
608 CALL zrot( n, q( 1, j-1 ), 1, q( 1, j ), 1,
609 $ d( j ), work( j ) )
610 180 CONTINUE
611 END IF
612 END IF
613*
614 IF( j2+kdn.GT.n ) THEN
615*
616* adjust J2 to keep within the bounds of the matrix
617*
618 nr = nr - 1
619 j2 = j2 - kdn - 1
620 END IF
621*
622 DO 190 j = j1, j2, kd1
623*
624* create nonzero element a(j+kd,j-1) outside the
625* band and store it in WORK
626*
627 work( j+kd ) = work( j )*ab( kd1, j )
628 ab( kd1, j ) = d( j )*ab( kd1, j )
629 190 CONTINUE
630 200 CONTINUE
631 210 CONTINUE
632 END IF
633*
634 IF( kd.GT.0 ) THEN
635*
636* make off-diagonal elements real and copy them to E
637*
638 DO 220 i = 1, n - 1
639 t = ab( 2, i )
640 abst = abs( t )
641 ab( 2, i ) = abst
642 e( i ) = abst
643 IF( abst.NE.zero ) THEN
644 t = t / abst
645 ELSE
646 t = cone
647 END IF
648 IF( i.LT.n-1 )
649 $ ab( 2, i+1 ) = ab( 2, i+1 )*t
650 IF( wantq ) THEN
651 CALL zscal( n, t, q( 1, i+1 ), 1 )
652 END IF
653 220 CONTINUE
654 ELSE
655*
656* set E to zero if original matrix was diagonal
657*
658 DO 230 i = 1, n - 1
659 e( i ) = zero
660 230 CONTINUE
661 END IF
662*
663* copy diagonal elements to D
664*
665 DO 240 i = 1, n
666 d( i ) = dble( ab( 1, i ) )
667 240 CONTINUE
668 END IF
669*
670 RETURN
671*
672* End of ZHBTRD
673*

◆ zhetrd_hb2st()

subroutine zhetrd_hb2st ( character stage1,
character vect,
character uplo,
integer n,
integer kd,
complex*16, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( * ) hous,
integer lhous,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric tridiagonal form T

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

Purpose:
!>
!> ZHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric
!> tridiagonal form T by a unitary similarity transformation:
!> Q**H * A * Q = T.
!>
Parameters
[in]STAGE1
!>          STAGE1 is CHARACTER*1
!>          = 'N':  : to mention that the stage 1 of the reduction  
!>                  from dense to band using the zhetrd_he2hb routine
!>                  was not called before this routine to reproduce AB. 
!>                  In other term this routine is called as standalone. 
!>          = 'Y':  : to mention that the stage 1 of the 
!>                  reduction from dense to band using the zhetrd_he2hb 
!>                  routine has been called to produce AB (e.g., AB is
!>                  the output of zhetrd_he2hb.
!>
[in]VECT
!>          VECT is CHARACTER*1
!>          = 'N':  No need for the Housholder representation, 
!>                  and thus LHOUS is of size max(1, 4*N);
!>          = 'V':  the Householder representation is needed to 
!>                  either generate or to apply Q later on, 
!>                  then LHOUS is to be queried and computed.
!>                  (NOT AVAILABLE IN THIS RELEASE).
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals 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 Hermitian 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, the diagonal elements of AB are overwritten by the
!>          diagonal elements of the tridiagonal matrix T; if KD > 0, the
!>          elements on the first superdiagonal (if UPLO = 'U') or the
!>          first subdiagonal (if UPLO = 'L') are overwritten by the
!>          off-diagonal elements of T; the rest of AB is overwritten by
!>          values generated during the reduction.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T.
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
!>
[out]HOUS
!>          HOUS is COMPLEX*16 array, dimension LHOUS, that
!>          store the Householder representation.
!>
[in]LHOUS
!>          LHOUS is INTEGER
!>          The dimension of the array HOUS. LHOUS = MAX(1, dimension)
!>          If LWORK = -1, or LHOUS=-1,
!>          then a query is assumed; the routine
!>          only calculates the optimal size of the HOUS array, returns
!>          this value as the first entry of the HOUS array, and no error
!>          message related to LHOUS is issued by XERBLA.
!>          LHOUS = MAX(1, dimension) where
!>          dimension = 4*N if VECT='N'
!>          not available now if VECT='H'     
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK = MAX(1, dimension)
!>          If LWORK = -1, or LHOUS=-1,
!>          then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>          LWORK = MAX(1, dimension) where
!>          dimension   = (2KD+1)*N + KD*NTHREADS
!>          where KD is the blocking size of the reduction,
!>          FACTOPTNB is the blocking used by the QR or LQ
!>          algorithm, usually FACTOPTNB=128 is a good choice
!>          NTHREADS is the number of threads used when
!>          openMP compilation is enabled, otherwise =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.
Further Details:
!>
!>  Implemented by Azzam Haidar.
!>
!>  All details are available on technical report, SC11, SC13 papers.
!>
!>  Azzam Haidar, Hatem Ltaief, and Jack Dongarra.
!>  Parallel reduction to condensed forms for symmetric eigenvalue problems
!>  using aggregated fine-grained and memory-aware kernels. In Proceedings
!>  of 2011 International Conference for High Performance Computing,
!>  Networking, Storage and Analysis (SC '11), New York, NY, USA,
!>  Article 8 , 11 pages.
!>  http://doi.acm.org/10.1145/2063384.2063394
!>
!>  A. Haidar, J. Kurzak, P. Luszczek, 2013.
!>  An improved parallel singular value algorithm and its implementation 
!>  for multicore hardware, In Proceedings of 2013 International Conference
!>  for High Performance Computing, Networking, Storage and Analysis (SC '13).
!>  Denver, Colorado, USA, 2013.
!>  Article 90, 12 pages.
!>  http://doi.acm.org/10.1145/2503210.2503292
!>
!>  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra.
!>  A novel hybrid CPU-GPU generalized eigensolver for electronic structure 
!>  calculations based on fine-grained memory aware tasks.
!>  International Journal of High Performance Computing Applications.
!>  Volume 28 Issue 2, Pages 196-209, May 2014.
!>  http://hpc.sagepub.com/content/28/2/196 
!>
!>

Definition at line 228 of file zhetrd_hb2st.F.

230*
231*
232#if defined(_OPENMP)
233 use omp_lib
234#endif
235*
236 IMPLICIT NONE
237*
238* -- LAPACK computational routine --
239* -- LAPACK is a software package provided by Univ. of Tennessee, --
240* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
241*
242* .. Scalar Arguments ..
243 CHARACTER STAGE1, UPLO, VECT
244 INTEGER N, KD, LDAB, LHOUS, LWORK, INFO
245* ..
246* .. Array Arguments ..
247 DOUBLE PRECISION D( * ), E( * )
248 COMPLEX*16 AB( LDAB, * ), HOUS( * ), WORK( * )
249* ..
250*
251* =====================================================================
252*
253* .. Parameters ..
254 DOUBLE PRECISION RZERO
255 COMPLEX*16 ZERO, ONE
256 parameter( rzero = 0.0d+0,
257 $ zero = ( 0.0d+0, 0.0d+0 ),
258 $ one = ( 1.0d+0, 0.0d+0 ) )
259* ..
260* .. Local Scalars ..
261 LOGICAL LQUERY, WANTQ, UPPER, AFTERS1
262 INTEGER I, M, K, IB, SWEEPID, MYID, SHIFT, STT, ST,
263 $ ED, STIND, EDIND, BLKLASTIND, COLPT, THED,
264 $ STEPERCOL, GRSIZ, THGRSIZ, THGRNB, THGRID,
265 $ NBTILES, TTYPE, TID, NTHREADS, DEBUG,
266 $ ABDPOS, ABOFDPOS, DPOS, OFDPOS, AWPOS,
267 $ INDA, INDW, APOS, SIZEA, LDA, INDV, INDTAU,
268 $ SIZEV, SIZETAU, LDV, LHMIN, LWMIN
269 DOUBLE PRECISION ABSTMP
270 COMPLEX*16 TMP
271* ..
272* .. External Subroutines ..
273 EXTERNAL zhb2st_kernels, zlacpy, zlaset, xerbla
274* ..
275* .. Intrinsic Functions ..
276 INTRINSIC min, max, ceiling, dble, real
277* ..
278* .. External Functions ..
279 LOGICAL LSAME
280 INTEGER ILAENV2STAGE
281 EXTERNAL lsame, ilaenv2stage
282* ..
283* .. Executable Statements ..
284*
285* Determine the minimal workspace size required.
286* Test the input parameters
287*
288 debug = 0
289 info = 0
290 afters1 = lsame( stage1, 'Y' )
291 wantq = lsame( vect, 'V' )
292 upper = lsame( uplo, 'U' )
293 lquery = ( lwork.EQ.-1 ) .OR. ( lhous.EQ.-1 )
294*
295* Determine the block size, the workspace size and the hous size.
296*
297 ib = ilaenv2stage( 2, 'ZHETRD_HB2ST', vect, n, kd, -1, -1 )
298 lhmin = ilaenv2stage( 3, 'ZHETRD_HB2ST', vect, n, kd, ib, -1 )
299 lwmin = ilaenv2stage( 4, 'ZHETRD_HB2ST', vect, n, kd, ib, -1 )
300*
301 IF( .NOT.afters1 .AND. .NOT.lsame( stage1, 'N' ) ) THEN
302 info = -1
303 ELSE IF( .NOT.lsame( vect, 'N' ) ) THEN
304 info = -2
305 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
306 info = -3
307 ELSE IF( n.LT.0 ) THEN
308 info = -4
309 ELSE IF( kd.LT.0 ) THEN
310 info = -5
311 ELSE IF( ldab.LT.(kd+1) ) THEN
312 info = -7
313 ELSE IF( lhous.LT.lhmin .AND. .NOT.lquery ) THEN
314 info = -11
315 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
316 info = -13
317 END IF
318*
319 IF( info.EQ.0 ) THEN
320 hous( 1 ) = lhmin
321 work( 1 ) = lwmin
322 END IF
323*
324 IF( info.NE.0 ) THEN
325 CALL xerbla( 'ZHETRD_HB2ST', -info )
326 RETURN
327 ELSE IF( lquery ) THEN
328 RETURN
329 END IF
330*
331* Quick return if possible
332*
333 IF( n.EQ.0 ) THEN
334 hous( 1 ) = 1
335 work( 1 ) = 1
336 RETURN
337 END IF
338*
339* Determine pointer position
340*
341 ldv = kd + ib
342 sizetau = 2 * n
343 sizev = 2 * n
344 indtau = 1
345 indv = indtau + sizetau
346 lda = 2 * kd + 1
347 sizea = lda * n
348 inda = 1
349 indw = inda + sizea
350 nthreads = 1
351 tid = 0
352*
353 IF( upper ) THEN
354 apos = inda + kd
355 awpos = inda
356 dpos = apos + kd
357 ofdpos = dpos - 1
358 abdpos = kd + 1
359 abofdpos = kd
360 ELSE
361 apos = inda
362 awpos = inda + kd + 1
363 dpos = apos
364 ofdpos = dpos + 1
365 abdpos = 1
366 abofdpos = 2
367
368 ENDIF
369*
370* Case KD=0:
371* The matrix is diagonal. We just copy it (convert to "real" for
372* complex because D is double and the imaginary part should be 0)
373* and store it in D. A sequential code here is better or
374* in a parallel environment it might need two cores for D and E
375*
376 IF( kd.EQ.0 ) THEN
377 DO 30 i = 1, n
378 d( i ) = dble( ab( abdpos, i ) )
379 30 CONTINUE
380 DO 40 i = 1, n-1
381 e( i ) = rzero
382 40 CONTINUE
383*
384 hous( 1 ) = 1
385 work( 1 ) = 1
386 RETURN
387 END IF
388*
389* Case KD=1:
390* The matrix is already Tridiagonal. We have to make diagonal
391* and offdiagonal elements real, and store them in D and E.
392* For that, for real precision just copy the diag and offdiag
393* to D and E while for the COMPLEX case the bulge chasing is
394* performed to convert the hermetian tridiagonal to symmetric
395* tridiagonal. A simpler conversion formula might be used, but then
396* updating the Q matrix will be required and based if Q is generated
397* or not this might complicate the story.
398*
399 IF( kd.EQ.1 ) THEN
400 DO 50 i = 1, n
401 d( i ) = dble( ab( abdpos, i ) )
402 50 CONTINUE
403*
404* make off-diagonal elements real and copy them to E
405*
406 IF( upper ) THEN
407 DO 60 i = 1, n - 1
408 tmp = ab( abofdpos, i+1 )
409 abstmp = abs( tmp )
410 ab( abofdpos, i+1 ) = abstmp
411 e( i ) = abstmp
412 IF( abstmp.NE.rzero ) THEN
413 tmp = tmp / abstmp
414 ELSE
415 tmp = one
416 END IF
417 IF( i.LT.n-1 )
418 $ ab( abofdpos, i+2 ) = ab( abofdpos, i+2 )*tmp
419C IF( WANTZ ) THEN
420C CALL ZSCAL( N, DCONJG( TMP ), Q( 1, I+1 ), 1 )
421C END IF
422 60 CONTINUE
423 ELSE
424 DO 70 i = 1, n - 1
425 tmp = ab( abofdpos, i )
426 abstmp = abs( tmp )
427 ab( abofdpos, i ) = abstmp
428 e( i ) = abstmp
429 IF( abstmp.NE.rzero ) THEN
430 tmp = tmp / abstmp
431 ELSE
432 tmp = one
433 END IF
434 IF( i.LT.n-1 )
435 $ ab( abofdpos, i+1 ) = ab( abofdpos, i+1 )*tmp
436C IF( WANTQ ) THEN
437C CALL ZSCAL( N, TMP, Q( 1, I+1 ), 1 )
438C END IF
439 70 CONTINUE
440 ENDIF
441*
442 hous( 1 ) = 1
443 work( 1 ) = 1
444 RETURN
445 END IF
446*
447* Main code start here.
448* Reduce the hermitian band of A to a tridiagonal matrix.
449*
450 thgrsiz = n
451 grsiz = 1
452 shift = 3
453 nbtiles = ceiling( real(n)/real(kd) )
454 stepercol = ceiling( real(shift)/real(grsiz) )
455 thgrnb = ceiling( real(n-1)/real(thgrsiz) )
456*
457 CALL zlacpy( "A", kd+1, n, ab, ldab, work( apos ), lda )
458 CALL zlaset( "A", kd, n, zero, zero, work( awpos ), lda )
459*
460*
461* openMP parallelisation start here
462*
463#if defined(_OPENMP)
464!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND )
465!$OMP$ PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID )
466!$OMP$ PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND )
467!$OMP$ SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK)
468!$OMP$ SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA )
469!$OMP$ SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT )
470!$OMP MASTER
471#endif
472*
473* main bulge chasing loop
474*
475 DO 100 thgrid = 1, thgrnb
476 stt = (thgrid-1)*thgrsiz+1
477 thed = min( (stt + thgrsiz -1), (n-1))
478 DO 110 i = stt, n-1
479 ed = min( i, thed )
480 IF( stt.GT.ed ) EXIT
481 DO 120 m = 1, stepercol
482 st = stt
483 DO 130 sweepid = st, ed
484 DO 140 k = 1, grsiz
485 myid = (i-sweepid)*(stepercol*grsiz)
486 $ + (m-1)*grsiz + k
487 IF ( myid.EQ.1 ) THEN
488 ttype = 1
489 ELSE
490 ttype = mod( myid, 2 ) + 2
491 ENDIF
492
493 IF( ttype.EQ.2 ) THEN
494 colpt = (myid/2)*kd + sweepid
495 stind = colpt-kd+1
496 edind = min(colpt,n)
497 blklastind = colpt
498 ELSE
499 colpt = ((myid+1)/2)*kd + sweepid
500 stind = colpt-kd+1
501 edind = min(colpt,n)
502 IF( ( stind.GE.edind-1 ).AND.
503 $ ( edind.EQ.n ) ) THEN
504 blklastind = n
505 ELSE
506 blklastind = 0
507 ENDIF
508 ENDIF
509*
510* Call the kernel
511*
512#if defined(_OPENMP) && _OPENMP >= 201307
513
514 IF( ttype.NE.1 ) THEN
515!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1))
516!$OMP$ DEPEND(in:WORK(MYID-1))
517!$OMP$ DEPEND(out:WORK(MYID))
518 tid = omp_get_thread_num()
519 CALL zhb2st_kernels( uplo, wantq, ttype,
520 $ stind, edind, sweepid, n, kd, ib,
521 $ work( inda ), lda,
522 $ hous( indv ), hous( indtau ), ldv,
523 $ work( indw + tid*kd ) )
524!$OMP END TASK
525 ELSE
526!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1))
527!$OMP$ DEPEND(out:WORK(MYID))
528 tid = omp_get_thread_num()
529 CALL zhb2st_kernels( uplo, wantq, ttype,
530 $ stind, edind, sweepid, n, kd, ib,
531 $ work( inda ), lda,
532 $ hous( indv ), hous( indtau ), ldv,
533 $ work( indw + tid*kd ) )
534!$OMP END TASK
535 ENDIF
536#else
537 CALL zhb2st_kernels( uplo, wantq, ttype,
538 $ stind, edind, sweepid, n, kd, ib,
539 $ work( inda ), lda,
540 $ hous( indv ), hous( indtau ), ldv,
541 $ work( indw + tid*kd ) )
542#endif
543 IF ( blklastind.GE.(n-1) ) THEN
544 stt = stt + 1
545 EXIT
546 ENDIF
547 140 CONTINUE
548 130 CONTINUE
549 120 CONTINUE
550 110 CONTINUE
551 100 CONTINUE
552*
553#if defined(_OPENMP)
554!$OMP END MASTER
555!$OMP END PARALLEL
556#endif
557*
558* Copy the diagonal from A to D. Note that D is REAL thus only
559* the Real part is needed, the imaginary part should be zero.
560*
561 DO 150 i = 1, n
562 d( i ) = dble( work( dpos+(i-1)*lda ) )
563 150 CONTINUE
564*
565* Copy the off diagonal from A to E. Note that E is REAL thus only
566* the Real part is needed, the imaginary part should be zero.
567*
568 IF( upper ) THEN
569 DO 160 i = 1, n-1
570 e( i ) = dble( work( ofdpos+i*lda ) )
571 160 CONTINUE
572 ELSE
573 DO 170 i = 1, n-1
574 e( i ) = dble( work( ofdpos+(i-1)*lda ) )
575 170 CONTINUE
576 ENDIF
577*
578 hous( 1 ) = lhmin
579 work( 1 ) = lwmin
580 RETURN
581*
582* End of ZHETRD_HB2ST
583*
ilaenv2stage
integer function ilaenv2stage(ispec, name, opts, n1, n2, n3, n4)
ILAENV2STAGE
Definition ilaenv2stage.f:149
zhb2st_kernels
subroutine zhb2st_kernels(uplo, wantz, ttype, st, ed, sweep, n, nb, ib, a, lda, v, tau, ldvt, work)
ZHB2ST_KERNELS
Definition zhb2st_kernels.f:170

◆ zhfrk()

subroutine zhfrk ( character transr,
character uplo,
character trans,
integer n,
integer k,
double precision alpha,
complex*16, dimension( lda, * ) a,
integer lda,
double precision beta,
complex*16, dimension( * ) c )

ZHFRK performs a Hermitian rank-k operation for matrix in RFP format.

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

Purpose:
!>
!> Level 3 BLAS like routine for C in RFP Format.
!>
!> ZHFRK performs one of the Hermitian rank--k operations
!>
!>    C := alpha*A*A**H + beta*C,
!>
!> or
!>
!>    C := alpha*A**H*A + beta*C,
!>
!> where alpha and beta are real scalars, C is an n--by--n Hermitian
!> matrix and A is an n--by--k matrix in the first case and a k--by--n
!> matrix in the second case.
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  The Normal Form of RFP A is stored;
!>          = 'C':  The Conjugate-transpose Form of RFP A is stored.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>           On  entry,   UPLO  specifies  whether  the  upper  or  lower
!>           triangular  part  of the  array  C  is to be  referenced  as
!>           follows:
!>
!>              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
!>                                  is to be referenced.
!>
!>              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
!>                                  is to be referenced.
!>
!>           Unchanged on exit.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>           On entry,  TRANS  specifies the operation to be performed as
!>           follows:
!>
!>              TRANS = 'N' or 'n'   C := alpha*A*A**H + beta*C.
!>
!>              TRANS = 'C' or 'c'   C := alpha*A**H*A + beta*C.
!>
!>           Unchanged on exit.
!>
[in]N
!>          N is INTEGER
!>           On entry,  N specifies the order of the matrix C.  N must be
!>           at least zero.
!>           Unchanged on exit.
!>
[in]K
!>          K is INTEGER
!>           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
!>           of  columns   of  the   matrix   A,   and  on   entry   with
!>           TRANS = 'C' or 'c',  K  specifies  the number of rows of the
!>           matrix A.  K must be at least zero.
!>           Unchanged on exit.
!>
[in]ALPHA
!>          ALPHA is DOUBLE PRECISION
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,ka)
!>           where KA
!>           is K  when TRANS = 'N' or 'n', and is N otherwise. Before
!>           entry with TRANS = 'N' or 'n', the leading N--by--K part of
!>           the array A must contain the matrix A, otherwise the leading
!>           K--by--N part of the array A must contain the matrix A.
!>           Unchanged on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>           On entry, LDA specifies the first dimension of A as declared
!>           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
!>           then  LDA must be at least  max( 1, n ), otherwise  LDA must
!>           be at least  max( 1, k ).
!>           Unchanged on exit.
!>
[in]BETA
!>          BETA is DOUBLE PRECISION
!>           On entry, BETA specifies the scalar beta.
!>           Unchanged on exit.
!>
[in,out]C
!>          C is COMPLEX*16 array, dimension (N*(N+1)/2)
!>           On entry, the matrix A in RFP Format. RFP Format is
!>           described by TRANSR, UPLO and N. 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 166 of file zhfrk.f.

168*
169* -- LAPACK computational routine --
170* -- LAPACK is a software package provided by Univ. of Tennessee, --
171* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172*
173* .. Scalar Arguments ..
174 DOUBLE PRECISION ALPHA, BETA
175 INTEGER K, LDA, N
176 CHARACTER TRANS, TRANSR, UPLO
177* ..
178* .. Array Arguments ..
179 COMPLEX*16 A( LDA, * ), C( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 DOUBLE PRECISION ONE, ZERO
186 COMPLEX*16 CZERO
187 parameter( one = 1.0d+0, zero = 0.0d+0 )
188 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
189* ..
190* .. Local Scalars ..
191 LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS
192 INTEGER INFO, NROWA, J, NK, N1, N2
193 COMPLEX*16 CALPHA, CBETA
194* ..
195* .. External Functions ..
196 LOGICAL LSAME
197 EXTERNAL lsame
198* ..
199* .. External Subroutines ..
200 EXTERNAL xerbla, zgemm, zherk
201* ..
202* .. Intrinsic Functions ..
203 INTRINSIC max, dcmplx
204* ..
205* .. Executable Statements ..
206*
207*
208* Test the input parameters.
209*
210 info = 0
211 normaltransr = lsame( transr, 'N' )
212 lower = lsame( uplo, 'L' )
213 notrans = lsame( trans, 'N' )
214*
215 IF( notrans ) THEN
216 nrowa = n
217 ELSE
218 nrowa = k
219 END IF
220*
221 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
222 info = -1
223 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
224 info = -2
225 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans, 'C' ) ) THEN
226 info = -3
227 ELSE IF( n.LT.0 ) THEN
228 info = -4
229 ELSE IF( k.LT.0 ) THEN
230 info = -5
231 ELSE IF( lda.LT.max( 1, nrowa ) ) THEN
232 info = -8
233 END IF
234 IF( info.NE.0 ) THEN
235 CALL xerbla( 'ZHFRK ', -info )
236 RETURN
237 END IF
238*
239* Quick return if possible.
240*
241* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not
242* done (it is in ZHERK for example) and left in the general case.
243*
244 IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
245 $ ( beta.EQ.one ) ) )RETURN
246*
247 IF( ( alpha.EQ.zero ) .AND. ( beta.EQ.zero ) ) THEN
248 DO j = 1, ( ( n*( n+1 ) ) / 2 )
249 c( j ) = czero
250 END DO
251 RETURN
252 END IF
253*
254 calpha = dcmplx( alpha, zero )
255 cbeta = dcmplx( beta, zero )
256*
257* C is N-by-N.
258* If N is odd, set NISODD = .TRUE., and N1 and N2.
259* If N is even, NISODD = .FALSE., and NK.
260*
261 IF( mod( n, 2 ).EQ.0 ) THEN
262 nisodd = .false.
263 nk = n / 2
264 ELSE
265 nisodd = .true.
266 IF( lower ) THEN
267 n2 = n / 2
268 n1 = n - n2
269 ELSE
270 n1 = n / 2
271 n2 = n - n1
272 END IF
273 END IF
274*
275 IF( nisodd ) THEN
276*
277* N is odd
278*
279 IF( normaltransr ) THEN
280*
281* N is odd and TRANSR = 'N'
282*
283 IF( lower ) THEN
284*
285* N is odd, TRANSR = 'N', and UPLO = 'L'
286*
287 IF( notrans ) THEN
288*
289* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
290*
291 CALL zherk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,
292 $ beta, c( 1 ), n )
293 CALL zherk( 'U', 'N', n2, k, alpha, a( n1+1, 1 ), lda,
294 $ beta, c( n+1 ), n )
295 CALL zgemm( 'N', 'C', n2, n1, k, calpha, a( n1+1, 1 ),
296 $ lda, a( 1, 1 ), lda, cbeta, c( n1+1 ), n )
297*
298 ELSE
299*
300* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C'
301*
302 CALL zherk( 'L', 'C', n1, k, alpha, a( 1, 1 ), lda,
303 $ beta, c( 1 ), n )
304 CALL zherk( 'U', 'C', n2, k, alpha, a( 1, n1+1 ), lda,
305 $ beta, c( n+1 ), n )
306 CALL zgemm( 'C', 'N', n2, n1, k, calpha, a( 1, n1+1 ),
307 $ lda, a( 1, 1 ), lda, cbeta, c( n1+1 ), n )
308*
309 END IF
310*
311 ELSE
312*
313* N is odd, TRANSR = 'N', and UPLO = 'U'
314*
315 IF( notrans ) THEN
316*
317* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
318*
319 CALL zherk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,
320 $ beta, c( n2+1 ), n )
321 CALL zherk( 'U', 'N', n2, k, alpha, a( n2, 1 ), lda,
322 $ beta, c( n1+1 ), n )
323 CALL zgemm( 'N', 'C', n1, n2, k, calpha, a( 1, 1 ),
324 $ lda, a( n2, 1 ), lda, cbeta, c( 1 ), n )
325*
326 ELSE
327*
328* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C'
329*
330 CALL zherk( 'L', 'C', n1, k, alpha, a( 1, 1 ), lda,
331 $ beta, c( n2+1 ), n )
332 CALL zherk( 'U', 'C', n2, k, alpha, a( 1, n2 ), lda,
333 $ beta, c( n1+1 ), n )
334 CALL zgemm( 'C', 'N', n1, n2, k, calpha, a( 1, 1 ),
335 $ lda, a( 1, n2 ), lda, cbeta, c( 1 ), n )
336*
337 END IF
338*
339 END IF
340*
341 ELSE
342*
343* N is odd, and TRANSR = 'C'
344*
345 IF( lower ) THEN
346*
347* N is odd, TRANSR = 'C', and UPLO = 'L'
348*
349 IF( notrans ) THEN
350*
351* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N'
352*
353 CALL zherk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,
354 $ beta, c( 1 ), n1 )
355 CALL zherk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,
356 $ beta, c( 2 ), n1 )
357 CALL zgemm( 'N', 'C', n1, n2, k, calpha, a( 1, 1 ),
358 $ lda, a( n1+1, 1 ), lda, cbeta,
359 $ c( n1*n1+1 ), n1 )
360*
361 ELSE
362*
363* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C'
364*
365 CALL zherk( 'U', 'C', n1, k, alpha, a( 1, 1 ), lda,
366 $ beta, c( 1 ), n1 )
367 CALL zherk( 'L', 'C', n2, k, alpha, a( 1, n1+1 ), lda,
368 $ beta, c( 2 ), n1 )
369 CALL zgemm( 'C', 'N', n1, n2, k, calpha, a( 1, 1 ),
370 $ lda, a( 1, n1+1 ), lda, cbeta,
371 $ c( n1*n1+1 ), n1 )
372*
373 END IF
374*
375 ELSE
376*
377* N is odd, TRANSR = 'C', and UPLO = 'U'
378*
379 IF( notrans ) THEN
380*
381* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N'
382*
383 CALL zherk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,
384 $ beta, c( n2*n2+1 ), n2 )
385 CALL zherk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,
386 $ beta, c( n1*n2+1 ), n2 )
387 CALL zgemm( 'N', 'C', n2, n1, k, calpha, a( n1+1, 1 ),
388 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), n2 )
389*
390 ELSE
391*
392* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C'
393*
394 CALL zherk( 'U', 'C', n1, k, alpha, a( 1, 1 ), lda,
395 $ beta, c( n2*n2+1 ), n2 )
396 CALL zherk( 'L', 'C', n2, k, alpha, a( 1, n1+1 ), lda,
397 $ beta, c( n1*n2+1 ), n2 )
398 CALL zgemm( 'C', 'N', n2, n1, k, calpha, a( 1, n1+1 ),
399 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), n2 )
400*
401 END IF
402*
403 END IF
404*
405 END IF
406*
407 ELSE
408*
409* N is even
410*
411 IF( normaltransr ) THEN
412*
413* N is even and TRANSR = 'N'
414*
415 IF( lower ) THEN
416*
417* N is even, TRANSR = 'N', and UPLO = 'L'
418*
419 IF( notrans ) THEN
420*
421* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
422*
423 CALL zherk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,
424 $ beta, c( 2 ), n+1 )
425 CALL zherk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
426 $ beta, c( 1 ), n+1 )
427 CALL zgemm( 'N', 'C', nk, nk, k, calpha, a( nk+1, 1 ),
428 $ lda, a( 1, 1 ), lda, cbeta, c( nk+2 ),
429 $ n+1 )
430*
431 ELSE
432*
433* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C'
434*
435 CALL zherk( 'L', 'C', nk, k, alpha, a( 1, 1 ), lda,
436 $ beta, c( 2 ), n+1 )
437 CALL zherk( 'U', 'C', nk, k, alpha, a( 1, nk+1 ), lda,
438 $ beta, c( 1 ), n+1 )
439 CALL zgemm( 'C', 'N', nk, nk, k, calpha, a( 1, nk+1 ),
440 $ lda, a( 1, 1 ), lda, cbeta, c( nk+2 ),
441 $ n+1 )
442*
443 END IF
444*
445 ELSE
446*
447* N is even, TRANSR = 'N', and UPLO = 'U'
448*
449 IF( notrans ) THEN
450*
451* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
452*
453 CALL zherk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,
454 $ beta, c( nk+2 ), n+1 )
455 CALL zherk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
456 $ beta, c( nk+1 ), n+1 )
457 CALL zgemm( 'N', 'C', nk, nk, k, calpha, a( 1, 1 ),
458 $ lda, a( nk+1, 1 ), lda, cbeta, c( 1 ),
459 $ n+1 )
460*
461 ELSE
462*
463* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C'
464*
465 CALL zherk( 'L', 'C', nk, k, alpha, a( 1, 1 ), lda,
466 $ beta, c( nk+2 ), n+1 )
467 CALL zherk( 'U', 'C', nk, k, alpha, a( 1, nk+1 ), lda,
468 $ beta, c( nk+1 ), n+1 )
469 CALL zgemm( 'C', 'N', nk, nk, k, calpha, a( 1, 1 ),
470 $ lda, a( 1, nk+1 ), lda, cbeta, c( 1 ),
471 $ n+1 )
472*
473 END IF
474*
475 END IF
476*
477 ELSE
478*
479* N is even, and TRANSR = 'C'
480*
481 IF( lower ) THEN
482*
483* N is even, TRANSR = 'C', and UPLO = 'L'
484*
485 IF( notrans ) THEN
486*
487* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N'
488*
489 CALL zherk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,
490 $ beta, c( nk+1 ), nk )
491 CALL zherk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
492 $ beta, c( 1 ), nk )
493 CALL zgemm( 'N', 'C', nk, nk, k, calpha, a( 1, 1 ),
494 $ lda, a( nk+1, 1 ), lda, cbeta,
495 $ c( ( ( nk+1 )*nk )+1 ), nk )
496*
497 ELSE
498*
499* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C'
500*
501 CALL zherk( 'U', 'C', nk, k, alpha, a( 1, 1 ), lda,
502 $ beta, c( nk+1 ), nk )
503 CALL zherk( 'L', 'C', nk, k, alpha, a( 1, nk+1 ), lda,
504 $ beta, c( 1 ), nk )
505 CALL zgemm( 'C', 'N', nk, nk, k, calpha, a( 1, 1 ),
506 $ lda, a( 1, nk+1 ), lda, cbeta,
507 $ c( ( ( nk+1 )*nk )+1 ), nk )
508*
509 END IF
510*
511 ELSE
512*
513* N is even, TRANSR = 'C', and UPLO = 'U'
514*
515 IF( notrans ) THEN
516*
517* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N'
518*
519 CALL zherk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,
520 $ beta, c( nk*( nk+1 )+1 ), nk )
521 CALL zherk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
522 $ beta, c( nk*nk+1 ), nk )
523 CALL zgemm( 'N', 'C', nk, nk, k, calpha, a( nk+1, 1 ),
524 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), nk )
525*
526 ELSE
527*
528* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C'
529*
530 CALL zherk( 'U', 'C', nk, k, alpha, a( 1, 1 ), lda,
531 $ beta, c( nk*( nk+1 )+1 ), nk )
532 CALL zherk( 'L', 'C', nk, k, alpha, a( 1, nk+1 ), lda,
533 $ beta, c( nk*nk+1 ), nk )
534 CALL zgemm( 'C', 'N', nk, nk, k, calpha, a( 1, nk+1 ),
535 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), nk )
536*
537 END IF
538*
539 END IF
540*
541 END IF
542*
543 END IF
544*
545 RETURN
546*
547* End of ZHFRK
548*
alpha
#define alpha
Definition eval.h:35
zherk
subroutine zherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
ZHERK
Definition zherk.f:173

◆ zhpcon()

subroutine zhpcon ( character uplo,
integer n,
complex*16, dimension( * ) ap,
integer, dimension( * ) ipiv,
double precision anorm,
double precision rcond,
complex*16, dimension( * ) work,
integer info )

ZHPCON

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

Purpose:
!>
!> ZHPCON estimates the reciprocal of the condition number of a complex
!> Hermitian packed matrix A using the factorization A = U*D*U**H or
!> A = L*D*L**H computed by ZHPTRF.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**H;
!>          = 'L':  Lower triangular, form is A = L*D*L**H.
!>
[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 block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZHPTRF, stored as a
!>          packed triangular matrix.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZHPTRF.
!>
[in]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The 1-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file zhpcon.f.

118*
119* -- LAPACK computational routine --
120* -- LAPACK is a software package provided by Univ. of Tennessee, --
121* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
122*
123* .. Scalar Arguments ..
124 CHARACTER UPLO
125 INTEGER INFO, N
126 DOUBLE PRECISION ANORM, RCOND
127* ..
128* .. Array Arguments ..
129 INTEGER IPIV( * )
130 COMPLEX*16 AP( * ), WORK( * )
131* ..
132*
133* =====================================================================
134*
135* .. Parameters ..
136 DOUBLE PRECISION ONE, ZERO
137 parameter( one = 1.0d+0, zero = 0.0d+0 )
138* ..
139* .. Local Scalars ..
140 LOGICAL UPPER
141 INTEGER I, IP, KASE
142 DOUBLE PRECISION AINVNM
143* ..
144* .. Local Arrays ..
145 INTEGER ISAVE( 3 )
146* ..
147* .. External Functions ..
148 LOGICAL LSAME
149 EXTERNAL lsame
150* ..
151* .. External Subroutines ..
152 EXTERNAL xerbla, zhptrs, zlacn2
153* ..
154* .. Executable Statements ..
155*
156* Test the input parameters.
157*
158 info = 0
159 upper = lsame( uplo, 'U' )
160 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
161 info = -1
162 ELSE IF( n.LT.0 ) THEN
163 info = -2
164 ELSE IF( anorm.LT.zero ) THEN
165 info = -5
166 END IF
167 IF( info.NE.0 ) THEN
168 CALL xerbla( 'ZHPCON', -info )
169 RETURN
170 END IF
171*
172* Quick return if possible
173*
174 rcond = zero
175 IF( n.EQ.0 ) THEN
176 rcond = one
177 RETURN
178 ELSE IF( anorm.LE.zero ) THEN
179 RETURN
180 END IF
181*
182* Check that the diagonal matrix D is nonsingular.
183*
184 IF( upper ) THEN
185*
186* Upper triangular storage: examine D from bottom to top
187*
188 ip = n*( n+1 ) / 2
189 DO 10 i = n, 1, -1
190 IF( ipiv( i ).GT.0 .AND. ap( ip ).EQ.zero )
191 $ RETURN
192 ip = ip - i
193 10 CONTINUE
194 ELSE
195*
196* Lower triangular storage: examine D from top to bottom.
197*
198 ip = 1
199 DO 20 i = 1, n
200 IF( ipiv( i ).GT.0 .AND. ap( ip ).EQ.zero )
201 $ RETURN
202 ip = ip + n - i + 1
203 20 CONTINUE
204 END IF
205*
206* Estimate the 1-norm of the inverse.
207*
208 kase = 0
209 30 CONTINUE
210 CALL zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
211 IF( kase.NE.0 ) THEN
212*
213* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
214*
215 CALL zhptrs( uplo, n, 1, ap, ipiv, work, n, info )
216 GO TO 30
217 END IF
218*
219* Compute the estimate of the reciprocal condition number.
220*
221 IF( ainvnm.NE.zero )
222 $ rcond = ( one / ainvnm ) / anorm
223*
224 RETURN
225*
226* End of ZHPCON
227*
zlacn2
subroutine zlacn2(n, v, x, est, kase, isave)
ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
Definition zlacn2.f:133
zhptrs
subroutine zhptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
ZHPTRS
Definition zhptrs.f:115

◆ zhpgst()

subroutine zhpgst ( integer itype,
character uplo,
integer n,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) bp,
integer info )

ZHPGST

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

Purpose:
!>
!> ZHPGST reduces a complex Hermitian-definite generalized
!> eigenproblem to standard form, using packed storage.
!>
!> If ITYPE = 1, the problem is A*x = lambda*B*x,
!> and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
!>
!> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
!> B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.
!>
!> B must have been previously factorized as U**H*U or L*L**H by ZPPTRF.
!>
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
!>          = 2 or 3: compute U*A*U**H or L**H*A*L.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored and B is factored as
!>                  U**H*U;
!>          = 'L':  Lower triangle of A is stored and B is factored as
!>                  L*L**H.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A and B.  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, if INFO = 0, the transformed matrix, stored in the
!>          same format as A.
!>
[in]BP
!>          BP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The triangular factor from the Cholesky factorization of B,
!>          stored in the same format as A, as returned by ZPPTRF.
!>
[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 112 of file zhpgst.f.

113*
114* -- LAPACK computational routine --
115* -- LAPACK is a software package provided by Univ. of Tennessee, --
116* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
117*
118* .. Scalar Arguments ..
119 CHARACTER UPLO
120 INTEGER INFO, ITYPE, N
121* ..
122* .. Array Arguments ..
123 COMPLEX*16 AP( * ), BP( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 DOUBLE PRECISION ONE, HALF
130 parameter( one = 1.0d+0, half = 0.5d+0 )
131 COMPLEX*16 CONE
132 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
133* ..
134* .. Local Scalars ..
135 LOGICAL UPPER
136 INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK
137 DOUBLE PRECISION AJJ, AKK, BJJ, BKK
138 COMPLEX*16 CT
139* ..
140* .. External Subroutines ..
141 EXTERNAL xerbla, zaxpy, zdscal, zhpmv, zhpr2, ztpmv,
142 $ ztpsv
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC dble
146* ..
147* .. External Functions ..
148 LOGICAL LSAME
149 COMPLEX*16 ZDOTC
150 EXTERNAL lsame, zdotc
151* ..
152* .. Executable Statements ..
153*
154* Test the input parameters.
155*
156 info = 0
157 upper = lsame( uplo, 'U' )
158 IF( itype.LT.1 .OR. itype.GT.3 ) THEN
159 info = -1
160 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
161 info = -2
162 ELSE IF( n.LT.0 ) THEN
163 info = -3
164 END IF
165 IF( info.NE.0 ) THEN
166 CALL xerbla( 'ZHPGST', -info )
167 RETURN
168 END IF
169*
170 IF( itype.EQ.1 ) THEN
171 IF( upper ) THEN
172*
173* Compute inv(U**H)*A*inv(U)
174*
175* J1 and JJ are the indices of A(1,j) and A(j,j)
176*
177 jj = 0
178 DO 10 j = 1, n
179 j1 = jj + 1
180 jj = jj + j
181*
182* Compute the j-th column of the upper triangle of A
183*
184 ap( jj ) = dble( ap( jj ) )
185 bjj = dble( bp( jj ) )
186 CALL ztpsv( uplo, 'Conjugate transpose', 'Non-unit', j,
187 $ bp, ap( j1 ), 1 )
188 CALL zhpmv( uplo, j-1, -cone, ap, bp( j1 ), 1, cone,
189 $ ap( j1 ), 1 )
190 CALL zdscal( j-1, one / bjj, ap( j1 ), 1 )
191 ap( jj ) = ( ap( jj )-zdotc( j-1, ap( j1 ), 1, bp( j1 ),
192 $ 1 ) ) / bjj
193 10 CONTINUE
194 ELSE
195*
196* Compute inv(L)*A*inv(L**H)
197*
198* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
199*
200 kk = 1
201 DO 20 k = 1, n
202 k1k1 = kk + n - k + 1
203*
204* Update the lower triangle of A(k:n,k:n)
205*
206 akk = dble( ap( kk ) )
207 bkk = dble( bp( kk ) )
208 akk = akk / bkk**2
209 ap( kk ) = akk
210 IF( k.LT.n ) THEN
211 CALL zdscal( n-k, one / bkk, ap( kk+1 ), 1 )
212 ct = -half*akk
213 CALL zaxpy( n-k, ct, bp( kk+1 ), 1, ap( kk+1 ), 1 )
214 CALL zhpr2( uplo, n-k, -cone, ap( kk+1 ), 1,
215 $ bp( kk+1 ), 1, ap( k1k1 ) )
216 CALL zaxpy( n-k, ct, bp( kk+1 ), 1, ap( kk+1 ), 1 )
217 CALL ztpsv( uplo, 'No transpose', 'Non-unit', n-k,
218 $ bp( k1k1 ), ap( kk+1 ), 1 )
219 END IF
220 kk = k1k1
221 20 CONTINUE
222 END IF
223 ELSE
224 IF( upper ) THEN
225*
226* Compute U*A*U**H
227*
228* K1 and KK are the indices of A(1,k) and A(k,k)
229*
230 kk = 0
231 DO 30 k = 1, n
232 k1 = kk + 1
233 kk = kk + k
234*
235* Update the upper triangle of A(1:k,1:k)
236*
237 akk = dble( ap( kk ) )
238 bkk = dble( bp( kk ) )
239 CALL ztpmv( uplo, 'No transpose', 'Non-unit', k-1, bp,
240 $ ap( k1 ), 1 )
241 ct = half*akk
242 CALL zaxpy( k-1, ct, bp( k1 ), 1, ap( k1 ), 1 )
243 CALL zhpr2( uplo, k-1, cone, ap( k1 ), 1, bp( k1 ), 1,
244 $ ap )
245 CALL zaxpy( k-1, ct, bp( k1 ), 1, ap( k1 ), 1 )
246 CALL zdscal( k-1, bkk, ap( k1 ), 1 )
247 ap( kk ) = akk*bkk**2
248 30 CONTINUE
249 ELSE
250*
251* Compute L**H *A*L
252*
253* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
254*
255 jj = 1
256 DO 40 j = 1, n
257 j1j1 = jj + n - j + 1
258*
259* Compute the j-th column of the lower triangle of A
260*
261 ajj = dble( ap( jj ) )
262 bjj = dble( bp( jj ) )
263 ap( jj ) = ajj*bjj + zdotc( n-j, ap( jj+1 ), 1,
264 $ bp( jj+1 ), 1 )
265 CALL zdscal( n-j, bjj, ap( jj+1 ), 1 )
266 CALL zhpmv( uplo, n-j, cone, ap( j1j1 ), bp( jj+1 ), 1,
267 $ cone, ap( jj+1 ), 1 )
268 CALL ztpmv( uplo, 'Conjugate transpose', 'Non-unit',
269 $ n-j+1, bp( jj ), ap( jj ), 1 )
270 jj = j1j1
271 40 CONTINUE
272 END IF
273 END IF
274 RETURN
275*
276* End of ZHPGST
277*
ztpsv
subroutine ztpsv(uplo, trans, diag, n, ap, x, incx)
ZTPSV
Definition ztpsv.f:144
zhpr2
subroutine zhpr2(uplo, n, alpha, x, incx, y, incy, ap)
ZHPR2
Definition zhpr2.f:145
zhpmv
subroutine zhpmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
ZHPMV
Definition zhpmv.f:149
ztpmv
subroutine ztpmv(uplo, trans, diag, n, ap, x, incx)
ZTPMV
Definition ztpmv.f:142

◆ zhprfs()

subroutine zhprfs ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) afp,
integer, dimension( * ) ipiv,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZHPRFS

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

Purpose:
!>
!> ZHPRFS improves the computed solution to a system of linear
!> equations when the coefficient matrix is Hermitian indefinite
!> and packed, and provides error bounds and backward error estimates
!> for the solution.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[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 B and X.  NRHS >= 0.
!>
[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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!>
[in]AFP
!>          AFP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The factored form of the matrix A.  AFP contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor U or L from the factorization A = U*D*U**H or
!>          A = L*D*L**H as computed by ZHPTRF, stored as a packed
!>          triangular matrix.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZHPTRF.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by ZHPTRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Internal Parameters:
!>  ITMAX is the maximum number of steps of iterative refinement.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 178 of file zhprfs.f.

180*
181* -- LAPACK computational routine --
182* -- LAPACK is a software package provided by Univ. of Tennessee, --
183* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
184*
185* .. Scalar Arguments ..
186 CHARACTER UPLO
187 INTEGER INFO, LDB, LDX, N, NRHS
188* ..
189* .. Array Arguments ..
190 INTEGER IPIV( * )
191 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
192 COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
193 $ X( LDX, * )
194* ..
195*
196* =====================================================================
197*
198* .. Parameters ..
199 INTEGER ITMAX
200 parameter( itmax = 5 )
201 DOUBLE PRECISION ZERO
202 parameter( zero = 0.0d+0 )
203 COMPLEX*16 ONE
204 parameter( one = ( 1.0d+0, 0.0d+0 ) )
205 DOUBLE PRECISION TWO
206 parameter( two = 2.0d+0 )
207 DOUBLE PRECISION THREE
208 parameter( three = 3.0d+0 )
209* ..
210* .. Local Scalars ..
211 LOGICAL UPPER
212 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
213 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
214 COMPLEX*16 ZDUM
215* ..
216* .. Local Arrays ..
217 INTEGER ISAVE( 3 )
218* ..
219* .. External Subroutines ..
220 EXTERNAL xerbla, zaxpy, zcopy, zhpmv, zhptrs, zlacn2
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC abs, dble, dimag, max
224* ..
225* .. External Functions ..
226 LOGICAL LSAME
227 DOUBLE PRECISION DLAMCH
228 EXTERNAL lsame, dlamch
229* ..
230* .. Statement Functions ..
231 DOUBLE PRECISION CABS1
232* ..
233* .. Statement Function definitions ..
234 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
235* ..
236* .. Executable Statements ..
237*
238* Test the input parameters.
239*
240 info = 0
241 upper = lsame( uplo, 'U' )
242 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
243 info = -1
244 ELSE IF( n.LT.0 ) THEN
245 info = -2
246 ELSE IF( nrhs.LT.0 ) THEN
247 info = -3
248 ELSE IF( ldb.LT.max( 1, n ) ) THEN
249 info = -8
250 ELSE IF( ldx.LT.max( 1, n ) ) THEN
251 info = -10
252 END IF
253 IF( info.NE.0 ) THEN
254 CALL xerbla( 'ZHPRFS', -info )
255 RETURN
256 END IF
257*
258* Quick return if possible
259*
260 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
261 DO 10 j = 1, nrhs
262 ferr( j ) = zero
263 berr( j ) = zero
264 10 CONTINUE
265 RETURN
266 END IF
267*
268* NZ = maximum number of nonzero elements in each row of A, plus 1
269*
270 nz = n + 1
271 eps = dlamch( 'Epsilon' )
272 safmin = dlamch( 'Safe minimum' )
273 safe1 = nz*safmin
274 safe2 = safe1 / eps
275*
276* Do for each right hand side
277*
278 DO 140 j = 1, nrhs
279*
280 count = 1
281 lstres = three
282 20 CONTINUE
283*
284* Loop until stopping criterion is satisfied.
285*
286* Compute residual R = B - A * X
287*
288 CALL zcopy( n, b( 1, j ), 1, work, 1 )
289 CALL zhpmv( uplo, n, -one, ap, x( 1, j ), 1, one, work, 1 )
290*
291* Compute componentwise relative backward error from formula
292*
293* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
294*
295* where abs(Z) is the componentwise absolute value of the matrix
296* or vector Z. If the i-th component of the denominator is less
297* than SAFE2, then SAFE1 is added to the i-th components of the
298* numerator and denominator before dividing.
299*
300 DO 30 i = 1, n
301 rwork( i ) = cabs1( b( i, j ) )
302 30 CONTINUE
303*
304* Compute abs(A)*abs(X) + abs(B).
305*
306 kk = 1
307 IF( upper ) THEN
308 DO 50 k = 1, n
309 s = zero
310 xk = cabs1( x( k, j ) )
311 ik = kk
312 DO 40 i = 1, k - 1
313 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
314 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
315 ik = ik + 1
316 40 CONTINUE
317 rwork( k ) = rwork( k ) + abs( dble( ap( kk+k-1 ) ) )*
318 $ xk + s
319 kk = kk + k
320 50 CONTINUE
321 ELSE
322 DO 70 k = 1, n
323 s = zero
324 xk = cabs1( x( k, j ) )
325 rwork( k ) = rwork( k ) + abs( dble( ap( kk ) ) )*xk
326 ik = kk + 1
327 DO 60 i = k + 1, n
328 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
329 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
330 ik = ik + 1
331 60 CONTINUE
332 rwork( k ) = rwork( k ) + s
333 kk = kk + ( n-k+1 )
334 70 CONTINUE
335 END IF
336 s = zero
337 DO 80 i = 1, n
338 IF( rwork( i ).GT.safe2 ) THEN
339 s = max( s, cabs1( work( i ) ) / rwork( i ) )
340 ELSE
341 s = max( s, ( cabs1( work( i ) )+safe1 ) /
342 $ ( rwork( i )+safe1 ) )
343 END IF
344 80 CONTINUE
345 berr( j ) = s
346*
347* Test stopping criterion. Continue iterating if
348* 1) The residual BERR(J) is larger than machine epsilon, and
349* 2) BERR(J) decreased by at least a factor of 2 during the
350* last iteration, and
351* 3) At most ITMAX iterations tried.
352*
353 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
354 $ count.LE.itmax ) THEN
355*
356* Update solution and try again.
357*
358 CALL zhptrs( uplo, n, 1, afp, ipiv, work, n, info )
359 CALL zaxpy( n, one, work, 1, x( 1, j ), 1 )
360 lstres = berr( j )
361 count = count + 1
362 GO TO 20
363 END IF
364*
365* Bound error from formula
366*
367* norm(X - XTRUE) / norm(X) .le. FERR =
368* norm( abs(inv(A))*
369* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
370*
371* where
372* norm(Z) is the magnitude of the largest component of Z
373* inv(A) is the inverse of A
374* abs(Z) is the componentwise absolute value of the matrix or
375* vector Z
376* NZ is the maximum number of nonzeros in any row of A, plus 1
377* EPS is machine epsilon
378*
379* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
380* is incremented by SAFE1 if the i-th component of
381* abs(A)*abs(X) + abs(B) is less than SAFE2.
382*
383* Use ZLACN2 to estimate the infinity-norm of the matrix
384* inv(A) * diag(W),
385* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
386*
387 DO 90 i = 1, n
388 IF( rwork( i ).GT.safe2 ) THEN
389 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
390 ELSE
391 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
392 $ safe1
393 END IF
394 90 CONTINUE
395*
396 kase = 0
397 100 CONTINUE
398 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
399 IF( kase.NE.0 ) THEN
400 IF( kase.EQ.1 ) THEN
401*
402* Multiply by diag(W)*inv(A**H).
403*
404 CALL zhptrs( uplo, n, 1, afp, ipiv, work, n, info )
405 DO 110 i = 1, n
406 work( i ) = rwork( i )*work( i )
407 110 CONTINUE
408 ELSE IF( kase.EQ.2 ) THEN
409*
410* Multiply by inv(A)*diag(W).
411*
412 DO 120 i = 1, n
413 work( i ) = rwork( i )*work( i )
414 120 CONTINUE
415 CALL zhptrs( uplo, n, 1, afp, ipiv, work, n, info )
416 END IF
417 GO TO 100
418 END IF
419*
420* Normalize error.
421*
422 lstres = zero
423 DO 130 i = 1, n
424 lstres = max( lstres, cabs1( x( i, j ) ) )
425 130 CONTINUE
426 IF( lstres.NE.zero )
427 $ ferr( j ) = ferr( j ) / lstres
428*
429 140 CONTINUE
430*
431 RETURN
432*
433* End of ZHPRFS
434*

◆ zhptrd()

subroutine zhptrd ( character uplo,
integer n,
complex*16, dimension( * ) ap,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( * ) tau,
integer info )

ZHPTRD

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

Purpose:
!>
!> ZHPTRD reduces a complex Hermitian matrix A stored in packed form to
!> real symmetric tridiagonal form T by a unitary similarity
!> transformation: Q**H * A * Q = T.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!>          On exit, if UPLO = 'U', the diagonal and first superdiagonal
!>          of A are overwritten by the corresponding elements of the
!>          tridiagonal matrix T, and the elements above the first
!>          superdiagonal, with the array TAU, represent the unitary
!>          matrix Q as a product of elementary reflectors; if UPLO
!>          = 'L', the diagonal and first subdiagonal of A are over-
!>          written by the corresponding elements of the tridiagonal
!>          matrix T, and the elements below the first subdiagonal, with
!>          the array TAU, represent the unitary matrix Q as a product
!>          of elementary reflectors. See Further Details.
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[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.
Further Details:
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(n-1) . . . H(2) H(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+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
!>  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(n-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(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
!>  overwriting A(i+2:n,i), and tau is stored in TAU(i).
!>

Definition at line 150 of file zhptrd.f.

151*
152* -- LAPACK computational routine --
153* -- LAPACK is a software package provided by Univ. of Tennessee, --
154* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
155*
156* .. Scalar Arguments ..
157 CHARACTER UPLO
158 INTEGER INFO, N
159* ..
160* .. Array Arguments ..
161 DOUBLE PRECISION D( * ), E( * )
162 COMPLEX*16 AP( * ), TAU( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 COMPLEX*16 ONE, ZERO, HALF
169 parameter( one = ( 1.0d+0, 0.0d+0 ),
170 $ zero = ( 0.0d+0, 0.0d+0 ),
171 $ half = ( 0.5d+0, 0.0d+0 ) )
172* ..
173* .. Local Scalars ..
174 LOGICAL UPPER
175 INTEGER I, I1, I1I1, II
176 COMPLEX*16 ALPHA, TAUI
177* ..
178* .. External Subroutines ..
179 EXTERNAL xerbla, zaxpy, zhpmv, zhpr2, zlarfg
180* ..
181* .. External Functions ..
182 LOGICAL LSAME
183 COMPLEX*16 ZDOTC
184 EXTERNAL lsame, zdotc
185* ..
186* .. Intrinsic Functions ..
187 INTRINSIC dble
188* ..
189* .. Executable Statements ..
190*
191* Test the input parameters
192*
193 info = 0
194 upper = lsame( uplo, 'U' )
195 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
196 info = -1
197 ELSE IF( n.LT.0 ) THEN
198 info = -2
199 END IF
200 IF( info.NE.0 ) THEN
201 CALL xerbla( 'ZHPTRD', -info )
202 RETURN
203 END IF
204*
205* Quick return if possible
206*
207 IF( n.LE.0 )
208 $ RETURN
209*
210 IF( upper ) THEN
211*
212* Reduce the upper triangle of A.
213* I1 is the index in AP of A(1,I+1).
214*
215 i1 = n*( n-1 ) / 2 + 1
216 ap( i1+n-1 ) = dble( ap( i1+n-1 ) )
217 DO 10 i = n - 1, 1, -1
218*
219* Generate elementary reflector H(i) = I - tau * v * v**H
220* to annihilate A(1:i-1,i+1)
221*
222 alpha = ap( i1+i-1 )
223 CALL zlarfg( i, alpha, ap( i1 ), 1, taui )
224 e( i ) = dble( alpha )
225*
226 IF( taui.NE.zero ) THEN
227*
228* Apply H(i) from both sides to A(1:i,1:i)
229*
230 ap( i1+i-1 ) = one
231*
232* Compute y := tau * A * v storing y in TAU(1:i)
233*
234 CALL zhpmv( uplo, i, taui, ap, ap( i1 ), 1, zero, tau,
235 $ 1 )
236*
237* Compute w := y - 1/2 * tau * (y**H *v) * v
238*
239 alpha = -half*taui*zdotc( i, tau, 1, ap( i1 ), 1 )
240 CALL zaxpy( i, alpha, ap( i1 ), 1, tau, 1 )
241*
242* Apply the transformation as a rank-2 update:
243* A := A - v * w**H - w * v**H
244*
245 CALL zhpr2( uplo, i, -one, ap( i1 ), 1, tau, 1, ap )
246*
247 END IF
248 ap( i1+i-1 ) = e( i )
249 d( i+1 ) = dble( ap( i1+i ) )
250 tau( i ) = taui
251 i1 = i1 - i
252 10 CONTINUE
253 d( 1 ) = dble( ap( 1 ) )
254 ELSE
255*
256* Reduce the lower triangle of A. II is the index in AP of
257* A(i,i) and I1I1 is the index of A(i+1,i+1).
258*
259 ii = 1
260 ap( 1 ) = dble( ap( 1 ) )
261 DO 20 i = 1, n - 1
262 i1i1 = ii + n - i + 1
263*
264* Generate elementary reflector H(i) = I - tau * v * v**H
265* to annihilate A(i+2:n,i)
266*
267 alpha = ap( ii+1 )
268 CALL zlarfg( n-i, alpha, ap( ii+2 ), 1, taui )
269 e( i ) = dble( alpha )
270*
271 IF( taui.NE.zero ) THEN
272*
273* Apply H(i) from both sides to A(i+1:n,i+1:n)
274*
275 ap( ii+1 ) = one
276*
277* Compute y := tau * A * v storing y in TAU(i:n-1)
278*
279 CALL zhpmv( uplo, n-i, taui, ap( i1i1 ), ap( ii+1 ), 1,
280 $ zero, tau( i ), 1 )
281*
282* Compute w := y - 1/2 * tau * (y**H *v) * v
283*
284 alpha = -half*taui*zdotc( n-i, tau( i ), 1, ap( ii+1 ),
285 $ 1 )
286 CALL zaxpy( n-i, alpha, ap( ii+1 ), 1, tau( i ), 1 )
287*
288* Apply the transformation as a rank-2 update:
289* A := A - v * w**H - w * v**H
290*
291 CALL zhpr2( uplo, n-i, -one, ap( ii+1 ), 1, tau( i ), 1,
292 $ ap( i1i1 ) )
293*
294 END IF
295 ap( ii+1 ) = e( i )
296 d( i ) = dble( ap( ii ) )
297 tau( i ) = taui
298 ii = i1i1
299 20 CONTINUE
300 d( n ) = dble( ap( ii ) )
301 END IF
302*
303 RETURN
304*
305* End of ZHPTRD
306*
zlarfg
subroutine zlarfg(n, alpha, x, incx, tau)
ZLARFG generates an elementary reflector (Householder matrix).
Definition zlarfg.f:106

◆ zhptrf()

subroutine zhptrf ( character uplo,
integer n,
complex*16, dimension( * ) ap,
integer, dimension( * ) ipiv,
integer info )

ZHPTRF

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

Purpose:
!>
!> ZHPTRF computes the factorization of a complex Hermitian packed
!> matrix A using the Bunch-Kaufman diagonal pivoting method:
!>
!>    A = U*D*U**H  or  A = L*D*L**H
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and D is Hermitian and block diagonal with
!> 1-by-1 and 2-by-2 diagonal blocks.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[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 block diagonal matrix D and the multipliers used
!>          to obtain the factor U or L, stored as a packed triangular
!>          matrix overwriting A (see below for further details).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D.
!>          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!>          interchanged and D(k,k) is a 1-by-1 diagonal block.
!>          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
!>          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!>          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
!>          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
!>          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization
!>               has been completed, but the block diagonal matrix D is
!>               exactly singular, and division by zero will occur if it
!>               is used to solve a system of equations.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  If UPLO = 'U', then A = U*D*U**H, where
!>     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!>  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!>  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    v    0   )   k-s
!>     U(k) =  (   0    I    0   )   s
!>             (   0    0    I   )   n-k
!>                k-s   s   n-k
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!>  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!>  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!>
!>  If UPLO = 'L', then A = L*D*L**H, where
!>     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!>  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!>  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    0     0   )  k-1
!>     L(k) =  (   0    I     0   )  s
!>             (   0    v     I   )  n-k-s+1
!>                k-1   s  n-k-s+1
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!>  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!>  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!>
Contributors:
J. Lewis, Boeing Computer Services Company

Definition at line 158 of file zhptrf.f.

159*
160* -- LAPACK computational routine --
161* -- LAPACK is a software package provided by Univ. of Tennessee, --
162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*
164* .. Scalar Arguments ..
165 CHARACTER UPLO
166 INTEGER INFO, N
167* ..
168* .. Array Arguments ..
169 INTEGER IPIV( * )
170 COMPLEX*16 AP( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 DOUBLE PRECISION ZERO, ONE
177 parameter( zero = 0.0d+0, one = 1.0d+0 )
178 DOUBLE PRECISION EIGHT, SEVTEN
179 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
180* ..
181* .. Local Scalars ..
182 LOGICAL UPPER
183 INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
184 $ KSTEP, KX, NPP
185 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, ROWMAX,
186 $ TT
187 COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, ZDUM
188* ..
189* .. External Functions ..
190 LOGICAL LSAME
191 INTEGER IZAMAX
192 DOUBLE PRECISION DLAPY2
193 EXTERNAL lsame, izamax, dlapy2
194* ..
195* .. External Subroutines ..
196 EXTERNAL xerbla, zdscal, zhpr, zswap
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, sqrt
200* ..
201* .. Statement Functions ..
202 DOUBLE PRECISION CABS1
203* ..
204* .. Statement Function definitions ..
205 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
206* ..
207* .. Executable Statements ..
208*
209* Test the input parameters.
210*
211 info = 0
212 upper = lsame( uplo, 'U' )
213 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
214 info = -1
215 ELSE IF( n.LT.0 ) THEN
216 info = -2
217 END IF
218 IF( info.NE.0 ) THEN
219 CALL xerbla( 'ZHPTRF', -info )
220 RETURN
221 END IF
222*
223* Initialize ALPHA for use in choosing pivot block size.
224*
225 alpha = ( one+sqrt( sevten ) ) / eight
226*
227 IF( upper ) THEN
228*
229* Factorize A as U*D*U**H using the upper triangle of A
230*
231* K is the main loop index, decreasing from N to 1 in steps of
232* 1 or 2
233*
234 k = n
235 kc = ( n-1 )*n / 2 + 1
236 10 CONTINUE
237 knc = kc
238*
239* If K < 1, exit from loop
240*
241 IF( k.LT.1 )
242 $ GO TO 110
243 kstep = 1
244*
245* Determine rows and columns to be interchanged and whether
246* a 1-by-1 or 2-by-2 pivot block will be used
247*
248 absakk = abs( dble( ap( kc+k-1 ) ) )
249*
250* IMAX is the row-index of the largest off-diagonal element in
251* column K, and COLMAX is its absolute value
252*
253 IF( k.GT.1 ) THEN
254 imax = izamax( k-1, ap( kc ), 1 )
255 colmax = cabs1( ap( kc+imax-1 ) )
256 ELSE
257 colmax = zero
258 END IF
259*
260 IF( max( absakk, colmax ).EQ.zero ) THEN
261*
262* Column K is zero: set INFO and continue
263*
264 IF( info.EQ.0 )
265 $ info = k
266 kp = k
267 ap( kc+k-1 ) = dble( ap( kc+k-1 ) )
268 ELSE
269 IF( absakk.GE.alpha*colmax ) THEN
270*
271* no interchange, use 1-by-1 pivot block
272*
273 kp = k
274 ELSE
275*
276* JMAX is the column-index of the largest off-diagonal
277* element in row IMAX, and ROWMAX is its absolute value
278*
279 rowmax = zero
280 jmax = imax
281 kx = imax*( imax+1 ) / 2 + imax
282 DO 20 j = imax + 1, k
283 IF( cabs1( ap( kx ) ).GT.rowmax ) THEN
284 rowmax = cabs1( ap( kx ) )
285 jmax = j
286 END IF
287 kx = kx + j
288 20 CONTINUE
289 kpc = ( imax-1 )*imax / 2 + 1
290 IF( imax.GT.1 ) THEN
291 jmax = izamax( imax-1, ap( kpc ), 1 )
292 rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) )
293 END IF
294*
295 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
296*
297* no interchange, use 1-by-1 pivot block
298*
299 kp = k
300 ELSE IF( abs( dble( ap( kpc+imax-1 ) ) ).GE.alpha*
301 $ rowmax ) THEN
302*
303* interchange rows and columns K and IMAX, use 1-by-1
304* pivot block
305*
306 kp = imax
307 ELSE
308*
309* interchange rows and columns K-1 and IMAX, use 2-by-2
310* pivot block
311*
312 kp = imax
313 kstep = 2
314 END IF
315 END IF
316*
317 kk = k - kstep + 1
318 IF( kstep.EQ.2 )
319 $ knc = knc - k + 1
320 IF( kp.NE.kk ) THEN
321*
322* Interchange rows and columns KK and KP in the leading
323* submatrix A(1:k,1:k)
324*
325 CALL zswap( kp-1, ap( knc ), 1, ap( kpc ), 1 )
326 kx = kpc + kp - 1
327 DO 30 j = kp + 1, kk - 1
328 kx = kx + j - 1
329 t = dconjg( ap( knc+j-1 ) )
330 ap( knc+j-1 ) = dconjg( ap( kx ) )
331 ap( kx ) = t
332 30 CONTINUE
333 ap( kx+kk-1 ) = dconjg( ap( kx+kk-1 ) )
334 r1 = dble( ap( knc+kk-1 ) )
335 ap( knc+kk-1 ) = dble( ap( kpc+kp-1 ) )
336 ap( kpc+kp-1 ) = r1
337 IF( kstep.EQ.2 ) THEN
338 ap( kc+k-1 ) = dble( ap( kc+k-1 ) )
339 t = ap( kc+k-2 )
340 ap( kc+k-2 ) = ap( kc+kp-1 )
341 ap( kc+kp-1 ) = t
342 END IF
343 ELSE
344 ap( kc+k-1 ) = dble( ap( kc+k-1 ) )
345 IF( kstep.EQ.2 )
346 $ ap( kc-1 ) = dble( ap( kc-1 ) )
347 END IF
348*
349* Update the leading submatrix
350*
351 IF( kstep.EQ.1 ) THEN
352*
353* 1-by-1 pivot block D(k): column k now holds
354*
355* W(k) = U(k)*D(k)
356*
357* where U(k) is the k-th column of U
358*
359* Perform a rank-1 update of A(1:k-1,1:k-1) as
360*
361* A := A - U(k)*D(k)*U(k)**H = A - W(k)*1/D(k)*W(k)**H
362*
363 r1 = one / dble( ap( kc+k-1 ) )
364 CALL zhpr( uplo, k-1, -r1, ap( kc ), 1, ap )
365*
366* Store U(k) in column k
367*
368 CALL zdscal( k-1, r1, ap( kc ), 1 )
369 ELSE
370*
371* 2-by-2 pivot block D(k): columns k and k-1 now hold
372*
373* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
374*
375* where U(k) and U(k-1) are the k-th and (k-1)-th columns
376* of U
377*
378* Perform a rank-2 update of A(1:k-2,1:k-2) as
379*
380* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**H
381* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**H
382*
383 IF( k.GT.2 ) THEN
384*
385 d = dlapy2( dble( ap( k-1+( k-1 )*k / 2 ) ),
386 $ dimag( ap( k-1+( k-1 )*k / 2 ) ) )
387 d22 = dble( ap( k-1+( k-2 )*( k-1 ) / 2 ) ) / d
388 d11 = dble( ap( k+( k-1 )*k / 2 ) ) / d
389 tt = one / ( d11*d22-one )
390 d12 = ap( k-1+( k-1 )*k / 2 ) / d
391 d = tt / d
392*
393 DO 50 j = k - 2, 1, -1
394 wkm1 = d*( d11*ap( j+( k-2 )*( k-1 ) / 2 )-
395 $ dconjg( d12 )*ap( j+( k-1 )*k / 2 ) )
396 wk = d*( d22*ap( j+( k-1 )*k / 2 )-d12*
397 $ ap( j+( k-2 )*( k-1 ) / 2 ) )
398 DO 40 i = j, 1, -1
399 ap( i+( j-1 )*j / 2 ) = ap( i+( j-1 )*j / 2 ) -
400 $ ap( i+( k-1 )*k / 2 )*dconjg( wk ) -
401 $ ap( i+( k-2 )*( k-1 ) / 2 )*dconjg( wkm1 )
402 40 CONTINUE
403 ap( j+( k-1 )*k / 2 ) = wk
404 ap( j+( k-2 )*( k-1 ) / 2 ) = wkm1
405 ap( j+( j-1 )*j / 2 ) = dcmplx( dble( ap( j+( j-
406 $ 1 )*j / 2 ) ), 0.0d+0 )
407 50 CONTINUE
408*
409 END IF
410*
411 END IF
412 END IF
413*
414* Store details of the interchanges in IPIV
415*
416 IF( kstep.EQ.1 ) THEN
417 ipiv( k ) = kp
418 ELSE
419 ipiv( k ) = -kp
420 ipiv( k-1 ) = -kp
421 END IF
422*
423* Decrease K and return to the start of the main loop
424*
425 k = k - kstep
426 kc = knc - k
427 GO TO 10
428*
429 ELSE
430*
431* Factorize A as L*D*L**H using the lower triangle of A
432*
433* K is the main loop index, increasing from 1 to N in steps of
434* 1 or 2
435*
436 k = 1
437 kc = 1
438 npp = n*( n+1 ) / 2
439 60 CONTINUE
440 knc = kc
441*
442* If K > N, exit from loop
443*
444 IF( k.GT.n )
445 $ GO TO 110
446 kstep = 1
447*
448* Determine rows and columns to be interchanged and whether
449* a 1-by-1 or 2-by-2 pivot block will be used
450*
451 absakk = abs( dble( ap( kc ) ) )
452*
453* IMAX is the row-index of the largest off-diagonal element in
454* column K, and COLMAX is its absolute value
455*
456 IF( k.LT.n ) THEN
457 imax = k + izamax( n-k, ap( kc+1 ), 1 )
458 colmax = cabs1( ap( kc+imax-k ) )
459 ELSE
460 colmax = zero
461 END IF
462*
463 IF( max( absakk, colmax ).EQ.zero ) THEN
464*
465* Column K is zero: set INFO and continue
466*
467 IF( info.EQ.0 )
468 $ info = k
469 kp = k
470 ap( kc ) = dble( ap( kc ) )
471 ELSE
472 IF( absakk.GE.alpha*colmax ) THEN
473*
474* no interchange, use 1-by-1 pivot block
475*
476 kp = k
477 ELSE
478*
479* JMAX is the column-index of the largest off-diagonal
480* element in row IMAX, and ROWMAX is its absolute value
481*
482 rowmax = zero
483 kx = kc + imax - k
484 DO 70 j = k, imax - 1
485 IF( cabs1( ap( kx ) ).GT.rowmax ) THEN
486 rowmax = cabs1( ap( kx ) )
487 jmax = j
488 END IF
489 kx = kx + n - j
490 70 CONTINUE
491 kpc = npp - ( n-imax+1 )*( n-imax+2 ) / 2 + 1
492 IF( imax.LT.n ) THEN
493 jmax = imax + izamax( n-imax, ap( kpc+1 ), 1 )
494 rowmax = max( rowmax, cabs1( ap( kpc+jmax-imax ) ) )
495 END IF
496*
497 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
498*
499* no interchange, use 1-by-1 pivot block
500*
501 kp = k
502 ELSE IF( abs( dble( ap( kpc ) ) ).GE.alpha*rowmax ) THEN
503*
504* interchange rows and columns K and IMAX, use 1-by-1
505* pivot block
506*
507 kp = imax
508 ELSE
509*
510* interchange rows and columns K+1 and IMAX, use 2-by-2
511* pivot block
512*
513 kp = imax
514 kstep = 2
515 END IF
516 END IF
517*
518 kk = k + kstep - 1
519 IF( kstep.EQ.2 )
520 $ knc = knc + n - k + 1
521 IF( kp.NE.kk ) THEN
522*
523* Interchange rows and columns KK and KP in the trailing
524* submatrix A(k:n,k:n)
525*
526 IF( kp.LT.n )
527 $ CALL zswap( n-kp, ap( knc+kp-kk+1 ), 1, ap( kpc+1 ),
528 $ 1 )
529 kx = knc + kp - kk
530 DO 80 j = kk + 1, kp - 1
531 kx = kx + n - j + 1
532 t = dconjg( ap( knc+j-kk ) )
533 ap( knc+j-kk ) = dconjg( ap( kx ) )
534 ap( kx ) = t
535 80 CONTINUE
536 ap( knc+kp-kk ) = dconjg( ap( knc+kp-kk ) )
537 r1 = dble( ap( knc ) )
538 ap( knc ) = dble( ap( kpc ) )
539 ap( kpc ) = r1
540 IF( kstep.EQ.2 ) THEN
541 ap( kc ) = dble( ap( kc ) )
542 t = ap( kc+1 )
543 ap( kc+1 ) = ap( kc+kp-k )
544 ap( kc+kp-k ) = t
545 END IF
546 ELSE
547 ap( kc ) = dble( ap( kc ) )
548 IF( kstep.EQ.2 )
549 $ ap( knc ) = dble( ap( knc ) )
550 END IF
551*
552* Update the trailing submatrix
553*
554 IF( kstep.EQ.1 ) THEN
555*
556* 1-by-1 pivot block D(k): column k now holds
557*
558* W(k) = L(k)*D(k)
559*
560* where L(k) is the k-th column of L
561*
562 IF( k.LT.n ) THEN
563*
564* Perform a rank-1 update of A(k+1:n,k+1:n) as
565*
566* A := A - L(k)*D(k)*L(k)**H = A - W(k)*(1/D(k))*W(k)**H
567*
568 r1 = one / dble( ap( kc ) )
569 CALL zhpr( uplo, n-k, -r1, ap( kc+1 ), 1,
570 $ ap( kc+n-k+1 ) )
571*
572* Store L(k) in column K
573*
574 CALL zdscal( n-k, r1, ap( kc+1 ), 1 )
575 END IF
576 ELSE
577*
578* 2-by-2 pivot block D(k): columns K and K+1 now hold
579*
580* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
581*
582* where L(k) and L(k+1) are the k-th and (k+1)-th columns
583* of L
584*
585 IF( k.LT.n-1 ) THEN
586*
587* Perform a rank-2 update of A(k+2:n,k+2:n) as
588*
589* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**H
590* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**H
591*
592* where L(k) and L(k+1) are the k-th and (k+1)-th
593* columns of L
594*
595 d = dlapy2( dble( ap( k+1+( k-1 )*( 2*n-k ) / 2 ) ),
596 $ dimag( ap( k+1+( k-1 )*( 2*n-k ) / 2 ) ) )
597 d11 = dble( ap( k+1+k*( 2*n-k-1 ) / 2 ) ) / d
598 d22 = dble( ap( k+( k-1 )*( 2*n-k ) / 2 ) ) / d
599 tt = one / ( d11*d22-one )
600 d21 = ap( k+1+( k-1 )*( 2*n-k ) / 2 ) / d
601 d = tt / d
602*
603 DO 100 j = k + 2, n
604 wk = d*( d11*ap( j+( k-1 )*( 2*n-k ) / 2 )-d21*
605 $ ap( j+k*( 2*n-k-1 ) / 2 ) )
606 wkp1 = d*( d22*ap( j+k*( 2*n-k-1 ) / 2 )-
607 $ dconjg( d21 )*ap( j+( k-1 )*( 2*n-k ) /
608 $ 2 ) )
609 DO 90 i = j, n
610 ap( i+( j-1 )*( 2*n-j ) / 2 ) = ap( i+( j-1 )*
611 $ ( 2*n-j ) / 2 ) - ap( i+( k-1 )*( 2*n-k ) /
612 $ 2 )*dconjg( wk ) - ap( i+k*( 2*n-k-1 ) / 2 )*
613 $ dconjg( wkp1 )
614 90 CONTINUE
615 ap( j+( k-1 )*( 2*n-k ) / 2 ) = wk
616 ap( j+k*( 2*n-k-1 ) / 2 ) = wkp1
617 ap( j+( j-1 )*( 2*n-j ) / 2 )
618 $ = dcmplx( dble( ap( j+( j-1 )*( 2*n-j ) / 2 ) ),
619 $ 0.0d+0 )
620 100 CONTINUE
621 END IF
622 END IF
623 END IF
624*
625* Store details of the interchanges in IPIV
626*
627 IF( kstep.EQ.1 ) THEN
628 ipiv( k ) = kp
629 ELSE
630 ipiv( k ) = -kp
631 ipiv( k+1 ) = -kp
632 END IF
633*
634* Increase K and return to the start of the main loop
635*
636 k = k + kstep
637 kc = knc + n - k + 2
638 GO TO 60
639*
640 END IF
641*
642 110 CONTINUE
643 RETURN
644*
645* End of ZHPTRF
646*
dlapy2
double precision function dlapy2(x, y)
DLAPY2 returns sqrt(x2+y2).
Definition dlapy2.f:63
izamax
integer function izamax(n, zx, incx)
IZAMAX
Definition izamax.f:71
zhpr
subroutine zhpr(uplo, n, alpha, x, incx, ap)
ZHPR
Definition zhpr.f:130

◆ zhptri()

subroutine zhptri ( character uplo,
integer n,
complex*16, dimension( * ) ap,
integer, dimension( * ) ipiv,
complex*16, dimension( * ) work,
integer info )

ZHPTRI

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

Purpose:
!>
!> ZHPTRI computes the inverse of a complex Hermitian indefinite matrix
!> A in packed storage using the factorization A = U*D*U**H or
!> A = L*D*L**H computed by ZHPTRF.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**H;
!>          = 'L':  Lower triangular, form is A = L*D*L**H.
!>
[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 block diagonal matrix D and the multipliers
!>          used to obtain the factor U or L as computed by ZHPTRF,
!>          stored as a packed triangular matrix.
!>
!>          On exit, if INFO = 0, the (Hermitian) inverse of the original
!>          matrix, stored as a packed triangular matrix. The j-th column
!>          of inv(A) is stored in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
!>          if UPLO = 'L',
!>             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZHPTRF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
!>               inverse could not be computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 108 of file zhptri.f.

109*
110* -- LAPACK computational 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 UPLO
116 INTEGER INFO, N
117* ..
118* .. Array Arguments ..
119 INTEGER IPIV( * )
120 COMPLEX*16 AP( * ), WORK( * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 DOUBLE PRECISION ONE
127 COMPLEX*16 CONE, ZERO
128 parameter( one = 1.0d+0, cone = ( 1.0d+0, 0.0d+0 ),
129 $ zero = ( 0.0d+0, 0.0d+0 ) )
130* ..
131* .. Local Scalars ..
132 LOGICAL UPPER
133 INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
134 DOUBLE PRECISION AK, AKP1, D, T
135 COMPLEX*16 AKKP1, TEMP
136* ..
137* .. External Functions ..
138 LOGICAL LSAME
139 COMPLEX*16 ZDOTC
140 EXTERNAL lsame, zdotc
141* ..
142* .. External Subroutines ..
143 EXTERNAL xerbla, zcopy, zhpmv, zswap
144* ..
145* .. Intrinsic Functions ..
146 INTRINSIC abs, dble, dconjg
147* ..
148* .. Executable Statements ..
149*
150* Test the input parameters.
151*
152 info = 0
153 upper = lsame( uplo, 'U' )
154 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
155 info = -1
156 ELSE IF( n.LT.0 ) THEN
157 info = -2
158 END IF
159 IF( info.NE.0 ) THEN
160 CALL xerbla( 'ZHPTRI', -info )
161 RETURN
162 END IF
163*
164* Quick return if possible
165*
166 IF( n.EQ.0 )
167 $ RETURN
168*
169* Check that the diagonal matrix D is nonsingular.
170*
171 IF( upper ) THEN
172*
173* Upper triangular storage: examine D from bottom to top
174*
175 kp = n*( n+1 ) / 2
176 DO 10 info = n, 1, -1
177 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
178 $ RETURN
179 kp = kp - info
180 10 CONTINUE
181 ELSE
182*
183* Lower triangular storage: examine D from top to bottom.
184*
185 kp = 1
186 DO 20 info = 1, n
187 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
188 $ RETURN
189 kp = kp + n - info + 1
190 20 CONTINUE
191 END IF
192 info = 0
193*
194 IF( upper ) THEN
195*
196* Compute inv(A) from the factorization A = U*D*U**H.
197*
198* K is the main loop index, increasing from 1 to N in steps of
199* 1 or 2, depending on the size of the diagonal blocks.
200*
201 k = 1
202 kc = 1
203 30 CONTINUE
204*
205* If K > N, exit from loop.
206*
207 IF( k.GT.n )
208 $ GO TO 50
209*
210 kcnext = kc + k
211 IF( ipiv( k ).GT.0 ) THEN
212*
213* 1 x 1 diagonal block
214*
215* Invert the diagonal block.
216*
217 ap( kc+k-1 ) = one / dble( ap( kc+k-1 ) )
218*
219* Compute column K of the inverse.
220*
221 IF( k.GT.1 ) THEN
222 CALL zcopy( k-1, ap( kc ), 1, work, 1 )
223 CALL zhpmv( uplo, k-1, -cone, ap, work, 1, zero,
224 $ ap( kc ), 1 )
225 ap( kc+k-1 ) = ap( kc+k-1 ) -
226 $ dble( zdotc( k-1, work, 1, ap( kc ), 1 ) )
227 END IF
228 kstep = 1
229 ELSE
230*
231* 2 x 2 diagonal block
232*
233* Invert the diagonal block.
234*
235 t = abs( ap( kcnext+k-1 ) )
236 ak = dble( ap( kc+k-1 ) ) / t
237 akp1 = dble( ap( kcnext+k ) ) / t
238 akkp1 = ap( kcnext+k-1 ) / t
239 d = t*( ak*akp1-one )
240 ap( kc+k-1 ) = akp1 / d
241 ap( kcnext+k ) = ak / d
242 ap( kcnext+k-1 ) = -akkp1 / d
243*
244* Compute columns K and K+1 of the inverse.
245*
246 IF( k.GT.1 ) THEN
247 CALL zcopy( k-1, ap( kc ), 1, work, 1 )
248 CALL zhpmv( uplo, k-1, -cone, ap, work, 1, zero,
249 $ ap( kc ), 1 )
250 ap( kc+k-1 ) = ap( kc+k-1 ) -
251 $ dble( zdotc( k-1, work, 1, ap( kc ), 1 ) )
252 ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -
253 $ zdotc( k-1, ap( kc ), 1, ap( kcnext ),
254 $ 1 )
255 CALL zcopy( k-1, ap( kcnext ), 1, work, 1 )
256 CALL zhpmv( uplo, k-1, -cone, ap, work, 1, zero,
257 $ ap( kcnext ), 1 )
258 ap( kcnext+k ) = ap( kcnext+k ) -
259 $ dble( zdotc( k-1, work, 1, ap( kcnext ),
260 $ 1 ) )
261 END IF
262 kstep = 2
263 kcnext = kcnext + k + 1
264 END IF
265*
266 kp = abs( ipiv( k ) )
267 IF( kp.NE.k ) THEN
268*
269* Interchange rows and columns K and KP in the leading
270* submatrix A(1:k+1,1:k+1)
271*
272 kpc = ( kp-1 )*kp / 2 + 1
273 CALL zswap( kp-1, ap( kc ), 1, ap( kpc ), 1 )
274 kx = kpc + kp - 1
275 DO 40 j = kp + 1, k - 1
276 kx = kx + j - 1
277 temp = dconjg( ap( kc+j-1 ) )
278 ap( kc+j-1 ) = dconjg( ap( kx ) )
279 ap( kx ) = temp
280 40 CONTINUE
281 ap( kc+kp-1 ) = dconjg( ap( kc+kp-1 ) )
282 temp = ap( kc+k-1 )
283 ap( kc+k-1 ) = ap( kpc+kp-1 )
284 ap( kpc+kp-1 ) = temp
285 IF( kstep.EQ.2 ) THEN
286 temp = ap( kc+k+k-1 )
287 ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
288 ap( kc+k+kp-1 ) = temp
289 END IF
290 END IF
291*
292 k = k + kstep
293 kc = kcnext
294 GO TO 30
295 50 CONTINUE
296*
297 ELSE
298*
299* Compute inv(A) from the factorization A = L*D*L**H.
300*
301* K is the main loop index, increasing from 1 to N in steps of
302* 1 or 2, depending on the size of the diagonal blocks.
303*
304 npp = n*( n+1 ) / 2
305 k = n
306 kc = npp
307 60 CONTINUE
308*
309* If K < 1, exit from loop.
310*
311 IF( k.LT.1 )
312 $ GO TO 80
313*
314 kcnext = kc - ( n-k+2 )
315 IF( ipiv( k ).GT.0 ) THEN
316*
317* 1 x 1 diagonal block
318*
319* Invert the diagonal block.
320*
321 ap( kc ) = one / dble( ap( kc ) )
322*
323* Compute column K of the inverse.
324*
325 IF( k.LT.n ) THEN
326 CALL zcopy( n-k, ap( kc+1 ), 1, work, 1 )
327 CALL zhpmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1,
328 $ zero, ap( kc+1 ), 1 )
329 ap( kc ) = ap( kc ) - dble( zdotc( n-k, work, 1,
330 $ ap( kc+1 ), 1 ) )
331 END IF
332 kstep = 1
333 ELSE
334*
335* 2 x 2 diagonal block
336*
337* Invert the diagonal block.
338*
339 t = abs( ap( kcnext+1 ) )
340 ak = dble( ap( kcnext ) ) / t
341 akp1 = dble( ap( kc ) ) / t
342 akkp1 = ap( kcnext+1 ) / t
343 d = t*( ak*akp1-one )
344 ap( kcnext ) = akp1 / d
345 ap( kc ) = ak / d
346 ap( kcnext+1 ) = -akkp1 / d
347*
348* Compute columns K-1 and K of the inverse.
349*
350 IF( k.LT.n ) THEN
351 CALL zcopy( n-k, ap( kc+1 ), 1, work, 1 )
352 CALL zhpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,
353 $ 1, zero, ap( kc+1 ), 1 )
354 ap( kc ) = ap( kc ) - dble( zdotc( n-k, work, 1,
355 $ ap( kc+1 ), 1 ) )
356 ap( kcnext+1 ) = ap( kcnext+1 ) -
357 $ zdotc( n-k, ap( kc+1 ), 1,
358 $ ap( kcnext+2 ), 1 )
359 CALL zcopy( n-k, ap( kcnext+2 ), 1, work, 1 )
360 CALL zhpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,
361 $ 1, zero, ap( kcnext+2 ), 1 )
362 ap( kcnext ) = ap( kcnext ) -
363 $ dble( zdotc( n-k, work, 1, ap( kcnext+2 ),
364 $ 1 ) )
365 END IF
366 kstep = 2
367 kcnext = kcnext - ( n-k+3 )
368 END IF
369*
370 kp = abs( ipiv( k ) )
371 IF( kp.NE.k ) THEN
372*
373* Interchange rows and columns K and KP in the trailing
374* submatrix A(k-1:n,k-1:n)
375*
376 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2 + 1
377 IF( kp.LT.n )
378 $ CALL zswap( n-kp, ap( kc+kp-k+1 ), 1, ap( kpc+1 ), 1 )
379 kx = kc + kp - k
380 DO 70 j = k + 1, kp - 1
381 kx = kx + n - j + 1
382 temp = dconjg( ap( kc+j-k ) )
383 ap( kc+j-k ) = dconjg( ap( kx ) )
384 ap( kx ) = temp
385 70 CONTINUE
386 ap( kc+kp-k ) = dconjg( ap( kc+kp-k ) )
387 temp = ap( kc )
388 ap( kc ) = ap( kpc )
389 ap( kpc ) = temp
390 IF( kstep.EQ.2 ) THEN
391 temp = ap( kc-n+k-1 )
392 ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
393 ap( kc-n+kp-1 ) = temp
394 END IF
395 END IF
396*
397 k = k - kstep
398 kc = kcnext
399 GO TO 60
400 80 CONTINUE
401 END IF
402*
403 RETURN
404*
405* End of ZHPTRI
406*

◆ zhptrs()

subroutine zhptrs ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
integer, dimension( * ) ipiv,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZHPTRS

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

Purpose:
!>
!> ZHPTRS solves a system of linear equations A*X = B with a complex
!> Hermitian matrix A stored in packed format using the factorization
!> A = U*D*U**H or A = L*D*L**H computed by ZHPTRF.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**H;
!>          = 'L':  Lower triangular, form is A = L*D*L**H.
!>
[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 matrix B.  NRHS >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZHPTRF, stored as a
!>          packed triangular matrix.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZHPTRF.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 114 of file zhptrs.f.

115*
116* -- LAPACK computational 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 UPLO
122 INTEGER INFO, LDB, N, NRHS
123* ..
124* .. Array Arguments ..
125 INTEGER IPIV( * )
126 COMPLEX*16 AP( * ), B( LDB, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 COMPLEX*16 ONE
133 parameter( one = ( 1.0d+0, 0.0d+0 ) )
134* ..
135* .. Local Scalars ..
136 LOGICAL UPPER
137 INTEGER J, K, KC, KP
138 DOUBLE PRECISION S
139 COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 EXTERNAL lsame
144* ..
145* .. External Subroutines ..
146 EXTERNAL xerbla, zdscal, zgemv, zgeru, zlacgv, zswap
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC dble, dconjg, max
150* ..
151* .. Executable Statements ..
152*
153 info = 0
154 upper = lsame( uplo, 'U' )
155 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
156 info = -1
157 ELSE IF( n.LT.0 ) THEN
158 info = -2
159 ELSE IF( nrhs.LT.0 ) THEN
160 info = -3
161 ELSE IF( ldb.LT.max( 1, n ) ) THEN
162 info = -7
163 END IF
164 IF( info.NE.0 ) THEN
165 CALL xerbla( 'ZHPTRS', -info )
166 RETURN
167 END IF
168*
169* Quick return if possible
170*
171 IF( n.EQ.0 .OR. nrhs.EQ.0 )
172 $ RETURN
173*
174 IF( upper ) THEN
175*
176* Solve A*X = B, where A = U*D*U**H.
177*
178* First solve U*D*X = B, overwriting B with X.
179*
180* K is the main loop index, decreasing from N to 1 in steps of
181* 1 or 2, depending on the size of the diagonal blocks.
182*
183 k = n
184 kc = n*( n+1 ) / 2 + 1
185 10 CONTINUE
186*
187* If K < 1, exit from loop.
188*
189 IF( k.LT.1 )
190 $ GO TO 30
191*
192 kc = kc - k
193 IF( ipiv( k ).GT.0 ) THEN
194*
195* 1 x 1 diagonal block
196*
197* Interchange rows K and IPIV(K).
198*
199 kp = ipiv( k )
200 IF( kp.NE.k )
201 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
202*
203* Multiply by inv(U(K)), where U(K) is the transformation
204* stored in column K of A.
205*
206 CALL zgeru( k-1, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
207 $ b( 1, 1 ), ldb )
208*
209* Multiply by the inverse of the diagonal block.
210*
211 s = dble( one ) / dble( ap( kc+k-1 ) )
212 CALL zdscal( nrhs, s, b( k, 1 ), ldb )
213 k = k - 1
214 ELSE
215*
216* 2 x 2 diagonal block
217*
218* Interchange rows K-1 and -IPIV(K).
219*
220 kp = -ipiv( k )
221 IF( kp.NE.k-1 )
222 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
223*
224* Multiply by inv(U(K)), where U(K) is the transformation
225* stored in columns K-1 and K of A.
226*
227 CALL zgeru( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
228 $ b( 1, 1 ), ldb )
229 CALL zgeru( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1,
230 $ b( k-1, 1 ), ldb, b( 1, 1 ), ldb )
231*
232* Multiply by the inverse of the diagonal block.
233*
234 akm1k = ap( kc+k-2 )
235 akm1 = ap( kc-1 ) / akm1k
236 ak = ap( kc+k-1 ) / dconjg( akm1k )
237 denom = akm1*ak - one
238 DO 20 j = 1, nrhs
239 bkm1 = b( k-1, j ) / akm1k
240 bk = b( k, j ) / dconjg( akm1k )
241 b( k-1, j ) = ( ak*bkm1-bk ) / denom
242 b( k, j ) = ( akm1*bk-bkm1 ) / denom
243 20 CONTINUE
244 kc = kc - k + 1
245 k = k - 2
246 END IF
247*
248 GO TO 10
249 30 CONTINUE
250*
251* Next solve U**H *X = B, overwriting B with X.
252*
253* K is the main loop index, increasing from 1 to N in steps of
254* 1 or 2, depending on the size of the diagonal blocks.
255*
256 k = 1
257 kc = 1
258 40 CONTINUE
259*
260* If K > N, exit from loop.
261*
262 IF( k.GT.n )
263 $ GO TO 50
264*
265 IF( ipiv( k ).GT.0 ) THEN
266*
267* 1 x 1 diagonal block
268*
269* Multiply by inv(U**H(K)), where U(K) is the transformation
270* stored in column K of A.
271*
272 IF( k.GT.1 ) THEN
273 CALL zlacgv( nrhs, b( k, 1 ), ldb )
274 CALL zgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
275 $ ldb, ap( kc ), 1, one, b( k, 1 ), ldb )
276 CALL zlacgv( nrhs, b( k, 1 ), ldb )
277 END IF
278*
279* Interchange rows K and IPIV(K).
280*
281 kp = ipiv( k )
282 IF( kp.NE.k )
283 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
284 kc = kc + k
285 k = k + 1
286 ELSE
287*
288* 2 x 2 diagonal block
289*
290* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation
291* stored in columns K and K+1 of A.
292*
293 IF( k.GT.1 ) THEN
294 CALL zlacgv( nrhs, b( k, 1 ), ldb )
295 CALL zgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
296 $ ldb, ap( kc ), 1, one, b( k, 1 ), ldb )
297 CALL zlacgv( nrhs, b( k, 1 ), ldb )
298*
299 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
300 CALL zgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
301 $ ldb, ap( kc+k ), 1, one, b( k+1, 1 ), ldb )
302 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
303 END IF
304*
305* Interchange rows K and -IPIV(K).
306*
307 kp = -ipiv( k )
308 IF( kp.NE.k )
309 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
310 kc = kc + 2*k + 1
311 k = k + 2
312 END IF
313*
314 GO TO 40
315 50 CONTINUE
316*
317 ELSE
318*
319* Solve A*X = B, where A = L*D*L**H.
320*
321* First solve L*D*X = B, overwriting B with X.
322*
323* K is the main loop index, increasing from 1 to N in steps of
324* 1 or 2, depending on the size of the diagonal blocks.
325*
326 k = 1
327 kc = 1
328 60 CONTINUE
329*
330* If K > N, exit from loop.
331*
332 IF( k.GT.n )
333 $ GO TO 80
334*
335 IF( ipiv( k ).GT.0 ) THEN
336*
337* 1 x 1 diagonal block
338*
339* Interchange rows K and IPIV(K).
340*
341 kp = ipiv( k )
342 IF( kp.NE.k )
343 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
344*
345* Multiply by inv(L(K)), where L(K) is the transformation
346* stored in column K of A.
347*
348 IF( k.LT.n )
349 $ CALL zgeru( n-k, nrhs, -one, ap( kc+1 ), 1, b( k, 1 ),
350 $ ldb, b( k+1, 1 ), ldb )
351*
352* Multiply by the inverse of the diagonal block.
353*
354 s = dble( one ) / dble( ap( kc ) )
355 CALL zdscal( nrhs, s, b( k, 1 ), ldb )
356 kc = kc + n - k + 1
357 k = k + 1
358 ELSE
359*
360* 2 x 2 diagonal block
361*
362* Interchange rows K+1 and -IPIV(K).
363*
364 kp = -ipiv( k )
365 IF( kp.NE.k+1 )
366 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
367*
368* Multiply by inv(L(K)), where L(K) is the transformation
369* stored in columns K and K+1 of A.
370*
371 IF( k.LT.n-1 ) THEN
372 CALL zgeru( n-k-1, nrhs, -one, ap( kc+2 ), 1, b( k, 1 ),
373 $ ldb, b( k+2, 1 ), ldb )
374 CALL zgeru( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1,
375 $ b( k+1, 1 ), ldb, b( k+2, 1 ), ldb )
376 END IF
377*
378* Multiply by the inverse of the diagonal block.
379*
380 akm1k = ap( kc+1 )
381 akm1 = ap( kc ) / dconjg( akm1k )
382 ak = ap( kc+n-k+1 ) / akm1k
383 denom = akm1*ak - one
384 DO 70 j = 1, nrhs
385 bkm1 = b( k, j ) / dconjg( akm1k )
386 bk = b( k+1, j ) / akm1k
387 b( k, j ) = ( ak*bkm1-bk ) / denom
388 b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
389 70 CONTINUE
390 kc = kc + 2*( n-k ) + 1
391 k = k + 2
392 END IF
393*
394 GO TO 60
395 80 CONTINUE
396*
397* Next solve L**H *X = B, overwriting B with X.
398*
399* K is the main loop index, decreasing from N to 1 in steps of
400* 1 or 2, depending on the size of the diagonal blocks.
401*
402 k = n
403 kc = n*( n+1 ) / 2 + 1
404 90 CONTINUE
405*
406* If K < 1, exit from loop.
407*
408 IF( k.LT.1 )
409 $ GO TO 100
410*
411 kc = kc - ( n-k+1 )
412 IF( ipiv( k ).GT.0 ) THEN
413*
414* 1 x 1 diagonal block
415*
416* Multiply by inv(L**H(K)), where L(K) is the transformation
417* stored in column K of A.
418*
419 IF( k.LT.n ) THEN
420 CALL zlacgv( nrhs, b( k, 1 ), ldb )
421 CALL zgemv( 'Conjugate transpose', n-k, nrhs, -one,
422 $ b( k+1, 1 ), ldb, ap( kc+1 ), 1, one,
423 $ b( k, 1 ), ldb )
424 CALL zlacgv( nrhs, b( k, 1 ), ldb )
425 END IF
426*
427* Interchange rows K and IPIV(K).
428*
429 kp = ipiv( k )
430 IF( kp.NE.k )
431 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
432 k = k - 1
433 ELSE
434*
435* 2 x 2 diagonal block
436*
437* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation
438* stored in columns K-1 and K of A.
439*
440 IF( k.LT.n ) THEN
441 CALL zlacgv( nrhs, b( k, 1 ), ldb )
442 CALL zgemv( 'Conjugate transpose', n-k, nrhs, -one,
443 $ b( k+1, 1 ), ldb, ap( kc+1 ), 1, one,
444 $ b( k, 1 ), ldb )
445 CALL zlacgv( nrhs, b( k, 1 ), ldb )
446*
447 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
448 CALL zgemv( 'Conjugate transpose', n-k, nrhs, -one,
449 $ b( k+1, 1 ), ldb, ap( kc-( n-k ) ), 1, one,
450 $ b( k-1, 1 ), ldb )
451 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
452 END IF
453*
454* Interchange rows K and -IPIV(K).
455*
456 kp = -ipiv( k )
457 IF( kp.NE.k )
458 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
459 kc = kc - ( n-k+2 )
460 k = k - 2
461 END IF
462*
463 GO TO 90
464 100 CONTINUE
465 END IF
466*
467 RETURN
468*
469* End of ZHPTRS
470*

◆ zhsein()

subroutine zhsein ( character side,
character eigsrc,
character initv,
logical, dimension( * ) select,
integer n,
complex*16, dimension( ldh, * ) h,
integer ldh,
complex*16, dimension( * ) w,
complex*16, dimension( ldvl, * ) vl,
integer ldvl,
complex*16, dimension( ldvr, * ) vr,
integer ldvr,
integer mm,
integer m,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) ifaill,
integer, dimension( * ) ifailr,
integer info )

ZHSEIN

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

Purpose:
!>
!> ZHSEIN uses inverse iteration to find specified right and/or left
!> eigenvectors of a complex upper Hessenberg matrix H.
!>
!> The right eigenvector x and the left eigenvector y of the matrix H
!> corresponding to an eigenvalue w are defined by:
!>
!>              H * x = w * x,     y**h * H = w * y**h
!>
!> where y**h denotes the conjugate transpose of the vector y.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'R': compute right eigenvectors only;
!>          = 'L': compute left eigenvectors only;
!>          = 'B': compute both right and left eigenvectors.
!>
[in]EIGSRC
!>          EIGSRC is CHARACTER*1
!>          Specifies the source of eigenvalues supplied in W:
!>          = 'Q': the eigenvalues were found using ZHSEQR; thus, if
!>                 H has zero subdiagonal elements, and so is
!>                 block-triangular, then the j-th eigenvalue can be
!>                 assumed to be an eigenvalue of the block containing
!>                 the j-th row/column.  This property allows ZHSEIN to
!>                 perform inverse iteration on just one diagonal block.
!>          = 'N': no assumptions are made on the correspondence
!>                 between eigenvalues and diagonal blocks.  In this
!>                 case, ZHSEIN must always perform inverse iteration
!>                 using the whole matrix H.
!>
[in]INITV
!>          INITV is CHARACTER*1
!>          = 'N': no initial vectors are supplied;
!>          = 'U': user-supplied initial vectors are stored in the arrays
!>                 VL and/or VR.
!>
[in]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          Specifies the eigenvectors to be computed. To select the
!>          eigenvector corresponding to the eigenvalue W(j),
!>          SELECT(j) must be set to .TRUE..
!>
[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.
!>          If a NaN is detected in H, the routine will return with INFO=-6.
!>
[in]LDH
!>          LDH is INTEGER
!>          The leading dimension of the array H.  LDH >= max(1,N).
!>
[in,out]W
!>          W is COMPLEX*16 array, dimension (N)
!>          On entry, the eigenvalues of H.
!>          On exit, the real parts of W may have been altered since
!>          close eigenvalues are perturbed slightly in searching for
!>          independent eigenvectors.
!>
[in,out]VL
!>          VL is COMPLEX*16 array, dimension (LDVL,MM)
!>          On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
!>          contain starting vectors for the inverse iteration for the
!>          left eigenvectors; the starting vector for each eigenvector
!>          must be in the same column in which the eigenvector will be
!>          stored.
!>          On exit, if SIDE = 'L' or 'B', the left eigenvectors
!>          specified by SELECT will be stored consecutively in the
!>          columns of VL, in the same order as their eigenvalues.
!>          If SIDE = 'R', VL is not referenced.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          The leading dimension of the array VL.
!>          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
!>
[in,out]VR
!>          VR is COMPLEX*16 array, dimension (LDVR,MM)
!>          On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
!>          contain starting vectors for the inverse iteration for the
!>          right eigenvectors; the starting vector for each eigenvector
!>          must be in the same column in which the eigenvector will be
!>          stored.
!>          On exit, if SIDE = 'R' or 'B', the right eigenvectors
!>          specified by SELECT will be stored consecutively in the
!>          columns of VR, in the same order as their eigenvalues.
!>          If SIDE = 'L', VR is not referenced.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.
!>          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
!>
[in]MM
!>          MM is INTEGER
!>          The number of columns in the arrays VL and/or VR. MM >= M.
!>
[out]M
!>          M is INTEGER
!>          The number of columns in the arrays VL and/or VR required to
!>          store the eigenvectors (= the number of .TRUE. elements in
!>          SELECT).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]IFAILL
!>          IFAILL is INTEGER array, dimension (MM)
!>          If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
!>          eigenvector in the i-th column of VL (corresponding to the
!>          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
!>          eigenvector converged satisfactorily.
!>          If SIDE = 'R', IFAILL is not referenced.
!>
[out]IFAILR
!>          IFAILR is INTEGER array, dimension (MM)
!>          If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
!>          eigenvector in the i-th column of VR (corresponding to the
!>          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
!>          eigenvector converged satisfactorily.
!>          If SIDE = 'L', IFAILR is not referenced.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, i is the number of eigenvectors which
!>                failed to converge; see IFAILL and IFAILR for further
!>                details.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Each eigenvector is normalized so that the element of largest
!>  magnitude has magnitude 1; here the magnitude of a complex number
!>  (x,y) is taken to be |x|+|y|.
!>

Definition at line 242 of file zhsein.f.

245*
246* -- LAPACK computational routine --
247* -- LAPACK is a software package provided by Univ. of Tennessee, --
248* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
249*
250* .. Scalar Arguments ..
251 CHARACTER EIGSRC, INITV, SIDE
252 INTEGER INFO, LDH, LDVL, LDVR, M, MM, N
253* ..
254* .. Array Arguments ..
255 LOGICAL SELECT( * )
256 INTEGER IFAILL( * ), IFAILR( * )
257 DOUBLE PRECISION RWORK( * )
258 COMPLEX*16 H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
259 $ W( * ), WORK( * )
260* ..
261*
262* =====================================================================
263*
264* .. Parameters ..
265 COMPLEX*16 ZERO
266 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
267 DOUBLE PRECISION RZERO
268 parameter( rzero = 0.0d+0 )
269* ..
270* .. Local Scalars ..
271 LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, RIGHTV
272 INTEGER I, IINFO, K, KL, KLN, KR, KS, LDWORK
273 DOUBLE PRECISION EPS3, HNORM, SMLNUM, ULP, UNFL
274 COMPLEX*16 CDUM, WK
275* ..
276* .. External Functions ..
277 LOGICAL LSAME, DISNAN
278 DOUBLE PRECISION DLAMCH, ZLANHS
279 EXTERNAL lsame, dlamch, zlanhs, disnan
280* ..
281* .. External Subroutines ..
282 EXTERNAL xerbla, zlaein
283* ..
284* .. Intrinsic Functions ..
285 INTRINSIC abs, dble, dimag, max
286* ..
287* .. Statement Functions ..
288 DOUBLE PRECISION CABS1
289* ..
290* .. Statement Function definitions ..
291 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
292* ..
293* .. Executable Statements ..
294*
295* Decode and test the input parameters.
296*
297 bothv = lsame( side, 'B' )
298 rightv = lsame( side, 'R' ) .OR. bothv
299 leftv = lsame( side, 'L' ) .OR. bothv
300*
301 fromqr = lsame( eigsrc, 'Q' )
302*
303 noinit = lsame( initv, 'N' )
304*
305* Set M to the number of columns required to store the selected
306* eigenvectors.
307*
308 m = 0
309 DO 10 k = 1, n
310 IF( SELECT( k ) )
311 $ m = m + 1
312 10 CONTINUE
313*
314 info = 0
315 IF( .NOT.rightv .AND. .NOT.leftv ) THEN
316 info = -1
317 ELSE IF( .NOT.fromqr .AND. .NOT.lsame( eigsrc, 'N' ) ) THEN
318 info = -2
319 ELSE IF( .NOT.noinit .AND. .NOT.lsame( initv, 'U' ) ) THEN
320 info = -3
321 ELSE IF( n.LT.0 ) THEN
322 info = -5
323 ELSE IF( ldh.LT.max( 1, n ) ) THEN
324 info = -7
325 ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN
326 info = -10
327 ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN
328 info = -12
329 ELSE IF( mm.LT.m ) THEN
330 info = -13
331 END IF
332 IF( info.NE.0 ) THEN
333 CALL xerbla( 'ZHSEIN', -info )
334 RETURN
335 END IF
336*
337* Quick return if possible.
338*
339 IF( n.EQ.0 )
340 $ RETURN
341*
342* Set machine-dependent constants.
343*
344 unfl = dlamch( 'Safe minimum' )
345 ulp = dlamch( 'Precision' )
346 smlnum = unfl*( n / ulp )
347*
348 ldwork = n
349*
350 kl = 1
351 kln = 0
352 IF( fromqr ) THEN
353 kr = 0
354 ELSE
355 kr = n
356 END IF
357 ks = 1
358*
359 DO 100 k = 1, n
360 IF( SELECT( k ) ) THEN
361*
362* Compute eigenvector(s) corresponding to W(K).
363*
364 IF( fromqr ) THEN
365*
366* If affiliation of eigenvalues is known, check whether
367* the matrix splits.
368*
369* Determine KL and KR such that 1 <= KL <= K <= KR <= N
370* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
371* KR = N).
372*
373* Then inverse iteration can be performed with the
374* submatrix H(KL:N,KL:N) for a left eigenvector, and with
375* the submatrix H(1:KR,1:KR) for a right eigenvector.
376*
377 DO 20 i = k, kl + 1, -1
378 IF( h( i, i-1 ).EQ.zero )
379 $ GO TO 30
380 20 CONTINUE
381 30 CONTINUE
382 kl = i
383 IF( k.GT.kr ) THEN
384 DO 40 i = k, n - 1
385 IF( h( i+1, i ).EQ.zero )
386 $ GO TO 50
387 40 CONTINUE
388 50 CONTINUE
389 kr = i
390 END IF
391 END IF
392*
393 IF( kl.NE.kln ) THEN
394 kln = kl
395*
396* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
397* has not ben computed before.
398*
399 hnorm = zlanhs( 'I', kr-kl+1, h( kl, kl ), ldh, rwork )
400 IF( disnan( hnorm ) ) THEN
401 info = -6
402 RETURN
403 ELSE IF( hnorm.GT.rzero ) THEN
404 eps3 = hnorm*ulp
405 ELSE
406 eps3 = smlnum
407 END IF
408 END IF
409*
410* Perturb eigenvalue if it is close to any previous
411* selected eigenvalues affiliated to the submatrix
412* H(KL:KR,KL:KR). Close roots are modified by EPS3.
413*
414 wk = w( k )
415 60 CONTINUE
416 DO 70 i = k - 1, kl, -1
417 IF( SELECT( i ) .AND. cabs1( w( i )-wk ).LT.eps3 ) THEN
418 wk = wk + eps3
419 GO TO 60
420 END IF
421 70 CONTINUE
422 w( k ) = wk
423*
424 IF( leftv ) THEN
425*
426* Compute left eigenvector.
427*
428 CALL zlaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,
429 $ wk, vl( kl, ks ), work, ldwork, rwork, eps3,
430 $ smlnum, iinfo )
431 IF( iinfo.GT.0 ) THEN
432 info = info + 1
433 ifaill( ks ) = k
434 ELSE
435 ifaill( ks ) = 0
436 END IF
437 DO 80 i = 1, kl - 1
438 vl( i, ks ) = zero
439 80 CONTINUE
440 END IF
441 IF( rightv ) THEN
442*
443* Compute right eigenvector.
444*
445 CALL zlaein( .true., noinit, kr, h, ldh, wk, vr( 1, ks ),
446 $ work, ldwork, rwork, eps3, smlnum, iinfo )
447 IF( iinfo.GT.0 ) THEN
448 info = info + 1
449 ifailr( ks ) = k
450 ELSE
451 ifailr( ks ) = 0
452 END IF
453 DO 90 i = kr + 1, n
454 vr( i, ks ) = zero
455 90 CONTINUE
456 END IF
457 ks = ks + 1
458 END IF
459 100 CONTINUE
460*
461 RETURN
462*
463* End of ZHSEIN
464*
disnan
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:59
zlaein
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 iterat...
Definition zlaein.f:149
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

◆ zhseqr()

subroutine zhseqr ( character job,
character compz,
integer n,
integer ilo,
integer ihi,
complex*16, dimension( ldh, * ) h,
integer ldh,
complex*16, dimension( * ) w,
complex*16, dimension( ldz, * ) z,
integer ldz,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZHSEQR

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

Purpose:
!>
!>    ZHSEQR 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)*T*(QZ)**H.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>           = 'E':  compute eigenvalues only;
!>           = 'S':  compute eigenvalues and the Schur form T.
!>
[in]COMPZ
!>          COMPZ is CHARACTER*1
!>           = 'N':  no Schur vectors are computed;
!>           = 'I':  Z is initialized to the unit matrix and the matrix Z
!>                   of Schur vectors of H is returned;
!>           = 'V':  Z must contain an unitary matrix Q on entry, and
!>                   the product Q*Z is returned.
!>
[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. 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 JOB = 'S', H contains the upper
!>           triangular matrix T from the Schur decomposition (the
!>           Schur form). If INFO = 0 and JOB = 'E', the contents of
!>           H are unspecified on exit.  (The output value of H when
!>           INFO > 0 is given under the description of INFO below.)
!>
!>           Unlike earlier versions of ZHSEQR, this subroutine may
!>           explicitly 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. If JOB = 'S', 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,out]Z
!>          Z is COMPLEX*16 array, dimension (LDZ,N)
!>           If COMPZ = 'N', Z is not referenced.
!>           If COMPZ = 'I', on entry Z need not be set and on exit,
!>           if INFO = 0, Z contains the unitary matrix Z of the Schur
!>           vectors of H.  If COMPZ = 'V', on entry Z must contain an
!>           N-by-N matrix Q, which is assumed to be equal to the unit
!>           matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
!>           if INFO = 0, Z contains Q*Z.
!>           Normally Q is the unitary matrix generated by ZUNGHR
!>           after the call to ZGEHRD which formed the Hessenberg matrix
!>           H. (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 COMPZ = 'I' or
!>           COMPZ = 'V', then LDZ >= MAX(1,N).  Otherwise, LDZ >= 1.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>           On exit, if INFO = 0, 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 and delivers very good and sometimes
!>           optimal performance.  However, LWORK as large as 11*N
!>           may be required for optimal performance.  A workspace
!>           query is recommended to determine the optimal workspace
!>           size.
!>
!>           If LWORK = -1, then ZHSEQR does a workspace query.
!>           In this case, ZHSEQR 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, the i-th argument had an illegal
!>                    value
!>             > 0:  if INFO = i, ZHSEQR failed to compute all of
!>                the eigenvalues.  Elements 1:ilo-1 and i+1:n of W
!>                contain those eigenvalues which have been
!>                successfully computed.  (Failures are rare.)
!>
!>                If INFO > 0 and JOB = 'E', 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 JOB   = 'S', 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 COMPZ = 'V', then on exit
!>
!>                  (final value of Z)  =  (initial value of Z)*U
!>
!>                where U is the unitary matrix in (*) (regard-
!>                less of the value of JOB.)
!>
!>                If INFO > 0 and COMPZ = 'I', then on exit
!>                      (final value of Z)  = U
!>                where U is the unitary matrix in (*) (regard-
!>                less of the value of JOB.)
!>
!>                If INFO > 0 and COMPZ = 'N', 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
Further Details:
!>
!>             Default values supplied by
!>             ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
!>             It is suggested that these defaults be adjusted in order
!>             to attain best performance in each particular
!>             computational environment.
!>
!>            ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point.
!>                      Default: 75. (Must be at least 11.)
!>
!>            ISPEC=13: Recommended deflation window size.
!>                      This depends on ILO, IHI and NS.  NS is the
!>                      number of simultaneous shifts returned
!>                      by ILAENV(ISPEC=15).  (See ISPEC=15 below.)
!>                      The default for (IHI-ILO+1) <= 500 is NS.
!>                      The default for (IHI-ILO+1) >  500 is 3*NS/2.
!>
!>            ISPEC=14: Nibble crossover point. (See IPARMQ for
!>                      details.)  Default: 14% of deflation window
!>                      size.
!>
!>            ISPEC=15: Number of simultaneous shifts in a multishift
!>                      QR iteration.
!>
!>                      If IHI-ILO+1 is ...
!>
!>                      greater than      ...but less    ... the
!>                      or equal to ...      than        default is
!>
!>                           1               30          NS =   2(+)
!>                          30               60          NS =   4(+)
!>                          60              150          NS =  10(+)
!>                         150              590          NS =  **
!>                         590             3000          NS =  64
!>                        3000             6000          NS = 128
!>                        6000             infinity      NS = 256
!>
!>                  (+)  By default some or all matrices of this order
!>                       are passed to the implicit double shift routine
!>                       ZLAHQR and this parameter is ignored.  See
!>                       ISPEC=12 above and comments in IPARMQ for
!>                       details.
!>
!>                 (**)  The asterisks (**) indicate an ad-hoc
!>                       function of N increasing from 10 to 64.
!>
!>            ISPEC=16: Select structured matrix multiply.
!>                      If the number of simultaneous shifts (specified
!>                      by ISPEC=15) is less than 14, then the default
!>                      for ISPEC=16 is 0.  Otherwise the default for
!>                      ISPEC=16 is 2.
!>
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 297 of file zhseqr.f.

299*
300* -- LAPACK computational routine --
301* -- LAPACK is a software package provided by Univ. of Tennessee, --
302* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
303*
304* .. Scalar Arguments ..
305 INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
306 CHARACTER COMPZ, JOB
307* ..
308* .. Array Arguments ..
309 COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
310* ..
311*
312* =====================================================================
313*
314* .. Parameters ..
315*
316* ==== Matrices of order NTINY or smaller must be processed by
317* . ZLAHQR because of insufficient subdiagonal scratch space.
318* . (This is a hard limit.) ====
319 INTEGER NTINY
320 parameter( ntiny = 15 )
321*
322* ==== NL allocates some local workspace to help small matrices
323* . through a rare ZLAHQR failure. NL > NTINY = 15 is
324* . required and NL <= NMIN = ILAENV(ISPEC=12,...) is recom-
325* . mended. (The default value of NMIN is 75.) Using NL = 49
326* . allows up to six simultaneous shifts and a 16-by-16
327* . deflation window. ====
328 INTEGER NL
329 parameter( nl = 49 )
330 COMPLEX*16 ZERO, ONE
331 parameter( zero = ( 0.0d0, 0.0d0 ),
332 $ one = ( 1.0d0, 0.0d0 ) )
333 DOUBLE PRECISION RZERO
334 parameter( rzero = 0.0d0 )
335* ..
336* .. Local Arrays ..
337 COMPLEX*16 HL( NL, NL ), WORKL( NL )
338* ..
339* .. Local Scalars ..
340 INTEGER KBOT, NMIN
341 LOGICAL INITZ, LQUERY, WANTT, WANTZ
342* ..
343* .. External Functions ..
344 INTEGER ILAENV
345 LOGICAL LSAME
346 EXTERNAL ilaenv, lsame
347* ..
348* .. External Subroutines ..
349 EXTERNAL xerbla, zcopy, zlacpy, zlahqr, zlaqr0, zlaset
350* ..
351* .. Intrinsic Functions ..
352 INTRINSIC dble, dcmplx, max, min
353* ..
354* .. Executable Statements ..
355*
356* ==== Decode and check the input parameters. ====
357*
358 wantt = lsame( job, 'S' )
359 initz = lsame( compz, 'I' )
360 wantz = initz .OR. lsame( compz, 'V' )
361 work( 1 ) = dcmplx( dble( max( 1, n ) ), rzero )
362 lquery = lwork.EQ.-1
363*
364 info = 0
365 IF( .NOT.lsame( job, 'E' ) .AND. .NOT.wantt ) THEN
366 info = -1
367 ELSE IF( .NOT.lsame( compz, 'N' ) .AND. .NOT.wantz ) THEN
368 info = -2
369 ELSE IF( n.LT.0 ) THEN
370 info = -3
371 ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
372 info = -4
373 ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
374 info = -5
375 ELSE IF( ldh.LT.max( 1, n ) ) THEN
376 info = -7
377 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.max( 1, n ) ) ) THEN
378 info = -10
379 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
380 info = -12
381 END IF
382*
383 IF( info.NE.0 ) THEN
384*
385* ==== Quick return in case of invalid argument. ====
386*
387 CALL xerbla( 'ZHSEQR', -info )
388 RETURN
389*
390 ELSE IF( n.EQ.0 ) THEN
391*
392* ==== Quick return in case N = 0; nothing to do. ====
393*
394 RETURN
395*
396 ELSE IF( lquery ) THEN
397*
398* ==== Quick return in case of a workspace query ====
399*
400 CALL zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi, z,
401 $ ldz, work, lwork, info )
402* ==== Ensure reported workspace size is backward-compatible with
403* . previous LAPACK versions. ====
404 work( 1 ) = dcmplx( max( dble( work( 1 ) ), dble( max( 1,
405 $ n ) ) ), rzero )
406 RETURN
407*
408 ELSE
409*
410* ==== copy eigenvalues isolated by ZGEBAL ====
411*
412 IF( ilo.GT.1 )
413 $ CALL zcopy( ilo-1, h, ldh+1, w, 1 )
414 IF( ihi.LT.n )
415 $ CALL zcopy( n-ihi, h( ihi+1, ihi+1 ), ldh+1, w( ihi+1 ), 1 )
416*
417* ==== Initialize Z, if requested ====
418*
419 IF( initz )
420 $ CALL zlaset( 'A', n, n, zero, one, z, ldz )
421*
422* ==== Quick return if possible ====
423*
424 IF( ilo.EQ.ihi ) THEN
425 w( ilo ) = h( ilo, ilo )
426 RETURN
427 END IF
428*
429* ==== ZLAHQR/ZLAQR0 crossover point ====
430*
431 nmin = ilaenv( 12, 'ZHSEQR', job( : 1 ) // compz( : 1 ), n,
432 $ ilo, ihi, lwork )
433 nmin = max( ntiny, nmin )
434*
435* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ====
436*
437 IF( n.GT.nmin ) THEN
438 CALL zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,
439 $ z, ldz, work, lwork, info )
440 ELSE
441*
442* ==== Small matrix ====
443*
444 CALL zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,
445 $ z, ldz, info )
446*
447 IF( info.GT.0 ) THEN
448*
449* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds
450* . when ZLAHQR fails. ====
451*
452 kbot = info
453*
454 IF( n.GE.nl ) THEN
455*
456* ==== Larger matrices have enough subdiagonal scratch
457* . space to call ZLAQR0 directly. ====
458*
459 CALL zlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,
460 $ ilo, ihi, z, ldz, work, lwork, info )
461*
462 ELSE
463*
464* ==== Tiny matrices don't have enough subdiagonal
465* . scratch space to benefit from ZLAQR0. Hence,
466* . tiny matrices must be copied into a larger
467* . array before calling ZLAQR0. ====
468*
469 CALL zlacpy( 'A', n, n, h, ldh, hl, nl )
470 hl( n+1, n ) = zero
471 CALL zlaset( 'A', nl, nl-n, zero, zero, hl( 1, n+1 ),
472 $ nl )
473 CALL zlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,
474 $ ilo, ihi, z, ldz, workl, nl, info )
475 IF( wantt .OR. info.NE.0 )
476 $ CALL zlacpy( 'A', n, n, hl, nl, h, ldh )
477 END IF
478 END IF
479 END IF
480*
481* ==== Clear out the trash, if necessary. ====
482*
483 IF( ( wantt .OR. info.NE.0 ) .AND. n.GT.2 )
484 $ CALL zlaset( 'L', n-2, n-2, zero, zero, h( 3, 1 ), ldh )
485*
486* ==== Ensure reported workspace size is backward-compatible with
487* . previous LAPACK versions. ====
488*
489 work( 1 ) = dcmplx( max( dble( max( 1, n ) ),
490 $ dble( work( 1 ) ) ), rzero )
491 END IF
492*
493* ==== End of ZHSEQR ====
494*
zlaqr0
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 de...
Definition zlaqr0.f:241
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
nl
character *2 function nl()
Definition message.F:2354

◆ zla_lin_berr()

subroutine zla_lin_berr ( integer n,
integer nz,
integer nrhs,
complex*16, dimension( n, nrhs ) res,
double precision, dimension( n, nrhs ) ayb,
double precision, dimension( nrhs ) berr )

ZLA_LIN_BERR computes a component-wise relative backward error.

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

Purpose:
!>
!>    ZLA_LIN_BERR computes componentwise relative backward error from
!>    the formula
!>        max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
!>    where abs(Z) is the componentwise absolute value of the matrix
!>    or vector Z.
!>
Parameters
[in]N
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!>
[in]NZ
!>          NZ is INTEGER
!>     We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to
!>     guard against spuriously zero residuals. Default value is N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>     The number of right hand sides, i.e., the number of columns
!>     of the matrices AYB, RES, and BERR.  NRHS >= 0.
!>
[in]RES
!>          RES is COMPLEX*16 array, dimension (N,NRHS)
!>     The residual matrix, i.e., the matrix R in the relative backward
!>     error formula above.
!>
[in]AYB
!>          AYB is DOUBLE PRECISION array, dimension (N, NRHS)
!>     The denominator in the relative backward error formula above, i.e.,
!>     the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B
!>     are from iterative refinement (see zla_gerfsx_extended.f).
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>     The componentwise relative backward error from the formula above.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 100 of file zla_lin_berr.f.

101*
102* -- LAPACK computational 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 INTEGER N, NZ, NRHS
108* ..
109* .. Array Arguments ..
110 DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS )
111 COMPLEX*16 RES( N, NRHS )
112* ..
113*
114* =====================================================================
115*
116* .. Local Scalars ..
117 DOUBLE PRECISION TMP
118 INTEGER I, J
119 COMPLEX*16 CDUM
120* ..
121* .. Intrinsic Functions ..
122 INTRINSIC abs, real, dimag, max
123* ..
124* .. External Functions ..
125 EXTERNAL dlamch
126 DOUBLE PRECISION DLAMCH
127 DOUBLE PRECISION SAFE1
128* ..
129* .. Statement Functions ..
130 COMPLEX*16 CABS1
131* ..
132* .. Statement Function Definitions ..
133 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
134* ..
135* .. Executable Statements ..
136*
137* Adding SAFE1 to the numerator guards against spuriously zero
138* residuals. A similar safeguard is in the CLA_yyAMV routine used
139* to compute AYB.
140*
141 safe1 = dlamch( 'Safe minimum' )
142 safe1 = (nz+1)*safe1
143
144 DO j = 1, nrhs
145 berr(j) = 0.0d+0
146 DO i = 1, n
147 IF (ayb(i,j) .NE. 0.0d+0) THEN
148 tmp = (safe1 + cabs1(res(i,j)))/ayb(i,j)
149 berr(j) = max( berr(j), tmp )
150 END IF
151*
152* If AYB is exactly 0.0 (and if computed by CLA_yyAMV), then we know
153* the true residual also must be exactly 0.0.
154*
155 END DO
156 END DO
157*
158* End of ZLA_LIN_BERR
159*

◆ zla_wwaddw()

subroutine zla_wwaddw ( integer n,
complex*16, dimension( * ) x,
complex*16, dimension( * ) y,
complex*16, dimension( * ) w )

ZLA_WWADDW adds a vector into a doubled-single vector.

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

Purpose:
!>
!>    ZLA_WWADDW adds a vector W into a doubled-single vector (X, Y).
!>
!>    This works for all extant IBM's hex and binary floating point
!>    arithmetic, but not for decimal.
!>
Parameters
[in]N
!>          N is INTEGER
!>            The length of vectors X, Y, and W.
!>
[in,out]X
!>          X is COMPLEX*16 array, dimension (N)
!>            The first part of the doubled-single accumulation vector.
!>
[in,out]Y
!>          Y is COMPLEX*16 array, dimension (N)
!>            The second part of the doubled-single accumulation vector.
!>
[in]W
!>          W is COMPLEX*16 array, dimension (N)
!>            The vector to be added.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 80 of file zla_wwaddw.f.

81*
82* -- LAPACK computational 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 N
88* ..
89* .. Array Arguments ..
90 COMPLEX*16 X( * ), Y( * ), W( * )
91* ..
92*
93* =====================================================================
94*
95* .. Local Scalars ..
96 COMPLEX*16 S
97 INTEGER I
98* ..
99* .. Executable Statements ..
100 DO 10 i = 1, n
101 s = x(i) + w(i)
102 s = (s + s) - s
103 y(i) = ((x(i) - s) + w(i)) + y(i)
104 x(i) = s
105 10 CONTINUE
106 RETURN
107*
108* End of ZLA_WWADDW
109*

◆ zlaed0()

subroutine zlaed0 ( integer qsiz,
integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldqs, * ) qstore,
integer ldqs,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer info )

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

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

Purpose:
!>
!> Using the divide and conquer method, ZLAED0 computes all eigenvalues
!> of a symmetric tridiagonal matrix which is one diagonal block of
!> those from reducing a dense or band Hermitian matrix and
!> corresponding eigenvectors of the dense or band matrix.
!>
Parameters
[in]QSIZ
!>          QSIZ is INTEGER
!>         The dimension of the unitary matrix used to reduce
!>         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>         On entry, the diagonal elements of the tridiagonal matrix.
!>         On exit, the eigenvalues in ascending order.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>         On entry, the off-diagonal elements of the tridiagonal matrix.
!>         On exit, E has been destroyed.
!>
[in,out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>         On entry, Q must contain an QSIZ x N matrix whose columns
!>         unitarily orthonormal. It is a part of the unitary matrix
!>         that reduces the full dense Hermitian matrix to a
!>         (reducible) symmetric tridiagonal matrix.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[out]IWORK
!>          IWORK is INTEGER array,
!>         the dimension of IWORK must be at least
!>                      6 + 6*N + 5*N*lg N
!>                      ( lg( N ) = smallest integer k
!>                                  such that 2^k >= N )
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array,
!>                               dimension (1 + 3*N + 2*N*lg N + 3*N**2)
!>                        ( lg( N ) = smallest integer k
!>                                    such that 2^k >= N )
!>
[out]QSTORE
!>          QSTORE is COMPLEX*16 array, dimension (LDQS, N)
!>         Used to store parts of
!>         the eigenvector matrix when the updating matrix multiplies
!>         take place.
!>
[in]LDQS
!>          LDQS is INTEGER
!>         The leading dimension of the array QSTORE.
!>         LDQS >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  The algorithm failed to compute an eigenvalue while
!>                working on the submatrix lying in rows and columns
!>                INFO/(N+1) through mod(INFO,N+1).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 143 of file zlaed0.f.

145*
146* -- LAPACK computational routine --
147* -- LAPACK is a software package provided by Univ. of Tennessee, --
148* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
149*
150* .. Scalar Arguments ..
151 INTEGER INFO, LDQ, LDQS, N, QSIZ
152* ..
153* .. Array Arguments ..
154 INTEGER IWORK( * )
155 DOUBLE PRECISION D( * ), E( * ), RWORK( * )
156 COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * )
157* ..
158*
159* =====================================================================
160*
161* Warning: N could be as big as QSIZ!
162*
163* .. Parameters ..
164 DOUBLE PRECISION TWO
165 parameter( two = 2.d+0 )
166* ..
167* .. Local Scalars ..
168 INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
169 $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
170 $ J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1,
171 $ SPM1, SPM2, SUBMAT, SUBPBS, TLVLS
172 DOUBLE PRECISION TEMP
173* ..
174* .. External Subroutines ..
175 EXTERNAL dcopy, dsteqr, xerbla, zcopy, zlacrm, zlaed7
176* ..
177* .. External Functions ..
178 INTEGER ILAENV
179 EXTERNAL ilaenv
180* ..
181* .. Intrinsic Functions ..
182 INTRINSIC abs, dble, int, log, max
183* ..
184* .. Executable Statements ..
185*
186* Test the input parameters.
187*
188 info = 0
189*
190* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN
191* INFO = -1
192* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )
193* $ THEN
194 IF( qsiz.LT.max( 0, n ) ) THEN
195 info = -1
196 ELSE IF( n.LT.0 ) THEN
197 info = -2
198 ELSE IF( ldq.LT.max( 1, n ) ) THEN
199 info = -6
200 ELSE IF( ldqs.LT.max( 1, n ) ) THEN
201 info = -8
202 END IF
203 IF( info.NE.0 ) THEN
204 CALL xerbla( 'ZLAED0', -info )
205 RETURN
206 END IF
207*
208* Quick return if possible
209*
210 IF( n.EQ.0 )
211 $ RETURN
212*
213 smlsiz = ilaenv( 9, 'ZLAED0', ' ', 0, 0, 0, 0 )
214*
215* Determine the size and placement of the submatrices, and save in
216* the leading elements of IWORK.
217*
218 iwork( 1 ) = n
219 subpbs = 1
220 tlvls = 0
221 10 CONTINUE
222 IF( iwork( subpbs ).GT.smlsiz ) THEN
223 DO 20 j = subpbs, 1, -1
224 iwork( 2*j ) = ( iwork( j )+1 ) / 2
225 iwork( 2*j-1 ) = iwork( j ) / 2
226 20 CONTINUE
227 tlvls = tlvls + 1
228 subpbs = 2*subpbs
229 GO TO 10
230 END IF
231 DO 30 j = 2, subpbs
232 iwork( j ) = iwork( j ) + iwork( j-1 )
233 30 CONTINUE
234*
235* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
236* using rank-1 modifications (cuts).
237*
238 spm1 = subpbs - 1
239 DO 40 i = 1, spm1
240 submat = iwork( i ) + 1
241 smm1 = submat - 1
242 d( smm1 ) = d( smm1 ) - abs( e( smm1 ) )
243 d( submat ) = d( submat ) - abs( e( smm1 ) )
244 40 CONTINUE
245*
246 indxq = 4*n + 3
247*
248* Set up workspaces for eigenvalues only/accumulate new vectors
249* routine
250*
251 temp = log( dble( n ) ) / log( two )
252 lgn = int( temp )
253 IF( 2**lgn.LT.n )
254 $ lgn = lgn + 1
255 IF( 2**lgn.LT.n )
256 $ lgn = lgn + 1
257 iprmpt = indxq + n + 1
258 iperm = iprmpt + n*lgn
259 iqptr = iperm + n*lgn
260 igivpt = iqptr + n + 2
261 igivcl = igivpt + n*lgn
262*
263 igivnm = 1
264 iq = igivnm + 2*n*lgn
265 iwrem = iq + n**2 + 1
266* Initialize pointers
267 DO 50 i = 0, subpbs
268 iwork( iprmpt+i ) = 1
269 iwork( igivpt+i ) = 1
270 50 CONTINUE
271 iwork( iqptr ) = 1
272*
273* Solve each submatrix eigenproblem at the bottom of the divide and
274* conquer tree.
275*
276 curr = 0
277 DO 70 i = 0, spm1
278 IF( i.EQ.0 ) THEN
279 submat = 1
280 matsiz = iwork( 1 )
281 ELSE
282 submat = iwork( i ) + 1
283 matsiz = iwork( i+1 ) - iwork( i )
284 END IF
285 ll = iq - 1 + iwork( iqptr+curr )
286 CALL dsteqr( 'I', matsiz, d( submat ), e( submat ),
287 $ rwork( ll ), matsiz, rwork, info )
288 CALL zlacrm( qsiz, matsiz, q( 1, submat ), ldq, rwork( ll ),
289 $ matsiz, qstore( 1, submat ), ldqs,
290 $ rwork( iwrem ) )
291 iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2
292 curr = curr + 1
293 IF( info.GT.0 ) THEN
294 info = submat*( n+1 ) + submat + matsiz - 1
295 RETURN
296 END IF
297 k = 1
298 DO 60 j = submat, iwork( i+1 )
299 iwork( indxq+j ) = k
300 k = k + 1
301 60 CONTINUE
302 70 CONTINUE
303*
304* Successively merge eigensystems of adjacent submatrices
305* into eigensystem for the corresponding larger matrix.
306*
307* while ( SUBPBS > 1 )
308*
309 curlvl = 1
310 80 CONTINUE
311 IF( subpbs.GT.1 ) THEN
312 spm2 = subpbs - 2
313 DO 90 i = 0, spm2, 2
314 IF( i.EQ.0 ) THEN
315 submat = 1
316 matsiz = iwork( 2 )
317 msd2 = iwork( 1 )
318 curprb = 0
319 ELSE
320 submat = iwork( i ) + 1
321 matsiz = iwork( i+2 ) - iwork( i )
322 msd2 = matsiz / 2
323 curprb = curprb + 1
324 END IF
325*
326* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
327* into an eigensystem of size MATSIZ. ZLAED7 handles the case
328* when the eigenvectors of a full or band Hermitian matrix (which
329* was reduced to tridiagonal form) are desired.
330*
331* I am free to use Q as a valuable working space until Loop 150.
332*
333 CALL zlaed7( matsiz, msd2, qsiz, tlvls, curlvl, curprb,
334 $ d( submat ), qstore( 1, submat ), ldqs,
335 $ e( submat+msd2-1 ), iwork( indxq+submat ),
336 $ rwork( iq ), iwork( iqptr ), iwork( iprmpt ),
337 $ iwork( iperm ), iwork( igivpt ),
338 $ iwork( igivcl ), rwork( igivnm ),
339 $ q( 1, submat ), rwork( iwrem ),
340 $ iwork( subpbs+1 ), info )
341 IF( info.GT.0 ) THEN
342 info = submat*( n+1 ) + submat + matsiz - 1
343 RETURN
344 END IF
345 iwork( i / 2+1 ) = iwork( i+2 )
346 90 CONTINUE
347 subpbs = subpbs / 2
348 curlvl = curlvl + 1
349 GO TO 80
350 END IF
351*
352* end while
353*
354* Re-merge the eigenvalues/vectors which were deflated at the final
355* merge step.
356*
357 DO 100 i = 1, n
358 j = iwork( indxq+i )
359 rwork( i ) = d( j )
360 CALL zcopy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 )
361 100 CONTINUE
362 CALL dcopy( n, rwork, 1, d, 1 )
363*
364 RETURN
365*
366* End of ZLAED0
367*
dsteqr
subroutine dsteqr(compz, n, d, e, z, ldz, work, info)
DSTEQR
Definition dsteqr.f:131
zlacrm
subroutine zlacrm(m, n, a, lda, b, ldb, c, ldc, rwork)
ZLACRM multiplies a complex matrix by a square real matrix.
Definition zlacrm.f:114
zlaed7
subroutine zlaed7(n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, ldq, rho, indxq, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, rwork, iwork, info)
ZLAED7 used by ZSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a ...
Definition zlaed7.f:249
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82

◆ zlaed7()

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

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

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

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

Definition at line 245 of file zlaed7.f.

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

◆ zlaed8()

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

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

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

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

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

◆ zlals0()

subroutine zlals0 ( integer icompq,
integer nl,
integer nr,
integer sqre,
integer nrhs,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldbx, * ) bx,
integer ldbx,
integer, dimension( * ) perm,
integer givptr,
integer, dimension( ldgcol, * ) givcol,
integer ldgcol,
double precision, dimension( ldgnum, * ) givnum,
integer ldgnum,
double precision, dimension( ldgnum, * ) poles,
double precision, dimension( * ) difl,
double precision, dimension( ldgnum, * ) difr,
double precision, dimension( * ) z,
integer k,
double precision c,
double precision s,
double precision, dimension( * ) rwork,
integer info )

ZLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd.

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

Purpose:
!>
!> ZLALS0 applies back the multiplying factors of either the left or the
!> right singular vector matrix of a diagonal matrix appended by a row
!> to the right hand side matrix B in solving the least squares problem
!> using the divide-and-conquer SVD approach.
!>
!> For the left singular vector matrix, three types of orthogonal
!> matrices are involved:
!>
!> (1L) Givens rotations: the number of such rotations is GIVPTR; the
!>      pairs of columns/rows they were applied to are stored in GIVCOL;
!>      and the C- and S-values of these rotations are stored in GIVNUM.
!>
!> (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
!>      row, and for J=2:N, PERM(J)-th row of B is to be moved to the
!>      J-th row.
!>
!> (3L) The left singular vector matrix of the remaining matrix.
!>
!> For the right singular vector matrix, four types of orthogonal
!> matrices are involved:
!>
!> (1R) The right singular vector matrix of the remaining matrix.
!>
!> (2R) If SQRE = 1, one extra Givens rotation to generate the right
!>      null space.
!>
!> (3R) The inverse transformation of (2L).
!>
!> (4R) The inverse transformation of (1L).
!>
Parameters
[in]ICOMPQ
!>          ICOMPQ is INTEGER
!>         Specifies whether singular vectors are to be computed in
!>         factored form:
!>         = 0: Left singular vector matrix.
!>         = 1: Right singular vector matrix.
!>
[in]NL
!>          NL is INTEGER
!>         The row dimension of the upper block. NL >= 1.
!>
[in]NR
!>          NR is INTEGER
!>         The row dimension of the lower block. NR >= 1.
!>
[in]SQRE
!>          SQRE is INTEGER
!>         = 0: the lower block is an NR-by-NR square matrix.
!>         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
!>
!>         The bidiagonal matrix has row dimension N = NL + NR + 1,
!>         and column dimension M = N + SQRE.
!>
[in]NRHS
!>          NRHS is INTEGER
!>         The number of columns of B and BX. NRHS must be at least 1.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension ( LDB, NRHS )
!>         On input, B contains the right hand sides of the least
!>         squares problem in rows 1 through M. On output, B contains
!>         the solution X in rows 1 through N.
!>
[in]LDB
!>          LDB is INTEGER
!>         The leading dimension of B. LDB must be at least
!>         max(1,MAX( M, N ) ).
!>
[out]BX
!>          BX is COMPLEX*16 array, dimension ( LDBX, NRHS )
!>
[in]LDBX
!>          LDBX is INTEGER
!>         The leading dimension of BX.
!>
[in]PERM
!>          PERM is INTEGER array, dimension ( N )
!>         The permutations (from deflation and sorting) applied
!>         to the two blocks.
!>
[in]GIVPTR
!>          GIVPTR is INTEGER
!>         The number of Givens rotations which took place in this
!>         subproblem.
!>
[in]GIVCOL
!>          GIVCOL is INTEGER array, dimension ( LDGCOL, 2 )
!>         Each pair of numbers indicates a pair of rows/columns
!>         involved in a Givens rotation.
!>
[in]LDGCOL
!>          LDGCOL is INTEGER
!>         The leading dimension of GIVCOL, must be at least N.
!>
[in]GIVNUM
!>          GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
!>         Each number indicates the C or S value used in the
!>         corresponding Givens rotation.
!>
[in]LDGNUM
!>          LDGNUM is INTEGER
!>         The leading dimension of arrays DIFR, POLES and
!>         GIVNUM, must be at least K.
!>
[in]POLES
!>          POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
!>         On entry, POLES(1:K, 1) contains the new singular
!>         values obtained from solving the secular equation, and
!>         POLES(1:K, 2) is an array containing the poles in the secular
!>         equation.
!>
[in]DIFL
!>          DIFL is DOUBLE PRECISION array, dimension ( K ).
!>         On entry, DIFL(I) is the distance between I-th updated
!>         (undeflated) singular value and the I-th (undeflated) old
!>         singular value.
!>
[in]DIFR
!>          DIFR is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
!>         On entry, DIFR(I, 1) contains the distances between I-th
!>         updated (undeflated) singular value and the I+1-th
!>         (undeflated) old singular value. And DIFR(I, 2) is the
!>         normalizing factor for the I-th right singular vector.
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension ( K )
!>         Contain the components of the deflation-adjusted updating row
!>         vector.
!>
[in]K
!>          K is INTEGER
!>         Contains the dimension of the non-deflated matrix,
!>         This is the order of the related secular equation. 1 <= K <=N.
!>
[in]C
!>          C is DOUBLE PRECISION
!>         C contains garbage if SQRE =0 and the C-value of a Givens
!>         rotation related to the right null space if SQRE = 1.
!>
[in]S
!>          S is DOUBLE PRECISION
!>         S contains garbage if SQRE =0 and the S-value of a Givens
!>         rotation related to the right null space if SQRE = 1.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>         ( K*(1+NRHS) + 2*NRHS )
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Ming Gu and Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA

Definition at line 267 of file zlals0.f.

270*
271* -- LAPACK computational 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 GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
277 $ LDGNUM, NL, NR, NRHS, SQRE
278 DOUBLE PRECISION C, S
279* ..
280* .. Array Arguments ..
281 INTEGER GIVCOL( LDGCOL, * ), PERM( * )
282 DOUBLE PRECISION DIFL( * ), DIFR( LDGNUM, * ),
283 $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
284 $ RWORK( * ), Z( * )
285 COMPLEX*16 B( LDB, * ), BX( LDBX, * )
286* ..
287*
288* =====================================================================
289*
290* .. Parameters ..
291 DOUBLE PRECISION ONE, ZERO, NEGONE
292 parameter( one = 1.0d0, zero = 0.0d0, negone = -1.0d0 )
293* ..
294* .. Local Scalars ..
295 INTEGER I, J, JCOL, JROW, M, N, NLP1
296 DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
297* ..
298* .. External Subroutines ..
299 EXTERNAL dgemv, xerbla, zcopy, zdrot, zdscal, zlacpy,
300 $ zlascl
301* ..
302* .. External Functions ..
303 DOUBLE PRECISION DLAMC3, DNRM2
304 EXTERNAL dlamc3, dnrm2
305* ..
306* .. Intrinsic Functions ..
307 INTRINSIC dble, dcmplx, dimag, max
308* ..
309* .. Executable Statements ..
310*
311* Test the input parameters.
312*
313 info = 0
314 n = nl + nr + 1
315*
316 IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
317 info = -1
318 ELSE IF( nl.LT.1 ) THEN
319 info = -2
320 ELSE IF( nr.LT.1 ) THEN
321 info = -3
322 ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
323 info = -4
324 ELSE IF( nrhs.LT.1 ) THEN
325 info = -5
326 ELSE IF( ldb.LT.n ) THEN
327 info = -7
328 ELSE IF( ldbx.LT.n ) THEN
329 info = -9
330 ELSE IF( givptr.LT.0 ) THEN
331 info = -11
332 ELSE IF( ldgcol.LT.n ) THEN
333 info = -13
334 ELSE IF( ldgnum.LT.n ) THEN
335 info = -15
336 ELSE IF( k.LT.1 ) THEN
337 info = -20
338 END IF
339 IF( info.NE.0 ) THEN
340 CALL xerbla( 'ZLALS0', -info )
341 RETURN
342 END IF
343*
344 m = n + sqre
345 nlp1 = nl + 1
346*
347 IF( icompq.EQ.0 ) THEN
348*
349* Apply back orthogonal transformations from the left.
350*
351* Step (1L): apply back the Givens rotations performed.
352*
353 DO 10 i = 1, givptr
354 CALL zdrot( nrhs, b( givcol( i, 2 ), 1 ), ldb,
355 $ b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
356 $ givnum( i, 1 ) )
357 10 CONTINUE
358*
359* Step (2L): permute rows of B.
360*
361 CALL zcopy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx )
362 DO 20 i = 2, n
363 CALL zcopy( nrhs, b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx )
364 20 CONTINUE
365*
366* Step (3L): apply the inverse of the left singular vector
367* matrix to BX.
368*
369 IF( k.EQ.1 ) THEN
370 CALL zcopy( nrhs, bx, ldbx, b, ldb )
371 IF( z( 1 ).LT.zero ) THEN
372 CALL zdscal( nrhs, negone, b, ldb )
373 END IF
374 ELSE
375 DO 100 j = 1, k
376 diflj = difl( j )
377 dj = poles( j, 1 )
378 dsigj = -poles( j, 2 )
379 IF( j.LT.k ) THEN
380 difrj = -difr( j, 1 )
381 dsigjp = -poles( j+1, 2 )
382 END IF
383 IF( ( z( j ).EQ.zero ) .OR. ( poles( j, 2 ).EQ.zero ) )
384 $ THEN
385 rwork( j ) = zero
386 ELSE
387 rwork( j ) = -poles( j, 2 )*z( j ) / diflj /
388 $ ( poles( j, 2 )+dj )
389 END IF
390 DO 30 i = 1, j - 1
391 IF( ( z( i ).EQ.zero ) .OR.
392 $ ( poles( i, 2 ).EQ.zero ) ) THEN
393 rwork( i ) = zero
394 ELSE
395 rwork( i ) = poles( i, 2 )*z( i ) /
396 $ ( dlamc3( poles( i, 2 ), dsigj )-
397 $ diflj ) / ( poles( i, 2 )+dj )
398 END IF
399 30 CONTINUE
400 DO 40 i = j + 1, k
401 IF( ( z( i ).EQ.zero ) .OR.
402 $ ( poles( i, 2 ).EQ.zero ) ) THEN
403 rwork( i ) = zero
404 ELSE
405 rwork( i ) = poles( i, 2 )*z( i ) /
406 $ ( dlamc3( poles( i, 2 ), dsigjp )+
407 $ difrj ) / ( poles( i, 2 )+dj )
408 END IF
409 40 CONTINUE
410 rwork( 1 ) = negone
411 temp = dnrm2( k, rwork, 1 )
412*
413* Since B and BX are complex, the following call to DGEMV
414* is performed in two steps (real and imaginary parts).
415*
416* CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
417* $ B( J, 1 ), LDB )
418*
419 i = k + nrhs*2
420 DO 60 jcol = 1, nrhs
421 DO 50 jrow = 1, k
422 i = i + 1
423 rwork( i ) = dble( bx( jrow, jcol ) )
424 50 CONTINUE
425 60 CONTINUE
426 CALL dgemv( 'T', k, nrhs, one, rwork( 1+k+nrhs*2 ), k,
427 $ rwork( 1 ), 1, zero, rwork( 1+k ), 1 )
428 i = k + nrhs*2
429 DO 80 jcol = 1, nrhs
430 DO 70 jrow = 1, k
431 i = i + 1
432 rwork( i ) = dimag( bx( jrow, jcol ) )
433 70 CONTINUE
434 80 CONTINUE
435 CALL dgemv( 'T', k, nrhs, one, rwork( 1+k+nrhs*2 ), k,
436 $ rwork( 1 ), 1, zero, rwork( 1+k+nrhs ), 1 )
437 DO 90 jcol = 1, nrhs
438 b( j, jcol ) = dcmplx( rwork( jcol+k ),
439 $ rwork( jcol+k+nrhs ) )
440 90 CONTINUE
441 CALL zlascl( 'G', 0, 0, temp, one, 1, nrhs, b( j, 1 ),
442 $ ldb, info )
443 100 CONTINUE
444 END IF
445*
446* Move the deflated rows of BX to B also.
447*
448 IF( k.LT.max( m, n ) )
449 $ CALL zlacpy( 'A', n-k, nrhs, bx( k+1, 1 ), ldbx,
450 $ b( k+1, 1 ), ldb )
451 ELSE
452*
453* Apply back the right orthogonal transformations.
454*
455* Step (1R): apply back the new right singular vector matrix
456* to B.
457*
458 IF( k.EQ.1 ) THEN
459 CALL zcopy( nrhs, b, ldb, bx, ldbx )
460 ELSE
461 DO 180 j = 1, k
462 dsigj = poles( j, 2 )
463 IF( z( j ).EQ.zero ) THEN
464 rwork( j ) = zero
465 ELSE
466 rwork( j ) = -z( j ) / difl( j ) /
467 $ ( dsigj+poles( j, 1 ) ) / difr( j, 2 )
468 END IF
469 DO 110 i = 1, j - 1
470 IF( z( j ).EQ.zero ) THEN
471 rwork( i ) = zero
472 ELSE
473 rwork( i ) = z( j ) / ( dlamc3( dsigj, -poles( i+1,
474 $ 2 ) )-difr( i, 1 ) ) /
475 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
476 END IF
477 110 CONTINUE
478 DO 120 i = j + 1, k
479 IF( z( j ).EQ.zero ) THEN
480 rwork( i ) = zero
481 ELSE
482 rwork( i ) = z( j ) / ( dlamc3( dsigj, -poles( i,
483 $ 2 ) )-difl( i ) ) /
484 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
485 END IF
486 120 CONTINUE
487*
488* Since B and BX are complex, the following call to DGEMV
489* is performed in two steps (real and imaginary parts).
490*
491* CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
492* $ BX( J, 1 ), LDBX )
493*
494 i = k + nrhs*2
495 DO 140 jcol = 1, nrhs
496 DO 130 jrow = 1, k
497 i = i + 1
498 rwork( i ) = dble( b( jrow, jcol ) )
499 130 CONTINUE
500 140 CONTINUE
501 CALL dgemv( 'T', k, nrhs, one, rwork( 1+k+nrhs*2 ), k,
502 $ rwork( 1 ), 1, zero, rwork( 1+k ), 1 )
503 i = k + nrhs*2
504 DO 160 jcol = 1, nrhs
505 DO 150 jrow = 1, k
506 i = i + 1
507 rwork( i ) = dimag( b( jrow, jcol ) )
508 150 CONTINUE
509 160 CONTINUE
510 CALL dgemv( 'T', k, nrhs, one, rwork( 1+k+nrhs*2 ), k,
511 $ rwork( 1 ), 1, zero, rwork( 1+k+nrhs ), 1 )
512 DO 170 jcol = 1, nrhs
513 bx( j, jcol ) = dcmplx( rwork( jcol+k ),
514 $ rwork( jcol+k+nrhs ) )
515 170 CONTINUE
516 180 CONTINUE
517 END IF
518*
519* Step (2R): if SQRE = 1, apply back the rotation that is
520* related to the right null space of the subproblem.
521*
522 IF( sqre.EQ.1 ) THEN
523 CALL zcopy( nrhs, b( m, 1 ), ldb, bx( m, 1 ), ldbx )
524 CALL zdrot( nrhs, bx( 1, 1 ), ldbx, bx( m, 1 ), ldbx, c, s )
525 END IF
526 IF( k.LT.max( m, n ) )
527 $ CALL zlacpy( 'A', n-k, nrhs, b( k+1, 1 ), ldb, bx( k+1, 1 ),
528 $ ldbx )
529*
530* Step (3R): permute rows of B.
531*
532 CALL zcopy( nrhs, bx( 1, 1 ), ldbx, b( nlp1, 1 ), ldb )
533 IF( sqre.EQ.1 ) THEN
534 CALL zcopy( nrhs, bx( m, 1 ), ldbx, b( m, 1 ), ldb )
535 END IF
536 DO 190 i = 2, n
537 CALL zcopy( nrhs, bx( i, 1 ), ldbx, b( perm( i ), 1 ), ldb )
538 190 CONTINUE
539*
540* Step (4R): apply back the Givens rotations performed.
541*
542 DO 200 i = givptr, 1, -1
543 CALL zdrot( nrhs, b( givcol( i, 2 ), 1 ), ldb,
544 $ b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
545 $ -givnum( i, 1 ) )
546 200 CONTINUE
547 END IF
548*
549 RETURN
550*
551* End of ZLALS0
552*
dgemv
subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
DGEMV
Definition dgemv.f:156
dnrm2
real(wp) function dnrm2(n, x, incx)
DNRM2
Definition dnrm2.f90:89
dlamc3
double precision function dlamc3(a, b)
DLAMC3
Definition dlamch.f:169

◆ zlalsa()

subroutine zlalsa ( integer icompq,
integer smlsiz,
integer n,
integer nrhs,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldbx, * ) bx,
integer ldbx,
double precision, dimension( ldu, * ) u,
integer ldu,
double precision, dimension( ldu, * ) vt,
integer, dimension( * ) k,
double precision, dimension( ldu, * ) difl,
double precision, dimension( ldu, * ) difr,
double precision, dimension( ldu, * ) z,
double precision, dimension( ldu, * ) poles,
integer, dimension( * ) givptr,
integer, dimension( ldgcol, * ) givcol,
integer ldgcol,
integer, dimension( ldgcol, * ) perm,
double precision, dimension( ldu, * ) givnum,
double precision, dimension( * ) c,
double precision, dimension( * ) s,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer info )

ZLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd.

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

Purpose:
!>
!> ZLALSA is an itermediate step in solving the least squares problem
!> by computing the SVD of the coefficient matrix in compact form (The
!> singular vectors are computed as products of simple orthorgonal
!> matrices.).
!>
!> If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector
!> matrix of an upper bidiagonal matrix to the right hand side; and if
!> ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the
!> right hand side. The singular vector matrices were generated in
!> compact form by ZLALSA.
!>
Parameters
[in]ICOMPQ
!>          ICOMPQ is INTEGER
!>         Specifies whether the left or the right singular vector
!>         matrix is involved.
!>         = 0: Left singular vector matrix
!>         = 1: Right singular vector matrix
!>
[in]SMLSIZ
!>          SMLSIZ is INTEGER
!>         The maximum size of the subproblems at the bottom of the
!>         computation tree.
!>
[in]N
!>          N is INTEGER
!>         The row and column dimensions of the upper bidiagonal matrix.
!>
[in]NRHS
!>          NRHS is INTEGER
!>         The number of columns of B and BX. NRHS must be at least 1.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension ( LDB, NRHS )
!>         On input, B contains the right hand sides of the least
!>         squares problem in rows 1 through M.
!>         On output, B contains the solution X in rows 1 through N.
!>
[in]LDB
!>          LDB is INTEGER
!>         The leading dimension of B in the calling subprogram.
!>         LDB must be at least max(1,MAX( M, N ) ).
!>
[out]BX
!>          BX is COMPLEX*16 array, dimension ( LDBX, NRHS )
!>         On exit, the result of applying the left or right singular
!>         vector matrix to B.
!>
[in]LDBX
!>          LDBX is INTEGER
!>         The leading dimension of BX.
!>
[in]U
!>          U is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
!>         On entry, U contains the left singular vector matrices of all
!>         subproblems at the bottom level.
!>
[in]LDU
!>          LDU is INTEGER, LDU = > N.
!>         The leading dimension of arrays U, VT, DIFL, DIFR,
!>         POLES, GIVNUM, and Z.
!>
[in]VT
!>          VT is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
!>         On entry, VT**H contains the right singular vector matrices of
!>         all subproblems at the bottom level.
!>
[in]K
!>          K is INTEGER array, dimension ( N ).
!>
[in]DIFL
!>          DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ).
!>         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
!>
[in]DIFR
!>          DIFR is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
!>         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
!>         distances between singular values on the I-th level and
!>         singular values on the (I -1)-th level, and DIFR(*, 2 * I)
!>         record the normalizing factors of the right singular vectors
!>         matrices of subproblems on I-th level.
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension ( LDU, NLVL ).
!>         On entry, Z(1, I) contains the components of the deflation-
!>         adjusted updating row vector for subproblems on the I-th
!>         level.
!>
[in]POLES
!>          POLES is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
!>         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
!>         singular values involved in the secular equations on the I-th
!>         level.
!>
[in]GIVPTR
!>          GIVPTR is INTEGER array, dimension ( N ).
!>         On entry, GIVPTR( I ) records the number of Givens
!>         rotations performed on the I-th problem on the computation
!>         tree.
!>
[in]GIVCOL
!>          GIVCOL is INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
!>         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
!>         locations of Givens rotations performed on the I-th level on
!>         the computation tree.
!>
[in]LDGCOL
!>          LDGCOL is INTEGER, LDGCOL = > N.
!>         The leading dimension of arrays GIVCOL and PERM.
!>
[in]PERM
!>          PERM is INTEGER array, dimension ( LDGCOL, NLVL ).
!>         On entry, PERM(*, I) records permutations done on the I-th
!>         level of the computation tree.
!>
[in]GIVNUM
!>          GIVNUM is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
!>         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
!>         values of Givens rotations performed on the I-th level on the
!>         computation tree.
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension ( N ).
!>         On entry, if the I-th subproblem is not square,
!>         C( I ) contains the C-value of a Givens rotation related to
!>         the right null space of the I-th subproblem.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension ( N ).
!>         On entry, if the I-th subproblem is not square,
!>         S( I ) contains the S-value of a Givens rotation related to
!>         the right null space of the I-th subproblem.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension at least
!>         MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (3*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Ming Gu and Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA

Definition at line 263 of file zlalsa.f.

267*
268* -- LAPACK computational 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 ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
274 $ SMLSIZ
275* ..
276* .. Array Arguments ..
277 INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
278 $ K( * ), PERM( LDGCOL, * )
279 DOUBLE PRECISION C( * ), DIFL( LDU, * ), DIFR( LDU, * ),
280 $ GIVNUM( LDU, * ), POLES( LDU, * ), RWORK( * ),
281 $ S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * )
282 COMPLEX*16 B( LDB, * ), BX( LDBX, * )
283* ..
284*
285* =====================================================================
286*
287* .. Parameters ..
288 DOUBLE PRECISION ZERO, ONE
289 parameter( zero = 0.0d0, one = 1.0d0 )
290* ..
291* .. Local Scalars ..
292 INTEGER I, I1, IC, IM1, INODE, J, JCOL, JIMAG, JREAL,
293 $ JROW, LF, LL, LVL, LVL2, ND, NDB1, NDIML,
294 $ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQRE
295* ..
296* .. External Subroutines ..
297 EXTERNAL dgemm, dlasdt, xerbla, zcopy, zlals0
298* ..
299* .. Intrinsic Functions ..
300 INTRINSIC dble, dcmplx, dimag
301* ..
302* .. Executable Statements ..
303*
304* Test the input parameters.
305*
306 info = 0
307*
308 IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
309 info = -1
310 ELSE IF( smlsiz.LT.3 ) THEN
311 info = -2
312 ELSE IF( n.LT.smlsiz ) THEN
313 info = -3
314 ELSE IF( nrhs.LT.1 ) THEN
315 info = -4
316 ELSE IF( ldb.LT.n ) THEN
317 info = -6
318 ELSE IF( ldbx.LT.n ) THEN
319 info = -8
320 ELSE IF( ldu.LT.n ) THEN
321 info = -10
322 ELSE IF( ldgcol.LT.n ) THEN
323 info = -19
324 END IF
325 IF( info.NE.0 ) THEN
326 CALL xerbla( 'ZLALSA', -info )
327 RETURN
328 END IF
329*
330* Book-keeping and setting up the computation tree.
331*
332 inode = 1
333 ndiml = inode + n
334 ndimr = ndiml + n
335*
336 CALL dlasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ),
337 $ iwork( ndimr ), smlsiz )
338*
339* The following code applies back the left singular vector factors.
340* For applying back the right singular vector factors, go to 170.
341*
342 IF( icompq.EQ.1 ) THEN
343 GO TO 170
344 END IF
345*
346* The nodes on the bottom level of the tree were solved
347* by DLASDQ. The corresponding left and right singular vector
348* matrices are in explicit form. First apply back the left
349* singular vector matrices.
350*
351 ndb1 = ( nd+1 ) / 2
352 DO 130 i = ndb1, nd
353*
354* IC : center row of each node
355* NL : number of rows of left subproblem
356* NR : number of rows of right subproblem
357* NLF: starting row of the left subproblem
358* NRF: starting row of the right subproblem
359*
360 i1 = i - 1
361 ic = iwork( inode+i1 )
362 nl = iwork( ndiml+i1 )
363 nr = iwork( ndimr+i1 )
364 nlf = ic - nl
365 nrf = ic + 1
366*
367* Since B and BX are complex, the following call to DGEMM
368* is performed in two steps (real and imaginary parts).
369*
370* CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
371* $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
372*
373 j = nl*nrhs*2
374 DO 20 jcol = 1, nrhs
375 DO 10 jrow = nlf, nlf + nl - 1
376 j = j + 1
377 rwork( j ) = dble( b( jrow, jcol ) )
378 10 CONTINUE
379 20 CONTINUE
380 CALL dgemm( 'T', 'N', nl, nrhs, nl, one, u( nlf, 1 ), ldu,
381 $ rwork( 1+nl*nrhs*2 ), nl, zero, rwork( 1 ), nl )
382 j = nl*nrhs*2
383 DO 40 jcol = 1, nrhs
384 DO 30 jrow = nlf, nlf + nl - 1
385 j = j + 1
386 rwork( j ) = dimag( b( jrow, jcol ) )
387 30 CONTINUE
388 40 CONTINUE
389 CALL dgemm( 'T', 'N', nl, nrhs, nl, one, u( nlf, 1 ), ldu,
390 $ rwork( 1+nl*nrhs*2 ), nl, zero, rwork( 1+nl*nrhs ),
391 $ nl )
392 jreal = 0
393 jimag = nl*nrhs
394 DO 60 jcol = 1, nrhs
395 DO 50 jrow = nlf, nlf + nl - 1
396 jreal = jreal + 1
397 jimag = jimag + 1
398 bx( jrow, jcol ) = dcmplx( rwork( jreal ),
399 $ rwork( jimag ) )
400 50 CONTINUE
401 60 CONTINUE
402*
403* Since B and BX are complex, the following call to DGEMM
404* is performed in two steps (real and imaginary parts).
405*
406* CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
407* $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
408*
409 j = nr*nrhs*2
410 DO 80 jcol = 1, nrhs
411 DO 70 jrow = nrf, nrf + nr - 1
412 j = j + 1
413 rwork( j ) = dble( b( jrow, jcol ) )
414 70 CONTINUE
415 80 CONTINUE
416 CALL dgemm( 'T', 'N', nr, nrhs, nr, one, u( nrf, 1 ), ldu,
417 $ rwork( 1+nr*nrhs*2 ), nr, zero, rwork( 1 ), nr )
418 j = nr*nrhs*2
419 DO 100 jcol = 1, nrhs
420 DO 90 jrow = nrf, nrf + nr - 1
421 j = j + 1
422 rwork( j ) = dimag( b( jrow, jcol ) )
423 90 CONTINUE
424 100 CONTINUE
425 CALL dgemm( 'T', 'N', nr, nrhs, nr, one, u( nrf, 1 ), ldu,
426 $ rwork( 1+nr*nrhs*2 ), nr, zero, rwork( 1+nr*nrhs ),
427 $ nr )
428 jreal = 0
429 jimag = nr*nrhs
430 DO 120 jcol = 1, nrhs
431 DO 110 jrow = nrf, nrf + nr - 1
432 jreal = jreal + 1
433 jimag = jimag + 1
434 bx( jrow, jcol ) = dcmplx( rwork( jreal ),
435 $ rwork( jimag ) )
436 110 CONTINUE
437 120 CONTINUE
438*
439 130 CONTINUE
440*
441* Next copy the rows of B that correspond to unchanged rows
442* in the bidiagonal matrix to BX.
443*
444 DO 140 i = 1, nd
445 ic = iwork( inode+i-1 )
446 CALL zcopy( nrhs, b( ic, 1 ), ldb, bx( ic, 1 ), ldbx )
447 140 CONTINUE
448*
449* Finally go through the left singular vector matrices of all
450* the other subproblems bottom-up on the tree.
451*
452 j = 2**nlvl
453 sqre = 0
454*
455 DO 160 lvl = nlvl, 1, -1
456 lvl2 = 2*lvl - 1
457*
458* find the first node LF and last node LL on
459* the current level LVL
460*
461 IF( lvl.EQ.1 ) THEN
462 lf = 1
463 ll = 1
464 ELSE
465 lf = 2**( lvl-1 )
466 ll = 2*lf - 1
467 END IF
468 DO 150 i = lf, ll
469 im1 = i - 1
470 ic = iwork( inode+im1 )
471 nl = iwork( ndiml+im1 )
472 nr = iwork( ndimr+im1 )
473 nlf = ic - nl
474 nrf = ic + 1
475 j = j - 1
476 CALL zlals0( icompq, nl, nr, sqre, nrhs, bx( nlf, 1 ), ldbx,
477 $ b( nlf, 1 ), ldb, perm( nlf, lvl ),
478 $ givptr( j ), givcol( nlf, lvl2 ), ldgcol,
479 $ givnum( nlf, lvl2 ), ldu, poles( nlf, lvl2 ),
480 $ difl( nlf, lvl ), difr( nlf, lvl2 ),
481 $ z( nlf, lvl ), k( j ), c( j ), s( j ), rwork,
482 $ info )
483 150 CONTINUE
484 160 CONTINUE
485 GO TO 330
486*
487* ICOMPQ = 1: applying back the right singular vector factors.
488*
489 170 CONTINUE
490*
491* First now go through the right singular vector matrices of all
492* the tree nodes top-down.
493*
494 j = 0
495 DO 190 lvl = 1, nlvl
496 lvl2 = 2*lvl - 1
497*
498* Find the first node LF and last node LL on
499* the current level LVL.
500*
501 IF( lvl.EQ.1 ) THEN
502 lf = 1
503 ll = 1
504 ELSE
505 lf = 2**( lvl-1 )
506 ll = 2*lf - 1
507 END IF
508 DO 180 i = ll, lf, -1
509 im1 = i - 1
510 ic = iwork( inode+im1 )
511 nl = iwork( ndiml+im1 )
512 nr = iwork( ndimr+im1 )
513 nlf = ic - nl
514 nrf = ic + 1
515 IF( i.EQ.ll ) THEN
516 sqre = 0
517 ELSE
518 sqre = 1
519 END IF
520 j = j + 1
521 CALL zlals0( icompq, nl, nr, sqre, nrhs, b( nlf, 1 ), ldb,
522 $ bx( nlf, 1 ), ldbx, perm( nlf, lvl ),
523 $ givptr( j ), givcol( nlf, lvl2 ), ldgcol,
524 $ givnum( nlf, lvl2 ), ldu, poles( nlf, lvl2 ),
525 $ difl( nlf, lvl ), difr( nlf, lvl2 ),
526 $ z( nlf, lvl ), k( j ), c( j ), s( j ), rwork,
527 $ info )
528 180 CONTINUE
529 190 CONTINUE
530*
531* The nodes on the bottom level of the tree were solved
532* by DLASDQ. The corresponding right singular vector
533* matrices are in explicit form. Apply them back.
534*
535 ndb1 = ( nd+1 ) / 2
536 DO 320 i = ndb1, nd
537 i1 = i - 1
538 ic = iwork( inode+i1 )
539 nl = iwork( ndiml+i1 )
540 nr = iwork( ndimr+i1 )
541 nlp1 = nl + 1
542 IF( i.EQ.nd ) THEN
543 nrp1 = nr
544 ELSE
545 nrp1 = nr + 1
546 END IF
547 nlf = ic - nl
548 nrf = ic + 1
549*
550* Since B and BX are complex, the following call to DGEMM is
551* performed in two steps (real and imaginary parts).
552*
553* CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
554* $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
555*
556 j = nlp1*nrhs*2
557 DO 210 jcol = 1, nrhs
558 DO 200 jrow = nlf, nlf + nlp1 - 1
559 j = j + 1
560 rwork( j ) = dble( b( jrow, jcol ) )
561 200 CONTINUE
562 210 CONTINUE
563 CALL dgemm( 'T', 'N', nlp1, nrhs, nlp1, one, vt( nlf, 1 ), ldu,
564 $ rwork( 1+nlp1*nrhs*2 ), nlp1, zero, rwork( 1 ),
565 $ nlp1 )
566 j = nlp1*nrhs*2
567 DO 230 jcol = 1, nrhs
568 DO 220 jrow = nlf, nlf + nlp1 - 1
569 j = j + 1
570 rwork( j ) = dimag( b( jrow, jcol ) )
571 220 CONTINUE
572 230 CONTINUE
573 CALL dgemm( 'T', 'N', nlp1, nrhs, nlp1, one, vt( nlf, 1 ), ldu,
574 $ rwork( 1+nlp1*nrhs*2 ), nlp1, zero,
575 $ rwork( 1+nlp1*nrhs ), nlp1 )
576 jreal = 0
577 jimag = nlp1*nrhs
578 DO 250 jcol = 1, nrhs
579 DO 240 jrow = nlf, nlf + nlp1 - 1
580 jreal = jreal + 1
581 jimag = jimag + 1
582 bx( jrow, jcol ) = dcmplx( rwork( jreal ),
583 $ rwork( jimag ) )
584 240 CONTINUE
585 250 CONTINUE
586*
587* Since B and BX are complex, the following call to DGEMM is
588* performed in two steps (real and imaginary parts).
589*
590* CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
591* $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
592*
593 j = nrp1*nrhs*2
594 DO 270 jcol = 1, nrhs
595 DO 260 jrow = nrf, nrf + nrp1 - 1
596 j = j + 1
597 rwork( j ) = dble( b( jrow, jcol ) )
598 260 CONTINUE
599 270 CONTINUE
600 CALL dgemm( 'T', 'N', nrp1, nrhs, nrp1, one, vt( nrf, 1 ), ldu,
601 $ rwork( 1+nrp1*nrhs*2 ), nrp1, zero, rwork( 1 ),
602 $ nrp1 )
603 j = nrp1*nrhs*2
604 DO 290 jcol = 1, nrhs
605 DO 280 jrow = nrf, nrf + nrp1 - 1
606 j = j + 1
607 rwork( j ) = dimag( b( jrow, jcol ) )
608 280 CONTINUE
609 290 CONTINUE
610 CALL dgemm( 'T', 'N', nrp1, nrhs, nrp1, one, vt( nrf, 1 ), ldu,
611 $ rwork( 1+nrp1*nrhs*2 ), nrp1, zero,
612 $ rwork( 1+nrp1*nrhs ), nrp1 )
613 jreal = 0
614 jimag = nrp1*nrhs
615 DO 310 jcol = 1, nrhs
616 DO 300 jrow = nrf, nrf + nrp1 - 1
617 jreal = jreal + 1
618 jimag = jimag + 1
619 bx( jrow, jcol ) = dcmplx( rwork( jreal ),
620 $ rwork( jimag ) )
621 300 CONTINUE
622 310 CONTINUE
623*
624 320 CONTINUE
625*
626 330 CONTINUE
627*
628 RETURN
629*
630* End of ZLALSA
631*
dlasdt
subroutine dlasdt(n, lvl, nd, inode, ndiml, ndimr, msub)
DLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc.
Definition dlasdt.f:105
zlals0
subroutine zlals0(icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx, perm, givptr, givcol, ldgcol, givnum, ldgnum, poles, difl, difr, z, k, c, s, rwork, info)
ZLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer...
Definition zlals0.f:270
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187

◆ zlalsd()

subroutine zlalsd ( character uplo,
integer smlsiz,
integer n,
integer nrhs,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision rcond,
integer rank,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer info )

ZLALSD uses the singular value decomposition of A to solve the least squares problem.

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

Purpose:
!>
!> ZLALSD uses the singular value decomposition of A to solve the least
!> squares problem of finding X to minimize the Euclidean norm of each
!> column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
!> are N-by-NRHS. The solution X overwrites B.
!>
!> The singular values of A smaller than RCOND times the largest
!> singular value are treated as zero in solving the least squares
!> problem; in this case a minimum norm solution is returned.
!> The actual singular values are returned in D in ascending order.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>         = 'U': D and E define an upper bidiagonal matrix.
!>         = 'L': D and E define a  lower bidiagonal matrix.
!>
[in]SMLSIZ
!>          SMLSIZ is INTEGER
!>         The maximum size of the subproblems at the bottom of the
!>         computation tree.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the  bidiagonal matrix.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>         The number of columns of B. NRHS must be at least 1.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>         On entry D contains the main diagonal of the bidiagonal
!>         matrix. On exit, if INFO = 0, D contains its singular values.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>         Contains the super-diagonal entries of the bidiagonal matrix.
!>         On exit, E has been destroyed.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>         On input, B contains the right hand sides of the least
!>         squares problem. On output, B contains the solution X.
!>
[in]LDB
!>          LDB is INTEGER
!>         The leading dimension of B in the calling subprogram.
!>         LDB must be at least max(1,N).
!>
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>         The singular values of A less than or equal to RCOND times
!>         the largest singular value are treated as zero in solving
!>         the least squares problem. If RCOND is negative,
!>         machine precision is used instead.
!>         For example, if diag(S)*X=B were the least squares problem,
!>         where diag(S) is a diagonal matrix of singular values, the
!>         solution would be X(i) = B(i) / S(i) if S(i) is greater than
!>         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
!>         RCOND*max(S).
!>
[out]RANK
!>          RANK is INTEGER
!>         The number of singular values of A greater than RCOND times
!>         the largest singular value.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N * NRHS)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension at least
!>         (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
!>         MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),
!>         where
!>         NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension at least
!>         (3*N*NLVL + 11*N).
!>
[out]INFO
!>          INFO is INTEGER
!>         = 0:  successful exit.
!>         < 0:  if INFO = -i, the i-th argument had an illegal value.
!>         > 0:  The algorithm failed to compute a singular value while
!>               working on the submatrix lying in rows and columns
!>               INFO/(N+1) through MOD(INFO,N+1).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Ming Gu and Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA

Definition at line 185 of file zlalsd.f.

187*
188* -- LAPACK computational routine --
189* -- LAPACK is a software package provided by Univ. of Tennessee, --
190* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
191*
192* .. Scalar Arguments ..
193 CHARACTER UPLO
194 INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ
195 DOUBLE PRECISION RCOND
196* ..
197* .. Array Arguments ..
198 INTEGER IWORK( * )
199 DOUBLE PRECISION D( * ), E( * ), RWORK( * )
200 COMPLEX*16 B( LDB, * ), WORK( * )
201* ..
202*
203* =====================================================================
204*
205* .. Parameters ..
206 DOUBLE PRECISION ZERO, ONE, TWO
207 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
208 COMPLEX*16 CZERO
209 parameter( czero = ( 0.0d0, 0.0d0 ) )
210* ..
211* .. Local Scalars ..
212 INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
213 $ GIVPTR, I, ICMPQ1, ICMPQ2, IRWB, IRWIB, IRWRB,
214 $ IRWU, IRWVT, IRWWRK, IWK, J, JCOL, JIMAG,
215 $ JREAL, JROW, K, NLVL, NM1, NRWORK, NSIZE, NSUB,
216 $ PERM, POLES, S, SIZEI, SMLSZP, SQRE, ST, ST1,
217 $ U, VT, Z
218 DOUBLE PRECISION CS, EPS, ORGNRM, RCND, R, SN, TOL
219* ..
220* .. External Functions ..
221 INTEGER IDAMAX
222 DOUBLE PRECISION DLAMCH, DLANST
223 EXTERNAL idamax, dlamch, dlanst
224* ..
225* .. External Subroutines ..
226 EXTERNAL dgemm, dlartg, dlascl, dlasda, dlasdq, dlaset,
227 $ dlasrt, xerbla, zcopy, zdrot, zlacpy, zlalsa,
228 $ zlascl, zlaset
229* ..
230* .. Intrinsic Functions ..
231 INTRINSIC abs, dble, dcmplx, dimag, int, log, sign
232* ..
233* .. Executable Statements ..
234*
235* Test the input parameters.
236*
237 info = 0
238*
239 IF( n.LT.0 ) THEN
240 info = -3
241 ELSE IF( nrhs.LT.1 ) THEN
242 info = -4
243 ELSE IF( ( ldb.LT.1 ) .OR. ( ldb.LT.n ) ) THEN
244 info = -8
245 END IF
246 IF( info.NE.0 ) THEN
247 CALL xerbla( 'ZLALSD', -info )
248 RETURN
249 END IF
250*
251 eps = dlamch( 'Epsilon' )
252*
253* Set up the tolerance.
254*
255 IF( ( rcond.LE.zero ) .OR. ( rcond.GE.one ) ) THEN
256 rcnd = eps
257 ELSE
258 rcnd = rcond
259 END IF
260*
261 rank = 0
262*
263* Quick return if possible.
264*
265 IF( n.EQ.0 ) THEN
266 RETURN
267 ELSE IF( n.EQ.1 ) THEN
268 IF( d( 1 ).EQ.zero ) THEN
269 CALL zlaset( 'A', 1, nrhs, czero, czero, b, ldb )
270 ELSE
271 rank = 1
272 CALL zlascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info )
273 d( 1 ) = abs( d( 1 ) )
274 END IF
275 RETURN
276 END IF
277*
278* Rotate the matrix if it is lower bidiagonal.
279*
280 IF( uplo.EQ.'L' ) THEN
281 DO 10 i = 1, n - 1
282 CALL dlartg( d( i ), e( i ), cs, sn, r )
283 d( i ) = r
284 e( i ) = sn*d( i+1 )
285 d( i+1 ) = cs*d( i+1 )
286 IF( nrhs.EQ.1 ) THEN
287 CALL zdrot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn )
288 ELSE
289 rwork( i*2-1 ) = cs
290 rwork( i*2 ) = sn
291 END IF
292 10 CONTINUE
293 IF( nrhs.GT.1 ) THEN
294 DO 30 i = 1, nrhs
295 DO 20 j = 1, n - 1
296 cs = rwork( j*2-1 )
297 sn = rwork( j*2 )
298 CALL zdrot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn )
299 20 CONTINUE
300 30 CONTINUE
301 END IF
302 END IF
303*
304* Scale.
305*
306 nm1 = n - 1
307 orgnrm = dlanst( 'M', n, d, e )
308 IF( orgnrm.EQ.zero ) THEN
309 CALL zlaset( 'A', n, nrhs, czero, czero, b, ldb )
310 RETURN
311 END IF
312*
313 CALL dlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info )
314 CALL dlascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info )
315*
316* If N is smaller than the minimum divide size SMLSIZ, then solve
317* the problem with another solver.
318*
319 IF( n.LE.smlsiz ) THEN
320 irwu = 1
321 irwvt = irwu + n*n
322 irwwrk = irwvt + n*n
323 irwrb = irwwrk
324 irwib = irwrb + n*nrhs
325 irwb = irwib + n*nrhs
326 CALL dlaset( 'A', n, n, zero, one, rwork( irwu ), n )
327 CALL dlaset( 'A', n, n, zero, one, rwork( irwvt ), n )
328 CALL dlasdq( 'U', 0, n, n, n, 0, d, e, rwork( irwvt ), n,
329 $ rwork( irwu ), n, rwork( irwwrk ), 1,
330 $ rwork( irwwrk ), info )
331 IF( info.NE.0 ) THEN
332 RETURN
333 END IF
334*
335* In the real version, B is passed to DLASDQ and multiplied
336* internally by Q**H. Here B is complex and that product is
337* computed below in two steps (real and imaginary parts).
338*
339 j = irwb - 1
340 DO 50 jcol = 1, nrhs
341 DO 40 jrow = 1, n
342 j = j + 1
343 rwork( j ) = dble( b( jrow, jcol ) )
344 40 CONTINUE
345 50 CONTINUE
346 CALL dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,
347 $ rwork( irwb ), n, zero, rwork( irwrb ), n )
348 j = irwb - 1
349 DO 70 jcol = 1, nrhs
350 DO 60 jrow = 1, n
351 j = j + 1
352 rwork( j ) = dimag( b( jrow, jcol ) )
353 60 CONTINUE
354 70 CONTINUE
355 CALL dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,
356 $ rwork( irwb ), n, zero, rwork( irwib ), n )
357 jreal = irwrb - 1
358 jimag = irwib - 1
359 DO 90 jcol = 1, nrhs
360 DO 80 jrow = 1, n
361 jreal = jreal + 1
362 jimag = jimag + 1
363 b( jrow, jcol ) = dcmplx( rwork( jreal ),
364 $ rwork( jimag ) )
365 80 CONTINUE
366 90 CONTINUE
367*
368 tol = rcnd*abs( d( idamax( n, d, 1 ) ) )
369 DO 100 i = 1, n
370 IF( d( i ).LE.tol ) THEN
371 CALL zlaset( 'A', 1, nrhs, czero, czero, b( i, 1 ), ldb )
372 ELSE
373 CALL zlascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),
374 $ ldb, info )
375 rank = rank + 1
376 END IF
377 100 CONTINUE
378*
379* Since B is complex, the following call to DGEMM is performed
380* in two steps (real and imaginary parts). That is for V * B
381* (in the real version of the code V**H is stored in WORK).
382*
383* CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
384* $ WORK( NWORK ), N )
385*
386 j = irwb - 1
387 DO 120 jcol = 1, nrhs
388 DO 110 jrow = 1, n
389 j = j + 1
390 rwork( j ) = dble( b( jrow, jcol ) )
391 110 CONTINUE
392 120 CONTINUE
393 CALL dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,
394 $ rwork( irwb ), n, zero, rwork( irwrb ), n )
395 j = irwb - 1
396 DO 140 jcol = 1, nrhs
397 DO 130 jrow = 1, n
398 j = j + 1
399 rwork( j ) = dimag( b( jrow, jcol ) )
400 130 CONTINUE
401 140 CONTINUE
402 CALL dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,
403 $ rwork( irwb ), n, zero, rwork( irwib ), n )
404 jreal = irwrb - 1
405 jimag = irwib - 1
406 DO 160 jcol = 1, nrhs
407 DO 150 jrow = 1, n
408 jreal = jreal + 1
409 jimag = jimag + 1
410 b( jrow, jcol ) = dcmplx( rwork( jreal ),
411 $ rwork( jimag ) )
412 150 CONTINUE
413 160 CONTINUE
414*
415* Unscale.
416*
417 CALL dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info )
418 CALL dlasrt( 'D', n, d, info )
419 CALL zlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info )
420*
421 RETURN
422 END IF
423*
424* Book-keeping and setting up some constants.
425*
426 nlvl = int( log( dble( n ) / dble( smlsiz+1 ) ) / log( two ) ) + 1
427*
428 smlszp = smlsiz + 1
429*
430 u = 1
431 vt = 1 + smlsiz*n
432 difl = vt + smlszp*n
433 difr = difl + nlvl*n
434 z = difr + nlvl*n*2
435 c = z + nlvl*n
436 s = c + n
437 poles = s + n
438 givnum = poles + 2*nlvl*n
439 nrwork = givnum + 2*nlvl*n
440 bx = 1
441*
442 irwrb = nrwork
443 irwib = irwrb + smlsiz*nrhs
444 irwb = irwib + smlsiz*nrhs
445*
446 sizei = 1 + n
447 k = sizei + n
448 givptr = k + n
449 perm = givptr + n
450 givcol = perm + nlvl*n
451 iwk = givcol + nlvl*n*2
452*
453 st = 1
454 sqre = 0
455 icmpq1 = 1
456 icmpq2 = 0
457 nsub = 0
458*
459 DO 170 i = 1, n
460 IF( abs( d( i ) ).LT.eps ) THEN
461 d( i ) = sign( eps, d( i ) )
462 END IF
463 170 CONTINUE
464*
465 DO 240 i = 1, nm1
466 IF( ( abs( e( i ) ).LT.eps ) .OR. ( i.EQ.nm1 ) ) THEN
467 nsub = nsub + 1
468 iwork( nsub ) = st
469*
470* Subproblem found. First determine its size and then
471* apply divide and conquer on it.
472*
473 IF( i.LT.nm1 ) THEN
474*
475* A subproblem with E(I) small for I < NM1.
476*
477 nsize = i - st + 1
478 iwork( sizei+nsub-1 ) = nsize
479 ELSE IF( abs( e( i ) ).GE.eps ) THEN
480*
481* A subproblem with E(NM1) not too small but I = NM1.
482*
483 nsize = n - st + 1
484 iwork( sizei+nsub-1 ) = nsize
485 ELSE
486*
487* A subproblem with E(NM1) small. This implies an
488* 1-by-1 subproblem at D(N), which is not solved
489* explicitly.
490*
491 nsize = i - st + 1
492 iwork( sizei+nsub-1 ) = nsize
493 nsub = nsub + 1
494 iwork( nsub ) = n
495 iwork( sizei+nsub-1 ) = 1
496 CALL zcopy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n )
497 END IF
498 st1 = st - 1
499 IF( nsize.EQ.1 ) THEN
500*
501* This is a 1-by-1 subproblem and is not solved
502* explicitly.
503*
504 CALL zcopy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n )
505 ELSE IF( nsize.LE.smlsiz ) THEN
506*
507* This is a small subproblem and is solved by DLASDQ.
508*
509 CALL dlaset( 'A', nsize, nsize, zero, one,
510 $ rwork( vt+st1 ), n )
511 CALL dlaset( 'A', nsize, nsize, zero, one,
512 $ rwork( u+st1 ), n )
513 CALL dlasdq( 'U', 0, nsize, nsize, nsize, 0, d( st ),
514 $ e( st ), rwork( vt+st1 ), n, rwork( u+st1 ),
515 $ n, rwork( nrwork ), 1, rwork( nrwork ),
516 $ info )
517 IF( info.NE.0 ) THEN
518 RETURN
519 END IF
520*
521* In the real version, B is passed to DLASDQ and multiplied
522* internally by Q**H. Here B is complex and that product is
523* computed below in two steps (real and imaginary parts).
524*
525 j = irwb - 1
526 DO 190 jcol = 1, nrhs
527 DO 180 jrow = st, st + nsize - 1
528 j = j + 1
529 rwork( j ) = dble( b( jrow, jcol ) )
530 180 CONTINUE
531 190 CONTINUE
532 CALL dgemm( 'T', 'N', nsize, nrhs, nsize, one,
533 $ rwork( u+st1 ), n, rwork( irwb ), nsize,
534 $ zero, rwork( irwrb ), nsize )
535 j = irwb - 1
536 DO 210 jcol = 1, nrhs
537 DO 200 jrow = st, st + nsize - 1
538 j = j + 1
539 rwork( j ) = dimag( b( jrow, jcol ) )
540 200 CONTINUE
541 210 CONTINUE
542 CALL dgemm( 'T', 'N', nsize, nrhs, nsize, one,
543 $ rwork( u+st1 ), n, rwork( irwb ), nsize,
544 $ zero, rwork( irwib ), nsize )
545 jreal = irwrb - 1
546 jimag = irwib - 1
547 DO 230 jcol = 1, nrhs
548 DO 220 jrow = st, st + nsize - 1
549 jreal = jreal + 1
550 jimag = jimag + 1
551 b( jrow, jcol ) = dcmplx( rwork( jreal ),
552 $ rwork( jimag ) )
553 220 CONTINUE
554 230 CONTINUE
555*
556 CALL zlacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,
557 $ work( bx+st1 ), n )
558 ELSE
559*
560* A large problem. Solve it using divide and conquer.
561*
562 CALL dlasda( icmpq1, smlsiz, nsize, sqre, d( st ),
563 $ e( st ), rwork( u+st1 ), n, rwork( vt+st1 ),
564 $ iwork( k+st1 ), rwork( difl+st1 ),
565 $ rwork( difr+st1 ), rwork( z+st1 ),
566 $ rwork( poles+st1 ), iwork( givptr+st1 ),
567 $ iwork( givcol+st1 ), n, iwork( perm+st1 ),
568 $ rwork( givnum+st1 ), rwork( c+st1 ),
569 $ rwork( s+st1 ), rwork( nrwork ),
570 $ iwork( iwk ), info )
571 IF( info.NE.0 ) THEN
572 RETURN
573 END IF
574 bxst = bx + st1
575 CALL zlalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),
576 $ ldb, work( bxst ), n, rwork( u+st1 ), n,
577 $ rwork( vt+st1 ), iwork( k+st1 ),
578 $ rwork( difl+st1 ), rwork( difr+st1 ),
579 $ rwork( z+st1 ), rwork( poles+st1 ),
580 $ iwork( givptr+st1 ), iwork( givcol+st1 ), n,
581 $ iwork( perm+st1 ), rwork( givnum+st1 ),
582 $ rwork( c+st1 ), rwork( s+st1 ),
583 $ rwork( nrwork ), iwork( iwk ), info )
584 IF( info.NE.0 ) THEN
585 RETURN
586 END IF
587 END IF
588 st = i + 1
589 END IF
590 240 CONTINUE
591*
592* Apply the singular values and treat the tiny ones as zero.
593*
594 tol = rcnd*abs( d( idamax( n, d, 1 ) ) )
595*
596 DO 250 i = 1, n
597*
598* Some of the elements in D can be negative because 1-by-1
599* subproblems were not solved explicitly.
600*
601 IF( abs( d( i ) ).LE.tol ) THEN
602 CALL zlaset( 'A', 1, nrhs, czero, czero, work( bx+i-1 ), n )
603 ELSE
604 rank = rank + 1
605 CALL zlascl( 'G', 0, 0, d( i ), one, 1, nrhs,
606 $ work( bx+i-1 ), n, info )
607 END IF
608 d( i ) = abs( d( i ) )
609 250 CONTINUE
610*
611* Now apply back the right singular vectors.
612*
613 icmpq2 = 1
614 DO 320 i = 1, nsub
615 st = iwork( i )
616 st1 = st - 1
617 nsize = iwork( sizei+i-1 )
618 bxst = bx + st1
619 IF( nsize.EQ.1 ) THEN
620 CALL zcopy( nrhs, work( bxst ), n, b( st, 1 ), ldb )
621 ELSE IF( nsize.LE.smlsiz ) THEN
622*
623* Since B and BX are complex, the following call to DGEMM
624* is performed in two steps (real and imaginary parts).
625*
626* CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
627* $ RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO,
628* $ B( ST, 1 ), LDB )
629*
630 j = bxst - n - 1
631 jreal = irwb - 1
632 DO 270 jcol = 1, nrhs
633 j = j + n
634 DO 260 jrow = 1, nsize
635 jreal = jreal + 1
636 rwork( jreal ) = dble( work( j+jrow ) )
637 260 CONTINUE
638 270 CONTINUE
639 CALL dgemm( 'T', 'N', nsize, nrhs, nsize, one,
640 $ rwork( vt+st1 ), n, rwork( irwb ), nsize, zero,
641 $ rwork( irwrb ), nsize )
642 j = bxst - n - 1
643 jimag = irwb - 1
644 DO 290 jcol = 1, nrhs
645 j = j + n
646 DO 280 jrow = 1, nsize
647 jimag = jimag + 1
648 rwork( jimag ) = dimag( work( j+jrow ) )
649 280 CONTINUE
650 290 CONTINUE
651 CALL dgemm( 'T', 'N', nsize, nrhs, nsize, one,
652 $ rwork( vt+st1 ), n, rwork( irwb ), nsize, zero,
653 $ rwork( irwib ), nsize )
654 jreal = irwrb - 1
655 jimag = irwib - 1
656 DO 310 jcol = 1, nrhs
657 DO 300 jrow = st, st + nsize - 1
658 jreal = jreal + 1
659 jimag = jimag + 1
660 b( jrow, jcol ) = dcmplx( rwork( jreal ),
661 $ rwork( jimag ) )
662 300 CONTINUE
663 310 CONTINUE
664 ELSE
665 CALL zlalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,
666 $ b( st, 1 ), ldb, rwork( u+st1 ), n,
667 $ rwork( vt+st1 ), iwork( k+st1 ),
668 $ rwork( difl+st1 ), rwork( difr+st1 ),
669 $ rwork( z+st1 ), rwork( poles+st1 ),
670 $ iwork( givptr+st1 ), iwork( givcol+st1 ), n,
671 $ iwork( perm+st1 ), rwork( givnum+st1 ),
672 $ rwork( c+st1 ), rwork( s+st1 ),
673 $ rwork( nrwork ), iwork( iwk ), info )
674 IF( info.NE.0 ) THEN
675 RETURN
676 END IF
677 END IF
678 320 CONTINUE
679*
680* Unscale and sort the singular values.
681*
682 CALL dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info )
683 CALL dlasrt( 'D', n, d, info )
684 CALL zlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info )
685*
686 RETURN
687*
688* End of ZLALSD
689*
dlasdq
subroutine dlasdq(uplo, sqre, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e....
Definition dlasdq.f:211
dlanst
double precision function dlanst(norm, n, d, e)
DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlanst.f:100
dlascl
subroutine dlascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition dlascl.f:143
dlaset
subroutine dlaset(uplo, m, n, alpha, beta, a, lda)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition dlaset.f:110
dlasda
subroutine dlasda(icompq, smlsiz, n, sqre, d, e, u, ldu, vt, k, difl, difr, z, poles, givptr, givcol, ldgcol, perm, givnum, c, s, work, iwork, info)
DLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagona...
Definition dlasda.f:273
dlasrt
subroutine dlasrt(id, n, d, info)
DLASRT sorts numbers in increasing or decreasing order.
Definition dlasrt.f:88
zlalsa
subroutine zlalsa(icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u, ldu, vt, k, difl, difr, z, poles, givptr, givcol, ldgcol, perm, givnum, c, s, rwork, iwork, info)
ZLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd.
Definition zlalsa.f:267

◆ zlanhf()

double precision function zlanhf ( character norm,
character transr,
character uplo,
integer n,
complex*16, dimension( 0: * ) a,
double precision, dimension( 0: * ) work )

ZLANHF 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 matrix in RFP format.

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

Purpose:
!>
!> ZLANHF  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 in RFP format.
!>
Returns
ZLANHF 
!>
!>    ZLANHF = ( 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  matrix norm.
!>
Parameters
[in]NORM
!>          NORM is CHARACTER
!>            Specifies the value to be returned in ZLANHF as described
!>            above.
!>
[in]TRANSR
!>          TRANSR is CHARACTER
!>            Specifies whether the RFP format of A is normal or
!>            conjugate-transposed format.
!>            = 'N':  RFP format is Normal
!>            = 'C':  RFP format is Conjugate-transposed
!>
[in]UPLO
!>          UPLO is CHARACTER
!>            On entry, UPLO specifies whether the RFP matrix A came from
!>            an upper or lower triangular matrix as follows:
!>
!>            UPLO = 'U' or 'u' RFP A came from an upper triangular
!>            matrix
!>
!>            UPLO = 'L' or 'l' RFP A came from a  lower triangular
!>            matrix
!>
[in]N
!>          N is INTEGER
!>            The order of the matrix A.  N >= 0.  When N = 0, ZLANHF is
!>            set to zero.
!>
[in]A
!>          A is COMPLEX*16 array, dimension ( N*(N+1)/2 );
!>            On entry, the matrix A in RFP Format.
!>            RFP Format is described by TRANSR, UPLO and N as follows:
!>            If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;
!>            K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If
!>            TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A
!>            as defined when TRANSR = 'N'. The contents of RFP A are
!>            defined by UPLO as follows: If UPLO = 'U' the RFP A
!>            contains the ( N*(N+1)/2 ) elements of upper packed A
!>            either in normal or conjugate-transpose Format. If
!>            UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements
!>            of lower packed A either in normal or conjugate-transpose
!>            Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When
!>            TRANSR is 'N' the LDA is N+1 when N is even and is N when
!>            is odd. See the Note below for more details.
!>            Unchanged on exit.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (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.
Further Details:
!>
!>  We first consider Standard Packed Format when N is even.
!>  We give an example where N = 6.
!>
!>      AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  conjugate-transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  conjugate-transpose of the last three columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                -- -- --
!>        03 04 05                33 43 53
!>                                   -- --
!>        13 14 15                00 44 54
!>                                      --
!>        23 24 25                10 11 55
!>
!>        33 34 35                20 21 22
!>        --
!>        00 44 45                30 31 32
!>        -- --
!>        01 11 55                40 41 42
!>        -- -- --
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- -- --                -- -- -- -- -- --
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     -- -- -- -- --                -- -- -- -- --
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     -- -- -- -- -- --                -- -- -- --
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>
!>  We next  consider Standard Packed Format when N is odd.
!>  We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  conjugate-transpose of the first two   columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  conjugate-transpose of the last two   columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N odd  and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                   -- --
!>        02 03 04                00 33 43
!>                                      --
!>        12 13 14                10 11 44
!>
!>        22 23 24                20 21 22
!>        --
!>        00 33 34                30 31 32
!>        -- --
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- --                   -- -- -- -- -- --
!>     02 12 22 00 01             00 10 20 30 40 50
!>     -- -- -- --                   -- -- -- -- --
!>     03 13 23 33 11             33 11 21 31 41 51
!>     -- -- -- -- --                   -- -- -- --
!>     04 14 24 34 44             43 44 22 32 42 52
!>

Definition at line 245 of file zlanhf.f.

246*
247* -- LAPACK computational routine --
248* -- LAPACK is a software package provided by Univ. of Tennessee, --
249* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
250*
251* .. Scalar Arguments ..
252 CHARACTER NORM, TRANSR, UPLO
253 INTEGER N
254* ..
255* .. Array Arguments ..
256 DOUBLE PRECISION WORK( 0: * )
257 COMPLEX*16 A( 0: * )
258* ..
259*
260* =====================================================================
261*
262* .. Parameters ..
263 DOUBLE PRECISION ONE, ZERO
264 parameter( one = 1.0d+0, zero = 0.0d+0 )
265* ..
266* .. Local Scalars ..
267 INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA
268 DOUBLE PRECISION SCALE, S, VALUE, AA, TEMP
269* ..
270* .. External Functions ..
271 LOGICAL LSAME, DISNAN
272 EXTERNAL lsame, disnan
273* ..
274* .. External Subroutines ..
275 EXTERNAL zlassq
276* ..
277* .. Intrinsic Functions ..
278 INTRINSIC abs, dble, sqrt
279* ..
280* .. Executable Statements ..
281*
282 IF( n.EQ.0 ) THEN
283 zlanhf = zero
284 RETURN
285 ELSE IF( n.EQ.1 ) THEN
286 zlanhf = abs(dble(a(0)))
287 RETURN
288 END IF
289*
290* set noe = 1 if n is odd. if n is even set noe=0
291*
292 noe = 1
293 IF( mod( n, 2 ).EQ.0 )
294 $ noe = 0
295*
296* set ifm = 0 when form='C' or 'c' and 1 otherwise
297*
298 ifm = 1
299 IF( lsame( transr, 'C' ) )
300 $ ifm = 0
301*
302* set ilu = 0 when uplo='U or 'u' and 1 otherwise
303*
304 ilu = 1
305 IF( lsame( uplo, 'U' ) )
306 $ ilu = 0
307*
308* set lda = (n+1)/2 when ifm = 0
309* set lda = n when ifm = 1 and noe = 1
310* set lda = n+1 when ifm = 1 and noe = 0
311*
312 IF( ifm.EQ.1 ) THEN
313 IF( noe.EQ.1 ) THEN
314 lda = n
315 ELSE
316* noe=0
317 lda = n + 1
318 END IF
319 ELSE
320* ifm=0
321 lda = ( n+1 ) / 2
322 END IF
323*
324 IF( lsame( norm, 'M' ) ) THEN
325*
326* Find max(abs(A(i,j))).
327*
328 k = ( n+1 ) / 2
329 VALUE = zero
330 IF( noe.EQ.1 ) THEN
331* n is odd & n = k + k - 1
332 IF( ifm.EQ.1 ) THEN
333* A is n by k
334 IF( ilu.EQ.1 ) THEN
335* uplo ='L'
336 j = 0
337* -> L(0,0)
338 temp = abs( dble( a( j+j*lda ) ) )
339 IF( VALUE .LT. temp .OR. disnan( temp ) )
340 $ VALUE = temp
341 DO i = 1, n - 1
342 temp = abs( a( i+j*lda ) )
343 IF( VALUE .LT. temp .OR. disnan( temp ) )
344 $ VALUE = temp
345 END DO
346 DO j = 1, k - 1
347 DO i = 0, j - 2
348 temp = abs( a( i+j*lda ) )
349 IF( VALUE .LT. temp .OR. disnan( temp ) )
350 $ VALUE = temp
351 END DO
352 i = j - 1
353* L(k+j,k+j)
354 temp = abs( dble( a( i+j*lda ) ) )
355 IF( VALUE .LT. temp .OR. disnan( temp ) )
356 $ VALUE = temp
357 i = j
358* -> L(j,j)
359 temp = abs( dble( a( i+j*lda ) ) )
360 IF( VALUE .LT. temp .OR. disnan( temp ) )
361 $ VALUE = temp
362 DO i = j + 1, n - 1
363 temp = abs( a( i+j*lda ) )
364 IF( VALUE .LT. temp .OR. disnan( temp ) )
365 $ VALUE = temp
366 END DO
367 END DO
368 ELSE
369* uplo = 'U'
370 DO j = 0, k - 2
371 DO i = 0, k + j - 2
372 temp = abs( a( i+j*lda ) )
373 IF( VALUE .LT. temp .OR. disnan( temp ) )
374 $ VALUE = temp
375 END DO
376 i = k + j - 1
377* -> U(i,i)
378 temp = abs( dble( a( i+j*lda ) ) )
379 IF( VALUE .LT. temp .OR. disnan( temp ) )
380 $ VALUE = temp
381 i = i + 1
382* =k+j; i -> U(j,j)
383 temp = abs( dble( a( i+j*lda ) ) )
384 IF( VALUE .LT. temp .OR. disnan( temp ) )
385 $ VALUE = temp
386 DO i = k + j + 1, n - 1
387 temp = abs( a( i+j*lda ) )
388 IF( VALUE .LT. temp .OR. disnan( temp ) )
389 $ VALUE = temp
390 END DO
391 END DO
392 DO i = 0, n - 2
393 temp = abs( a( i+j*lda ) )
394 IF( VALUE .LT. temp .OR. disnan( temp ) )
395 $ VALUE = temp
396* j=k-1
397 END DO
398* i=n-1 -> U(n-1,n-1)
399 temp = abs( dble( a( i+j*lda ) ) )
400 IF( VALUE .LT. temp .OR. disnan( temp ) )
401 $ VALUE = temp
402 END IF
403 ELSE
404* xpose case; A is k by n
405 IF( ilu.EQ.1 ) THEN
406* uplo ='L'
407 DO j = 0, k - 2
408 DO i = 0, j - 1
409 temp = abs( a( i+j*lda ) )
410 IF( VALUE .LT. temp .OR. disnan( temp ) )
411 $ VALUE = temp
412 END DO
413 i = j
414* L(i,i)
415 temp = abs( dble( a( i+j*lda ) ) )
416 IF( VALUE .LT. temp .OR. disnan( temp ) )
417 $ VALUE = temp
418 i = j + 1
419* L(j+k,j+k)
420 temp = abs( dble( a( i+j*lda ) ) )
421 IF( VALUE .LT. temp .OR. disnan( temp ) )
422 $ VALUE = temp
423 DO i = j + 2, k - 1
424 temp = abs( a( i+j*lda ) )
425 IF( VALUE .LT. temp .OR. disnan( temp ) )
426 $ VALUE = temp
427 END DO
428 END DO
429 j = k - 1
430 DO i = 0, k - 2
431 temp = abs( a( i+j*lda ) )
432 IF( VALUE .LT. temp .OR. disnan( temp ) )
433 $ VALUE = temp
434 END DO
435 i = k - 1
436* -> L(i,i) is at A(i,j)
437 temp = abs( dble( a( i+j*lda ) ) )
438 IF( VALUE .LT. temp .OR. disnan( temp ) )
439 $ VALUE = temp
440 DO j = k, n - 1
441 DO i = 0, k - 1
442 temp = abs( a( i+j*lda ) )
443 IF( VALUE .LT. temp .OR. disnan( temp ) )
444 $ VALUE = temp
445 END DO
446 END DO
447 ELSE
448* uplo = 'U'
449 DO j = 0, k - 2
450 DO i = 0, k - 1
451 temp = abs( a( i+j*lda ) )
452 IF( VALUE .LT. temp .OR. disnan( temp ) )
453 $ VALUE = temp
454 END DO
455 END DO
456 j = k - 1
457* -> U(j,j) is at A(0,j)
458 temp = abs( dble( a( 0+j*lda ) ) )
459 IF( VALUE .LT. temp .OR. disnan( temp ) )
460 $ VALUE = temp
461 DO i = 1, k - 1
462 temp = abs( a( i+j*lda ) )
463 IF( VALUE .LT. temp .OR. disnan( temp ) )
464 $ VALUE = temp
465 END DO
466 DO j = k, n - 1
467 DO i = 0, j - k - 1
468 temp = abs( a( i+j*lda ) )
469 IF( VALUE .LT. temp .OR. disnan( temp ) )
470 $ VALUE = temp
471 END DO
472 i = j - k
473* -> U(i,i) at A(i,j)
474 temp = abs( dble( a( i+j*lda ) ) )
475 IF( VALUE .LT. temp .OR. disnan( temp ) )
476 $ VALUE = temp
477 i = j - k + 1
478* U(j,j)
479 temp = abs( dble( a( i+j*lda ) ) )
480 IF( VALUE .LT. temp .OR. disnan( temp ) )
481 $ VALUE = temp
482 DO i = j - k + 2, k - 1
483 temp = abs( a( i+j*lda ) )
484 IF( VALUE .LT. temp .OR. disnan( temp ) )
485 $ VALUE = temp
486 END DO
487 END DO
488 END IF
489 END IF
490 ELSE
491* n is even & k = n/2
492 IF( ifm.EQ.1 ) THEN
493* A is n+1 by k
494 IF( ilu.EQ.1 ) THEN
495* uplo ='L'
496 j = 0
497* -> L(k,k) & j=1 -> L(0,0)
498 temp = abs( dble( a( j+j*lda ) ) )
499 IF( VALUE .LT. temp .OR. disnan( temp ) )
500 $ VALUE = temp
501 temp = abs( dble( a( j+1+j*lda ) ) )
502 IF( VALUE .LT. temp .OR. disnan( temp ) )
503 $ VALUE = temp
504 DO i = 2, n
505 temp = abs( a( i+j*lda ) )
506 IF( VALUE .LT. temp .OR. disnan( temp ) )
507 $ VALUE = temp
508 END DO
509 DO j = 1, k - 1
510 DO i = 0, j - 1
511 temp = abs( a( i+j*lda ) )
512 IF( VALUE .LT. temp .OR. disnan( temp ) )
513 $ VALUE = temp
514 END DO
515 i = j
516* L(k+j,k+j)
517 temp = abs( dble( a( i+j*lda ) ) )
518 IF( VALUE .LT. temp .OR. disnan( temp ) )
519 $ VALUE = temp
520 i = j + 1
521* -> L(j,j)
522 temp = abs( dble( a( i+j*lda ) ) )
523 IF( VALUE .LT. temp .OR. disnan( temp ) )
524 $ VALUE = temp
525 DO i = j + 2, n
526 temp = abs( a( i+j*lda ) )
527 IF( VALUE .LT. temp .OR. disnan( temp ) )
528 $ VALUE = temp
529 END DO
530 END DO
531 ELSE
532* uplo = 'U'
533 DO j = 0, k - 2
534 DO i = 0, k + j - 1
535 temp = abs( a( i+j*lda ) )
536 IF( VALUE .LT. temp .OR. disnan( temp ) )
537 $ VALUE = temp
538 END DO
539 i = k + j
540* -> U(i,i)
541 temp = abs( dble( a( i+j*lda ) ) )
542 IF( VALUE .LT. temp .OR. disnan( temp ) )
543 $ VALUE = temp
544 i = i + 1
545* =k+j+1; i -> U(j,j)
546 temp = abs( dble( a( i+j*lda ) ) )
547 IF( VALUE .LT. temp .OR. disnan( temp ) )
548 $ VALUE = temp
549 DO i = k + j + 2, n
550 temp = abs( a( i+j*lda ) )
551 IF( VALUE .LT. temp .OR. disnan( temp ) )
552 $ VALUE = temp
553 END DO
554 END DO
555 DO i = 0, n - 2
556 temp = abs( a( i+j*lda ) )
557 IF( VALUE .LT. temp .OR. disnan( temp ) )
558 $ VALUE = temp
559* j=k-1
560 END DO
561* i=n-1 -> U(n-1,n-1)
562 temp = abs( dble( a( i+j*lda ) ) )
563 IF( VALUE .LT. temp .OR. disnan( temp ) )
564 $ VALUE = temp
565 i = n
566* -> U(k-1,k-1)
567 temp = abs( dble( a( i+j*lda ) ) )
568 IF( VALUE .LT. temp .OR. disnan( temp ) )
569 $ VALUE = temp
570 END IF
571 ELSE
572* xpose case; A is k by n+1
573 IF( ilu.EQ.1 ) THEN
574* uplo ='L'
575 j = 0
576* -> L(k,k) at A(0,0)
577 temp = abs( dble( a( j+j*lda ) ) )
578 IF( VALUE .LT. temp .OR. disnan( temp ) )
579 $ VALUE = temp
580 DO i = 1, k - 1
581 temp = abs( a( i+j*lda ) )
582 IF( VALUE .LT. temp .OR. disnan( temp ) )
583 $ VALUE = temp
584 END DO
585 DO j = 1, k - 1
586 DO i = 0, j - 2
587 temp = abs( a( i+j*lda ) )
588 IF( VALUE .LT. temp .OR. disnan( temp ) )
589 $ VALUE = temp
590 END DO
591 i = j - 1
592* L(i,i)
593 temp = abs( dble( a( i+j*lda ) ) )
594 IF( VALUE .LT. temp .OR. disnan( temp ) )
595 $ VALUE = temp
596 i = j
597* L(j+k,j+k)
598 temp = abs( dble( a( i+j*lda ) ) )
599 IF( VALUE .LT. temp .OR. disnan( temp ) )
600 $ VALUE = temp
601 DO i = j + 1, k - 1
602 temp = abs( a( i+j*lda ) )
603 IF( VALUE .LT. temp .OR. disnan( temp ) )
604 $ VALUE = temp
605 END DO
606 END DO
607 j = k
608 DO i = 0, k - 2
609 temp = abs( a( i+j*lda ) )
610 IF( VALUE .LT. temp .OR. disnan( temp ) )
611 $ VALUE = temp
612 END DO
613 i = k - 1
614* -> L(i,i) is at A(i,j)
615 temp = abs( dble( a( i+j*lda ) ) )
616 IF( VALUE .LT. temp .OR. disnan( temp ) )
617 $ VALUE = temp
618 DO j = k + 1, n
619 DO i = 0, k - 1
620 temp = abs( a( i+j*lda ) )
621 IF( VALUE .LT. temp .OR. disnan( temp ) )
622 $ VALUE = temp
623 END DO
624 END DO
625 ELSE
626* uplo = 'U'
627 DO j = 0, k - 1
628 DO i = 0, k - 1
629 temp = abs( a( i+j*lda ) )
630 IF( VALUE .LT. temp .OR. disnan( temp ) )
631 $ VALUE = temp
632 END DO
633 END DO
634 j = k
635* -> U(j,j) is at A(0,j)
636 temp = abs( dble( a( 0+j*lda ) ) )
637 IF( VALUE .LT. temp .OR. disnan( temp ) )
638 $ VALUE = temp
639 DO i = 1, k - 1
640 temp = abs( a( i+j*lda ) )
641 IF( VALUE .LT. temp .OR. disnan( temp ) )
642 $ VALUE = temp
643 END DO
644 DO j = k + 1, n - 1
645 DO i = 0, j - k - 2
646 temp = abs( a( i+j*lda ) )
647 IF( VALUE .LT. temp .OR. disnan( temp ) )
648 $ VALUE = temp
649 END DO
650 i = j - k - 1
651* -> U(i,i) at A(i,j)
652 temp = abs( dble( a( i+j*lda ) ) )
653 IF( VALUE .LT. temp .OR. disnan( temp ) )
654 $ VALUE = temp
655 i = j - k
656* U(j,j)
657 temp = abs( dble( a( i+j*lda ) ) )
658 IF( VALUE .LT. temp .OR. disnan( temp ) )
659 $ VALUE = temp
660 DO i = j - k + 1, k - 1
661 temp = abs( a( i+j*lda ) )
662 IF( VALUE .LT. temp .OR. disnan( temp ) )
663 $ VALUE = temp
664 END DO
665 END DO
666 j = n
667 DO i = 0, k - 2
668 temp = abs( a( i+j*lda ) )
669 IF( VALUE .LT. temp .OR. disnan( temp ) )
670 $ VALUE = temp
671 END DO
672 i = k - 1
673* U(k,k) at A(i,j)
674 temp = abs( dble( a( i+j*lda ) ) )
675 IF( VALUE .LT. temp .OR. disnan( temp ) )
676 $ VALUE = temp
677 END IF
678 END IF
679 END IF
680 ELSE IF( ( lsame( norm, 'I' ) ) .OR. ( lsame( norm, 'O' ) ) .OR.
681 $ ( norm.EQ.'1' ) ) THEN
682*
683* Find normI(A) ( = norm1(A), since A is Hermitian).
684*
685 IF( ifm.EQ.1 ) THEN
686* A is 'N'
687 k = n / 2
688 IF( noe.EQ.1 ) THEN
689* n is odd & A is n by (n+1)/2
690 IF( ilu.EQ.0 ) THEN
691* uplo = 'U'
692 DO i = 0, k - 1
693 work( i ) = zero
694 END DO
695 DO j = 0, k
696 s = zero
697 DO i = 0, k + j - 1
698 aa = abs( a( i+j*lda ) )
699* -> A(i,j+k)
700 s = s + aa
701 work( i ) = work( i ) + aa
702 END DO
703 aa = abs( dble( a( i+j*lda ) ) )
704* -> A(j+k,j+k)
705 work( j+k ) = s + aa
706 IF( i.EQ.k+k )
707 $ GO TO 10
708 i = i + 1
709 aa = abs( dble( a( i+j*lda ) ) )
710* -> A(j,j)
711 work( j ) = work( j ) + aa
712 s = zero
713 DO l = j + 1, k - 1
714 i = i + 1
715 aa = abs( a( i+j*lda ) )
716* -> A(l,j)
717 s = s + aa
718 work( l ) = work( l ) + aa
719 END DO
720 work( j ) = work( j ) + s
721 END DO
722 10 CONTINUE
723 VALUE = work( 0 )
724 DO i = 1, n-1
725 temp = work( i )
726 IF( VALUE .LT. temp .OR. disnan( temp ) )
727 $ VALUE = temp
728 END DO
729 ELSE
730* ilu = 1 & uplo = 'L'
731 k = k + 1
732* k=(n+1)/2 for n odd and ilu=1
733 DO i = k, n - 1
734 work( i ) = zero
735 END DO
736 DO j = k - 1, 0, -1
737 s = zero
738 DO i = 0, j - 2
739 aa = abs( a( i+j*lda ) )
740* -> A(j+k,i+k)
741 s = s + aa
742 work( i+k ) = work( i+k ) + aa
743 END DO
744 IF( j.GT.0 ) THEN
745 aa = abs( dble( a( i+j*lda ) ) )
746* -> A(j+k,j+k)
747 s = s + aa
748 work( i+k ) = work( i+k ) + s
749* i=j
750 i = i + 1
751 END IF
752 aa = abs( dble( a( i+j*lda ) ) )
753* -> A(j,j)
754 work( j ) = aa
755 s = zero
756 DO l = j + 1, n - 1
757 i = i + 1
758 aa = abs( a( i+j*lda ) )
759* -> A(l,j)
760 s = s + aa
761 work( l ) = work( l ) + aa
762 END DO
763 work( j ) = work( j ) + s
764 END DO
765 VALUE = work( 0 )
766 DO i = 1, n-1
767 temp = work( i )
768 IF( VALUE .LT. temp .OR. disnan( temp ) )
769 $ VALUE = temp
770 END DO
771 END IF
772 ELSE
773* n is even & A is n+1 by k = n/2
774 IF( ilu.EQ.0 ) THEN
775* uplo = 'U'
776 DO i = 0, k - 1
777 work( i ) = zero
778 END DO
779 DO j = 0, k - 1
780 s = zero
781 DO i = 0, k + j - 1
782 aa = abs( a( i+j*lda ) )
783* -> A(i,j+k)
784 s = s + aa
785 work( i ) = work( i ) + aa
786 END DO
787 aa = abs( dble( a( i+j*lda ) ) )
788* -> A(j+k,j+k)
789 work( j+k ) = s + aa
790 i = i + 1
791 aa = abs( dble( a( i+j*lda ) ) )
792* -> A(j,j)
793 work( j ) = work( j ) + aa
794 s = zero
795 DO l = j + 1, k - 1
796 i = i + 1
797 aa = abs( a( i+j*lda ) )
798* -> A(l,j)
799 s = s + aa
800 work( l ) = work( l ) + aa
801 END DO
802 work( j ) = work( j ) + s
803 END DO
804 VALUE = work( 0 )
805 DO i = 1, n-1
806 temp = work( i )
807 IF( VALUE .LT. temp .OR. disnan( temp ) )
808 $ VALUE = temp
809 END DO
810 ELSE
811* ilu = 1 & uplo = 'L'
812 DO i = k, n - 1
813 work( i ) = zero
814 END DO
815 DO j = k - 1, 0, -1
816 s = zero
817 DO i = 0, j - 1
818 aa = abs( a( i+j*lda ) )
819* -> A(j+k,i+k)
820 s = s + aa
821 work( i+k ) = work( i+k ) + aa
822 END DO
823 aa = abs( dble( a( i+j*lda ) ) )
824* -> A(j+k,j+k)
825 s = s + aa
826 work( i+k ) = work( i+k ) + s
827* i=j
828 i = i + 1
829 aa = abs( dble( a( i+j*lda ) ) )
830* -> A(j,j)
831 work( j ) = aa
832 s = zero
833 DO l = j + 1, n - 1
834 i = i + 1
835 aa = abs( a( i+j*lda ) )
836* -> A(l,j)
837 s = s + aa
838 work( l ) = work( l ) + aa
839 END DO
840 work( j ) = work( j ) + s
841 END DO
842 VALUE = work( 0 )
843 DO i = 1, n-1
844 temp = work( i )
845 IF( VALUE .LT. temp .OR. disnan( temp ) )
846 $ VALUE = temp
847 END DO
848 END IF
849 END IF
850 ELSE
851* ifm=0
852 k = n / 2
853 IF( noe.EQ.1 ) THEN
854* n is odd & A is (n+1)/2 by n
855 IF( ilu.EQ.0 ) THEN
856* uplo = 'U'
857 n1 = k
858* n/2
859 k = k + 1
860* k is the row size and lda
861 DO i = n1, n - 1
862 work( i ) = zero
863 END DO
864 DO j = 0, n1 - 1
865 s = zero
866 DO i = 0, k - 1
867 aa = abs( a( i+j*lda ) )
868* A(j,n1+i)
869 work( i+n1 ) = work( i+n1 ) + aa
870 s = s + aa
871 END DO
872 work( j ) = s
873 END DO
874* j=n1=k-1 is special
875 s = abs( dble( a( 0+j*lda ) ) )
876* A(k-1,k-1)
877 DO i = 1, k - 1
878 aa = abs( a( i+j*lda ) )
879* A(k-1,i+n1)
880 work( i+n1 ) = work( i+n1 ) + aa
881 s = s + aa
882 END DO
883 work( j ) = work( j ) + s
884 DO j = k, n - 1
885 s = zero
886 DO i = 0, j - k - 1
887 aa = abs( a( i+j*lda ) )
888* A(i,j-k)
889 work( i ) = work( i ) + aa
890 s = s + aa
891 END DO
892* i=j-k
893 aa = abs( dble( a( i+j*lda ) ) )
894* A(j-k,j-k)
895 s = s + aa
896 work( j-k ) = work( j-k ) + s
897 i = i + 1
898 s = abs( dble( a( i+j*lda ) ) )
899* A(j,j)
900 DO l = j + 1, n - 1
901 i = i + 1
902 aa = abs( a( i+j*lda ) )
903* A(j,l)
904 work( l ) = work( l ) + aa
905 s = s + aa
906 END DO
907 work( j ) = work( j ) + s
908 END DO
909 VALUE = work( 0 )
910 DO i = 1, n-1
911 temp = work( i )
912 IF( VALUE .LT. temp .OR. disnan( temp ) )
913 $ VALUE = temp
914 END DO
915 ELSE
916* ilu=1 & uplo = 'L'
917 k = k + 1
918* k=(n+1)/2 for n odd and ilu=1
919 DO i = k, n - 1
920 work( i ) = zero
921 END DO
922 DO j = 0, k - 2
923* process
924 s = zero
925 DO i = 0, j - 1
926 aa = abs( a( i+j*lda ) )
927* A(j,i)
928 work( i ) = work( i ) + aa
929 s = s + aa
930 END DO
931 aa = abs( dble( a( i+j*lda ) ) )
932* i=j so process of A(j,j)
933 s = s + aa
934 work( j ) = s
935* is initialised here
936 i = i + 1
937* i=j process A(j+k,j+k)
938 aa = abs( dble( a( i+j*lda ) ) )
939 s = aa
940 DO l = k + j + 1, n - 1
941 i = i + 1
942 aa = abs( a( i+j*lda ) )
943* A(l,k+j)
944 s = s + aa
945 work( l ) = work( l ) + aa
946 END DO
947 work( k+j ) = work( k+j ) + s
948 END DO
949* j=k-1 is special :process col A(k-1,0:k-1)
950 s = zero
951 DO i = 0, k - 2
952 aa = abs( a( i+j*lda ) )
953* A(k,i)
954 work( i ) = work( i ) + aa
955 s = s + aa
956 END DO
957* i=k-1
958 aa = abs( dble( a( i+j*lda ) ) )
959* A(k-1,k-1)
960 s = s + aa
961 work( i ) = s
962* done with col j=k+1
963 DO j = k, n - 1
964* process col j of A = A(j,0:k-1)
965 s = zero
966 DO i = 0, k - 1
967 aa = abs( a( i+j*lda ) )
968* A(j,i)
969 work( i ) = work( i ) + aa
970 s = s + aa
971 END DO
972 work( j ) = work( j ) + s
973 END DO
974 VALUE = work( 0 )
975 DO i = 1, n-1
976 temp = work( i )
977 IF( VALUE .LT. temp .OR. disnan( temp ) )
978 $ VALUE = temp
979 END DO
980 END IF
981 ELSE
982* n is even & A is k=n/2 by n+1
983 IF( ilu.EQ.0 ) THEN
984* uplo = 'U'
985 DO i = k, n - 1
986 work( i ) = zero
987 END DO
988 DO j = 0, k - 1
989 s = zero
990 DO i = 0, k - 1
991 aa = abs( a( i+j*lda ) )
992* A(j,i+k)
993 work( i+k ) = work( i+k ) + aa
994 s = s + aa
995 END DO
996 work( j ) = s
997 END DO
998* j=k
999 aa = abs( dble( a( 0+j*lda ) ) )
1000* A(k,k)
1001 s = aa
1002 DO i = 1, k - 1
1003 aa = abs( a( i+j*lda ) )
1004* A(k,k+i)
1005 work( i+k ) = work( i+k ) + aa
1006 s = s + aa
1007 END DO
1008 work( j ) = work( j ) + s
1009 DO j = k + 1, n - 1
1010 s = zero
1011 DO i = 0, j - 2 - k
1012 aa = abs( a( i+j*lda ) )
1013* A(i,j-k-1)
1014 work( i ) = work( i ) + aa
1015 s = s + aa
1016 END DO
1017* i=j-1-k
1018 aa = abs( dble( a( i+j*lda ) ) )
1019* A(j-k-1,j-k-1)
1020 s = s + aa
1021 work( j-k-1 ) = work( j-k-1 ) + s
1022 i = i + 1
1023 aa = abs( dble( a( i+j*lda ) ) )
1024* A(j,j)
1025 s = aa
1026 DO l = j + 1, n - 1
1027 i = i + 1
1028 aa = abs( a( i+j*lda ) )
1029* A(j,l)
1030 work( l ) = work( l ) + aa
1031 s = s + aa
1032 END DO
1033 work( j ) = work( j ) + s
1034 END DO
1035* j=n
1036 s = zero
1037 DO i = 0, k - 2
1038 aa = abs( a( i+j*lda ) )
1039* A(i,k-1)
1040 work( i ) = work( i ) + aa
1041 s = s + aa
1042 END DO
1043* i=k-1
1044 aa = abs( dble( a( i+j*lda ) ) )
1045* A(k-1,k-1)
1046 s = s + aa
1047 work( i ) = work( i ) + s
1048 VALUE = work( 0 )
1049 DO i = 1, n-1
1050 temp = work( i )
1051 IF( VALUE .LT. temp .OR. disnan( temp ) )
1052 $ VALUE = temp
1053 END DO
1054 ELSE
1055* ilu=1 & uplo = 'L'
1056 DO i = k, n - 1
1057 work( i ) = zero
1058 END DO
1059* j=0 is special :process col A(k:n-1,k)
1060 s = abs( dble( a( 0 ) ) )
1061* A(k,k)
1062 DO i = 1, k - 1
1063 aa = abs( a( i ) )
1064* A(k+i,k)
1065 work( i+k ) = work( i+k ) + aa
1066 s = s + aa
1067 END DO
1068 work( k ) = work( k ) + s
1069 DO j = 1, k - 1
1070* process
1071 s = zero
1072 DO i = 0, j - 2
1073 aa = abs( a( i+j*lda ) )
1074* A(j-1,i)
1075 work( i ) = work( i ) + aa
1076 s = s + aa
1077 END DO
1078 aa = abs( dble( a( i+j*lda ) ) )
1079* i=j-1 so process of A(j-1,j-1)
1080 s = s + aa
1081 work( j-1 ) = s
1082* is initialised here
1083 i = i + 1
1084* i=j process A(j+k,j+k)
1085 aa = abs( dble( a( i+j*lda ) ) )
1086 s = aa
1087 DO l = k + j + 1, n - 1
1088 i = i + 1
1089 aa = abs( a( i+j*lda ) )
1090* A(l,k+j)
1091 s = s + aa
1092 work( l ) = work( l ) + aa
1093 END DO
1094 work( k+j ) = work( k+j ) + s
1095 END DO
1096* j=k is special :process col A(k,0:k-1)
1097 s = zero
1098 DO i = 0, k - 2
1099 aa = abs( a( i+j*lda ) )
1100* A(k,i)
1101 work( i ) = work( i ) + aa
1102 s = s + aa
1103 END DO
1104*
1105* i=k-1
1106 aa = abs( dble( a( i+j*lda ) ) )
1107* A(k-1,k-1)
1108 s = s + aa
1109 work( i ) = s
1110* done with col j=k+1
1111 DO j = k + 1, n
1112*
1113* process col j-1 of A = A(j-1,0:k-1)
1114 s = zero
1115 DO i = 0, k - 1
1116 aa = abs( a( i+j*lda ) )
1117* A(j-1,i)
1118 work( i ) = work( i ) + aa
1119 s = s + aa
1120 END DO
1121 work( j-1 ) = work( j-1 ) + s
1122 END DO
1123 VALUE = work( 0 )
1124 DO i = 1, n-1
1125 temp = work( i )
1126 IF( VALUE .LT. temp .OR. disnan( temp ) )
1127 $ VALUE = temp
1128 END DO
1129 END IF
1130 END IF
1131 END IF
1132 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
1133*
1134* Find normF(A).
1135*
1136 k = ( n+1 ) / 2
1137 scale = zero
1138 s = one
1139 IF( noe.EQ.1 ) THEN
1140* n is odd
1141 IF( ifm.EQ.1 ) THEN
1142* A is normal & A is n by k
1143 IF( ilu.EQ.0 ) THEN
1144* A is upper
1145 DO j = 0, k - 3
1146 CALL zlassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s )
1147* L at A(k,0)
1148 END DO
1149 DO j = 0, k - 1
1150 CALL zlassq( k+j-1, a( 0+j*lda ), 1, scale, s )
1151* trap U at A(0,0)
1152 END DO
1153 s = s + s
1154* double s for the off diagonal elements
1155 l = k - 1
1156* -> U(k,k) at A(k-1,0)
1157 DO i = 0, k - 2
1158 aa = dble( a( l ) )
1159* U(k+i,k+i)
1160 IF( aa.NE.zero ) THEN
1161 IF( scale.LT.aa ) THEN
1162 s = one + s*( scale / aa )**2
1163 scale = aa
1164 ELSE
1165 s = s + ( aa / scale )**2
1166 END IF
1167 END IF
1168 aa = dble( a( l+1 ) )
1169* U(i,i)
1170 IF( aa.NE.zero ) THEN
1171 IF( scale.LT.aa ) THEN
1172 s = one + s*( scale / aa )**2
1173 scale = aa
1174 ELSE
1175 s = s + ( aa / scale )**2
1176 END IF
1177 END IF
1178 l = l + lda + 1
1179 END DO
1180 aa = dble( a( l ) )
1181* U(n-1,n-1)
1182 IF( aa.NE.zero ) THEN
1183 IF( scale.LT.aa ) THEN
1184 s = one + s*( scale / aa )**2
1185 scale = aa
1186 ELSE
1187 s = s + ( aa / scale )**2
1188 END IF
1189 END IF
1190 ELSE
1191* ilu=1 & A is lower
1192 DO j = 0, k - 1
1193 CALL zlassq( n-j-1, a( j+1+j*lda ), 1, scale, s )
1194* trap L at A(0,0)
1195 END DO
1196 DO j = 1, k - 2
1197 CALL zlassq( j, a( 0+( 1+j )*lda ), 1, scale, s )
1198* U at A(0,1)
1199 END DO
1200 s = s + s
1201* double s for the off diagonal elements
1202 aa = dble( a( 0 ) )
1203* L(0,0) at A(0,0)
1204 IF( aa.NE.zero ) THEN
1205 IF( scale.LT.aa ) THEN
1206 s = one + s*( scale / aa )**2
1207 scale = aa
1208 ELSE
1209 s = s + ( aa / scale )**2
1210 END IF
1211 END IF
1212 l = lda
1213* -> L(k,k) at A(0,1)
1214 DO i = 1, k - 1
1215 aa = dble( a( l ) )
1216* L(k-1+i,k-1+i)
1217 IF( aa.NE.zero ) THEN
1218 IF( scale.LT.aa ) THEN
1219 s = one + s*( scale / aa )**2
1220 scale = aa
1221 ELSE
1222 s = s + ( aa / scale )**2
1223 END IF
1224 END IF
1225 aa = dble( a( l+1 ) )
1226* L(i,i)
1227 IF( aa.NE.zero ) THEN
1228 IF( scale.LT.aa ) THEN
1229 s = one + s*( scale / aa )**2
1230 scale = aa
1231 ELSE
1232 s = s + ( aa / scale )**2
1233 END IF
1234 END IF
1235 l = l + lda + 1
1236 END DO
1237 END IF
1238 ELSE
1239* A is xpose & A is k by n
1240 IF( ilu.EQ.0 ) THEN
1241* A**H is upper
1242 DO j = 1, k - 2
1243 CALL zlassq( j, a( 0+( k+j )*lda ), 1, scale, s )
1244* U at A(0,k)
1245 END DO
1246 DO j = 0, k - 2
1247 CALL zlassq( k, a( 0+j*lda ), 1, scale, s )
1248* k by k-1 rect. at A(0,0)
1249 END DO
1250 DO j = 0, k - 2
1251 CALL zlassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,
1252 $ scale, s )
1253* L at A(0,k-1)
1254 END DO
1255 s = s + s
1256* double s for the off diagonal elements
1257 l = 0 + k*lda - lda
1258* -> U(k-1,k-1) at A(0,k-1)
1259 aa = dble( a( l ) )
1260* U(k-1,k-1)
1261 IF( aa.NE.zero ) THEN
1262 IF( scale.LT.aa ) THEN
1263 s = one + s*( scale / aa )**2
1264 scale = aa
1265 ELSE
1266 s = s + ( aa / scale )**2
1267 END IF
1268 END IF
1269 l = l + lda
1270* -> U(0,0) at A(0,k)
1271 DO j = k, n - 1
1272 aa = dble( a( l ) )
1273* -> U(j-k,j-k)
1274 IF( aa.NE.zero ) THEN
1275 IF( scale.LT.aa ) THEN
1276 s = one + s*( scale / aa )**2
1277 scale = aa
1278 ELSE
1279 s = s + ( aa / scale )**2
1280 END IF
1281 END IF
1282 aa = dble( a( l+1 ) )
1283* -> U(j,j)
1284 IF( aa.NE.zero ) THEN
1285 IF( scale.LT.aa ) THEN
1286 s = one + s*( scale / aa )**2
1287 scale = aa
1288 ELSE
1289 s = s + ( aa / scale )**2
1290 END IF
1291 END IF
1292 l = l + lda + 1
1293 END DO
1294 ELSE
1295* A**H is lower
1296 DO j = 1, k - 1
1297 CALL zlassq( j, a( 0+j*lda ), 1, scale, s )
1298* U at A(0,0)
1299 END DO
1300 DO j = k, n - 1
1301 CALL zlassq( k, a( 0+j*lda ), 1, scale, s )
1302* k by k-1 rect. at A(0,k)
1303 END DO
1304 DO j = 0, k - 3
1305 CALL zlassq( k-j-2, a( j+2+j*lda ), 1, scale, s )
1306* L at A(1,0)
1307 END DO
1308 s = s + s
1309* double s for the off diagonal elements
1310 l = 0
1311* -> L(0,0) at A(0,0)
1312 DO i = 0, k - 2
1313 aa = dble( a( l ) )
1314* L(i,i)
1315 IF( aa.NE.zero ) THEN
1316 IF( scale.LT.aa ) THEN
1317 s = one + s*( scale / aa )**2
1318 scale = aa
1319 ELSE
1320 s = s + ( aa / scale )**2
1321 END IF
1322 END IF
1323 aa = dble( a( l+1 ) )
1324* L(k+i,k+i)
1325 IF( aa.NE.zero ) THEN
1326 IF( scale.LT.aa ) THEN
1327 s = one + s*( scale / aa )**2
1328 scale = aa
1329 ELSE
1330 s = s + ( aa / scale )**2
1331 END IF
1332 END IF
1333 l = l + lda + 1
1334 END DO
1335* L-> k-1 + (k-1)*lda or L(k-1,k-1) at A(k-1,k-1)
1336 aa = dble( a( l ) )
1337* L(k-1,k-1) at A(k-1,k-1)
1338 IF( aa.NE.zero ) THEN
1339 IF( scale.LT.aa ) THEN
1340 s = one + s*( scale / aa )**2
1341 scale = aa
1342 ELSE
1343 s = s + ( aa / scale )**2
1344 END IF
1345 END IF
1346 END IF
1347 END IF
1348 ELSE
1349* n is even
1350 IF( ifm.EQ.1 ) THEN
1351* A is normal
1352 IF( ilu.EQ.0 ) THEN
1353* A is upper
1354 DO j = 0, k - 2
1355 CALL zlassq( k-j-1, a( k+j+2+j*lda ), 1, scale, s )
1356* L at A(k+1,0)
1357 END DO
1358 DO j = 0, k - 1
1359 CALL zlassq( k+j, a( 0+j*lda ), 1, scale, s )
1360* trap U at A(0,0)
1361 END DO
1362 s = s + s
1363* double s for the off diagonal elements
1364 l = k
1365* -> U(k,k) at A(k,0)
1366 DO i = 0, k - 1
1367 aa = dble( a( l ) )
1368* U(k+i,k+i)
1369 IF( aa.NE.zero ) THEN
1370 IF( scale.LT.aa ) THEN
1371 s = one + s*( scale / aa )**2
1372 scale = aa
1373 ELSE
1374 s = s + ( aa / scale )**2
1375 END IF
1376 END IF
1377 aa = dble( a( l+1 ) )
1378* U(i,i)
1379 IF( aa.NE.zero ) THEN
1380 IF( scale.LT.aa ) THEN
1381 s = one + s*( scale / aa )**2
1382 scale = aa
1383 ELSE
1384 s = s + ( aa / scale )**2
1385 END IF
1386 END IF
1387 l = l + lda + 1
1388 END DO
1389 ELSE
1390* ilu=1 & A is lower
1391 DO j = 0, k - 1
1392 CALL zlassq( n-j-1, a( j+2+j*lda ), 1, scale, s )
1393* trap L at A(1,0)
1394 END DO
1395 DO j = 1, k - 1
1396 CALL zlassq( j, a( 0+j*lda ), 1, scale, s )
1397* U at A(0,0)
1398 END DO
1399 s = s + s
1400* double s for the off diagonal elements
1401 l = 0
1402* -> L(k,k) at A(0,0)
1403 DO i = 0, k - 1
1404 aa = dble( a( l ) )
1405* L(k-1+i,k-1+i)
1406 IF( aa.NE.zero ) THEN
1407 IF( scale.LT.aa ) THEN
1408 s = one + s*( scale / aa )**2
1409 scale = aa
1410 ELSE
1411 s = s + ( aa / scale )**2
1412 END IF
1413 END IF
1414 aa = dble( a( l+1 ) )
1415* L(i,i)
1416 IF( aa.NE.zero ) THEN
1417 IF( scale.LT.aa ) THEN
1418 s = one + s*( scale / aa )**2
1419 scale = aa
1420 ELSE
1421 s = s + ( aa / scale )**2
1422 END IF
1423 END IF
1424 l = l + lda + 1
1425 END DO
1426 END IF
1427 ELSE
1428* A is xpose
1429 IF( ilu.EQ.0 ) THEN
1430* A**H is upper
1431 DO j = 1, k - 1
1432 CALL zlassq( j, a( 0+( k+1+j )*lda ), 1, scale, s )
1433* U at A(0,k+1)
1434 END DO
1435 DO j = 0, k - 1
1436 CALL zlassq( k, a( 0+j*lda ), 1, scale, s )
1437* k by k rect. at A(0,0)
1438 END DO
1439 DO j = 0, k - 2
1440 CALL zlassq( k-j-1, a( j+1+( j+k )*lda ), 1, scale,
1441 $ s )
1442* L at A(0,k)
1443 END DO
1444 s = s + s
1445* double s for the off diagonal elements
1446 l = 0 + k*lda
1447* -> U(k,k) at A(0,k)
1448 aa = dble( a( l ) )
1449* U(k,k)
1450 IF( aa.NE.zero ) THEN
1451 IF( scale.LT.aa ) THEN
1452 s = one + s*( scale / aa )**2
1453 scale = aa
1454 ELSE
1455 s = s + ( aa / scale )**2
1456 END IF
1457 END IF
1458 l = l + lda
1459* -> U(0,0) at A(0,k+1)
1460 DO j = k + 1, n - 1
1461 aa = dble( a( l ) )
1462* -> U(j-k-1,j-k-1)
1463 IF( aa.NE.zero ) THEN
1464 IF( scale.LT.aa ) THEN
1465 s = one + s*( scale / aa )**2
1466 scale = aa
1467 ELSE
1468 s = s + ( aa / scale )**2
1469 END IF
1470 END IF
1471 aa = dble( a( l+1 ) )
1472* -> U(j,j)
1473 IF( aa.NE.zero ) THEN
1474 IF( scale.LT.aa ) THEN
1475 s = one + s*( scale / aa )**2
1476 scale = aa
1477 ELSE
1478 s = s + ( aa / scale )**2
1479 END IF
1480 END IF
1481 l = l + lda + 1
1482 END DO
1483* L=k-1+n*lda
1484* -> U(k-1,k-1) at A(k-1,n)
1485 aa = dble( a( l ) )
1486* U(k,k)
1487 IF( aa.NE.zero ) THEN
1488 IF( scale.LT.aa ) THEN
1489 s = one + s*( scale / aa )**2
1490 scale = aa
1491 ELSE
1492 s = s + ( aa / scale )**2
1493 END IF
1494 END IF
1495 ELSE
1496* A**H is lower
1497 DO j = 1, k - 1
1498 CALL zlassq( j, a( 0+( j+1 )*lda ), 1, scale, s )
1499* U at A(0,1)
1500 END DO
1501 DO j = k + 1, n
1502 CALL zlassq( k, a( 0+j*lda ), 1, scale, s )
1503* k by k rect. at A(0,k+1)
1504 END DO
1505 DO j = 0, k - 2
1506 CALL zlassq( k-j-1, a( j+1+j*lda ), 1, scale, s )
1507* L at A(0,0)
1508 END DO
1509 s = s + s
1510* double s for the off diagonal elements
1511 l = 0
1512* -> L(k,k) at A(0,0)
1513 aa = dble( a( l ) )
1514* L(k,k) at A(0,0)
1515 IF( aa.NE.zero ) THEN
1516 IF( scale.LT.aa ) THEN
1517 s = one + s*( scale / aa )**2
1518 scale = aa
1519 ELSE
1520 s = s + ( aa / scale )**2
1521 END IF
1522 END IF
1523 l = lda
1524* -> L(0,0) at A(0,1)
1525 DO i = 0, k - 2
1526 aa = dble( a( l ) )
1527* L(i,i)
1528 IF( aa.NE.zero ) THEN
1529 IF( scale.LT.aa ) THEN
1530 s = one + s*( scale / aa )**2
1531 scale = aa
1532 ELSE
1533 s = s + ( aa / scale )**2
1534 END IF
1535 END IF
1536 aa = dble( a( l+1 ) )
1537* L(k+i+1,k+i+1)
1538 IF( aa.NE.zero ) THEN
1539 IF( scale.LT.aa ) THEN
1540 s = one + s*( scale / aa )**2
1541 scale = aa
1542 ELSE
1543 s = s + ( aa / scale )**2
1544 END IF
1545 END IF
1546 l = l + lda + 1
1547 END DO
1548* L-> k - 1 + k*lda or L(k-1,k-1) at A(k-1,k)
1549 aa = dble( a( l ) )
1550* L(k-1,k-1) at A(k-1,k)
1551 IF( aa.NE.zero ) THEN
1552 IF( scale.LT.aa ) THEN
1553 s = one + s*( scale / aa )**2
1554 scale = aa
1555 ELSE
1556 s = s + ( aa / scale )**2
1557 END IF
1558 END IF
1559 END IF
1560 END IF
1561 END IF
1562 VALUE = scale*sqrt( s )
1563 END IF
1564*
1565 zlanhf = VALUE
1566 RETURN
1567*
1568* End of ZLANHF
1569*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
zlanhf
double precision function zlanhf(norm, transr, uplo, n, a, work)
ZLANHF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanhf.f:246

◆ zlarscl2()

subroutine zlarscl2 ( integer m,
integer n,
double precision, dimension( * ) d,
complex*16, dimension( ldx, * ) x,
integer ldx )

ZLARSCL2 performs reciprocal diagonal scaling on a vector.

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

Purpose:
!>
!> ZLARSCL2 performs a reciprocal diagonal scaling on an vector:
!>   x <-- inv(D) * x
!> where the DOUBLE PRECISION diagonal matrix D is stored as a vector.
!>
!> Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS
!> standard.
!>
Parameters
[in]M
!>          M is INTEGER
!>     The number of rows of D and X. M >= 0.
!>
[in]N
!>          N is INTEGER
!>     The number of columns of X. N >= 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, length M
!>     Diagonal matrix D, stored as a vector of length M.
!>
[in,out]X
!>          X is COMPLEX*16 array, dimension (LDX,N)
!>     On entry, the vector X to be scaled by D.
!>     On exit, the scaled vector.
!>
[in]LDX
!>          LDX is INTEGER
!>     The leading dimension of the vector X. LDX >= M.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 90 of file zlarscl2.f.

91*
92* -- LAPACK computational routine --
93* -- LAPACK is a software package provided by Univ. of Tennessee, --
94* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
95*
96* .. Scalar Arguments ..
97 INTEGER M, N, LDX
98* ..
99* .. Array Arguments ..
100 COMPLEX*16 X( LDX, * )
101 DOUBLE PRECISION D( * )
102* ..
103*
104* =====================================================================
105*
106* .. Local Scalars ..
107 INTEGER I, J
108* ..
109* .. Executable Statements ..
110*
111 DO j = 1, n
112 DO i = 1, m
113 x( i, j ) = x( i, j ) / d( i )
114 END DO
115 END DO
116
117 RETURN

◆ zlarz()

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

ZLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix.

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

Purpose:
!>
!> ZLARZ applies a complex elementary reflector H to a complex
!> M-by-N matrix C, from either the left or the right. H is represented
!> in the form
!>
!>       H = I - tau * v * v**H
!>
!> where tau is a complex scalar and v is a complex vector.
!>
!> If tau = 0, then H is taken to be the unit matrix.
!>
!> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead
!> tau.
!>
!> H is a product of k elementary reflectors as returned by ZTZRZF.
!>
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]L
!>          L is INTEGER
!>          The number of entries of the vector V containing
!>          the meaningful part of the Householder vectors.
!>          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
!>
[in]V
!>          V is COMPLEX*16 array, dimension (1+(L-1)*abs(INCV))
!>          The vector v in the representation of H as returned by
!>          ZTZRZF. 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.
Contributors:
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
Further Details:
!>

Definition at line 146 of file zlarz.f.

147*
148* -- LAPACK computational routine --
149* -- LAPACK is a software package provided by Univ. of Tennessee, --
150* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
151*
152* .. Scalar Arguments ..
153 CHARACTER SIDE
154 INTEGER INCV, L, LDC, M, N
155 COMPLEX*16 TAU
156* ..
157* .. Array Arguments ..
158 COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 COMPLEX*16 ONE, ZERO
165 parameter( one = ( 1.0d+0, 0.0d+0 ),
166 $ zero = ( 0.0d+0, 0.0d+0 ) )
167* ..
168* .. External Subroutines ..
169 EXTERNAL zaxpy, zcopy, zgemv, zgerc, zgeru, zlacgv
170* ..
171* .. External Functions ..
172 LOGICAL LSAME
173 EXTERNAL lsame
174* ..
175* .. Executable Statements ..
176*
177 IF( lsame( side, 'L' ) ) THEN
178*
179* Form H * C
180*
181 IF( tau.NE.zero ) THEN
182*
183* w( 1:n ) = conjg( C( 1, 1:n ) )
184*
185 CALL zcopy( n, c, ldc, work, 1 )
186 CALL zlacgv( n, work, 1 )
187*
188* w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )**H * v( 1:l ) )
189*
190 CALL zgemv( 'Conjugate transpose', l, n, one, c( m-l+1, 1 ),
191 $ ldc, v, incv, one, work, 1 )
192 CALL zlacgv( n, work, 1 )
193*
194* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
195*
196 CALL zaxpy( n, -tau, work, 1, c, ldc )
197*
198* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
199* tau * v( 1:l ) * w( 1:n )**H
200*
201 CALL zgeru( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),
202 $ ldc )
203 END IF
204*
205 ELSE
206*
207* Form C * H
208*
209 IF( tau.NE.zero ) THEN
210*
211* w( 1:m ) = C( 1:m, 1 )
212*
213 CALL zcopy( m, c, 1, work, 1 )
214*
215* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
216*
217 CALL zgemv( 'No transpose', m, l, one, c( 1, n-l+1 ), ldc,
218 $ v, incv, one, work, 1 )
219*
220* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )
221*
222 CALL zaxpy( m, -tau, work, 1, c, 1 )
223*
224* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
225* tau * w( 1:m ) * v( 1:l )**H
226*
227 CALL zgerc( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),
228 $ ldc )
229*
230 END IF
231*
232 END IF
233*
234 RETURN
235*
236* End of ZLARZ
237*

◆ zlarzb()

subroutine zlarzb ( 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( ldc, * ) c,
integer ldc,
complex*16, dimension( ldwork, * ) work,
integer ldwork )

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

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

Purpose:
!>
!> ZLARZB applies a complex block reflector H or its transpose H**H
!> to a complex distributed M-by-N  C from the left or the right.
!>
!> Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
!>
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, not supported yet)
!>          = '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                        (not supported yet)
!>          = '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).
!>
[in]L
!>          L is INTEGER
!>          The number of columns of the matrix V containing the
!>          meaningful part of the Householder reflectors.
!>          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
!>
[in]V
!>          V is COMPLEX*16 array, dimension (LDV,NV).
!>          If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V.
!>          If STOREV = 'C', LDV >= L; 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.
Contributors:
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
Further Details:
!>

Definition at line 181 of file zlarzb.f.

183*
184* -- LAPACK computational routine --
185* -- LAPACK is a software package provided by Univ. of Tennessee, --
186* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
187*
188* .. Scalar Arguments ..
189 CHARACTER DIRECT, SIDE, STOREV, TRANS
190 INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N
191* ..
192* .. Array Arguments ..
193 COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
194 $ WORK( LDWORK, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 COMPLEX*16 ONE
201 parameter( one = ( 1.0d+0, 0.0d+0 ) )
202* ..
203* .. Local Scalars ..
204 CHARACTER TRANST
205 INTEGER I, INFO, J
206* ..
207* .. External Functions ..
208 LOGICAL LSAME
209 EXTERNAL lsame
210* ..
211* .. External Subroutines ..
212 EXTERNAL xerbla, zcopy, zgemm, zlacgv, ztrmm
213* ..
214* .. Executable Statements ..
215*
216* Quick return if possible
217*
218 IF( m.LE.0 .OR. n.LE.0 )
219 $ RETURN
220*
221* Check for currently supported options
222*
223 info = 0
224 IF( .NOT.lsame( direct, 'B' ) ) THEN
225 info = -3
226 ELSE IF( .NOT.lsame( storev, 'R' ) ) THEN
227 info = -4
228 END IF
229 IF( info.NE.0 ) THEN
230 CALL xerbla( 'ZLARZB', -info )
231 RETURN
232 END IF
233*
234 IF( lsame( trans, 'N' ) ) THEN
235 transt = 'C'
236 ELSE
237 transt = 'N'
238 END IF
239*
240 IF( lsame( side, 'L' ) ) THEN
241*
242* Form H * C or H**H * C
243*
244* W( 1:n, 1:k ) = C( 1:k, 1:n )**H
245*
246 DO 10 j = 1, k
247 CALL zcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
248 10 CONTINUE
249*
250* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
251* C( m-l+1:m, 1:n )**H * V( 1:k, 1:l )**T
252*
253 IF( l.GT.0 )
254 $ CALL zgemm( 'Transpose', 'Conjugate transpose', n, k, l,
255 $ one, c( m-l+1, 1 ), ldc, v, ldv, one, work,
256 $ ldwork )
257*
258* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T**T or W( 1:m, 1:k ) * T
259*
260 CALL ztrmm( 'Right', 'Lower', transt, 'Non-unit', n, k, one, t,
261 $ ldt, work, ldwork )
262*
263* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )**H
264*
265 DO 30 j = 1, n
266 DO 20 i = 1, k
267 c( i, j ) = c( i, j ) - work( j, i )
268 20 CONTINUE
269 30 CONTINUE
270*
271* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
272* V( 1:k, 1:l )**H * W( 1:n, 1:k )**H
273*
274 IF( l.GT.0 )
275 $ CALL zgemm( 'Transpose', 'Transpose', l, n, k, -one, v, ldv,
276 $ work, ldwork, one, c( m-l+1, 1 ), ldc )
277*
278 ELSE IF( lsame( side, 'R' ) ) THEN
279*
280* Form C * H or C * H**H
281*
282* W( 1:m, 1:k ) = C( 1:m, 1:k )
283*
284 DO 40 j = 1, k
285 CALL zcopy( m, c( 1, j ), 1, work( 1, j ), 1 )
286 40 CONTINUE
287*
288* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
289* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )**H
290*
291 IF( l.GT.0 )
292 $ CALL zgemm( 'No transpose', 'Transpose', m, k, l, one,
293 $ c( 1, n-l+1 ), ldc, v, ldv, one, work, ldwork )
294*
295* W( 1:m, 1:k ) = W( 1:m, 1:k ) * conjg( T ) or
296* W( 1:m, 1:k ) * T**H
297*
298 DO 50 j = 1, k
299 CALL zlacgv( k-j+1, t( j, j ), 1 )
300 50 CONTINUE
301 CALL ztrmm( 'Right', 'Lower', trans, 'Non-unit', m, k, one, t,
302 $ ldt, work, ldwork )
303 DO 60 j = 1, k
304 CALL zlacgv( k-j+1, t( j, j ), 1 )
305 60 CONTINUE
306*
307* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
308*
309 DO 80 j = 1, k
310 DO 70 i = 1, m
311 c( i, j ) = c( i, j ) - work( i, j )
312 70 CONTINUE
313 80 CONTINUE
314*
315* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
316* W( 1:m, 1:k ) * conjg( V( 1:k, 1:l ) )
317*
318 DO 90 j = 1, l
319 CALL zlacgv( k, v( 1, j ), 1 )
320 90 CONTINUE
321 IF( l.GT.0 )
322 $ CALL zgemm( 'No transpose', 'No transpose', m, l, k, -one,
323 $ work, ldwork, v, ldv, one, c( 1, n-l+1 ), ldc )
324 DO 100 j = 1, l
325 CALL zlacgv( k, v( 1, j ), 1 )
326 100 CONTINUE
327*
328 END IF
329*
330 RETURN
331*
332* End of ZLARZB
333*
ztrmm
subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRMM
Definition ztrmm.f:177

◆ zlarzt()

subroutine zlarzt ( 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 )

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

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

Purpose:
!>
!> ZLARZT 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
!>
!> Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
!>
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, not supported yet)
!>          = '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                        (not supported yet)
!>          = '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,out]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.
Contributors:
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
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_____
!>         ( v1 v2 v3 )                        /            \
!>         ( v1 v2 v3 )                      ( v1 v1 v1 v1 v1 . . . . 1 )
!>     V = ( v1 v2 v3 )                      ( v2 v2 v2 v2 v2 . . . 1   )
!>         ( v1 v2 v3 )                      ( v3 v3 v3 v3 v3 . . 1     )
!>         ( v1 v2 v3 )
!>            .  .  .
!>            .  .  .
!>            1  .  .
!>               1  .
!>                  1
!>
!>  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
!>
!>                                                        ______V_____
!>            1                                          /            \
!>            .  1                           ( 1 . . . . v1 v1 v1 v1 v1 )
!>            .  .  1                        ( . 1 . . . v2 v2 v2 v2 v2 )
!>            .  .  .                        ( . . 1 . . v3 v3 v3 v3 v3 )
!>            .  .  .
!>         ( v1 v2 v3 )
!>         ( v1 v2 v3 )
!>     V = ( v1 v2 v3 )
!>         ( v1 v2 v3 )
!>         ( v1 v2 v3 )
!>

Definition at line 184 of file zlarzt.f.

185*
186* -- LAPACK computational routine --
187* -- LAPACK is a software package provided by Univ. of Tennessee, --
188* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
189*
190* .. Scalar Arguments ..
191 CHARACTER DIRECT, STOREV
192 INTEGER K, LDT, LDV, N
193* ..
194* .. Array Arguments ..
195 COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
196* ..
197*
198* =====================================================================
199*
200* .. Parameters ..
201 COMPLEX*16 ZERO
202 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
203* ..
204* .. Local Scalars ..
205 INTEGER I, INFO, J
206* ..
207* .. External Subroutines ..
208 EXTERNAL xerbla, zgemv, zlacgv, ztrmv
209* ..
210* .. External Functions ..
211 LOGICAL LSAME
212 EXTERNAL lsame
213* ..
214* .. Executable Statements ..
215*
216* Check for currently supported options
217*
218 info = 0
219 IF( .NOT.lsame( direct, 'B' ) ) THEN
220 info = -1
221 ELSE IF( .NOT.lsame( storev, 'R' ) ) THEN
222 info = -2
223 END IF
224 IF( info.NE.0 ) THEN
225 CALL xerbla( 'ZLARZT', -info )
226 RETURN
227 END IF
228*
229 DO 20 i = k, 1, -1
230 IF( tau( i ).EQ.zero ) THEN
231*
232* H(i) = I
233*
234 DO 10 j = i, k
235 t( j, i ) = zero
236 10 CONTINUE
237 ELSE
238*
239* general case
240*
241 IF( i.LT.k ) THEN
242*
243* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)**H
244*
245 CALL zlacgv( n, v( i, 1 ), ldv )
246 CALL zgemv( 'No transpose', k-i, n, -tau( i ),
247 $ v( i+1, 1 ), ldv, v( i, 1 ), ldv, zero,
248 $ t( i+1, i ), 1 )
249 CALL zlacgv( n, v( i, 1 ), ldv )
250*
251* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)
252*
253 CALL ztrmv( 'Lower', 'No transpose', 'Non-unit', k-i,
254 $ t( i+1, i+1 ), ldt, t( i+1, i ), 1 )
255 END IF
256 t( i, i ) = tau( i )
257 END IF
258 20 CONTINUE
259 RETURN
260*
261* End of ZLARZT
262*

◆ zlascl2()

subroutine zlascl2 ( integer m,
integer n,
double precision, dimension( * ) d,
complex*16, dimension( ldx, * ) x,
integer ldx )

ZLASCL2 performs diagonal scaling on a vector.

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

Purpose:
!>
!> ZLASCL2 performs a diagonal scaling on a vector:
!>   x <-- D * x
!> where the DOUBLE PRECISION diagonal matrix D is stored as a vector.
!>
!> Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS
!> standard.
!>
Parameters
[in]M
!>          M is INTEGER
!>     The number of rows of D and X. M >= 0.
!>
[in]N
!>          N is INTEGER
!>     The number of columns of X. N >= 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, length M
!>     Diagonal matrix D, stored as a vector of length M.
!>
[in,out]X
!>          X is COMPLEX*16 array, dimension (LDX,N)
!>     On entry, the vector X to be scaled by D.
!>     On exit, the scaled vector.
!>
[in]LDX
!>          LDX is INTEGER
!>     The leading dimension of the vector X. LDX >= M.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 90 of file zlascl2.f.

91*
92* -- LAPACK computational routine --
93* -- LAPACK is a software package provided by Univ. of Tennessee, --
94* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
95*
96* .. Scalar Arguments ..
97 INTEGER M, N, LDX
98* ..
99* .. Array Arguments ..
100 DOUBLE PRECISION D( * )
101 COMPLEX*16 X( LDX, * )
102* ..
103*
104* =====================================================================
105*
106* .. Local Scalars ..
107 INTEGER I, J
108* ..
109* .. Executable Statements ..
110*
111 DO j = 1, n
112 DO i = 1, m
113 x( i, j ) = x( i, j ) * d( i )
114 END DO
115 END DO
116
117 RETURN

◆ zlatrz()

subroutine zlatrz ( integer m,
integer n,
integer l,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work )

ZLATRZ factors an upper trapezoidal matrix by means of unitary transformations.

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

Purpose:
!>
!> ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix
!> [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z by means
!> of unitary transformations, where  Z is an (M+L)-by-(M+L) unitary
!> matrix and, R and A1 are M-by-M upper triangular matrices.
!>
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]L
!>          L is INTEGER
!>          The number of columns of the matrix A containing the
!>          meaningful part of the Householder vectors. N-M >= L >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the leading M-by-N upper trapezoidal part of the
!>          array A must contain the matrix to be factorized.
!>          On exit, the leading M-by-M upper triangular part of A
!>          contains the upper triangular matrix R, and elements N-L+1 to
!>          N of the first M rows of A, with the array TAU, represent the
!>          unitary matrix Z as a product of M elementary reflectors.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (M)
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (M)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
Further Details:
!>
!>  The factorization is obtained by Householder's method.  The kth
!>  transformation matrix, Z( k ), which is used to introduce zeros into
!>  the ( m - k + 1 )th row of A, is given in the form
!>
!>     Z( k ) = ( I     0   ),
!>              ( 0  T( k ) )
!>
!>  where
!>
!>     T( k ) = I - tau*u( k )*u( k )**H,   u( k ) = (   1    ),
!>                                                 (   0    )
!>                                                 ( z( k ) )
!>
!>  tau is a scalar and z( k ) is an l element vector. tau and z( k )
!>  are chosen to annihilate the elements of the kth row of A2.
!>
!>  The scalar tau is returned in the kth element of TAU and the vector
!>  u( k ) in the kth row of A2, such that the elements of z( k ) are
!>  in  a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
!>  the upper triangular part of A1.
!>
!>  Z is given by
!>
!>     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
!>

Definition at line 139 of file zlatrz.f.

140*
141* -- LAPACK computational routine --
142* -- LAPACK is a software package provided by Univ. of Tennessee, --
143* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
144*
145* .. Scalar Arguments ..
146 INTEGER L, LDA, M, N
147* ..
148* .. Array Arguments ..
149 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
150* ..
151*
152* =====================================================================
153*
154* .. Parameters ..
155 COMPLEX*16 ZERO
156 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
157* ..
158* .. Local Scalars ..
159 INTEGER I
160 COMPLEX*16 ALPHA
161* ..
162* .. External Subroutines ..
163 EXTERNAL zlacgv, zlarfg, zlarz
164* ..
165* .. Intrinsic Functions ..
166 INTRINSIC dconjg
167* ..
168* .. Executable Statements ..
169*
170* Quick return if possible
171*
172 IF( m.EQ.0 ) THEN
173 RETURN
174 ELSE IF( m.EQ.n ) THEN
175 DO 10 i = 1, n
176 tau( i ) = zero
177 10 CONTINUE
178 RETURN
179 END IF
180*
181 DO 20 i = m, 1, -1
182*
183* Generate elementary reflector H(i) to annihilate
184* [ A(i,i) A(i,n-l+1:n) ]
185*
186 CALL zlacgv( l, a( i, n-l+1 ), lda )
187 alpha = dconjg( a( i, i ) )
188 CALL zlarfg( l+1, alpha, a( i, n-l+1 ), lda, tau( i ) )
189 tau( i ) = dconjg( tau( i ) )
190*
191* Apply H(i) to A(1:i-1,i:n) from the right
192*
193 CALL zlarz( 'Right', i-1, n-i+1, l, a( i, n-l+1 ), lda,
194 $ dconjg( tau( i ) ), a( 1, i ), lda, work )
195 a( i, i ) = dconjg( alpha )
196*
197 20 CONTINUE
198*
199 RETURN
200*
201* End of ZLATRZ
202*
zlarz
subroutine zlarz(side, m, n, l, v, incv, tau, c, ldc, work)
ZLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix.
Definition zlarz.f:147

◆ zlatzm()

subroutine zlatzm ( character side,
integer m,
integer n,
complex*16, dimension( * ) v,
integer incv,
complex*16 tau,
complex*16, dimension( ldc, * ) c1,
complex*16, dimension( ldc, * ) c2,
integer ldc,
complex*16, dimension( * ) work )

ZLATZM

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine ZUNMRZ.
!>
!> ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix.
!>
!> Let P = I - tau*u*u**H,   u = ( 1 ),
!>                               ( v )
!> where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if
!> SIDE = 'R'.
!>
!> If SIDE equals 'L', let
!>        C = [ C1 ] 1
!>            [ C2 ] m-1
!>              n
!> Then C is overwritten by P*C.
!>
!> If SIDE equals 'R', let
!>        C = [ C1, C2 ] m
!>               1  n-1
!> Then C is overwritten by C*P.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': form P * C
!>          = 'R': form C * P
!>
[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'
!>                  (1 + (N-1)*abs(INCV)) if SIDE = 'R'
!>          The vector v in the representation of P. 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 P.
!>
[in,out]C1
!>          C1 is COMPLEX*16 array, dimension
!>                         (LDC,N) if SIDE = 'L'
!>                         (M,1)   if SIDE = 'R'
!>          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1
!>          if SIDE = 'R'.
!>
!>          On exit, the first row of P*C if SIDE = 'L', or the first
!>          column of C*P if SIDE = 'R'.
!>
[in,out]C2
!>          C2 is COMPLEX*16 array, dimension
!>                         (LDC, N)   if SIDE = 'L'
!>                         (LDC, N-1) if SIDE = 'R'
!>          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the
!>          m x (n - 1) matrix C2 if SIDE = 'R'.
!>
!>          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P
!>          if SIDE = 'R'.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the arrays C1 and C2.
!>          LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (N) if SIDE = 'L'
!>                      (M) if SIDE = 'R'
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 151 of file zlatzm.f.

152*
153* -- LAPACK computational routine --
154* -- LAPACK is a software package provided by Univ. of Tennessee, --
155* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
156*
157* .. Scalar Arguments ..
158 CHARACTER SIDE
159 INTEGER INCV, LDC, M, N
160 COMPLEX*16 TAU
161* ..
162* .. Array Arguments ..
163 COMPLEX*16 C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
164* ..
165*
166* =====================================================================
167*
168* .. Parameters ..
169 COMPLEX*16 ONE, ZERO
170 parameter( one = ( 1.0d+0, 0.0d+0 ),
171 $ zero = ( 0.0d+0, 0.0d+0 ) )
172* ..
173* .. External Subroutines ..
174 EXTERNAL zaxpy, zcopy, zgemv, zgerc, zgeru, zlacgv
175* ..
176* .. External Functions ..
177 LOGICAL LSAME
178 EXTERNAL lsame
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC min
182* ..
183* .. Executable Statements ..
184*
185 IF( ( min( m, n ).EQ.0 ) .OR. ( tau.EQ.zero ) )
186 $ RETURN
187*
188 IF( lsame( side, 'L' ) ) THEN
189*
190* w := ( C1 + v**H * C2 )**H
191*
192 CALL zcopy( n, c1, ldc, work, 1 )
193 CALL zlacgv( n, work, 1 )
194 CALL zgemv( 'Conjugate transpose', m-1, n, one, c2, ldc, v,
195 $ incv, one, work, 1 )
196*
197* [ C1 ] := [ C1 ] - tau* [ 1 ] * w**H
198* [ C2 ] [ C2 ] [ v ]
199*
200 CALL zlacgv( n, work, 1 )
201 CALL zaxpy( n, -tau, work, 1, c1, ldc )
202 CALL zgeru( m-1, n, -tau, v, incv, work, 1, c2, ldc )
203*
204 ELSE IF( lsame( side, 'R' ) ) THEN
205*
206* w := C1 + C2 * v
207*
208 CALL zcopy( m, c1, 1, work, 1 )
209 CALL zgemv( 'No transpose', m, n-1, one, c2, ldc, v, incv, one,
210 $ work, 1 )
211*
212* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**H]
213*
214 CALL zaxpy( m, -tau, work, 1, c1, 1 )
215 CALL zgerc( m, n-1, -tau, work, 1, v, incv, c2, ldc )
216 END IF
217*
218 RETURN
219*
220* End of ZLATZM
221*

◆ zpbcon()

subroutine zpbcon ( character uplo,
integer n,
integer kd,
complex*16, dimension( ldab, * ) ab,
integer ldab,
double precision anorm,
double precision rcond,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZPBCON

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

Purpose:
!>
!> ZPBCON estimates the reciprocal of the condition number (in the
!> 1-norm) of a complex Hermitian positive definite band matrix using
!> the Cholesky factorization A = U**H*U or A = L*L**H computed by
!> ZPBTRF.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangular factor stored in AB;
!>          = 'L':  Lower triangular factor stored in AB.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
!>
[in]AB
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**H*U or A = L*L**H of the band matrix A, stored in the
!>          first KD+1 rows of the array.  The j-th column of U or L is
!>          stored in the j-th column of the array AB as follows:
!>          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO ='L', AB(1+i-j,j)    = L(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]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The 1-norm (or infinity-norm) of the Hermitian band matrix A.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 131 of file zpbcon.f.

133*
134* -- LAPACK computational 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 CHARACTER UPLO
140 INTEGER INFO, KD, LDAB, N
141 DOUBLE PRECISION ANORM, RCOND
142* ..
143* .. Array Arguments ..
144 DOUBLE PRECISION RWORK( * )
145 COMPLEX*16 AB( LDAB, * ), WORK( * )
146* ..
147*
148* =====================================================================
149*
150* .. Parameters ..
151 DOUBLE PRECISION ONE, ZERO
152 parameter( one = 1.0d+0, zero = 0.0d+0 )
153* ..
154* .. Local Scalars ..
155 LOGICAL UPPER
156 CHARACTER NORMIN
157 INTEGER IX, KASE
158 DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
159 COMPLEX*16 ZDUM
160* ..
161* .. Local Arrays ..
162 INTEGER ISAVE( 3 )
163* ..
164* .. External Functions ..
165 LOGICAL LSAME
166 INTEGER IZAMAX
167 DOUBLE PRECISION DLAMCH
168 EXTERNAL lsame, izamax, dlamch
169* ..
170* .. External Subroutines ..
171 EXTERNAL xerbla, zdrscl, zlacn2, zlatbs
172* ..
173* .. Intrinsic Functions ..
174 INTRINSIC abs, dble, dimag
175* ..
176* .. Statement Functions ..
177 DOUBLE PRECISION CABS1
178* ..
179* .. Statement Function definitions ..
180 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
181* ..
182* .. Executable Statements ..
183*
184* Test the input parameters.
185*
186 info = 0
187 upper = lsame( uplo, 'U' )
188 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
189 info = -1
190 ELSE IF( n.LT.0 ) THEN
191 info = -2
192 ELSE IF( kd.LT.0 ) THEN
193 info = -3
194 ELSE IF( ldab.LT.kd+1 ) THEN
195 info = -5
196 ELSE IF( anorm.LT.zero ) THEN
197 info = -6
198 END IF
199 IF( info.NE.0 ) THEN
200 CALL xerbla( 'ZPBCON', -info )
201 RETURN
202 END IF
203*
204* Quick return if possible
205*
206 rcond = zero
207 IF( n.EQ.0 ) THEN
208 rcond = one
209 RETURN
210 ELSE IF( anorm.EQ.zero ) THEN
211 RETURN
212 END IF
213*
214 smlnum = dlamch( 'Safe minimum' )
215*
216* Estimate the 1-norm of the inverse.
217*
218 kase = 0
219 normin = 'N'
220 10 CONTINUE
221 CALL zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
222 IF( kase.NE.0 ) THEN
223 IF( upper ) THEN
224*
225* Multiply by inv(U**H).
226*
227 CALL zlatbs( 'Upper', 'Conjugate transpose', 'Non-unit',
228 $ normin, n, kd, ab, ldab, work, scalel, rwork,
229 $ info )
230 normin = 'Y'
231*
232* Multiply by inv(U).
233*
234 CALL zlatbs( 'Upper', 'No transpose', 'Non-unit', normin, n,
235 $ kd, ab, ldab, work, scaleu, rwork, info )
236 ELSE
237*
238* Multiply by inv(L).
239*
240 CALL zlatbs( 'Lower', 'No transpose', 'Non-unit', normin, n,
241 $ kd, ab, ldab, work, scalel, rwork, info )
242 normin = 'Y'
243*
244* Multiply by inv(L**H).
245*
246 CALL zlatbs( 'Lower', 'Conjugate transpose', 'Non-unit',
247 $ normin, n, kd, ab, ldab, work, scaleu, rwork,
248 $ info )
249 END IF
250*
251* Multiply by 1/SCALE if doing so will not cause overflow.
252*
253 scale = scalel*scaleu
254 IF( scale.NE.one ) THEN
255 ix = izamax( n, work, 1 )
256 IF( scale.LT.cabs1( work( ix ) )*smlnum .OR. scale.EQ.zero )
257 $ GO TO 20
258 CALL zdrscl( n, scale, work, 1 )
259 END IF
260 GO TO 10
261 END IF
262*
263* Compute the estimate of the reciprocal condition number.
264*
265 IF( ainvnm.NE.zero )
266 $ rcond = ( one / ainvnm ) / anorm
267*
268 20 CONTINUE
269*
270 RETURN
271*
272* End of ZPBCON
273*
zlatbs
subroutine zlatbs(uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
ZLATBS solves a triangular banded system of equations.
Definition zlatbs.f:243
zdrscl
subroutine zdrscl(n, sa, sx, incx)
ZDRSCL multiplies a vector by the reciprocal of a real scalar.
Definition zdrscl.f:84

◆ zpbequ()

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

ZPBEQU

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

Purpose:
!>
!> ZPBEQU computes row and column scalings intended to equilibrate a
!> Hermitian positive definite band matrix A and reduce its condition
!> number (with respect to the two-norm).  S contains the scale factors,
!> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
!> choice of S puts the condition number of B within a factor N of the
!> smallest possible condition number over all possible diagonal
!> scalings.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangular of A is stored;
!>          = 'L':  Lower triangular of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'.  KD >= 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 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 A.  LDAB >= KD+1.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (N)
!>          If INFO = 0, S contains the scale factors for A.
!>
[out]SCOND
!>          SCOND is DOUBLE PRECISION
!>          If INFO = 0, S contains the ratio of the smallest S(i) to
!>          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
!>          large nor too small, it is not worth scaling by S.
!>
[out]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix element.  If AMAX is very
!>          close to overflow or very close to underflow, the matrix
!>          should be scaled.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file zpbequ.f.

130*
131* -- LAPACK computational 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 UPLO
137 INTEGER INFO, KD, LDAB, N
138 DOUBLE PRECISION AMAX, SCOND
139* ..
140* .. Array Arguments ..
141 DOUBLE PRECISION S( * )
142 COMPLEX*16 AB( LDAB, * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 DOUBLE PRECISION ZERO, ONE
149 parameter( zero = 0.0d+0, one = 1.0d+0 )
150* ..
151* .. Local Scalars ..
152 LOGICAL UPPER
153 INTEGER I, J
154 DOUBLE PRECISION SMIN
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 EXTERNAL lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL xerbla
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC dble, max, min, sqrt
165* ..
166* .. Executable Statements ..
167*
168* Test the input parameters.
169*
170 info = 0
171 upper = lsame( uplo, 'U' )
172 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
173 info = -1
174 ELSE IF( n.LT.0 ) THEN
175 info = -2
176 ELSE IF( kd.LT.0 ) THEN
177 info = -3
178 ELSE IF( ldab.LT.kd+1 ) THEN
179 info = -5
180 END IF
181 IF( info.NE.0 ) THEN
182 CALL xerbla( 'ZPBEQU', -info )
183 RETURN
184 END IF
185*
186* Quick return if possible
187*
188 IF( n.EQ.0 ) THEN
189 scond = one
190 amax = zero
191 RETURN
192 END IF
193*
194 IF( upper ) THEN
195 j = kd + 1
196 ELSE
197 j = 1
198 END IF
199*
200* Initialize SMIN and AMAX.
201*
202 s( 1 ) = dble( ab( j, 1 ) )
203 smin = s( 1 )
204 amax = s( 1 )
205*
206* Find the minimum and maximum diagonal elements.
207*
208 DO 10 i = 2, n
209 s( i ) = dble( ab( j, i ) )
210 smin = min( smin, s( i ) )
211 amax = max( amax, s( i ) )
212 10 CONTINUE
213*
214 IF( smin.LE.zero ) THEN
215*
216* Find the first non-positive diagonal element and return.
217*
218 DO 20 i = 1, n
219 IF( s( i ).LE.zero ) THEN
220 info = i
221 RETURN
222 END IF
223 20 CONTINUE
224 ELSE
225*
226* Set the scale factors to the reciprocals
227* of the diagonal elements.
228*
229 DO 30 i = 1, n
230 s( i ) = one / sqrt( s( i ) )
231 30 CONTINUE
232*
233* Compute SCOND = min(S(I)) / max(S(I))
234*
235 scond = sqrt( smin ) / sqrt( amax )
236 END IF
237 RETURN
238*
239* End of ZPBEQU
240*

◆ zpbrfs()

subroutine zpbrfs ( character uplo,
integer n,
integer kd,
integer nrhs,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( ldafb, * ) afb,
integer ldafb,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZPBRFS

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

Purpose:
!>
!> ZPBRFS improves the computed solution to a system of linear
!> equations when the coefficient matrix is Hermitian positive definite
!> and banded, and provides error bounds and backward error estimates
!> for the solution.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X.  NRHS >= 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 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]AFB
!>          AFB is COMPLEX*16 array, dimension (LDAFB,N)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**H*U or A = L*L**H of the band matrix A as computed by
!>          ZPBTRF, in the same storage format as A (see AB).
!>
[in]LDAFB
!>          LDAFB is INTEGER
!>          The leading dimension of the array AFB.  LDAFB >= KD+1.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by ZPBTRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Internal Parameters:
!>  ITMAX is the maximum number of steps of iterative refinement.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 187 of file zpbrfs.f.

189*
190* -- LAPACK computational routine --
191* -- LAPACK is a software package provided by Univ. of Tennessee, --
192* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
193*
194* .. Scalar Arguments ..
195 CHARACTER UPLO
196 INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
197* ..
198* .. Array Arguments ..
199 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
200 COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
201 $ WORK( * ), X( LDX, * )
202* ..
203*
204* =====================================================================
205*
206* .. Parameters ..
207 INTEGER ITMAX
208 parameter( itmax = 5 )
209 DOUBLE PRECISION ZERO
210 parameter( zero = 0.0d+0 )
211 COMPLEX*16 ONE
212 parameter( one = ( 1.0d+0, 0.0d+0 ) )
213 DOUBLE PRECISION TWO
214 parameter( two = 2.0d+0 )
215 DOUBLE PRECISION THREE
216 parameter( three = 3.0d+0 )
217* ..
218* .. Local Scalars ..
219 LOGICAL UPPER
220 INTEGER COUNT, I, J, K, KASE, L, NZ
221 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
222 COMPLEX*16 ZDUM
223* ..
224* .. Local Arrays ..
225 INTEGER ISAVE( 3 )
226* ..
227* .. External Subroutines ..
228 EXTERNAL xerbla, zaxpy, zcopy, zhbmv, zlacn2, zpbtrs
229* ..
230* .. Intrinsic Functions ..
231 INTRINSIC abs, dble, dimag, max, min
232* ..
233* .. External Functions ..
234 LOGICAL LSAME
235 DOUBLE PRECISION DLAMCH
236 EXTERNAL lsame, dlamch
237* ..
238* .. Statement Functions ..
239 DOUBLE PRECISION CABS1
240* ..
241* .. Statement Function definitions ..
242 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
243* ..
244* .. Executable Statements ..
245*
246* Test the input parameters.
247*
248 info = 0
249 upper = lsame( uplo, 'U' )
250 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
251 info = -1
252 ELSE IF( n.LT.0 ) THEN
253 info = -2
254 ELSE IF( kd.LT.0 ) THEN
255 info = -3
256 ELSE IF( nrhs.LT.0 ) THEN
257 info = -4
258 ELSE IF( ldab.LT.kd+1 ) THEN
259 info = -6
260 ELSE IF( ldafb.LT.kd+1 ) THEN
261 info = -8
262 ELSE IF( ldb.LT.max( 1, n ) ) THEN
263 info = -10
264 ELSE IF( ldx.LT.max( 1, n ) ) THEN
265 info = -12
266 END IF
267 IF( info.NE.0 ) THEN
268 CALL xerbla( 'ZPBRFS', -info )
269 RETURN
270 END IF
271*
272* Quick return if possible
273*
274 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
275 DO 10 j = 1, nrhs
276 ferr( j ) = zero
277 berr( j ) = zero
278 10 CONTINUE
279 RETURN
280 END IF
281*
282* NZ = maximum number of nonzero elements in each row of A, plus 1
283*
284 nz = min( n+1, 2*kd+2 )
285 eps = dlamch( 'Epsilon' )
286 safmin = dlamch( 'Safe minimum' )
287 safe1 = nz*safmin
288 safe2 = safe1 / eps
289*
290* Do for each right hand side
291*
292 DO 140 j = 1, nrhs
293*
294 count = 1
295 lstres = three
296 20 CONTINUE
297*
298* Loop until stopping criterion is satisfied.
299*
300* Compute residual R = B - A * X
301*
302 CALL zcopy( n, b( 1, j ), 1, work, 1 )
303 CALL zhbmv( uplo, n, kd, -one, ab, ldab, x( 1, j ), 1, one,
304 $ work, 1 )
305*
306* Compute componentwise relative backward error from formula
307*
308* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
309*
310* where abs(Z) is the componentwise absolute value of the matrix
311* or vector Z. If the i-th component of the denominator is less
312* than SAFE2, then SAFE1 is added to the i-th components of the
313* numerator and denominator before dividing.
314*
315 DO 30 i = 1, n
316 rwork( i ) = cabs1( b( i, j ) )
317 30 CONTINUE
318*
319* Compute abs(A)*abs(X) + abs(B).
320*
321 IF( upper ) THEN
322 DO 50 k = 1, n
323 s = zero
324 xk = cabs1( x( k, j ) )
325 l = kd + 1 - k
326 DO 40 i = max( 1, k-kd ), k - 1
327 rwork( i ) = rwork( i ) + cabs1( ab( l+i, k ) )*xk
328 s = s + cabs1( ab( l+i, k ) )*cabs1( x( i, j ) )
329 40 CONTINUE
330 rwork( k ) = rwork( k ) + abs( dble( ab( kd+1, k ) ) )*
331 $ xk + s
332 50 CONTINUE
333 ELSE
334 DO 70 k = 1, n
335 s = zero
336 xk = cabs1( x( k, j ) )
337 rwork( k ) = rwork( k ) + abs( dble( ab( 1, k ) ) )*xk
338 l = 1 - k
339 DO 60 i = k + 1, min( n, k+kd )
340 rwork( i ) = rwork( i ) + cabs1( ab( l+i, k ) )*xk
341 s = s + cabs1( ab( l+i, k ) )*cabs1( x( i, j ) )
342 60 CONTINUE
343 rwork( k ) = rwork( k ) + s
344 70 CONTINUE
345 END IF
346 s = zero
347 DO 80 i = 1, n
348 IF( rwork( i ).GT.safe2 ) THEN
349 s = max( s, cabs1( work( i ) ) / rwork( i ) )
350 ELSE
351 s = max( s, ( cabs1( work( i ) )+safe1 ) /
352 $ ( rwork( i )+safe1 ) )
353 END IF
354 80 CONTINUE
355 berr( j ) = s
356*
357* Test stopping criterion. Continue iterating if
358* 1) The residual BERR(J) is larger than machine epsilon, and
359* 2) BERR(J) decreased by at least a factor of 2 during the
360* last iteration, and
361* 3) At most ITMAX iterations tried.
362*
363 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
364 $ count.LE.itmax ) THEN
365*
366* Update solution and try again.
367*
368 CALL zpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info )
369 CALL zaxpy( n, one, work, 1, x( 1, j ), 1 )
370 lstres = berr( j )
371 count = count + 1
372 GO TO 20
373 END IF
374*
375* Bound error from formula
376*
377* norm(X - XTRUE) / norm(X) .le. FERR =
378* norm( abs(inv(A))*
379* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
380*
381* where
382* norm(Z) is the magnitude of the largest component of Z
383* inv(A) is the inverse of A
384* abs(Z) is the componentwise absolute value of the matrix or
385* vector Z
386* NZ is the maximum number of nonzeros in any row of A, plus 1
387* EPS is machine epsilon
388*
389* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
390* is incremented by SAFE1 if the i-th component of
391* abs(A)*abs(X) + abs(B) is less than SAFE2.
392*
393* Use ZLACN2 to estimate the infinity-norm of the matrix
394* inv(A) * diag(W),
395* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
396*
397 DO 90 i = 1, n
398 IF( rwork( i ).GT.safe2 ) THEN
399 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
400 ELSE
401 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
402 $ safe1
403 END IF
404 90 CONTINUE
405*
406 kase = 0
407 100 CONTINUE
408 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
409 IF( kase.NE.0 ) THEN
410 IF( kase.EQ.1 ) THEN
411*
412* Multiply by diag(W)*inv(A**H).
413*
414 CALL zpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info )
415 DO 110 i = 1, n
416 work( i ) = rwork( i )*work( i )
417 110 CONTINUE
418 ELSE IF( kase.EQ.2 ) THEN
419*
420* Multiply by inv(A)*diag(W).
421*
422 DO 120 i = 1, n
423 work( i ) = rwork( i )*work( i )
424 120 CONTINUE
425 CALL zpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info )
426 END IF
427 GO TO 100
428 END IF
429*
430* Normalize error.
431*
432 lstres = zero
433 DO 130 i = 1, n
434 lstres = max( lstres, cabs1( x( i, j ) ) )
435 130 CONTINUE
436 IF( lstres.NE.zero )
437 $ ferr( j ) = ferr( j ) / lstres
438*
439 140 CONTINUE
440*
441 RETURN
442*
443* End of ZPBRFS
444*
zpbtrs
subroutine zpbtrs(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
ZPBTRS
Definition zpbtrs.f:121
zhbmv
subroutine zhbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
ZHBMV
Definition zhbmv.f:187

◆ zpbstf()

subroutine zpbstf ( character uplo,
integer n,
integer kd,
complex*16, dimension( ldab, * ) ab,
integer ldab,
integer info )

ZPBSTF

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

Purpose:
!>
!> ZPBSTF computes a split Cholesky factorization of a complex
!> Hermitian positive definite band matrix A.
!>
!> This routine is designed to be used in conjunction with ZHBGST.
!>
!> The factorization has the form  A = S**H*S  where S is a band matrix
!> of the same bandwidth as A and the following structure:
!>
!>   S = ( U    )
!>       ( M  L )
!>
!> where U is upper triangular of order m = (n+kd)/2, and L is lower
!> triangular of order n-m.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals 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 Hermitian 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 factor S from the split Cholesky
!>          factorization A = S**H*S. See Further Details.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, the factorization could not be completed,
!>               because the updated element a(i,i) was negative; the
!>               matrix A is not positive definite.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The band storage scheme is illustrated by the following example, when
!>  N = 7, KD = 2:
!>
!>  S = ( s11  s12  s13                     )
!>      (      s22  s23  s24                )
!>      (           s33  s34                )
!>      (                s44                )
!>      (           s53  s54  s55           )
!>      (                s64  s65  s66      )
!>      (                     s75  s76  s77 )
!>
!>  If UPLO = 'U', the array AB holds:
!>
!>  on entry:                          on exit:
!>
!>   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53**H s64**H s75**H
!>   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54**H s65**H s76**H
!>  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55    s66    s77
!>
!>  If UPLO = 'L', the array AB holds:
!>
!>  on entry:                          on exit:
!>
!>  a11  a22  a33  a44  a55  a66  a77  s11    s22    s33    s44  s55  s66  s77
!>  a21  a32  a43  a54  a65  a76   *   s12**H s23**H s34**H s54  s65  s76   *
!>  a31  a42  a53  a64  a64   *    *   s13**H s24**H s53    s64  s75   *    *
!>
!>  Array elements marked * are not used by the routine; s12**H denotes
!>  conjg(s12); the diagonal elements of S are real.
!>

Definition at line 152 of file zpbstf.f.

153*
154* -- LAPACK computational routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 CHARACTER UPLO
160 INTEGER INFO, KD, LDAB, N
161* ..
162* .. Array Arguments ..
163 COMPLEX*16 AB( LDAB, * )
164* ..
165*
166* =====================================================================
167*
168* .. Parameters ..
169 DOUBLE PRECISION ONE, ZERO
170 parameter( one = 1.0d+0, zero = 0.0d+0 )
171* ..
172* .. Local Scalars ..
173 LOGICAL UPPER
174 INTEGER J, KLD, KM, M
175 DOUBLE PRECISION AJJ
176* ..
177* .. External Functions ..
178 LOGICAL LSAME
179 EXTERNAL lsame
180* ..
181* .. External Subroutines ..
182 EXTERNAL xerbla, zdscal, zher, zlacgv
183* ..
184* .. Intrinsic Functions ..
185 INTRINSIC dble, max, min, sqrt
186* ..
187* .. Executable Statements ..
188*
189* Test the input parameters.
190*
191 info = 0
192 upper = lsame( uplo, 'U' )
193 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
194 info = -1
195 ELSE IF( n.LT.0 ) THEN
196 info = -2
197 ELSE IF( kd.LT.0 ) THEN
198 info = -3
199 ELSE IF( ldab.LT.kd+1 ) THEN
200 info = -5
201 END IF
202 IF( info.NE.0 ) THEN
203 CALL xerbla( 'ZPBSTF', -info )
204 RETURN
205 END IF
206*
207* Quick return if possible
208*
209 IF( n.EQ.0 )
210 $ RETURN
211*
212 kld = max( 1, ldab-1 )
213*
214* Set the splitting point m.
215*
216 m = ( n+kd ) / 2
217*
218 IF( upper ) THEN
219*
220* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m).
221*
222 DO 10 j = n, m + 1, -1
223*
224* Compute s(j,j) and test for non-positive-definiteness.
225*
226 ajj = dble( ab( kd+1, j ) )
227 IF( ajj.LE.zero ) THEN
228 ab( kd+1, j ) = ajj
229 GO TO 50
230 END IF
231 ajj = sqrt( ajj )
232 ab( kd+1, j ) = ajj
233 km = min( j-1, kd )
234*
235* Compute elements j-km:j-1 of the j-th column and update the
236* the leading submatrix within the band.
237*
238 CALL zdscal( km, one / ajj, ab( kd+1-km, j ), 1 )
239 CALL zher( 'Upper', km, -one, ab( kd+1-km, j ), 1,
240 $ ab( kd+1, j-km ), kld )
241 10 CONTINUE
242*
243* Factorize the updated submatrix A(1:m,1:m) as U**H*U.
244*
245 DO 20 j = 1, m
246*
247* Compute s(j,j) and test for non-positive-definiteness.
248*
249 ajj = dble( ab( kd+1, j ) )
250 IF( ajj.LE.zero ) THEN
251 ab( kd+1, j ) = ajj
252 GO TO 50
253 END IF
254 ajj = sqrt( ajj )
255 ab( kd+1, j ) = ajj
256 km = min( kd, m-j )
257*
258* Compute elements j+1:j+km of the j-th row and update the
259* trailing submatrix within the band.
260*
261 IF( km.GT.0 ) THEN
262 CALL zdscal( km, one / ajj, ab( kd, j+1 ), kld )
263 CALL zlacgv( km, ab( kd, j+1 ), kld )
264 CALL zher( 'Upper', km, -one, ab( kd, j+1 ), kld,
265 $ ab( kd+1, j+1 ), kld )
266 CALL zlacgv( km, ab( kd, j+1 ), kld )
267 END IF
268 20 CONTINUE
269 ELSE
270*
271* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m).
272*
273 DO 30 j = n, m + 1, -1
274*
275* Compute s(j,j) and test for non-positive-definiteness.
276*
277 ajj = dble( ab( 1, j ) )
278 IF( ajj.LE.zero ) THEN
279 ab( 1, j ) = ajj
280 GO TO 50
281 END IF
282 ajj = sqrt( ajj )
283 ab( 1, j ) = ajj
284 km = min( j-1, kd )
285*
286* Compute elements j-km:j-1 of the j-th row and update the
287* trailing submatrix within the band.
288*
289 CALL zdscal( km, one / ajj, ab( km+1, j-km ), kld )
290 CALL zlacgv( km, ab( km+1, j-km ), kld )
291 CALL zher( 'Lower', km, -one, ab( km+1, j-km ), kld,
292 $ ab( 1, j-km ), kld )
293 CALL zlacgv( km, ab( km+1, j-km ), kld )
294 30 CONTINUE
295*
296* Factorize the updated submatrix A(1:m,1:m) as U**H*U.
297*
298 DO 40 j = 1, m
299*
300* Compute s(j,j) and test for non-positive-definiteness.
301*
302 ajj = dble( ab( 1, j ) )
303 IF( ajj.LE.zero ) THEN
304 ab( 1, j ) = ajj
305 GO TO 50
306 END IF
307 ajj = sqrt( ajj )
308 ab( 1, j ) = ajj
309 km = min( kd, m-j )
310*
311* Compute elements j+1:j+km of the j-th column and update the
312* trailing submatrix within the band.
313*
314 IF( km.GT.0 ) THEN
315 CALL zdscal( km, one / ajj, ab( 2, j ), 1 )
316 CALL zher( 'Lower', km, -one, ab( 2, j ), 1,
317 $ ab( 1, j+1 ), kld )
318 END IF
319 40 CONTINUE
320 END IF
321 RETURN
322*
323 50 CONTINUE
324 info = j
325 RETURN
326*
327* End of ZPBSTF
328*
zher
subroutine zher(uplo, n, alpha, x, incx, a, lda)
ZHER
Definition zher.f:135

◆ zpbtf2()

subroutine zpbtf2 ( character uplo,
integer n,
integer kd,
complex*16, dimension( ldab, * ) ab,
integer ldab,
integer info )

ZPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (unblocked algorithm).

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

Purpose:
!>
!> ZPBTF2 computes the Cholesky factorization of a complex Hermitian
!> positive definite band matrix A.
!>
!> The factorization has the form
!>    A = U**H * U ,  if UPLO = 'U', or
!>    A = L  * L**H,  if UPLO = 'L',
!> where U is an upper triangular matrix, U**H is the conjugate transpose
!> of U, and L is lower triangular.
!>
!> This is the unblocked version of the algorithm, calling Level 2 BLAS.
!>
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]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 Hermitian 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]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>          > 0: if INFO = k, the leading minor of order k is not
!>               positive definite, and the factorization could not be
!>               completed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The band storage scheme is illustrated by the following example, when
!>  N = 6, KD = 2, and UPLO = 'U':
!>
!>  On entry:                       On exit:
!>
!>      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
!>      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!>     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!>
!>  Similarly, if UPLO = 'L' the format of A is as follows:
!>
!>  On entry:                       On exit:
!>
!>     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
!>     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
!>     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
!>
!>  Array elements marked * are not used by the routine.
!>

Definition at line 141 of file zpbtf2.f.

142*
143* -- LAPACK computational 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 UPLO
149 INTEGER INFO, KD, LDAB, N
150* ..
151* .. Array Arguments ..
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 UPPER
163 INTEGER J, KLD, KN
164 DOUBLE PRECISION AJJ
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 EXTERNAL lsame
169* ..
170* .. External Subroutines ..
171 EXTERNAL xerbla, zdscal, zher, zlacgv
172* ..
173* .. Intrinsic Functions ..
174 INTRINSIC dble, max, min, sqrt
175* ..
176* .. Executable Statements ..
177*
178* Test the input parameters.
179*
180 info = 0
181 upper = lsame( uplo, 'U' )
182 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
183 info = -1
184 ELSE IF( n.LT.0 ) THEN
185 info = -2
186 ELSE IF( kd.LT.0 ) THEN
187 info = -3
188 ELSE IF( ldab.LT.kd+1 ) THEN
189 info = -5
190 END IF
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'ZPBTF2', -info )
193 RETURN
194 END IF
195*
196* Quick return if possible
197*
198 IF( n.EQ.0 )
199 $ RETURN
200*
201 kld = max( 1, ldab-1 )
202*
203 IF( upper ) THEN
204*
205* Compute the Cholesky factorization A = U**H * U.
206*
207 DO 10 j = 1, n
208*
209* Compute U(J,J) and test for non-positive-definiteness.
210*
211 ajj = dble( ab( kd+1, j ) )
212 IF( ajj.LE.zero ) THEN
213 ab( kd+1, j ) = ajj
214 GO TO 30
215 END IF
216 ajj = sqrt( ajj )
217 ab( kd+1, j ) = ajj
218*
219* Compute elements J+1:J+KN of row J and update the
220* trailing submatrix within the band.
221*
222 kn = min( kd, n-j )
223 IF( kn.GT.0 ) THEN
224 CALL zdscal( kn, one / ajj, ab( kd, j+1 ), kld )
225 CALL zlacgv( kn, ab( kd, j+1 ), kld )
226 CALL zher( 'Upper', kn, -one, ab( kd, j+1 ), kld,
227 $ ab( kd+1, j+1 ), kld )
228 CALL zlacgv( kn, ab( kd, j+1 ), kld )
229 END IF
230 10 CONTINUE
231 ELSE
232*
233* Compute the Cholesky factorization A = L*L**H.
234*
235 DO 20 j = 1, n
236*
237* Compute L(J,J) and test for non-positive-definiteness.
238*
239 ajj = dble( ab( 1, j ) )
240 IF( ajj.LE.zero ) THEN
241 ab( 1, j ) = ajj
242 GO TO 30
243 END IF
244 ajj = sqrt( ajj )
245 ab( 1, j ) = ajj
246*
247* Compute elements J+1:J+KN of column J and update the
248* trailing submatrix within the band.
249*
250 kn = min( kd, n-j )
251 IF( kn.GT.0 ) THEN
252 CALL zdscal( kn, one / ajj, ab( 2, j ), 1 )
253 CALL zher( 'Lower', kn, -one, ab( 2, j ), 1,
254 $ ab( 1, j+1 ), kld )
255 END IF
256 20 CONTINUE
257 END IF
258 RETURN
259*
260 30 CONTINUE
261 info = j
262 RETURN
263*
264* End of ZPBTF2
265*

◆ zpbtrf()

subroutine zpbtrf ( character uplo,
integer n,
integer kd,
complex*16, dimension( ldab, * ) ab,
integer ldab,
integer info )

ZPBTRF

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

Purpose:
!>
!> ZPBTRF computes the Cholesky factorization of a complex Hermitian
!> positive definite band matrix A.
!>
!> The factorization has the form
!>    A = U**H * U,  if UPLO = 'U', or
!>    A = L  * L**H,  if UPLO = 'L',
!> where U is an upper triangular matrix and L is lower triangular.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals 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 Hermitian 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]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the leading minor of order i is not
!>                positive definite, and the factorization could not be
!>                completed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The band storage scheme is illustrated by the following example, when
!>  N = 6, KD = 2, and UPLO = 'U':
!>
!>  On entry:                       On exit:
!>
!>      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
!>      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!>     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!>
!>  Similarly, if UPLO = 'L' the format of A is as follows:
!>
!>  On entry:                       On exit:
!>
!>     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
!>     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
!>     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
!>
!>  Array elements marked * are not used by the routine.
!>
Contributors:
Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989

Definition at line 141 of file zpbtrf.f.

142*
143* -- LAPACK computational 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 UPLO
149 INTEGER INFO, KD, LDAB, N
150* ..
151* .. Array Arguments ..
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 COMPLEX*16 CONE
161 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
162 INTEGER NBMAX, LDWORK
163 parameter( nbmax = 32, ldwork = nbmax+1 )
164* ..
165* .. Local Scalars ..
166 INTEGER I, I2, I3, IB, II, J, JJ, NB
167* ..
168* .. Local Arrays ..
169 COMPLEX*16 WORK( LDWORK, NBMAX )
170* ..
171* .. External Functions ..
172 LOGICAL LSAME
173 INTEGER ILAENV
174 EXTERNAL lsame, ilaenv
175* ..
176* .. External Subroutines ..
177 EXTERNAL xerbla, zgemm, zherk, zpbtf2, zpotf2, ztrsm
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC min
181* ..
182* .. Executable Statements ..
183*
184* Test the input parameters.
185*
186 info = 0
187 IF( ( .NOT.lsame( uplo, 'U' ) ) .AND.
188 $ ( .NOT.lsame( uplo, 'L' ) ) ) THEN
189 info = -1
190 ELSE IF( n.LT.0 ) THEN
191 info = -2
192 ELSE IF( kd.LT.0 ) THEN
193 info = -3
194 ELSE IF( ldab.LT.kd+1 ) THEN
195 info = -5
196 END IF
197 IF( info.NE.0 ) THEN
198 CALL xerbla( 'ZPBTRF', -info )
199 RETURN
200 END IF
201*
202* Quick return if possible
203*
204 IF( n.EQ.0 )
205 $ RETURN
206*
207* Determine the block size for this environment
208*
209 nb = ilaenv( 1, 'ZPBTRF', uplo, n, kd, -1, -1 )
210*
211* The block size must not exceed the semi-bandwidth KD, and must not
212* exceed the limit set by the size of the local array WORK.
213*
214 nb = min( nb, nbmax )
215*
216 IF( nb.LE.1 .OR. nb.GT.kd ) THEN
217*
218* Use unblocked code
219*
220 CALL zpbtf2( uplo, n, kd, ab, ldab, info )
221 ELSE
222*
223* Use blocked code
224*
225 IF( lsame( uplo, 'U' ) ) THEN
226*
227* Compute the Cholesky factorization of a Hermitian band
228* matrix, given the upper triangle of the matrix in band
229* storage.
230*
231* Zero the upper triangle of the work array.
232*
233 DO 20 j = 1, nb
234 DO 10 i = 1, j - 1
235 work( i, j ) = zero
236 10 CONTINUE
237 20 CONTINUE
238*
239* Process the band matrix one diagonal block at a time.
240*
241 DO 70 i = 1, n, nb
242 ib = min( nb, n-i+1 )
243*
244* Factorize the diagonal block
245*
246 CALL zpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii )
247 IF( ii.NE.0 ) THEN
248 info = i + ii - 1
249 GO TO 150
250 END IF
251 IF( i+ib.LE.n ) THEN
252*
253* Update the relevant part of the trailing submatrix.
254* If A11 denotes the diagonal block which has just been
255* factorized, then we need to update the remaining
256* blocks in the diagram:
257*
258* A11 A12 A13
259* A22 A23
260* A33
261*
262* The numbers of rows and columns in the partitioning
263* are IB, I2, I3 respectively. The blocks A12, A22 and
264* A23 are empty if IB = KD. The upper triangle of A13
265* lies outside the band.
266*
267 i2 = min( kd-ib, n-i-ib+1 )
268 i3 = min( ib, n-i-kd+1 )
269*
270 IF( i2.GT.0 ) THEN
271*
272* Update A12
273*
274 CALL ztrsm( 'Left', 'Upper', 'Conjugate transpose',
275 $ 'Non-unit', ib, i2, cone,
276 $ ab( kd+1, i ), ldab-1,
277 $ ab( kd+1-ib, i+ib ), ldab-1 )
278*
279* Update A22
280*
281 CALL zherk( 'Upper', 'Conjugate transpose', i2, ib,
282 $ -one, ab( kd+1-ib, i+ib ), ldab-1, one,
283 $ ab( kd+1, i+ib ), ldab-1 )
284 END IF
285*
286 IF( i3.GT.0 ) THEN
287*
288* Copy the lower triangle of A13 into the work array.
289*
290 DO 40 jj = 1, i3
291 DO 30 ii = jj, ib
292 work( ii, jj ) = ab( ii-jj+1, jj+i+kd-1 )
293 30 CONTINUE
294 40 CONTINUE
295*
296* Update A13 (in the work array).
297*
298 CALL ztrsm( 'Left', 'Upper', 'Conjugate transpose',
299 $ 'Non-unit', ib, i3, cone,
300 $ ab( kd+1, i ), ldab-1, work, ldwork )
301*
302* Update A23
303*
304 IF( i2.GT.0 )
305 $ CALL zgemm( 'Conjugate transpose',
306 $ 'No transpose', i2, i3, ib, -cone,
307 $ ab( kd+1-ib, i+ib ), ldab-1, work,
308 $ ldwork, cone, ab( 1+ib, i+kd ),
309 $ ldab-1 )
310*
311* Update A33
312*
313 CALL zherk( 'Upper', 'Conjugate transpose', i3, ib,
314 $ -one, work, ldwork, one,
315 $ ab( kd+1, i+kd ), ldab-1 )
316*
317* Copy the lower triangle of A13 back into place.
318*
319 DO 60 jj = 1, i3
320 DO 50 ii = jj, ib
321 ab( ii-jj+1, jj+i+kd-1 ) = work( ii, jj )
322 50 CONTINUE
323 60 CONTINUE
324 END IF
325 END IF
326 70 CONTINUE
327 ELSE
328*
329* Compute the Cholesky factorization of a Hermitian band
330* matrix, given the lower triangle of the matrix in band
331* storage.
332*
333* Zero the lower triangle of the work array.
334*
335 DO 90 j = 1, nb
336 DO 80 i = j + 1, nb
337 work( i, j ) = zero
338 80 CONTINUE
339 90 CONTINUE
340*
341* Process the band matrix one diagonal block at a time.
342*
343 DO 140 i = 1, n, nb
344 ib = min( nb, n-i+1 )
345*
346* Factorize the diagonal block
347*
348 CALL zpotf2( uplo, ib, ab( 1, i ), ldab-1, ii )
349 IF( ii.NE.0 ) THEN
350 info = i + ii - 1
351 GO TO 150
352 END IF
353 IF( i+ib.LE.n ) THEN
354*
355* Update the relevant part of the trailing submatrix.
356* If A11 denotes the diagonal block which has just been
357* factorized, then we need to update the remaining
358* blocks in the diagram:
359*
360* A11
361* A21 A22
362* A31 A32 A33
363*
364* The numbers of rows and columns in the partitioning
365* are IB, I2, I3 respectively. The blocks A21, A22 and
366* A32 are empty if IB = KD. The lower triangle of A31
367* lies outside the band.
368*
369 i2 = min( kd-ib, n-i-ib+1 )
370 i3 = min( ib, n-i-kd+1 )
371*
372 IF( i2.GT.0 ) THEN
373*
374* Update A21
375*
376 CALL ztrsm( 'Right', 'Lower',
377 $ 'Conjugate transpose', 'Non-unit', i2,
378 $ ib, cone, ab( 1, i ), ldab-1,
379 $ ab( 1+ib, i ), ldab-1 )
380*
381* Update A22
382*
383 CALL zherk( 'Lower', 'No transpose', i2, ib, -one,
384 $ ab( 1+ib, i ), ldab-1, one,
385 $ ab( 1, i+ib ), ldab-1 )
386 END IF
387*
388 IF( i3.GT.0 ) THEN
389*
390* Copy the upper triangle of A31 into the work array.
391*
392 DO 110 jj = 1, ib
393 DO 100 ii = 1, min( jj, i3 )
394 work( ii, jj ) = ab( kd+1-jj+ii, jj+i-1 )
395 100 CONTINUE
396 110 CONTINUE
397*
398* Update A31 (in the work array).
399*
400 CALL ztrsm( 'Right', 'Lower',
401 $ 'Conjugate transpose', 'Non-unit', i3,
402 $ ib, cone, ab( 1, i ), ldab-1, work,
403 $ ldwork )
404*
405* Update A32
406*
407 IF( i2.GT.0 )
408 $ CALL zgemm( 'No transpose',
409 $ 'Conjugate transpose', i3, i2, ib,
410 $ -cone, work, ldwork, ab( 1+ib, i ),
411 $ ldab-1, cone, ab( 1+kd-ib, i+ib ),
412 $ ldab-1 )
413*
414* Update A33
415*
416 CALL zherk( 'Lower', 'No transpose', i3, ib, -one,
417 $ work, ldwork, one, ab( 1, i+kd ),
418 $ ldab-1 )
419*
420* Copy the upper triangle of A31 back into place.
421*
422 DO 130 jj = 1, ib
423 DO 120 ii = 1, min( jj, i3 )
424 ab( kd+1-jj+ii, jj+i-1 ) = work( ii, jj )
425 120 CONTINUE
426 130 CONTINUE
427 END IF
428 END IF
429 140 CONTINUE
430 END IF
431 END IF
432 RETURN
433*
434 150 CONTINUE
435 RETURN
436*
437* End of ZPBTRF
438*
zpbtf2
subroutine zpbtf2(uplo, n, kd, ab, ldab, info)
ZPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (un...
Definition zpbtf2.f:142
zpotf2
subroutine zpotf2(uplo, n, a, lda, info)
ZPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblock...
Definition zpotf2.f:109
ztrsm
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180

◆ zpbtrs()

subroutine zpbtrs ( character uplo,
integer n,
integer kd,
integer nrhs,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZPBTRS

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

Purpose:
!>
!> ZPBTRS solves a system of linear equations A*X = B with a Hermitian
!> positive definite band matrix A using the Cholesky factorization
!> A = U**H *U or A = L*L**H computed by ZPBTRF.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangular factor stored in AB;
!>          = 'L':  Lower triangular factor stored in AB.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]AB
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**H *U or A = L*L**H of the band matrix A, stored in the
!>          first KD+1 rows of the array.  The j-th column of U or L is
!>          stored in the j-th column of the array AB as follows:
!>          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO ='L', AB(1+i-j,j)    = L(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]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 120 of file zpbtrs.f.

121*
122* -- LAPACK computational 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 CHARACTER UPLO
128 INTEGER INFO, KD, LDAB, LDB, N, NRHS
129* ..
130* .. Array Arguments ..
131 COMPLEX*16 AB( LDAB, * ), B( LDB, * )
132* ..
133*
134* =====================================================================
135*
136* .. Local Scalars ..
137 LOGICAL UPPER
138 INTEGER J
139* ..
140* .. External Functions ..
141 LOGICAL LSAME
142 EXTERNAL lsame
143* ..
144* .. External Subroutines ..
145 EXTERNAL xerbla, ztbsv
146* ..
147* .. Intrinsic Functions ..
148 INTRINSIC max
149* ..
150* .. Executable Statements ..
151*
152* Test the input parameters.
153*
154 info = 0
155 upper = lsame( uplo, 'U' )
156 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
157 info = -1
158 ELSE IF( n.LT.0 ) THEN
159 info = -2
160 ELSE IF( kd.LT.0 ) THEN
161 info = -3
162 ELSE IF( nrhs.LT.0 ) THEN
163 info = -4
164 ELSE IF( ldab.LT.kd+1 ) THEN
165 info = -6
166 ELSE IF( ldb.LT.max( 1, n ) ) THEN
167 info = -8
168 END IF
169 IF( info.NE.0 ) THEN
170 CALL xerbla( 'ZPBTRS', -info )
171 RETURN
172 END IF
173*
174* Quick return if possible
175*
176 IF( n.EQ.0 .OR. nrhs.EQ.0 )
177 $ RETURN
178*
179 IF( upper ) THEN
180*
181* Solve A*X = B where A = U**H *U.
182*
183 DO 10 j = 1, nrhs
184*
185* Solve U**H *X = B, overwriting B with X.
186*
187 CALL ztbsv( 'Upper', 'Conjugate transpose', 'Non-unit', n,
188 $ kd, ab, ldab, b( 1, j ), 1 )
189*
190* Solve U*X = B, overwriting B with X.
191*
192 CALL ztbsv( 'Upper', 'No transpose', 'Non-unit', n, kd, ab,
193 $ ldab, b( 1, j ), 1 )
194 10 CONTINUE
195 ELSE
196*
197* Solve A*X = B where A = L*L**H.
198*
199 DO 20 j = 1, nrhs
200*
201* Solve L*X = B, overwriting B with X.
202*
203 CALL ztbsv( 'Lower', 'No transpose', 'Non-unit', n, kd, ab,
204 $ ldab, b( 1, j ), 1 )
205*
206* Solve L**H *X = B, overwriting B with X.
207*
208 CALL ztbsv( 'Lower', 'Conjugate transpose', 'Non-unit', n,
209 $ kd, ab, ldab, b( 1, j ), 1 )
210 20 CONTINUE
211 END IF
212*
213 RETURN
214*
215* End of ZPBTRS
216*
ztbsv
subroutine ztbsv(uplo, trans, diag, n, k, a, lda, x, incx)
ZTBSV
Definition ztbsv.f:189

◆ zpftrf()

subroutine zpftrf ( character transr,
character uplo,
integer n,
complex*16, dimension( 0: * ) a,
integer info )

ZPFTRF

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

Purpose:
!>
!> ZPFTRF computes the Cholesky factorization of a complex Hermitian
!> positive definite matrix A.
!>
!> The factorization has the form
!>    A = U**H * U,  if UPLO = 'U', or
!>    A = L  * L**H,  if UPLO = 'L',
!> where U is an upper triangular matrix and L is lower triangular.
!>
!> This is the block version of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  The Normal TRANSR of RFP A is stored;
!>          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of RFP A is stored;
!>          = 'L':  Lower triangle of RFP A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension ( N*(N+1)/2 );
!>          On entry, the Hermitian matrix A in RFP format. RFP format is
!>          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'
!>          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is
!>          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is
!>          the Conjugate-transpose of RFP A as defined when
!>          TRANSR = 'N'. The contents of RFP A are defined by UPLO as
!>          follows: If UPLO = 'U' the RFP A contains the nt elements of
!>          upper packed A. If UPLO = 'L' the RFP A contains the elements
!>          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =
!>          'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N
!>          is odd. See the Note below for more details.
!>
!>          On exit, if INFO = 0, the factor U or L from the Cholesky
!>          factorization RFP A = U**H*U or RFP A = L*L**H.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the leading minor of order i is not
!>                positive definite, and the factorization could not be
!>                completed.
!>
!>  Further Notes on RFP Format:
!>  ============================
!>
!>  We first consider Standard Packed Format when N is even.
!>  We give an example where N = 6.
!>
!>     AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  conjugate-transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  conjugate-transpose of the last three columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                -- -- --
!>        03 04 05                33 43 53
!>                                   -- --
!>        13 14 15                00 44 54
!>                                      --
!>        23 24 25                10 11 55
!>
!>        33 34 35                20 21 22
!>        --
!>        00 44 45                30 31 32
!>        -- --
!>        01 11 55                40 41 42
!>        -- -- --
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>           RFP A                   RFP A
!>
!>     -- -- -- --                -- -- -- -- -- --
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     -- -- -- -- --                -- -- -- -- --
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     -- -- -- -- -- --                -- -- -- --
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>  We next  consider Standard Packed Format when N is odd.
!>  We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  conjugate-transpose of the first two   columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  conjugate-transpose of the last two   columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N odd  and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                   -- --
!>        02 03 04                00 33 43
!>                                      --
!>        12 13 14                10 11 44
!>
!>        22 23 24                20 21 22
!>        --
!>        00 33 34                30 31 32
!>        -- --
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>           RFP A                   RFP A
!>
!>     -- -- --                   -- -- -- -- -- --
!>     02 12 22 00 01             00 10 20 30 40 50
!>     -- -- -- --                   -- -- -- -- --
!>     03 13 23 33 11             33 11 21 31 41 51
!>     -- -- -- -- --                   -- -- -- --
!>     04 14 24 34 44             43 44 22 32 42 52
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 210 of file zpftrf.f.

211*
212* -- LAPACK computational routine --
213* -- LAPACK is a software package provided by Univ. of Tennessee, --
214* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
215*
216* .. Scalar Arguments ..
217 CHARACTER TRANSR, UPLO
218 INTEGER N, INFO
219* ..
220* .. Array Arguments ..
221 COMPLEX*16 A( 0: * )
222*
223* =====================================================================
224*
225* .. Parameters ..
226 DOUBLE PRECISION ONE
227 COMPLEX*16 CONE
228 parameter( one = 1.0d+0, cone = ( 1.0d+0, 0.0d+0 ) )
229* ..
230* .. Local Scalars ..
231 LOGICAL LOWER, NISODD, NORMALTRANSR
232 INTEGER N1, N2, K
233* ..
234* .. External Functions ..
235 LOGICAL LSAME
236 EXTERNAL lsame
237* ..
238* .. External Subroutines ..
239 EXTERNAL xerbla, zherk, zpotrf, ztrsm
240* ..
241* .. Intrinsic Functions ..
242 INTRINSIC mod
243* ..
244* .. Executable Statements ..
245*
246* Test the input parameters.
247*
248 info = 0
249 normaltransr = lsame( transr, 'N' )
250 lower = lsame( uplo, 'L' )
251 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
252 info = -1
253 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
254 info = -2
255 ELSE IF( n.LT.0 ) THEN
256 info = -3
257 END IF
258 IF( info.NE.0 ) THEN
259 CALL xerbla( 'ZPFTRF', -info )
260 RETURN
261 END IF
262*
263* Quick return if possible
264*
265 IF( n.EQ.0 )
266 $ RETURN
267*
268* If N is odd, set NISODD = .TRUE.
269* If N is even, set K = N/2 and NISODD = .FALSE.
270*
271 IF( mod( n, 2 ).EQ.0 ) THEN
272 k = n / 2
273 nisodd = .false.
274 ELSE
275 nisodd = .true.
276 END IF
277*
278* Set N1 and N2 depending on LOWER
279*
280 IF( lower ) THEN
281 n2 = n / 2
282 n1 = n - n2
283 ELSE
284 n1 = n / 2
285 n2 = n - n1
286 END IF
287*
288* start execution: there are eight cases
289*
290 IF( nisodd ) THEN
291*
292* N is odd
293*
294 IF( normaltransr ) THEN
295*
296* N is odd and TRANSR = 'N'
297*
298 IF( lower ) THEN
299*
300* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) )
301* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0)
302* T1 -> a(0), T2 -> a(n), S -> a(n1)
303*
304 CALL zpotrf( 'L', n1, a( 0 ), n, info )
305 IF( info.GT.0 )
306 $ RETURN
307 CALL ztrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0 ), n,
308 $ a( n1 ), n )
309 CALL zherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,
310 $ a( n ), n )
311 CALL zpotrf( 'U', n2, a( n ), n, info )
312 IF( info.GT.0 )
313 $ info = info + n1
314*
315 ELSE
316*
317* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1)
318* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0)
319* T1 -> a(n2), T2 -> a(n1), S -> a(0)
320*
321 CALL zpotrf( 'L', n1, a( n2 ), n, info )
322 IF( info.GT.0 )
323 $ RETURN
324 CALL ztrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,
325 $ a( 0 ), n )
326 CALL zherk( 'U', 'C', n2, n1, -one, a( 0 ), n, one,
327 $ a( n1 ), n )
328 CALL zpotrf( 'U', n2, a( n1 ), n, info )
329 IF( info.GT.0 )
330 $ info = info + n1
331*
332 END IF
333*
334 ELSE
335*
336* N is odd and TRANSR = 'C'
337*
338 IF( lower ) THEN
339*
340* SRPA for LOWER, TRANSPOSE and N is odd
341* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1)
342* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1
343*
344 CALL zpotrf( 'U', n1, a( 0 ), n1, info )
345 IF( info.GT.0 )
346 $ RETURN
347 CALL ztrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0 ), n1,
348 $ a( n1*n1 ), n1 )
349 CALL zherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,
350 $ a( 1 ), n1 )
351 CALL zpotrf( 'L', n2, a( 1 ), n1, info )
352 IF( info.GT.0 )
353 $ info = info + n1
354*
355 ELSE
356*
357* SRPA for UPPER, TRANSPOSE and N is odd
358* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0)
359* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2
360*
361 CALL zpotrf( 'U', n1, a( n2*n2 ), n2, info )
362 IF( info.GT.0 )
363 $ RETURN
364 CALL ztrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),
365 $ n2, a( 0 ), n2 )
366 CALL zherk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,
367 $ a( n1*n2 ), n2 )
368 CALL zpotrf( 'L', n2, a( n1*n2 ), n2, info )
369 IF( info.GT.0 )
370 $ info = info + n1
371*
372 END IF
373*
374 END IF
375*
376 ELSE
377*
378* N is even
379*
380 IF( normaltransr ) THEN
381*
382* N is even and TRANSR = 'N'
383*
384 IF( lower ) THEN
385*
386* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) )
387* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0)
388* T1 -> a(1), T2 -> a(0), S -> a(k+1)
389*
390 CALL zpotrf( 'L', k, a( 1 ), n+1, info )
391 IF( info.GT.0 )
392 $ RETURN
393 CALL ztrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1 ), n+1,
394 $ a( k+1 ), n+1 )
395 CALL zherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,
396 $ a( 0 ), n+1 )
397 CALL zpotrf( 'U', k, a( 0 ), n+1, info )
398 IF( info.GT.0 )
399 $ info = info + k
400*
401 ELSE
402*
403* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) )
404* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0)
405* T1 -> a(k+1), T2 -> a(k), S -> a(0)
406*
407 CALL zpotrf( 'L', k, a( k+1 ), n+1, info )
408 IF( info.GT.0 )
409 $ RETURN
410 CALL ztrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),
411 $ n+1, a( 0 ), n+1 )
412 CALL zherk( 'U', 'C', k, k, -one, a( 0 ), n+1, one,
413 $ a( k ), n+1 )
414 CALL zpotrf( 'U', k, a( k ), n+1, info )
415 IF( info.GT.0 )
416 $ info = info + k
417*
418 END IF
419*
420 ELSE
421*
422* N is even and TRANSR = 'C'
423*
424 IF( lower ) THEN
425*
426* SRPA for LOWER, TRANSPOSE and N is even (see paper)
427* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1)
428* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k
429*
430 CALL zpotrf( 'U', k, a( 0+k ), k, info )
431 IF( info.GT.0 )
432 $ RETURN
433 CALL ztrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,
434 $ a( k*( k+1 ) ), k )
435 CALL zherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,
436 $ a( 0 ), k )
437 CALL zpotrf( 'L', k, a( 0 ), k, info )
438 IF( info.GT.0 )
439 $ info = info + k
440*
441 ELSE
442*
443* SRPA for UPPER, TRANSPOSE and N is even (see paper)
444* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0)
445* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k
446*
447 CALL zpotrf( 'U', k, a( k*( k+1 ) ), k, info )
448 IF( info.GT.0 )
449 $ RETURN
450 CALL ztrsm( 'R', 'U', 'N', 'N', k, k, cone,
451 $ a( k*( k+1 ) ), k, a( 0 ), k )
452 CALL zherk( 'L', 'N', k, k, -one, a( 0 ), k, one,
453 $ a( k*k ), k )
454 CALL zpotrf( 'L', k, a( k*k ), k, info )
455 IF( info.GT.0 )
456 $ info = info + k
457*
458 END IF
459*
460 END IF
461*
462 END IF
463*
464 RETURN
465*
466* End of ZPFTRF
467*
zpotrf
subroutine zpotrf(uplo, n, a, lda, info)
ZPOTRF VARIANT: right looking block version of the algorithm, calling Level 3 BLAS.
Definition zpotrf.f:102

◆ zpftri()

subroutine zpftri ( character transr,
character uplo,
integer n,
complex*16, dimension( 0: * ) a,
integer info )

ZPFTRI

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

Purpose:
!>
!> ZPFTRI computes the inverse of a complex Hermitian positive definite
!> matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!> computed by ZPFTRF.
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  The Normal TRANSR of RFP A is stored;
!>          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension ( N*(N+1)/2 );
!>          On entry, the Hermitian matrix A in RFP format. RFP format is
!>          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'
!>          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is
!>          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is
!>          the Conjugate-transpose of RFP A as defined when
!>          TRANSR = 'N'. The contents of RFP A are defined by UPLO as
!>          follows: If UPLO = 'U' the RFP A contains the nt elements of
!>          upper packed A. If UPLO = 'L' the RFP A contains the elements
!>          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =
!>          'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N
!>          is odd. See the Note below for more details.
!>
!>          On exit, the Hermitian inverse of the original matrix, in the
!>          same storage format.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the (i,i) element of the factor U or L is
!>                zero, and the inverse could not be computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  We first consider Standard Packed Format when N is even.
!>  We give an example where N = 6.
!>
!>      AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  conjugate-transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  conjugate-transpose of the last three columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                -- -- --
!>        03 04 05                33 43 53
!>                                   -- --
!>        13 14 15                00 44 54
!>                                      --
!>        23 24 25                10 11 55
!>
!>        33 34 35                20 21 22
!>        --
!>        00 44 45                30 31 32
!>        -- --
!>        01 11 55                40 41 42
!>        -- -- --
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- -- --                -- -- -- -- -- --
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     -- -- -- -- --                -- -- -- -- --
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     -- -- -- -- -- --                -- -- -- --
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>
!>  We next  consider Standard Packed Format when N is odd.
!>  We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  conjugate-transpose of the first two   columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  conjugate-transpose of the last two   columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N odd  and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                   -- --
!>        02 03 04                00 33 43
!>                                      --
!>        12 13 14                10 11 44
!>
!>        22 23 24                20 21 22
!>        --
!>        00 33 34                30 31 32
!>        -- --
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- --                   -- -- -- -- -- --
!>     02 12 22 00 01             00 10 20 30 40 50
!>     -- -- -- --                   -- -- -- -- --
!>     03 13 23 33 11             33 11 21 31 41 51
!>     -- -- -- -- --                   -- -- -- --
!>     04 14 24 34 44             43 44 22 32 42 52
!>

Definition at line 211 of file zpftri.f.

212*
213* -- LAPACK computational routine --
214* -- LAPACK is a software package provided by Univ. of Tennessee, --
215* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
216*
217* .. Scalar Arguments ..
218 CHARACTER TRANSR, UPLO
219 INTEGER INFO, N
220* .. Array Arguments ..
221 COMPLEX*16 A( 0: * )
222* ..
223*
224* =====================================================================
225*
226* .. Parameters ..
227 DOUBLE PRECISION ONE
228 COMPLEX*16 CONE
229 parameter( one = 1.d0, cone = ( 1.d0, 0.d0 ) )
230* ..
231* .. Local Scalars ..
232 LOGICAL LOWER, NISODD, NORMALTRANSR
233 INTEGER N1, N2, K
234* ..
235* .. External Functions ..
236 LOGICAL LSAME
237 EXTERNAL lsame
238* ..
239* .. External Subroutines ..
240 EXTERNAL xerbla, ztftri, zlauum, ztrmm, zherk
241* ..
242* .. Intrinsic Functions ..
243 INTRINSIC mod
244* ..
245* .. Executable Statements ..
246*
247* Test the input parameters.
248*
249 info = 0
250 normaltransr = lsame( transr, 'N' )
251 lower = lsame( uplo, 'L' )
252 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
253 info = -1
254 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
255 info = -2
256 ELSE IF( n.LT.0 ) THEN
257 info = -3
258 END IF
259 IF( info.NE.0 ) THEN
260 CALL xerbla( 'ZPFTRI', -info )
261 RETURN
262 END IF
263*
264* Quick return if possible
265*
266 IF( n.EQ.0 )
267 $ RETURN
268*
269* Invert the triangular Cholesky factor U or L.
270*
271 CALL ztftri( transr, uplo, 'N', n, a, info )
272 IF( info.GT.0 )
273 $ RETURN
274*
275* If N is odd, set NISODD = .TRUE.
276* If N is even, set K = N/2 and NISODD = .FALSE.
277*
278 IF( mod( n, 2 ).EQ.0 ) THEN
279 k = n / 2
280 nisodd = .false.
281 ELSE
282 nisodd = .true.
283 END IF
284*
285* Set N1 and N2 depending on LOWER
286*
287 IF( lower ) THEN
288 n2 = n / 2
289 n1 = n - n2
290 ELSE
291 n1 = n / 2
292 n2 = n - n1
293 END IF
294*
295* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or
296* inv(L)^C*inv(L). There are eight cases.
297*
298 IF( nisodd ) THEN
299*
300* N is odd
301*
302 IF( normaltransr ) THEN
303*
304* N is odd and TRANSR = 'N'
305*
306 IF( lower ) THEN
307*
308* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) )
309* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0)
310* T1 -> a(0), T2 -> a(n), S -> a(N1)
311*
312 CALL zlauum( 'L', n1, a( 0 ), n, info )
313 CALL zherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,
314 $ a( 0 ), n )
315 CALL ztrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,
316 $ a( n1 ), n )
317 CALL zlauum( 'U', n2, a( n ), n, info )
318*
319 ELSE
320*
321* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1)
322* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0)
323* T1 -> a(N2), T2 -> a(N1), S -> a(0)
324*
325 CALL zlauum( 'L', n1, a( n2 ), n, info )
326 CALL zherk( 'L', 'N', n1, n2, one, a( 0 ), n, one,
327 $ a( n2 ), n )
328 CALL ztrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,
329 $ a( 0 ), n )
330 CALL zlauum( 'U', n2, a( n1 ), n, info )
331*
332 END IF
333*
334 ELSE
335*
336* N is odd and TRANSR = 'C'
337*
338 IF( lower ) THEN
339*
340* SRPA for LOWER, TRANSPOSE, and N is odd
341* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1)
342*
343 CALL zlauum( 'U', n1, a( 0 ), n1, info )
344 CALL zherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,
345 $ a( 0 ), n1 )
346 CALL ztrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1 ), n1,
347 $ a( n1*n1 ), n1 )
348 CALL zlauum( 'L', n2, a( 1 ), n1, info )
349*
350 ELSE
351*
352* SRPA for UPPER, TRANSPOSE, and N is odd
353* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0)
354*
355 CALL zlauum( 'U', n1, a( n2*n2 ), n2, info )
356 CALL zherk( 'U', 'C', n1, n2, one, a( 0 ), n2, one,
357 $ a( n2*n2 ), n2 )
358 CALL ztrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),
359 $ n2, a( 0 ), n2 )
360 CALL zlauum( 'L', n2, a( n1*n2 ), n2, info )
361*
362 END IF
363*
364 END IF
365*
366 ELSE
367*
368* N is even
369*
370 IF( normaltransr ) THEN
371*
372* N is even and TRANSR = 'N'
373*
374 IF( lower ) THEN
375*
376* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) )
377* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0)
378* T1 -> a(1), T2 -> a(0), S -> a(k+1)
379*
380 CALL zlauum( 'L', k, a( 1 ), n+1, info )
381 CALL zherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,
382 $ a( 1 ), n+1 )
383 CALL ztrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0 ), n+1,
384 $ a( k+1 ), n+1 )
385 CALL zlauum( 'U', k, a( 0 ), n+1, info )
386*
387 ELSE
388*
389* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) )
390* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0)
391* T1 -> a(k+1), T2 -> a(k), S -> a(0)
392*
393 CALL zlauum( 'L', k, a( k+1 ), n+1, info )
394 CALL zherk( 'L', 'N', k, k, one, a( 0 ), n+1, one,
395 $ a( k+1 ), n+1 )
396 CALL ztrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,
397 $ a( 0 ), n+1 )
398 CALL zlauum( 'U', k, a( k ), n+1, info )
399*
400 END IF
401*
402 ELSE
403*
404* N is even and TRANSR = 'C'
405*
406 IF( lower ) THEN
407*
408* SRPA for LOWER, TRANSPOSE, and N is even (see paper)
409* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1),
410* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k
411*
412 CALL zlauum( 'U', k, a( k ), k, info )
413 CALL zherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,
414 $ a( k ), k )
415 CALL ztrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0 ), k,
416 $ a( k*( k+1 ) ), k )
417 CALL zlauum( 'L', k, a( 0 ), k, info )
418*
419 ELSE
420*
421* SRPA for UPPER, TRANSPOSE, and N is even (see paper)
422* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0),
423* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k
424*
425 CALL zlauum( 'U', k, a( k*( k+1 ) ), k, info )
426 CALL zherk( 'U', 'C', k, k, one, a( 0 ), k, one,
427 $ a( k*( k+1 ) ), k )
428 CALL ztrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,
429 $ a( 0 ), k )
430 CALL zlauum( 'L', k, a( k*k ), k, info )
431*
432 END IF
433*
434 END IF
435*
436 END IF
437*
438 RETURN
439*
440* End of ZPFTRI
441*
zlauum
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...
Definition zlauum.f:102
ztftri
subroutine ztftri(transr, uplo, diag, n, a, info)
ZTFTRI
Definition ztftri.f:221

◆ zpftrs()

subroutine zpftrs ( character transr,
character uplo,
integer n,
integer nrhs,
complex*16, dimension( 0: * ) a,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZPFTRS

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

Purpose:
!>
!> ZPFTRS solves a system of linear equations A*X = B with a Hermitian
!> positive definite matrix A using the Cholesky factorization
!> A = U**H*U or A = L*L**H computed by ZPFTRF.
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  The Normal TRANSR of RFP A is stored;
!>          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of RFP A is stored;
!>          = 'L':  Lower triangle of RFP A is stored.
!>
[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 matrix B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension ( N*(N+1)/2 );
!>          The triangular factor U or L from the Cholesky factorization
!>          of RFP A = U**H*U or RFP A = L*L**H, as computed by ZPFTRF.
!>          See note below for more details about RFP A.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  We first consider Standard Packed Format when N is even.
!>  We give an example where N = 6.
!>
!>      AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  conjugate-transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  conjugate-transpose of the last three columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                -- -- --
!>        03 04 05                33 43 53
!>                                   -- --
!>        13 14 15                00 44 54
!>                                      --
!>        23 24 25                10 11 55
!>
!>        33 34 35                20 21 22
!>        --
!>        00 44 45                30 31 32
!>        -- --
!>        01 11 55                40 41 42
!>        -- -- --
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- -- --                -- -- -- -- -- --
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     -- -- -- -- --                -- -- -- -- --
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     -- -- -- -- -- --                -- -- -- --
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>
!>  We next  consider Standard Packed Format when N is odd.
!>  We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  conjugate-transpose of the first two   columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  conjugate-transpose of the last two   columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N odd  and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                   -- --
!>        02 03 04                00 33 43
!>                                      --
!>        12 13 14                10 11 44
!>
!>        22 23 24                20 21 22
!>        --
!>        00 33 34                30 31 32
!>        -- --
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- --                   -- -- -- -- -- --
!>     02 12 22 00 01             00 10 20 30 40 50
!>     -- -- -- --                   -- -- -- -- --
!>     03 13 23 33 11             33 11 21 31 41 51
!>     -- -- -- -- --                   -- -- -- --
!>     04 14 24 34 44             43 44 22 32 42 52
!>

Definition at line 219 of file zpftrs.f.

220*
221* -- LAPACK computational routine --
222* -- LAPACK is a software package provided by Univ. of Tennessee, --
223* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
224*
225* .. Scalar Arguments ..
226 CHARACTER TRANSR, UPLO
227 INTEGER INFO, LDB, N, NRHS
228* ..
229* .. Array Arguments ..
230 COMPLEX*16 A( 0: * ), B( LDB, * )
231* ..
232*
233* =====================================================================
234*
235* .. Parameters ..
236 COMPLEX*16 CONE
237 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
238* ..
239* .. Local Scalars ..
240 LOGICAL LOWER, NORMALTRANSR
241* ..
242* .. External Functions ..
243 LOGICAL LSAME
244 EXTERNAL lsame
245* ..
246* .. External Subroutines ..
247 EXTERNAL xerbla, ztfsm
248* ..
249* .. Intrinsic Functions ..
250 INTRINSIC max
251* ..
252* .. Executable Statements ..
253*
254* Test the input parameters.
255*
256 info = 0
257 normaltransr = lsame( transr, 'N' )
258 lower = lsame( uplo, 'L' )
259 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
260 info = -1
261 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
262 info = -2
263 ELSE IF( n.LT.0 ) THEN
264 info = -3
265 ELSE IF( nrhs.LT.0 ) THEN
266 info = -4
267 ELSE IF( ldb.LT.max( 1, n ) ) THEN
268 info = -7
269 END IF
270 IF( info.NE.0 ) THEN
271 CALL xerbla( 'ZPFTRS', -info )
272 RETURN
273 END IF
274*
275* Quick return if possible
276*
277 IF( n.EQ.0 .OR. nrhs.EQ.0 )
278 $ RETURN
279*
280* start execution: there are two triangular solves
281*
282 IF( lower ) THEN
283 CALL ztfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,
284 $ ldb )
285 CALL ztfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,
286 $ ldb )
287 ELSE
288 CALL ztfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,
289 $ ldb )
290 CALL ztfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,
291 $ ldb )
292 END IF
293*
294 RETURN
295*
296* End of ZPFTRS
297*
ztfsm
subroutine ztfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
ZTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition ztfsm.f:298

◆ zppcon()

subroutine zppcon ( character uplo,
integer n,
complex*16, dimension( * ) ap,
double precision anorm,
double precision rcond,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZPPCON

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

Purpose:
!>
!> ZPPCON estimates the reciprocal of the condition number (in the
!> 1-norm) of a complex Hermitian positive definite packed matrix using
!> the Cholesky factorization A = U**H*U or A = L*L**H computed by
!> ZPPTRF.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[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 triangular factor U or L from the Cholesky factorization
!>          A = U**H*U or A = L*L**H, packed columnwise in a linear
!>          array.  The j-th column of U or L is stored in the array AP
!>          as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
!>
[in]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The 1-norm (or infinity-norm) of the Hermitian matrix A.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file zppcon.f.

118*
119* -- LAPACK computational routine --
120* -- LAPACK is a software package provided by Univ. of Tennessee, --
121* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
122*
123* .. Scalar Arguments ..
124 CHARACTER UPLO
125 INTEGER INFO, N
126 DOUBLE PRECISION ANORM, RCOND
127* ..
128* .. Array Arguments ..
129 DOUBLE PRECISION RWORK( * )
130 COMPLEX*16 AP( * ), WORK( * )
131* ..
132*
133* =====================================================================
134*
135* .. Parameters ..
136 DOUBLE PRECISION ONE, ZERO
137 parameter( one = 1.0d+0, zero = 0.0d+0 )
138* ..
139* .. Local Scalars ..
140 LOGICAL UPPER
141 CHARACTER NORMIN
142 INTEGER IX, KASE
143 DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
144 COMPLEX*16 ZDUM
145* ..
146* .. Local Arrays ..
147 INTEGER ISAVE( 3 )
148* ..
149* .. External Functions ..
150 LOGICAL LSAME
151 INTEGER IZAMAX
152 DOUBLE PRECISION DLAMCH
153 EXTERNAL lsame, izamax, dlamch
154* ..
155* .. External Subroutines ..
156 EXTERNAL xerbla, zdrscl, zlacn2, zlatps
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC abs, dble, dimag
160* ..
161* .. Statement Functions ..
162 DOUBLE PRECISION CABS1
163* ..
164* .. Statement Function definitions ..
165 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
166* ..
167* .. Executable Statements ..
168*
169* Test the input parameters.
170*
171 info = 0
172 upper = lsame( uplo, 'U' )
173 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
174 info = -1
175 ELSE IF( n.LT.0 ) THEN
176 info = -2
177 ELSE IF( anorm.LT.zero ) THEN
178 info = -4
179 END IF
180 IF( info.NE.0 ) THEN
181 CALL xerbla( 'ZPPCON', -info )
182 RETURN
183 END IF
184*
185* Quick return if possible
186*
187 rcond = zero
188 IF( n.EQ.0 ) THEN
189 rcond = one
190 RETURN
191 ELSE IF( anorm.EQ.zero ) THEN
192 RETURN
193 END IF
194*
195 smlnum = dlamch( 'Safe minimum' )
196*
197* Estimate the 1-norm of the inverse.
198*
199 kase = 0
200 normin = 'N'
201 10 CONTINUE
202 CALL zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
203 IF( kase.NE.0 ) THEN
204 IF( upper ) THEN
205*
206* Multiply by inv(U**H).
207*
208 CALL zlatps( 'Upper', 'Conjugate transpose', 'Non-unit',
209 $ normin, n, ap, work, scalel, rwork, info )
210 normin = 'Y'
211*
212* Multiply by inv(U).
213*
214 CALL zlatps( 'Upper', 'No transpose', 'Non-unit', normin, n,
215 $ ap, work, scaleu, rwork, info )
216 ELSE
217*
218* Multiply by inv(L).
219*
220 CALL zlatps( 'Lower', 'No transpose', 'Non-unit', normin, n,
221 $ ap, work, scalel, rwork, info )
222 normin = 'Y'
223*
224* Multiply by inv(L**H).
225*
226 CALL zlatps( 'Lower', 'Conjugate transpose', 'Non-unit',
227 $ normin, n, ap, work, scaleu, rwork, info )
228 END IF
229*
230* Multiply by 1/SCALE if doing so will not cause overflow.
231*
232 scale = scalel*scaleu
233 IF( scale.NE.one ) THEN
234 ix = izamax( n, work, 1 )
235 IF( scale.LT.cabs1( work( ix ) )*smlnum .OR. scale.EQ.zero )
236 $ GO TO 20
237 CALL zdrscl( n, scale, work, 1 )
238 END IF
239 GO TO 10
240 END IF
241*
242* Compute the estimate of the reciprocal condition number.
243*
244 IF( ainvnm.NE.zero )
245 $ rcond = ( one / ainvnm ) / anorm
246*
247 20 CONTINUE
248 RETURN
249*
250* End of ZPPCON
251*
zlatps
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.
Definition zlatps.f:231

◆ zppequ()

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

ZPPEQU

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

Purpose:
!>
!> ZPPEQU computes row and column scalings intended to equilibrate a
!> Hermitian positive definite matrix A in packed storage and reduce
!> its condition number (with respect to the two-norm).  S contains the
!> scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
!> B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
!> This choice of S puts the condition number of B within a factor N of
!> the smallest possible condition number over all possible diagonal
!> scalings.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[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 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.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (N)
!>          If INFO = 0, S contains the scale factors for A.
!>
[out]SCOND
!>          SCOND is DOUBLE PRECISION
!>          If INFO = 0, S contains the ratio of the smallest S(i) to
!>          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
!>          large nor too small, it is not worth scaling by S.
!>
[out]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix element.  If AMAX is very
!>          close to overflow or very close to underflow, the matrix
!>          should be scaled.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 116 of file zppequ.f.

117*
118* -- LAPACK computational routine --
119* -- LAPACK is a software package provided by Univ. of Tennessee, --
120* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
121*
122* .. Scalar Arguments ..
123 CHARACTER UPLO
124 INTEGER INFO, N
125 DOUBLE PRECISION AMAX, SCOND
126* ..
127* .. Array Arguments ..
128 DOUBLE PRECISION S( * )
129 COMPLEX*16 AP( * )
130* ..
131*
132* =====================================================================
133*
134* .. Parameters ..
135 DOUBLE PRECISION ONE, ZERO
136 parameter( one = 1.0d+0, zero = 0.0d+0 )
137* ..
138* .. Local Scalars ..
139 LOGICAL UPPER
140 INTEGER I, JJ
141 DOUBLE PRECISION SMIN
142* ..
143* .. External Functions ..
144 LOGICAL LSAME
145 EXTERNAL lsame
146* ..
147* .. External Subroutines ..
148 EXTERNAL xerbla
149* ..
150* .. Intrinsic Functions ..
151 INTRINSIC dble, max, min, sqrt
152* ..
153* .. Executable Statements ..
154*
155* Test the input parameters.
156*
157 info = 0
158 upper = lsame( uplo, 'U' )
159 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
160 info = -1
161 ELSE IF( n.LT.0 ) THEN
162 info = -2
163 END IF
164 IF( info.NE.0 ) THEN
165 CALL xerbla( 'ZPPEQU', -info )
166 RETURN
167 END IF
168*
169* Quick return if possible
170*
171 IF( n.EQ.0 ) THEN
172 scond = one
173 amax = zero
174 RETURN
175 END IF
176*
177* Initialize SMIN and AMAX.
178*
179 s( 1 ) = dble( ap( 1 ) )
180 smin = s( 1 )
181 amax = s( 1 )
182*
183 IF( upper ) THEN
184*
185* UPLO = 'U': Upper triangle of A is stored.
186* Find the minimum and maximum diagonal elements.
187*
188 jj = 1
189 DO 10 i = 2, n
190 jj = jj + i
191 s( i ) = dble( ap( jj ) )
192 smin = min( smin, s( i ) )
193 amax = max( amax, s( i ) )
194 10 CONTINUE
195*
196 ELSE
197*
198* UPLO = 'L': Lower triangle of A is stored.
199* Find the minimum and maximum diagonal elements.
200*
201 jj = 1
202 DO 20 i = 2, n
203 jj = jj + n - i + 2
204 s( i ) = dble( ap( jj ) )
205 smin = min( smin, s( i ) )
206 amax = max( amax, s( i ) )
207 20 CONTINUE
208 END IF
209*
210 IF( smin.LE.zero ) THEN
211*
212* Find the first non-positive diagonal element and return.
213*
214 DO 30 i = 1, n
215 IF( s( i ).LE.zero ) THEN
216 info = i
217 RETURN
218 END IF
219 30 CONTINUE
220 ELSE
221*
222* Set the scale factors to the reciprocals
223* of the diagonal elements.
224*
225 DO 40 i = 1, n
226 s( i ) = one / sqrt( s( i ) )
227 40 CONTINUE
228*
229* Compute SCOND = min(S(I)) / max(S(I))
230*
231 scond = sqrt( smin ) / sqrt( amax )
232 END IF
233 RETURN
234*
235* End of ZPPEQU
236*

◆ zpprfs()

subroutine zpprfs ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) afp,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZPPRFS

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

Purpose:
!>
!> ZPPRFS improves the computed solution to a system of linear
!> equations when the coefficient matrix is Hermitian positive definite
!> and packed, and provides error bounds and backward error estimates
!> for the solution.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[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 B and X.  NRHS >= 0.
!>
[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.
!>
[in]AFP
!>          AFP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF,
!>          packed columnwise in a linear array in the same format as A
!>          (see AP).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by ZPPTRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Internal Parameters:
!>  ITMAX is the maximum number of steps of iterative refinement.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file zpprfs.f.

171*
172* -- LAPACK computational routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 CHARACTER UPLO
178 INTEGER INFO, LDB, LDX, N, NRHS
179* ..
180* .. Array Arguments ..
181 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
182 COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
183 $ X( LDX, * )
184* ..
185*
186* ====================================================================
187*
188* .. Parameters ..
189 INTEGER ITMAX
190 parameter( itmax = 5 )
191 DOUBLE PRECISION ZERO
192 parameter( zero = 0.0d+0 )
193 COMPLEX*16 CONE
194 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
195 DOUBLE PRECISION TWO
196 parameter( two = 2.0d+0 )
197 DOUBLE PRECISION THREE
198 parameter( three = 3.0d+0 )
199* ..
200* .. Local Scalars ..
201 LOGICAL UPPER
202 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
203 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
204 COMPLEX*16 ZDUM
205* ..
206* .. Local Arrays ..
207 INTEGER ISAVE( 3 )
208* ..
209* .. External Subroutines ..
210 EXTERNAL xerbla, zaxpy, zcopy, zhpmv, zlacn2, zpptrs
211* ..
212* .. Intrinsic Functions ..
213 INTRINSIC abs, dble, dimag, max
214* ..
215* .. External Functions ..
216 LOGICAL LSAME
217 DOUBLE PRECISION DLAMCH
218 EXTERNAL lsame, dlamch
219* ..
220* .. Statement Functions ..
221 DOUBLE PRECISION CABS1
222* ..
223* .. Statement Function definitions ..
224 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
225* ..
226* .. Executable Statements ..
227*
228* Test the input parameters.
229*
230 info = 0
231 upper = lsame( uplo, 'U' )
232 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
233 info = -1
234 ELSE IF( n.LT.0 ) THEN
235 info = -2
236 ELSE IF( nrhs.LT.0 ) THEN
237 info = -3
238 ELSE IF( ldb.LT.max( 1, n ) ) THEN
239 info = -7
240 ELSE IF( ldx.LT.max( 1, n ) ) THEN
241 info = -9
242 END IF
243 IF( info.NE.0 ) THEN
244 CALL xerbla( 'ZPPRFS', -info )
245 RETURN
246 END IF
247*
248* Quick return if possible
249*
250 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
251 DO 10 j = 1, nrhs
252 ferr( j ) = zero
253 berr( j ) = zero
254 10 CONTINUE
255 RETURN
256 END IF
257*
258* NZ = maximum number of nonzero elements in each row of A, plus 1
259*
260 nz = n + 1
261 eps = dlamch( 'Epsilon' )
262 safmin = dlamch( 'Safe minimum' )
263 safe1 = nz*safmin
264 safe2 = safe1 / eps
265*
266* Do for each right hand side
267*
268 DO 140 j = 1, nrhs
269*
270 count = 1
271 lstres = three
272 20 CONTINUE
273*
274* Loop until stopping criterion is satisfied.
275*
276* Compute residual R = B - A * X
277*
278 CALL zcopy( n, b( 1, j ), 1, work, 1 )
279 CALL zhpmv( uplo, n, -cone, ap, x( 1, j ), 1, cone, work, 1 )
280*
281* Compute componentwise relative backward error from formula
282*
283* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
284*
285* where abs(Z) is the componentwise absolute value of the matrix
286* or vector Z. If the i-th component of the denominator is less
287* than SAFE2, then SAFE1 is added to the i-th components of the
288* numerator and denominator before dividing.
289*
290 DO 30 i = 1, n
291 rwork( i ) = cabs1( b( i, j ) )
292 30 CONTINUE
293*
294* Compute abs(A)*abs(X) + abs(B).
295*
296 kk = 1
297 IF( upper ) THEN
298 DO 50 k = 1, n
299 s = zero
300 xk = cabs1( x( k, j ) )
301 ik = kk
302 DO 40 i = 1, k - 1
303 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
304 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
305 ik = ik + 1
306 40 CONTINUE
307 rwork( k ) = rwork( k ) + abs( dble( ap( kk+k-1 ) ) )*
308 $ xk + s
309 kk = kk + k
310 50 CONTINUE
311 ELSE
312 DO 70 k = 1, n
313 s = zero
314 xk = cabs1( x( k, j ) )
315 rwork( k ) = rwork( k ) + abs( dble( ap( kk ) ) )*xk
316 ik = kk + 1
317 DO 60 i = k + 1, n
318 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
319 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
320 ik = ik + 1
321 60 CONTINUE
322 rwork( k ) = rwork( k ) + s
323 kk = kk + ( n-k+1 )
324 70 CONTINUE
325 END IF
326 s = zero
327 DO 80 i = 1, n
328 IF( rwork( i ).GT.safe2 ) THEN
329 s = max( s, cabs1( work( i ) ) / rwork( i ) )
330 ELSE
331 s = max( s, ( cabs1( work( i ) )+safe1 ) /
332 $ ( rwork( i )+safe1 ) )
333 END IF
334 80 CONTINUE
335 berr( j ) = s
336*
337* Test stopping criterion. Continue iterating if
338* 1) The residual BERR(J) is larger than machine epsilon, and
339* 2) BERR(J) decreased by at least a factor of 2 during the
340* last iteration, and
341* 3) At most ITMAX iterations tried.
342*
343 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
344 $ count.LE.itmax ) THEN
345*
346* Update solution and try again.
347*
348 CALL zpptrs( uplo, n, 1, afp, work, n, info )
349 CALL zaxpy( n, cone, work, 1, x( 1, j ), 1 )
350 lstres = berr( j )
351 count = count + 1
352 GO TO 20
353 END IF
354*
355* Bound error from formula
356*
357* norm(X - XTRUE) / norm(X) .le. FERR =
358* norm( abs(inv(A))*
359* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
360*
361* where
362* norm(Z) is the magnitude of the largest component of Z
363* inv(A) is the inverse of A
364* abs(Z) is the componentwise absolute value of the matrix or
365* vector Z
366* NZ is the maximum number of nonzeros in any row of A, plus 1
367* EPS is machine epsilon
368*
369* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
370* is incremented by SAFE1 if the i-th component of
371* abs(A)*abs(X) + abs(B) is less than SAFE2.
372*
373* Use ZLACN2 to estimate the infinity-norm of the matrix
374* inv(A) * diag(W),
375* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
376*
377 DO 90 i = 1, n
378 IF( rwork( i ).GT.safe2 ) THEN
379 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
380 ELSE
381 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
382 $ safe1
383 END IF
384 90 CONTINUE
385*
386 kase = 0
387 100 CONTINUE
388 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
389 IF( kase.NE.0 ) THEN
390 IF( kase.EQ.1 ) THEN
391*
392* Multiply by diag(W)*inv(A**H).
393*
394 CALL zpptrs( uplo, n, 1, afp, work, n, info )
395 DO 110 i = 1, n
396 work( i ) = rwork( i )*work( i )
397 110 CONTINUE
398 ELSE IF( kase.EQ.2 ) THEN
399*
400* Multiply by inv(A)*diag(W).
401*
402 DO 120 i = 1, n
403 work( i ) = rwork( i )*work( i )
404 120 CONTINUE
405 CALL zpptrs( uplo, n, 1, afp, work, n, info )
406 END IF
407 GO TO 100
408 END IF
409*
410* Normalize error.
411*
412 lstres = zero
413 DO 130 i = 1, n
414 lstres = max( lstres, cabs1( x( i, j ) ) )
415 130 CONTINUE
416 IF( lstres.NE.zero )
417 $ ferr( j ) = ferr( j ) / lstres
418*
419 140 CONTINUE
420*
421 RETURN
422*
423* End of ZPPRFS
424*
zpptrs
subroutine zpptrs(uplo, n, nrhs, ap, b, ldb, info)
ZPPTRS
Definition zpptrs.f:108

◆ zpptrf()

subroutine zpptrf ( character uplo,
integer n,
complex*16, dimension( * ) ap,
integer info )

ZPPTRF

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

Purpose:
!>
!> ZPPTRF computes the Cholesky factorization of a complex Hermitian
!> positive definite matrix A stored in packed format.
!>
!> The factorization has the form
!>    A = U**H * U,  if UPLO = 'U', or
!>    A = L  * L**H,  if UPLO = 'L',
!> where U is an upper triangular matrix and L is lower triangular.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[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.
!>          See below for further details.
!>
!>          On exit, if INFO = 0, the triangular factor U or L from the
!>          Cholesky factorization A = U**H*U or A = L*L**H, in the same
!>          storage format as A.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the leading minor of order i is not
!>                positive definite, and the factorization could not be
!>                completed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The packed storage scheme is illustrated by the following example
!>  when N = 4, UPLO = 'U':
!>
!>  Two-dimensional storage of the Hermitian matrix A:
!>
!>     a11 a12 a13 a14
!>         a22 a23 a24
!>             a33 a34     (aij = conjg(aji))
!>                 a44
!>
!>  Packed storage of the upper triangle of A:
!>
!>  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
!>

Definition at line 118 of file zpptrf.f.

119*
120* -- LAPACK computational routine --
121* -- LAPACK is a software package provided by Univ. of Tennessee, --
122* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
123*
124* .. Scalar Arguments ..
125 CHARACTER UPLO
126 INTEGER INFO, N
127* ..
128* .. Array Arguments ..
129 COMPLEX*16 AP( * )
130* ..
131*
132* =====================================================================
133*
134* .. Parameters ..
135 DOUBLE PRECISION ZERO, ONE
136 parameter( zero = 0.0d+0, one = 1.0d+0 )
137* ..
138* .. Local Scalars ..
139 LOGICAL UPPER
140 INTEGER J, JC, JJ
141 DOUBLE PRECISION AJJ
142* ..
143* .. External Functions ..
144 LOGICAL LSAME
145 COMPLEX*16 ZDOTC
146 EXTERNAL lsame, zdotc
147* ..
148* .. External Subroutines ..
149 EXTERNAL xerbla, zdscal, zhpr, ztpsv
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC dble, sqrt
153* ..
154* .. Executable Statements ..
155*
156* Test the input parameters.
157*
158 info = 0
159 upper = lsame( uplo, 'U' )
160 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
161 info = -1
162 ELSE IF( n.LT.0 ) THEN
163 info = -2
164 END IF
165 IF( info.NE.0 ) THEN
166 CALL xerbla( 'ZPPTRF', -info )
167 RETURN
168 END IF
169*
170* Quick return if possible
171*
172 IF( n.EQ.0 )
173 $ RETURN
174*
175 IF( upper ) THEN
176*
177* Compute the Cholesky factorization A = U**H * U.
178*
179 jj = 0
180 DO 10 j = 1, n
181 jc = jj + 1
182 jj = jj + j
183*
184* Compute elements 1:J-1 of column J.
185*
186 IF( j.GT.1 )
187 $ CALL ztpsv( 'Upper', 'Conjugate transpose', 'Non-unit',
188 $ j-1, ap, ap( jc ), 1 )
189*
190* Compute U(J,J) and test for non-positive-definiteness.
191*
192 ajj = dble( ap( jj ) ) - dble( zdotc( j-1,
193 $ ap( jc ), 1, ap( jc ), 1 ) )
194 IF( ajj.LE.zero ) THEN
195 ap( jj ) = ajj
196 GO TO 30
197 END IF
198 ap( jj ) = sqrt( ajj )
199 10 CONTINUE
200 ELSE
201*
202* Compute the Cholesky factorization A = L * L**H.
203*
204 jj = 1
205 DO 20 j = 1, n
206*
207* Compute L(J,J) and test for non-positive-definiteness.
208*
209 ajj = dble( ap( jj ) )
210 IF( ajj.LE.zero ) THEN
211 ap( jj ) = ajj
212 GO TO 30
213 END IF
214 ajj = sqrt( ajj )
215 ap( jj ) = ajj
216*
217* Compute elements J+1:N of column J and update the trailing
218* submatrix.
219*
220 IF( j.LT.n ) THEN
221 CALL zdscal( n-j, one / ajj, ap( jj+1 ), 1 )
222 CALL zhpr( 'Lower', n-j, -one, ap( jj+1 ), 1,
223 $ ap( jj+n-j+1 ) )
224 jj = jj + n - j + 1
225 END IF
226 20 CONTINUE
227 END IF
228 GO TO 40
229*
230 30 CONTINUE
231 info = j
232*
233 40 CONTINUE
234 RETURN
235*
236* End of ZPPTRF
237*
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ zpptri()

subroutine zpptri ( character uplo,
integer n,
complex*16, dimension( * ) ap,
integer info )

ZPPTRI

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

Purpose:
!>
!> ZPPTRI computes the inverse of a complex Hermitian positive definite
!> matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
!> computed by ZPPTRF.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangular factor is stored in AP;
!>          = 'L':  Lower triangular factor is stored in AP.
!>
[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 triangular factor U or L from the Cholesky
!>          factorization A = U**H*U or A = L*L**H, packed columnwise as
!>          a linear array.  The j-th column of U or L is stored in the
!>          array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
!>
!>          On exit, the upper or lower triangle of the (Hermitian)
!>          inverse of A, overwriting the input factor U or L.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the (i,i) element of the factor U or L is
!>                zero, and the inverse could not be computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 92 of file zpptri.f.

93*
94* -- LAPACK computational routine --
95* -- LAPACK is a software package provided by Univ. of Tennessee, --
96* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
97*
98* .. Scalar Arguments ..
99 CHARACTER UPLO
100 INTEGER INFO, N
101* ..
102* .. Array Arguments ..
103 COMPLEX*16 AP( * )
104* ..
105*
106* =====================================================================
107*
108* .. Parameters ..
109 DOUBLE PRECISION ONE
110 parameter( one = 1.0d+0 )
111* ..
112* .. Local Scalars ..
113 LOGICAL UPPER
114 INTEGER J, JC, JJ, JJN
115 DOUBLE PRECISION AJJ
116* ..
117* .. External Functions ..
118 LOGICAL LSAME
119 COMPLEX*16 ZDOTC
120 EXTERNAL lsame, zdotc
121* ..
122* .. External Subroutines ..
123 EXTERNAL xerbla, zdscal, zhpr, ztpmv, ztptri
124* ..
125* .. Intrinsic Functions ..
126 INTRINSIC dble
127* ..
128* .. Executable Statements ..
129*
130* Test the input parameters.
131*
132 info = 0
133 upper = lsame( uplo, 'U' )
134 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
135 info = -1
136 ELSE IF( n.LT.0 ) THEN
137 info = -2
138 END IF
139 IF( info.NE.0 ) THEN
140 CALL xerbla( 'ZPPTRI', -info )
141 RETURN
142 END IF
143*
144* Quick return if possible
145*
146 IF( n.EQ.0 )
147 $ RETURN
148*
149* Invert the triangular Cholesky factor U or L.
150*
151 CALL ztptri( uplo, 'Non-unit', n, ap, info )
152 IF( info.GT.0 )
153 $ RETURN
154 IF( upper ) THEN
155*
156* Compute the product inv(U) * inv(U)**H.
157*
158 jj = 0
159 DO 10 j = 1, n
160 jc = jj + 1
161 jj = jj + j
162 IF( j.GT.1 )
163 $ CALL zhpr( 'Upper', j-1, one, ap( jc ), 1, ap )
164 ajj = dble( ap( jj ) )
165 CALL zdscal( j, ajj, ap( jc ), 1 )
166 10 CONTINUE
167*
168 ELSE
169*
170* Compute the product inv(L)**H * inv(L).
171*
172 jj = 1
173 DO 20 j = 1, n
174 jjn = jj + n - j + 1
175 ap( jj ) = dble( zdotc( n-j+1, ap( jj ), 1, ap( jj ), 1 ) )
176 IF( j.LT.n )
177 $ CALL ztpmv( 'Lower', 'Conjugate transpose', 'Non-unit',
178 $ n-j, ap( jjn ), ap( jj+1 ), 1 )
179 jj = jjn
180 20 CONTINUE
181 END IF
182*
183 RETURN
184*
185* End of ZPPTRI
186*
ztptri
subroutine ztptri(uplo, diag, n, ap, info)
ZTPTRI
Definition ztptri.f:117

◆ zpptrs()

subroutine zpptrs ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZPPTRS

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

Purpose:
!>
!> ZPPTRS solves a system of linear equations A*X = B with a Hermitian
!> positive definite matrix A in packed storage using the Cholesky
!> factorization A = U**H * U or A = L * L**H computed by ZPPTRF.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[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 matrix B.  NRHS >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**H * U or A = L * L**H, packed columnwise in a linear
!>          array.  The j-th column of U or L is stored in the array AP
!>          as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file zpptrs.f.

108*
109* -- LAPACK computational routine --
110* -- LAPACK is a software package provided by Univ. of Tennessee, --
111* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112*
113* .. Scalar Arguments ..
114 CHARACTER UPLO
115 INTEGER INFO, LDB, N, NRHS
116* ..
117* .. Array Arguments ..
118 COMPLEX*16 AP( * ), B( LDB, * )
119* ..
120*
121* =====================================================================
122*
123* .. Local Scalars ..
124 LOGICAL UPPER
125 INTEGER I
126* ..
127* .. External Functions ..
128 LOGICAL LSAME
129 EXTERNAL lsame
130* ..
131* .. External Subroutines ..
132 EXTERNAL xerbla, ztpsv
133* ..
134* .. Intrinsic Functions ..
135 INTRINSIC max
136* ..
137* .. Executable Statements ..
138*
139* Test the input parameters.
140*
141 info = 0
142 upper = lsame( uplo, 'U' )
143 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
144 info = -1
145 ELSE IF( n.LT.0 ) THEN
146 info = -2
147 ELSE IF( nrhs.LT.0 ) THEN
148 info = -3
149 ELSE IF( ldb.LT.max( 1, n ) ) THEN
150 info = -6
151 END IF
152 IF( info.NE.0 ) THEN
153 CALL xerbla( 'ZPPTRS', -info )
154 RETURN
155 END IF
156*
157* Quick return if possible
158*
159 IF( n.EQ.0 .OR. nrhs.EQ.0 )
160 $ RETURN
161*
162 IF( upper ) THEN
163*
164* Solve A*X = B where A = U**H * U.
165*
166 DO 10 i = 1, nrhs
167*
168* Solve U**H *X = B, overwriting B with X.
169*
170 CALL ztpsv( 'Upper', 'Conjugate transpose', 'Non-unit', n,
171 $ ap, b( 1, i ), 1 )
172*
173* Solve U*X = B, overwriting B with X.
174*
175 CALL ztpsv( 'Upper', 'No transpose', 'Non-unit', n, ap,
176 $ b( 1, i ), 1 )
177 10 CONTINUE
178 ELSE
179*
180* Solve A*X = B where A = L * L**H.
181*
182 DO 20 i = 1, nrhs
183*
184* Solve L*Y = B, overwriting B with X.
185*
186 CALL ztpsv( 'Lower', 'No transpose', 'Non-unit', n, ap,
187 $ b( 1, i ), 1 )
188*
189* Solve L**H *X = Y, overwriting B with X.
190*
191 CALL ztpsv( 'Lower', 'Conjugate transpose', 'Non-unit', n,
192 $ ap, b( 1, i ), 1 )
193 20 CONTINUE
194 END IF
195*
196 RETURN
197*
198* End of ZPPTRS
199*

◆ zpstf2()

subroutine zpstf2 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( n ) piv,
integer rank,
double precision tol,
double precision, dimension( 2*n ) work,
integer info )

ZPSTF2 computes the Cholesky factorization with complete pivoting of a complex Hermitian positive semidefinite matrix.

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

Purpose:
!>
!> ZPSTF2 computes the Cholesky factorization with complete
!> pivoting of a complex Hermitian positive semidefinite matrix A.
!>
!> The factorization has the form
!>    P**T * A * P = U**H * U ,  if UPLO = 'U',
!>    P**T * A * P = L  * L**H,  if UPLO = 'L',
!> where U is an upper triangular matrix and L is lower triangular, and
!> P is stored as vector PIV.
!>
!> This algorithm does not attempt to check that A is positive
!> semidefinite. This version of the algorithm calls level 2 BLAS.
!>
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]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n by n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n by n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, if INFO = 0, the factor U or L from the Cholesky
!>          factorization as above.
!>
[out]PIV
!>          PIV is INTEGER array, dimension (N)
!>          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.
!>
[out]RANK
!>          RANK is INTEGER
!>          The rank of A given by the number of steps the algorithm
!>          completed.
!>
[in]TOL
!>          TOL is DOUBLE PRECISION
!>          User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )
!>          will be used. The algorithm terminates at the (K-1)st step
!>          if the pivot <= TOL.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (2*N)
!>          Work space.
!>
[out]INFO
!>          INFO is INTEGER
!>          < 0: If INFO = -K, the K-th argument had an illegal value,
!>          = 0: algorithm completed successfully, and
!>          > 0: the matrix A is either rank deficient with computed rank
!>               as returned in RANK, or is not positive semidefinite. See
!>               Section 7 of LAPACK Working Note #161 for further
!>               information.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 141 of file zpstf2.f.

142*
143* -- LAPACK computational 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 DOUBLE PRECISION TOL
149 INTEGER INFO, LDA, N, RANK
150 CHARACTER UPLO
151* ..
152* .. Array Arguments ..
153 COMPLEX*16 A( LDA, * )
154 DOUBLE PRECISION WORK( 2*N )
155 INTEGER PIV( N )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 DOUBLE PRECISION ONE, ZERO
162 parameter( one = 1.0d+0, zero = 0.0d+0 )
163 COMPLEX*16 CONE
164 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
165* ..
166* .. Local Scalars ..
167 COMPLEX*16 ZTEMP
168 DOUBLE PRECISION AJJ, DSTOP, DTEMP
169 INTEGER I, ITEMP, J, PVT
170 LOGICAL UPPER
171* ..
172* .. External Functions ..
173 DOUBLE PRECISION DLAMCH
174 LOGICAL LSAME, DISNAN
175 EXTERNAL dlamch, lsame, disnan
176* ..
177* .. External Subroutines ..
178 EXTERNAL zdscal, zgemv, zlacgv, zswap, xerbla
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC dble, dconjg, max, sqrt
182* ..
183* .. Executable Statements ..
184*
185* Test the input parameters
186*
187 info = 0
188 upper = lsame( uplo, 'U' )
189 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
190 info = -1
191 ELSE IF( n.LT.0 ) THEN
192 info = -2
193 ELSE IF( lda.LT.max( 1, n ) ) THEN
194 info = -4
195 END IF
196 IF( info.NE.0 ) THEN
197 CALL xerbla( 'ZPSTF2', -info )
198 RETURN
199 END IF
200*
201* Quick return if possible
202*
203 IF( n.EQ.0 )
204 $ RETURN
205*
206* Initialize PIV
207*
208 DO 100 i = 1, n
209 piv( i ) = i
210 100 CONTINUE
211*
212* Compute stopping value
213*
214 DO 110 i = 1, n
215 work( i ) = dble( a( i, i ) )
216 110 CONTINUE
217 pvt = maxloc( work( 1:n ), 1 )
218 ajj = dble( a( pvt, pvt ) )
219 IF( ajj.LE.zero.OR.disnan( ajj ) ) THEN
220 rank = 0
221 info = 1
222 GO TO 200
223 END IF
224*
225* Compute stopping value if not supplied
226*
227 IF( tol.LT.zero ) THEN
228 dstop = n * dlamch( 'Epsilon' ) * ajj
229 ELSE
230 dstop = tol
231 END IF
232*
233* Set first half of WORK to zero, holds dot products
234*
235 DO 120 i = 1, n
236 work( i ) = 0
237 120 CONTINUE
238*
239 IF( upper ) THEN
240*
241* Compute the Cholesky factorization P**T * A * P = U**H* U
242*
243 DO 150 j = 1, n
244*
245* Find pivot, test for exit, else swap rows and columns
246* Update dot products, compute possible pivots which are
247* stored in the second half of WORK
248*
249 DO 130 i = j, n
250*
251 IF( j.GT.1 ) THEN
252 work( i ) = work( i ) +
253 $ dble( dconjg( a( j-1, i ) )*
254 $ a( j-1, i ) )
255 END IF
256 work( n+i ) = dble( a( i, i ) ) - work( i )
257*
258 130 CONTINUE
259*
260 IF( j.GT.1 ) THEN
261 itemp = maxloc( work( (n+j):(2*n) ), 1 )
262 pvt = itemp + j - 1
263 ajj = work( n+pvt )
264 IF( ajj.LE.dstop.OR.disnan( ajj ) ) THEN
265 a( j, j ) = ajj
266 GO TO 190
267 END IF
268 END IF
269*
270 IF( j.NE.pvt ) THEN
271*
272* Pivot OK, so can now swap pivot rows and columns
273*
274 a( pvt, pvt ) = a( j, j )
275 CALL zswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 )
276 IF( pvt.LT.n )
277 $ CALL zswap( n-pvt, a( j, pvt+1 ), lda,
278 $ a( pvt, pvt+1 ), lda )
279 DO 140 i = j + 1, pvt - 1
280 ztemp = dconjg( a( j, i ) )
281 a( j, i ) = dconjg( a( i, pvt ) )
282 a( i, pvt ) = ztemp
283 140 CONTINUE
284 a( j, pvt ) = dconjg( a( j, pvt ) )
285*
286* Swap dot products and PIV
287*
288 dtemp = work( j )
289 work( j ) = work( pvt )
290 work( pvt ) = dtemp
291 itemp = piv( pvt )
292 piv( pvt ) = piv( j )
293 piv( j ) = itemp
294 END IF
295*
296 ajj = sqrt( ajj )
297 a( j, j ) = ajj
298*
299* Compute elements J+1:N of row J
300*
301 IF( j.LT.n ) THEN
302 CALL zlacgv( j-1, a( 1, j ), 1 )
303 CALL zgemv( 'Trans', j-1, n-j, -cone, a( 1, j+1 ), lda,
304 $ a( 1, j ), 1, cone, a( j, j+1 ), lda )
305 CALL zlacgv( j-1, a( 1, j ), 1 )
306 CALL zdscal( n-j, one / ajj, a( j, j+1 ), lda )
307 END IF
308*
309 150 CONTINUE
310*
311 ELSE
312*
313* Compute the Cholesky factorization P**T * A * P = L * L**H
314*
315 DO 180 j = 1, n
316*
317* Find pivot, test for exit, else swap rows and columns
318* Update dot products, compute possible pivots which are
319* stored in the second half of WORK
320*
321 DO 160 i = j, n
322*
323 IF( j.GT.1 ) THEN
324 work( i ) = work( i ) +
325 $ dble( dconjg( a( i, j-1 ) )*
326 $ a( i, j-1 ) )
327 END IF
328 work( n+i ) = dble( a( i, i ) ) - work( i )
329*
330 160 CONTINUE
331*
332 IF( j.GT.1 ) THEN
333 itemp = maxloc( work( (n+j):(2*n) ), 1 )
334 pvt = itemp + j - 1
335 ajj = work( n+pvt )
336 IF( ajj.LE.dstop.OR.disnan( ajj ) ) THEN
337 a( j, j ) = ajj
338 GO TO 190
339 END IF
340 END IF
341*
342 IF( j.NE.pvt ) THEN
343*
344* Pivot OK, so can now swap pivot rows and columns
345*
346 a( pvt, pvt ) = a( j, j )
347 CALL zswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda )
348 IF( pvt.LT.n )
349 $ CALL zswap( n-pvt, a( pvt+1, j ), 1, a( pvt+1, pvt ),
350 $ 1 )
351 DO 170 i = j + 1, pvt - 1
352 ztemp = dconjg( a( i, j ) )
353 a( i, j ) = dconjg( a( pvt, i ) )
354 a( pvt, i ) = ztemp
355 170 CONTINUE
356 a( pvt, j ) = dconjg( a( pvt, j ) )
357*
358* Swap dot products and PIV
359*
360 dtemp = work( j )
361 work( j ) = work( pvt )
362 work( pvt ) = dtemp
363 itemp = piv( pvt )
364 piv( pvt ) = piv( j )
365 piv( j ) = itemp
366 END IF
367*
368 ajj = sqrt( ajj )
369 a( j, j ) = ajj
370*
371* Compute elements J+1:N of column J
372*
373 IF( j.LT.n ) THEN
374 CALL zlacgv( j-1, a( j, 1 ), lda )
375 CALL zgemv( 'No Trans', n-j, j-1, -cone, a( j+1, 1 ),
376 $ lda, a( j, 1 ), lda, cone, a( j+1, j ), 1 )
377 CALL zlacgv( j-1, a( j, 1 ), lda )
378 CALL zdscal( n-j, one / ajj, a( j+1, j ), 1 )
379 END IF
380*
381 180 CONTINUE
382*
383 END IF
384*
385* Ran to completion, A has full rank
386*
387 rank = n
388*
389 GO TO 200
390 190 CONTINUE
391*
392* Rank is number of steps completed. Set INFO = 1 to signal
393* that the factorization cannot be used to solve a system.
394*
395 rank = j - 1
396 info = 1
397*
398 200 CONTINUE
399 RETURN
400*
401* End of ZPSTF2
402*

◆ zpstrf()

subroutine zpstrf ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( n ) piv,
integer rank,
double precision tol,
double precision, dimension( 2*n ) work,
integer info )

ZPSTRF computes the Cholesky factorization with complete pivoting of a complex Hermitian positive semidefinite matrix.

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

Purpose:
!>
!> ZPSTRF computes the Cholesky factorization with complete
!> pivoting of a complex Hermitian positive semidefinite matrix A.
!>
!> The factorization has the form
!>    P**T * A * P = U**H * U ,  if UPLO = 'U',
!>    P**T * A * P = L  * L**H,  if UPLO = 'L',
!> where U is an upper triangular matrix and L is lower triangular, and
!> P is stored as vector PIV.
!>
!> This algorithm does not attempt to check that A is positive
!> semidefinite. This version of the algorithm calls level 3 BLAS.
!>
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]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n by n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n by n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, if INFO = 0, the factor U or L from the Cholesky
!>          factorization as above.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]PIV
!>          PIV is INTEGER array, dimension (N)
!>          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.
!>
[out]RANK
!>          RANK is INTEGER
!>          The rank of A given by the number of steps the algorithm
!>          completed.
!>
[in]TOL
!>          TOL is DOUBLE PRECISION
!>          User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )
!>          will be used. The algorithm terminates at the (K-1)st step
!>          if the pivot <= TOL.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (2*N)
!>          Work space.
!>
[out]INFO
!>          INFO is INTEGER
!>          < 0: If INFO = -K, the K-th argument had an illegal value,
!>          = 0: algorithm completed successfully, and
!>          > 0: the matrix A is either rank deficient with computed rank
!>               as returned in RANK, or is not positive semidefinite. See
!>               Section 7 of LAPACK Working Note #161 for further
!>               information.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 141 of file zpstrf.f.

142*
143* -- LAPACK computational 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 DOUBLE PRECISION TOL
149 INTEGER INFO, LDA, N, RANK
150 CHARACTER UPLO
151* ..
152* .. Array Arguments ..
153 COMPLEX*16 A( LDA, * )
154 DOUBLE PRECISION WORK( 2*N )
155 INTEGER PIV( N )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 DOUBLE PRECISION ONE, ZERO
162 parameter( one = 1.0d+0, zero = 0.0d+0 )
163 COMPLEX*16 CONE
164 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
165* ..
166* .. Local Scalars ..
167 COMPLEX*16 ZTEMP
168 DOUBLE PRECISION AJJ, DSTOP, DTEMP
169 INTEGER I, ITEMP, J, JB, K, NB, PVT
170 LOGICAL UPPER
171* ..
172* .. External Functions ..
173 DOUBLE PRECISION DLAMCH
174 INTEGER ILAENV
175 LOGICAL LSAME, DISNAN
176 EXTERNAL dlamch, ilaenv, lsame, disnan
177* ..
178* .. External Subroutines ..
179 EXTERNAL zdscal, zgemv, zherk, zlacgv, zpstf2, zswap,
180 $ xerbla
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC dble, dconjg, max, min, sqrt, maxloc
184* ..
185* .. Executable Statements ..
186*
187* Test the input parameters.
188*
189 info = 0
190 upper = lsame( uplo, 'U' )
191 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
192 info = -1
193 ELSE IF( n.LT.0 ) THEN
194 info = -2
195 ELSE IF( lda.LT.max( 1, n ) ) THEN
196 info = -4
197 END IF
198 IF( info.NE.0 ) THEN
199 CALL xerbla( 'ZPSTRF', -info )
200 RETURN
201 END IF
202*
203* Quick return if possible
204*
205 IF( n.EQ.0 )
206 $ RETURN
207*
208* Get block size
209*
210 nb = ilaenv( 1, 'ZPOTRF', uplo, n, -1, -1, -1 )
211 IF( nb.LE.1 .OR. nb.GE.n ) THEN
212*
213* Use unblocked code
214*
215 CALL zpstf2( uplo, n, a( 1, 1 ), lda, piv, rank, tol, work,
216 $ info )
217 GO TO 230
218*
219 ELSE
220*
221* Initialize PIV
222*
223 DO 100 i = 1, n
224 piv( i ) = i
225 100 CONTINUE
226*
227* Compute stopping value
228*
229 DO 110 i = 1, n
230 work( i ) = dble( a( i, i ) )
231 110 CONTINUE
232 pvt = maxloc( work( 1:n ), 1 )
233 ajj = dble( a( pvt, pvt ) )
234 IF( ajj.LE.zero.OR.disnan( ajj ) ) THEN
235 rank = 0
236 info = 1
237 GO TO 230
238 END IF
239*
240* Compute stopping value if not supplied
241*
242 IF( tol.LT.zero ) THEN
243 dstop = n * dlamch( 'Epsilon' ) * ajj
244 ELSE
245 dstop = tol
246 END IF
247*
248*
249 IF( upper ) THEN
250*
251* Compute the Cholesky factorization P**T * A * P = U**H * U
252*
253 DO 160 k = 1, n, nb
254*
255* Account for last block not being NB wide
256*
257 jb = min( nb, n-k+1 )
258*
259* Set relevant part of first half of WORK to zero,
260* holds dot products
261*
262 DO 120 i = k, n
263 work( i ) = 0
264 120 CONTINUE
265*
266 DO 150 j = k, k + jb - 1
267*
268* Find pivot, test for exit, else swap rows and columns
269* Update dot products, compute possible pivots which are
270* stored in the second half of WORK
271*
272 DO 130 i = j, n
273*
274 IF( j.GT.k ) THEN
275 work( i ) = work( i ) +
276 $ dble( dconjg( a( j-1, i ) )*
277 $ a( j-1, i ) )
278 END IF
279 work( n+i ) = dble( a( i, i ) ) - work( i )
280*
281 130 CONTINUE
282*
283 IF( j.GT.1 ) THEN
284 itemp = maxloc( work( (n+j):(2*n) ), 1 )
285 pvt = itemp + j - 1
286 ajj = work( n+pvt )
287 IF( ajj.LE.dstop.OR.disnan( ajj ) ) THEN
288 a( j, j ) = ajj
289 GO TO 220
290 END IF
291 END IF
292*
293 IF( j.NE.pvt ) THEN
294*
295* Pivot OK, so can now swap pivot rows and columns
296*
297 a( pvt, pvt ) = a( j, j )
298 CALL zswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 )
299 IF( pvt.LT.n )
300 $ CALL zswap( n-pvt, a( j, pvt+1 ), lda,
301 $ a( pvt, pvt+1 ), lda )
302 DO 140 i = j + 1, pvt - 1
303 ztemp = dconjg( a( j, i ) )
304 a( j, i ) = dconjg( a( i, pvt ) )
305 a( i, pvt ) = ztemp
306 140 CONTINUE
307 a( j, pvt ) = dconjg( a( j, pvt ) )
308*
309* Swap dot products and PIV
310*
311 dtemp = work( j )
312 work( j ) = work( pvt )
313 work( pvt ) = dtemp
314 itemp = piv( pvt )
315 piv( pvt ) = piv( j )
316 piv( j ) = itemp
317 END IF
318*
319 ajj = sqrt( ajj )
320 a( j, j ) = ajj
321*
322* Compute elements J+1:N of row J.
323*
324 IF( j.LT.n ) THEN
325 CALL zlacgv( j-1, a( 1, j ), 1 )
326 CALL zgemv( 'Trans', j-k, n-j, -cone, a( k, j+1 ),
327 $ lda, a( k, j ), 1, cone, a( j, j+1 ),
328 $ lda )
329 CALL zlacgv( j-1, a( 1, j ), 1 )
330 CALL zdscal( n-j, one / ajj, a( j, j+1 ), lda )
331 END IF
332*
333 150 CONTINUE
334*
335* Update trailing matrix, J already incremented
336*
337 IF( k+jb.LE.n ) THEN
338 CALL zherk( 'Upper', 'Conj Trans', n-j+1, jb, -one,
339 $ a( k, j ), lda, one, a( j, j ), lda )
340 END IF
341*
342 160 CONTINUE
343*
344 ELSE
345*
346* Compute the Cholesky factorization P**T * A * P = L * L**H
347*
348 DO 210 k = 1, n, nb
349*
350* Account for last block not being NB wide
351*
352 jb = min( nb, n-k+1 )
353*
354* Set relevant part of first half of WORK to zero,
355* holds dot products
356*
357 DO 170 i = k, n
358 work( i ) = 0
359 170 CONTINUE
360*
361 DO 200 j = k, k + jb - 1
362*
363* Find pivot, test for exit, else swap rows and columns
364* Update dot products, compute possible pivots which are
365* stored in the second half of WORK
366*
367 DO 180 i = j, n
368*
369 IF( j.GT.k ) THEN
370 work( i ) = work( i ) +
371 $ dble( dconjg( a( i, j-1 ) )*
372 $ a( i, j-1 ) )
373 END IF
374 work( n+i ) = dble( a( i, i ) ) - work( i )
375*
376 180 CONTINUE
377*
378 IF( j.GT.1 ) THEN
379 itemp = maxloc( work( (n+j):(2*n) ), 1 )
380 pvt = itemp + j - 1
381 ajj = work( n+pvt )
382 IF( ajj.LE.dstop.OR.disnan( ajj ) ) THEN
383 a( j, j ) = ajj
384 GO TO 220
385 END IF
386 END IF
387*
388 IF( j.NE.pvt ) THEN
389*
390* Pivot OK, so can now swap pivot rows and columns
391*
392 a( pvt, pvt ) = a( j, j )
393 CALL zswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda )
394 IF( pvt.LT.n )
395 $ CALL zswap( n-pvt, a( pvt+1, j ), 1,
396 $ a( pvt+1, pvt ), 1 )
397 DO 190 i = j + 1, pvt - 1
398 ztemp = dconjg( a( i, j ) )
399 a( i, j ) = dconjg( a( pvt, i ) )
400 a( pvt, i ) = ztemp
401 190 CONTINUE
402 a( pvt, j ) = dconjg( a( pvt, j ) )
403*
404*
405* Swap dot products and PIV
406*
407 dtemp = work( j )
408 work( j ) = work( pvt )
409 work( pvt ) = dtemp
410 itemp = piv( pvt )
411 piv( pvt ) = piv( j )
412 piv( j ) = itemp
413 END IF
414*
415 ajj = sqrt( ajj )
416 a( j, j ) = ajj
417*
418* Compute elements J+1:N of column J.
419*
420 IF( j.LT.n ) THEN
421 CALL zlacgv( j-1, a( j, 1 ), lda )
422 CALL zgemv( 'No Trans', n-j, j-k, -cone,
423 $ a( j+1, k ), lda, a( j, k ), lda, cone,
424 $ a( j+1, j ), 1 )
425 CALL zlacgv( j-1, a( j, 1 ), lda )
426 CALL zdscal( n-j, one / ajj, a( j+1, j ), 1 )
427 END IF
428*
429 200 CONTINUE
430*
431* Update trailing matrix, J already incremented
432*
433 IF( k+jb.LE.n ) THEN
434 CALL zherk( 'Lower', 'No Trans', n-j+1, jb, -one,
435 $ a( j, k ), lda, one, a( j, j ), lda )
436 END IF
437*
438 210 CONTINUE
439*
440 END IF
441 END IF
442*
443* Ran to completion, A has full rank
444*
445 rank = n
446*
447 GO TO 230
448 220 CONTINUE
449*
450* Rank is the number of steps completed. Set INFO = 1 to signal
451* that the factorization cannot be used to solve a system.
452*
453 rank = j - 1
454 info = 1
455*
456 230 CONTINUE
457 RETURN
458*
459* End of ZPSTRF
460*
zpstf2
subroutine zpstf2(uplo, n, a, lda, piv, rank, tol, work, info)
ZPSTF2 computes the Cholesky factorization with complete pivoting of a complex Hermitian positive sem...
Definition zpstf2.f:142

◆ zspcon()

subroutine zspcon ( character uplo,
integer n,
complex*16, dimension( * ) ap,
integer, dimension( * ) ipiv,
double precision anorm,
double precision rcond,
complex*16, dimension( * ) work,
integer info )

ZSPCON

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

Purpose:
!>
!> ZSPCON estimates the reciprocal of the condition number (in the
!> 1-norm) of a complex symmetric packed matrix A using the
!> factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[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 block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZSPTRF, stored as a
!>          packed triangular matrix.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZSPTRF.
!>
[in]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The 1-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file zspcon.f.

118*
119* -- LAPACK computational routine --
120* -- LAPACK is a software package provided by Univ. of Tennessee, --
121* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
122*
123* .. Scalar Arguments ..
124 CHARACTER UPLO
125 INTEGER INFO, N
126 DOUBLE PRECISION ANORM, RCOND
127* ..
128* .. Array Arguments ..
129 INTEGER IPIV( * )
130 COMPLEX*16 AP( * ), WORK( * )
131* ..
132*
133* =====================================================================
134*
135* .. Parameters ..
136 DOUBLE PRECISION ONE, ZERO
137 parameter( one = 1.0d+0, zero = 0.0d+0 )
138* ..
139* .. Local Scalars ..
140 LOGICAL UPPER
141 INTEGER I, IP, KASE
142 DOUBLE PRECISION AINVNM
143* ..
144* .. Local Arrays ..
145 INTEGER ISAVE( 3 )
146* ..
147* .. External Functions ..
148 LOGICAL LSAME
149 EXTERNAL lsame
150* ..
151* .. External Subroutines ..
152 EXTERNAL xerbla, zlacn2, zsptrs
153* ..
154* .. Executable Statements ..
155*
156* Test the input parameters.
157*
158 info = 0
159 upper = lsame( uplo, 'U' )
160 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
161 info = -1
162 ELSE IF( n.LT.0 ) THEN
163 info = -2
164 ELSE IF( anorm.LT.zero ) THEN
165 info = -5
166 END IF
167 IF( info.NE.0 ) THEN
168 CALL xerbla( 'ZSPCON', -info )
169 RETURN
170 END IF
171*
172* Quick return if possible
173*
174 rcond = zero
175 IF( n.EQ.0 ) THEN
176 rcond = one
177 RETURN
178 ELSE IF( anorm.LE.zero ) THEN
179 RETURN
180 END IF
181*
182* Check that the diagonal matrix D is nonsingular.
183*
184 IF( upper ) THEN
185*
186* Upper triangular storage: examine D from bottom to top
187*
188 ip = n*( n+1 ) / 2
189 DO 10 i = n, 1, -1
190 IF( ipiv( i ).GT.0 .AND. ap( ip ).EQ.zero )
191 $ RETURN
192 ip = ip - i
193 10 CONTINUE
194 ELSE
195*
196* Lower triangular storage: examine D from top to bottom.
197*
198 ip = 1
199 DO 20 i = 1, n
200 IF( ipiv( i ).GT.0 .AND. ap( ip ).EQ.zero )
201 $ RETURN
202 ip = ip + n - i + 1
203 20 CONTINUE
204 END IF
205*
206* Estimate the 1-norm of the inverse.
207*
208 kase = 0
209 30 CONTINUE
210 CALL zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
211 IF( kase.NE.0 ) THEN
212*
213* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
214*
215 CALL zsptrs( uplo, n, 1, ap, ipiv, work, n, info )
216 GO TO 30
217 END IF
218*
219* Compute the estimate of the reciprocal condition number.
220*
221 IF( ainvnm.NE.zero )
222 $ rcond = ( one / ainvnm ) / anorm
223*
224 RETURN
225*
226* End of ZSPCON
227*
zsptrs
subroutine zsptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
ZSPTRS
Definition zsptrs.f:115

◆ zsprfs()

subroutine zsprfs ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) afp,
integer, dimension( * ) ipiv,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZSPRFS

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

Purpose:
!>
!> ZSPRFS improves the computed solution to a system of linear
!> equations when the coefficient matrix is symmetric indefinite
!> and packed, and provides error bounds and backward error estimates
!> for the solution.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[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 B and X.  NRHS >= 0.
!>
[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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!>
[in]AFP
!>          AFP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The factored form of the matrix A.  AFP contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor U or L from the factorization A = U*D*U**T or
!>          A = L*D*L**T as computed by ZSPTRF, stored as a packed
!>          triangular matrix.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZSPTRF.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by ZSPTRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Internal Parameters:
!>  ITMAX is the maximum number of steps of iterative refinement.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 178 of file zsprfs.f.

180*
181* -- LAPACK computational routine --
182* -- LAPACK is a software package provided by Univ. of Tennessee, --
183* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
184*
185* .. Scalar Arguments ..
186 CHARACTER UPLO
187 INTEGER INFO, LDB, LDX, N, NRHS
188* ..
189* .. Array Arguments ..
190 INTEGER IPIV( * )
191 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
192 COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
193 $ X( LDX, * )
194* ..
195*
196* =====================================================================
197*
198* .. Parameters ..
199 INTEGER ITMAX
200 parameter( itmax = 5 )
201 DOUBLE PRECISION ZERO
202 parameter( zero = 0.0d+0 )
203 COMPLEX*16 ONE
204 parameter( one = ( 1.0d+0, 0.0d+0 ) )
205 DOUBLE PRECISION TWO
206 parameter( two = 2.0d+0 )
207 DOUBLE PRECISION THREE
208 parameter( three = 3.0d+0 )
209* ..
210* .. Local Scalars ..
211 LOGICAL UPPER
212 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
213 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
214 COMPLEX*16 ZDUM
215* ..
216* .. Local Arrays ..
217 INTEGER ISAVE( 3 )
218* ..
219* .. External Subroutines ..
220 EXTERNAL xerbla, zaxpy, zcopy, zlacn2, zspmv, zsptrs
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC abs, dble, dimag, max
224* ..
225* .. External Functions ..
226 LOGICAL LSAME
227 DOUBLE PRECISION DLAMCH
228 EXTERNAL lsame, dlamch
229* ..
230* .. Statement Functions ..
231 DOUBLE PRECISION CABS1
232* ..
233* .. Statement Function definitions ..
234 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
235* ..
236* .. Executable Statements ..
237*
238* Test the input parameters.
239*
240 info = 0
241 upper = lsame( uplo, 'U' )
242 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
243 info = -1
244 ELSE IF( n.LT.0 ) THEN
245 info = -2
246 ELSE IF( nrhs.LT.0 ) THEN
247 info = -3
248 ELSE IF( ldb.LT.max( 1, n ) ) THEN
249 info = -8
250 ELSE IF( ldx.LT.max( 1, n ) ) THEN
251 info = -10
252 END IF
253 IF( info.NE.0 ) THEN
254 CALL xerbla( 'ZSPRFS', -info )
255 RETURN
256 END IF
257*
258* Quick return if possible
259*
260 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
261 DO 10 j = 1, nrhs
262 ferr( j ) = zero
263 berr( j ) = zero
264 10 CONTINUE
265 RETURN
266 END IF
267*
268* NZ = maximum number of nonzero elements in each row of A, plus 1
269*
270 nz = n + 1
271 eps = dlamch( 'Epsilon' )
272 safmin = dlamch( 'Safe minimum' )
273 safe1 = nz*safmin
274 safe2 = safe1 / eps
275*
276* Do for each right hand side
277*
278 DO 140 j = 1, nrhs
279*
280 count = 1
281 lstres = three
282 20 CONTINUE
283*
284* Loop until stopping criterion is satisfied.
285*
286* Compute residual R = B - A * X
287*
288 CALL zcopy( n, b( 1, j ), 1, work, 1 )
289 CALL zspmv( uplo, n, -one, ap, x( 1, j ), 1, one, work, 1 )
290*
291* Compute componentwise relative backward error from formula
292*
293* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
294*
295* where abs(Z) is the componentwise absolute value of the matrix
296* or vector Z. If the i-th component of the denominator is less
297* than SAFE2, then SAFE1 is added to the i-th components of the
298* numerator and denominator before dividing.
299*
300 DO 30 i = 1, n
301 rwork( i ) = cabs1( b( i, j ) )
302 30 CONTINUE
303*
304* Compute abs(A)*abs(X) + abs(B).
305*
306 kk = 1
307 IF( upper ) THEN
308 DO 50 k = 1, n
309 s = zero
310 xk = cabs1( x( k, j ) )
311 ik = kk
312 DO 40 i = 1, k - 1
313 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
314 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
315 ik = ik + 1
316 40 CONTINUE
317 rwork( k ) = rwork( k ) + cabs1( ap( kk+k-1 ) )*xk + s
318 kk = kk + k
319 50 CONTINUE
320 ELSE
321 DO 70 k = 1, n
322 s = zero
323 xk = cabs1( x( k, j ) )
324 rwork( k ) = rwork( k ) + cabs1( ap( kk ) )*xk
325 ik = kk + 1
326 DO 60 i = k + 1, n
327 rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
328 s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
329 ik = ik + 1
330 60 CONTINUE
331 rwork( k ) = rwork( k ) + s
332 kk = kk + ( n-k+1 )
333 70 CONTINUE
334 END IF
335 s = zero
336 DO 80 i = 1, n
337 IF( rwork( i ).GT.safe2 ) THEN
338 s = max( s, cabs1( work( i ) ) / rwork( i ) )
339 ELSE
340 s = max( s, ( cabs1( work( i ) )+safe1 ) /
341 $ ( rwork( i )+safe1 ) )
342 END IF
343 80 CONTINUE
344 berr( j ) = s
345*
346* Test stopping criterion. Continue iterating if
347* 1) The residual BERR(J) is larger than machine epsilon, and
348* 2) BERR(J) decreased by at least a factor of 2 during the
349* last iteration, and
350* 3) At most ITMAX iterations tried.
351*
352 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
353 $ count.LE.itmax ) THEN
354*
355* Update solution and try again.
356*
357 CALL zsptrs( uplo, n, 1, afp, ipiv, work, n, info )
358 CALL zaxpy( n, one, work, 1, x( 1, j ), 1 )
359 lstres = berr( j )
360 count = count + 1
361 GO TO 20
362 END IF
363*
364* Bound error from formula
365*
366* norm(X - XTRUE) / norm(X) .le. FERR =
367* norm( abs(inv(A))*
368* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
369*
370* where
371* norm(Z) is the magnitude of the largest component of Z
372* inv(A) is the inverse of A
373* abs(Z) is the componentwise absolute value of the matrix or
374* vector Z
375* NZ is the maximum number of nonzeros in any row of A, plus 1
376* EPS is machine epsilon
377*
378* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
379* is incremented by SAFE1 if the i-th component of
380* abs(A)*abs(X) + abs(B) is less than SAFE2.
381*
382* Use ZLACN2 to estimate the infinity-norm of the matrix
383* inv(A) * diag(W),
384* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
385*
386 DO 90 i = 1, n
387 IF( rwork( i ).GT.safe2 ) THEN
388 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
389 ELSE
390 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
391 $ safe1
392 END IF
393 90 CONTINUE
394*
395 kase = 0
396 100 CONTINUE
397 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
398 IF( kase.NE.0 ) THEN
399 IF( kase.EQ.1 ) THEN
400*
401* Multiply by diag(W)*inv(A**T).
402*
403 CALL zsptrs( uplo, n, 1, afp, ipiv, work, n, info )
404 DO 110 i = 1, n
405 work( i ) = rwork( i )*work( i )
406 110 CONTINUE
407 ELSE IF( kase.EQ.2 ) THEN
408*
409* Multiply by inv(A)*diag(W).
410*
411 DO 120 i = 1, n
412 work( i ) = rwork( i )*work( i )
413 120 CONTINUE
414 CALL zsptrs( uplo, n, 1, afp, ipiv, work, n, info )
415 END IF
416 GO TO 100
417 END IF
418*
419* Normalize error.
420*
421 lstres = zero
422 DO 130 i = 1, n
423 lstres = max( lstres, cabs1( x( i, j ) ) )
424 130 CONTINUE
425 IF( lstres.NE.zero )
426 $ ferr( j ) = ferr( j ) / lstres
427*
428 140 CONTINUE
429*
430 RETURN
431*
432* End of ZSPRFS
433*
zspmv
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
Definition zspmv.f:151

◆ zsptrf()

subroutine zsptrf ( character uplo,
integer n,
complex*16, dimension( * ) ap,
integer, dimension( * ) ipiv,
integer info )

ZSPTRF

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

Purpose:
!>
!> ZSPTRF computes the factorization of a complex symmetric matrix A
!> stored in packed format using the Bunch-Kaufman diagonal pivoting
!> method:
!>
!>    A = U*D*U**T  or  A = L*D*L**T
!>
!> where U (or L) is a product of permutation and unit upper (lower)
!> triangular matrices, and D is symmetric and block diagonal with
!> 1-by-1 and 2-by-2 diagonal blocks.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!>
[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 block diagonal matrix D and the multipliers used
!>          to obtain the factor U or L, stored as a packed triangular
!>          matrix overwriting A (see below for further details).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D.
!>          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!>          interchanged and D(k,k) is a 1-by-1 diagonal block.
!>          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
!>          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!>          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
!>          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
!>          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization
!>               has been completed, but the block diagonal matrix D is
!>               exactly singular, and division by zero will occur if it
!>               is used to solve a system of equations.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  5-96 - Based on modifications by J. Lewis, Boeing Computer Services
!>         Company
!>
!>  If UPLO = 'U', then A = U*D*U**T, where
!>     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!>  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!>  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    v    0   )   k-s
!>     U(k) =  (   0    I    0   )   s
!>             (   0    0    I   )   n-k
!>                k-s   s   n-k
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!>  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!>  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!>
!>  If UPLO = 'L', then A = L*D*L**T, where
!>     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!>  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!>  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!>  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!>  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!>  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!>
!>             (   I    0     0   )  k-1
!>     L(k) =  (   0    I     0   )  s
!>             (   0    v     I   )  n-k-s+1
!>                k-1   s  n-k-s+1
!>
!>  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!>  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!>  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!>

Definition at line 157 of file zsptrf.f.

158*
159* -- LAPACK computational 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 CHARACTER UPLO
165 INTEGER INFO, N
166* ..
167* .. Array Arguments ..
168 INTEGER IPIV( * )
169 COMPLEX*16 AP( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 DOUBLE PRECISION ZERO, ONE
176 parameter( zero = 0.0d+0, one = 1.0d+0 )
177 DOUBLE PRECISION EIGHT, SEVTEN
178 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
179 COMPLEX*16 CONE
180 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
181* ..
182* .. Local Scalars ..
183 LOGICAL UPPER
184 INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
185 $ KSTEP, KX, NPP
186 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX
187 COMPLEX*16 D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, ZDUM
188* ..
189* .. External Functions ..
190 LOGICAL LSAME
191 INTEGER IZAMAX
192 EXTERNAL lsame, izamax
193* ..
194* .. External Subroutines ..
195 EXTERNAL xerbla, zscal, zspr, zswap
196* ..
197* .. Intrinsic Functions ..
198 INTRINSIC abs, dble, dimag, max, sqrt
199* ..
200* .. Statement Functions ..
201 DOUBLE PRECISION CABS1
202* ..
203* .. Statement Function definitions ..
204 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
205* ..
206* .. Executable Statements ..
207*
208* Test the input parameters.
209*
210 info = 0
211 upper = lsame( uplo, 'U' )
212 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
213 info = -1
214 ELSE IF( n.LT.0 ) THEN
215 info = -2
216 END IF
217 IF( info.NE.0 ) THEN
218 CALL xerbla( 'ZSPTRF', -info )
219 RETURN
220 END IF
221*
222* Initialize ALPHA for use in choosing pivot block size.
223*
224 alpha = ( one+sqrt( sevten ) ) / eight
225*
226 IF( upper ) THEN
227*
228* Factorize A as U*D*U**T using the upper triangle of A
229*
230* K is the main loop index, decreasing from N to 1 in steps of
231* 1 or 2
232*
233 k = n
234 kc = ( n-1 )*n / 2 + 1
235 10 CONTINUE
236 knc = kc
237*
238* If K < 1, exit from loop
239*
240 IF( k.LT.1 )
241 $ GO TO 110
242 kstep = 1
243*
244* Determine rows and columns to be interchanged and whether
245* a 1-by-1 or 2-by-2 pivot block will be used
246*
247 absakk = cabs1( ap( kc+k-1 ) )
248*
249* IMAX is the row-index of the largest off-diagonal element in
250* column K, and COLMAX is its absolute value
251*
252 IF( k.GT.1 ) THEN
253 imax = izamax( k-1, ap( kc ), 1 )
254 colmax = cabs1( ap( kc+imax-1 ) )
255 ELSE
256 colmax = zero
257 END IF
258*
259 IF( max( absakk, colmax ).EQ.zero ) THEN
260*
261* Column K is zero: set INFO and continue
262*
263 IF( info.EQ.0 )
264 $ info = k
265 kp = k
266 ELSE
267 IF( absakk.GE.alpha*colmax ) THEN
268*
269* no interchange, use 1-by-1 pivot block
270*
271 kp = k
272 ELSE
273*
274 rowmax = zero
275 jmax = imax
276 kx = imax*( imax+1 ) / 2 + imax
277 DO 20 j = imax + 1, k
278 IF( cabs1( ap( kx ) ).GT.rowmax ) THEN
279 rowmax = cabs1( ap( kx ) )
280 jmax = j
281 END IF
282 kx = kx + j
283 20 CONTINUE
284 kpc = ( imax-1 )*imax / 2 + 1
285 IF( imax.GT.1 ) THEN
286 jmax = izamax( imax-1, ap( kpc ), 1 )
287 rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) )
288 END IF
289*
290 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
291*
292* no interchange, use 1-by-1 pivot block
293*
294 kp = k
295 ELSE IF( cabs1( ap( kpc+imax-1 ) ).GE.alpha*rowmax ) THEN
296*
297* interchange rows and columns K and IMAX, use 1-by-1
298* pivot block
299*
300 kp = imax
301 ELSE
302*
303* interchange rows and columns K-1 and IMAX, use 2-by-2
304* pivot block
305*
306 kp = imax
307 kstep = 2
308 END IF
309 END IF
310*
311 kk = k - kstep + 1
312 IF( kstep.EQ.2 )
313 $ knc = knc - k + 1
314 IF( kp.NE.kk ) THEN
315*
316* Interchange rows and columns KK and KP in the leading
317* submatrix A(1:k,1:k)
318*
319 CALL zswap( kp-1, ap( knc ), 1, ap( kpc ), 1 )
320 kx = kpc + kp - 1
321 DO 30 j = kp + 1, kk - 1
322 kx = kx + j - 1
323 t = ap( knc+j-1 )
324 ap( knc+j-1 ) = ap( kx )
325 ap( kx ) = t
326 30 CONTINUE
327 t = ap( knc+kk-1 )
328 ap( knc+kk-1 ) = ap( kpc+kp-1 )
329 ap( kpc+kp-1 ) = t
330 IF( kstep.EQ.2 ) THEN
331 t = ap( kc+k-2 )
332 ap( kc+k-2 ) = ap( kc+kp-1 )
333 ap( kc+kp-1 ) = t
334 END IF
335 END IF
336*
337* Update the leading submatrix
338*
339 IF( kstep.EQ.1 ) THEN
340*
341* 1-by-1 pivot block D(k): column k now holds
342*
343* W(k) = U(k)*D(k)
344*
345* where U(k) is the k-th column of U
346*
347* Perform a rank-1 update of A(1:k-1,1:k-1) as
348*
349* A := A - U(k)*D(k)*U(k)**T = A - W(k)*1/D(k)*W(k)**T
350*
351 r1 = cone / ap( kc+k-1 )
352 CALL zspr( uplo, k-1, -r1, ap( kc ), 1, ap )
353*
354* Store U(k) in column k
355*
356 CALL zscal( k-1, r1, ap( kc ), 1 )
357 ELSE
358*
359* 2-by-2 pivot block D(k): columns k and k-1 now hold
360*
361* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
362*
363* where U(k) and U(k-1) are the k-th and (k-1)-th columns
364* of U
365*
366* Perform a rank-2 update of A(1:k-2,1:k-2) as
367*
368* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
369* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T
370*
371 IF( k.GT.2 ) THEN
372*
373 d12 = ap( k-1+( k-1 )*k / 2 )
374 d22 = ap( k-1+( k-2 )*( k-1 ) / 2 ) / d12
375 d11 = ap( k+( k-1 )*k / 2 ) / d12
376 t = cone / ( d11*d22-cone )
377 d12 = t / d12
378*
379 DO 50 j = k - 2, 1, -1
380 wkm1 = d12*( d11*ap( j+( k-2 )*( k-1 ) / 2 )-
381 $ ap( j+( k-1 )*k / 2 ) )
382 wk = d12*( d22*ap( j+( k-1 )*k / 2 )-
383 $ ap( j+( k-2 )*( k-1 ) / 2 ) )
384 DO 40 i = j, 1, -1
385 ap( i+( j-1 )*j / 2 ) = ap( i+( j-1 )*j / 2 ) -
386 $ ap( i+( k-1 )*k / 2 )*wk -
387 $ ap( i+( k-2 )*( k-1 ) / 2 )*wkm1
388 40 CONTINUE
389 ap( j+( k-1 )*k / 2 ) = wk
390 ap( j+( k-2 )*( k-1 ) / 2 ) = wkm1
391 50 CONTINUE
392*
393 END IF
394 END IF
395 END IF
396*
397* Store details of the interchanges in IPIV
398*
399 IF( kstep.EQ.1 ) THEN
400 ipiv( k ) = kp
401 ELSE
402 ipiv( k ) = -kp
403 ipiv( k-1 ) = -kp
404 END IF
405*
406* Decrease K and return to the start of the main loop
407*
408 k = k - kstep
409 kc = knc - k
410 GO TO 10
411*
412 ELSE
413*
414* Factorize A as L*D*L**T using the lower triangle of A
415*
416* K is the main loop index, increasing from 1 to N in steps of
417* 1 or 2
418*
419 k = 1
420 kc = 1
421 npp = n*( n+1 ) / 2
422 60 CONTINUE
423 knc = kc
424*
425* If K > N, exit from loop
426*
427 IF( k.GT.n )
428 $ GO TO 110
429 kstep = 1
430*
431* Determine rows and columns to be interchanged and whether
432* a 1-by-1 or 2-by-2 pivot block will be used
433*
434 absakk = cabs1( ap( kc ) )
435*
436* IMAX is the row-index of the largest off-diagonal element in
437* column K, and COLMAX is its absolute value
438*
439 IF( k.LT.n ) THEN
440 imax = k + izamax( n-k, ap( kc+1 ), 1 )
441 colmax = cabs1( ap( kc+imax-k ) )
442 ELSE
443 colmax = zero
444 END IF
445*
446 IF( max( absakk, colmax ).EQ.zero ) THEN
447*
448* Column K is zero: set INFO and continue
449*
450 IF( info.EQ.0 )
451 $ info = k
452 kp = k
453 ELSE
454 IF( absakk.GE.alpha*colmax ) THEN
455*
456* no interchange, use 1-by-1 pivot block
457*
458 kp = k
459 ELSE
460*
461* JMAX is the column-index of the largest off-diagonal
462* element in row IMAX, and ROWMAX is its absolute value
463*
464 rowmax = zero
465 kx = kc + imax - k
466 DO 70 j = k, imax - 1
467 IF( cabs1( ap( kx ) ).GT.rowmax ) THEN
468 rowmax = cabs1( ap( kx ) )
469 jmax = j
470 END IF
471 kx = kx + n - j
472 70 CONTINUE
473 kpc = npp - ( n-imax+1 )*( n-imax+2 ) / 2 + 1
474 IF( imax.LT.n ) THEN
475 jmax = imax + izamax( n-imax, ap( kpc+1 ), 1 )
476 rowmax = max( rowmax, cabs1( ap( kpc+jmax-imax ) ) )
477 END IF
478*
479 IF( absakk.GE.alpha*colmax*( colmax / rowmax ) ) THEN
480*
481* no interchange, use 1-by-1 pivot block
482*
483 kp = k
484 ELSE IF( cabs1( ap( kpc ) ).GE.alpha*rowmax ) THEN
485*
486* interchange rows and columns K and IMAX, use 1-by-1
487* pivot block
488*
489 kp = imax
490 ELSE
491*
492* interchange rows and columns K+1 and IMAX, use 2-by-2
493* pivot block
494*
495 kp = imax
496 kstep = 2
497 END IF
498 END IF
499*
500 kk = k + kstep - 1
501 IF( kstep.EQ.2 )
502 $ knc = knc + n - k + 1
503 IF( kp.NE.kk ) THEN
504*
505* Interchange rows and columns KK and KP in the trailing
506* submatrix A(k:n,k:n)
507*
508 IF( kp.LT.n )
509 $ CALL zswap( n-kp, ap( knc+kp-kk+1 ), 1, ap( kpc+1 ),
510 $ 1 )
511 kx = knc + kp - kk
512 DO 80 j = kk + 1, kp - 1
513 kx = kx + n - j + 1
514 t = ap( knc+j-kk )
515 ap( knc+j-kk ) = ap( kx )
516 ap( kx ) = t
517 80 CONTINUE
518 t = ap( knc )
519 ap( knc ) = ap( kpc )
520 ap( kpc ) = t
521 IF( kstep.EQ.2 ) THEN
522 t = ap( kc+1 )
523 ap( kc+1 ) = ap( kc+kp-k )
524 ap( kc+kp-k ) = t
525 END IF
526 END IF
527*
528* Update the trailing submatrix
529*
530 IF( kstep.EQ.1 ) THEN
531*
532* 1-by-1 pivot block D(k): column k now holds
533*
534* W(k) = L(k)*D(k)
535*
536* where L(k) is the k-th column of L
537*
538 IF( k.LT.n ) THEN
539*
540* Perform a rank-1 update of A(k+1:n,k+1:n) as
541*
542* A := A - L(k)*D(k)*L(k)**T = A - W(k)*(1/D(k))*W(k)**T
543*
544 r1 = cone / ap( kc )
545 CALL zspr( uplo, n-k, -r1, ap( kc+1 ), 1,
546 $ ap( kc+n-k+1 ) )
547*
548* Store L(k) in column K
549*
550 CALL zscal( n-k, r1, ap( kc+1 ), 1 )
551 END IF
552 ELSE
553*
554* 2-by-2 pivot block D(k): columns K and K+1 now hold
555*
556* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
557*
558* where L(k) and L(k+1) are the k-th and (k+1)-th columns
559* of L
560*
561 IF( k.LT.n-1 ) THEN
562*
563* Perform a rank-2 update of A(k+2:n,k+2:n) as
564*
565* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**T
566* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**T
567*
568* where L(k) and L(k+1) are the k-th and (k+1)-th
569* columns of L
570*
571 d21 = ap( k+1+( k-1 )*( 2*n-k ) / 2 )
572 d11 = ap( k+1+k*( 2*n-k-1 ) / 2 ) / d21
573 d22 = ap( k+( k-1 )*( 2*n-k ) / 2 ) / d21
574 t = cone / ( d11*d22-cone )
575 d21 = t / d21
576*
577 DO 100 j = k + 2, n
578 wk = d21*( d11*ap( j+( k-1 )*( 2*n-k ) / 2 )-
579 $ ap( j+k*( 2*n-k-1 ) / 2 ) )
580 wkp1 = d21*( d22*ap( j+k*( 2*n-k-1 ) / 2 )-
581 $ ap( j+( k-1 )*( 2*n-k ) / 2 ) )
582 DO 90 i = j, n
583 ap( i+( j-1 )*( 2*n-j ) / 2 ) = ap( i+( j-1 )*
584 $ ( 2*n-j ) / 2 ) - ap( i+( k-1 )*( 2*n-k ) /
585 $ 2 )*wk - ap( i+k*( 2*n-k-1 ) / 2 )*wkp1
586 90 CONTINUE
587 ap( j+( k-1 )*( 2*n-k ) / 2 ) = wk
588 ap( j+k*( 2*n-k-1 ) / 2 ) = wkp1
589 100 CONTINUE
590 END IF
591 END IF
592 END IF
593*
594* Store details of the interchanges in IPIV
595*
596 IF( kstep.EQ.1 ) THEN
597 ipiv( k ) = kp
598 ELSE
599 ipiv( k ) = -kp
600 ipiv( k+1 ) = -kp
601 END IF
602*
603* Increase K and return to the start of the main loop
604*
605 k = k + kstep
606 kc = knc + n - k + 2
607 GO TO 60
608*
609 END IF
610*
611 110 CONTINUE
612 RETURN
613*
614* End of ZSPTRF
615*
zspr
subroutine zspr(uplo, n, alpha, x, incx, ap)
ZSPR performs the symmetrical rank-1 update of a complex symmetric packed matrix.
Definition zspr.f:132

◆ zsptri()

subroutine zsptri ( character uplo,
integer n,
complex*16, dimension( * ) ap,
integer, dimension( * ) ipiv,
complex*16, dimension( * ) work,
integer info )

ZSPTRI

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

Purpose:
!>
!> ZSPTRI computes the inverse of a complex symmetric indefinite matrix
!> A in packed storage using the factorization A = U*D*U**T or
!> A = L*D*L**T computed by ZSPTRF.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[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 block diagonal matrix D and the multipliers
!>          used to obtain the factor U or L as computed by ZSPTRF,
!>          stored as a packed triangular matrix.
!>
!>          On exit, if INFO = 0, the (symmetric) inverse of the original
!>          matrix, stored as a packed triangular matrix. The j-th column
!>          of inv(A) is stored in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
!>          if UPLO = 'L',
!>             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZSPTRF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
!>               inverse could not be computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 108 of file zsptri.f.

109*
110* -- LAPACK computational 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 UPLO
116 INTEGER INFO, N
117* ..
118* .. Array Arguments ..
119 INTEGER IPIV( * )
120 COMPLEX*16 AP( * ), WORK( * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 COMPLEX*16 ONE, ZERO
127 parameter( one = ( 1.0d+0, 0.0d+0 ),
128 $ zero = ( 0.0d+0, 0.0d+0 ) )
129* ..
130* .. Local Scalars ..
131 LOGICAL UPPER
132 INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
133 COMPLEX*16 AK, AKKP1, AKP1, D, T, TEMP
134* ..
135* .. External Functions ..
136 LOGICAL LSAME
137 COMPLEX*16 ZDOTU
138 EXTERNAL lsame, zdotu
139* ..
140* .. External Subroutines ..
141 EXTERNAL xerbla, zcopy, zspmv, zswap
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC abs
145* ..
146* .. Executable Statements ..
147*
148* Test the input parameters.
149*
150 info = 0
151 upper = lsame( uplo, 'U' )
152 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
153 info = -1
154 ELSE IF( n.LT.0 ) THEN
155 info = -2
156 END IF
157 IF( info.NE.0 ) THEN
158 CALL xerbla( 'ZSPTRI', -info )
159 RETURN
160 END IF
161*
162* Quick return if possible
163*
164 IF( n.EQ.0 )
165 $ RETURN
166*
167* Check that the diagonal matrix D is nonsingular.
168*
169 IF( upper ) THEN
170*
171* Upper triangular storage: examine D from bottom to top
172*
173 kp = n*( n+1 ) / 2
174 DO 10 info = n, 1, -1
175 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
176 $ RETURN
177 kp = kp - info
178 10 CONTINUE
179 ELSE
180*
181* Lower triangular storage: examine D from top to bottom.
182*
183 kp = 1
184 DO 20 info = 1, n
185 IF( ipiv( info ).GT.0 .AND. ap( kp ).EQ.zero )
186 $ RETURN
187 kp = kp + n - info + 1
188 20 CONTINUE
189 END IF
190 info = 0
191*
192 IF( upper ) THEN
193*
194* Compute inv(A) from the factorization A = U*D*U**T.
195*
196* K is the main loop index, increasing from 1 to N in steps of
197* 1 or 2, depending on the size of the diagonal blocks.
198*
199 k = 1
200 kc = 1
201 30 CONTINUE
202*
203* If K > N, exit from loop.
204*
205 IF( k.GT.n )
206 $ GO TO 50
207*
208 kcnext = kc + k
209 IF( ipiv( k ).GT.0 ) THEN
210*
211* 1 x 1 diagonal block
212*
213* Invert the diagonal block.
214*
215 ap( kc+k-1 ) = one / ap( kc+k-1 )
216*
217* Compute column K of the inverse.
218*
219 IF( k.GT.1 ) THEN
220 CALL zcopy( k-1, ap( kc ), 1, work, 1 )
221 CALL zspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
222 $ 1 )
223 ap( kc+k-1 ) = ap( kc+k-1 ) -
224 $ zdotu( k-1, work, 1, ap( kc ), 1 )
225 END IF
226 kstep = 1
227 ELSE
228*
229* 2 x 2 diagonal block
230*
231* Invert the diagonal block.
232*
233 t = ap( kcnext+k-1 )
234 ak = ap( kc+k-1 ) / t
235 akp1 = ap( kcnext+k ) / t
236 akkp1 = ap( kcnext+k-1 ) / t
237 d = t*( ak*akp1-one )
238 ap( kc+k-1 ) = akp1 / d
239 ap( kcnext+k ) = ak / d
240 ap( kcnext+k-1 ) = -akkp1 / d
241*
242* Compute columns K and K+1 of the inverse.
243*
244 IF( k.GT.1 ) THEN
245 CALL zcopy( k-1, ap( kc ), 1, work, 1 )
246 CALL zspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
247 $ 1 )
248 ap( kc+k-1 ) = ap( kc+k-1 ) -
249 $ zdotu( k-1, work, 1, ap( kc ), 1 )
250 ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -
251 $ zdotu( k-1, ap( kc ), 1, ap( kcnext ),
252 $ 1 )
253 CALL zcopy( k-1, ap( kcnext ), 1, work, 1 )
254 CALL zspmv( uplo, k-1, -one, ap, work, 1, zero,
255 $ ap( kcnext ), 1 )
256 ap( kcnext+k ) = ap( kcnext+k ) -
257 $ zdotu( k-1, work, 1, ap( kcnext ), 1 )
258 END IF
259 kstep = 2
260 kcnext = kcnext + k + 1
261 END IF
262*
263 kp = abs( ipiv( k ) )
264 IF( kp.NE.k ) THEN
265*
266* Interchange rows and columns K and KP in the leading
267* submatrix A(1:k+1,1:k+1)
268*
269 kpc = ( kp-1 )*kp / 2 + 1
270 CALL zswap( kp-1, ap( kc ), 1, ap( kpc ), 1 )
271 kx = kpc + kp - 1
272 DO 40 j = kp + 1, k - 1
273 kx = kx + j - 1
274 temp = ap( kc+j-1 )
275 ap( kc+j-1 ) = ap( kx )
276 ap( kx ) = temp
277 40 CONTINUE
278 temp = ap( kc+k-1 )
279 ap( kc+k-1 ) = ap( kpc+kp-1 )
280 ap( kpc+kp-1 ) = temp
281 IF( kstep.EQ.2 ) THEN
282 temp = ap( kc+k+k-1 )
283 ap( kc+k+k-1 ) = ap( kc+k+kp-1 )
284 ap( kc+k+kp-1 ) = temp
285 END IF
286 END IF
287*
288 k = k + kstep
289 kc = kcnext
290 GO TO 30
291 50 CONTINUE
292*
293 ELSE
294*
295* Compute inv(A) from the factorization A = L*D*L**T.
296*
297* K is the main loop index, increasing from 1 to N in steps of
298* 1 or 2, depending on the size of the diagonal blocks.
299*
300 npp = n*( n+1 ) / 2
301 k = n
302 kc = npp
303 60 CONTINUE
304*
305* If K < 1, exit from loop.
306*
307 IF( k.LT.1 )
308 $ GO TO 80
309*
310 kcnext = kc - ( n-k+2 )
311 IF( ipiv( k ).GT.0 ) THEN
312*
313* 1 x 1 diagonal block
314*
315* Invert the diagonal block.
316*
317 ap( kc ) = one / ap( kc )
318*
319* Compute column K of the inverse.
320*
321 IF( k.LT.n ) THEN
322 CALL zcopy( n-k, ap( kc+1 ), 1, work, 1 )
323 CALL zspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1,
324 $ zero, ap( kc+1 ), 1 )
325 ap( kc ) = ap( kc ) - zdotu( n-k, work, 1, ap( kc+1 ),
326 $ 1 )
327 END IF
328 kstep = 1
329 ELSE
330*
331* 2 x 2 diagonal block
332*
333* Invert the diagonal block.
334*
335 t = ap( kcnext+1 )
336 ak = ap( kcnext ) / t
337 akp1 = ap( kc ) / t
338 akkp1 = ap( kcnext+1 ) / t
339 d = t*( ak*akp1-one )
340 ap( kcnext ) = akp1 / d
341 ap( kc ) = ak / d
342 ap( kcnext+1 ) = -akkp1 / d
343*
344* Compute columns K-1 and K of the inverse.
345*
346 IF( k.LT.n ) THEN
347 CALL zcopy( n-k, ap( kc+1 ), 1, work, 1 )
348 CALL zspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
349 $ zero, ap( kc+1 ), 1 )
350 ap( kc ) = ap( kc ) - zdotu( n-k, work, 1, ap( kc+1 ),
351 $ 1 )
352 ap( kcnext+1 ) = ap( kcnext+1 ) -
353 $ zdotu( n-k, ap( kc+1 ), 1,
354 $ ap( kcnext+2 ), 1 )
355 CALL zcopy( n-k, ap( kcnext+2 ), 1, work, 1 )
356 CALL zspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
357 $ zero, ap( kcnext+2 ), 1 )
358 ap( kcnext ) = ap( kcnext ) -
359 $ zdotu( n-k, work, 1, ap( kcnext+2 ), 1 )
360 END IF
361 kstep = 2
362 kcnext = kcnext - ( n-k+3 )
363 END IF
364*
365 kp = abs( ipiv( k ) )
366 IF( kp.NE.k ) THEN
367*
368* Interchange rows and columns K and KP in the trailing
369* submatrix A(k-1:n,k-1:n)
370*
371 kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2 + 1
372 IF( kp.LT.n )
373 $ CALL zswap( n-kp, ap( kc+kp-k+1 ), 1, ap( kpc+1 ), 1 )
374 kx = kc + kp - k
375 DO 70 j = k + 1, kp - 1
376 kx = kx + n - j + 1
377 temp = ap( kc+j-k )
378 ap( kc+j-k ) = ap( kx )
379 ap( kx ) = temp
380 70 CONTINUE
381 temp = ap( kc )
382 ap( kc ) = ap( kpc )
383 ap( kpc ) = temp
384 IF( kstep.EQ.2 ) THEN
385 temp = ap( kc-n+k-1 )
386 ap( kc-n+k-1 ) = ap( kc-n+kp-1 )
387 ap( kc-n+kp-1 ) = temp
388 END IF
389 END IF
390*
391 k = k - kstep
392 kc = kcnext
393 GO TO 60
394 80 CONTINUE
395 END IF
396*
397 RETURN
398*
399* End of ZSPTRI
400*
zdotu
complex *16 function zdotu(n, zx, incx, zy, incy)
ZDOTU
Definition zdotu.f:83

◆ zsptrs()

subroutine zsptrs ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
integer, dimension( * ) ipiv,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZSPTRS

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

Purpose:
!>
!> ZSPTRS solves a system of linear equations A*X = B with a complex
!> symmetric matrix A stored in packed format using the factorization
!> A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are stored
!>          as an upper or lower triangular matrix.
!>          = 'U':  Upper triangular, form is A = U*D*U**T;
!>          = 'L':  Lower triangular, form is A = L*D*L**T.
!>
[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 matrix B.  NRHS >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZSPTRF, stored as a
!>          packed triangular matrix.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by ZSPTRF.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 114 of file zsptrs.f.

115*
116* -- LAPACK computational 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 UPLO
122 INTEGER INFO, LDB, N, NRHS
123* ..
124* .. Array Arguments ..
125 INTEGER IPIV( * )
126 COMPLEX*16 AP( * ), B( LDB, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 COMPLEX*16 ONE
133 parameter( one = ( 1.0d+0, 0.0d+0 ) )
134* ..
135* .. Local Scalars ..
136 LOGICAL UPPER
137 INTEGER J, K, KC, KP
138 COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
139* ..
140* .. External Functions ..
141 LOGICAL LSAME
142 EXTERNAL lsame
143* ..
144* .. External Subroutines ..
145 EXTERNAL xerbla, zgemv, zgeru, zscal, zswap
146* ..
147* .. Intrinsic Functions ..
148 INTRINSIC max
149* ..
150* .. Executable Statements ..
151*
152 info = 0
153 upper = lsame( uplo, 'U' )
154 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
155 info = -1
156 ELSE IF( n.LT.0 ) THEN
157 info = -2
158 ELSE IF( nrhs.LT.0 ) THEN
159 info = -3
160 ELSE IF( ldb.LT.max( 1, n ) ) THEN
161 info = -7
162 END IF
163 IF( info.NE.0 ) THEN
164 CALL xerbla( 'ZSPTRS', -info )
165 RETURN
166 END IF
167*
168* Quick return if possible
169*
170 IF( n.EQ.0 .OR. nrhs.EQ.0 )
171 $ RETURN
172*
173 IF( upper ) THEN
174*
175* Solve A*X = B, where A = U*D*U**T.
176*
177* First solve U*D*X = B, overwriting B with X.
178*
179* K is the main loop index, decreasing from N to 1 in steps of
180* 1 or 2, depending on the size of the diagonal blocks.
181*
182 k = n
183 kc = n*( n+1 ) / 2 + 1
184 10 CONTINUE
185*
186* If K < 1, exit from loop.
187*
188 IF( k.LT.1 )
189 $ GO TO 30
190*
191 kc = kc - k
192 IF( ipiv( k ).GT.0 ) THEN
193*
194* 1 x 1 diagonal block
195*
196* Interchange rows K and IPIV(K).
197*
198 kp = ipiv( k )
199 IF( kp.NE.k )
200 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
201*
202* Multiply by inv(U(K)), where U(K) is the transformation
203* stored in column K of A.
204*
205 CALL zgeru( k-1, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
206 $ b( 1, 1 ), ldb )
207*
208* Multiply by the inverse of the diagonal block.
209*
210 CALL zscal( nrhs, one / ap( kc+k-1 ), b( k, 1 ), ldb )
211 k = k - 1
212 ELSE
213*
214* 2 x 2 diagonal block
215*
216* Interchange rows K-1 and -IPIV(K).
217*
218 kp = -ipiv( k )
219 IF( kp.NE.k-1 )
220 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb )
221*
222* Multiply by inv(U(K)), where U(K) is the transformation
223* stored in columns K-1 and K of A.
224*
225 CALL zgeru( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
226 $ b( 1, 1 ), ldb )
227 CALL zgeru( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1,
228 $ b( k-1, 1 ), ldb, b( 1, 1 ), ldb )
229*
230* Multiply by the inverse of the diagonal block.
231*
232 akm1k = ap( kc+k-2 )
233 akm1 = ap( kc-1 ) / akm1k
234 ak = ap( kc+k-1 ) / akm1k
235 denom = akm1*ak - one
236 DO 20 j = 1, nrhs
237 bkm1 = b( k-1, j ) / akm1k
238 bk = b( k, j ) / akm1k
239 b( k-1, j ) = ( ak*bkm1-bk ) / denom
240 b( k, j ) = ( akm1*bk-bkm1 ) / denom
241 20 CONTINUE
242 kc = kc - k + 1
243 k = k - 2
244 END IF
245*
246 GO TO 10
247 30 CONTINUE
248*
249* Next solve U**T*X = B, overwriting B with X.
250*
251* K is the main loop index, increasing from 1 to N in steps of
252* 1 or 2, depending on the size of the diagonal blocks.
253*
254 k = 1
255 kc = 1
256 40 CONTINUE
257*
258* If K > N, exit from loop.
259*
260 IF( k.GT.n )
261 $ GO TO 50
262*
263 IF( ipiv( k ).GT.0 ) THEN
264*
265* 1 x 1 diagonal block
266*
267* Multiply by inv(U**T(K)), where U(K) is the transformation
268* stored in column K of A.
269*
270 CALL zgemv( 'Transpose', k-1, nrhs, -one, b, ldb, ap( kc ),
271 $ 1, one, b( k, 1 ), ldb )
272*
273* Interchange rows K and IPIV(K).
274*
275 kp = ipiv( k )
276 IF( kp.NE.k )
277 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
278 kc = kc + k
279 k = k + 1
280 ELSE
281*
282* 2 x 2 diagonal block
283*
284* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
285* stored in columns K and K+1 of A.
286*
287 CALL zgemv( 'Transpose', k-1, nrhs, -one, b, ldb, ap( kc ),
288 $ 1, one, b( k, 1 ), ldb )
289 CALL zgemv( 'Transpose', k-1, nrhs, -one, b, ldb,
290 $ ap( kc+k ), 1, one, b( k+1, 1 ), ldb )
291*
292* Interchange rows K and -IPIV(K).
293*
294 kp = -ipiv( k )
295 IF( kp.NE.k )
296 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
297 kc = kc + 2*k + 1
298 k = k + 2
299 END IF
300*
301 GO TO 40
302 50 CONTINUE
303*
304 ELSE
305*
306* Solve A*X = B, where A = L*D*L**T.
307*
308* First solve L*D*X = B, overwriting B with X.
309*
310* K is the main loop index, increasing from 1 to N in steps of
311* 1 or 2, depending on the size of the diagonal blocks.
312*
313 k = 1
314 kc = 1
315 60 CONTINUE
316*
317* If K > N, exit from loop.
318*
319 IF( k.GT.n )
320 $ GO TO 80
321*
322 IF( ipiv( k ).GT.0 ) THEN
323*
324* 1 x 1 diagonal block
325*
326* Interchange rows K and IPIV(K).
327*
328 kp = ipiv( k )
329 IF( kp.NE.k )
330 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
331*
332* Multiply by inv(L(K)), where L(K) is the transformation
333* stored in column K of A.
334*
335 IF( k.LT.n )
336 $ CALL zgeru( n-k, nrhs, -one, ap( kc+1 ), 1, b( k, 1 ),
337 $ ldb, b( k+1, 1 ), ldb )
338*
339* Multiply by the inverse of the diagonal block.
340*
341 CALL zscal( nrhs, one / ap( kc ), b( k, 1 ), ldb )
342 kc = kc + n - k + 1
343 k = k + 1
344 ELSE
345*
346* 2 x 2 diagonal block
347*
348* Interchange rows K+1 and -IPIV(K).
349*
350 kp = -ipiv( k )
351 IF( kp.NE.k+1 )
352 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb )
353*
354* Multiply by inv(L(K)), where L(K) is the transformation
355* stored in columns K and K+1 of A.
356*
357 IF( k.LT.n-1 ) THEN
358 CALL zgeru( n-k-1, nrhs, -one, ap( kc+2 ), 1, b( k, 1 ),
359 $ ldb, b( k+2, 1 ), ldb )
360 CALL zgeru( n-k-1, nrhs, -one, ap( kc+n-k+2 ), 1,
361 $ b( k+1, 1 ), ldb, b( k+2, 1 ), ldb )
362 END IF
363*
364* Multiply by the inverse of the diagonal block.
365*
366 akm1k = ap( kc+1 )
367 akm1 = ap( kc ) / akm1k
368 ak = ap( kc+n-k+1 ) / akm1k
369 denom = akm1*ak - one
370 DO 70 j = 1, nrhs
371 bkm1 = b( k, j ) / akm1k
372 bk = b( k+1, j ) / akm1k
373 b( k, j ) = ( ak*bkm1-bk ) / denom
374 b( k+1, j ) = ( akm1*bk-bkm1 ) / denom
375 70 CONTINUE
376 kc = kc + 2*( n-k ) + 1
377 k = k + 2
378 END IF
379*
380 GO TO 60
381 80 CONTINUE
382*
383* Next solve L**T*X = B, overwriting B with X.
384*
385* K is the main loop index, decreasing from N to 1 in steps of
386* 1 or 2, depending on the size of the diagonal blocks.
387*
388 k = n
389 kc = n*( n+1 ) / 2 + 1
390 90 CONTINUE
391*
392* If K < 1, exit from loop.
393*
394 IF( k.LT.1 )
395 $ GO TO 100
396*
397 kc = kc - ( n-k+1 )
398 IF( ipiv( k ).GT.0 ) THEN
399*
400* 1 x 1 diagonal block
401*
402* Multiply by inv(L**T(K)), where L(K) is the transformation
403* stored in column K of A.
404*
405 IF( k.LT.n )
406 $ CALL zgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
407 $ ldb, ap( kc+1 ), 1, one, b( k, 1 ), ldb )
408*
409* Interchange rows K and IPIV(K).
410*
411 kp = ipiv( k )
412 IF( kp.NE.k )
413 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
414 k = k - 1
415 ELSE
416*
417* 2 x 2 diagonal block
418*
419* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
420* stored in columns K-1 and K of A.
421*
422 IF( k.LT.n ) THEN
423 CALL zgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
424 $ ldb, ap( kc+1 ), 1, one, b( k, 1 ), ldb )
425 CALL zgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
426 $ ldb, ap( kc-( n-k ) ), 1, one, b( k-1, 1 ),
427 $ ldb )
428 END IF
429*
430* Interchange rows K and -IPIV(K).
431*
432 kp = -ipiv( k )
433 IF( kp.NE.k )
434 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
435 kc = kc - ( n-k+2 )
436 k = k - 2
437 END IF
438*
439 GO TO 90
440 100 CONTINUE
441 END IF
442*
443 RETURN
444*
445* End of ZSPTRS
446*

◆ zstedc()

subroutine zstedc ( character compz,
integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldz, * ) z,
integer ldz,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer lrwork,
integer, dimension( * ) iwork,
integer liwork,
integer info )

ZSTEDC

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

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

Definition at line 210 of file zstedc.f.

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

◆ zstegr()

subroutine zstegr ( character jobz,
character range,
integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision vl,
double precision vu,
integer il,
integer iu,
double precision abstol,
integer m,
double precision, dimension( * ) w,
complex*16, dimension( ldz, * ) z,
integer ldz,
integer, dimension( * ) isuppz,
double precision, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer liwork,
integer info )

ZSTEGR

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

Purpose:
!>
!> ZSTEGR computes selected eigenvalues and, optionally, eigenvectors
!> of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!> a well defined set of pairwise different real eigenvalues, the corresponding
!> real eigenvectors are pairwise orthogonal.
!>
!> The spectrum may be computed either completely or partially by specifying
!> either an interval (VL,VU] or a range of indices IL:IU for the desired
!> eigenvalues.
!>
!> ZSTEGR is a compatibility wrapper around the improved ZSTEMR routine.
!> See ZSTEMR for further details.
!>
!> One important change is that the ABSTOL parameter no longer provides any
!> benefit and hence is no longer used.
!>
!> Note : ZSTEGR and ZSTEMR work only on machines which follow
!> IEEE-754 floating-point standard in their handling of infinities and
!> NaNs.  Normal execution may create these exceptiona values and hence
!> may abort due to a floating point exception in environments which
!> do not conform to the IEEE-754 standard.
!>
Parameters
[in]JOBZ
!>          JOBZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only;
!>          = 'V':  Compute eigenvalues and eigenvectors.
!>
[in]RANGE
!>          RANGE is CHARACTER*1
!>          = 'A': all eigenvalues will be found.
!>          = 'V': all eigenvalues in the half-open interval (VL,VU]
!>                 will be found.
!>          = 'I': the IL-th through IU-th eigenvalues will be found.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the N diagonal elements of the tridiagonal matrix
!>          T. On exit, D is overwritten.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N)
!>          On entry, the (N-1) subdiagonal elements of the tridiagonal
!>          matrix T in elements 1 to N-1 of E. E(N) need not be set on
!>          input, but is used internally as workspace.
!>          On exit, E is overwritten.
!>
[in]VL
!>          VL is DOUBLE PRECISION
!>
!>          If RANGE='V', the lower bound of the interval to
!>          be searched for eigenvalues. VL < VU.
!>          Not referenced if RANGE = 'A' or 'I'.
!>
[in]VU
!>          VU is DOUBLE PRECISION
!>
!>          If RANGE='V', the upper bound of the interval to
!>          be searched for eigenvalues. VL < VU.
!>          Not referenced if RANGE = 'A' or 'I'.
!>
[in]IL
!>          IL is INTEGER
!>
!>          If RANGE='I', the index of the
!>          smallest eigenvalue to be returned.
!>          1 <= IL <= IU <= N, if N > 0.
!>          Not referenced if RANGE = 'A' or 'V'.
!>
[in]IU
!>          IU is INTEGER
!>
!>          If RANGE='I', the index of the
!>          largest eigenvalue to be returned.
!>          1 <= IL <= IU <= N, if N > 0.
!>          Not referenced if RANGE = 'A' or 'V'.
!>
[in]ABSTOL
!>          ABSTOL is DOUBLE PRECISION
!>          Unused.  Was the absolute error tolerance for the
!>          eigenvalues/eigenvectors in previous versions.
!>
[out]M
!>          M is INTEGER
!>          The total number of eigenvalues found.  0 <= M <= N.
!>          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!>
[out]W
!>          W is DOUBLE PRECISION array, dimension (N)
!>          The first M elements contain the selected eigenvalues in
!>          ascending order.
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension (LDZ, max(1,M) )
!>          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
!>          contain the orthonormal eigenvectors of the matrix T
!>          corresponding to the selected eigenvalues, with the i-th
!>          column of Z holding the eigenvector associated with W(i).
!>          If JOBZ = 'N', then Z is not referenced.
!>          Note: the user must ensure that at least max(1,M) columns are
!>          supplied in the array Z; if RANGE = 'V', the exact value of M
!>          is not known in advance and an upper bound must be used.
!>          Supplying N columns is always safe.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1, and if
!>          JOBZ = 'V', then 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 computed eigenvector
!>          is nonzero only in elements ISUPPZ( 2*i-1 ) through
!>          ISUPPZ( 2*i ). This is relevant in the case when the matrix
!>          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>          On exit, if INFO = 0, WORK(1) returns the optimal
!>          (and minimal) LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,18*N)
!>          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (LIWORK)
!>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!>
[in]LIWORK
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
!>          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
!>          if only the eigenvalues are to be computed.
!>          If LIWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the IWORK array,
!>          returns this value as the first entry of the IWORK array, and
!>          no error message related to LIWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          On exit, INFO
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = 1X, internal error in DLARRE,
!>                if INFO = 2X, internal error in ZLARRV.
!>                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
!>                the nonzero error code returned by DLARRE or
!>                ZLARRV, respectively.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Inderjit Dhillon, IBM Almaden, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, LBNL/NERSC, USA

Definition at line 262 of file zstegr.f.

265*
266* -- LAPACK computational routine --
267* -- LAPACK is a software package provided by Univ. of Tennessee, --
268* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
269*
270* .. Scalar Arguments ..
271 CHARACTER JOBZ, RANGE
272 INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
273 DOUBLE PRECISION ABSTOL, VL, VU
274* ..
275* .. Array Arguments ..
276 INTEGER ISUPPZ( * ), IWORK( * )
277 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
278 COMPLEX*16 Z( LDZ, * )
279* ..
280*
281* =====================================================================
282*
283* .. Local Scalars ..
284 LOGICAL TRYRAC
285* ..
286* .. External Subroutines ..
287 EXTERNAL zstemr
288* ..
289* .. Executable Statements ..
290 info = 0
291 tryrac = .false.
292
293 CALL zstemr( jobz, range, n, d, e, vl, vu, il, iu,
294 $ m, w, z, ldz, n, isuppz, tryrac, work, lwork,
295 $ iwork, liwork, info )
296*
297* End of ZSTEGR
298*
zstemr
subroutine zstemr(jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
ZSTEMR
Definition zstemr.f:338

◆ zstein()

subroutine zstein ( integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
integer m,
double precision, dimension( * ) w,
integer, dimension( * ) iblock,
integer, dimension( * ) isplit,
complex*16, dimension( ldz, * ) z,
integer ldz,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer, dimension( * ) ifail,
integer info )

ZSTEIN

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

Purpose:
!>
!> ZSTEIN computes the eigenvectors of a real symmetric tridiagonal
!> matrix T corresponding to specified eigenvalues, using inverse
!> iteration.
!>
!> The maximum number of iterations allowed for each eigenvector is
!> specified by an internal parameter MAXITS (currently set to 5).
!>
!> Although the eigenvectors are real, they are stored in a complex
!> array, which may be passed to ZUNMTR or ZUPMTR for back
!> transformation to the eigenvectors of a complex Hermitian matrix
!> which was reduced to tridiagonal form.
!>
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix T.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) subdiagonal elements of the tridiagonal matrix
!>          T, stored in elements 1 to N-1.
!>
[in]M
!>          M is INTEGER
!>          The number of eigenvectors to be found.  0 <= M <= N.
!>
[in]W
!>          W is DOUBLE PRECISION array, dimension (N)
!>          The first M elements of W contain the 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 DSTEBZ with ORDER = 'B' is expected here. )
!>
[in]IBLOCK
!>          IBLOCK is INTEGER array, dimension (N)
!>          The submatrix indices associated with the corresponding
!>          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
!>          the first submatrix from the top, =2 if W(i) belongs to
!>          the second submatrix, etc.  ( The output array IBLOCK
!>          from DSTEBZ is expected here. )
!>
[in]ISPLIT
!>          ISPLIT is INTEGER array, dimension (N)
!>          The splitting points, at which T breaks up into submatrices.
!>          The first submatrix consists of rows/columns 1 to
!>          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
!>          through ISPLIT( 2 ), etc.
!>          ( The output array ISPLIT from DSTEBZ is expected here. )
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension (LDZ, M)
!>          The computed eigenvectors.  The eigenvector associated
!>          with the eigenvalue W(i) is stored in the i-th column of
!>          Z.  Any vector which fails to converge is set to its current
!>          iterate after MAXITS iterations.
!>          The imaginary parts of the eigenvectors are set to zero.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= max(1,N).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (5*N)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N)
!>
[out]IFAIL
!>          IFAIL is INTEGER array, dimension (M)
!>          On normal exit, all elements of IFAIL are zero.
!>          If one or more eigenvectors fail to converge after
!>          MAXITS iterations, then their indices are stored in
!>          array IFAIL.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, then i eigenvectors failed to converge
!>               in MAXITS iterations.  Their indices are stored in
!>               array IFAIL.
!>
Internal Parameters:
!>  MAXITS  INTEGER, default = 5
!>          The maximum number of iterations performed.
!>
!>  EXTRA   INTEGER, default = 2
!>          The number of iterations performed after norm growth
!>          criterion is satisfied, should be at least 1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 180 of file zstein.f.

182*
183* -- LAPACK computational routine --
184* -- LAPACK is a software package provided by Univ. of Tennessee, --
185* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
186*
187* .. Scalar Arguments ..
188 INTEGER INFO, LDZ, M, N
189* ..
190* .. Array Arguments ..
191 INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
192 $ IWORK( * )
193 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
194 COMPLEX*16 Z( LDZ, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 COMPLEX*16 CZERO, CONE
201 parameter( czero = ( 0.0d+0, 0.0d+0 ),
202 $ cone = ( 1.0d+0, 0.0d+0 ) )
203 DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1
204 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 1.0d+1,
205 $ odm3 = 1.0d-3, odm1 = 1.0d-1 )
206 INTEGER MAXITS, EXTRA
207 parameter( maxits = 5, extra = 2 )
208* ..
209* .. Local Scalars ..
210 INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
211 $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
212 $ JBLK, JMAX, JR, NBLK, NRMCHK
213 DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
214 $ SCL, SEP, TOL, XJ, XJM, ZTR
215* ..
216* .. Local Arrays ..
217 INTEGER ISEED( 4 )
218* ..
219* .. External Functions ..
220 INTEGER IDAMAX
221 DOUBLE PRECISION DLAMCH, DNRM2
222 EXTERNAL idamax, dlamch, dnrm2
223* ..
224* .. External Subroutines ..
225 EXTERNAL dcopy, dlagtf, dlagts, dlarnv, dscal, xerbla
226* ..
227* .. Intrinsic Functions ..
228 INTRINSIC abs, dble, dcmplx, max, sqrt
229* ..
230* .. Executable Statements ..
231*
232* Test the input parameters.
233*
234 info = 0
235 DO 10 i = 1, m
236 ifail( i ) = 0
237 10 CONTINUE
238*
239 IF( n.LT.0 ) THEN
240 info = -1
241 ELSE IF( m.LT.0 .OR. m.GT.n ) THEN
242 info = -4
243 ELSE IF( ldz.LT.max( 1, n ) ) THEN
244 info = -9
245 ELSE
246 DO 20 j = 2, m
247 IF( iblock( j ).LT.iblock( j-1 ) ) THEN
248 info = -6
249 GO TO 30
250 END IF
251 IF( iblock( j ).EQ.iblock( j-1 ) .AND. w( j ).LT.w( j-1 ) )
252 $ THEN
253 info = -5
254 GO TO 30
255 END IF
256 20 CONTINUE
257 30 CONTINUE
258 END IF
259*
260 IF( info.NE.0 ) THEN
261 CALL xerbla( 'ZSTEIN', -info )
262 RETURN
263 END IF
264*
265* Quick return if possible
266*
267 IF( n.EQ.0 .OR. m.EQ.0 ) THEN
268 RETURN
269 ELSE IF( n.EQ.1 ) THEN
270 z( 1, 1 ) = cone
271 RETURN
272 END IF
273*
274* Get machine constants.
275*
276 eps = dlamch( 'Precision' )
277*
278* Initialize seed for random number generator DLARNV.
279*
280 DO 40 i = 1, 4
281 iseed( i ) = 1
282 40 CONTINUE
283*
284* Initialize pointers.
285*
286 indrv1 = 0
287 indrv2 = indrv1 + n
288 indrv3 = indrv2 + n
289 indrv4 = indrv3 + n
290 indrv5 = indrv4 + n
291*
292* Compute eigenvectors of matrix blocks.
293*
294 j1 = 1
295 DO 180 nblk = 1, iblock( m )
296*
297* Find starting and ending indices of block nblk.
298*
299 IF( nblk.EQ.1 ) THEN
300 b1 = 1
301 ELSE
302 b1 = isplit( nblk-1 ) + 1
303 END IF
304 bn = isplit( nblk )
305 blksiz = bn - b1 + 1
306 IF( blksiz.EQ.1 )
307 $ GO TO 60
308 gpind = j1
309*
310* Compute reorthogonalization criterion and stopping criterion.
311*
312 onenrm = abs( d( b1 ) ) + abs( e( b1 ) )
313 onenrm = max( onenrm, abs( d( bn ) )+abs( e( bn-1 ) ) )
314 DO 50 i = b1 + 1, bn - 1
315 onenrm = max( onenrm, abs( d( i ) )+abs( e( i-1 ) )+
316 $ abs( e( i ) ) )
317 50 CONTINUE
318 ortol = odm3*onenrm
319*
320 dtpcrt = sqrt( odm1 / blksiz )
321*
322* Loop through eigenvalues of block nblk.
323*
324 60 CONTINUE
325 jblk = 0
326 DO 170 j = j1, m
327 IF( iblock( j ).NE.nblk ) THEN
328 j1 = j
329 GO TO 180
330 END IF
331 jblk = jblk + 1
332 xj = w( j )
333*
334* Skip all the work if the block size is one.
335*
336 IF( blksiz.EQ.1 ) THEN
337 work( indrv1+1 ) = one
338 GO TO 140
339 END IF
340*
341* If eigenvalues j and j-1 are too close, add a relatively
342* small perturbation.
343*
344 IF( jblk.GT.1 ) THEN
345 eps1 = abs( eps*xj )
346 pertol = ten*eps1
347 sep = xj - xjm
348 IF( sep.LT.pertol )
349 $ xj = xjm + pertol
350 END IF
351*
352 its = 0
353 nrmchk = 0
354*
355* Get random starting vector.
356*
357 CALL dlarnv( 2, iseed, blksiz, work( indrv1+1 ) )
358*
359* Copy the matrix T so it won't be destroyed in factorization.
360*
361 CALL dcopy( blksiz, d( b1 ), 1, work( indrv4+1 ), 1 )
362 CALL dcopy( blksiz-1, e( b1 ), 1, work( indrv2+2 ), 1 )
363 CALL dcopy( blksiz-1, e( b1 ), 1, work( indrv3+1 ), 1 )
364*
365* Compute LU factors with partial pivoting ( PT = LU )
366*
367 tol = zero
368 CALL dlagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),
369 $ work( indrv3+1 ), tol, work( indrv5+1 ), iwork,
370 $ iinfo )
371*
372* Update iteration count.
373*
374 70 CONTINUE
375 its = its + 1
376 IF( its.GT.maxits )
377 $ GO TO 120
378*
379* Normalize and scale the righthand side vector Pb.
380*
381 jmax = idamax( blksiz, work( indrv1+1 ), 1 )
382 scl = blksiz*onenrm*max( eps,
383 $ abs( work( indrv4+blksiz ) ) ) /
384 $ abs( work( indrv1+jmax ) )
385 CALL dscal( blksiz, scl, work( indrv1+1 ), 1 )
386*
387* Solve the system LU = Pb.
388*
389 CALL dlagts( -1, blksiz, work( indrv4+1 ), work( indrv2+2 ),
390 $ work( indrv3+1 ), work( indrv5+1 ), iwork,
391 $ work( indrv1+1 ), tol, iinfo )
392*
393* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
394* close enough.
395*
396 IF( jblk.EQ.1 )
397 $ GO TO 110
398 IF( abs( xj-xjm ).GT.ortol )
399 $ gpind = j
400 IF( gpind.NE.j ) THEN
401 DO 100 i = gpind, j - 1
402 ztr = zero
403 DO 80 jr = 1, blksiz
404 ztr = ztr + work( indrv1+jr )*
405 $ dble( z( b1-1+jr, i ) )
406 80 CONTINUE
407 DO 90 jr = 1, blksiz
408 work( indrv1+jr ) = work( indrv1+jr ) -
409 $ ztr*dble( z( b1-1+jr, i ) )
410 90 CONTINUE
411 100 CONTINUE
412 END IF
413*
414* Check the infinity norm of the iterate.
415*
416 110 CONTINUE
417 jmax = idamax( blksiz, work( indrv1+1 ), 1 )
418 nrm = abs( work( indrv1+jmax ) )
419*
420* Continue for additional iterations after norm reaches
421* stopping criterion.
422*
423 IF( nrm.LT.dtpcrt )
424 $ GO TO 70
425 nrmchk = nrmchk + 1
426 IF( nrmchk.LT.extra+1 )
427 $ GO TO 70
428*
429 GO TO 130
430*
431* If stopping criterion was not satisfied, update info and
432* store eigenvector number in array ifail.
433*
434 120 CONTINUE
435 info = info + 1
436 ifail( info ) = j
437*
438* Accept iterate as jth eigenvector.
439*
440 130 CONTINUE
441 scl = one / dnrm2( blksiz, work( indrv1+1 ), 1 )
442 jmax = idamax( blksiz, work( indrv1+1 ), 1 )
443 IF( work( indrv1+jmax ).LT.zero )
444 $ scl = -scl
445 CALL dscal( blksiz, scl, work( indrv1+1 ), 1 )
446 140 CONTINUE
447 DO 150 i = 1, n
448 z( i, j ) = czero
449 150 CONTINUE
450 DO 160 i = 1, blksiz
451 z( b1+i-1, j ) = dcmplx( work( indrv1+i ), zero )
452 160 CONTINUE
453*
454* Save the shift to check eigenvalue spacing at next
455* iteration.
456*
457 xjm = xj
458*
459 170 CONTINUE
460 180 CONTINUE
461*
462 RETURN
463*
464* End of ZSTEIN
465*
dlarnv
subroutine dlarnv(idist, iseed, n, x)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition dlarnv.f:97
dlagts
subroutine dlagts(job, n, a, b, c, d, in, y, tol, info)
DLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal ma...
Definition dlagts.f:161
dlagtf
subroutine dlagtf(n, a, lambda, b, c, tol, d, in, info)
DLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix,...
Definition dlagtf.f:156

◆ zstemr()

subroutine zstemr ( character jobz,
character range,
integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision vl,
double precision vu,
integer il,
integer iu,
integer m,
double precision, dimension( * ) w,
complex*16, dimension( ldz, * ) z,
integer ldz,
integer nzc,
integer, dimension( * ) isuppz,
logical tryrac,
double precision, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer liwork,
integer info )

ZSTEMR

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

Purpose:
!>
!> ZSTEMR computes selected eigenvalues and, optionally, eigenvectors
!> of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!> a well defined set of pairwise different real eigenvalues, the corresponding
!> real eigenvectors are pairwise orthogonal.
!>
!> The spectrum may be computed either completely or partially by specifying
!> either an interval (VL,VU] or a range of indices IL:IU for the desired
!> eigenvalues.
!>
!> Depending on the number of desired eigenvalues, these are computed either
!> by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
!> computed by the use of various suitable L D L^T factorizations near clusters
!> of close eigenvalues (referred to as RRRs, Relatively Robust
!> Representations). An informal sketch of the algorithm follows.
!>
!> For each unreduced block (submatrix) of T,
!>    (a) Compute T - sigma I  = L D L^T, so that L and D
!>        define all the wanted eigenvalues to high relative accuracy.
!>        This means that small relative changes in the entries of D and L
!>        cause only small relative changes in the eigenvalues and
!>        eigenvectors. The standard (unfactored) representation of the
!>        tridiagonal matrix T does not have this property in general.
!>    (b) Compute the eigenvalues to suitable accuracy.
!>        If the eigenvectors are desired, the algorithm attains full
!>        accuracy of the computed eigenvalues only right before
!>        the corresponding vectors have to be computed, see steps c) and d).
!>    (c) For each cluster of close eigenvalues, select a new
!>        shift close to the cluster, find a new factorization, and refine
!>        the shifted eigenvalues to suitable accuracy.
!>    (d) For each eigenvalue with a large enough relative separation compute
!>        the corresponding eigenvector by forming a rank revealing twisted
!>        factorization. Go back to (c) for any clusters that remain.
!>
!> For more details, see:
!> - Inderjit S. Dhillon and Beresford N. Parlett: 
!>   Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
!> - Inderjit Dhillon and Beresford Parlett:  SIAM Journal on Matrix Analysis and Applications, Vol. 25,
!>   2004.  Also LAPACK Working Note 154.
!> - Inderjit Dhillon: ,
!>   Computer Science Division Technical Report No. UCB/CSD-97-971,
!>   UC Berkeley, May 1997.
!>
!> Further Details
!> 1.ZSTEMR works only on machines which follow IEEE-754
!> floating-point standard in their handling of infinities and NaNs.
!> This permits the use of efficient inner loops avoiding a check for
!> zero divisors.
!>
!> 2. LAPACK routines can be used to reduce a complex Hermitean matrix to
!> real symmetric tridiagonal form.
!>
!> (Any complex Hermitean tridiagonal matrix has real values on its diagonal
!> and potentially complex numbers on its off-diagonals. By applying a
!> similarity transform with an appropriate diagonal matrix
!> diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean
!> matrix can be transformed into a real symmetric matrix and complex
!> arithmetic can be entirely avoided.)
!>
!> While the eigenvectors of the real symmetric tridiagonal matrix are real,
!> the eigenvectors of original complex Hermitean matrix have complex entries
!> in general.
!> Since LAPACK drivers overwrite the matrix data with the eigenvectors,
!> ZSTEMR accepts complex workspace to facilitate interoperability
!> with ZUNMTR or ZUPMTR.
!>
Parameters
[in]JOBZ
!>          JOBZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only;
!>          = 'V':  Compute eigenvalues and eigenvectors.
!>
[in]RANGE
!>          RANGE is CHARACTER*1
!>          = 'A': all eigenvalues will be found.
!>          = 'V': all eigenvalues in the half-open interval (VL,VU]
!>                 will be found.
!>          = 'I': the IL-th through IU-th eigenvalues will be found.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the N diagonal elements of the tridiagonal matrix
!>          T. On exit, D is overwritten.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N)
!>          On entry, the (N-1) subdiagonal elements of the tridiagonal
!>          matrix T in elements 1 to N-1 of E. E(N) need not be set on
!>          input, but is used internally as workspace.
!>          On exit, E is overwritten.
!>
[in]VL
!>          VL is DOUBLE PRECISION
!>
!>          If RANGE='V', the lower bound of the interval to
!>          be searched for eigenvalues. VL < VU.
!>          Not referenced if RANGE = 'A' or 'I'.
!>
[in]VU
!>          VU is DOUBLE PRECISION
!>
!>          If RANGE='V', the upper bound of the interval to
!>          be searched for eigenvalues. VL < VU.
!>          Not referenced if RANGE = 'A' or 'I'.
!>
[in]IL
!>          IL is INTEGER
!>
!>          If RANGE='I', the index of the
!>          smallest eigenvalue to be returned.
!>          1 <= IL <= IU <= N, if N > 0.
!>          Not referenced if RANGE = 'A' or 'V'.
!>
[in]IU
!>          IU is INTEGER
!>
!>          If RANGE='I', the index of the
!>          largest eigenvalue to be returned.
!>          1 <= IL <= IU <= N, if N > 0.
!>          Not referenced if RANGE = 'A' or 'V'.
!>
[out]M
!>          M is INTEGER
!>          The total number of eigenvalues found.  0 <= M <= N.
!>          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!>
[out]W
!>          W is DOUBLE PRECISION array, dimension (N)
!>          The first M elements contain the selected eigenvalues in
!>          ascending order.
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension (LDZ, max(1,M) )
!>          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
!>          contain the orthonormal eigenvectors of the matrix T
!>          corresponding to the selected eigenvalues, with the i-th
!>          column of Z holding the eigenvector associated with W(i).
!>          If JOBZ = 'N', then Z is not referenced.
!>          Note: the user must ensure that at least max(1,M) columns are
!>          supplied in the array Z; if RANGE = 'V', the exact value of M
!>          is not known in advance and can be computed with a workspace
!>          query by setting NZC = -1, see below.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1, and if
!>          JOBZ = 'V', then LDZ >= max(1,N).
!>
[in]NZC
!>          NZC is INTEGER
!>          The number of eigenvectors to be held in the array Z.
!>          If RANGE = 'A', then NZC >= max(1,N).
!>          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
!>          If RANGE = 'I', then NZC >= IU-IL+1.
!>          If NZC = -1, then a workspace query is assumed; the
!>          routine calculates the number of columns of the array Z that
!>          are needed to hold the eigenvectors.
!>          This value is returned as the first entry of the Z array, and
!>          no error message related to NZC is issued by XERBLA.
!>
[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 computed eigenvector
!>          is nonzero only in elements ISUPPZ( 2*i-1 ) through
!>          ISUPPZ( 2*i ). This is relevant in the case when the matrix
!>          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
!>
[in,out]TRYRAC
!>          TRYRAC is LOGICAL
!>          If TRYRAC = .TRUE., indicates that the code should check whether
!>          the tridiagonal matrix defines its eigenvalues to high relative
!>          accuracy.  If so, the code uses relative-accuracy preserving
!>          algorithms that might be (a bit) slower depending on the matrix.
!>          If the matrix does not define its eigenvalues to high relative
!>          accuracy, the code can uses possibly faster algorithms.
!>          If TRYRAC = .FALSE., the code is not required to guarantee
!>          relatively accurate eigenvalues and can use the fastest possible
!>          techniques.
!>          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
!>          does not define its eigenvalues to high relative accuracy.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>          On exit, if INFO = 0, WORK(1) returns the optimal
!>          (and minimal) LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,18*N)
!>          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (LIWORK)
!>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!>
[in]LIWORK
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
!>          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
!>          if only the eigenvalues are to be computed.
!>          If LIWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the IWORK array,
!>          returns this value as the first entry of the IWORK array, and
!>          no error message related to LIWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          On exit, INFO
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = 1X, internal error in DLARRE,
!>                if INFO = 2X, internal error in ZLARRV.
!>                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
!>                the nonzero error code returned by DLARRE or
!>                ZLARRV, respectively.
!>
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 335 of file zstemr.f.

338*
339* -- LAPACK computational routine --
340* -- LAPACK is a software package provided by Univ. of Tennessee, --
341* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
342*
343* .. Scalar Arguments ..
344 CHARACTER JOBZ, RANGE
345 LOGICAL TRYRAC
346 INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
347 DOUBLE PRECISION VL, VU
348* ..
349* .. Array Arguments ..
350 INTEGER ISUPPZ( * ), IWORK( * )
351 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
352 COMPLEX*16 Z( LDZ, * )
353* ..
354*
355* =====================================================================
356*
357* .. Parameters ..
358 DOUBLE PRECISION ZERO, ONE, FOUR, MINRGP
359 parameter( zero = 0.0d0, one = 1.0d0,
360 $ four = 4.0d0,
361 $ minrgp = 1.0d-3 )
362* ..
363* .. Local Scalars ..
364 LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
365 INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
366 $ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
367 $ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
368 $ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
369 $ NZCMIN, OFFSET, WBEGIN, WEND
370 DOUBLE PRECISION BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
371 $ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
372 $ THRESH, TMP, TNRM, WL, WU
373* ..
374* ..
375* .. External Functions ..
376 LOGICAL LSAME
377 DOUBLE PRECISION DLAMCH, DLANST
378 EXTERNAL lsame, dlamch, dlanst
379* ..
380* .. External Subroutines ..
381 EXTERNAL dcopy, dlae2, dlaev2, dlarrc, dlarre, dlarrj,
382 $ dlarrr, dlasrt, dscal, xerbla, zlarrv, zswap
383* ..
384* .. Intrinsic Functions ..
385 INTRINSIC max, min, sqrt
386
387
388* ..
389* .. Executable Statements ..
390*
391* Test the input parameters.
392*
393 wantz = lsame( jobz, 'V' )
394 alleig = lsame( range, 'A' )
395 valeig = lsame( range, 'V' )
396 indeig = lsame( range, 'I' )
397*
398 lquery = ( ( lwork.EQ.-1 ).OR.( liwork.EQ.-1 ) )
399 zquery = ( nzc.EQ.-1 )
400
401* DSTEMR needs WORK of size 6*N, IWORK of size 3*N.
402* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N.
403* Furthermore, ZLARRV needs WORK of size 12*N, IWORK of size 7*N.
404 IF( wantz ) THEN
405 lwmin = 18*n
406 liwmin = 10*n
407 ELSE
408* need less workspace if only the eigenvalues are wanted
409 lwmin = 12*n
410 liwmin = 8*n
411 ENDIF
412
413 wl = zero
414 wu = zero
415 iil = 0
416 iiu = 0
417 nsplit = 0
418
419 IF( valeig ) THEN
420* We do not reference VL, VU in the cases RANGE = 'I','A'
421* The interval (WL, WU] contains all the wanted eigenvalues.
422* It is either given by the user or computed in DLARRE.
423 wl = vl
424 wu = vu
425 ELSEIF( indeig ) THEN
426* We do not reference IL, IU in the cases RANGE = 'V','A'
427 iil = il
428 iiu = iu
429 ENDIF
430*
431 info = 0
432 IF( .NOT.( wantz .OR. lsame( jobz, 'N' ) ) ) THEN
433 info = -1
434 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) ) THEN
435 info = -2
436 ELSE IF( n.LT.0 ) THEN
437 info = -3
438 ELSE IF( valeig .AND. n.GT.0 .AND. wu.LE.wl ) THEN
439 info = -7
440 ELSE IF( indeig .AND. ( iil.LT.1 .OR. iil.GT.n ) ) THEN
441 info = -8
442 ELSE IF( indeig .AND. ( iiu.LT.iil .OR. iiu.GT.n ) ) THEN
443 info = -9
444 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) ) THEN
445 info = -13
446 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
447 info = -17
448 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery ) THEN
449 info = -19
450 END IF
451*
452* Get machine constants.
453*
454 safmin = dlamch( 'Safe minimum' )
455 eps = dlamch( 'Precision' )
456 smlnum = safmin / eps
457 bignum = one / smlnum
458 rmin = sqrt( smlnum )
459 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
460*
461 IF( info.EQ.0 ) THEN
462 work( 1 ) = lwmin
463 iwork( 1 ) = liwmin
464*
465 IF( wantz .AND. alleig ) THEN
466 nzcmin = n
467 ELSE IF( wantz .AND. valeig ) THEN
468 CALL dlarrc( 'T', n, vl, vu, d, e, safmin,
469 $ nzcmin, itmp, itmp2, info )
470 ELSE IF( wantz .AND. indeig ) THEN
471 nzcmin = iiu-iil+1
472 ELSE
473* WANTZ .EQ. FALSE.
474 nzcmin = 0
475 ENDIF
476 IF( zquery .AND. info.EQ.0 ) THEN
477 z( 1,1 ) = nzcmin
478 ELSE IF( nzc.LT.nzcmin .AND. .NOT.zquery ) THEN
479 info = -14
480 END IF
481 END IF
482
483 IF( info.NE.0 ) THEN
484*
485 CALL xerbla( 'ZSTEMR', -info )
486*
487 RETURN
488 ELSE IF( lquery .OR. zquery ) THEN
489 RETURN
490 END IF
491*
492* Handle N = 0, 1, and 2 cases immediately
493*
494 m = 0
495 IF( n.EQ.0 )
496 $ RETURN
497*
498 IF( n.EQ.1 ) THEN
499 IF( alleig .OR. indeig ) THEN
500 m = 1
501 w( 1 ) = d( 1 )
502 ELSE
503 IF( wl.LT.d( 1 ) .AND. wu.GE.d( 1 ) ) THEN
504 m = 1
505 w( 1 ) = d( 1 )
506 END IF
507 END IF
508 IF( wantz.AND.(.NOT.zquery) ) THEN
509 z( 1, 1 ) = one
510 isuppz(1) = 1
511 isuppz(2) = 1
512 END IF
513 RETURN
514 END IF
515*
516 IF( n.EQ.2 ) THEN
517 IF( .NOT.wantz ) THEN
518 CALL dlae2( d(1), e(1), d(2), r1, r2 )
519 ELSE IF( wantz.AND.(.NOT.zquery) ) THEN
520 CALL dlaev2( d(1), e(1), d(2), r1, r2, cs, sn )
521 END IF
522 IF( alleig.OR.
523 $ (valeig.AND.(r2.GT.wl).AND.
524 $ (r2.LE.wu)).OR.
525 $ (indeig.AND.(iil.EQ.1)) ) THEN
526 m = m+1
527 w( m ) = r2
528 IF( wantz.AND.(.NOT.zquery) ) THEN
529 z( 1, m ) = -sn
530 z( 2, m ) = cs
531* Note: At most one of SN and CS can be zero.
532 IF (sn.NE.zero) THEN
533 IF (cs.NE.zero) THEN
534 isuppz(2*m-1) = 1
535 isuppz(2*m) = 2
536 ELSE
537 isuppz(2*m-1) = 1
538 isuppz(2*m) = 1
539 END IF
540 ELSE
541 isuppz(2*m-1) = 2
542 isuppz(2*m) = 2
543 END IF
544 ENDIF
545 ENDIF
546 IF( alleig.OR.
547 $ (valeig.AND.(r1.GT.wl).AND.
548 $ (r1.LE.wu)).OR.
549 $ (indeig.AND.(iiu.EQ.2)) ) THEN
550 m = m+1
551 w( m ) = r1
552 IF( wantz.AND.(.NOT.zquery) ) THEN
553 z( 1, m ) = cs
554 z( 2, m ) = sn
555* Note: At most one of SN and CS can be zero.
556 IF (sn.NE.zero) THEN
557 IF (cs.NE.zero) THEN
558 isuppz(2*m-1) = 1
559 isuppz(2*m) = 2
560 ELSE
561 isuppz(2*m-1) = 1
562 isuppz(2*m) = 1
563 END IF
564 ELSE
565 isuppz(2*m-1) = 2
566 isuppz(2*m) = 2
567 END IF
568 ENDIF
569 ENDIF
570 ELSE
571
572* Continue with general N
573
574 indgrs = 1
575 inderr = 2*n + 1
576 indgp = 3*n + 1
577 indd = 4*n + 1
578 inde2 = 5*n + 1
579 indwrk = 6*n + 1
580*
581 iinspl = 1
582 iindbl = n + 1
583 iindw = 2*n + 1
584 iindwk = 3*n + 1
585*
586* Scale matrix to allowable range, if necessary.
587* The allowable range is related to the PIVMIN parameter; see the
588* comments in DLARRD. The preference for scaling small values
589* up is heuristic; we expect users' matrices not to be close to the
590* RMAX threshold.
591*
592 scale = one
593 tnrm = dlanst( 'M', n, d, e )
594 IF( tnrm.GT.zero .AND. tnrm.LT.rmin ) THEN
595 scale = rmin / tnrm
596 ELSE IF( tnrm.GT.rmax ) THEN
597 scale = rmax / tnrm
598 END IF
599 IF( scale.NE.one ) THEN
600 CALL dscal( n, scale, d, 1 )
601 CALL dscal( n-1, scale, e, 1 )
602 tnrm = tnrm*scale
603 IF( valeig ) THEN
604* If eigenvalues in interval have to be found,
605* scale (WL, WU] accordingly
606 wl = wl*scale
607 wu = wu*scale
608 ENDIF
609 END IF
610*
611* Compute the desired eigenvalues of the tridiagonal after splitting
612* into smaller subblocks if the corresponding off-diagonal elements
613* are small
614* THRESH is the splitting parameter for DLARRE
615* A negative THRESH forces the old splitting criterion based on the
616* size of the off-diagonal. A positive THRESH switches to splitting
617* which preserves relative accuracy.
618*
619 IF( tryrac ) THEN
620* Test whether the matrix warrants the more expensive relative approach.
621 CALL dlarrr( n, d, e, iinfo )
622 ELSE
623* The user does not care about relative accurately eigenvalues
624 iinfo = -1
625 ENDIF
626* Set the splitting criterion
627 IF (iinfo.EQ.0) THEN
628 thresh = eps
629 ELSE
630 thresh = -eps
631* relative accuracy is desired but T does not guarantee it
632 tryrac = .false.
633 ENDIF
634*
635 IF( tryrac ) THEN
636* Copy original diagonal, needed to guarantee relative accuracy
637 CALL dcopy(n,d,1,work(indd),1)
638 ENDIF
639* Store the squares of the offdiagonal values of T
640 DO 5 j = 1, n-1
641 work( inde2+j-1 ) = e(j)**2
642 5 CONTINUE
643
644* Set the tolerance parameters for bisection
645 IF( .NOT.wantz ) THEN
646* DLARRE computes the eigenvalues to full precision.
647 rtol1 = four * eps
648 rtol2 = four * eps
649 ELSE
650* DLARRE computes the eigenvalues to less than full precision.
651* ZLARRV will refine the eigenvalue approximations, and we only
652* need less accurate initial bisection in DLARRE.
653* Note: these settings do only affect the subset case and DLARRE
654 rtol1 = sqrt(eps)
655 rtol2 = max( sqrt(eps)*5.0d-3, four * eps )
656 ENDIF
657 CALL dlarre( range, n, wl, wu, iil, iiu, d, e,
658 $ work(inde2), rtol1, rtol2, thresh, nsplit,
659 $ iwork( iinspl ), m, w, work( inderr ),
660 $ work( indgp ), iwork( iindbl ),
661 $ iwork( iindw ), work( indgrs ), pivmin,
662 $ work( indwrk ), iwork( iindwk ), iinfo )
663 IF( iinfo.NE.0 ) THEN
664 info = 10 + abs( iinfo )
665 RETURN
666 END IF
667* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired
668* part of the spectrum. All desired eigenvalues are contained in
669* (WL,WU]
670
671
672 IF( wantz ) THEN
673*
674* Compute the desired eigenvectors corresponding to the computed
675* eigenvalues
676*
677 CALL zlarrv( n, wl, wu, d, e,
678 $ pivmin, iwork( iinspl ), m,
679 $ 1, m, minrgp, rtol1, rtol2,
680 $ w, work( inderr ), work( indgp ), iwork( iindbl ),
681 $ iwork( iindw ), work( indgrs ), z, ldz,
682 $ isuppz, work( indwrk ), iwork( iindwk ), iinfo )
683 IF( iinfo.NE.0 ) THEN
684 info = 20 + abs( iinfo )
685 RETURN
686 END IF
687 ELSE
688* DLARRE computes eigenvalues of the (shifted) root representation
689* ZLARRV returns the eigenvalues of the unshifted matrix.
690* However, if the eigenvectors are not desired by the user, we need
691* to apply the corresponding shifts from DLARRE to obtain the
692* eigenvalues of the original matrix.
693 DO 20 j = 1, m
694 itmp = iwork( iindbl+j-1 )
695 w( j ) = w( j ) + e( iwork( iinspl+itmp-1 ) )
696 20 CONTINUE
697 END IF
698*
699
700 IF ( tryrac ) THEN
701* Refine computed eigenvalues so that they are relatively accurate
702* with respect to the original matrix T.
703 ibegin = 1
704 wbegin = 1
705 DO 39 jblk = 1, iwork( iindbl+m-1 )
706 iend = iwork( iinspl+jblk-1 )
707 in = iend - ibegin + 1
708 wend = wbegin - 1
709* check if any eigenvalues have to be refined in this block
710 36 CONTINUE
711 IF( wend.LT.m ) THEN
712 IF( iwork( iindbl+wend ).EQ.jblk ) THEN
713 wend = wend + 1
714 GO TO 36
715 END IF
716 END IF
717 IF( wend.LT.wbegin ) THEN
718 ibegin = iend + 1
719 GO TO 39
720 END IF
721
722 offset = iwork(iindw+wbegin-1)-1
723 ifirst = iwork(iindw+wbegin-1)
724 ilast = iwork(iindw+wend-1)
725 rtol2 = four * eps
726 CALL dlarrj( in,
727 $ work(indd+ibegin-1), work(inde2+ibegin-1),
728 $ ifirst, ilast, rtol2, offset, w(wbegin),
729 $ work( inderr+wbegin-1 ),
730 $ work( indwrk ), iwork( iindwk ), pivmin,
731 $ tnrm, iinfo )
732 ibegin = iend + 1
733 wbegin = wend + 1
734 39 CONTINUE
735 ENDIF
736*
737* If matrix was scaled, then rescale eigenvalues appropriately.
738*
739 IF( scale.NE.one ) THEN
740 CALL dscal( m, one / scale, w, 1 )
741 END IF
742 END IF
743*
744* If eigenvalues are not in increasing order, then sort them,
745* possibly along with eigenvectors.
746*
747 IF( nsplit.GT.1 .OR. n.EQ.2 ) THEN
748 IF( .NOT. wantz ) THEN
749 CALL dlasrt( 'I', m, w, iinfo )
750 IF( iinfo.NE.0 ) THEN
751 info = 3
752 RETURN
753 END IF
754 ELSE
755 DO 60 j = 1, m - 1
756 i = 0
757 tmp = w( j )
758 DO 50 jj = j + 1, m
759 IF( w( jj ).LT.tmp ) THEN
760 i = jj
761 tmp = w( jj )
762 END IF
763 50 CONTINUE
764 IF( i.NE.0 ) THEN
765 w( i ) = w( j )
766 w( j ) = tmp
767 IF( wantz ) THEN
768 CALL zswap( n, z( 1, i ), 1, z( 1, j ), 1 )
769 itmp = isuppz( 2*i-1 )
770 isuppz( 2*i-1 ) = isuppz( 2*j-1 )
771 isuppz( 2*j-1 ) = itmp
772 itmp = isuppz( 2*i )
773 isuppz( 2*i ) = isuppz( 2*j )
774 isuppz( 2*j ) = itmp
775 END IF
776 END IF
777 60 CONTINUE
778 END IF
779 ENDIF
780*
781*
782 work( 1 ) = lwmin
783 iwork( 1 ) = liwmin
784 RETURN
785*
786* End of ZSTEMR
787*
dlarrr
subroutine dlarrr(n, d, e, info)
DLARRR performs tests to decide whether the symmetric tridiagonal matrix T warrants expensive computa...
Definition dlarrr.f:94
dlarrj
subroutine dlarrj(n, d, e2, ifirst, ilast, rtol, offset, w, werr, work, iwork, pivmin, spdiam, info)
DLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T.
Definition dlarrj.f:168
dlarrc
subroutine dlarrc(jobt, n, vl, vu, d, e, pivmin, eigcnt, lcnt, rcnt, info)
DLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix.
Definition dlarrc.f:137
dlae2
subroutine dlae2(a, b, c, rt1, rt2)
DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.
Definition dlae2.f:102
dlarre
subroutine dlarre(range, n, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, work, iwork, info)
DLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduce...
Definition dlarre.f:305
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
zlarrv
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 ...
Definition zlarrv.f:286

◆ zsteqr()

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

ZSTEQR

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

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

Definition at line 131 of file zsteqr.f.

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

◆ ztbcon()

subroutine ztbcon ( character norm,
character uplo,
character diag,
integer n,
integer kd,
complex*16, dimension( ldab, * ) ab,
integer ldab,
double precision rcond,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZTBCON

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

Purpose:
!>
!> ZTBCON estimates the reciprocal of the condition number of a
!> triangular band matrix A, in either the 1-norm or the infinity-norm.
!>
!> The norm of A is computed and an estimate is obtained for
!> norm(inv(A)), then the reciprocal of the condition number is
!> computed as
!>    RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies whether the 1-norm condition number or the
!>          infinity-norm condition number is required:
!>          = '1' or 'O':  1-norm;
!>          = 'I':         Infinity-norm.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals or subdiagonals of the
!>          triangular band 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).
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 141 of file ztbcon.f.

143*
144* -- LAPACK computational 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 DIAG, NORM, UPLO
150 INTEGER INFO, KD, LDAB, N
151 DOUBLE PRECISION RCOND
152* ..
153* .. Array Arguments ..
154 DOUBLE PRECISION RWORK( * )
155 COMPLEX*16 AB( LDAB, * ), WORK( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 DOUBLE PRECISION ONE, ZERO
162 parameter( one = 1.0d+0, zero = 0.0d+0 )
163* ..
164* .. Local Scalars ..
165 LOGICAL NOUNIT, ONENRM, UPPER
166 CHARACTER NORMIN
167 INTEGER IX, KASE, KASE1
168 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
169 COMPLEX*16 ZDUM
170* ..
171* .. Local Arrays ..
172 INTEGER ISAVE( 3 )
173* ..
174* .. External Functions ..
175 LOGICAL LSAME
176 INTEGER IZAMAX
177 DOUBLE PRECISION DLAMCH, ZLANTB
178 EXTERNAL lsame, izamax, dlamch, zlantb
179* ..
180* .. External Subroutines ..
181 EXTERNAL xerbla, zdrscl, zlacn2, zlatbs
182* ..
183* .. Intrinsic Functions ..
184 INTRINSIC abs, dble, dimag, max
185* ..
186* .. Statement Functions ..
187 DOUBLE PRECISION CABS1
188* ..
189* .. Statement Function definitions ..
190 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
191* ..
192* .. Executable Statements ..
193*
194* Test the input parameters.
195*
196 info = 0
197 upper = lsame( uplo, 'U' )
198 onenrm = norm.EQ.'1' .OR. lsame( norm, 'O' )
199 nounit = lsame( diag, 'N' )
200*
201 IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN
202 info = -1
203 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
204 info = -2
205 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
206 info = -3
207 ELSE IF( n.LT.0 ) THEN
208 info = -4
209 ELSE IF( kd.LT.0 ) THEN
210 info = -5
211 ELSE IF( ldab.LT.kd+1 ) THEN
212 info = -7
213 END IF
214 IF( info.NE.0 ) THEN
215 CALL xerbla( 'ZTBCON', -info )
216 RETURN
217 END IF
218*
219* Quick return if possible
220*
221 IF( n.EQ.0 ) THEN
222 rcond = one
223 RETURN
224 END IF
225*
226 rcond = zero
227 smlnum = dlamch( 'Safe minimum' )*dble( max( n, 1 ) )
228*
229* Compute the 1-norm of the triangular matrix A or A**H.
230*
231 anorm = zlantb( norm, uplo, diag, n, kd, ab, ldab, rwork )
232*
233* Continue only if ANORM > 0.
234*
235 IF( anorm.GT.zero ) THEN
236*
237* Estimate the 1-norm of the inverse of A.
238*
239 ainvnm = zero
240 normin = 'N'
241 IF( onenrm ) THEN
242 kase1 = 1
243 ELSE
244 kase1 = 2
245 END IF
246 kase = 0
247 10 CONTINUE
248 CALL zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
249 IF( kase.NE.0 ) THEN
250 IF( kase.EQ.kase1 ) THEN
251*
252* Multiply by inv(A).
253*
254 CALL zlatbs( uplo, 'No transpose', diag, normin, n, kd,
255 $ ab, ldab, work, scale, rwork, info )
256 ELSE
257*
258* Multiply by inv(A**H).
259*
260 CALL zlatbs( uplo, 'Conjugate transpose', diag, normin,
261 $ n, kd, ab, ldab, work, scale, rwork, info )
262 END IF
263 normin = 'Y'
264*
265* Multiply by 1/SCALE if doing so will not cause overflow.
266*
267 IF( scale.NE.one ) THEN
268 ix = izamax( n, work, 1 )
269 xnorm = cabs1( work( ix ) )
270 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
271 $ GO TO 20
272 CALL zdrscl( n, scale, work, 1 )
273 END IF
274 GO TO 10
275 END IF
276*
277* Compute the estimate of the reciprocal condition number.
278*
279 IF( ainvnm.NE.zero )
280 $ rcond = ( one / anorm ) / ainvnm
281 END IF
282*
283 20 CONTINUE
284 RETURN
285*
286* End of ZTBCON
287*
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

◆ ztbrfs()

subroutine ztbrfs ( character uplo,
character trans,
character diag,
integer n,
integer kd,
integer nrhs,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZTBRFS

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

Purpose:
!>
!> ZTBRFS provides error bounds and backward error estimates for the
!> solution to a system of linear equations with a triangular band
!> coefficient matrix.
!>
!> The solution matrix X must be computed by ZTBTRS or some other
!> means before entering this routine.  ZTBRFS does not do iterative
!> refinement because doing so cannot improve the backward error.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals or subdiagonals of the
!>          triangular band matrix A.  KD >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X.  NRHS >= 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).
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 186 of file ztbrfs.f.

188*
189* -- LAPACK computational routine --
190* -- LAPACK is a software package provided by Univ. of Tennessee, --
191* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
192*
193* .. Scalar Arguments ..
194 CHARACTER DIAG, TRANS, UPLO
195 INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS
196* ..
197* .. Array Arguments ..
198 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
199 COMPLEX*16 AB( LDAB, * ), B( LDB, * ), WORK( * ),
200 $ X( LDX, * )
201* ..
202*
203* =====================================================================
204*
205* .. Parameters ..
206 DOUBLE PRECISION ZERO
207 parameter( zero = 0.0d+0 )
208 COMPLEX*16 ONE
209 parameter( one = ( 1.0d+0, 0.0d+0 ) )
210* ..
211* .. Local Scalars ..
212 LOGICAL NOTRAN, NOUNIT, UPPER
213 CHARACTER TRANSN, TRANST
214 INTEGER I, J, K, KASE, NZ
215 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
216 COMPLEX*16 ZDUM
217* ..
218* .. Local Arrays ..
219 INTEGER ISAVE( 3 )
220* ..
221* .. External Subroutines ..
222 EXTERNAL xerbla, zaxpy, zcopy, zlacn2, ztbmv, ztbsv
223* ..
224* .. Intrinsic Functions ..
225 INTRINSIC abs, dble, dimag, max, min
226* ..
227* .. External Functions ..
228 LOGICAL LSAME
229 DOUBLE PRECISION DLAMCH
230 EXTERNAL lsame, dlamch
231* ..
232* .. Statement Functions ..
233 DOUBLE PRECISION CABS1
234* ..
235* .. Statement Function definitions ..
236 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
237* ..
238* .. Executable Statements ..
239*
240* Test the input parameters.
241*
242 info = 0
243 upper = lsame( uplo, 'U' )
244 notran = lsame( trans, 'N' )
245 nounit = lsame( diag, 'N' )
246*
247 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
248 info = -1
249 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
250 $ lsame( trans, 'C' ) ) THEN
251 info = -2
252 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
253 info = -3
254 ELSE IF( n.LT.0 ) THEN
255 info = -4
256 ELSE IF( kd.LT.0 ) THEN
257 info = -5
258 ELSE IF( nrhs.LT.0 ) THEN
259 info = -6
260 ELSE IF( ldab.LT.kd+1 ) THEN
261 info = -8
262 ELSE IF( ldb.LT.max( 1, n ) ) THEN
263 info = -10
264 ELSE IF( ldx.LT.max( 1, n ) ) THEN
265 info = -12
266 END IF
267 IF( info.NE.0 ) THEN
268 CALL xerbla( 'ZTBRFS', -info )
269 RETURN
270 END IF
271*
272* Quick return if possible
273*
274 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
275 DO 10 j = 1, nrhs
276 ferr( j ) = zero
277 berr( j ) = zero
278 10 CONTINUE
279 RETURN
280 END IF
281*
282 IF( notran ) THEN
283 transn = 'N'
284 transt = 'C'
285 ELSE
286 transn = 'C'
287 transt = 'N'
288 END IF
289*
290* NZ = maximum number of nonzero elements in each row of A, plus 1
291*
292 nz = kd + 2
293 eps = dlamch( 'Epsilon' )
294 safmin = dlamch( 'Safe minimum' )
295 safe1 = nz*safmin
296 safe2 = safe1 / eps
297*
298* Do for each right hand side
299*
300 DO 250 j = 1, nrhs
301*
302* Compute residual R = B - op(A) * X,
303* where op(A) = A, A**T, or A**H, depending on TRANS.
304*
305 CALL zcopy( n, x( 1, j ), 1, work, 1 )
306 CALL ztbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
307 CALL zaxpy( n, -one, b( 1, j ), 1, work, 1 )
308*
309* Compute componentwise relative backward error from formula
310*
311* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
312*
313* where abs(Z) is the componentwise absolute value of the matrix
314* or vector Z. If the i-th component of the denominator is less
315* than SAFE2, then SAFE1 is added to the i-th components of the
316* numerator and denominator before dividing.
317*
318 DO 20 i = 1, n
319 rwork( i ) = cabs1( b( i, j ) )
320 20 CONTINUE
321*
322 IF( notran ) THEN
323*
324* Compute abs(A)*abs(X) + abs(B).
325*
326 IF( upper ) THEN
327 IF( nounit ) THEN
328 DO 40 k = 1, n
329 xk = cabs1( x( k, j ) )
330 DO 30 i = max( 1, k-kd ), k
331 rwork( i ) = rwork( i ) +
332 $ cabs1( ab( kd+1+i-k, k ) )*xk
333 30 CONTINUE
334 40 CONTINUE
335 ELSE
336 DO 60 k = 1, n
337 xk = cabs1( x( k, j ) )
338 DO 50 i = max( 1, k-kd ), k - 1
339 rwork( i ) = rwork( i ) +
340 $ cabs1( ab( kd+1+i-k, k ) )*xk
341 50 CONTINUE
342 rwork( k ) = rwork( k ) + xk
343 60 CONTINUE
344 END IF
345 ELSE
346 IF( nounit ) THEN
347 DO 80 k = 1, n
348 xk = cabs1( x( k, j ) )
349 DO 70 i = k, min( n, k+kd )
350 rwork( i ) = rwork( i ) +
351 $ cabs1( ab( 1+i-k, k ) )*xk
352 70 CONTINUE
353 80 CONTINUE
354 ELSE
355 DO 100 k = 1, n
356 xk = cabs1( x( k, j ) )
357 DO 90 i = k + 1, min( n, k+kd )
358 rwork( i ) = rwork( i ) +
359 $ cabs1( ab( 1+i-k, k ) )*xk
360 90 CONTINUE
361 rwork( k ) = rwork( k ) + xk
362 100 CONTINUE
363 END IF
364 END IF
365 ELSE
366*
367* Compute abs(A**H)*abs(X) + abs(B).
368*
369 IF( upper ) THEN
370 IF( nounit ) THEN
371 DO 120 k = 1, n
372 s = zero
373 DO 110 i = max( 1, k-kd ), k
374 s = s + cabs1( ab( kd+1+i-k, k ) )*
375 $ cabs1( x( i, j ) )
376 110 CONTINUE
377 rwork( k ) = rwork( k ) + s
378 120 CONTINUE
379 ELSE
380 DO 140 k = 1, n
381 s = cabs1( x( k, j ) )
382 DO 130 i = max( 1, k-kd ), k - 1
383 s = s + cabs1( ab( kd+1+i-k, k ) )*
384 $ cabs1( x( i, j ) )
385 130 CONTINUE
386 rwork( k ) = rwork( k ) + s
387 140 CONTINUE
388 END IF
389 ELSE
390 IF( nounit ) THEN
391 DO 160 k = 1, n
392 s = zero
393 DO 150 i = k, min( n, k+kd )
394 s = s + cabs1( ab( 1+i-k, k ) )*
395 $ cabs1( x( i, j ) )
396 150 CONTINUE
397 rwork( k ) = rwork( k ) + s
398 160 CONTINUE
399 ELSE
400 DO 180 k = 1, n
401 s = cabs1( x( k, j ) )
402 DO 170 i = k + 1, min( n, k+kd )
403 s = s + cabs1( ab( 1+i-k, k ) )*
404 $ cabs1( x( i, j ) )
405 170 CONTINUE
406 rwork( k ) = rwork( k ) + s
407 180 CONTINUE
408 END IF
409 END IF
410 END IF
411 s = zero
412 DO 190 i = 1, n
413 IF( rwork( i ).GT.safe2 ) THEN
414 s = max( s, cabs1( work( i ) ) / rwork( i ) )
415 ELSE
416 s = max( s, ( cabs1( work( i ) )+safe1 ) /
417 $ ( rwork( i )+safe1 ) )
418 END IF
419 190 CONTINUE
420 berr( j ) = s
421*
422* Bound error from formula
423*
424* norm(X - XTRUE) / norm(X) .le. FERR =
425* norm( abs(inv(op(A)))*
426* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
427*
428* where
429* norm(Z) is the magnitude of the largest component of Z
430* inv(op(A)) is the inverse of op(A)
431* abs(Z) is the componentwise absolute value of the matrix or
432* vector Z
433* NZ is the maximum number of nonzeros in any row of A, plus 1
434* EPS is machine epsilon
435*
436* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
437* is incremented by SAFE1 if the i-th component of
438* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
439*
440* Use ZLACN2 to estimate the infinity-norm of the matrix
441* inv(op(A)) * diag(W),
442* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
443*
444 DO 200 i = 1, n
445 IF( rwork( i ).GT.safe2 ) THEN
446 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
447 ELSE
448 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
449 $ safe1
450 END IF
451 200 CONTINUE
452*
453 kase = 0
454 210 CONTINUE
455 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
456 IF( kase.NE.0 ) THEN
457 IF( kase.EQ.1 ) THEN
458*
459* Multiply by diag(W)*inv(op(A)**H).
460*
461 CALL ztbsv( uplo, transt, diag, n, kd, ab, ldab, work,
462 $ 1 )
463 DO 220 i = 1, n
464 work( i ) = rwork( i )*work( i )
465 220 CONTINUE
466 ELSE
467*
468* Multiply by inv(op(A))*diag(W).
469*
470 DO 230 i = 1, n
471 work( i ) = rwork( i )*work( i )
472 230 CONTINUE
473 CALL ztbsv( uplo, transn, diag, n, kd, ab, ldab, work,
474 $ 1 )
475 END IF
476 GO TO 210
477 END IF
478*
479* Normalize error.
480*
481 lstres = zero
482 DO 240 i = 1, n
483 lstres = max( lstres, cabs1( x( i, j ) ) )
484 240 CONTINUE
485 IF( lstres.NE.zero )
486 $ ferr( j ) = ferr( j ) / lstres
487*
488 250 CONTINUE
489*
490 RETURN
491*
492* End of ZTBRFS
493*
ztbmv
subroutine ztbmv(uplo, trans, diag, n, k, a, lda, x, incx)
ZTBMV
Definition ztbmv.f:186

◆ ztbtrs()

subroutine ztbtrs ( character uplo,
character trans,
character diag,
integer n,
integer kd,
integer nrhs,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZTBTRS

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

Purpose:
!>
!> ZTBTRS solves a triangular system of the form
!>
!>    A * X = B,  A**T * X = B,  or  A**H * X = B,
!>
!> where A is a triangular band matrix of order N, and B is an
!> N-by-NRHS matrix.  A check is made to verify that A is nonsingular.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals or subdiagonals of the
!>          triangular band matrix A.  KD >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 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 AB.  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).
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, if INFO = 0, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the i-th diagonal element of A is zero,
!>                indicating that the matrix is singular and the
!>                solutions X have not been computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 144 of file ztbtrs.f.

146*
147* -- LAPACK computational routine --
148* -- LAPACK is a software package provided by Univ. of Tennessee, --
149* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
150*
151* .. Scalar Arguments ..
152 CHARACTER DIAG, TRANS, UPLO
153 INTEGER INFO, KD, LDAB, LDB, N, NRHS
154* ..
155* .. Array Arguments ..
156 COMPLEX*16 AB( LDAB, * ), B( LDB, * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 COMPLEX*16 ZERO
163 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
164* ..
165* .. Local Scalars ..
166 LOGICAL NOUNIT, UPPER
167 INTEGER J
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 EXTERNAL lsame
172* ..
173* .. External Subroutines ..
174 EXTERNAL xerbla, ztbsv
175* ..
176* .. Intrinsic Functions ..
177 INTRINSIC max
178* ..
179* .. Executable Statements ..
180*
181* Test the input parameters.
182*
183 info = 0
184 nounit = lsame( diag, 'N' )
185 upper = lsame( uplo, 'U' )
186 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
187 info = -1
188 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.
189 $ lsame( trans, 'T' ) .AND. .NOT.lsame( trans, 'C' ) ) THEN
190 info = -2
191 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
192 info = -3
193 ELSE IF( n.LT.0 ) THEN
194 info = -4
195 ELSE IF( kd.LT.0 ) THEN
196 info = -5
197 ELSE IF( nrhs.LT.0 ) THEN
198 info = -6
199 ELSE IF( ldab.LT.kd+1 ) THEN
200 info = -8
201 ELSE IF( ldb.LT.max( 1, n ) ) THEN
202 info = -10
203 END IF
204 IF( info.NE.0 ) THEN
205 CALL xerbla( 'ZTBTRS', -info )
206 RETURN
207 END IF
208*
209* Quick return if possible
210*
211 IF( n.EQ.0 )
212 $ RETURN
213*
214* Check for singularity.
215*
216 IF( nounit ) THEN
217 IF( upper ) THEN
218 DO 10 info = 1, n
219 IF( ab( kd+1, info ).EQ.zero )
220 $ RETURN
221 10 CONTINUE
222 ELSE
223 DO 20 info = 1, n
224 IF( ab( 1, info ).EQ.zero )
225 $ RETURN
226 20 CONTINUE
227 END IF
228 END IF
229 info = 0
230*
231* Solve A * X = B, A**T * X = B, or A**H * X = B.
232*
233 DO 30 j = 1, nrhs
234 CALL ztbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1, j ), 1 )
235 30 CONTINUE
236*
237 RETURN
238*
239* End of ZTBTRS
240*

◆ ztfsm()

subroutine ztfsm ( character transr,
character side,
character uplo,
character trans,
character diag,
integer m,
integer n,
complex*16 alpha,
complex*16, dimension( 0: * ) a,
complex*16, dimension( 0: ldb-1, 0: * ) b,
integer ldb )

ZTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).

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

Purpose:
!>
!> Level 3 BLAS like routine for A in RFP Format.
!>
!> ZTFSM  solves the matrix equation
!>
!>    op( A )*X = alpha*B  or  X*op( A ) = alpha*B
!>
!> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
!> non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
!>
!>    op( A ) = A   or   op( A ) = A**H.
!>
!> A is in Rectangular Full Packed (RFP) Format.
!>
!> The matrix X is overwritten on B.
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  The Normal Form of RFP A is stored;
!>          = 'C':  The Conjugate-transpose Form of RFP A is stored.
!>
[in]SIDE
!>          SIDE is CHARACTER*1
!>           On entry, SIDE specifies whether op( A ) appears on the left
!>           or right of X as follows:
!>
!>              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
!>
!>              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
!>
!>           Unchanged on exit.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>           On entry, UPLO specifies whether the RFP matrix A came from
!>           an upper or lower triangular matrix as follows:
!>           UPLO = 'U' or 'u' RFP A came from an upper triangular matrix
!>           UPLO = 'L' or 'l' RFP A came from a  lower triangular matrix
!>
!>           Unchanged on exit.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>           On entry, TRANS  specifies the form of op( A ) to be used
!>           in the matrix multiplication as follows:
!>
!>              TRANS  = 'N' or 'n'   op( A ) = A.
!>
!>              TRANS  = 'C' or 'c'   op( A ) = conjg( A' ).
!>
!>           Unchanged on exit.
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>           On entry, DIAG specifies whether or not RFP A is unit
!>           triangular as follows:
!>
!>              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!>
!>              DIAG = 'N' or 'n'   A is not assumed to be unit
!>                                  triangular.
!>
!>           Unchanged on exit.
!>
[in]M
!>          M is INTEGER
!>           On entry, M specifies the number of rows of B. M must be at
!>           least zero.
!>           Unchanged on exit.
!>
[in]N
!>          N is INTEGER
!>           On entry, N specifies the number of columns of B.  N must be
!>           at least zero.
!>           Unchanged on exit.
!>
[in]ALPHA
!>          ALPHA is COMPLEX*16
!>           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
!>           zero then  A is not referenced and  B need not be set before
!>           entry.
!>           Unchanged on exit.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (N*(N+1)/2)
!>           NT = N*(N+1)/2. On entry, the matrix A in RFP Format.
!>           RFP Format is described by TRANSR, UPLO and N as follows:
!>           If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;
!>           K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If
!>           TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as
!>           defined when TRANSR = 'N'. The contents of RFP A are defined
!>           by UPLO as follows: If UPLO = 'U' the RFP A contains the NT
!>           elements of upper packed A either in normal or
!>           conjugate-transpose Format. If UPLO = 'L' the RFP A contains
!>           the NT elements of lower packed A either in normal or
!>           conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when
!>           TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is
!>           even and is N when is odd.
!>           See the Note below for more details. Unchanged on exit.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>           Before entry,  the leading  m by n part of the array  B must
!>           contain  the  right-hand  side  matrix  B,  and  on exit  is
!>           overwritten by the solution matrix  X.
!>
[in]LDB
!>          LDB is INTEGER
!>           On entry, LDB specifies the first dimension of B as declared
!>           in  the  calling  (sub)  program.   LDB  must  be  at  least
!>           max( 1, m ).
!>           Unchanged on exit.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  We first consider Standard Packed Format when N is even.
!>  We give an example where N = 6.
!>
!>      AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  conjugate-transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  conjugate-transpose of the last three columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                -- -- --
!>        03 04 05                33 43 53
!>                                   -- --
!>        13 14 15                00 44 54
!>                                      --
!>        23 24 25                10 11 55
!>
!>        33 34 35                20 21 22
!>        --
!>        00 44 45                30 31 32
!>        -- --
!>        01 11 55                40 41 42
!>        -- -- --
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- -- --                -- -- -- -- -- --
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     -- -- -- -- --                -- -- -- -- --
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     -- -- -- -- -- --                -- -- -- --
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>
!>  We next  consider Standard Packed Format when N is odd.
!>  We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  conjugate-transpose of the first two   columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  conjugate-transpose of the last two   columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N odd  and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                   -- --
!>        02 03 04                00 33 43
!>                                      --
!>        12 13 14                10 11 44
!>
!>        22 23 24                20 21 22
!>        --
!>        00 33 34                30 31 32
!>        -- --
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- --                   -- -- -- -- -- --
!>     02 12 22 00 01             00 10 20 30 40 50
!>     -- -- -- --                   -- -- -- -- --
!>     03 13 23 33 11             33 11 21 31 41 51
!>     -- -- -- -- --                   -- -- -- --
!>     04 14 24 34 44             43 44 22 32 42 52
!>

Definition at line 296 of file ztfsm.f.

298*
299* -- LAPACK computational routine --
300* -- LAPACK is a software package provided by Univ. of Tennessee, --
301* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
302*
303* .. Scalar Arguments ..
304 CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO
305 INTEGER LDB, M, N
306 COMPLEX*16 ALPHA
307* ..
308* .. Array Arguments ..
309 COMPLEX*16 A( 0: * ), B( 0: LDB-1, 0: * )
310* ..
311*
312* =====================================================================
313* ..
314* .. Parameters ..
315 COMPLEX*16 CONE, CZERO
316 parameter( cone = ( 1.0d+0, 0.0d+0 ),
317 $ czero = ( 0.0d+0, 0.0d+0 ) )
318* ..
319* .. Local Scalars ..
320 LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR,
321 $ NOTRANS
322 INTEGER M1, M2, N1, N2, K, INFO, I, J
323* ..
324* .. External Functions ..
325 LOGICAL LSAME
326 EXTERNAL lsame
327* ..
328* .. External Subroutines ..
329 EXTERNAL xerbla, zgemm, ztrsm
330* ..
331* .. Intrinsic Functions ..
332 INTRINSIC max, mod
333* ..
334* .. Executable Statements ..
335*
336* Test the input parameters.
337*
338 info = 0
339 normaltransr = lsame( transr, 'N' )
340 lside = lsame( side, 'L' )
341 lower = lsame( uplo, 'L' )
342 notrans = lsame( trans, 'N' )
343 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
344 info = -1
345 ELSE IF( .NOT.lside .AND. .NOT.lsame( side, 'R' ) ) THEN
346 info = -2
347 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
348 info = -3
349 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans, 'C' ) ) THEN
350 info = -4
351 ELSE IF( .NOT.lsame( diag, 'N' ) .AND. .NOT.lsame( diag, 'U' ) )
352 $ THEN
353 info = -5
354 ELSE IF( m.LT.0 ) THEN
355 info = -6
356 ELSE IF( n.LT.0 ) THEN
357 info = -7
358 ELSE IF( ldb.LT.max( 1, m ) ) THEN
359 info = -11
360 END IF
361 IF( info.NE.0 ) THEN
362 CALL xerbla( 'ZTFSM ', -info )
363 RETURN
364 END IF
365*
366* Quick return when ( (N.EQ.0).OR.(M.EQ.0) )
367*
368 IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
369 $ RETURN
370*
371* Quick return when ALPHA.EQ.(0D+0,0D+0)
372*
373 IF( alpha.EQ.czero ) THEN
374 DO 20 j = 0, n - 1
375 DO 10 i = 0, m - 1
376 b( i, j ) = czero
377 10 CONTINUE
378 20 CONTINUE
379 RETURN
380 END IF
381*
382 IF( lside ) THEN
383*
384* SIDE = 'L'
385*
386* A is M-by-M.
387* If M is odd, set NISODD = .TRUE., and M1 and M2.
388* If M is even, NISODD = .FALSE., and M.
389*
390 IF( mod( m, 2 ).EQ.0 ) THEN
391 misodd = .false.
392 k = m / 2
393 ELSE
394 misodd = .true.
395 IF( lower ) THEN
396 m2 = m / 2
397 m1 = m - m2
398 ELSE
399 m1 = m / 2
400 m2 = m - m1
401 END IF
402 END IF
403*
404 IF( misodd ) THEN
405*
406* SIDE = 'L' and N is odd
407*
408 IF( normaltransr ) THEN
409*
410* SIDE = 'L', N is odd, and TRANSR = 'N'
411*
412 IF( lower ) THEN
413*
414* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L'
415*
416 IF( notrans ) THEN
417*
418* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and
419* TRANS = 'N'
420*
421 IF( m.EQ.1 ) THEN
422 CALL ztrsm( 'L', 'L', 'N', diag, m1, n, alpha,
423 $ a, m, b, ldb )
424 ELSE
425 CALL ztrsm( 'L', 'L', 'N', diag, m1, n, alpha,
426 $ a( 0 ), m, b, ldb )
427 CALL zgemm( 'N', 'N', m2, n, m1, -cone, a( m1 ),
428 $ m, b, ldb, alpha, b( m1, 0 ), ldb )
429 CALL ztrsm( 'L', 'U', 'C', diag, m2, n, cone,
430 $ a( m ), m, b( m1, 0 ), ldb )
431 END IF
432*
433 ELSE
434*
435* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and
436* TRANS = 'C'
437*
438 IF( m.EQ.1 ) THEN
439 CALL ztrsm( 'L', 'L', 'C', diag, m1, n, alpha,
440 $ a( 0 ), m, b, ldb )
441 ELSE
442 CALL ztrsm( 'L', 'U', 'N', diag, m2, n, alpha,
443 $ a( m ), m, b( m1, 0 ), ldb )
444 CALL zgemm( 'C', 'N', m1, n, m2, -cone, a( m1 ),
445 $ m, b( m1, 0 ), ldb, alpha, b, ldb )
446 CALL ztrsm( 'L', 'L', 'C', diag, m1, n, cone,
447 $ a( 0 ), m, b, ldb )
448 END IF
449*
450 END IF
451*
452 ELSE
453*
454* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U'
455*
456 IF( .NOT.notrans ) THEN
457*
458* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and
459* TRANS = 'N'
460*
461 CALL ztrsm( 'L', 'L', 'N', diag, m1, n, alpha,
462 $ a( m2 ), m, b, ldb )
463 CALL zgemm( 'C', 'N', m2, n, m1, -cone, a( 0 ), m,
464 $ b, ldb, alpha, b( m1, 0 ), ldb )
465 CALL ztrsm( 'L', 'U', 'C', diag, m2, n, cone,
466 $ a( m1 ), m, b( m1, 0 ), ldb )
467*
468 ELSE
469*
470* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and
471* TRANS = 'C'
472*
473 CALL ztrsm( 'L', 'U', 'N', diag, m2, n, alpha,
474 $ a( m1 ), m, b( m1, 0 ), ldb )
475 CALL zgemm( 'N', 'N', m1, n, m2, -cone, a( 0 ), m,
476 $ b( m1, 0 ), ldb, alpha, b, ldb )
477 CALL ztrsm( 'L', 'L', 'C', diag, m1, n, cone,
478 $ a( m2 ), m, b, ldb )
479*
480 END IF
481*
482 END IF
483*
484 ELSE
485*
486* SIDE = 'L', N is odd, and TRANSR = 'C'
487*
488 IF( lower ) THEN
489*
490* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'L'
491*
492 IF( notrans ) THEN
493*
494* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and
495* TRANS = 'N'
496*
497 IF( m.EQ.1 ) THEN
498 CALL ztrsm( 'L', 'U', 'C', diag, m1, n, alpha,
499 $ a( 0 ), m1, b, ldb )
500 ELSE
501 CALL ztrsm( 'L', 'U', 'C', diag, m1, n, alpha,
502 $ a( 0 ), m1, b, ldb )
503 CALL zgemm( 'C', 'N', m2, n, m1, -cone,
504 $ a( m1*m1 ), m1, b, ldb, alpha,
505 $ b( m1, 0 ), ldb )
506 CALL ztrsm( 'L', 'L', 'N', diag, m2, n, cone,
507 $ a( 1 ), m1, b( m1, 0 ), ldb )
508 END IF
509*
510 ELSE
511*
512* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and
513* TRANS = 'C'
514*
515 IF( m.EQ.1 ) THEN
516 CALL ztrsm( 'L', 'U', 'N', diag, m1, n, alpha,
517 $ a( 0 ), m1, b, ldb )
518 ELSE
519 CALL ztrsm( 'L', 'L', 'C', diag, m2, n, alpha,
520 $ a( 1 ), m1, b( m1, 0 ), ldb )
521 CALL zgemm( 'N', 'N', m1, n, m2, -cone,
522 $ a( m1*m1 ), m1, b( m1, 0 ), ldb,
523 $ alpha, b, ldb )
524 CALL ztrsm( 'L', 'U', 'N', diag, m1, n, cone,
525 $ a( 0 ), m1, b, ldb )
526 END IF
527*
528 END IF
529*
530 ELSE
531*
532* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'U'
533*
534 IF( .NOT.notrans ) THEN
535*
536* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and
537* TRANS = 'N'
538*
539 CALL ztrsm( 'L', 'U', 'C', diag, m1, n, alpha,
540 $ a( m2*m2 ), m2, b, ldb )
541 CALL zgemm( 'N', 'N', m2, n, m1, -cone, a( 0 ), m2,
542 $ b, ldb, alpha, b( m1, 0 ), ldb )
543 CALL ztrsm( 'L', 'L', 'N', diag, m2, n, cone,
544 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
545*
546 ELSE
547*
548* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and
549* TRANS = 'C'
550*
551 CALL ztrsm( 'L', 'L', 'C', diag, m2, n, alpha,
552 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
553 CALL zgemm( 'C', 'N', m1, n, m2, -cone, a( 0 ), m2,
554 $ b( m1, 0 ), ldb, alpha, b, ldb )
555 CALL ztrsm( 'L', 'U', 'N', diag, m1, n, cone,
556 $ a( m2*m2 ), m2, b, ldb )
557*
558 END IF
559*
560 END IF
561*
562 END IF
563*
564 ELSE
565*
566* SIDE = 'L' and N is even
567*
568 IF( normaltransr ) THEN
569*
570* SIDE = 'L', N is even, and TRANSR = 'N'
571*
572 IF( lower ) THEN
573*
574* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L'
575*
576 IF( notrans ) THEN
577*
578* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L',
579* and TRANS = 'N'
580*
581 CALL ztrsm( 'L', 'L', 'N', diag, k, n, alpha,
582 $ a( 1 ), m+1, b, ldb )
583 CALL zgemm( 'N', 'N', k, n, k, -cone, a( k+1 ),
584 $ m+1, b, ldb, alpha, b( k, 0 ), ldb )
585 CALL ztrsm( 'L', 'U', 'C', diag, k, n, cone,
586 $ a( 0 ), m+1, b( k, 0 ), ldb )
587*
588 ELSE
589*
590* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L',
591* and TRANS = 'C'
592*
593 CALL ztrsm( 'L', 'U', 'N', diag, k, n, alpha,
594 $ a( 0 ), m+1, b( k, 0 ), ldb )
595 CALL zgemm( 'C', 'N', k, n, k, -cone, a( k+1 ),
596 $ m+1, b( k, 0 ), ldb, alpha, b, ldb )
597 CALL ztrsm( 'L', 'L', 'C', diag, k, n, cone,
598 $ a( 1 ), m+1, b, ldb )
599*
600 END IF
601*
602 ELSE
603*
604* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U'
605*
606 IF( .NOT.notrans ) THEN
607*
608* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U',
609* and TRANS = 'N'
610*
611 CALL ztrsm( 'L', 'L', 'N', diag, k, n, alpha,
612 $ a( k+1 ), m+1, b, ldb )
613 CALL zgemm( 'C', 'N', k, n, k, -cone, a( 0 ), m+1,
614 $ b, ldb, alpha, b( k, 0 ), ldb )
615 CALL ztrsm( 'L', 'U', 'C', diag, k, n, cone,
616 $ a( k ), m+1, b( k, 0 ), ldb )
617*
618 ELSE
619*
620* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U',
621* and TRANS = 'C'
622 CALL ztrsm( 'L', 'U', 'N', diag, k, n, alpha,
623 $ a( k ), m+1, b( k, 0 ), ldb )
624 CALL zgemm( 'N', 'N', k, n, k, -cone, a( 0 ), m+1,
625 $ b( k, 0 ), ldb, alpha, b, ldb )
626 CALL ztrsm( 'L', 'L', 'C', diag, k, n, cone,
627 $ a( k+1 ), m+1, b, ldb )
628*
629 END IF
630*
631 END IF
632*
633 ELSE
634*
635* SIDE = 'L', N is even, and TRANSR = 'C'
636*
637 IF( lower ) THEN
638*
639* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'L'
640*
641 IF( notrans ) THEN
642*
643* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L',
644* and TRANS = 'N'
645*
646 CALL ztrsm( 'L', 'U', 'C', diag, k, n, alpha,
647 $ a( k ), k, b, ldb )
648 CALL zgemm( 'C', 'N', k, n, k, -cone,
649 $ a( k*( k+1 ) ), k, b, ldb, alpha,
650 $ b( k, 0 ), ldb )
651 CALL ztrsm( 'L', 'L', 'N', diag, k, n, cone,
652 $ a( 0 ), k, b( k, 0 ), ldb )
653*
654 ELSE
655*
656* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L',
657* and TRANS = 'C'
658*
659 CALL ztrsm( 'L', 'L', 'C', diag, k, n, alpha,
660 $ a( 0 ), k, b( k, 0 ), ldb )
661 CALL zgemm( 'N', 'N', k, n, k, -cone,
662 $ a( k*( k+1 ) ), k, b( k, 0 ), ldb,
663 $ alpha, b, ldb )
664 CALL ztrsm( 'L', 'U', 'N', diag, k, n, cone,
665 $ a( k ), k, b, ldb )
666*
667 END IF
668*
669 ELSE
670*
671* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'U'
672*
673 IF( .NOT.notrans ) THEN
674*
675* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U',
676* and TRANS = 'N'
677*
678 CALL ztrsm( 'L', 'U', 'C', diag, k, n, alpha,
679 $ a( k*( k+1 ) ), k, b, ldb )
680 CALL zgemm( 'N', 'N', k, n, k, -cone, a( 0 ), k, b,
681 $ ldb, alpha, b( k, 0 ), ldb )
682 CALL ztrsm( 'L', 'L', 'N', diag, k, n, cone,
683 $ a( k*k ), k, b( k, 0 ), ldb )
684*
685 ELSE
686*
687* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U',
688* and TRANS = 'C'
689*
690 CALL ztrsm( 'L', 'L', 'C', diag, k, n, alpha,
691 $ a( k*k ), k, b( k, 0 ), ldb )
692 CALL zgemm( 'C', 'N', k, n, k, -cone, a( 0 ), k,
693 $ b( k, 0 ), ldb, alpha, b, ldb )
694 CALL ztrsm( 'L', 'U', 'N', diag, k, n, cone,
695 $ a( k*( k+1 ) ), k, b, ldb )
696*
697 END IF
698*
699 END IF
700*
701 END IF
702*
703 END IF
704*
705 ELSE
706*
707* SIDE = 'R'
708*
709* A is N-by-N.
710* If N is odd, set NISODD = .TRUE., and N1 and N2.
711* If N is even, NISODD = .FALSE., and K.
712*
713 IF( mod( n, 2 ).EQ.0 ) THEN
714 nisodd = .false.
715 k = n / 2
716 ELSE
717 nisodd = .true.
718 IF( lower ) THEN
719 n2 = n / 2
720 n1 = n - n2
721 ELSE
722 n1 = n / 2
723 n2 = n - n1
724 END IF
725 END IF
726*
727 IF( nisodd ) THEN
728*
729* SIDE = 'R' and N is odd
730*
731 IF( normaltransr ) THEN
732*
733* SIDE = 'R', N is odd, and TRANSR = 'N'
734*
735 IF( lower ) THEN
736*
737* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L'
738*
739 IF( notrans ) THEN
740*
741* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and
742* TRANS = 'N'
743*
744 CALL ztrsm( 'R', 'U', 'C', diag, m, n2, alpha,
745 $ a( n ), n, b( 0, n1 ), ldb )
746 CALL zgemm( 'N', 'N', m, n1, n2, -cone, b( 0, n1 ),
747 $ ldb, a( n1 ), n, alpha, b( 0, 0 ),
748 $ ldb )
749 CALL ztrsm( 'R', 'L', 'N', diag, m, n1, cone,
750 $ a( 0 ), n, b( 0, 0 ), ldb )
751*
752 ELSE
753*
754* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and
755* TRANS = 'C'
756*
757 CALL ztrsm( 'R', 'L', 'C', diag, m, n1, alpha,
758 $ a( 0 ), n, b( 0, 0 ), ldb )
759 CALL zgemm( 'N', 'C', m, n2, n1, -cone, b( 0, 0 ),
760 $ ldb, a( n1 ), n, alpha, b( 0, n1 ),
761 $ ldb )
762 CALL ztrsm( 'R', 'U', 'N', diag, m, n2, cone,
763 $ a( n ), n, b( 0, n1 ), ldb )
764*
765 END IF
766*
767 ELSE
768*
769* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U'
770*
771 IF( notrans ) THEN
772*
773* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and
774* TRANS = 'N'
775*
776 CALL ztrsm( 'R', 'L', 'C', diag, m, n1, alpha,
777 $ a( n2 ), n, b( 0, 0 ), ldb )
778 CALL zgemm( 'N', 'N', m, n2, n1, -cone, b( 0, 0 ),
779 $ ldb, a( 0 ), n, alpha, b( 0, n1 ),
780 $ ldb )
781 CALL ztrsm( 'R', 'U', 'N', diag, m, n2, cone,
782 $ a( n1 ), n, b( 0, n1 ), ldb )
783*
784 ELSE
785*
786* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and
787* TRANS = 'C'
788*
789 CALL ztrsm( 'R', 'U', 'C', diag, m, n2, alpha,
790 $ a( n1 ), n, b( 0, n1 ), ldb )
791 CALL zgemm( 'N', 'C', m, n1, n2, -cone, b( 0, n1 ),
792 $ ldb, a( 0 ), n, alpha, b( 0, 0 ), ldb )
793 CALL ztrsm( 'R', 'L', 'N', diag, m, n1, cone,
794 $ a( n2 ), n, b( 0, 0 ), ldb )
795*
796 END IF
797*
798 END IF
799*
800 ELSE
801*
802* SIDE = 'R', N is odd, and TRANSR = 'C'
803*
804 IF( lower ) THEN
805*
806* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'L'
807*
808 IF( notrans ) THEN
809*
810* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and
811* TRANS = 'N'
812*
813 CALL ztrsm( 'R', 'L', 'N', diag, m, n2, alpha,
814 $ a( 1 ), n1, b( 0, n1 ), ldb )
815 CALL zgemm( 'N', 'C', m, n1, n2, -cone, b( 0, n1 ),
816 $ ldb, a( n1*n1 ), n1, alpha, b( 0, 0 ),
817 $ ldb )
818 CALL ztrsm( 'R', 'U', 'C', diag, m, n1, cone,
819 $ a( 0 ), n1, b( 0, 0 ), ldb )
820*
821 ELSE
822*
823* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and
824* TRANS = 'C'
825*
826 CALL ztrsm( 'R', 'U', 'N', diag, m, n1, alpha,
827 $ a( 0 ), n1, b( 0, 0 ), ldb )
828 CALL zgemm( 'N', 'N', m, n2, n1, -cone, b( 0, 0 ),
829 $ ldb, a( n1*n1 ), n1, alpha, b( 0, n1 ),
830 $ ldb )
831 CALL ztrsm( 'R', 'L', 'C', diag, m, n2, cone,
832 $ a( 1 ), n1, b( 0, n1 ), ldb )
833*
834 END IF
835*
836 ELSE
837*
838* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'U'
839*
840 IF( notrans ) THEN
841*
842* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and
843* TRANS = 'N'
844*
845 CALL ztrsm( 'R', 'U', 'N', diag, m, n1, alpha,
846 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
847 CALL zgemm( 'N', 'C', m, n2, n1, -cone, b( 0, 0 ),
848 $ ldb, a( 0 ), n2, alpha, b( 0, n1 ),
849 $ ldb )
850 CALL ztrsm( 'R', 'L', 'C', diag, m, n2, cone,
851 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
852*
853 ELSE
854*
855* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and
856* TRANS = 'C'
857*
858 CALL ztrsm( 'R', 'L', 'N', diag, m, n2, alpha,
859 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
860 CALL zgemm( 'N', 'N', m, n1, n2, -cone, b( 0, n1 ),
861 $ ldb, a( 0 ), n2, alpha, b( 0, 0 ),
862 $ ldb )
863 CALL ztrsm( 'R', 'U', 'C', diag, m, n1, cone,
864 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
865*
866 END IF
867*
868 END IF
869*
870 END IF
871*
872 ELSE
873*
874* SIDE = 'R' and N is even
875*
876 IF( normaltransr ) THEN
877*
878* SIDE = 'R', N is even, and TRANSR = 'N'
879*
880 IF( lower ) THEN
881*
882* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L'
883*
884 IF( notrans ) THEN
885*
886* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L',
887* and TRANS = 'N'
888*
889 CALL ztrsm( 'R', 'U', 'C', diag, m, k, alpha,
890 $ a( 0 ), n+1, b( 0, k ), ldb )
891 CALL zgemm( 'N', 'N', m, k, k, -cone, b( 0, k ),
892 $ ldb, a( k+1 ), n+1, alpha, b( 0, 0 ),
893 $ ldb )
894 CALL ztrsm( 'R', 'L', 'N', diag, m, k, cone,
895 $ a( 1 ), n+1, b( 0, 0 ), ldb )
896*
897 ELSE
898*
899* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L',
900* and TRANS = 'C'
901*
902 CALL ztrsm( 'R', 'L', 'C', diag, m, k, alpha,
903 $ a( 1 ), n+1, b( 0, 0 ), ldb )
904 CALL zgemm( 'N', 'C', m, k, k, -cone, b( 0, 0 ),
905 $ ldb, a( k+1 ), n+1, alpha, b( 0, k ),
906 $ ldb )
907 CALL ztrsm( 'R', 'U', 'N', diag, m, k, cone,
908 $ a( 0 ), n+1, b( 0, k ), ldb )
909*
910 END IF
911*
912 ELSE
913*
914* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U'
915*
916 IF( notrans ) THEN
917*
918* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U',
919* and TRANS = 'N'
920*
921 CALL ztrsm( 'R', 'L', 'C', diag, m, k, alpha,
922 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
923 CALL zgemm( 'N', 'N', m, k, k, -cone, b( 0, 0 ),
924 $ ldb, a( 0 ), n+1, alpha, b( 0, k ),
925 $ ldb )
926 CALL ztrsm( 'R', 'U', 'N', diag, m, k, cone,
927 $ a( k ), n+1, b( 0, k ), ldb )
928*
929 ELSE
930*
931* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U',
932* and TRANS = 'C'
933*
934 CALL ztrsm( 'R', 'U', 'C', diag, m, k, alpha,
935 $ a( k ), n+1, b( 0, k ), ldb )
936 CALL zgemm( 'N', 'C', m, k, k, -cone, b( 0, k ),
937 $ ldb, a( 0 ), n+1, alpha, b( 0, 0 ),
938 $ ldb )
939 CALL ztrsm( 'R', 'L', 'N', diag, m, k, cone,
940 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
941*
942 END IF
943*
944 END IF
945*
946 ELSE
947*
948* SIDE = 'R', N is even, and TRANSR = 'C'
949*
950 IF( lower ) THEN
951*
952* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'L'
953*
954 IF( notrans ) THEN
955*
956* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L',
957* and TRANS = 'N'
958*
959 CALL ztrsm( 'R', 'L', 'N', diag, m, k, alpha,
960 $ a( 0 ), k, b( 0, k ), ldb )
961 CALL zgemm( 'N', 'C', m, k, k, -cone, b( 0, k ),
962 $ ldb, a( ( k+1 )*k ), k, alpha,
963 $ b( 0, 0 ), ldb )
964 CALL ztrsm( 'R', 'U', 'C', diag, m, k, cone,
965 $ a( k ), k, b( 0, 0 ), ldb )
966*
967 ELSE
968*
969* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L',
970* and TRANS = 'C'
971*
972 CALL ztrsm( 'R', 'U', 'N', diag, m, k, alpha,
973 $ a( k ), k, b( 0, 0 ), ldb )
974 CALL zgemm( 'N', 'N', m, k, k, -cone, b( 0, 0 ),
975 $ ldb, a( ( k+1 )*k ), k, alpha,
976 $ b( 0, k ), ldb )
977 CALL ztrsm( 'R', 'L', 'C', diag, m, k, cone,
978 $ a( 0 ), k, b( 0, k ), ldb )
979*
980 END IF
981*
982 ELSE
983*
984* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'U'
985*
986 IF( notrans ) THEN
987*
988* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U',
989* and TRANS = 'N'
990*
991 CALL ztrsm( 'R', 'U', 'N', diag, m, k, alpha,
992 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
993 CALL zgemm( 'N', 'C', m, k, k, -cone, b( 0, 0 ),
994 $ ldb, a( 0 ), k, alpha, b( 0, k ), ldb )
995 CALL ztrsm( 'R', 'L', 'C', diag, m, k, cone,
996 $ a( k*k ), k, b( 0, k ), ldb )
997*
998 ELSE
999*
1000* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U',
1001* and TRANS = 'C'
1002*
1003 CALL ztrsm( 'R', 'L', 'N', diag, m, k, alpha,
1004 $ a( k*k ), k, b( 0, k ), ldb )
1005 CALL zgemm( 'N', 'N', m, k, k, -cone, b( 0, k ),
1006 $ ldb, a( 0 ), k, alpha, b( 0, 0 ), ldb )
1007 CALL ztrsm( 'R', 'U', 'C', diag, m, k, cone,
1008 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
1009*
1010 END IF
1011*
1012 END IF
1013*
1014 END IF
1015*
1016 END IF
1017 END IF
1018*
1019 RETURN
1020*
1021* End of ZTFSM
1022*

◆ ztftri()

subroutine ztftri ( character transr,
character uplo,
character diag,
integer n,
complex*16, dimension( 0: * ) a,
integer info )

ZTFTRI

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

Purpose:
!>
!> ZTFTRI computes the inverse of a triangular matrix A stored in RFP
!> format.
!>
!> This is a Level 3 BLAS version of the algorithm.
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  The Normal TRANSR of RFP A is stored;
!>          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension ( N*(N+1)/2 );
!>          On entry, the triangular matrix A in RFP format. RFP format
!>          is described by TRANSR, UPLO, and N as follows: If TRANSR =
!>          'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is
!>          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is
!>          the Conjugate-transpose of RFP A as defined when
!>          TRANSR = 'N'. The contents of RFP A are defined by UPLO as
!>          follows: If UPLO = 'U' the RFP A contains the nt elements of
!>          upper packed A; If UPLO = 'L' the RFP A contains the nt
!>          elements of lower packed A. The LDA of RFP A is (N+1)/2 when
!>          TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is
!>          even and N is odd. See the Note below for more details.
!>
!>          On exit, the (triangular) inverse of the original matrix, in
!>          the same storage format.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
!>               matrix is singular and its inverse can not be computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  We first consider Standard Packed Format when N is even.
!>  We give an example where N = 6.
!>
!>      AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  conjugate-transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  conjugate-transpose of the last three columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                -- -- --
!>        03 04 05                33 43 53
!>                                   -- --
!>        13 14 15                00 44 54
!>                                      --
!>        23 24 25                10 11 55
!>
!>        33 34 35                20 21 22
!>        --
!>        00 44 45                30 31 32
!>        -- --
!>        01 11 55                40 41 42
!>        -- -- --
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- -- --                -- -- -- -- -- --
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     -- -- -- -- --                -- -- -- -- --
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     -- -- -- -- -- --                -- -- -- --
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>
!>  We next  consider Standard Packed Format when N is odd.
!>  We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  conjugate-transpose of the first two   columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  conjugate-transpose of the last two   columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N odd  and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                   -- --
!>        02 03 04                00 33 43
!>                                      --
!>        12 13 14                10 11 44
!>
!>        22 23 24                20 21 22
!>        --
!>        00 33 34                30 31 32
!>        -- --
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- --                   -- -- -- -- -- --
!>     02 12 22 00 01             00 10 20 30 40 50
!>     -- -- -- --                   -- -- -- -- --
!>     03 13 23 33 11             33 11 21 31 41 51
!>     -- -- -- -- --                   -- -- -- --
!>     04 14 24 34 44             43 44 22 32 42 52
!>

Definition at line 220 of file ztftri.f.

221*
222* -- LAPACK computational routine --
223* -- LAPACK is a software package provided by Univ. of Tennessee, --
224* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
225*
226* .. Scalar Arguments ..
227 CHARACTER TRANSR, UPLO, DIAG
228 INTEGER INFO, N
229* ..
230* .. Array Arguments ..
231 COMPLEX*16 A( 0: * )
232* ..
233*
234* =====================================================================
235*
236* .. Parameters ..
237 COMPLEX*16 CONE
238 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
239* ..
240* .. Local Scalars ..
241 LOGICAL LOWER, NISODD, NORMALTRANSR
242 INTEGER N1, N2, K
243* ..
244* .. External Functions ..
245 LOGICAL LSAME
246 EXTERNAL lsame
247* ..
248* .. External Subroutines ..
249 EXTERNAL xerbla, ztrmm, ztrtri
250* ..
251* .. Intrinsic Functions ..
252 INTRINSIC mod
253* ..
254* .. Executable Statements ..
255*
256* Test the input parameters.
257*
258 info = 0
259 normaltransr = lsame( transr, 'N' )
260 lower = lsame( uplo, 'L' )
261 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
262 info = -1
263 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
264 info = -2
265 ELSE IF( .NOT.lsame( diag, 'N' ) .AND. .NOT.lsame( diag, 'U' ) )
266 $ THEN
267 info = -3
268 ELSE IF( n.LT.0 ) THEN
269 info = -4
270 END IF
271 IF( info.NE.0 ) THEN
272 CALL xerbla( 'ZTFTRI', -info )
273 RETURN
274 END IF
275*
276* Quick return if possible
277*
278 IF( n.EQ.0 )
279 $ RETURN
280*
281* If N is odd, set NISODD = .TRUE.
282* If N is even, set K = N/2 and NISODD = .FALSE.
283*
284 IF( mod( n, 2 ).EQ.0 ) THEN
285 k = n / 2
286 nisodd = .false.
287 ELSE
288 nisodd = .true.
289 END IF
290*
291* Set N1 and N2 depending on LOWER
292*
293 IF( lower ) THEN
294 n2 = n / 2
295 n1 = n - n2
296 ELSE
297 n1 = n / 2
298 n2 = n - n1
299 END IF
300*
301*
302* start execution: there are eight cases
303*
304 IF( nisodd ) THEN
305*
306* N is odd
307*
308 IF( normaltransr ) THEN
309*
310* N is odd and TRANSR = 'N'
311*
312 IF( lower ) THEN
313*
314* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) )
315* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0)
316* T1 -> a(0), T2 -> a(n), S -> a(n1)
317*
318 CALL ztrtri( 'L', diag, n1, a( 0 ), n, info )
319 IF( info.GT.0 )
320 $ RETURN
321 CALL ztrmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0 ),
322 $ n, a( n1 ), n )
323 CALL ztrtri( 'U', diag, n2, a( n ), n, info )
324 IF( info.GT.0 )
325 $ info = info + n1
326 IF( info.GT.0 )
327 $ RETURN
328 CALL ztrmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,
329 $ a( n1 ), n )
330*
331 ELSE
332*
333* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1)
334* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0)
335* T1 -> a(n2), T2 -> a(n1), S -> a(0)
336*
337 CALL ztrtri( 'L', diag, n1, a( n2 ), n, info )
338 IF( info.GT.0 )
339 $ RETURN
340 CALL ztrmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),
341 $ n, a( 0 ), n )
342 CALL ztrtri( 'U', diag, n2, a( n1 ), n, info )
343 IF( info.GT.0 )
344 $ info = info + n1
345 IF( info.GT.0 )
346 $ RETURN
347 CALL ztrmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),
348 $ n, a( 0 ), n )
349*
350 END IF
351*
352 ELSE
353*
354* N is odd and TRANSR = 'C'
355*
356 IF( lower ) THEN
357*
358* SRPA for LOWER, TRANSPOSE and N is odd
359* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1)
360*
361 CALL ztrtri( 'U', diag, n1, a( 0 ), n1, info )
362 IF( info.GT.0 )
363 $ RETURN
364 CALL ztrmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0 ),
365 $ n1, a( n1*n1 ), n1 )
366 CALL ztrtri( 'L', diag, n2, a( 1 ), n1, info )
367 IF( info.GT.0 )
368 $ info = info + n1
369 IF( info.GT.0 )
370 $ RETURN
371 CALL ztrmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1 ),
372 $ n1, a( n1*n1 ), n1 )
373*
374 ELSE
375*
376* SRPA for UPPER, TRANSPOSE and N is odd
377* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0)
378*
379 CALL ztrtri( 'U', diag, n1, a( n2*n2 ), n2, info )
380 IF( info.GT.0 )
381 $ RETURN
382 CALL ztrmm( 'R', 'U', 'C', diag, n2, n1, -cone,
383 $ a( n2*n2 ), n2, a( 0 ), n2 )
384 CALL ztrtri( 'L', diag, n2, a( n1*n2 ), n2, info )
385 IF( info.GT.0 )
386 $ info = info + n1
387 IF( info.GT.0 )
388 $ RETURN
389 CALL ztrmm( 'L', 'L', 'N', diag, n2, n1, cone,
390 $ a( n1*n2 ), n2, a( 0 ), n2 )
391 END IF
392*
393 END IF
394*
395 ELSE
396*
397* N is even
398*
399 IF( normaltransr ) THEN
400*
401* N is even and TRANSR = 'N'
402*
403 IF( lower ) THEN
404*
405* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) )
406* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0)
407* T1 -> a(1), T2 -> a(0), S -> a(k+1)
408*
409 CALL ztrtri( 'L', diag, k, a( 1 ), n+1, info )
410 IF( info.GT.0 )
411 $ RETURN
412 CALL ztrmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1 ),
413 $ n+1, a( k+1 ), n+1 )
414 CALL ztrtri( 'U', diag, k, a( 0 ), n+1, info )
415 IF( info.GT.0 )
416 $ info = info + k
417 IF( info.GT.0 )
418 $ RETURN
419 CALL ztrmm( 'L', 'U', 'C', diag, k, k, cone, a( 0 ), n+1,
420 $ a( k+1 ), n+1 )
421*
422 ELSE
423*
424* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) )
425* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0)
426* T1 -> a(k+1), T2 -> a(k), S -> a(0)
427*
428 CALL ztrtri( 'L', diag, k, a( k+1 ), n+1, info )
429 IF( info.GT.0 )
430 $ RETURN
431 CALL ztrmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),
432 $ n+1, a( 0 ), n+1 )
433 CALL ztrtri( 'U', diag, k, a( k ), n+1, info )
434 IF( info.GT.0 )
435 $ info = info + k
436 IF( info.GT.0 )
437 $ RETURN
438 CALL ztrmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,
439 $ a( 0 ), n+1 )
440 END IF
441 ELSE
442*
443* N is even and TRANSR = 'C'
444*
445 IF( lower ) THEN
446*
447* SRPA for LOWER, TRANSPOSE and N is even (see paper)
448* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1)
449* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k
450*
451 CALL ztrtri( 'U', diag, k, a( k ), k, info )
452 IF( info.GT.0 )
453 $ RETURN
454 CALL ztrmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,
455 $ a( k*( k+1 ) ), k )
456 CALL ztrtri( 'L', diag, k, a( 0 ), k, info )
457 IF( info.GT.0 )
458 $ info = info + k
459 IF( info.GT.0 )
460 $ RETURN
461 CALL ztrmm( 'R', 'L', 'C', diag, k, k, cone, a( 0 ), k,
462 $ a( k*( k+1 ) ), k )
463 ELSE
464*
465* SRPA for UPPER, TRANSPOSE and N is even (see paper)
466* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0)
467* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k
468*
469 CALL ztrtri( 'U', diag, k, a( k*( k+1 ) ), k, info )
470 IF( info.GT.0 )
471 $ RETURN
472 CALL ztrmm( 'R', 'U', 'C', diag, k, k, -cone,
473 $ a( k*( k+1 ) ), k, a( 0 ), k )
474 CALL ztrtri( 'L', diag, k, a( k*k ), k, info )
475 IF( info.GT.0 )
476 $ info = info + k
477 IF( info.GT.0 )
478 $ RETURN
479 CALL ztrmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,
480 $ a( 0 ), k )
481 END IF
482 END IF
483 END IF
484*
485 RETURN
486*
487* End of ZTFTRI
488*
ztrtri
subroutine ztrtri(uplo, diag, n, a, lda, info)
ZTRTRI
Definition ztrtri.f:109

◆ ztfttp()

subroutine ztfttp ( character transr,
character uplo,
integer n,
complex*16, dimension( 0: * ) arf,
complex*16, dimension( 0: * ) ap,
integer info )

ZTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed format (TP).

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

Purpose:
!>
!> ZTFTTP copies a triangular matrix A from rectangular full packed
!> format (TF) to standard packed format (TP).
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  ARF is in Normal format;
!>          = 'C':  ARF is in Conjugate-transpose format;
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A. N >= 0.
!>
[in]ARF
!>          ARF is COMPLEX*16 array, dimension ( N*(N+1)/2 ),
!>          On entry, the upper or lower triangular matrix A stored in
!>          RFP format. For a further discussion see Notes below.
!>
[out]AP
!>          AP is COMPLEX*16 array, dimension ( N*(N+1)/2 ),
!>          On exit, 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.
!>
[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.
Further Details:
!>
!>  We first consider Standard Packed Format when N is even.
!>  We give an example where N = 6.
!>
!>      AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  conjugate-transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  conjugate-transpose of the last three columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                -- -- --
!>        03 04 05                33 43 53
!>                                   -- --
!>        13 14 15                00 44 54
!>                                      --
!>        23 24 25                10 11 55
!>
!>        33 34 35                20 21 22
!>        --
!>        00 44 45                30 31 32
!>        -- --
!>        01 11 55                40 41 42
!>        -- -- --
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- -- --                -- -- -- -- -- --
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     -- -- -- -- --                -- -- -- -- --
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     -- -- -- -- -- --                -- -- -- --
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>
!>  We next consider Standard Packed Format when N is odd.
!>  We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  conjugate-transpose of the first two   columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  conjugate-transpose of the last two   columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N odd  and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                   -- --
!>        02 03 04                00 33 43
!>                                      --
!>        12 13 14                10 11 44
!>
!>        22 23 24                20 21 22
!>        --
!>        00 33 34                30 31 32
!>        -- --
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- --                   -- -- -- -- -- --
!>     02 12 22 00 01             00 10 20 30 40 50
!>     -- -- -- --                   -- -- -- -- --
!>     03 13 23 33 11             33 11 21 31 41 51
!>     -- -- -- -- --                   -- -- -- --
!>     04 14 24 34 44             43 44 22 32 42 52
!>

Definition at line 207 of file ztfttp.f.

208*
209* -- LAPACK computational routine --
210* -- LAPACK is a software package provided by Univ. of Tennessee, --
211* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
212*
213* .. Scalar Arguments ..
214 CHARACTER TRANSR, UPLO
215 INTEGER INFO, N
216* ..
217* .. Array Arguments ..
218 COMPLEX*16 AP( 0: * ), ARF( 0: * )
219* ..
220*
221* =====================================================================
222*
223* .. Parameters ..
224* ..
225* .. Local Scalars ..
226 LOGICAL LOWER, NISODD, NORMALTRANSR
227 INTEGER N1, N2, K, NT
228 INTEGER I, J, IJ
229 INTEGER IJP, JP, LDA, JS
230* ..
231* .. External Functions ..
232 LOGICAL LSAME
233 EXTERNAL lsame
234* ..
235* .. External Subroutines ..
236 EXTERNAL xerbla
237* ..
238* .. Intrinsic Functions ..
239 INTRINSIC dconjg
240* ..
241* .. Intrinsic Functions ..
242* ..
243* .. Executable Statements ..
244*
245* Test the input parameters.
246*
247 info = 0
248 normaltransr = lsame( transr, 'N' )
249 lower = lsame( uplo, 'L' )
250 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
251 info = -1
252 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
253 info = -2
254 ELSE IF( n.LT.0 ) THEN
255 info = -3
256 END IF
257 IF( info.NE.0 ) THEN
258 CALL xerbla( 'ZTFTTP', -info )
259 RETURN
260 END IF
261*
262* Quick return if possible
263*
264 IF( n.EQ.0 )
265 $ RETURN
266*
267 IF( n.EQ.1 ) THEN
268 IF( normaltransr ) THEN
269 ap( 0 ) = arf( 0 )
270 ELSE
271 ap( 0 ) = dconjg( arf( 0 ) )
272 END IF
273 RETURN
274 END IF
275*
276* Size of array ARF(0:NT-1)
277*
278 nt = n*( n+1 ) / 2
279*
280* Set N1 and N2 depending on LOWER
281*
282 IF( lower ) THEN
283 n2 = n / 2
284 n1 = n - n2
285 ELSE
286 n1 = n / 2
287 n2 = n - n1
288 END IF
289*
290* If N is odd, set NISODD = .TRUE.
291* If N is even, set K = N/2 and NISODD = .FALSE.
292*
293* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe)
294* where noe = 0 if n is even, noe = 1 if n is odd
295*
296 IF( mod( n, 2 ).EQ.0 ) THEN
297 k = n / 2
298 nisodd = .false.
299 lda = n + 1
300 ELSE
301 nisodd = .true.
302 lda = n
303 END IF
304*
305* ARF^C has lda rows and n+1-noe cols
306*
307 IF( .NOT.normaltransr )
308 $ lda = ( n+1 ) / 2
309*
310* start execution: there are eight cases
311*
312 IF( nisodd ) THEN
313*
314* N is odd
315*
316 IF( normaltransr ) THEN
317*
318* N is odd and TRANSR = 'N'
319*
320 IF( lower ) THEN
321*
322* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) )
323* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0)
324* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n
325*
326 ijp = 0
327 jp = 0
328 DO j = 0, n2
329 DO i = j, n - 1
330 ij = i + jp
331 ap( ijp ) = arf( ij )
332 ijp = ijp + 1
333 END DO
334 jp = jp + lda
335 END DO
336 DO i = 0, n2 - 1
337 DO j = 1 + i, n2
338 ij = i + j*lda
339 ap( ijp ) = dconjg( arf( ij ) )
340 ijp = ijp + 1
341 END DO
342 END DO
343*
344 ELSE
345*
346* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1)
347* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0)
348* T1 -> a(n2), T2 -> a(n1), S -> a(0)
349*
350 ijp = 0
351 DO j = 0, n1 - 1
352 ij = n2 + j
353 DO i = 0, j
354 ap( ijp ) = dconjg( arf( ij ) )
355 ijp = ijp + 1
356 ij = ij + lda
357 END DO
358 END DO
359 js = 0
360 DO j = n1, n - 1
361 ij = js
362 DO ij = js, js + j
363 ap( ijp ) = arf( ij )
364 ijp = ijp + 1
365 END DO
366 js = js + lda
367 END DO
368*
369 END IF
370*
371 ELSE
372*
373* N is odd and TRANSR = 'C'
374*
375 IF( lower ) THEN
376*
377* SRPA for LOWER, TRANSPOSE and N is odd
378* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1)
379* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1
380*
381 ijp = 0
382 DO i = 0, n2
383 DO ij = i*( lda+1 ), n*lda - 1, lda
384 ap( ijp ) = dconjg( arf( ij ) )
385 ijp = ijp + 1
386 END DO
387 END DO
388 js = 1
389 DO j = 0, n2 - 1
390 DO ij = js, js + n2 - j - 1
391 ap( ijp ) = arf( ij )
392 ijp = ijp + 1
393 END DO
394 js = js + lda + 1
395 END DO
396*
397 ELSE
398*
399* SRPA for UPPER, TRANSPOSE and N is odd
400* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0)
401* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2
402*
403 ijp = 0
404 js = n2*lda
405 DO j = 0, n1 - 1
406 DO ij = js, js + j
407 ap( ijp ) = arf( ij )
408 ijp = ijp + 1
409 END DO
410 js = js + lda
411 END DO
412 DO i = 0, n1
413 DO ij = i, i + ( n1+i )*lda, lda
414 ap( ijp ) = dconjg( arf( ij ) )
415 ijp = ijp + 1
416 END DO
417 END DO
418*
419 END IF
420*
421 END IF
422*
423 ELSE
424*
425* N is even
426*
427 IF( normaltransr ) THEN
428*
429* N is even and TRANSR = 'N'
430*
431 IF( lower ) THEN
432*
433* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) )
434* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0)
435* T1 -> a(1), T2 -> a(0), S -> a(k+1)
436*
437 ijp = 0
438 jp = 0
439 DO j = 0, k - 1
440 DO i = j, n - 1
441 ij = 1 + i + jp
442 ap( ijp ) = arf( ij )
443 ijp = ijp + 1
444 END DO
445 jp = jp + lda
446 END DO
447 DO i = 0, k - 1
448 DO j = i, k - 1
449 ij = i + j*lda
450 ap( ijp ) = dconjg( arf( ij ) )
451 ijp = ijp + 1
452 END DO
453 END DO
454*
455 ELSE
456*
457* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) )
458* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0)
459* T1 -> a(k+1), T2 -> a(k), S -> a(0)
460*
461 ijp = 0
462 DO j = 0, k - 1
463 ij = k + 1 + j
464 DO i = 0, j
465 ap( ijp ) = dconjg( arf( ij ) )
466 ijp = ijp + 1
467 ij = ij + lda
468 END DO
469 END DO
470 js = 0
471 DO j = k, n - 1
472 ij = js
473 DO ij = js, js + j
474 ap( ijp ) = arf( ij )
475 ijp = ijp + 1
476 END DO
477 js = js + lda
478 END DO
479*
480 END IF
481*
482 ELSE
483*
484* N is even and TRANSR = 'C'
485*
486 IF( lower ) THEN
487*
488* SRPA for LOWER, TRANSPOSE and N is even (see paper)
489* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1)
490* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k
491*
492 ijp = 0
493 DO i = 0, k - 1
494 DO ij = i + ( i+1 )*lda, ( n+1 )*lda - 1, lda
495 ap( ijp ) = dconjg( arf( ij ) )
496 ijp = ijp + 1
497 END DO
498 END DO
499 js = 0
500 DO j = 0, k - 1
501 DO ij = js, js + k - j - 1
502 ap( ijp ) = arf( ij )
503 ijp = ijp + 1
504 END DO
505 js = js + lda + 1
506 END DO
507*
508 ELSE
509*
510* SRPA for UPPER, TRANSPOSE and N is even (see paper)
511* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0)
512* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k
513*
514 ijp = 0
515 js = ( k+1 )*lda
516 DO j = 0, k - 1
517 DO ij = js, js + j
518 ap( ijp ) = arf( ij )
519 ijp = ijp + 1
520 END DO
521 js = js + lda
522 END DO
523 DO i = 0, k - 1
524 DO ij = i, i + ( k+i )*lda, lda
525 ap( ijp ) = dconjg( arf( ij ) )
526 ijp = ijp + 1
527 END DO
528 END DO
529*
530 END IF
531*
532 END IF
533*
534 END IF
535*
536 RETURN
537*
538* End of ZTFTTP
539*

◆ ztfttr()

subroutine ztfttr ( character transr,
character uplo,
integer n,
complex*16, dimension( 0: * ) arf,
complex*16, dimension( 0: lda-1, 0: * ) a,
integer lda,
integer info )

ZTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full format (TR).

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

Purpose:
!>
!> ZTFTTR copies a triangular matrix A from rectangular full packed
!> format (TF) to standard full format (TR).
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  ARF is in Normal format;
!>          = 'C':  ARF is in Conjugate-transpose format;
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]ARF
!>          ARF is COMPLEX*16 array, dimension ( N*(N+1)/2 ),
!>          On entry, the upper or lower triangular matrix A stored in
!>          RFP format. For a further discussion see Notes below.
!>
[out]A
!>          A is COMPLEX*16 array, dimension ( LDA, N )
!>          On exit, 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.
!>
[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 = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  We first consider Standard Packed Format when N is even.
!>  We give an example where N = 6.
!>
!>      AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  conjugate-transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  conjugate-transpose of the last three columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                -- -- --
!>        03 04 05                33 43 53
!>                                   -- --
!>        13 14 15                00 44 54
!>                                      --
!>        23 24 25                10 11 55
!>
!>        33 34 35                20 21 22
!>        --
!>        00 44 45                30 31 32
!>        -- --
!>        01 11 55                40 41 42
!>        -- -- --
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- -- --                -- -- -- -- -- --
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     -- -- -- -- --                -- -- -- -- --
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     -- -- -- -- -- --                -- -- -- --
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>
!>  We next  consider Standard Packed Format when N is odd.
!>  We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  conjugate-transpose of the first two   columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  conjugate-transpose of the last two   columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N odd  and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                   -- --
!>        02 03 04                00 33 43
!>                                      --
!>        12 13 14                10 11 44
!>
!>        22 23 24                20 21 22
!>        --
!>        00 33 34                30 31 32
!>        -- --
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- --                   -- -- -- -- -- --
!>     02 12 22 00 01             00 10 20 30 40 50
!>     -- -- -- --                   -- -- -- -- --
!>     03 13 23 33 11             33 11 21 31 41 51
!>     -- -- -- -- --                   -- -- -- --
!>     04 14 24 34 44             43 44 22 32 42 52
!>

Definition at line 215 of file ztfttr.f.

216*
217* -- LAPACK computational routine --
218* -- LAPACK is a software package provided by Univ. of Tennessee, --
219* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
220*
221* .. Scalar Arguments ..
222 CHARACTER TRANSR, UPLO
223 INTEGER INFO, N, LDA
224* ..
225* .. Array Arguments ..
226 COMPLEX*16 A( 0: LDA-1, 0: * ), ARF( 0: * )
227* ..
228*
229* =====================================================================
230*
231* .. Parameters ..
232* ..
233* .. Local Scalars ..
234 LOGICAL LOWER, NISODD, NORMALTRANSR
235 INTEGER N1, N2, K, NT, NX2, NP1X2
236 INTEGER I, J, L, IJ
237* ..
238* .. External Functions ..
239 LOGICAL LSAME
240 EXTERNAL lsame
241* ..
242* .. External Subroutines ..
243 EXTERNAL xerbla
244* ..
245* .. Intrinsic Functions ..
246 INTRINSIC dconjg, max, mod
247* ..
248* .. Executable Statements ..
249*
250* Test the input parameters.
251*
252 info = 0
253 normaltransr = lsame( transr, 'N' )
254 lower = lsame( uplo, 'L' )
255 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
256 info = -1
257 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
258 info = -2
259 ELSE IF( n.LT.0 ) THEN
260 info = -3
261 ELSE IF( lda.LT.max( 1, n ) ) THEN
262 info = -6
263 END IF
264 IF( info.NE.0 ) THEN
265 CALL xerbla( 'ZTFTTR', -info )
266 RETURN
267 END IF
268*
269* Quick return if possible
270*
271 IF( n.LE.1 ) THEN
272 IF( n.EQ.1 ) THEN
273 IF( normaltransr ) THEN
274 a( 0, 0 ) = arf( 0 )
275 ELSE
276 a( 0, 0 ) = dconjg( arf( 0 ) )
277 END IF
278 END IF
279 RETURN
280 END IF
281*
282* Size of array ARF(1:2,0:nt-1)
283*
284 nt = n*( n+1 ) / 2
285*
286* set N1 and N2 depending on LOWER: for N even N1=N2=K
287*
288 IF( lower ) THEN
289 n2 = n / 2
290 n1 = n - n2
291 ELSE
292 n1 = n / 2
293 n2 = n - n1
294 END IF
295*
296* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2.
297* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is
298* N--by--(N+1)/2.
299*
300 IF( mod( n, 2 ).EQ.0 ) THEN
301 k = n / 2
302 nisodd = .false.
303 IF( .NOT.lower )
304 $ np1x2 = n + n + 2
305 ELSE
306 nisodd = .true.
307 IF( .NOT.lower )
308 $ nx2 = n + n
309 END IF
310*
311 IF( nisodd ) THEN
312*
313* N is odd
314*
315 IF( normaltransr ) THEN
316*
317* N is odd and TRANSR = 'N'
318*
319 IF( lower ) THEN
320*
321* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) )
322* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0)
323* T1 -> a(0), T2 -> a(n), S -> a(n1); lda=n
324*
325 ij = 0
326 DO j = 0, n2
327 DO i = n1, n2 + j
328 a( n2+j, i ) = dconjg( arf( ij ) )
329 ij = ij + 1
330 END DO
331 DO i = j, n - 1
332 a( i, j ) = arf( ij )
333 ij = ij + 1
334 END DO
335 END DO
336*
337 ELSE
338*
339* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1)
340* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0)
341* T1 -> a(n2), T2 -> a(n1), S -> a(0); lda=n
342*
343 ij = nt - n
344 DO j = n - 1, n1, -1
345 DO i = 0, j
346 a( i, j ) = arf( ij )
347 ij = ij + 1
348 END DO
349 DO l = j - n1, n1 - 1
350 a( j-n1, l ) = dconjg( arf( ij ) )
351 ij = ij + 1
352 END DO
353 ij = ij - nx2
354 END DO
355*
356 END IF
357*
358 ELSE
359*
360* N is odd and TRANSR = 'C'
361*
362 IF( lower ) THEN
363*
364* SRPA for LOWER, TRANSPOSE and N is odd
365* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1)
366* T1 -> A(0+0) , T2 -> A(1+0) , S -> A(0+n1*n1); lda=n1
367*
368 ij = 0
369 DO j = 0, n2 - 1
370 DO i = 0, j
371 a( j, i ) = dconjg( arf( ij ) )
372 ij = ij + 1
373 END DO
374 DO i = n1 + j, n - 1
375 a( i, n1+j ) = arf( ij )
376 ij = ij + 1
377 END DO
378 END DO
379 DO j = n2, n - 1
380 DO i = 0, n1 - 1
381 a( j, i ) = dconjg( arf( ij ) )
382 ij = ij + 1
383 END DO
384 END DO
385*
386 ELSE
387*
388* SRPA for UPPER, TRANSPOSE and N is odd
389* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0)
390* T1 -> A(n2*n2), T2 -> A(n1*n2), S -> A(0); lda = n2
391*
392 ij = 0
393 DO j = 0, n1
394 DO i = n1, n - 1
395 a( j, i ) = dconjg( arf( ij ) )
396 ij = ij + 1
397 END DO
398 END DO
399 DO j = 0, n1 - 1
400 DO i = 0, j
401 a( i, j ) = arf( ij )
402 ij = ij + 1
403 END DO
404 DO l = n2 + j, n - 1
405 a( n2+j, l ) = dconjg( arf( ij ) )
406 ij = ij + 1
407 END DO
408 END DO
409*
410 END IF
411*
412 END IF
413*
414 ELSE
415*
416* N is even
417*
418 IF( normaltransr ) THEN
419*
420* N is even and TRANSR = 'N'
421*
422 IF( lower ) THEN
423*
424* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) )
425* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0)
426* T1 -> a(1), T2 -> a(0), S -> a(k+1); lda=n+1
427*
428 ij = 0
429 DO j = 0, k - 1
430 DO i = k, k + j
431 a( k+j, i ) = dconjg( arf( ij ) )
432 ij = ij + 1
433 END DO
434 DO i = j, n - 1
435 a( i, j ) = arf( ij )
436 ij = ij + 1
437 END DO
438 END DO
439*
440 ELSE
441*
442* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) )
443* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0)
444* T1 -> a(k+1), T2 -> a(k), S -> a(0); lda=n+1
445*
446 ij = nt - n - 1
447 DO j = n - 1, k, -1
448 DO i = 0, j
449 a( i, j ) = arf( ij )
450 ij = ij + 1
451 END DO
452 DO l = j - k, k - 1
453 a( j-k, l ) = dconjg( arf( ij ) )
454 ij = ij + 1
455 END DO
456 ij = ij - np1x2
457 END DO
458*
459 END IF
460*
461 ELSE
462*
463* N is even and TRANSR = 'C'
464*
465 IF( lower ) THEN
466*
467* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B)
468* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) :
469* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k
470*
471 ij = 0
472 j = k
473 DO i = k, n - 1
474 a( i, j ) = arf( ij )
475 ij = ij + 1
476 END DO
477 DO j = 0, k - 2
478 DO i = 0, j
479 a( j, i ) = dconjg( arf( ij ) )
480 ij = ij + 1
481 END DO
482 DO i = k + 1 + j, n - 1
483 a( i, k+1+j ) = arf( ij )
484 ij = ij + 1
485 END DO
486 END DO
487 DO j = k - 1, n - 1
488 DO i = 0, k - 1
489 a( j, i ) = dconjg( arf( ij ) )
490 ij = ij + 1
491 END DO
492 END DO
493*
494 ELSE
495*
496* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B)
497* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0)
498* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k
499*
500 ij = 0
501 DO j = 0, k
502 DO i = k, n - 1
503 a( j, i ) = dconjg( arf( ij ) )
504 ij = ij + 1
505 END DO
506 END DO
507 DO j = 0, k - 2
508 DO i = 0, j
509 a( i, j ) = arf( ij )
510 ij = ij + 1
511 END DO
512 DO l = k + 1 + j, n - 1
513 a( k+1+j, l ) = dconjg( arf( ij ) )
514 ij = ij + 1
515 END DO
516 END DO
517*
518* Note that here J = K-1
519*
520 DO i = 0, j
521 a( i, j ) = arf( ij )
522 ij = ij + 1
523 END DO
524*
525 END IF
526*
527 END IF
528*
529 END IF
530*
531 RETURN
532*
533* End of ZTFTTR
534*

◆ ztgsen()

subroutine ztgsen ( integer ijob,
logical wantq,
logical wantz,
logical, dimension( * ) select,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( * ) alpha,
complex*16, dimension( * ) beta,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldz, * ) z,
integer ldz,
integer m,
double precision pl,
double precision pr,
double precision, dimension( * ) dif,
complex*16, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer liwork,
integer info )

ZTGSEN

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

Purpose:
!>
!> ZTGSEN reorders the generalized Schur decomposition of a complex
!> matrix pair (A, B) (in terms of an unitary equivalence trans-
!> formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues
!> appears in the leading diagonal blocks of the pair (A,B). The leading
!> columns of Q and Z form unitary bases of the corresponding left and
!> right eigenspaces (deflating subspaces). (A, B) must be in
!> generalized Schur canonical form, that is, A and B are both upper
!> triangular.
!>
!> ZTGSEN also computes the generalized eigenvalues
!>
!>          w(j)= ALPHA(j) / BETA(j)
!>
!> of the reordered matrix pair (A, B).
!>
!> Optionally, the routine computes estimates of reciprocal condition
!> numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
!> (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
!> between the matrix pairs (A11, B11) and (A22,B22) that correspond to
!> the selected cluster and the eigenvalues outside the cluster, resp.,
!> and norms of  onto left and right eigenspaces w.r.t.
!> the selected cluster in the (1,1)-block.
!>
!>
Parameters
[in]IJOB
!>          IJOB is INTEGER
!>          Specifies whether condition numbers are required for the
!>          cluster of eigenvalues (PL and PR) or the deflating subspaces
!>          (Difu and Difl):
!>           =0: Only reorder w.r.t. SELECT. No extras.
!>           =1: Reciprocal of norms of  onto left and right
!>               eigenspaces w.r.t. the selected cluster (PL and PR).
!>           =2: Upper bounds on Difu and Difl. F-norm-based estimate
!>               (DIF(1:2)).
!>           =3: Estimate of Difu and Difl. 1-norm-based estimate
!>               (DIF(1:2)).
!>               About 5 times as expensive as IJOB = 2.
!>           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
!>               version to get it all.
!>           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
!>
[in]WANTQ
!>          WANTQ is LOGICAL
!>          .TRUE. : update the left transformation matrix Q;
!>          .FALSE.: do not update Q.
!>
[in]WANTZ
!>          WANTZ is LOGICAL
!>          .TRUE. : update the right transformation matrix Z;
!>          .FALSE.: do not update Z.
!>
[in]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          SELECT specifies the eigenvalues in the selected cluster. To
!>          select an eigenvalue w(j), SELECT(j) must be set to
!>          .TRUE..
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A and B. N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension(LDA,N)
!>          On entry, the upper triangular matrix A, in generalized
!>          Schur canonical form.
!>          On exit, A is overwritten by the reordered matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension(LDB,N)
!>          On entry, the upper triangular matrix B, in generalized
!>          Schur canonical form.
!>          On exit, B is overwritten by the reordered matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!>
[out]ALPHA
!>          ALPHA is COMPLEX*16 array, dimension (N)
!>
[out]BETA
!>          BETA is COMPLEX*16 array, dimension (N)
!>
!>          The diagonal elements of A and B, respectively,
!>          when the pair (A,B) has been reduced to generalized Schur
!>          form.  ALPHA(i)/BETA(i) i=1,...,N are the generalized
!>          eigenvalues.
!>
[in,out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
!>          On exit, Q has been postmultiplied by the left unitary
!>          transformation matrix which reorder (A, B); The leading M
!>          columns of Q form orthonormal bases for the specified pair of
!>          left eigenspaces (deflating subspaces).
!>          If WANTQ = .FALSE., Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= 1.
!>          If WANTQ = .TRUE., LDQ >= N.
!>
[in,out]Z
!>          Z is COMPLEX*16 array, dimension (LDZ,N)
!>          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
!>          On exit, Z has been postmultiplied by the left unitary
!>          transformation matrix which reorder (A, B); The leading M
!>          columns of Z form orthonormal bases for the specified pair of
!>          left eigenspaces (deflating subspaces).
!>          If WANTZ = .FALSE., Z is not referenced.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z. LDZ >= 1.
!>          If WANTZ = .TRUE., LDZ >= N.
!>
[out]M
!>          M is INTEGER
!>          The dimension of the specified pair of left and right
!>          eigenspaces, (deflating subspaces) 0 <= M <= N.
!>
[out]PL
!>          PL is DOUBLE PRECISION
!>
[out]PR
!>          PR is DOUBLE PRECISION
!>
!>          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
!>          reciprocal  of the norm of  onto left and right
!>          eigenspace with respect to the selected cluster.
!>          0 < PL, PR <= 1.
!>          If M = 0 or M = N, PL = PR  = 1.
!>          If IJOB = 0, 2 or 3 PL, PR are not referenced.
!>
[out]DIF
!>          DIF is DOUBLE PRECISION array, dimension (2).
!>          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
!>          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
!>          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
!>          estimates of Difu and Difl, computed using reversed
!>          communication with ZLACN2.
!>          If M = 0 or N, DIF(1:2) = F-norm([A, B]).
!>          If IJOB = 0 or 1, DIF is not referenced.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >=  1
!>          If IJOB = 1, 2 or 4, LWORK >=  2*M*(N-M)
!>          If IJOB = 3 or 5, LWORK >=  4*M*(N-M)
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
!>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!>
[in]LIWORK
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK. LIWORK >= 1.
!>          If IJOB = 1, 2 or 4, LIWORK >=  N+2;
!>          If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
!>
!>          If LIWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the IWORK array,
!>          returns this value as the first entry of the IWORK array, and
!>          no error message related to LIWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>            =0: Successful exit.
!>            <0: If INFO = -i, the i-th argument had an illegal value.
!>            =1: Reordering of (A, B) failed because the transformed
!>                matrix pair (A, B) would be too far from generalized
!>                Schur form; the problem is very ill-conditioned.
!>                (A, B) may have been partially reordered.
!>                If requested, 0 is returned in DIF(*), PL and PR.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  ZTGSEN first collects the selected eigenvalues by computing unitary
!>  U and W that move them to the top left corner of (A, B). In other
!>  words, the selected eigenvalues are the eigenvalues of (A11, B11) in
!>
!>              U**H*(A, B)*W = (A11 A12) (B11 B12) n1
!>                              ( 0  A22),( 0  B22) n2
!>                                n1  n2    n1  n2
!>
!>  where N = n1+n2 and U**H means the conjugate transpose of U. The first
!>  n1 columns of U and W span the specified pair of left and right
!>  eigenspaces (deflating subspaces) of (A, B).
!>
!>  If (A, B) has been obtained from the generalized real Schur
!>  decomposition of a matrix pair (C, D) = Q*(A, B)*Z**H, then the
!>  reordered generalized Schur form of (C, D) is given by
!>
!>           (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H,
!>
!>  and the first n1 columns of Q*U and Z*W span the corresponding
!>  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
!>
!>  Note that if the selected eigenvalue is sufficiently ill-conditioned,
!>  then its value may differ significantly from its value before
!>  reordering.
!>
!>  The reciprocal condition numbers of the left and right eigenspaces
!>  spanned by the first n1 columns of U and W (or Q*U and Z*W) may
!>  be returned in DIF(1:2), corresponding to Difu and Difl, resp.
!>
!>  The Difu and Difl are defined as:
!>
!>       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
!>  and
!>       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
!>
!>  where sigma-min(Zu) is the smallest singular value of the
!>  (2*n1*n2)-by-(2*n1*n2) matrix
!>
!>       Zu = [ kron(In2, A11)  -kron(A22**H, In1) ]
!>            [ kron(In2, B11)  -kron(B22**H, In1) ].
!>
!>  Here, Inx is the identity matrix of size nx and A22**H is the
!>  conjugate transpose of A22. kron(X, Y) is the Kronecker product between
!>  the matrices X and Y.
!>
!>  When DIF(2) is small, small changes in (A, B) can cause large changes
!>  in the deflating subspace. An approximate (asymptotic) bound on the
!>  maximum angular error in the computed deflating subspaces is
!>
!>       EPS * norm((A, B)) / DIF(2),
!>
!>  where EPS is the machine precision.
!>
!>  The reciprocal norm of the projectors on the left and right
!>  eigenspaces associated with (A11, B11) may be returned in PL and PR.
!>  They are computed as follows. First we compute L and R so that
!>  P*(A, B)*Q is block diagonal, where
!>
!>       P = ( I -L ) n1           Q = ( I R ) n1
!>           ( 0  I ) n2    and        ( 0 I ) n2
!>             n1 n2                    n1 n2
!>
!>  and (L, R) is the solution to the generalized Sylvester equation
!>
!>       A11*R - L*A22 = -A12
!>       B11*R - L*B22 = -B12
!>
!>  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
!>  An approximate (asymptotic) bound on the average absolute error of
!>  the selected eigenvalues is
!>
!>       EPS * norm((A, B)) / PL.
!>
!>  There are also global error bounds which valid for perturbations up
!>  to a certain restriction:  A lower bound (x) on the smallest
!>  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
!>  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
!>  (i.e. (A + E, B + F), is
!>
!>   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
!>
!>  An approximate bound on x can be computed from DIF(1:2), PL and PR.
!>
!>  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
!>  (L', R') and unperturbed (L, R) left and right deflating subspaces
!>  associated with the selected cluster in the (1,1)-blocks can be
!>  bounded as
!>
!>   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
!>   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
!>
!>  See LAPACK User's Guide section 4.11 or the following references
!>  for more information.
!>
!>  Note that if the default method for computing the Frobenius-norm-
!>  based estimate DIF is not wanted (see ZLATDF), then the parameter
!>  IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF
!>  (IJOB = 2 will be used)). See ZTGSYL for more details.
!>
Contributors:
Bo Kagstrom and Peter Poromaa, Department of Computing Science, Umea University, S-901 87 Umea, Sweden.
References:
[1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the Generalized Real Schur Form of a Regular Matrix Pair (A, B), in M.S. Moonen et al (eds), Linear Algebra for Large Scale and Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
[2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified Eigenvalues of a Regular Matrix Pair (A, B) and Condition Estimation: Theory, Algorithms and Software, Report UMINF - 94.04, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. To appear in Numerical Algorithms, 1996.
[3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software for Solving the Generalized Sylvester Equation and Estimating the Separation between Regular Matrix Pairs, Report UMINF - 93.23, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, December 1993, Revised April 1994, Also as LAPACK working Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.

Definition at line 430 of file ztgsen.f.

433*
434* -- LAPACK computational routine --
435* -- LAPACK is a software package provided by Univ. of Tennessee, --
436* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
437*
438* .. Scalar Arguments ..
439 LOGICAL WANTQ, WANTZ
440 INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
441 $ M, N
442 DOUBLE PRECISION PL, PR
443* ..
444* .. Array Arguments ..
445 LOGICAL SELECT( * )
446 INTEGER IWORK( * )
447 DOUBLE PRECISION DIF( * )
448 COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
449 $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * )
450* ..
451*
452* =====================================================================
453*
454* .. Parameters ..
455 INTEGER IDIFJB
456 parameter( idifjb = 3 )
457 DOUBLE PRECISION ZERO, ONE
458 parameter( zero = 0.0d+0, one = 1.0d+0 )
459* ..
460* .. Local Scalars ..
461 LOGICAL LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP
462 INTEGER I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2,
463 $ N1, N2
464 DOUBLE PRECISION DSCALE, DSUM, RDSCAL, SAFMIN
465 COMPLEX*16 TEMP1, TEMP2
466* ..
467* .. Local Arrays ..
468 INTEGER ISAVE( 3 )
469* ..
470* .. External Subroutines ..
471 EXTERNAL xerbla, zlacn2, zlacpy, zlassq, zscal, ztgexc,
472 $ ztgsyl
473* ..
474* .. Intrinsic Functions ..
475 INTRINSIC abs, dcmplx, dconjg, max, sqrt
476* ..
477* .. External Functions ..
478 DOUBLE PRECISION DLAMCH
479 EXTERNAL dlamch
480* ..
481* .. Executable Statements ..
482*
483* Decode and test the input parameters
484*
485 info = 0
486 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 )
487*
488 IF( ijob.LT.0 .OR. ijob.GT.5 ) THEN
489 info = -1
490 ELSE IF( n.LT.0 ) THEN
491 info = -5
492 ELSE IF( lda.LT.max( 1, n ) ) THEN
493 info = -7
494 ELSE IF( ldb.LT.max( 1, n ) ) THEN
495 info = -9
496 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) ) THEN
497 info = -13
498 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) ) THEN
499 info = -15
500 END IF
501*
502 IF( info.NE.0 ) THEN
503 CALL xerbla( 'ZTGSEN', -info )
504 RETURN
505 END IF
506*
507 ierr = 0
508*
509 wantp = ijob.EQ.1 .OR. ijob.GE.4
510 wantd1 = ijob.EQ.2 .OR. ijob.EQ.4
511 wantd2 = ijob.EQ.3 .OR. ijob.EQ.5
512 wantd = wantd1 .OR. wantd2
513*
514* Set M to the dimension of the specified pair of deflating
515* subspaces.
516*
517 m = 0
518 IF( .NOT.lquery .OR. ijob.NE.0 ) THEN
519 DO 10 k = 1, n
520 alpha( k ) = a( k, k )
521 beta( k ) = b( k, k )
522 IF( k.LT.n ) THEN
523 IF( SELECT( k ) )
524 $ m = m + 1
525 ELSE
526 IF( SELECT( n ) )
527 $ m = m + 1
528 END IF
529 10 CONTINUE
530 END IF
531*
532 IF( ijob.EQ.1 .OR. ijob.EQ.2 .OR. ijob.EQ.4 ) THEN
533 lwmin = max( 1, 2*m*( n-m ) )
534 liwmin = max( 1, n+2 )
535 ELSE IF( ijob.EQ.3 .OR. ijob.EQ.5 ) THEN
536 lwmin = max( 1, 4*m*( n-m ) )
537 liwmin = max( 1, 2*m*( n-m ), n+2 )
538 ELSE
539 lwmin = 1
540 liwmin = 1
541 END IF
542*
543 work( 1 ) = lwmin
544 iwork( 1 ) = liwmin
545*
546 IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
547 info = -21
548 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery ) THEN
549 info = -23
550 END IF
551*
552 IF( info.NE.0 ) THEN
553 CALL xerbla( 'ZTGSEN', -info )
554 RETURN
555 ELSE IF( lquery ) THEN
556 RETURN
557 END IF
558*
559* Quick return if possible.
560*
561 IF( m.EQ.n .OR. m.EQ.0 ) THEN
562 IF( wantp ) THEN
563 pl = one
564 pr = one
565 END IF
566 IF( wantd ) THEN
567 dscale = zero
568 dsum = one
569 DO 20 i = 1, n
570 CALL zlassq( n, a( 1, i ), 1, dscale, dsum )
571 CALL zlassq( n, b( 1, i ), 1, dscale, dsum )
572 20 CONTINUE
573 dif( 1 ) = dscale*sqrt( dsum )
574 dif( 2 ) = dif( 1 )
575 END IF
576 GO TO 70
577 END IF
578*
579* Get machine constant
580*
581 safmin = dlamch( 'S' )
582*
583* Collect the selected blocks at the top-left corner of (A, B).
584*
585 ks = 0
586 DO 30 k = 1, n
587 swap = SELECT( k )
588 IF( swap ) THEN
589 ks = ks + 1
590*
591* Swap the K-th block to position KS. Compute unitary Q
592* and Z that will swap adjacent diagonal blocks in (A, B).
593*
594 IF( k.NE.ks )
595 $ CALL ztgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
596 $ ldz, k, ks, ierr )
597*
598 IF( ierr.GT.0 ) THEN
599*
600* Swap is rejected: exit.
601*
602 info = 1
603 IF( wantp ) THEN
604 pl = zero
605 pr = zero
606 END IF
607 IF( wantd ) THEN
608 dif( 1 ) = zero
609 dif( 2 ) = zero
610 END IF
611 GO TO 70
612 END IF
613 END IF
614 30 CONTINUE
615 IF( wantp ) THEN
616*
617* Solve generalized Sylvester equation for R and L:
618* A11 * R - L * A22 = A12
619* B11 * R - L * B22 = B12
620*
621 n1 = m
622 n2 = n - m
623 i = n1 + 1
624 CALL zlacpy( 'Full', n1, n2, a( 1, i ), lda, work, n1 )
625 CALL zlacpy( 'Full', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),
626 $ n1 )
627 ijb = 0
628 CALL ztgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,
629 $ n1, b, ldb, b( i, i ), ldb, work( n1*n2+1 ), n1,
630 $ dscale, dif( 1 ), work( n1*n2*2+1 ),
631 $ lwork-2*n1*n2, iwork, ierr )
632*
633* Estimate the reciprocal of norms of "projections" onto
634* left and right eigenspaces
635*
636 rdscal = zero
637 dsum = one
638 CALL zlassq( n1*n2, work, 1, rdscal, dsum )
639 pl = rdscal*sqrt( dsum )
640 IF( pl.EQ.zero ) THEN
641 pl = one
642 ELSE
643 pl = dscale / ( sqrt( dscale*dscale / pl+pl )*sqrt( pl ) )
644 END IF
645 rdscal = zero
646 dsum = one
647 CALL zlassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum )
648 pr = rdscal*sqrt( dsum )
649 IF( pr.EQ.zero ) THEN
650 pr = one
651 ELSE
652 pr = dscale / ( sqrt( dscale*dscale / pr+pr )*sqrt( pr ) )
653 END IF
654 END IF
655 IF( wantd ) THEN
656*
657* Compute estimates Difu and Difl.
658*
659 IF( wantd1 ) THEN
660 n1 = m
661 n2 = n - m
662 i = n1 + 1
663 ijb = idifjb
664*
665* Frobenius norm-based Difu estimate.
666*
667 CALL ztgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,
668 $ n1, b, ldb, b( i, i ), ldb, work( n1*n2+1 ),
669 $ n1, dscale, dif( 1 ), work( n1*n2*2+1 ),
670 $ lwork-2*n1*n2, iwork, ierr )
671*
672* Frobenius norm-based Difl estimate.
673*
674 CALL ztgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,
675 $ n2, b( i, i ), ldb, b, ldb, work( n1*n2+1 ),
676 $ n2, dscale, dif( 2 ), work( n1*n2*2+1 ),
677 $ lwork-2*n1*n2, iwork, ierr )
678 ELSE
679*
680* Compute 1-norm-based estimates of Difu and Difl using
681* reversed communication with ZLACN2. In each step a
682* generalized Sylvester equation or a transposed variant
683* is solved.
684*
685 kase = 0
686 n1 = m
687 n2 = n - m
688 i = n1 + 1
689 ijb = 0
690 mn2 = 2*n1*n2
691*
692* 1-norm-based estimate of Difu.
693*
694 40 CONTINUE
695 CALL zlacn2( mn2, work( mn2+1 ), work, dif( 1 ), kase,
696 $ isave )
697 IF( kase.NE.0 ) THEN
698 IF( kase.EQ.1 ) THEN
699*
700* Solve generalized Sylvester equation
701*
702 CALL ztgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,
703 $ work, n1, b, ldb, b( i, i ), ldb,
704 $ work( n1*n2+1 ), n1, dscale, dif( 1 ),
705 $ work( n1*n2*2+1 ), lwork-2*n1*n2, iwork,
706 $ ierr )
707 ELSE
708*
709* Solve the transposed variant.
710*
711 CALL ztgsyl( 'C', ijb, n1, n2, a, lda, a( i, i ), lda,
712 $ work, n1, b, ldb, b( i, i ), ldb,
713 $ work( n1*n2+1 ), n1, dscale, dif( 1 ),
714 $ work( n1*n2*2+1 ), lwork-2*n1*n2, iwork,
715 $ ierr )
716 END IF
717 GO TO 40
718 END IF
719 dif( 1 ) = dscale / dif( 1 )
720*
721* 1-norm-based estimate of Difl.
722*
723 50 CONTINUE
724 CALL zlacn2( mn2, work( mn2+1 ), work, dif( 2 ), kase,
725 $ isave )
726 IF( kase.NE.0 ) THEN
727 IF( kase.EQ.1 ) THEN
728*
729* Solve generalized Sylvester equation
730*
731 CALL ztgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,
732 $ work, n2, b( i, i ), ldb, b, ldb,
733 $ work( n1*n2+1 ), n2, dscale, dif( 2 ),
734 $ work( n1*n2*2+1 ), lwork-2*n1*n2, iwork,
735 $ ierr )
736 ELSE
737*
738* Solve the transposed variant.
739*
740 CALL ztgsyl( 'C', ijb, n2, n1, a( i, i ), lda, a, lda,
741 $ work, n2, b, ldb, b( i, i ), ldb,
742 $ work( n1*n2+1 ), n2, dscale, dif( 2 ),
743 $ work( n1*n2*2+1 ), lwork-2*n1*n2, iwork,
744 $ ierr )
745 END IF
746 GO TO 50
747 END IF
748 dif( 2 ) = dscale / dif( 2 )
749 END IF
750 END IF
751*
752* If B(K,K) is complex, make it real and positive (normalization
753* of the generalized Schur form) and Store the generalized
754* eigenvalues of reordered pair (A, B)
755*
756 DO 60 k = 1, n
757 dscale = abs( b( k, k ) )
758 IF( dscale.GT.safmin ) THEN
759 temp1 = dconjg( b( k, k ) / dscale )
760 temp2 = b( k, k ) / dscale
761 b( k, k ) = dscale
762 CALL zscal( n-k, temp1, b( k, k+1 ), ldb )
763 CALL zscal( n-k+1, temp1, a( k, k ), lda )
764 IF( wantq )
765 $ CALL zscal( n, temp2, q( 1, k ), 1 )
766 ELSE
767 b( k, k ) = dcmplx( zero, zero )
768 END IF
769*
770 alpha( k ) = a( k, k )
771 beta( k ) = b( k, k )
772*
773 60 CONTINUE
774*
775 70 CONTINUE
776*
777 work( 1 ) = lwmin
778 iwork( 1 ) = liwmin
779*
780 RETURN
781*
782* End of ZTGSEN
783*
ztgexc
subroutine ztgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, info)
ZTGEXC
Definition ztgexc.f:200
ztgsyl
subroutine ztgsyl(trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, dif, work, lwork, iwork, info)
ZTGSYL
Definition ztgsyl.f:295
swap
#define swap(a, b, tmp)
Definition macros.h:40

◆ ztgsja()

subroutine ztgsja ( character jobu,
character jobv,
character jobq,
integer m,
integer p,
integer n,
integer k,
integer l,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision tola,
double precision tolb,
double precision, dimension( * ) alpha,
double precision, dimension( * ) beta,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldv, * ) v,
integer ldv,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( * ) work,
integer ncycle,
integer info )

ZTGSJA

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

Purpose:
!>
!> ZTGSJA computes the generalized singular value decomposition (GSVD)
!> of two complex upper triangular (or trapezoidal) matrices A and B.
!>
!> On entry, it is assumed that matrices A and B have the following
!> forms, which may be obtained by the preprocessing subroutine ZGGSVP
!> from a general M-by-N matrix A and P-by-N matrix B:
!>
!>              N-K-L  K    L
!>    A =    K ( 0    A12  A13 ) if M-K-L >= 0;
!>           L ( 0     0   A23 )
!>       M-K-L ( 0     0    0  )
!>
!>            N-K-L  K    L
!>    A =  K ( 0    A12  A13 ) if M-K-L < 0;
!>       M-K ( 0     0   A23 )
!>
!>            N-K-L  K    L
!>    B =  L ( 0     0   B13 )
!>       P-L ( 0     0    0  )
!>
!> where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
!> upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
!> otherwise A23 is (M-K)-by-L upper trapezoidal.
!>
!> On exit,
!>
!>        U**H *A*Q = D1*( 0 R ),    V**H *B*Q = D2*( 0 R ),
!>
!> where U, V and Q are unitary matrices.
!> R is a nonsingular upper triangular matrix, and D1
!> and D2 are ``diagonal'' matrices, which are of the following
!> structures:
!>
!> If M-K-L >= 0,
!>
!>                     K  L
!>        D1 =     K ( I  0 )
!>                 L ( 0  C )
!>             M-K-L ( 0  0 )
!>
!>                    K  L
!>        D2 = L   ( 0  S )
!>             P-L ( 0  0 )
!>
!>                N-K-L  K    L
!>   ( 0 R ) = K (  0   R11  R12 ) K
!>             L (  0    0   R22 ) L
!>
!> where
!>
!>   C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
!>   S = diag( BETA(K+1),  ... , BETA(K+L) ),
!>   C**2 + S**2 = I.
!>
!>   R is stored in A(1:K+L,N-K-L+1:N) on exit.
!>
!> If M-K-L < 0,
!>
!>                K M-K K+L-M
!>     D1 =   K ( I  0    0   )
!>          M-K ( 0  C    0   )
!>
!>                  K M-K K+L-M
!>     D2 =   M-K ( 0  S    0   )
!>          K+L-M ( 0  0    I   )
!>            P-L ( 0  0    0   )
!>
!>                N-K-L  K   M-K  K+L-M
!> ( 0 R ) =    K ( 0    R11  R12  R13  )
!>           M-K ( 0     0   R22  R23  )
!>         K+L-M ( 0     0    0   R33  )
!>
!> where
!> C = diag( ALPHA(K+1), ... , ALPHA(M) ),
!> S = diag( BETA(K+1),  ... , BETA(M) ),
!> C**2 + S**2 = I.
!>
!> R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
!>     (  0  R22 R23 )
!> in B(M-K+1:L,N+M-K-L+1:N) on exit.
!>
!> The computation of the unitary transformation matrices U, V or Q
!> is optional.  These matrices may either be formed explicitly, or they
!> may be postmultiplied into input matrices U1, V1, or Q1.
!>
Parameters
[in]JOBU
!>          JOBU is CHARACTER*1
!>          = 'U':  U must contain a unitary matrix U1 on entry, and
!>                  the product U1*U is returned;
!>          = 'I':  U is initialized to the unit matrix, and the
!>                  unitary matrix U is returned;
!>          = 'N':  U is not computed.
!>
[in]JOBV
!>          JOBV is CHARACTER*1
!>          = 'V':  V must contain a unitary matrix V1 on entry, and
!>                  the product V1*V is returned;
!>          = 'I':  V is initialized to the unit matrix, and the
!>                  unitary matrix V is returned;
!>          = 'N':  V is not computed.
!>
[in]JOBQ
!>          JOBQ is CHARACTER*1
!>          = 'Q':  Q must contain a unitary matrix Q1 on entry, and
!>                  the product Q1*Q is returned;
!>          = 'I':  Q is initialized to the unit matrix, and the
!>                  unitary matrix Q is returned;
!>          = 'N':  Q is not computed.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of rows of the matrix B.  P >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and B.  N >= 0.
!>
[in]K
!>          K is INTEGER
!>
[in]L
!>          L is INTEGER
!>
!>          K and L specify the subblocks in the input matrices A and B:
!>          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)
!>          of A and B, whose GSVD is going to be computed by ZTGSJA.
!>          See Further Details.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
!>          matrix R or part of R.  See Purpose for details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          On entry, the P-by-N matrix B.
!>          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
!>          a part of R.  See Purpose for details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,P).
!>
[in]TOLA
!>          TOLA is DOUBLE PRECISION
!>
[in]TOLB
!>          TOLB is DOUBLE PRECISION
!>
!>          TOLA and TOLB are the convergence criteria for the Jacobi-
!>          Kogbetliantz iteration procedure. Generally, they are the
!>          same as used in the preprocessing step, say
!>              TOLA = MAX(M,N)*norm(A)*MAZHEPS,
!>              TOLB = MAX(P,N)*norm(B)*MAZHEPS.
!>
[out]ALPHA
!>          ALPHA is DOUBLE PRECISION array, dimension (N)
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>
!>          On exit, ALPHA and BETA contain the generalized singular
!>          value pairs of A and B;
!>            ALPHA(1:K) = 1,
!>            BETA(1:K)  = 0,
!>          and if M-K-L >= 0,
!>            ALPHA(K+1:K+L) = diag(C),
!>            BETA(K+1:K+L)  = diag(S),
!>          or if M-K-L < 0,
!>            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
!>            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
!>          Furthermore, if K+L < N,
!>            ALPHA(K+L+1:N) = 0 and
!>            BETA(K+L+1:N)  = 0.
!>
[in,out]U
!>          U is COMPLEX*16 array, dimension (LDU,M)
!>          On entry, if JOBU = 'U', U must contain a matrix U1 (usually
!>          the unitary matrix returned by ZGGSVP).
!>          On exit,
!>          if JOBU = 'I', U contains the unitary matrix U;
!>          if JOBU = 'U', U contains the product U1*U.
!>          If JOBU = 'N', U is not referenced.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U. LDU >= max(1,M) if
!>          JOBU = 'U'; LDU >= 1 otherwise.
!>
[in,out]V
!>          V is COMPLEX*16 array, dimension (LDV,P)
!>          On entry, if JOBV = 'V', V must contain a matrix V1 (usually
!>          the unitary matrix returned by ZGGSVP).
!>          On exit,
!>          if JOBV = 'I', V contains the unitary matrix V;
!>          if JOBV = 'V', V contains the product V1*V.
!>          If JOBV = 'N', V is not referenced.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= max(1,P) if
!>          JOBV = 'V'; LDV >= 1 otherwise.
!>
[in,out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
!>          the unitary matrix returned by ZGGSVP).
!>          On exit,
!>          if JOBQ = 'I', Q contains the unitary matrix Q;
!>          if JOBQ = 'Q', Q contains the product Q1*Q.
!>          If JOBQ = 'N', Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= max(1,N) if
!>          JOBQ = 'Q'; LDQ >= 1 otherwise.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]NCYCLE
!>          NCYCLE is INTEGER
!>          The number of cycles required for convergence.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          = 1:  the procedure does not converge after MAXIT cycles.
!>
Internal Parameters:
!>  MAXIT   INTEGER
!>          MAXIT specifies the total loops that the iterative procedure
!>          may take. If after MAXIT cycles, the routine fails to
!>          converge, we return INFO = 1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  ZTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
!>  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
!>  matrix B13 to the form:
!>
!>           U1**H *A13*Q1 = C1*R1; V1**H *B13*Q1 = S1*R1,
!>
!>  where U1, V1 and Q1 are unitary matrix.
!>  C1 and S1 are diagonal matrices satisfying
!>
!>                C1**2 + S1**2 = I,
!>
!>  and R1 is an L-by-L nonsingular upper triangular matrix.
!>

Definition at line 376 of file ztgsja.f.

379*
380* -- LAPACK computational routine --
381* -- LAPACK is a software package provided by Univ. of Tennessee, --
382* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
383*
384* .. Scalar Arguments ..
385 CHARACTER JOBQ, JOBU, JOBV
386 INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N,
387 $ NCYCLE, P
388 DOUBLE PRECISION TOLA, TOLB
389* ..
390* .. Array Arguments ..
391 DOUBLE PRECISION ALPHA( * ), BETA( * )
392 COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
393 $ U( LDU, * ), V( LDV, * ), WORK( * )
394* ..
395*
396* =====================================================================
397*
398* .. Parameters ..
399 INTEGER MAXIT
400 parameter( maxit = 40 )
401 DOUBLE PRECISION ZERO, ONE, HUGENUM
402 parameter( zero = 0.0d+0, one = 1.0d+0 )
403 COMPLEX*16 CZERO, CONE
404 parameter( czero = ( 0.0d+0, 0.0d+0 ),
405 $ cone = ( 1.0d+0, 0.0d+0 ) )
406* ..
407* .. Local Scalars ..
408*
409 LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
410 INTEGER I, J, KCYCLE
411 DOUBLE PRECISION A1, A3, B1, B3, CSQ, CSU, CSV, ERROR, GAMMA,
412 $ RWK, SSMIN
413 COMPLEX*16 A2, B2, SNQ, SNU, SNV
414* ..
415* .. External Functions ..
416 LOGICAL LSAME
417 EXTERNAL lsame
418* ..
419* .. External Subroutines ..
420 EXTERNAL dlartg, xerbla, zcopy, zdscal, zlags2, zlapll,
421 $ zlaset, zrot
422* ..
423* .. Intrinsic Functions ..
424 INTRINSIC abs, dble, dconjg, max, min, huge
425 parameter( hugenum = huge(zero) )
426* ..
427* .. Executable Statements ..
428*
429* Decode and test the input parameters
430*
431 initu = lsame( jobu, 'I' )
432 wantu = initu .OR. lsame( jobu, 'U' )
433*
434 initv = lsame( jobv, 'I' )
435 wantv = initv .OR. lsame( jobv, 'V' )
436*
437 initq = lsame( jobq, 'I' )
438 wantq = initq .OR. lsame( jobq, 'Q' )
439*
440 info = 0
441 IF( .NOT.( initu .OR. wantu .OR. lsame( jobu, 'N' ) ) ) THEN
442 info = -1
443 ELSE IF( .NOT.( initv .OR. wantv .OR. lsame( jobv, 'N' ) ) ) THEN
444 info = -2
445 ELSE IF( .NOT.( initq .OR. wantq .OR. lsame( jobq, 'N' ) ) ) THEN
446 info = -3
447 ELSE IF( m.LT.0 ) THEN
448 info = -4
449 ELSE IF( p.LT.0 ) THEN
450 info = -5
451 ELSE IF( n.LT.0 ) THEN
452 info = -6
453 ELSE IF( lda.LT.max( 1, m ) ) THEN
454 info = -10
455 ELSE IF( ldb.LT.max( 1, p ) ) THEN
456 info = -12
457 ELSE IF( ldu.LT.1 .OR. ( wantu .AND. ldu.LT.m ) ) THEN
458 info = -18
459 ELSE IF( ldv.LT.1 .OR. ( wantv .AND. ldv.LT.p ) ) THEN
460 info = -20
461 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) ) THEN
462 info = -22
463 END IF
464 IF( info.NE.0 ) THEN
465 CALL xerbla( 'ZTGSJA', -info )
466 RETURN
467 END IF
468*
469* Initialize U, V and Q, if necessary
470*
471 IF( initu )
472 $ CALL zlaset( 'Full', m, m, czero, cone, u, ldu )
473 IF( initv )
474 $ CALL zlaset( 'Full', p, p, czero, cone, v, ldv )
475 IF( initq )
476 $ CALL zlaset( 'Full', n, n, czero, cone, q, ldq )
477*
478* Loop until convergence
479*
480 upper = .false.
481 DO 40 kcycle = 1, maxit
482*
483 upper = .NOT.upper
484*
485 DO 20 i = 1, l - 1
486 DO 10 j = i + 1, l
487*
488 a1 = zero
489 a2 = czero
490 a3 = zero
491 IF( k+i.LE.m )
492 $ a1 = dble( a( k+i, n-l+i ) )
493 IF( k+j.LE.m )
494 $ a3 = dble( a( k+j, n-l+j ) )
495*
496 b1 = dble( b( i, n-l+i ) )
497 b3 = dble( b( j, n-l+j ) )
498*
499 IF( upper ) THEN
500 IF( k+i.LE.m )
501 $ a2 = a( k+i, n-l+j )
502 b2 = b( i, n-l+j )
503 ELSE
504 IF( k+j.LE.m )
505 $ a2 = a( k+j, n-l+i )
506 b2 = b( j, n-l+i )
507 END IF
508*
509 CALL zlags2( upper, a1, a2, a3, b1, b2, b3, csu, snu,
510 $ csv, snv, csq, snq )
511*
512* Update (K+I)-th and (K+J)-th rows of matrix A: U**H *A
513*
514 IF( k+j.LE.m )
515 $ CALL zrot( l, a( k+j, n-l+1 ), lda, a( k+i, n-l+1 ),
516 $ lda, csu, dconjg( snu ) )
517*
518* Update I-th and J-th rows of matrix B: V**H *B
519*
520 CALL zrot( l, b( j, n-l+1 ), ldb, b( i, n-l+1 ), ldb,
521 $ csv, dconjg( snv ) )
522*
523* Update (N-L+I)-th and (N-L+J)-th columns of matrices
524* A and B: A*Q and B*Q
525*
526 CALL zrot( min( k+l, m ), a( 1, n-l+j ), 1,
527 $ a( 1, n-l+i ), 1, csq, snq )
528*
529 CALL zrot( l, b( 1, n-l+j ), 1, b( 1, n-l+i ), 1, csq,
530 $ snq )
531*
532 IF( upper ) THEN
533 IF( k+i.LE.m )
534 $ a( k+i, n-l+j ) = czero
535 b( i, n-l+j ) = czero
536 ELSE
537 IF( k+j.LE.m )
538 $ a( k+j, n-l+i ) = czero
539 b( j, n-l+i ) = czero
540 END IF
541*
542* Ensure that the diagonal elements of A and B are real.
543*
544 IF( k+i.LE.m )
545 $ a( k+i, n-l+i ) = dble( a( k+i, n-l+i ) )
546 IF( k+j.LE.m )
547 $ a( k+j, n-l+j ) = dble( a( k+j, n-l+j ) )
548 b( i, n-l+i ) = dble( b( i, n-l+i ) )
549 b( j, n-l+j ) = dble( b( j, n-l+j ) )
550*
551* Update unitary matrices U, V, Q, if desired.
552*
553 IF( wantu .AND. k+j.LE.m )
554 $ CALL zrot( m, u( 1, k+j ), 1, u( 1, k+i ), 1, csu,
555 $ snu )
556*
557 IF( wantv )
558 $ CALL zrot( p, v( 1, j ), 1, v( 1, i ), 1, csv, snv )
559*
560 IF( wantq )
561 $ CALL zrot( n, q( 1, n-l+j ), 1, q( 1, n-l+i ), 1, csq,
562 $ snq )
563*
564 10 CONTINUE
565 20 CONTINUE
566*
567 IF( .NOT.upper ) THEN
568*
569* The matrices A13 and B13 were lower triangular at the start
570* of the cycle, and are now upper triangular.
571*
572* Convergence test: test the parallelism of the corresponding
573* rows of A and B.
574*
575 error = zero
576 DO 30 i = 1, min( l, m-k )
577 CALL zcopy( l-i+1, a( k+i, n-l+i ), lda, work, 1 )
578 CALL zcopy( l-i+1, b( i, n-l+i ), ldb, work( l+1 ), 1 )
579 CALL zlapll( l-i+1, work, 1, work( l+1 ), 1, ssmin )
580 error = max( error, ssmin )
581 30 CONTINUE
582*
583 IF( abs( error ).LE.min( tola, tolb ) )
584 $ GO TO 50
585 END IF
586*
587* End of cycle loop
588*
589 40 CONTINUE
590*
591* The algorithm has not converged after MAXIT cycles.
592*
593 info = 1
594 GO TO 100
595*
596 50 CONTINUE
597*
598* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged.
599* Compute the generalized singular value pairs (ALPHA, BETA), and
600* set the triangular matrix R to array A.
601*
602 DO 60 i = 1, k
603 alpha( i ) = one
604 beta( i ) = zero
605 60 CONTINUE
606*
607 DO 70 i = 1, min( l, m-k )
608*
609 a1 = dble( a( k+i, n-l+i ) )
610 b1 = dble( b( i, n-l+i ) )
611 gamma = b1 / a1
612*
613 IF( (gamma.LE.hugenum).AND.(gamma.GE.-hugenum) ) THEN
614*
615 IF( gamma.LT.zero ) THEN
616 CALL zdscal( l-i+1, -one, b( i, n-l+i ), ldb )
617 IF( wantv )
618 $ CALL zdscal( p, -one, v( 1, i ), 1 )
619 END IF
620*
621 CALL dlartg( abs( gamma ), one, beta( k+i ), alpha( k+i ),
622 $ rwk )
623*
624 IF( alpha( k+i ).GE.beta( k+i ) ) THEN
625 CALL zdscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),
626 $ lda )
627 ELSE
628 CALL zdscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),
629 $ ldb )
630 CALL zcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),
631 $ lda )
632 END IF
633*
634 ELSE
635*
636 alpha( k+i ) = zero
637 beta( k+i ) = one
638 CALL zcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),
639 $ lda )
640 END IF
641 70 CONTINUE
642*
643* Post-assignment
644*
645 DO 80 i = m + 1, k + l
646 alpha( i ) = zero
647 beta( i ) = one
648 80 CONTINUE
649*
650 IF( k+l.LT.n ) THEN
651 DO 90 i = k + l + 1, n
652 alpha( i ) = zero
653 beta( i ) = zero
654 90 CONTINUE
655 END IF
656*
657 100 CONTINUE
658 ncycle = kcycle
659*
660 RETURN
661*
662* End of ZTGSJA
663*
zlags2
subroutine zlags2(upper, a1, a2, a3, b1, b2, b3, csu, snu, csv, snv, csq, snq)
ZLAGS2
Definition zlags2.f:158
zlapll
subroutine zlapll(n, x, incx, y, incy, ssmin)
ZLAPLL measures the linear dependence of two vectors.
Definition zlapll.f:100

◆ ztgsna()

subroutine ztgsna ( character job,
character howmny,
logical, dimension( * ) select,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldvl, * ) vl,
integer ldvl,
complex*16, dimension( ldvr, * ) vr,
integer ldvr,
double precision, dimension( * ) s,
double precision, dimension( * ) dif,
integer mm,
integer m,
complex*16, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer info )

ZTGSNA

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

Purpose:
!>
!> ZTGSNA estimates reciprocal condition numbers for specified
!> eigenvalues and/or eigenvectors of a matrix pair (A, B).
!>
!> (A, B) must be in generalized Schur canonical form, that is, A and
!> B are both upper triangular.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          Specifies whether condition numbers are required for
!>          eigenvalues (S) or eigenvectors (DIF):
!>          = 'E': for eigenvalues only (S);
!>          = 'V': for eigenvectors only (DIF);
!>          = 'B': for both eigenvalues and eigenvectors (S and DIF).
!>
[in]HOWMNY
!>          HOWMNY is CHARACTER*1
!>          = 'A': compute condition numbers for all eigenpairs;
!>          = 'S': compute condition numbers for selected eigenpairs
!>                 specified by the array SELECT.
!>
[in]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
!>          condition numbers are required. To select condition numbers
!>          for the corresponding j-th eigenvalue and/or eigenvector,
!>          SELECT(j) must be set to .TRUE..
!>          If HOWMNY = 'A', SELECT is not referenced.
!>
[in]N
!>          N is INTEGER
!>          The order of the square matrix pair (A, B). N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The upper triangular matrix A in the pair (A,B).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          The upper triangular matrix B in the pair (A, B).
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!>
[in]VL
!>          VL is COMPLEX*16 array, dimension (LDVL,M)
!>          IF JOB = 'E' or 'B', VL must contain left eigenvectors of
!>          (A, B), corresponding to the eigenpairs specified by HOWMNY
!>          and SELECT.  The eigenvectors must be stored in consecutive
!>          columns of VL, as returned by ZTGEVC.
!>          If JOB = 'V', VL is not referenced.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          The leading dimension of the array VL. LDVL >= 1; and
!>          If JOB = 'E' or 'B', LDVL >= N.
!>
[in]VR
!>          VR is COMPLEX*16 array, dimension (LDVR,M)
!>          IF JOB = 'E' or 'B', VR must contain right eigenvectors of
!>          (A, B), corresponding to the eigenpairs specified by HOWMNY
!>          and SELECT.  The eigenvectors must be stored in consecutive
!>          columns of VR, as returned by ZTGEVC.
!>          If JOB = 'V', VR is not referenced.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          The leading dimension of the array VR. LDVR >= 1;
!>          If JOB = 'E' or 'B', LDVR >= N.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (MM)
!>          If JOB = 'E' or 'B', the reciprocal condition numbers of the
!>          selected eigenvalues, stored in consecutive elements of the
!>          array.
!>          If JOB = 'V', S is not referenced.
!>
[out]DIF
!>          DIF is DOUBLE PRECISION array, dimension (MM)
!>          If JOB = 'V' or 'B', the estimated reciprocal condition
!>          numbers of the selected eigenvectors, stored in consecutive
!>          elements of the array.
!>          If the eigenvalues cannot be reordered to compute DIF(j),
!>          DIF(j) is set to 0; this can only occur when the true value
!>          would be very small anyway.
!>          For each eigenvalue/vector specified by SELECT, DIF stores
!>          a Frobenius norm-based estimate of Difl.
!>          If JOB = 'E', DIF is not referenced.
!>
[in]MM
!>          MM is INTEGER
!>          The number of elements in the arrays S and DIF. MM >= M.
!>
[out]M
!>          M is INTEGER
!>          The number of elements of the arrays S and DIF used to store
!>          the specified condition numbers; for each selected eigenvalue
!>          one element is used. If HOWMNY = 'A', M is set to N.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,N).
!>          If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N+2)
!>          If JOB = 'E', IWORK is not referenced.
!>
[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.
Further Details:
!>
!>  The reciprocal of the condition number of the i-th generalized
!>  eigenvalue w = (a, b) is defined as
!>
!>          S(I) = (|v**HAu|**2 + |v**HBu|**2)**(1/2) / (norm(u)*norm(v))
!>
!>  where u and v are the right and left eigenvectors of (A, B)
!>  corresponding to w; |z| denotes the absolute value of the complex
!>  number, and norm(u) denotes the 2-norm of the vector u. The pair
!>  (a, b) corresponds to an eigenvalue w = a/b (= v**HAu/v**HBu) of the
!>  matrix pair (A, B). If both a and b equal zero, then (A,B) is
!>  singular and S(I) = -1 is returned.
!>
!>  An approximate error bound on the chordal distance between the i-th
!>  computed generalized eigenvalue w and the corresponding exact
!>  eigenvalue lambda is
!>
!>          chord(w, lambda) <=   EPS * norm(A, B) / S(I),
!>
!>  where EPS is the machine precision.
!>
!>  The reciprocal of the condition number of the right eigenvector u
!>  and left eigenvector v corresponding to the generalized eigenvalue w
!>  is defined as follows. Suppose
!>
!>                   (A, B) = ( a   *  ) ( b  *  )  1
!>                            ( 0  A22 ),( 0 B22 )  n-1
!>                              1  n-1     1 n-1
!>
!>  Then the reciprocal condition number DIF(I) is
!>
!>          Difl[(a, b), (A22, B22)]  = sigma-min( Zl )
!>
!>  where sigma-min(Zl) denotes the smallest singular value of
!>
!>         Zl = [ kron(a, In-1) -kron(1, A22) ]
!>              [ kron(b, In-1) -kron(1, B22) ].
!>
!>  Here In-1 is the identity matrix of size n-1 and X**H is the conjugate
!>  transpose of X. kron(X, Y) is the Kronecker product between the
!>  matrices X and Y.
!>
!>  We approximate the smallest singular value of Zl with an upper
!>  bound. This is done by ZLATDF.
!>
!>  An approximate error bound for a computed eigenvector VL(i) or
!>  VR(i) is given by
!>
!>                      EPS * norm(A, B) / DIF(i).
!>
!>  See ref. [2-3] for more details and further references.
!>
Contributors:
Bo Kagstrom and Peter Poromaa, Department of Computing Science, Umea University, S-901 87 Umea, Sweden.
References:
!>
!>  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
!>      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
!>      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
!>      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
!>
!>  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
!>      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
!>      Estimation: Theory, Algorithms and Software, Report
!>      UMINF - 94.04, Department of Computing Science, Umea University,
!>      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
!>      To appear in Numerical Algorithms, 1996.
!>
!>  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
!>      for Solving the Generalized Sylvester Equation and Estimating the
!>      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
!>      Department of Computing Science, Umea University, S-901 87 Umea,
!>      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
!>      Note 75.
!>      To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.
!>

Definition at line 308 of file ztgsna.f.

311*
312* -- LAPACK computational routine --
313* -- LAPACK is a software package provided by Univ. of Tennessee, --
314* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
315*
316* .. Scalar Arguments ..
317 CHARACTER HOWMNY, JOB
318 INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
319* ..
320* .. Array Arguments ..
321 LOGICAL SELECT( * )
322 INTEGER IWORK( * )
323 DOUBLE PRECISION DIF( * ), S( * )
324 COMPLEX*16 A( LDA, * ), B( LDB, * ), VL( LDVL, * ),
325 $ VR( LDVR, * ), WORK( * )
326* ..
327*
328* =====================================================================
329*
330* .. Parameters ..
331 DOUBLE PRECISION ZERO, ONE
332 INTEGER IDIFJB
333 parameter( zero = 0.0d+0, one = 1.0d+0, idifjb = 3 )
334* ..
335* .. Local Scalars ..
336 LOGICAL LQUERY, SOMCON, WANTBH, WANTDF, WANTS
337 INTEGER I, IERR, IFST, ILST, K, KS, LWMIN, N1, N2
338 DOUBLE PRECISION BIGNUM, COND, EPS, LNRM, RNRM, SCALE, SMLNUM
339 COMPLEX*16 YHAX, YHBX
340* ..
341* .. Local Arrays ..
342 COMPLEX*16 DUMMY( 1 ), DUMMY1( 1 )
343* ..
344* .. External Functions ..
345 LOGICAL LSAME
346 DOUBLE PRECISION DLAMCH, DLAPY2, DZNRM2
347 COMPLEX*16 ZDOTC
348 EXTERNAL lsame, dlamch, dlapy2, dznrm2, zdotc
349* ..
350* .. External Subroutines ..
351 EXTERNAL dlabad, xerbla, zgemv, zlacpy, ztgexc, ztgsyl
352* ..
353* .. Intrinsic Functions ..
354 INTRINSIC abs, dcmplx, max
355* ..
356* .. Executable Statements ..
357*
358* Decode and test the input parameters
359*
360 wantbh = lsame( job, 'B' )
361 wants = lsame( job, 'E' ) .OR. wantbh
362 wantdf = lsame( job, 'V' ) .OR. wantbh
363*
364 somcon = lsame( howmny, 'S' )
365*
366 info = 0
367 lquery = ( lwork.EQ.-1 )
368*
369 IF( .NOT.wants .AND. .NOT.wantdf ) THEN
370 info = -1
371 ELSE IF( .NOT.lsame( howmny, 'A' ) .AND. .NOT.somcon ) THEN
372 info = -2
373 ELSE IF( n.LT.0 ) THEN
374 info = -4
375 ELSE IF( lda.LT.max( 1, n ) ) THEN
376 info = -6
377 ELSE IF( ldb.LT.max( 1, n ) ) THEN
378 info = -8
379 ELSE IF( wants .AND. ldvl.LT.n ) THEN
380 info = -10
381 ELSE IF( wants .AND. ldvr.LT.n ) THEN
382 info = -12
383 ELSE
384*
385* Set M to the number of eigenpairs for which condition numbers
386* are required, and test MM.
387*
388 IF( somcon ) THEN
389 m = 0
390 DO 10 k = 1, n
391 IF( SELECT( k ) )
392 $ m = m + 1
393 10 CONTINUE
394 ELSE
395 m = n
396 END IF
397*
398 IF( n.EQ.0 ) THEN
399 lwmin = 1
400 ELSE IF( lsame( job, 'V' ) .OR. lsame( job, 'B' ) ) THEN
401 lwmin = 2*n*n
402 ELSE
403 lwmin = n
404 END IF
405 work( 1 ) = lwmin
406*
407 IF( mm.LT.m ) THEN
408 info = -15
409 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
410 info = -18
411 END IF
412 END IF
413*
414 IF( info.NE.0 ) THEN
415 CALL xerbla( 'ZTGSNA', -info )
416 RETURN
417 ELSE IF( lquery ) THEN
418 RETURN
419 END IF
420*
421* Quick return if possible
422*
423 IF( n.EQ.0 )
424 $ RETURN
425*
426* Get machine constants
427*
428 eps = dlamch( 'P' )
429 smlnum = dlamch( 'S' ) / eps
430 bignum = one / smlnum
431 CALL dlabad( smlnum, bignum )
432 ks = 0
433 DO 20 k = 1, n
434*
435* Determine whether condition numbers are required for the k-th
436* eigenpair.
437*
438 IF( somcon ) THEN
439 IF( .NOT.SELECT( k ) )
440 $ GO TO 20
441 END IF
442*
443 ks = ks + 1
444*
445 IF( wants ) THEN
446*
447* Compute the reciprocal condition number of the k-th
448* eigenvalue.
449*
450 rnrm = dznrm2( n, vr( 1, ks ), 1 )
451 lnrm = dznrm2( n, vl( 1, ks ), 1 )
452 CALL zgemv( 'N', n, n, dcmplx( one, zero ), a, lda,
453 $ vr( 1, ks ), 1, dcmplx( zero, zero ), work, 1 )
454 yhax = zdotc( n, work, 1, vl( 1, ks ), 1 )
455 CALL zgemv( 'N', n, n, dcmplx( one, zero ), b, ldb,
456 $ vr( 1, ks ), 1, dcmplx( zero, zero ), work, 1 )
457 yhbx = zdotc( n, work, 1, vl( 1, ks ), 1 )
458 cond = dlapy2( abs( yhax ), abs( yhbx ) )
459 IF( cond.EQ.zero ) THEN
460 s( ks ) = -one
461 ELSE
462 s( ks ) = cond / ( rnrm*lnrm )
463 END IF
464 END IF
465*
466 IF( wantdf ) THEN
467 IF( n.EQ.1 ) THEN
468 dif( ks ) = dlapy2( abs( a( 1, 1 ) ), abs( b( 1, 1 ) ) )
469 ELSE
470*
471* Estimate the reciprocal condition number of the k-th
472* eigenvectors.
473*
474* Copy the matrix (A, B) to the array WORK and move the
475* (k,k)th pair to the (1,1) position.
476*
477 CALL zlacpy( 'Full', n, n, a, lda, work, n )
478 CALL zlacpy( 'Full', n, n, b, ldb, work( n*n+1 ), n )
479 ifst = k
480 ilst = 1
481*
482 CALL ztgexc( .false., .false., n, work, n, work( n*n+1 ),
483 $ n, dummy, 1, dummy1, 1, ifst, ilst, ierr )
484*
485 IF( ierr.GT.0 ) THEN
486*
487* Ill-conditioned problem - swap rejected.
488*
489 dif( ks ) = zero
490 ELSE
491*
492* Reordering successful, solve generalized Sylvester
493* equation for R and L,
494* A22 * R - L * A11 = A12
495* B22 * R - L * B11 = B12,
496* and compute estimate of Difl[(A11,B11), (A22, B22)].
497*
498 n1 = 1
499 n2 = n - n1
500 i = n*n + 1
501 CALL ztgsyl( 'N', idifjb, n2, n1, work( n*n1+n1+1 ),
502 $ n, work, n, work( n1+1 ), n,
503 $ work( n*n1+n1+i ), n, work( i ), n,
504 $ work( n1+i ), n, scale, dif( ks ), dummy,
505 $ 1, iwork, ierr )
506 END IF
507 END IF
508 END IF
509*
510 20 CONTINUE
511 work( 1 ) = lwmin
512 RETURN
513*
514* End of ZTGSNA
515*
dlabad
subroutine dlabad(small, large)
DLABAD
Definition dlabad.f:74

◆ ztpcon()

subroutine ztpcon ( character norm,
character uplo,
character diag,
integer n,
complex*16, dimension( * ) ap,
double precision rcond,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZTPCON

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

Purpose:
!>
!> ZTPCON estimates the reciprocal of the condition number of a packed
!> triangular matrix A, in either the 1-norm or the infinity-norm.
!>
!> The norm of A is computed and an estimate is obtained for
!> norm(inv(A)), then the reciprocal of the condition number is
!> computed as
!>    RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies whether the 1-norm condition number or the
!>          infinity-norm condition number is required:
!>          = '1' or 'O':  1-norm;
!>          = 'I':         Infinity-norm.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[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.
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 128 of file ztpcon.f.

130*
131* -- LAPACK computational 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 DIAG, NORM, UPLO
137 INTEGER INFO, N
138 DOUBLE PRECISION RCOND
139* ..
140* .. Array Arguments ..
141 DOUBLE PRECISION RWORK( * )
142 COMPLEX*16 AP( * ), WORK( * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 DOUBLE PRECISION ONE, ZERO
149 parameter( one = 1.0d+0, zero = 0.0d+0 )
150* ..
151* .. Local Scalars ..
152 LOGICAL NOUNIT, ONENRM, UPPER
153 CHARACTER NORMIN
154 INTEGER IX, KASE, KASE1
155 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
156 COMPLEX*16 ZDUM
157* ..
158* .. Local Arrays ..
159 INTEGER ISAVE( 3 )
160* ..
161* .. External Functions ..
162 LOGICAL LSAME
163 INTEGER IZAMAX
164 DOUBLE PRECISION DLAMCH, ZLANTP
165 EXTERNAL lsame, izamax, dlamch, zlantp
166* ..
167* .. External Subroutines ..
168 EXTERNAL xerbla, zdrscl, zlacn2, zlatps
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC abs, dble, dimag, max
172* ..
173* .. Statement Functions ..
174 DOUBLE PRECISION CABS1
175* ..
176* .. Statement Function definitions ..
177 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
178* ..
179* .. Executable Statements ..
180*
181* Test the input parameters.
182*
183 info = 0
184 upper = lsame( uplo, 'U' )
185 onenrm = norm.EQ.'1' .OR. lsame( norm, 'O' )
186 nounit = lsame( diag, 'N' )
187*
188 IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN
189 info = -1
190 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
191 info = -2
192 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
193 info = -3
194 ELSE IF( n.LT.0 ) THEN
195 info = -4
196 END IF
197 IF( info.NE.0 ) THEN
198 CALL xerbla( 'ZTPCON', -info )
199 RETURN
200 END IF
201*
202* Quick return if possible
203*
204 IF( n.EQ.0 ) THEN
205 rcond = one
206 RETURN
207 END IF
208*
209 rcond = zero
210 smlnum = dlamch( 'Safe minimum' )*dble( max( 1, n ) )
211*
212* Compute the norm of the triangular matrix A.
213*
214 anorm = zlantp( norm, uplo, diag, n, ap, rwork )
215*
216* Continue only if ANORM > 0.
217*
218 IF( anorm.GT.zero ) THEN
219*
220* Estimate the norm of the inverse of A.
221*
222 ainvnm = zero
223 normin = 'N'
224 IF( onenrm ) THEN
225 kase1 = 1
226 ELSE
227 kase1 = 2
228 END IF
229 kase = 0
230 10 CONTINUE
231 CALL zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
232 IF( kase.NE.0 ) THEN
233 IF( kase.EQ.kase1 ) THEN
234*
235* Multiply by inv(A).
236*
237 CALL zlatps( uplo, 'No transpose', diag, normin, n, ap,
238 $ work, scale, rwork, info )
239 ELSE
240*
241* Multiply by inv(A**H).
242*
243 CALL zlatps( uplo, 'Conjugate transpose', diag, normin,
244 $ n, ap, work, scale, rwork, info )
245 END IF
246 normin = 'Y'
247*
248* Multiply by 1/SCALE if doing so will not cause overflow.
249*
250 IF( scale.NE.one ) THEN
251 ix = izamax( n, work, 1 )
252 xnorm = cabs1( work( ix ) )
253 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
254 $ GO TO 20
255 CALL zdrscl( n, scale, work, 1 )
256 END IF
257 GO TO 10
258 END IF
259*
260* Compute the estimate of the reciprocal condition number.
261*
262 IF( ainvnm.NE.zero )
263 $ rcond = ( one / anorm ) / ainvnm
264 END IF
265*
266 20 CONTINUE
267 RETURN
268*
269* End of ZTPCON
270*
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

◆ ztpmqrt()

subroutine ztpmqrt ( character side,
character trans,
integer m,
integer n,
integer k,
integer l,
integer nb,
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( * ) work,
integer info )

ZTPMQRT

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

Purpose:
!>
!> ZTPMQRT applies a complex orthogonal matrix Q obtained from a
!>  complex block reflector H to a general
!> complex matrix C, which consists of two blocks A and B.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate transpose, apply Q**H.
!>
[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 number of elementary reflectors whose product defines
!>          the matrix Q.
!>
[in]L
!>          L is INTEGER
!>          The order of the trapezoidal part of V.
!>          K >= L >= 0.  See Further Details.
!>
[in]NB
!>          NB is INTEGER
!>          The block size used for the storage of T.  K >= NB >= 1.
!>          This must be the same value of NB used to generate T
!>          in CTPQRT.
!>
[in]V
!>          V is COMPLEX*16 array, dimension (LDV,K)
!>          The i-th column must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          CTPQRT in B.  See Further Details.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V.
!>          If SIDE = 'L', LDV >= max(1,M);
!>          if SIDE = 'R', LDV >= max(1,N).
!>
[in]T
!>          T is COMPLEX*16 array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by CTPQRT, stored as a NB-by-K matrix.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB.
!>
[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
!>          Q*C or Q**H*C or C*Q or C*Q**H.  See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If SIDE = 'L', LDC >= max(1,K);
!>          If SIDE = 'R', LDC >= 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
!>          Q*C or Q**H*C or C*Q or C*Q**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. The dimension of WORK is
!>           N*NB if SIDE = 'L', or  M*NB if SIDE = 'R'.
!>
[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.
Further Details:
!>
!>  The columns of the pentagonal matrix V contain the elementary reflectors
!>  H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
!>  trapezoidal block V2:
!>
!>        V = [V1]
!>            [V2].
!>
!>  The size of the trapezoidal block V2 is determined by the parameter L,
!>  where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L
!>  rows of a K-by-K upper triangular matrix.  If L=K, V2 is upper triangular;
!>  if L=0, there is no trapezoidal block, hence V = V1 is rectangular.
!>
!>  If SIDE = 'L':  C = [A]  where A is K-by-N,  B is M-by-N and V is M-by-K.
!>                      [B]
!>
!>  If SIDE = 'R':  C = [A B]  where A is M-by-K, B is M-by-N and V is N-by-K.
!>
!>  The complex orthogonal matrix Q is formed from V and T.
!>
!>  If TRANS='N' and SIDE='L', C is on exit replaced with Q * C.
!>
!>  If TRANS='C' and SIDE='L', C is on exit replaced with Q**H * C.
!>
!>  If TRANS='N' and SIDE='R', C is on exit replaced with C * Q.
!>
!>  If TRANS='C' and SIDE='R', C is on exit replaced with C * Q**H.
!>

Definition at line 214 of file ztpmqrt.f.

216*
217* -- LAPACK computational routine --
218* -- LAPACK is a software package provided by Univ. of Tennessee, --
219* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
220*
221* .. Scalar Arguments ..
222 CHARACTER SIDE, TRANS
223 INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT
224* ..
225* .. Array Arguments ..
226 COMPLEX*16 V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ),
227 $ WORK( * )
228* ..
229*
230* =====================================================================
231*
232* ..
233* .. Local Scalars ..
234 LOGICAL LEFT, RIGHT, TRAN, NOTRAN
235 INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ
236* ..
237* .. External Functions ..
238 LOGICAL LSAME
239 EXTERNAL lsame
240* ..
241* .. External Subroutines ..
242 EXTERNAL ztprfb, xerbla
243* ..
244* .. Intrinsic Functions ..
245 INTRINSIC max, min
246* ..
247* .. Executable Statements ..
248*
249* .. Test the input arguments ..
250*
251 info = 0
252 left = lsame( side, 'L' )
253 right = lsame( side, 'R' )
254 tran = lsame( trans, 'C' )
255 notran = lsame( trans, 'N' )
256*
257 IF ( left ) THEN
258 ldvq = max( 1, m )
259 ldaq = max( 1, k )
260 ELSE IF ( right ) THEN
261 ldvq = max( 1, n )
262 ldaq = max( 1, m )
263 END IF
264 IF( .NOT.left .AND. .NOT.right ) THEN
265 info = -1
266 ELSE IF( .NOT.tran .AND. .NOT.notran ) THEN
267 info = -2
268 ELSE IF( m.LT.0 ) THEN
269 info = -3
270 ELSE IF( n.LT.0 ) THEN
271 info = -4
272 ELSE IF( k.LT.0 ) THEN
273 info = -5
274 ELSE IF( l.LT.0 .OR. l.GT.k ) THEN
275 info = -6
276 ELSE IF( nb.LT.1 .OR. (nb.GT.k .AND. k.GT.0) ) THEN
277 info = -7
278 ELSE IF( ldv.LT.ldvq ) THEN
279 info = -9
280 ELSE IF( ldt.LT.nb ) THEN
281 info = -11
282 ELSE IF( lda.LT.ldaq ) THEN
283 info = -13
284 ELSE IF( ldb.LT.max( 1, m ) ) THEN
285 info = -15
286 END IF
287*
288 IF( info.NE.0 ) THEN
289 CALL xerbla( 'ZTPMQRT', -info )
290 RETURN
291 END IF
292*
293* .. Quick return if possible ..
294*
295 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) RETURN
296*
297 IF( left .AND. tran ) THEN
298*
299 DO i = 1, k, nb
300 ib = min( nb, k-i+1 )
301 mb = min( m-l+i+ib-1, m )
302 IF( i.GE.l ) THEN
303 lb = 0
304 ELSE
305 lb = mb-m+l-i+1
306 END IF
307 CALL ztprfb( 'L', 'C', 'F', 'C', mb, n, ib, lb,
308 $ v( 1, i ), ldv, t( 1, i ), ldt,
309 $ a( i, 1 ), lda, b, ldb, work, ib )
310 END DO
311*
312 ELSE IF( right .AND. notran ) THEN
313*
314 DO i = 1, k, nb
315 ib = min( nb, k-i+1 )
316 mb = min( n-l+i+ib-1, n )
317 IF( i.GE.l ) THEN
318 lb = 0
319 ELSE
320 lb = mb-n+l-i+1
321 END IF
322 CALL ztprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,
323 $ v( 1, i ), ldv, t( 1, i ), ldt,
324 $ a( 1, i ), lda, b, ldb, work, m )
325 END DO
326*
327 ELSE IF( left .AND. notran ) THEN
328*
329 kf = ((k-1)/nb)*nb+1
330 DO i = kf, 1, -nb
331 ib = min( nb, k-i+1 )
332 mb = min( m-l+i+ib-1, m )
333 IF( i.GE.l ) THEN
334 lb = 0
335 ELSE
336 lb = mb-m+l-i+1
337 END IF
338 CALL ztprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,
339 $ v( 1, i ), ldv, t( 1, i ), ldt,
340 $ a( i, 1 ), lda, b, ldb, work, ib )
341 END DO
342*
343 ELSE IF( right .AND. tran ) THEN
344*
345 kf = ((k-1)/nb)*nb+1
346 DO i = kf, 1, -nb
347 ib = min( nb, k-i+1 )
348 mb = min( n-l+i+ib-1, n )
349 IF( i.GE.l ) THEN
350 lb = 0
351 ELSE
352 lb = mb-n+l-i+1
353 END IF
354 CALL ztprfb( 'R', 'C', 'F', 'C', m, mb, ib, lb,
355 $ v( 1, i ), ldv, t( 1, i ), ldt,
356 $ a( 1, i ), lda, b, ldb, work, m )
357 END DO
358*
359 END IF
360*
361 RETURN
362*
363* End of ZTPMQRT
364*
ztprfb
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 matri...
Definition ztprfb.f:251

◆ ztpqrt()

subroutine ztpqrt ( integer m,
integer n,
integer l,
integer nb,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( * ) work,
integer info )

ZTPQRT

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

Purpose:
!>
!> ZTPQRT computes a blocked QR factorization of a complex
!>  matrix C, which is composed of a
!> triangular block A and pentagonal block B, using the compact
!> WY representation for Q.
!>
Parameters
[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, and the order of the
!>          triangular matrix A.
!>          N >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the upper trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in]NB
!>          NB is INTEGER
!>          The block size to be used in the blocked QR.  N >= NB >= 1.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the upper triangular N-by-N matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the upper triangular matrix R.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          On entry, the pentagonal M-by-N matrix B.  The first M-L rows
!>          are rectangular, and the last L rows are upper trapezoidal.
!>          On exit, B contains the pentagonal matrix V.  See Further Details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDT,N)
!>          The upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.  See Further Details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NB*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The input matrix C is a (N+M)-by-N matrix
!>
!>               C = [ A ]
!>                   [ B ]
!>
!>  where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal
!>  matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N
!>  upper trapezoidal matrix B2:
!>
!>               B = [ B1 ]  <- (M-L)-by-N rectangular
!>                   [ B2 ]  <-     L-by-N upper trapezoidal.
!>
!>  The upper trapezoidal matrix B2 consists of the first L rows of a
!>  N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is upper triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th column
!>  below the diagonal (of A) in the (N+M)-by-N input matrix C
!>
!>               C = [ A ]  <- upper triangular N-by-N
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>
!>               W = [ I ]  <- identity, N-by-N
!>                   [ V ]  <- M-by-N, same form as B.
!>
!>  Thus, all of information needed for W is contained on exit in B, which
!>  we call V above.  Note that V has the same form as B; that is,
!>
!>               V = [ V1 ] <- (M-L)-by-N rectangular
!>                   [ V2 ] <-     L-by-N upper trapezoidal.
!>
!>  The columns of V represent the vectors which define the H(i)'s.
!>
!>  The number of blocks is B = ceiling(N/NB), where each
!>  block is of order NB except for the last block, which is of order
!>  IB = N - (B-1)*NB.  For each of the B blocks, a upper triangular block
!>  reflector factor is computed: T1, T2, ..., TB.  The NB-by-NB (and IB-by-IB
!>  for the last block) T's are stored in the NB-by-N matrix T as
!>
!>               T = [T1 T2 ... TB].
!>

Definition at line 187 of file ztpqrt.f.

189*
190* -- LAPACK computational routine --
191* -- LAPACK is a software package provided by Univ. of Tennessee, --
192* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
193*
194* .. Scalar Arguments ..
195 INTEGER INFO, LDA, LDB, LDT, N, M, L, NB
196* ..
197* .. Array Arguments ..
198 COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
199* ..
200*
201* =====================================================================
202*
203* ..
204* .. Local Scalars ..
205 INTEGER I, IB, LB, MB, IINFO
206* ..
207* .. External Subroutines ..
208 EXTERNAL ztpqrt2, ztprfb, xerbla
209* ..
210* .. Executable Statements ..
211*
212* Test the input arguments
213*
214 info = 0
215 IF( m.LT.0 ) THEN
216 info = -1
217 ELSE IF( n.LT.0 ) THEN
218 info = -2
219 ELSE IF( l.LT.0 .OR. (l.GT.min(m,n) .AND. min(m,n).GE.0)) THEN
220 info = -3
221 ELSE IF( nb.LT.1 .OR. (nb.GT.n .AND. n.GT.0)) THEN
222 info = -4
223 ELSE IF( lda.LT.max( 1, n ) ) THEN
224 info = -6
225 ELSE IF( ldb.LT.max( 1, m ) ) THEN
226 info = -8
227 ELSE IF( ldt.LT.nb ) THEN
228 info = -10
229 END IF
230 IF( info.NE.0 ) THEN
231 CALL xerbla( 'ZTPQRT', -info )
232 RETURN
233 END IF
234*
235* Quick return if possible
236*
237 IF( m.EQ.0 .OR. n.EQ.0 ) RETURN
238*
239 DO i = 1, n, nb
240*
241* Compute the QR factorization of the current block
242*
243 ib = min( n-i+1, nb )
244 mb = min( m-l+i+ib-1, m )
245 IF( i.GE.l ) THEN
246 lb = 0
247 ELSE
248 lb = mb-m+l-i+1
249 END IF
250*
251 CALL ztpqrt2( mb, ib, lb, a(i,i), lda, b( 1, i ), ldb,
252 $ t(1, i ), ldt, iinfo )
253*
254* Update by applying H**H to B(:,I+IB:N) from the left
255*
256 IF( i+ib.LE.n ) THEN
257 CALL ztprfb( 'L', 'C', 'F', 'C', mb, n-i-ib+1, ib, lb,
258 $ b( 1, i ), ldb, t( 1, i ), ldt,
259 $ a( i, i+ib ), lda, b( 1, i+ib ), ldb,
260 $ work, ib )
261 END IF
262 END DO
263 RETURN
264*
265* End of ZTPQRT
266*
ztpqrt2
subroutine ztpqrt2(m, n, l, a, lda, b, ldb, t, ldt, info)
ZTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix,...
Definition ztpqrt2.f:173

◆ ztpqrt2()

subroutine ztpqrt2 ( integer m,
integer n,
integer l,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldt, * ) t,
integer ldt,
integer info )

ZTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q.

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

Purpose:
!>
!> ZTPQRT2 computes a QR factorization of a complex 
!> matrix C, which is composed of a triangular block A and pentagonal block B,
!> using the compact WY representation for Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The total number of rows of the matrix B.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix B, and the order of
!>          the triangular matrix A.
!>          N >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the upper trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the upper triangular N-by-N matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the upper triangular matrix R.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          On entry, the pentagonal M-by-N matrix B.  The first M-L rows
!>          are rectangular, and the last L rows are upper trapezoidal.
!>          On exit, B contains the pentagonal matrix V.  See Further Details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDT,N)
!>          The N-by-N upper triangular factor T of the block reflector.
!>          See Further Details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= max(1,N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The input matrix C is a (N+M)-by-N matrix
!>
!>               C = [ A ]
!>                   [ B ]
!>
!>  where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal
!>  matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N
!>  upper trapezoidal matrix B2:
!>
!>               B = [ B1 ]  <- (M-L)-by-N rectangular
!>                   [ B2 ]  <-     L-by-N upper trapezoidal.
!>
!>  The upper trapezoidal matrix B2 consists of the first L rows of a
!>  N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is upper triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th column
!>  below the diagonal (of A) in the (N+M)-by-N input matrix C
!>
!>               C = [ A ]  <- upper triangular N-by-N
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>
!>               W = [ I ]  <- identity, N-by-N
!>                   [ V ]  <- M-by-N, same form as B.
!>
!>  Thus, all of information needed for W is contained on exit in B, which
!>  we call V above.  Note that V has the same form as B; that is,
!>
!>               V = [ V1 ] <- (M-L)-by-N rectangular
!>                   [ V2 ] <-     L-by-N upper trapezoidal.
!>
!>  The columns of V represent the vectors which define the H(i)'s.
!>  The (M+N)-by-(M+N) block reflector H is then given by
!>
!>               H = I - W * T * W**H
!>
!>  where W**H is the conjugate transpose of W and T is the upper triangular
!>  factor of the block reflector.
!>

Definition at line 172 of file ztpqrt2.f.

173*
174* -- LAPACK computational routine --
175* -- LAPACK is a software package provided by Univ. of Tennessee, --
176* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
177*
178* .. Scalar Arguments ..
179 INTEGER INFO, LDA, LDB, LDT, N, M, L
180* ..
181* .. Array Arguments ..
182 COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * )
183* ..
184*
185* =====================================================================
186*
187* .. Parameters ..
188 COMPLEX*16 ONE, ZERO
189 parameter( one = (1.0,0.0), zero = (0.0,0.0) )
190* ..
191* .. Local Scalars ..
192 INTEGER I, J, P, MP, NP
193 COMPLEX*16 ALPHA
194* ..
195* .. External Subroutines ..
196 EXTERNAL zlarfg, zgemv, zgerc, ztrmv, xerbla
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC max, min
200* ..
201* .. Executable Statements ..
202*
203* Test the input arguments
204*
205 info = 0
206 IF( m.LT.0 ) THEN
207 info = -1
208 ELSE IF( n.LT.0 ) THEN
209 info = -2
210 ELSE IF( l.LT.0 .OR. l.GT.min(m,n) ) THEN
211 info = -3
212 ELSE IF( lda.LT.max( 1, n ) ) THEN
213 info = -5
214 ELSE IF( ldb.LT.max( 1, m ) ) THEN
215 info = -7
216 ELSE IF( ldt.LT.max( 1, n ) ) THEN
217 info = -9
218 END IF
219 IF( info.NE.0 ) THEN
220 CALL xerbla( 'ZTPQRT2', -info )
221 RETURN
222 END IF
223*
224* Quick return if possible
225*
226 IF( n.EQ.0 .OR. m.EQ.0 ) RETURN
227*
228 DO i = 1, n
229*
230* Generate elementary reflector H(I) to annihilate B(:,I)
231*
232 p = m-l+min( l, i )
233 CALL zlarfg( p+1, a( i, i ), b( 1, i ), 1, t( i, 1 ) )
234 IF( i.LT.n ) THEN
235*
236* W(1:N-I) := C(I:M,I+1:N)**H * C(I:M,I) [use W = T(:,N)]
237*
238 DO j = 1, n-i
239 t( j, n ) = conjg(a( i, i+j ))
240 END DO
241 CALL zgemv( 'C', p, n-i, one, b( 1, i+1 ), ldb,
242 $ b( 1, i ), 1, one, t( 1, n ), 1 )
243*
244* C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)**H
245*
246 alpha = -conjg(t( i, 1 ))
247 DO j = 1, n-i
248 a( i, i+j ) = a( i, i+j ) + alpha*conjg(t( j, n ))
249 END DO
250 CALL zgerc( p, n-i, alpha, b( 1, i ), 1,
251 $ t( 1, n ), 1, b( 1, i+1 ), ldb )
252 END IF
253 END DO
254*
255 DO i = 2, n
256*
257* T(1:I-1,I) := C(I:M,1:I-1)**H * (alpha * C(I:M,I))
258*
259 alpha = -t( i, 1 )
260
261 DO j = 1, i-1
262 t( j, i ) = zero
263 END DO
264 p = min( i-1, l )
265 mp = min( m-l+1, m )
266 np = min( p+1, n )
267*
268* Triangular part of B2
269*
270 DO j = 1, p
271 t( j, i ) = alpha*b( m-l+j, i )
272 END DO
273 CALL ztrmv( 'U', 'C', 'N', p, b( mp, 1 ), ldb,
274 $ t( 1, i ), 1 )
275*
276* Rectangular part of B2
277*
278 CALL zgemv( 'C', l, i-1-p, alpha, b( mp, np ), ldb,
279 $ b( mp, i ), 1, zero, t( np, i ), 1 )
280*
281* B1
282*
283 CALL zgemv( 'C', m-l, i-1, alpha, b, ldb, b( 1, i ), 1,
284 $ one, t( 1, i ), 1 )
285*
286* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I)
287*
288 CALL ztrmv( 'U', 'N', 'N', i-1, t, ldt, t( 1, i ), 1 )
289*
290* T(I,I) = tau(I)
291*
292 t( i, i ) = t( i, 1 )
293 t( i, 1 ) = zero
294 END DO
295
296*
297* End of ZTPQRT2
298*

◆ ztprfs()

subroutine ztprfs ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZTPRFS

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

Purpose:
!>
!> ZTPRFS provides error bounds and backward error estimates for the
!> solution to a system of linear equations with a triangular packed
!> coefficient matrix.
!>
!> The solution matrix X must be computed by ZTPTRS or some other
!> means before entering this routine.  ZTPRFS does not do iterative
!> refinement because doing so cannot improve the backward error.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[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 B and X.  NRHS >= 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.
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 172 of file ztprfs.f.

174*
175* -- LAPACK computational routine --
176* -- LAPACK is a software package provided by Univ. of Tennessee, --
177* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
178*
179* .. Scalar Arguments ..
180 CHARACTER DIAG, TRANS, UPLO
181 INTEGER INFO, LDB, LDX, N, NRHS
182* ..
183* .. Array Arguments ..
184 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
185 COMPLEX*16 AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
186* ..
187*
188* =====================================================================
189*
190* .. Parameters ..
191 DOUBLE PRECISION ZERO
192 parameter( zero = 0.0d+0 )
193 COMPLEX*16 ONE
194 parameter( one = ( 1.0d+0, 0.0d+0 ) )
195* ..
196* .. Local Scalars ..
197 LOGICAL NOTRAN, NOUNIT, UPPER
198 CHARACTER TRANSN, TRANST
199 INTEGER I, J, K, KASE, KC, NZ
200 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
201 COMPLEX*16 ZDUM
202* ..
203* .. Local Arrays ..
204 INTEGER ISAVE( 3 )
205* ..
206* .. External Subroutines ..
207 EXTERNAL xerbla, zaxpy, zcopy, zlacn2, ztpmv, ztpsv
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC abs, dble, dimag, max
211* ..
212* .. External Functions ..
213 LOGICAL LSAME
214 DOUBLE PRECISION DLAMCH
215 EXTERNAL lsame, dlamch
216* ..
217* .. Statement Functions ..
218 DOUBLE PRECISION CABS1
219* ..
220* .. Statement Function definitions ..
221 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
222* ..
223* .. Executable Statements ..
224*
225* Test the input parameters.
226*
227 info = 0
228 upper = lsame( uplo, 'U' )
229 notran = lsame( trans, 'N' )
230 nounit = lsame( diag, 'N' )
231*
232 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
233 info = -1
234 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
235 $ lsame( trans, 'C' ) ) THEN
236 info = -2
237 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
238 info = -3
239 ELSE IF( n.LT.0 ) THEN
240 info = -4
241 ELSE IF( nrhs.LT.0 ) THEN
242 info = -5
243 ELSE IF( ldb.LT.max( 1, n ) ) THEN
244 info = -8
245 ELSE IF( ldx.LT.max( 1, n ) ) THEN
246 info = -10
247 END IF
248 IF( info.NE.0 ) THEN
249 CALL xerbla( 'ZTPRFS', -info )
250 RETURN
251 END IF
252*
253* Quick return if possible
254*
255 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
256 DO 10 j = 1, nrhs
257 ferr( j ) = zero
258 berr( j ) = zero
259 10 CONTINUE
260 RETURN
261 END IF
262*
263 IF( notran ) THEN
264 transn = 'N'
265 transt = 'C'
266 ELSE
267 transn = 'C'
268 transt = 'N'
269 END IF
270*
271* NZ = maximum number of nonzero elements in each row of A, plus 1
272*
273 nz = n + 1
274 eps = dlamch( 'Epsilon' )
275 safmin = dlamch( 'Safe minimum' )
276 safe1 = nz*safmin
277 safe2 = safe1 / eps
278*
279* Do for each right hand side
280*
281 DO 250 j = 1, nrhs
282*
283* Compute residual R = B - op(A) * X,
284* where op(A) = A, A**T, or A**H, depending on TRANS.
285*
286 CALL zcopy( n, x( 1, j ), 1, work, 1 )
287 CALL ztpmv( uplo, trans, diag, n, ap, work, 1 )
288 CALL zaxpy( n, -one, b( 1, j ), 1, work, 1 )
289*
290* Compute componentwise relative backward error from formula
291*
292* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
293*
294* where abs(Z) is the componentwise absolute value of the matrix
295* or vector Z. If the i-th component of the denominator is less
296* than SAFE2, then SAFE1 is added to the i-th components of the
297* numerator and denominator before dividing.
298*
299 DO 20 i = 1, n
300 rwork( i ) = cabs1( b( i, j ) )
301 20 CONTINUE
302*
303 IF( notran ) THEN
304*
305* Compute abs(A)*abs(X) + abs(B).
306*
307 IF( upper ) THEN
308 kc = 1
309 IF( nounit ) THEN
310 DO 40 k = 1, n
311 xk = cabs1( x( k, j ) )
312 DO 30 i = 1, k
313 rwork( i ) = rwork( i ) +
314 $ cabs1( ap( kc+i-1 ) )*xk
315 30 CONTINUE
316 kc = kc + k
317 40 CONTINUE
318 ELSE
319 DO 60 k = 1, n
320 xk = cabs1( x( k, j ) )
321 DO 50 i = 1, k - 1
322 rwork( i ) = rwork( i ) +
323 $ cabs1( ap( kc+i-1 ) )*xk
324 50 CONTINUE
325 rwork( k ) = rwork( k ) + xk
326 kc = kc + k
327 60 CONTINUE
328 END IF
329 ELSE
330 kc = 1
331 IF( nounit ) THEN
332 DO 80 k = 1, n
333 xk = cabs1( x( k, j ) )
334 DO 70 i = k, n
335 rwork( i ) = rwork( i ) +
336 $ cabs1( ap( kc+i-k ) )*xk
337 70 CONTINUE
338 kc = kc + n - k + 1
339 80 CONTINUE
340 ELSE
341 DO 100 k = 1, n
342 xk = cabs1( x( k, j ) )
343 DO 90 i = k + 1, n
344 rwork( i ) = rwork( i ) +
345 $ cabs1( ap( kc+i-k ) )*xk
346 90 CONTINUE
347 rwork( k ) = rwork( k ) + xk
348 kc = kc + n - k + 1
349 100 CONTINUE
350 END IF
351 END IF
352 ELSE
353*
354* Compute abs(A**H)*abs(X) + abs(B).
355*
356 IF( upper ) THEN
357 kc = 1
358 IF( nounit ) THEN
359 DO 120 k = 1, n
360 s = zero
361 DO 110 i = 1, k
362 s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
363 110 CONTINUE
364 rwork( k ) = rwork( k ) + s
365 kc = kc + k
366 120 CONTINUE
367 ELSE
368 DO 140 k = 1, n
369 s = cabs1( x( k, j ) )
370 DO 130 i = 1, k - 1
371 s = s + cabs1( ap( kc+i-1 ) )*cabs1( x( i, j ) )
372 130 CONTINUE
373 rwork( k ) = rwork( k ) + s
374 kc = kc + k
375 140 CONTINUE
376 END IF
377 ELSE
378 kc = 1
379 IF( nounit ) THEN
380 DO 160 k = 1, n
381 s = zero
382 DO 150 i = k, n
383 s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
384 150 CONTINUE
385 rwork( k ) = rwork( k ) + s
386 kc = kc + n - k + 1
387 160 CONTINUE
388 ELSE
389 DO 180 k = 1, n
390 s = cabs1( x( k, j ) )
391 DO 170 i = k + 1, n
392 s = s + cabs1( ap( kc+i-k ) )*cabs1( x( i, j ) )
393 170 CONTINUE
394 rwork( k ) = rwork( k ) + s
395 kc = kc + n - k + 1
396 180 CONTINUE
397 END IF
398 END IF
399 END IF
400 s = zero
401 DO 190 i = 1, n
402 IF( rwork( i ).GT.safe2 ) THEN
403 s = max( s, cabs1( work( i ) ) / rwork( i ) )
404 ELSE
405 s = max( s, ( cabs1( work( i ) )+safe1 ) /
406 $ ( rwork( i )+safe1 ) )
407 END IF
408 190 CONTINUE
409 berr( j ) = s
410*
411* Bound error from formula
412*
413* norm(X - XTRUE) / norm(X) .le. FERR =
414* norm( abs(inv(op(A)))*
415* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
416*
417* where
418* norm(Z) is the magnitude of the largest component of Z
419* inv(op(A)) is the inverse of op(A)
420* abs(Z) is the componentwise absolute value of the matrix or
421* vector Z
422* NZ is the maximum number of nonzeros in any row of A, plus 1
423* EPS is machine epsilon
424*
425* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
426* is incremented by SAFE1 if the i-th component of
427* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
428*
429* Use ZLACN2 to estimate the infinity-norm of the matrix
430* inv(op(A)) * diag(W),
431* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
432*
433 DO 200 i = 1, n
434 IF( rwork( i ).GT.safe2 ) THEN
435 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
436 ELSE
437 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
438 $ safe1
439 END IF
440 200 CONTINUE
441*
442 kase = 0
443 210 CONTINUE
444 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
445 IF( kase.NE.0 ) THEN
446 IF( kase.EQ.1 ) THEN
447*
448* Multiply by diag(W)*inv(op(A)**H).
449*
450 CALL ztpsv( uplo, transt, diag, n, ap, work, 1 )
451 DO 220 i = 1, n
452 work( i ) = rwork( i )*work( i )
453 220 CONTINUE
454 ELSE
455*
456* Multiply by inv(op(A))*diag(W).
457*
458 DO 230 i = 1, n
459 work( i ) = rwork( i )*work( i )
460 230 CONTINUE
461 CALL ztpsv( uplo, transn, diag, n, ap, work, 1 )
462 END IF
463 GO TO 210
464 END IF
465*
466* Normalize error.
467*
468 lstres = zero
469 DO 240 i = 1, n
470 lstres = max( lstres, cabs1( x( i, j ) ) )
471 240 CONTINUE
472 IF( lstres.NE.zero )
473 $ ferr( j ) = ferr( j ) / lstres
474*
475 250 CONTINUE
476*
477 RETURN
478*
479* End of ZTPRFS
480*

◆ ztptri()

subroutine ztptri ( character uplo,
character diag,
integer n,
complex*16, dimension( * ) ap,
integer info )

ZTPTRI

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

Purpose:
!>
!> ZTPTRI computes the inverse of a complex upper or lower triangular
!> matrix A stored in packed format.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit 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 triangular matrix A, stored
!>          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)*((2*n-j)/2) = A(i,j) for j<=i<=n.
!>          See below for further details.
!>          On exit, the (triangular) inverse of the original matrix, in
!>          the same packed storage format.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, A(i,i) is exactly zero.  The triangular
!>                matrix is singular and its inverse can not be computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  A triangular matrix A can be transferred to packed storage using one
!>  of the following program segments:
!>
!>  UPLO = 'U':                      UPLO = 'L':
!>
!>        JC = 1                           JC = 1
!>        DO 2 J = 1, N                    DO 2 J = 1, N
!>           DO 1 I = 1, J                    DO 1 I = J, N
!>              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)
!>      1    CONTINUE                    1    CONTINUE
!>           JC = JC + J                      JC = JC + N - J + 1
!>      2 CONTINUE                       2 CONTINUE
!>

Definition at line 116 of file ztptri.f.

117*
118* -- LAPACK computational routine --
119* -- LAPACK is a software package provided by Univ. of Tennessee, --
120* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
121*
122* .. Scalar Arguments ..
123 CHARACTER DIAG, UPLO
124 INTEGER INFO, N
125* ..
126* .. Array Arguments ..
127 COMPLEX*16 AP( * )
128* ..
129*
130* =====================================================================
131*
132* .. Parameters ..
133 COMPLEX*16 ONE, ZERO
134 parameter( one = ( 1.0d+0, 0.0d+0 ),
135 $ zero = ( 0.0d+0, 0.0d+0 ) )
136* ..
137* .. Local Scalars ..
138 LOGICAL NOUNIT, UPPER
139 INTEGER J, JC, JCLAST, JJ
140 COMPLEX*16 AJJ
141* ..
142* .. External Functions ..
143 LOGICAL LSAME
144 EXTERNAL lsame
145* ..
146* .. External Subroutines ..
147 EXTERNAL xerbla, zscal, ztpmv
148* ..
149* .. Executable Statements ..
150*
151* Test the input parameters.
152*
153 info = 0
154 upper = lsame( uplo, 'U' )
155 nounit = lsame( diag, 'N' )
156 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
157 info = -1
158 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
159 info = -2
160 ELSE IF( n.LT.0 ) THEN
161 info = -3
162 END IF
163 IF( info.NE.0 ) THEN
164 CALL xerbla( 'ZTPTRI', -info )
165 RETURN
166 END IF
167*
168* Check for singularity if non-unit.
169*
170 IF( nounit ) THEN
171 IF( upper ) THEN
172 jj = 0
173 DO 10 info = 1, n
174 jj = jj + info
175 IF( ap( jj ).EQ.zero )
176 $ RETURN
177 10 CONTINUE
178 ELSE
179 jj = 1
180 DO 20 info = 1, n
181 IF( ap( jj ).EQ.zero )
182 $ RETURN
183 jj = jj + n - info + 1
184 20 CONTINUE
185 END IF
186 info = 0
187 END IF
188*
189 IF( upper ) THEN
190*
191* Compute inverse of upper triangular matrix.
192*
193 jc = 1
194 DO 30 j = 1, n
195 IF( nounit ) THEN
196 ap( jc+j-1 ) = one / ap( jc+j-1 )
197 ajj = -ap( jc+j-1 )
198 ELSE
199 ajj = -one
200 END IF
201*
202* Compute elements 1:j-1 of j-th column.
203*
204 CALL ztpmv( 'Upper', 'No transpose', diag, j-1, ap,
205 $ ap( jc ), 1 )
206 CALL zscal( j-1, ajj, ap( jc ), 1 )
207 jc = jc + j
208 30 CONTINUE
209*
210 ELSE
211*
212* Compute inverse of lower triangular matrix.
213*
214 jc = n*( n+1 ) / 2
215 DO 40 j = n, 1, -1
216 IF( nounit ) THEN
217 ap( jc ) = one / ap( jc )
218 ajj = -ap( jc )
219 ELSE
220 ajj = -one
221 END IF
222 IF( j.LT.n ) THEN
223*
224* Compute elements j+1:n of j-th column.
225*
226 CALL ztpmv( 'Lower', 'No transpose', diag, n-j,
227 $ ap( jclast ), ap( jc+1 ), 1 )
228 CALL zscal( n-j, ajj, ap( jc+1 ), 1 )
229 END IF
230 jclast = jc
231 jc = jc - n + j - 2
232 40 CONTINUE
233 END IF
234*
235 RETURN
236*
237* End of ZTPTRI
238*

◆ ztptrs()

subroutine ztptrs ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZTPTRS

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

Purpose:
!>
!> ZTPTRS solves a triangular system of the form
!>
!>    A * X = B,  A**T * X = B,  or  A**H * X = B,
!>
!> where A is a triangular matrix of order N stored in packed format,
!> and B is an N-by-NRHS matrix.  A check is made to verify that A is
!> nonsingular.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[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 matrix B.  NRHS >= 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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, if INFO = 0, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the i-th diagonal element of A is zero,
!>                indicating that the matrix is singular and the
!>                solutions X have not been computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file ztptrs.f.

130*
131* -- LAPACK computational 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 DIAG, TRANS, UPLO
137 INTEGER INFO, LDB, N, NRHS
138* ..
139* .. Array Arguments ..
140 COMPLEX*16 AP( * ), B( LDB, * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 COMPLEX*16 ZERO
147 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
148* ..
149* .. Local Scalars ..
150 LOGICAL NOUNIT, UPPER
151 INTEGER J, JC
152* ..
153* .. External Functions ..
154 LOGICAL LSAME
155 EXTERNAL lsame
156* ..
157* .. External Subroutines ..
158 EXTERNAL xerbla, ztpsv
159* ..
160* .. Intrinsic Functions ..
161 INTRINSIC max
162* ..
163* .. Executable Statements ..
164*
165* Test the input parameters.
166*
167 info = 0
168 upper = lsame( uplo, 'U' )
169 nounit = lsame( diag, 'N' )
170 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
171 info = -1
172 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.
173 $ lsame( trans, 'T' ) .AND. .NOT.lsame( trans, 'C' ) ) THEN
174 info = -2
175 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
176 info = -3
177 ELSE IF( n.LT.0 ) THEN
178 info = -4
179 ELSE IF( nrhs.LT.0 ) THEN
180 info = -5
181 ELSE IF( ldb.LT.max( 1, n ) ) THEN
182 info = -8
183 END IF
184 IF( info.NE.0 ) THEN
185 CALL xerbla( 'ZTPTRS', -info )
186 RETURN
187 END IF
188*
189* Quick return if possible
190*
191 IF( n.EQ.0 )
192 $ RETURN
193*
194* Check for singularity.
195*
196 IF( nounit ) THEN
197 IF( upper ) THEN
198 jc = 1
199 DO 10 info = 1, n
200 IF( ap( jc+info-1 ).EQ.zero )
201 $ RETURN
202 jc = jc + info
203 10 CONTINUE
204 ELSE
205 jc = 1
206 DO 20 info = 1, n
207 IF( ap( jc ).EQ.zero )
208 $ RETURN
209 jc = jc + n - info + 1
210 20 CONTINUE
211 END IF
212 END IF
213 info = 0
214*
215* Solve A * x = b, A**T * x = b, or A**H * x = b.
216*
217 DO 30 j = 1, nrhs
218 CALL ztpsv( uplo, trans, diag, n, ap, b( 1, j ), 1 )
219 30 CONTINUE
220*
221 RETURN
222*
223* End of ZTPTRS
224*

◆ ztpttf()

subroutine ztpttf ( character transr,
character uplo,
integer n,
complex*16, dimension( 0: * ) ap,
complex*16, dimension( 0: * ) arf,
integer info )

ZTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed format (TF).

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

Purpose:
!>
!> ZTPTTF copies a triangular matrix A from standard packed format (TP)
!> to rectangular full packed format (TF).
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  ARF in Normal format is wanted;
!>          = 'C':  ARF in Conjugate-transpose format is wanted.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[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 ),
!>          On entry, 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.
!>
[out]ARF
!>          ARF is COMPLEX*16 array, dimension ( N*(N+1)/2 ),
!>          On exit, the upper or lower triangular matrix A stored in
!>          RFP format. For a further discussion see Notes below.
!>
[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.
Further Details:
!>
!>  We first consider Standard Packed Format when N is even.
!>  We give an example where N = 6.
!>
!>      AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  conjugate-transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  conjugate-transpose of the last three columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                -- -- --
!>        03 04 05                33 43 53
!>                                   -- --
!>        13 14 15                00 44 54
!>                                      --
!>        23 24 25                10 11 55
!>
!>        33 34 35                20 21 22
!>        --
!>        00 44 45                30 31 32
!>        -- --
!>        01 11 55                40 41 42
!>        -- -- --
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- -- --                -- -- -- -- -- --
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     -- -- -- -- --                -- -- -- -- --
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     -- -- -- -- -- --                -- -- -- --
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>
!>  We next  consider Standard Packed Format when N is odd.
!>  We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  conjugate-transpose of the first two   columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  conjugate-transpose of the last two   columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N odd  and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                   -- --
!>        02 03 04                00 33 43
!>                                      --
!>        12 13 14                10 11 44
!>
!>        22 23 24                20 21 22
!>        --
!>        00 33 34                30 31 32
!>        -- --
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- --                   -- -- -- -- -- --
!>     02 12 22 00 01             00 10 20 30 40 50
!>     -- -- -- --                   -- -- -- -- --
!>     03 13 23 33 11             33 11 21 31 41 51
!>     -- -- -- -- --                   -- -- -- --
!>     04 14 24 34 44             43 44 22 32 42 52
!>

Definition at line 206 of file ztpttf.f.

207*
208* -- LAPACK computational routine --
209* -- LAPACK is a software package provided by Univ. of Tennessee, --
210* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
211*
212* .. Scalar Arguments ..
213 CHARACTER TRANSR, UPLO
214 INTEGER INFO, N
215* ..
216* .. Array Arguments ..
217 COMPLEX*16 AP( 0: * ), ARF( 0: * )
218*
219* =====================================================================
220*
221* .. Parameters ..
222* ..
223* .. Local Scalars ..
224 LOGICAL LOWER, NISODD, NORMALTRANSR
225 INTEGER N1, N2, K, NT
226 INTEGER I, J, IJ
227 INTEGER IJP, JP, LDA, JS
228* ..
229* .. External Functions ..
230 LOGICAL LSAME
231 EXTERNAL lsame
232* ..
233* .. External Subroutines ..
234 EXTERNAL xerbla
235* ..
236* .. Intrinsic Functions ..
237 INTRINSIC dconjg, mod
238* ..
239* .. Executable Statements ..
240*
241* Test the input parameters.
242*
243 info = 0
244 normaltransr = lsame( transr, 'N' )
245 lower = lsame( uplo, 'L' )
246 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
247 info = -1
248 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
249 info = -2
250 ELSE IF( n.LT.0 ) THEN
251 info = -3
252 END IF
253 IF( info.NE.0 ) THEN
254 CALL xerbla( 'ZTPTTF', -info )
255 RETURN
256 END IF
257*
258* Quick return if possible
259*
260 IF( n.EQ.0 )
261 $ RETURN
262*
263 IF( n.EQ.1 ) THEN
264 IF( normaltransr ) THEN
265 arf( 0 ) = ap( 0 )
266 ELSE
267 arf( 0 ) = dconjg( ap( 0 ) )
268 END IF
269 RETURN
270 END IF
271*
272* Size of array ARF(0:NT-1)
273*
274 nt = n*( n+1 ) / 2
275*
276* Set N1 and N2 depending on LOWER
277*
278 IF( lower ) THEN
279 n2 = n / 2
280 n1 = n - n2
281 ELSE
282 n1 = n / 2
283 n2 = n - n1
284 END IF
285*
286* If N is odd, set NISODD = .TRUE.
287* If N is even, set K = N/2 and NISODD = .FALSE.
288*
289* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe)
290* where noe = 0 if n is even, noe = 1 if n is odd
291*
292 IF( mod( n, 2 ).EQ.0 ) THEN
293 k = n / 2
294 nisodd = .false.
295 lda = n + 1
296 ELSE
297 nisodd = .true.
298 lda = n
299 END IF
300*
301* ARF^C has lda rows and n+1-noe cols
302*
303 IF( .NOT.normaltransr )
304 $ lda = ( n+1 ) / 2
305*
306* start execution: there are eight cases
307*
308 IF( nisodd ) THEN
309*
310* N is odd
311*
312 IF( normaltransr ) THEN
313*
314* N is odd and TRANSR = 'N'
315*
316 IF( lower ) THEN
317*
318* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) )
319* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0)
320* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n
321*
322 ijp = 0
323 jp = 0
324 DO j = 0, n2
325 DO i = j, n - 1
326 ij = i + jp
327 arf( ij ) = ap( ijp )
328 ijp = ijp + 1
329 END DO
330 jp = jp + lda
331 END DO
332 DO i = 0, n2 - 1
333 DO j = 1 + i, n2
334 ij = i + j*lda
335 arf( ij ) = dconjg( ap( ijp ) )
336 ijp = ijp + 1
337 END DO
338 END DO
339*
340 ELSE
341*
342* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1)
343* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0)
344* T1 -> a(n2), T2 -> a(n1), S -> a(0)
345*
346 ijp = 0
347 DO j = 0, n1 - 1
348 ij = n2 + j
349 DO i = 0, j
350 arf( ij ) = dconjg( ap( ijp ) )
351 ijp = ijp + 1
352 ij = ij + lda
353 END DO
354 END DO
355 js = 0
356 DO j = n1, n - 1
357 ij = js
358 DO ij = js, js + j
359 arf( ij ) = ap( ijp )
360 ijp = ijp + 1
361 END DO
362 js = js + lda
363 END DO
364*
365 END IF
366*
367 ELSE
368*
369* N is odd and TRANSR = 'C'
370*
371 IF( lower ) THEN
372*
373* SRPA for LOWER, TRANSPOSE and N is odd
374* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1)
375* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1
376*
377 ijp = 0
378 DO i = 0, n2
379 DO ij = i*( lda+1 ), n*lda - 1, lda
380 arf( ij ) = dconjg( ap( ijp ) )
381 ijp = ijp + 1
382 END DO
383 END DO
384 js = 1
385 DO j = 0, n2 - 1
386 DO ij = js, js + n2 - j - 1
387 arf( ij ) = ap( ijp )
388 ijp = ijp + 1
389 END DO
390 js = js + lda + 1
391 END DO
392*
393 ELSE
394*
395* SRPA for UPPER, TRANSPOSE and N is odd
396* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0)
397* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2
398*
399 ijp = 0
400 js = n2*lda
401 DO j = 0, n1 - 1
402 DO ij = js, js + j
403 arf( ij ) = ap( ijp )
404 ijp = ijp + 1
405 END DO
406 js = js + lda
407 END DO
408 DO i = 0, n1
409 DO ij = i, i + ( n1+i )*lda, lda
410 arf( ij ) = dconjg( ap( ijp ) )
411 ijp = ijp + 1
412 END DO
413 END DO
414*
415 END IF
416*
417 END IF
418*
419 ELSE
420*
421* N is even
422*
423 IF( normaltransr ) THEN
424*
425* N is even and TRANSR = 'N'
426*
427 IF( lower ) THEN
428*
429* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) )
430* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0)
431* T1 -> a(1), T2 -> a(0), S -> a(k+1)
432*
433 ijp = 0
434 jp = 0
435 DO j = 0, k - 1
436 DO i = j, n - 1
437 ij = 1 + i + jp
438 arf( ij ) = ap( ijp )
439 ijp = ijp + 1
440 END DO
441 jp = jp + lda
442 END DO
443 DO i = 0, k - 1
444 DO j = i, k - 1
445 ij = i + j*lda
446 arf( ij ) = dconjg( ap( ijp ) )
447 ijp = ijp + 1
448 END DO
449 END DO
450*
451 ELSE
452*
453* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) )
454* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0)
455* T1 -> a(k+1), T2 -> a(k), S -> a(0)
456*
457 ijp = 0
458 DO j = 0, k - 1
459 ij = k + 1 + j
460 DO i = 0, j
461 arf( ij ) = dconjg( ap( ijp ) )
462 ijp = ijp + 1
463 ij = ij + lda
464 END DO
465 END DO
466 js = 0
467 DO j = k, n - 1
468 ij = js
469 DO ij = js, js + j
470 arf( ij ) = ap( ijp )
471 ijp = ijp + 1
472 END DO
473 js = js + lda
474 END DO
475*
476 END IF
477*
478 ELSE
479*
480* N is even and TRANSR = 'C'
481*
482 IF( lower ) THEN
483*
484* SRPA for LOWER, TRANSPOSE and N is even (see paper)
485* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1)
486* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k
487*
488 ijp = 0
489 DO i = 0, k - 1
490 DO ij = i + ( i+1 )*lda, ( n+1 )*lda - 1, lda
491 arf( ij ) = dconjg( ap( ijp ) )
492 ijp = ijp + 1
493 END DO
494 END DO
495 js = 0
496 DO j = 0, k - 1
497 DO ij = js, js + k - j - 1
498 arf( ij ) = ap( ijp )
499 ijp = ijp + 1
500 END DO
501 js = js + lda + 1
502 END DO
503*
504 ELSE
505*
506* SRPA for UPPER, TRANSPOSE and N is even (see paper)
507* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0)
508* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k
509*
510 ijp = 0
511 js = ( k+1 )*lda
512 DO j = 0, k - 1
513 DO ij = js, js + j
514 arf( ij ) = ap( ijp )
515 ijp = ijp + 1
516 END DO
517 js = js + lda
518 END DO
519 DO i = 0, k - 1
520 DO ij = i, i + ( k+i )*lda, lda
521 arf( ij ) = dconjg( ap( ijp ) )
522 ijp = ijp + 1
523 END DO
524 END DO
525*
526 END IF
527*
528 END IF
529*
530 END IF
531*
532 RETURN
533*
534* End of ZTPTTF
535*

◆ ztpttr()

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

ZTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (TR).

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

Purpose:
!>
!> ZTPTTR copies a triangular matrix A from standard packed format (TP)
!> to standard full format (TR).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular.
!>          = 'L':  A is lower triangular.
!>
[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 ),
!>          On entry, 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.
!>
[out]A
!>          A is COMPLEX*16 array, dimension ( LDA, N )
!>          On exit, the triangular 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.
!>
[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 = -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 103 of file ztpttr.f.

104*
105* -- LAPACK computational 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 INFO, N, LDA
112* ..
113* .. Array Arguments ..
114 COMPLEX*16 A( LDA, * ), AP( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120* ..
121* .. Local Scalars ..
122 LOGICAL LOWER
123 INTEGER I, J, K
124* ..
125* .. External Functions ..
126 LOGICAL LSAME
127 EXTERNAL lsame
128* ..
129* .. External Subroutines ..
130 EXTERNAL xerbla
131* ..
132* .. Executable Statements ..
133*
134* Test the input parameters.
135*
136 info = 0
137 lower = lsame( uplo, 'L' )
138 IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
139 info = -1
140 ELSE IF( n.LT.0 ) THEN
141 info = -2
142 ELSE IF( lda.LT.max( 1, n ) ) THEN
143 info = -5
144 END IF
145 IF( info.NE.0 ) THEN
146 CALL xerbla( 'ZTPTTR', -info )
147 RETURN
148 END IF
149*
150 IF( lower ) THEN
151 k = 0
152 DO j = 1, n
153 DO i = j, n
154 k = k + 1
155 a( i, j ) = ap( k )
156 END DO
157 END DO
158 ELSE
159 k = 0
160 DO j = 1, n
161 DO i = 1, j
162 k = k + 1
163 a( i, j ) = ap( k )
164 END DO
165 END DO
166 END IF
167*
168*
169 RETURN
170*
171* End of ZTPTTR
172*

◆ ztrcon()

subroutine ztrcon ( character norm,
character uplo,
character diag,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision rcond,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZTRCON

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

Purpose:
!>
!> ZTRCON estimates the reciprocal of the condition number of a
!> triangular matrix A, in either the 1-norm or the infinity-norm.
!>
!> The norm of A is computed and an estimate is obtained for
!> norm(inv(A)), then the reciprocal of the condition number is
!> computed as
!>    RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies whether the 1-norm condition number or the
!>          infinity-norm condition number is required:
!>          = '1' or 'O':  1-norm;
!>          = 'I':         Infinity-norm.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[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).
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 135 of file ztrcon.f.

137*
138* -- LAPACK computational routine --
139* -- LAPACK is a software package provided by Univ. of Tennessee, --
140* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
141*
142* .. Scalar Arguments ..
143 CHARACTER DIAG, NORM, UPLO
144 INTEGER INFO, LDA, N
145 DOUBLE PRECISION RCOND
146* ..
147* .. Array Arguments ..
148 DOUBLE PRECISION RWORK( * )
149 COMPLEX*16 A( LDA, * ), WORK( * )
150* ..
151*
152* =====================================================================
153*
154* .. Parameters ..
155 DOUBLE PRECISION ONE, ZERO
156 parameter( one = 1.0d+0, zero = 0.0d+0 )
157* ..
158* .. Local Scalars ..
159 LOGICAL NOUNIT, ONENRM, UPPER
160 CHARACTER NORMIN
161 INTEGER IX, KASE, KASE1
162 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
163 COMPLEX*16 ZDUM
164* ..
165* .. Local Arrays ..
166 INTEGER ISAVE( 3 )
167* ..
168* .. External Functions ..
169 LOGICAL LSAME
170 INTEGER IZAMAX
171 DOUBLE PRECISION DLAMCH, ZLANTR
172 EXTERNAL lsame, izamax, dlamch, zlantr
173* ..
174* .. External Subroutines ..
175 EXTERNAL xerbla, zdrscl, zlacn2, zlatrs
176* ..
177* .. Intrinsic Functions ..
178 INTRINSIC abs, dble, dimag, max
179* ..
180* .. Statement Functions ..
181 DOUBLE PRECISION CABS1
182* ..
183* .. Statement Function definitions ..
184 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
185* ..
186* .. Executable Statements ..
187*
188* Test the input parameters.
189*
190 info = 0
191 upper = lsame( uplo, 'U' )
192 onenrm = norm.EQ.'1' .OR. lsame( norm, 'O' )
193 nounit = lsame( diag, 'N' )
194*
195 IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN
196 info = -1
197 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
198 info = -2
199 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
200 info = -3
201 ELSE IF( n.LT.0 ) THEN
202 info = -4
203 ELSE IF( lda.LT.max( 1, n ) ) THEN
204 info = -6
205 END IF
206 IF( info.NE.0 ) THEN
207 CALL xerbla( 'ZTRCON', -info )
208 RETURN
209 END IF
210*
211* Quick return if possible
212*
213 IF( n.EQ.0 ) THEN
214 rcond = one
215 RETURN
216 END IF
217*
218 rcond = zero
219 smlnum = dlamch( 'Safe minimum' )*dble( max( 1, n ) )
220*
221* Compute the norm of the triangular matrix A.
222*
223 anorm = zlantr( norm, uplo, diag, n, n, a, lda, rwork )
224*
225* Continue only if ANORM > 0.
226*
227 IF( anorm.GT.zero ) THEN
228*
229* Estimate the norm of the inverse of A.
230*
231 ainvnm = zero
232 normin = 'N'
233 IF( onenrm ) THEN
234 kase1 = 1
235 ELSE
236 kase1 = 2
237 END IF
238 kase = 0
239 10 CONTINUE
240 CALL zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
241 IF( kase.NE.0 ) THEN
242 IF( kase.EQ.kase1 ) THEN
243*
244* Multiply by inv(A).
245*
246 CALL zlatrs( uplo, 'No transpose', diag, normin, n, a,
247 $ lda, work, scale, rwork, info )
248 ELSE
249*
250* Multiply by inv(A**H).
251*
252 CALL zlatrs( uplo, 'Conjugate transpose', diag, normin,
253 $ n, a, lda, work, scale, rwork, info )
254 END IF
255 normin = 'Y'
256*
257* Multiply by 1/SCALE if doing so will not cause overflow.
258*
259 IF( scale.NE.one ) THEN
260 ix = izamax( n, work, 1 )
261 xnorm = cabs1( work( ix ) )
262 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
263 $ GO TO 20
264 CALL zdrscl( n, scale, work, 1 )
265 END IF
266 GO TO 10
267 END IF
268*
269* Compute the estimate of the reciprocal condition number.
270*
271 IF( ainvnm.NE.zero )
272 $ rcond = ( one / anorm ) / ainvnm
273 END IF
274*
275 20 CONTINUE
276 RETURN
277*
278* End of ZTRCON
279*
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
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

◆ ztrevc()

subroutine ztrevc ( character side,
character howmny,
logical, dimension( * ) select,
integer n,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( ldvl, * ) vl,
integer ldvl,
complex*16, dimension( ldvr, * ) vr,
integer ldvr,
integer mm,
integer m,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZTREVC

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

Purpose:
!>
!> ZTREVC computes some or all of the right and/or left eigenvectors of
!> a complex upper triangular matrix T.
!> Matrices of this type are produced by the Schur factorization of
!> a complex general matrix:  A = Q*T*Q**H, as computed by ZHSEQR.
!>
!> The right eigenvector x and the left eigenvector y of T corresponding
!> to an eigenvalue w are defined by:
!>
!>              T*x = w*x,     (y**H)*T = w*(y**H)
!>
!> where y**H denotes the conjugate transpose of the vector y.
!> The eigenvalues are not input to this routine, but are read directly
!> from the diagonal of T.
!>
!> This routine returns the matrices X and/or Y of right and left
!> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!> input matrix.  If Q is the unitary factor that reduces a matrix A to
!> Schur form T, then Q*X and Q*Y are the matrices of right and left
!> eigenvectors of A.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'R':  compute right eigenvectors only;
!>          = 'L':  compute left eigenvectors only;
!>          = 'B':  compute both right and left eigenvectors.
!>
[in]HOWMNY
!>          HOWMNY is CHARACTER*1
!>          = 'A':  compute all right and/or left eigenvectors;
!>          = 'B':  compute all right and/or left eigenvectors,
!>                  backtransformed using the matrices supplied in
!>                  VR and/or VL;
!>          = 'S':  compute selected right and/or left eigenvectors,
!>                  as indicated by the logical array SELECT.
!>
[in]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
!>          computed.
!>          The eigenvector corresponding to the j-th eigenvalue is
!>          computed if SELECT(j) = .TRUE..
!>          Not referenced if HOWMNY = 'A' or 'B'.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!>
[in,out]T
!>          T is COMPLEX*16 array, dimension (LDT,N)
!>          The upper triangular matrix T.  T is modified, but restored
!>          on exit.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in,out]VL
!>          VL is COMPLEX*16 array, dimension (LDVL,MM)
!>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
!>          contain an N-by-N matrix Q (usually the unitary matrix Q of
!>          Schur vectors returned by ZHSEQR).
!>          On exit, if SIDE = 'L' or 'B', VL contains:
!>          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
!>          if HOWMNY = 'B', the matrix Q*Y;
!>          if HOWMNY = 'S', the left eigenvectors of T specified by
!>                           SELECT, stored consecutively in the columns
!>                           of VL, in the same order as their
!>                           eigenvalues.
!>          Not referenced if SIDE = 'R'.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          The leading dimension of the array VL.  LDVL >= 1, and if
!>          SIDE = 'L' or 'B', LDVL >= N.
!>
[in,out]VR
!>          VR is COMPLEX*16 array, dimension (LDVR,MM)
!>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
!>          contain an N-by-N matrix Q (usually the unitary matrix Q of
!>          Schur vectors returned by ZHSEQR).
!>          On exit, if SIDE = 'R' or 'B', VR contains:
!>          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
!>          if HOWMNY = 'B', the matrix Q*X;
!>          if HOWMNY = 'S', the right eigenvectors of T specified by
!>                           SELECT, stored consecutively in the columns
!>                           of VR, in the same order as their
!>                           eigenvalues.
!>          Not referenced if SIDE = 'L'.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.  LDVR >= 1, and if
!>          SIDE = 'R' or 'B'; LDVR >= N.
!>
[in]MM
!>          MM is INTEGER
!>          The number of columns in the arrays VL and/or VR. MM >= M.
!>
[out]M
!>          M is INTEGER
!>          The number of columns in the arrays VL and/or VR actually
!>          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
!>          is set to N.  Each selected eigenvector occupies one
!>          column.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The algorithm used in this program is basically backward (forward)
!>  substitution, with scaling to make the the code robust against
!>  possible overflow.
!>
!>  Each eigenvector is normalized so that the element of largest
!>  magnitude has magnitude 1; here the magnitude of a complex number
!>  (x,y) is taken to be |x| + |y|.
!>

Definition at line 216 of file ztrevc.f.

218*
219* -- LAPACK computational routine --
220* -- LAPACK is a software package provided by Univ. of Tennessee, --
221* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
222*
223* .. Scalar Arguments ..
224 CHARACTER HOWMNY, SIDE
225 INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
226* ..
227* .. Array Arguments ..
228 LOGICAL SELECT( * )
229 DOUBLE PRECISION RWORK( * )
230 COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
231 $ WORK( * )
232* ..
233*
234* =====================================================================
235*
236* .. Parameters ..
237 DOUBLE PRECISION ZERO, ONE
238 parameter( zero = 0.0d+0, one = 1.0d+0 )
239 COMPLEX*16 CMZERO, CMONE
240 parameter( cmzero = ( 0.0d+0, 0.0d+0 ),
241 $ cmone = ( 1.0d+0, 0.0d+0 ) )
242* ..
243* .. Local Scalars ..
244 LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
245 INTEGER I, II, IS, J, K, KI
246 DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
247 COMPLEX*16 CDUM
248* ..
249* .. External Functions ..
250 LOGICAL LSAME
251 INTEGER IZAMAX
252 DOUBLE PRECISION DLAMCH, DZASUM
253 EXTERNAL lsame, izamax, dlamch, dzasum
254* ..
255* .. External Subroutines ..
256 EXTERNAL xerbla, zcopy, zdscal, zgemv, zlatrs, dlabad
257* ..
258* .. Intrinsic Functions ..
259 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max
260* ..
261* .. Statement Functions ..
262 DOUBLE PRECISION CABS1
263* ..
264* .. Statement Function definitions ..
265 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
266* ..
267* .. Executable Statements ..
268*
269* Decode and test the input parameters
270*
271 bothv = lsame( side, 'B' )
272 rightv = lsame( side, 'R' ) .OR. bothv
273 leftv = lsame( side, 'L' ) .OR. bothv
274*
275 allv = lsame( howmny, 'A' )
276 over = lsame( howmny, 'B' )
277 somev = lsame( howmny, 'S' )
278*
279* Set M to the number of columns required to store the selected
280* eigenvectors.
281*
282 IF( somev ) THEN
283 m = 0
284 DO 10 j = 1, n
285 IF( SELECT( j ) )
286 $ m = m + 1
287 10 CONTINUE
288 ELSE
289 m = n
290 END IF
291*
292 info = 0
293 IF( .NOT.rightv .AND. .NOT.leftv ) THEN
294 info = -1
295 ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN
296 info = -2
297 ELSE IF( n.LT.0 ) THEN
298 info = -4
299 ELSE IF( ldt.LT.max( 1, n ) ) THEN
300 info = -6
301 ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN
302 info = -8
303 ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN
304 info = -10
305 ELSE IF( mm.LT.m ) THEN
306 info = -11
307 END IF
308 IF( info.NE.0 ) THEN
309 CALL xerbla( 'ZTREVC', -info )
310 RETURN
311 END IF
312*
313* Quick return if possible.
314*
315 IF( n.EQ.0 )
316 $ RETURN
317*
318* Set the constants to control overflow.
319*
320 unfl = dlamch( 'Safe minimum' )
321 ovfl = one / unfl
322 CALL dlabad( unfl, ovfl )
323 ulp = dlamch( 'Precision' )
324 smlnum = unfl*( n / ulp )
325*
326* Store the diagonal elements of T in working array WORK.
327*
328 DO 20 i = 1, n
329 work( i+n ) = t( i, i )
330 20 CONTINUE
331*
332* Compute 1-norm of each column of strictly upper triangular
333* part of T to control overflow in triangular solver.
334*
335 rwork( 1 ) = zero
336 DO 30 j = 2, n
337 rwork( j ) = dzasum( j-1, t( 1, j ), 1 )
338 30 CONTINUE
339*
340 IF( rightv ) THEN
341*
342* Compute right eigenvectors.
343*
344 is = m
345 DO 80 ki = n, 1, -1
346*
347 IF( somev ) THEN
348 IF( .NOT.SELECT( ki ) )
349 $ GO TO 80
350 END IF
351 smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
352*
353 work( 1 ) = cmone
354*
355* Form right-hand side.
356*
357 DO 40 k = 1, ki - 1
358 work( k ) = -t( k, ki )
359 40 CONTINUE
360*
361* Solve the triangular system:
362* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK.
363*
364 DO 50 k = 1, ki - 1
365 t( k, k ) = t( k, k ) - t( ki, ki )
366 IF( cabs1( t( k, k ) ).LT.smin )
367 $ t( k, k ) = smin
368 50 CONTINUE
369*
370 IF( ki.GT.1 ) THEN
371 CALL zlatrs( 'Upper', 'No transpose', 'Non-unit', 'Y',
372 $ ki-1, t, ldt, work( 1 ), scale, rwork,
373 $ info )
374 work( ki ) = scale
375 END IF
376*
377* Copy the vector x or Q*x to VR and normalize.
378*
379 IF( .NOT.over ) THEN
380 CALL zcopy( ki, work( 1 ), 1, vr( 1, is ), 1 )
381*
382 ii = izamax( ki, vr( 1, is ), 1 )
383 remax = one / cabs1( vr( ii, is ) )
384 CALL zdscal( ki, remax, vr( 1, is ), 1 )
385*
386 DO 60 k = ki + 1, n
387 vr( k, is ) = cmzero
388 60 CONTINUE
389 ELSE
390 IF( ki.GT.1 )
391 $ CALL zgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1 ),
392 $ 1, dcmplx( scale ), vr( 1, ki ), 1 )
393*
394 ii = izamax( n, vr( 1, ki ), 1 )
395 remax = one / cabs1( vr( ii, ki ) )
396 CALL zdscal( n, remax, vr( 1, ki ), 1 )
397 END IF
398*
399* Set back the original diagonal elements of T.
400*
401 DO 70 k = 1, ki - 1
402 t( k, k ) = work( k+n )
403 70 CONTINUE
404*
405 is = is - 1
406 80 CONTINUE
407 END IF
408*
409 IF( leftv ) THEN
410*
411* Compute left eigenvectors.
412*
413 is = 1
414 DO 130 ki = 1, n
415*
416 IF( somev ) THEN
417 IF( .NOT.SELECT( ki ) )
418 $ GO TO 130
419 END IF
420 smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
421*
422 work( n ) = cmone
423*
424* Form right-hand side.
425*
426 DO 90 k = ki + 1, n
427 work( k ) = -dconjg( t( ki, k ) )
428 90 CONTINUE
429*
430* Solve the triangular system:
431* (T(KI+1:N,KI+1:N) - T(KI,KI))**H * X = SCALE*WORK.
432*
433 DO 100 k = ki + 1, n
434 t( k, k ) = t( k, k ) - t( ki, ki )
435 IF( cabs1( t( k, k ) ).LT.smin )
436 $ t( k, k ) = smin
437 100 CONTINUE
438*
439 IF( ki.LT.n ) THEN
440 CALL zlatrs( 'Upper', 'Conjugate transpose', 'Non-unit',
441 $ 'Y', n-ki, t( ki+1, ki+1 ), ldt,
442 $ work( ki+1 ), scale, rwork, info )
443 work( ki ) = scale
444 END IF
445*
446* Copy the vector x or Q*x to VL and normalize.
447*
448 IF( .NOT.over ) THEN
449 CALL zcopy( n-ki+1, work( ki ), 1, vl( ki, is ), 1 )
450*
451 ii = izamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
452 remax = one / cabs1( vl( ii, is ) )
453 CALL zdscal( n-ki+1, remax, vl( ki, is ), 1 )
454*
455 DO 110 k = 1, ki - 1
456 vl( k, is ) = cmzero
457 110 CONTINUE
458 ELSE
459 IF( ki.LT.n )
460 $ CALL zgemv( 'N', n, n-ki, cmone, vl( 1, ki+1 ), ldvl,
461 $ work( ki+1 ), 1, dcmplx( scale ),
462 $ vl( 1, ki ), 1 )
463*
464 ii = izamax( n, vl( 1, ki ), 1 )
465 remax = one / cabs1( vl( ii, ki ) )
466 CALL zdscal( n, remax, vl( 1, ki ), 1 )
467 END IF
468*
469* Set back the original diagonal elements of T.
470*
471 DO 120 k = ki + 1, n
472 t( k, k ) = work( k+n )
473 120 CONTINUE
474*
475 is = is + 1
476 130 CONTINUE
477 END IF
478*
479 RETURN
480*
481* End of ZTREVC
482*
dzasum
double precision function dzasum(n, zx, incx)
DZASUM
Definition dzasum.f:72

◆ ztrevc3()

subroutine ztrevc3 ( character side,
character howmny,
logical, dimension( * ) select,
integer n,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( ldvl, * ) vl,
integer ldvl,
complex*16, dimension( ldvr, * ) vr,
integer ldvr,
integer mm,
integer m,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer lrwork,
integer info )

ZTREVC3

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

Purpose:
!>
!> ZTREVC3 computes some or all of the right and/or left eigenvectors of
!> a complex upper triangular matrix T.
!> Matrices of this type are produced by the Schur factorization of
!> a complex general matrix:  A = Q*T*Q**H, as computed by ZHSEQR.
!>
!> The right eigenvector x and the left eigenvector y of T corresponding
!> to an eigenvalue w are defined by:
!>
!>              T*x = w*x,     (y**H)*T = w*(y**H)
!>
!> where y**H denotes the conjugate transpose of the vector y.
!> The eigenvalues are not input to this routine, but are read directly
!> from the diagonal of T.
!>
!> This routine returns the matrices X and/or Y of right and left
!> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!> input matrix. If Q is the unitary factor that reduces a matrix A to
!> Schur form T, then Q*X and Q*Y are the matrices of right and left
!> eigenvectors of A.
!>
!> This uses a Level 3 BLAS version of the back transformation.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'R':  compute right eigenvectors only;
!>          = 'L':  compute left eigenvectors only;
!>          = 'B':  compute both right and left eigenvectors.
!>
[in]HOWMNY
!>          HOWMNY is CHARACTER*1
!>          = 'A':  compute all right and/or left eigenvectors;
!>          = 'B':  compute all right and/or left eigenvectors,
!>                  backtransformed using the matrices supplied in
!>                  VR and/or VL;
!>          = 'S':  compute selected right and/or left eigenvectors,
!>                  as indicated by the logical array SELECT.
!>
[in]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
!>          computed.
!>          The eigenvector corresponding to the j-th eigenvalue is
!>          computed if SELECT(j) = .TRUE..
!>          Not referenced if HOWMNY = 'A' or 'B'.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!>
[in,out]T
!>          T is COMPLEX*16 array, dimension (LDT,N)
!>          The upper triangular matrix T.  T is modified, but restored
!>          on exit.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in,out]VL
!>          VL is COMPLEX*16 array, dimension (LDVL,MM)
!>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
!>          contain an N-by-N matrix Q (usually the unitary matrix Q of
!>          Schur vectors returned by ZHSEQR).
!>          On exit, if SIDE = 'L' or 'B', VL contains:
!>          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
!>          if HOWMNY = 'B', the matrix Q*Y;
!>          if HOWMNY = 'S', the left eigenvectors of T specified by
!>                           SELECT, stored consecutively in the columns
!>                           of VL, in the same order as their
!>                           eigenvalues.
!>          Not referenced if SIDE = 'R'.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          The leading dimension of the array VL.
!>          LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N.
!>
[in,out]VR
!>          VR is COMPLEX*16 array, dimension (LDVR,MM)
!>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
!>          contain an N-by-N matrix Q (usually the unitary matrix Q of
!>          Schur vectors returned by ZHSEQR).
!>          On exit, if SIDE = 'R' or 'B', VR contains:
!>          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
!>          if HOWMNY = 'B', the matrix Q*X;
!>          if HOWMNY = 'S', the right eigenvectors of T specified by
!>                           SELECT, stored consecutively in the columns
!>                           of VR, in the same order as their
!>                           eigenvalues.
!>          Not referenced if SIDE = 'L'.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.
!>          LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N.
!>
[in]MM
!>          MM is INTEGER
!>          The number of columns in the arrays VL and/or VR. MM >= M.
!>
[out]M
!>          M is INTEGER
!>          The number of columns in the arrays VL and/or VR actually
!>          used to store the eigenvectors.
!>          If HOWMNY = 'A' or 'B', M is set to N.
!>          Each selected eigenvector occupies one column.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of array WORK. LWORK >= max(1,2*N).
!>          For optimum performance, LWORK >= N + 2*N*NB, where NB is
!>          the optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (LRWORK)
!>
[in]LRWORK
!>          LRWORK is INTEGER
!>          The dimension of array RWORK. LRWORK >= max(1,N).
!>
!>          If LRWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the RWORK array, returns
!>          this value as the first entry of the RWORK array, and no error
!>          message related to LRWORK is issued by XERBLA.
!>
[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.
Further Details:
!>
!>  The algorithm used in this program is basically backward (forward)
!>  substitution, with scaling to make the the code robust against
!>  possible overflow.
!>
!>  Each eigenvector is normalized so that the element of largest
!>  magnitude has magnitude 1; here the magnitude of a complex number
!>  (x,y) is taken to be |x| + |y|.
!>

Definition at line 242 of file ztrevc3.f.

244 IMPLICIT NONE
245*
246* -- LAPACK computational routine --
247* -- LAPACK is a software package provided by Univ. of Tennessee, --
248* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
249*
250* .. Scalar Arguments ..
251 CHARACTER HOWMNY, SIDE
252 INTEGER INFO, LDT, LDVL, LDVR, LWORK, LRWORK, M, MM, N
253* ..
254* .. Array Arguments ..
255 LOGICAL SELECT( * )
256 DOUBLE PRECISION RWORK( * )
257 COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
258 $ WORK( * )
259* ..
260*
261* =====================================================================
262*
263* .. Parameters ..
264 DOUBLE PRECISION ZERO, ONE
265 parameter( zero = 0.0d+0, one = 1.0d+0 )
266 COMPLEX*16 CZERO, CONE
267 parameter( czero = ( 0.0d+0, 0.0d+0 ),
268 $ cone = ( 1.0d+0, 0.0d+0 ) )
269 INTEGER NBMIN, NBMAX
270 parameter( nbmin = 8, nbmax = 128 )
271* ..
272* .. Local Scalars ..
273 LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, RIGHTV, SOMEV
274 INTEGER I, II, IS, J, K, KI, IV, MAXWRK, NB
275 DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
276 COMPLEX*16 CDUM
277* ..
278* .. External Functions ..
279 LOGICAL LSAME
280 INTEGER ILAENV, IZAMAX
281 DOUBLE PRECISION DLAMCH, DZASUM
282 EXTERNAL lsame, ilaenv, izamax, dlamch, dzasum
283* ..
284* .. External Subroutines ..
285 EXTERNAL xerbla, zcopy, zdscal, zgemv, zlatrs,
286 $ zgemm, dlabad, zlaset, zlacpy
287* ..
288* .. Intrinsic Functions ..
289 INTRINSIC abs, dble, dcmplx, conjg, dimag, max
290* ..
291* .. Statement Functions ..
292 DOUBLE PRECISION CABS1
293* ..
294* .. Statement Function definitions ..
295 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
296* ..
297* .. Executable Statements ..
298*
299* Decode and test the input parameters
300*
301 bothv = lsame( side, 'B' )
302 rightv = lsame( side, 'R' ) .OR. bothv
303 leftv = lsame( side, 'L' ) .OR. bothv
304*
305 allv = lsame( howmny, 'A' )
306 over = lsame( howmny, 'B' )
307 somev = lsame( howmny, 'S' )
308*
309* Set M to the number of columns required to store the selected
310* eigenvectors.
311*
312 IF( somev ) THEN
313 m = 0
314 DO 10 j = 1, n
315 IF( SELECT( j ) )
316 $ m = m + 1
317 10 CONTINUE
318 ELSE
319 m = n
320 END IF
321*
322 info = 0
323 nb = ilaenv( 1, 'ZTREVC', side // howmny, n, -1, -1, -1 )
324 maxwrk = n + 2*n*nb
325 work(1) = maxwrk
326 rwork(1) = n
327 lquery = ( lwork.EQ.-1 .OR. lrwork.EQ.-1 )
328 IF( .NOT.rightv .AND. .NOT.leftv ) THEN
329 info = -1
330 ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN
331 info = -2
332 ELSE IF( n.LT.0 ) THEN
333 info = -4
334 ELSE IF( ldt.LT.max( 1, n ) ) THEN
335 info = -6
336 ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN
337 info = -8
338 ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN
339 info = -10
340 ELSE IF( mm.LT.m ) THEN
341 info = -11
342 ELSE IF( lwork.LT.max( 1, 2*n ) .AND. .NOT.lquery ) THEN
343 info = -14
344 ELSE IF ( lrwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
345 info = -16
346 END IF
347 IF( info.NE.0 ) THEN
348 CALL xerbla( 'ZTREVC3', -info )
349 RETURN
350 ELSE IF( lquery ) THEN
351 RETURN
352 END IF
353*
354* Quick return if possible.
355*
356 IF( n.EQ.0 )
357 $ RETURN
358*
359* Use blocked version of back-transformation if sufficient workspace.
360* Zero-out the workspace to avoid potential NaN propagation.
361*
362 IF( over .AND. lwork .GE. n + 2*n*nbmin ) THEN
363 nb = (lwork - n) / (2*n)
364 nb = min( nb, nbmax )
365 CALL zlaset( 'F', n, 1+2*nb, czero, czero, work, n )
366 ELSE
367 nb = 1
368 END IF
369*
370* Set the constants to control overflow.
371*
372 unfl = dlamch( 'Safe minimum' )
373 ovfl = one / unfl
374 CALL dlabad( unfl, ovfl )
375 ulp = dlamch( 'Precision' )
376 smlnum = unfl*( n / ulp )
377*
378* Store the diagonal elements of T in working array WORK.
379*
380 DO 20 i = 1, n
381 work( i ) = t( i, i )
382 20 CONTINUE
383*
384* Compute 1-norm of each column of strictly upper triangular
385* part of T to control overflow in triangular solver.
386*
387 rwork( 1 ) = zero
388 DO 30 j = 2, n
389 rwork( j ) = dzasum( j-1, t( 1, j ), 1 )
390 30 CONTINUE
391*
392 IF( rightv ) THEN
393*
394* ============================================================
395* Compute right eigenvectors.
396*
397* IV is index of column in current block.
398* Non-blocked version always uses IV=NB=1;
399* blocked version starts with IV=NB, goes down to 1.
400* (Note the "0-th" column is used to store the original diagonal.)
401 iv = nb
402 is = m
403 DO 80 ki = n, 1, -1
404 IF( somev ) THEN
405 IF( .NOT.SELECT( ki ) )
406 $ GO TO 80
407 END IF
408 smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
409*
410* --------------------------------------------------------
411* Complex right eigenvector
412*
413 work( ki + iv*n ) = cone
414*
415* Form right-hand side.
416*
417 DO 40 k = 1, ki - 1
418 work( k + iv*n ) = -t( k, ki )
419 40 CONTINUE
420*
421* Solve upper triangular system:
422* [ T(1:KI-1,1:KI-1) - T(KI,KI) ]*X = SCALE*WORK.
423*
424 DO 50 k = 1, ki - 1
425 t( k, k ) = t( k, k ) - t( ki, ki )
426 IF( cabs1( t( k, k ) ).LT.smin )
427 $ t( k, k ) = smin
428 50 CONTINUE
429*
430 IF( ki.GT.1 ) THEN
431 CALL zlatrs( 'Upper', 'No transpose', 'Non-unit', 'Y',
432 $ ki-1, t, ldt, work( 1 + iv*n ), scale,
433 $ rwork, info )
434 work( ki + iv*n ) = scale
435 END IF
436*
437* Copy the vector x or Q*x to VR and normalize.
438*
439 IF( .NOT.over ) THEN
440* ------------------------------
441* no back-transform: copy x to VR and normalize.
442 CALL zcopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 )
443*
444 ii = izamax( ki, vr( 1, is ), 1 )
445 remax = one / cabs1( vr( ii, is ) )
446 CALL zdscal( ki, remax, vr( 1, is ), 1 )
447*
448 DO 60 k = ki + 1, n
449 vr( k, is ) = czero
450 60 CONTINUE
451*
452 ELSE IF( nb.EQ.1 ) THEN
453* ------------------------------
454* version 1: back-transform each vector with GEMV, Q*x.
455 IF( ki.GT.1 )
456 $ CALL zgemv( 'N', n, ki-1, cone, vr, ldvr,
457 $ work( 1 + iv*n ), 1, dcmplx( scale ),
458 $ vr( 1, ki ), 1 )
459*
460 ii = izamax( n, vr( 1, ki ), 1 )
461 remax = one / cabs1( vr( ii, ki ) )
462 CALL zdscal( n, remax, vr( 1, ki ), 1 )
463*
464 ELSE
465* ------------------------------
466* version 2: back-transform block of vectors with GEMM
467* zero out below vector
468 DO k = ki + 1, n
469 work( k + iv*n ) = czero
470 END DO
471*
472* Columns IV:NB of work are valid vectors.
473* When the number of vectors stored reaches NB,
474* or if this was last vector, do the GEMM
475 IF( (iv.EQ.1) .OR. (ki.EQ.1) ) THEN
476 CALL zgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,
477 $ vr, ldvr,
478 $ work( 1 + (iv)*n ), n,
479 $ czero,
480 $ work( 1 + (nb+iv)*n ), n )
481* normalize vectors
482 DO k = iv, nb
483 ii = izamax( n, work( 1 + (nb+k)*n ), 1 )
484 remax = one / cabs1( work( ii + (nb+k)*n ) )
485 CALL zdscal( n, remax, work( 1 + (nb+k)*n ), 1 )
486 END DO
487 CALL zlacpy( 'F', n, nb-iv+1,
488 $ work( 1 + (nb+iv)*n ), n,
489 $ vr( 1, ki ), ldvr )
490 iv = nb
491 ELSE
492 iv = iv - 1
493 END IF
494 END IF
495*
496* Restore the original diagonal elements of T.
497*
498 DO 70 k = 1, ki - 1
499 t( k, k ) = work( k )
500 70 CONTINUE
501*
502 is = is - 1
503 80 CONTINUE
504 END IF
505*
506 IF( leftv ) THEN
507*
508* ============================================================
509* Compute left eigenvectors.
510*
511* IV is index of column in current block.
512* Non-blocked version always uses IV=1;
513* blocked version starts with IV=1, goes up to NB.
514* (Note the "0-th" column is used to store the original diagonal.)
515 iv = 1
516 is = 1
517 DO 130 ki = 1, n
518*
519 IF( somev ) THEN
520 IF( .NOT.SELECT( ki ) )
521 $ GO TO 130
522 END IF
523 smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
524*
525* --------------------------------------------------------
526* Complex left eigenvector
527*
528 work( ki + iv*n ) = cone
529*
530* Form right-hand side.
531*
532 DO 90 k = ki + 1, n
533 work( k + iv*n ) = -conjg( t( ki, k ) )
534 90 CONTINUE
535*
536* Solve conjugate-transposed triangular system:
537* [ T(KI+1:N,KI+1:N) - T(KI,KI) ]**H * X = SCALE*WORK.
538*
539 DO 100 k = ki + 1, n
540 t( k, k ) = t( k, k ) - t( ki, ki )
541 IF( cabs1( t( k, k ) ).LT.smin )
542 $ t( k, k ) = smin
543 100 CONTINUE
544*
545 IF( ki.LT.n ) THEN
546 CALL zlatrs( 'Upper', 'Conjugate transpose', 'Non-unit',
547 $ 'Y', n-ki, t( ki+1, ki+1 ), ldt,
548 $ work( ki+1 + iv*n ), scale, rwork, info )
549 work( ki + iv*n ) = scale
550 END IF
551*
552* Copy the vector x or Q*x to VL and normalize.
553*
554 IF( .NOT.over ) THEN
555* ------------------------------
556* no back-transform: copy x to VL and normalize.
557 CALL zcopy( n-ki+1, work( ki + iv*n ), 1, vl(ki,is), 1 )
558*
559 ii = izamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
560 remax = one / cabs1( vl( ii, is ) )
561 CALL zdscal( n-ki+1, remax, vl( ki, is ), 1 )
562*
563 DO 110 k = 1, ki - 1
564 vl( k, is ) = czero
565 110 CONTINUE
566*
567 ELSE IF( nb.EQ.1 ) THEN
568* ------------------------------
569* version 1: back-transform each vector with GEMV, Q*x.
570 IF( ki.LT.n )
571 $ CALL zgemv( 'N', n, n-ki, cone, vl( 1, ki+1 ), ldvl,
572 $ work( ki+1 + iv*n ), 1, dcmplx( scale ),
573 $ vl( 1, ki ), 1 )
574*
575 ii = izamax( n, vl( 1, ki ), 1 )
576 remax = one / cabs1( vl( ii, ki ) )
577 CALL zdscal( n, remax, vl( 1, ki ), 1 )
578*
579 ELSE
580* ------------------------------
581* version 2: back-transform block of vectors with GEMM
582* zero out above vector
583* could go from KI-NV+1 to KI-1
584 DO k = 1, ki - 1
585 work( k + iv*n ) = czero
586 END DO
587*
588* Columns 1:IV of work are valid vectors.
589* When the number of vectors stored reaches NB,
590* or if this was last vector, do the GEMM
591 IF( (iv.EQ.nb) .OR. (ki.EQ.n) ) THEN
592 CALL zgemm( 'N', 'N', n, iv, n-ki+iv, cone,
593 $ vl( 1, ki-iv+1 ), ldvl,
594 $ work( ki-iv+1 + (1)*n ), n,
595 $ czero,
596 $ work( 1 + (nb+1)*n ), n )
597* normalize vectors
598 DO k = 1, iv
599 ii = izamax( n, work( 1 + (nb+k)*n ), 1 )
600 remax = one / cabs1( work( ii + (nb+k)*n ) )
601 CALL zdscal( n, remax, work( 1 + (nb+k)*n ), 1 )
602 END DO
603 CALL zlacpy( 'F', n, iv,
604 $ work( 1 + (nb+1)*n ), n,
605 $ vl( 1, ki-iv+1 ), ldvl )
606 iv = 1
607 ELSE
608 iv = iv + 1
609 END IF
610 END IF
611*
612* Restore the original diagonal elements of T.
613*
614 DO 120 k = ki + 1, n
615 t( k, k ) = work( k )
616 120 CONTINUE
617*
618 is = is + 1
619 130 CONTINUE
620 END IF
621*
622 RETURN
623*
624* End of ZTREVC3
625*

◆ ztrexc()

subroutine ztrexc ( character compq,
integer n,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( ldq, * ) q,
integer ldq,
integer ifst,
integer ilst,
integer info )

ZTREXC

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

Purpose:
!>
!> ZTREXC reorders the Schur factorization of a complex matrix
!> A = Q*T*Q**H, so that the diagonal element of T with row index IFST
!> is moved to row ILST.
!>
!> The Schur form T is reordered by a unitary similarity transformation
!> Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
!> postmultplying it with Z.
!>
Parameters
[in]COMPQ
!>          COMPQ is CHARACTER*1
!>          = 'V':  update the matrix Q of Schur vectors;
!>          = 'N':  do not update Q.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!>          If N == 0 arguments ILST and IFST may be any value.
!>
[in,out]T
!>          T is COMPLEX*16 array, dimension (LDT,N)
!>          On entry, the upper triangular matrix T.
!>          On exit, the reordered upper triangular matrix.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in,out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
!>          On exit, if COMPQ = 'V', Q has been postmultiplied by the
!>          unitary transformation matrix Z which reorders T.
!>          If COMPQ = 'N', Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= 1, and if
!>          COMPQ = 'V', LDQ >= max(1,N).
!>
[in]IFST
!>          IFST is INTEGER
!>
[in]ILST
!>          ILST is INTEGER
!>
!>          Specify the reordering of the diagonal elements of T:
!>          The element with row index IFST is moved to row ILST by a
!>          sequence of transpositions between adjacent elements.
!>          1 <= IFST <= N; 1 <= ILST <= N.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 125 of file ztrexc.f.

126*
127* -- LAPACK computational 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 COMPQ
133 INTEGER IFST, ILST, INFO, LDQ, LDT, N
134* ..
135* .. Array Arguments ..
136 COMPLEX*16 Q( LDQ, * ), T( LDT, * )
137* ..
138*
139* =====================================================================
140*
141* .. Local Scalars ..
142 LOGICAL WANTQ
143 INTEGER K, M1, M2, M3
144 DOUBLE PRECISION CS
145 COMPLEX*16 SN, T11, T22, TEMP
146* ..
147* .. External Functions ..
148 LOGICAL LSAME
149 EXTERNAL lsame
150* ..
151* .. External Subroutines ..
152 EXTERNAL xerbla, zlartg, zrot
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC dconjg, max
156* ..
157* .. Executable Statements ..
158*
159* Decode and test the input parameters.
160*
161 info = 0
162 wantq = lsame( compq, 'V' )
163 IF( .NOT.lsame( compq, 'N' ) .AND. .NOT.wantq ) THEN
164 info = -1
165 ELSE IF( n.LT.0 ) THEN
166 info = -2
167 ELSE IF( ldt.LT.max( 1, n ) ) THEN
168 info = -4
169 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.max( 1, n ) ) ) THEN
170 info = -6
171 ELSE IF(( ifst.LT.1 .OR. ifst.GT.n ).AND.( n.GT.0 )) THEN
172 info = -7
173 ELSE IF(( ilst.LT.1 .OR. ilst.GT.n ).AND.( n.GT.0 )) THEN
174 info = -8
175 END IF
176 IF( info.NE.0 ) THEN
177 CALL xerbla( 'ZTREXC', -info )
178 RETURN
179 END IF
180*
181* Quick return if possible
182*
183 IF( n.LE.1 .OR. ifst.EQ.ilst )
184 $ RETURN
185*
186 IF( ifst.LT.ilst ) THEN
187*
188* Move the IFST-th diagonal element forward down the diagonal.
189*
190 m1 = 0
191 m2 = -1
192 m3 = 1
193 ELSE
194*
195* Move the IFST-th diagonal element backward up the diagonal.
196*
197 m1 = -1
198 m2 = 0
199 m3 = -1
200 END IF
201*
202 DO 10 k = ifst + m1, ilst + m2, m3
203*
204* Interchange the k-th and (k+1)-th diagonal elements.
205*
206 t11 = t( k, k )
207 t22 = t( k+1, k+1 )
208*
209* Determine the transformation to perform the interchange.
210*
211 CALL zlartg( t( k, k+1 ), t22-t11, cs, sn, temp )
212*
213* Apply transformation to the matrix T.
214*
215 IF( k+2.LE.n )
216 $ CALL zrot( n-k-1, t( k, k+2 ), ldt, t( k+1, k+2 ), ldt, cs,
217 $ sn )
218 CALL zrot( k-1, t( 1, k ), 1, t( 1, k+1 ), 1, cs,
219 $ dconjg( sn ) )
220*
221 t( k, k ) = t22
222 t( k+1, k+1 ) = t11
223*
224 IF( wantq ) THEN
225*
226* Accumulate transformation in the matrix Q.
227*
228 CALL zrot( n, q( 1, k ), 1, q( 1, k+1 ), 1, cs,
229 $ dconjg( sn ) )
230 END IF
231*
232 10 CONTINUE
233*
234 RETURN
235*
236* End of ZTREXC
237*

◆ ztrrfs()

subroutine ztrrfs ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZTRRFS

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

Purpose:
!>
!> ZTRRFS provides error bounds and backward error estimates for the
!> solution to a system of linear equations with a triangular
!> coefficient matrix.
!>
!> The solution matrix X must be computed by ZTRTRS or some other
!> means before entering this routine.  ZTRRFS does not do iterative
!> refinement because doing so cannot improve the backward error.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[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 B and X.  NRHS >= 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]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 180 of file ztrrfs.f.

182*
183* -- LAPACK computational routine --
184* -- LAPACK is a software package provided by Univ. of Tennessee, --
185* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
186*
187* .. Scalar Arguments ..
188 CHARACTER DIAG, TRANS, UPLO
189 INTEGER INFO, LDA, LDB, LDX, N, NRHS
190* ..
191* .. Array Arguments ..
192 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
193 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ),
194 $ X( LDX, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 DOUBLE PRECISION ZERO
201 parameter( zero = 0.0d+0 )
202 COMPLEX*16 ONE
203 parameter( one = ( 1.0d+0, 0.0d+0 ) )
204* ..
205* .. Local Scalars ..
206 LOGICAL NOTRAN, NOUNIT, UPPER
207 CHARACTER TRANSN, TRANST
208 INTEGER I, J, K, KASE, NZ
209 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
210 COMPLEX*16 ZDUM
211* ..
212* .. Local Arrays ..
213 INTEGER ISAVE( 3 )
214* ..
215* .. External Subroutines ..
216 EXTERNAL xerbla, zaxpy, zcopy, zlacn2, ztrmv, ztrsv
217* ..
218* .. Intrinsic Functions ..
219 INTRINSIC abs, dble, dimag, max
220* ..
221* .. External Functions ..
222 LOGICAL LSAME
223 DOUBLE PRECISION DLAMCH
224 EXTERNAL lsame, dlamch
225* ..
226* .. Statement Functions ..
227 DOUBLE PRECISION CABS1
228* ..
229* .. Statement Function definitions ..
230 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
231* ..
232* .. Executable Statements ..
233*
234* Test the input parameters.
235*
236 info = 0
237 upper = lsame( uplo, 'U' )
238 notran = lsame( trans, 'N' )
239 nounit = lsame( diag, 'N' )
240*
241 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
242 info = -1
243 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
244 $ lsame( trans, 'C' ) ) THEN
245 info = -2
246 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
247 info = -3
248 ELSE IF( n.LT.0 ) THEN
249 info = -4
250 ELSE IF( nrhs.LT.0 ) THEN
251 info = -5
252 ELSE IF( lda.LT.max( 1, n ) ) THEN
253 info = -7
254 ELSE IF( ldb.LT.max( 1, n ) ) THEN
255 info = -9
256 ELSE IF( ldx.LT.max( 1, n ) ) THEN
257 info = -11
258 END IF
259 IF( info.NE.0 ) THEN
260 CALL xerbla( 'ZTRRFS', -info )
261 RETURN
262 END IF
263*
264* Quick return if possible
265*
266 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
267 DO 10 j = 1, nrhs
268 ferr( j ) = zero
269 berr( j ) = zero
270 10 CONTINUE
271 RETURN
272 END IF
273*
274 IF( notran ) THEN
275 transn = 'N'
276 transt = 'C'
277 ELSE
278 transn = 'C'
279 transt = 'N'
280 END IF
281*
282* NZ = maximum number of nonzero elements in each row of A, plus 1
283*
284 nz = n + 1
285 eps = dlamch( 'Epsilon' )
286 safmin = dlamch( 'Safe minimum' )
287 safe1 = nz*safmin
288 safe2 = safe1 / eps
289*
290* Do for each right hand side
291*
292 DO 250 j = 1, nrhs
293*
294* Compute residual R = B - op(A) * X,
295* where op(A) = A, A**T, or A**H, depending on TRANS.
296*
297 CALL zcopy( n, x( 1, j ), 1, work, 1 )
298 CALL ztrmv( uplo, trans, diag, n, a, lda, work, 1 )
299 CALL zaxpy( n, -one, b( 1, j ), 1, work, 1 )
300*
301* Compute componentwise relative backward error from formula
302*
303* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
304*
305* where abs(Z) is the componentwise absolute value of the matrix
306* or vector Z. If the i-th component of the denominator is less
307* than SAFE2, then SAFE1 is added to the i-th components of the
308* numerator and denominator before dividing.
309*
310 DO 20 i = 1, n
311 rwork( i ) = cabs1( b( i, j ) )
312 20 CONTINUE
313*
314 IF( notran ) THEN
315*
316* Compute abs(A)*abs(X) + abs(B).
317*
318 IF( upper ) THEN
319 IF( nounit ) THEN
320 DO 40 k = 1, n
321 xk = cabs1( x( k, j ) )
322 DO 30 i = 1, k
323 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
324 30 CONTINUE
325 40 CONTINUE
326 ELSE
327 DO 60 k = 1, n
328 xk = cabs1( x( k, j ) )
329 DO 50 i = 1, k - 1
330 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
331 50 CONTINUE
332 rwork( k ) = rwork( k ) + xk
333 60 CONTINUE
334 END IF
335 ELSE
336 IF( nounit ) THEN
337 DO 80 k = 1, n
338 xk = cabs1( x( k, j ) )
339 DO 70 i = k, n
340 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
341 70 CONTINUE
342 80 CONTINUE
343 ELSE
344 DO 100 k = 1, n
345 xk = cabs1( x( k, j ) )
346 DO 90 i = k + 1, n
347 rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk
348 90 CONTINUE
349 rwork( k ) = rwork( k ) + xk
350 100 CONTINUE
351 END IF
352 END IF
353 ELSE
354*
355* Compute abs(A**H)*abs(X) + abs(B).
356*
357 IF( upper ) THEN
358 IF( nounit ) THEN
359 DO 120 k = 1, n
360 s = zero
361 DO 110 i = 1, k
362 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
363 110 CONTINUE
364 rwork( k ) = rwork( k ) + s
365 120 CONTINUE
366 ELSE
367 DO 140 k = 1, n
368 s = cabs1( x( k, j ) )
369 DO 130 i = 1, k - 1
370 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
371 130 CONTINUE
372 rwork( k ) = rwork( k ) + s
373 140 CONTINUE
374 END IF
375 ELSE
376 IF( nounit ) THEN
377 DO 160 k = 1, n
378 s = zero
379 DO 150 i = k, n
380 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
381 150 CONTINUE
382 rwork( k ) = rwork( k ) + s
383 160 CONTINUE
384 ELSE
385 DO 180 k = 1, n
386 s = cabs1( x( k, j ) )
387 DO 170 i = k + 1, n
388 s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) )
389 170 CONTINUE
390 rwork( k ) = rwork( k ) + s
391 180 CONTINUE
392 END IF
393 END IF
394 END IF
395 s = zero
396 DO 190 i = 1, n
397 IF( rwork( i ).GT.safe2 ) THEN
398 s = max( s, cabs1( work( i ) ) / rwork( i ) )
399 ELSE
400 s = max( s, ( cabs1( work( i ) )+safe1 ) /
401 $ ( rwork( i )+safe1 ) )
402 END IF
403 190 CONTINUE
404 berr( j ) = s
405*
406* Bound error from formula
407*
408* norm(X - XTRUE) / norm(X) .le. FERR =
409* norm( abs(inv(op(A)))*
410* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
411*
412* where
413* norm(Z) is the magnitude of the largest component of Z
414* inv(op(A)) is the inverse of op(A)
415* abs(Z) is the componentwise absolute value of the matrix or
416* vector Z
417* NZ is the maximum number of nonzeros in any row of A, plus 1
418* EPS is machine epsilon
419*
420* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
421* is incremented by SAFE1 if the i-th component of
422* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
423*
424* Use ZLACN2 to estimate the infinity-norm of the matrix
425* inv(op(A)) * diag(W),
426* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
427*
428 DO 200 i = 1, n
429 IF( rwork( i ).GT.safe2 ) THEN
430 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
431 ELSE
432 rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
433 $ safe1
434 END IF
435 200 CONTINUE
436*
437 kase = 0
438 210 CONTINUE
439 CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
440 IF( kase.NE.0 ) THEN
441 IF( kase.EQ.1 ) THEN
442*
443* Multiply by diag(W)*inv(op(A)**H).
444*
445 CALL ztrsv( uplo, transt, diag, n, a, lda, work, 1 )
446 DO 220 i = 1, n
447 work( i ) = rwork( i )*work( i )
448 220 CONTINUE
449 ELSE
450*
451* Multiply by inv(op(A))*diag(W).
452*
453 DO 230 i = 1, n
454 work( i ) = rwork( i )*work( i )
455 230 CONTINUE
456 CALL ztrsv( uplo, transn, diag, n, a, lda, work, 1 )
457 END IF
458 GO TO 210
459 END IF
460*
461* Normalize error.
462*
463 lstres = zero
464 DO 240 i = 1, n
465 lstres = max( lstres, cabs1( x( i, j ) ) )
466 240 CONTINUE
467 IF( lstres.NE.zero )
468 $ ferr( j ) = ferr( j ) / lstres
469*
470 250 CONTINUE
471*
472 RETURN
473*
474* End of ZTRRFS
475*
ztrsv
subroutine ztrsv(uplo, trans, diag, n, a, lda, x, incx)
ZTRSV
Definition ztrsv.f:149

◆ ztrsen()

subroutine ztrsen ( character job,
character compq,
logical, dimension( * ) select,
integer n,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( * ) w,
integer m,
double precision s,
double precision sep,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZTRSEN

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

Purpose:
!>
!> ZTRSEN reorders the Schur factorization of a complex matrix
!> A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
!> the leading positions on the diagonal of the upper triangular matrix
!> T, and the leading columns of Q form an orthonormal basis of the
!> corresponding right invariant subspace.
!>
!> Optionally the routine computes the reciprocal condition numbers of
!> the cluster of eigenvalues and/or the invariant subspace.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          Specifies whether condition numbers are required for the
!>          cluster of eigenvalues (S) or the invariant subspace (SEP):
!>          = 'N': none;
!>          = 'E': for eigenvalues only (S);
!>          = 'V': for invariant subspace only (SEP);
!>          = 'B': for both eigenvalues and invariant subspace (S and
!>                 SEP).
!>
[in]COMPQ
!>          COMPQ is CHARACTER*1
!>          = 'V': update the matrix Q of Schur vectors;
!>          = 'N': do not update Q.
!>
[in]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          SELECT specifies the eigenvalues in the selected cluster. To
!>          select the j-th eigenvalue, SELECT(j) must be set to .TRUE..
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!>
[in,out]T
!>          T is COMPLEX*16 array, dimension (LDT,N)
!>          On entry, the upper triangular matrix T.
!>          On exit, T is overwritten by the reordered matrix T, with the
!>          selected eigenvalues as the leading diagonal elements.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in,out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
!>          On exit, if COMPQ = 'V', Q has been postmultiplied by the
!>          unitary transformation matrix which reorders T; the leading M
!>          columns of Q form an orthonormal basis for the specified
!>          invariant subspace.
!>          If COMPQ = 'N', Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
!>
[out]W
!>          W is COMPLEX*16 array, dimension (N)
!>          The reordered eigenvalues of T, in the same order as they
!>          appear on the diagonal of T.
!>
[out]M
!>          M is INTEGER
!>          The dimension of the specified invariant subspace.
!>          0 <= M <= N.
!>
[out]S
!>          S is DOUBLE PRECISION
!>          If JOB = 'E' or 'B', S is a lower bound on the reciprocal
!>          condition number for the selected cluster of eigenvalues.
!>          S cannot underestimate the true reciprocal condition number
!>          by more than a factor of sqrt(N). If M = 0 or N, S = 1.
!>          If JOB = 'N' or 'V', S is not referenced.
!>
[out]SEP
!>          SEP is DOUBLE PRECISION
!>          If JOB = 'V' or 'B', SEP is the estimated reciprocal
!>          condition number of the specified invariant subspace. If
!>          M = 0 or N, SEP = norm(T).
!>          If JOB = 'N' or 'E', SEP is not referenced.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If JOB = 'N', LWORK >= 1;
!>          if JOB = 'E', LWORK = max(1,M*(N-M));
!>          if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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.
Further Details:
!>
!>  ZTRSEN first collects the selected eigenvalues by computing a unitary
!>  transformation Z to move them to the top left corner of T. In other
!>  words, the selected eigenvalues are the eigenvalues of T11 in:
!>
!>          Z**H * T * Z = ( T11 T12 ) n1
!>                         (  0  T22 ) n2
!>                            n1  n2
!>
!>  where N = n1+n2. The first
!>  n1 columns of Z span the specified invariant subspace of T.
!>
!>  If T has been obtained from the Schur factorization of a matrix
!>  A = Q*T*Q**H, then the reordered Schur factorization of A is given by
!>  A = (Q*Z)*(Z**H*T*Z)*(Q*Z)**H, and the first n1 columns of Q*Z span the
!>  corresponding invariant subspace of A.
!>
!>  The reciprocal condition number of the average of the eigenvalues of
!>  T11 may be returned in S. S lies between 0 (very badly conditioned)
!>  and 1 (very well conditioned). It is computed as follows. First we
!>  compute R so that
!>
!>                         P = ( I  R ) n1
!>                             ( 0  0 ) n2
!>                               n1 n2
!>
!>  is the projector on the invariant subspace associated with T11.
!>  R is the solution of the Sylvester equation:
!>
!>                        T11*R - R*T22 = T12.
!>
!>  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
!>  the two-norm of M. Then S is computed as the lower bound
!>
!>                      (1 + F-norm(R)**2)**(-1/2)
!>
!>  on the reciprocal of 2-norm(P), the true reciprocal condition number.
!>  S cannot underestimate 1 / 2-norm(P) by more than a factor of
!>  sqrt(N).
!>
!>  An approximate error bound for the computed average of the
!>  eigenvalues of T11 is
!>
!>                         EPS * norm(T) / S
!>
!>  where EPS is the machine precision.
!>
!>  The reciprocal condition number of the right invariant subspace
!>  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
!>  SEP is defined as the separation of T11 and T22:
!>
!>                     sep( T11, T22 ) = sigma-min( C )
!>
!>  where sigma-min(C) is the smallest singular value of the
!>  n1*n2-by-n1*n2 matrix
!>
!>     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
!>
!>  I(m) is an m by m identity matrix, and kprod denotes the Kronecker
!>  product. We estimate sigma-min(C) by the reciprocal of an estimate of
!>  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
!>  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
!>
!>  When SEP is small, small changes in T can cause large changes in
!>  the invariant subspace. An approximate bound on the maximum angular
!>  error in the computed right invariant subspace is
!>
!>                      EPS * norm(T) / SEP
!>

Definition at line 262 of file ztrsen.f.

264*
265* -- LAPACK computational routine --
266* -- LAPACK is a software package provided by Univ. of Tennessee, --
267* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
268*
269* .. Scalar Arguments ..
270 CHARACTER COMPQ, JOB
271 INTEGER INFO, LDQ, LDT, LWORK, M, N
272 DOUBLE PRECISION S, SEP
273* ..
274* .. Array Arguments ..
275 LOGICAL SELECT( * )
276 COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
277* ..
278*
279* =====================================================================
280*
281* .. Parameters ..
282 DOUBLE PRECISION ZERO, ONE
283 parameter( zero = 0.0d+0, one = 1.0d+0 )
284* ..
285* .. Local Scalars ..
286 LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP
287 INTEGER IERR, K, KASE, KS, LWMIN, N1, N2, NN
288 DOUBLE PRECISION EST, RNORM, SCALE
289* ..
290* .. Local Arrays ..
291 INTEGER ISAVE( 3 )
292 DOUBLE PRECISION RWORK( 1 )
293* ..
294* .. External Functions ..
295 LOGICAL LSAME
296 DOUBLE PRECISION ZLANGE
297 EXTERNAL lsame, zlange
298* ..
299* .. External Subroutines ..
300 EXTERNAL xerbla, zlacn2, zlacpy, ztrexc, ztrsyl
301* ..
302* .. Intrinsic Functions ..
303 INTRINSIC max, sqrt
304* ..
305* .. Executable Statements ..
306*
307* Decode and test the input parameters.
308*
309 wantbh = lsame( job, 'B' )
310 wants = lsame( job, 'E' ) .OR. wantbh
311 wantsp = lsame( job, 'V' ) .OR. wantbh
312 wantq = lsame( compq, 'V' )
313*
314* Set M to the number of selected eigenvalues.
315*
316 m = 0
317 DO 10 k = 1, n
318 IF( SELECT( k ) )
319 $ m = m + 1
320 10 CONTINUE
321*
322 n1 = m
323 n2 = n - m
324 nn = n1*n2
325*
326 info = 0
327 lquery = ( lwork.EQ.-1 )
328*
329 IF( wantsp ) THEN
330 lwmin = max( 1, 2*nn )
331 ELSE IF( lsame( job, 'N' ) ) THEN
332 lwmin = 1
333 ELSE IF( lsame( job, 'E' ) ) THEN
334 lwmin = max( 1, nn )
335 END IF
336*
337 IF( .NOT.lsame( job, 'N' ) .AND. .NOT.wants .AND. .NOT.wantsp )
338 $ THEN
339 info = -1
340 ELSE IF( .NOT.lsame( compq, 'N' ) .AND. .NOT.wantq ) THEN
341 info = -2
342 ELSE IF( n.LT.0 ) THEN
343 info = -4
344 ELSE IF( ldt.LT.max( 1, n ) ) THEN
345 info = -6
346 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) ) THEN
347 info = -8
348 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
349 info = -14
350 END IF
351*
352 IF( info.EQ.0 ) THEN
353 work( 1 ) = lwmin
354 END IF
355*
356 IF( info.NE.0 ) THEN
357 CALL xerbla( 'ZTRSEN', -info )
358 RETURN
359 ELSE IF( lquery ) THEN
360 RETURN
361 END IF
362*
363* Quick return if possible
364*
365 IF( m.EQ.n .OR. m.EQ.0 ) THEN
366 IF( wants )
367 $ s = one
368 IF( wantsp )
369 $ sep = zlange( '1', n, n, t, ldt, rwork )
370 GO TO 40
371 END IF
372*
373* Collect the selected eigenvalues at the top left corner of T.
374*
375 ks = 0
376 DO 20 k = 1, n
377 IF( SELECT( k ) ) THEN
378 ks = ks + 1
379*
380* Swap the K-th eigenvalue to position KS.
381*
382 IF( k.NE.ks )
383 $ CALL ztrexc( compq, n, t, ldt, q, ldq, k, ks, ierr )
384 END IF
385 20 CONTINUE
386*
387 IF( wants ) THEN
388*
389* Solve the Sylvester equation for R:
390*
391* T11*R - R*T22 = scale*T12
392*
393 CALL zlacpy( 'F', n1, n2, t( 1, n1+1 ), ldt, work, n1 )
394 CALL ztrsyl( 'N', 'N', -1, n1, n2, t, ldt, t( n1+1, n1+1 ),
395 $ ldt, work, n1, scale, ierr )
396*
397* Estimate the reciprocal of the condition number of the cluster
398* of eigenvalues.
399*
400 rnorm = zlange( 'F', n1, n2, work, n1, rwork )
401 IF( rnorm.EQ.zero ) THEN
402 s = one
403 ELSE
404 s = scale / ( sqrt( scale*scale / rnorm+rnorm )*
405 $ sqrt( rnorm ) )
406 END IF
407 END IF
408*
409 IF( wantsp ) THEN
410*
411* Estimate sep(T11,T22).
412*
413 est = zero
414 kase = 0
415 30 CONTINUE
416 CALL zlacn2( nn, work( nn+1 ), work, est, kase, isave )
417 IF( kase.NE.0 ) THEN
418 IF( kase.EQ.1 ) THEN
419*
420* Solve T11*R - R*T22 = scale*X.
421*
422 CALL ztrsyl( 'N', 'N', -1, n1, n2, t, ldt,
423 $ t( n1+1, n1+1 ), ldt, work, n1, scale,
424 $ ierr )
425 ELSE
426*
427* Solve T11**H*R - R*T22**H = scale*X.
428*
429 CALL ztrsyl( 'C', 'C', -1, n1, n2, t, ldt,
430 $ t( n1+1, n1+1 ), ldt, work, n1, scale,
431 $ ierr )
432 END IF
433 GO TO 30
434 END IF
435*
436 sep = scale / est
437 END IF
438*
439 40 CONTINUE
440*
441* Copy reordered eigenvalues to W.
442*
443 DO 50 k = 1, n
444 w( k ) = t( k, k )
445 50 CONTINUE
446*
447 work( 1 ) = lwmin
448*
449 RETURN
450*
451* End of ZTRSEN
452*
zlange
double precision function zlange(norm, m, n, a, lda, work)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlange.f:115
ztrexc
subroutine ztrexc(compq, n, t, ldt, q, ldq, ifst, ilst, info)
ZTREXC
Definition ztrexc.f:126
ztrsyl
subroutine ztrsyl(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
ZTRSYL
Definition ztrsyl.f:157

◆ ztrsna()

subroutine ztrsna ( character job,
character howmny,
logical, dimension( * ) select,
integer n,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( ldvl, * ) vl,
integer ldvl,
complex*16, dimension( ldvr, * ) vr,
integer ldvr,
double precision, dimension( * ) s,
double precision, dimension( * ) sep,
integer mm,
integer m,
complex*16, dimension( ldwork, * ) work,
integer ldwork,
double precision, dimension( * ) rwork,
integer info )

ZTRSNA

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

Purpose:
!>
!> ZTRSNA estimates reciprocal condition numbers for specified
!> eigenvalues and/or right eigenvectors of a complex upper triangular
!> matrix T (or of any matrix Q*T*Q**H with Q unitary).
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          Specifies whether condition numbers are required for
!>          eigenvalues (S) or eigenvectors (SEP):
!>          = 'E': for eigenvalues only (S);
!>          = 'V': for eigenvectors only (SEP);
!>          = 'B': for both eigenvalues and eigenvectors (S and SEP).
!>
[in]HOWMNY
!>          HOWMNY is CHARACTER*1
!>          = 'A': compute condition numbers for all eigenpairs;
!>          = 'S': compute condition numbers for selected eigenpairs
!>                 specified by the array SELECT.
!>
[in]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
!>          condition numbers are required. To select condition numbers
!>          for the j-th eigenpair, SELECT(j) must be set to .TRUE..
!>          If HOWMNY = 'A', SELECT is not referenced.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!>
[in]T
!>          T is COMPLEX*16 array, dimension (LDT,N)
!>          The upper triangular matrix T.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in]VL
!>          VL is COMPLEX*16 array, dimension (LDVL,M)
!>          If JOB = 'E' or 'B', VL must contain left eigenvectors of T
!>          (or of any Q*T*Q**H with Q unitary), corresponding to the
!>          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
!>          must be stored in consecutive columns of VL, as returned by
!>          ZHSEIN or ZTREVC.
!>          If JOB = 'V', VL is not referenced.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          The leading dimension of the array VL.
!>          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
!>
[in]VR
!>          VR is COMPLEX*16 array, dimension (LDVR,M)
!>          If JOB = 'E' or 'B', VR must contain right eigenvectors of T
!>          (or of any Q*T*Q**H with Q unitary), corresponding to the
!>          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
!>          must be stored in consecutive columns of VR, as returned by
!>          ZHSEIN or ZTREVC.
!>          If JOB = 'V', VR is not referenced.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.
!>          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (MM)
!>          If JOB = 'E' or 'B', the reciprocal condition numbers of the
!>          selected eigenvalues, stored in consecutive elements of the
!>          array. Thus S(j), SEP(j), and the j-th columns of VL and VR
!>          all correspond to the same eigenpair (but not in general the
!>          j-th eigenpair, unless all eigenpairs are selected).
!>          If JOB = 'V', S is not referenced.
!>
[out]SEP
!>          SEP is DOUBLE PRECISION array, dimension (MM)
!>          If JOB = 'V' or 'B', the estimated reciprocal condition
!>          numbers of the selected eigenvectors, stored in consecutive
!>          elements of the array.
!>          If JOB = 'E', SEP is not referenced.
!>
[in]MM
!>          MM is INTEGER
!>          The number of elements in the arrays S (if JOB = 'E' or 'B')
!>           and/or SEP (if JOB = 'V' or 'B'). MM >= M.
!>
[out]M
!>          M is INTEGER
!>          The number of elements of the arrays S and/or SEP actually
!>          used to store the estimated condition numbers.
!>          If HOWMNY = 'A', M is set to N.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LDWORK,N+6)
!>          If JOB = 'E', WORK is not referenced.
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.
!>          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>          If JOB = 'E', RWORK is not referenced.
!>
[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.
Further Details:
!>
!>  The reciprocal of the condition number of an eigenvalue lambda is
!>  defined as
!>
!>          S(lambda) = |v**H*u| / (norm(u)*norm(v))
!>
!>  where u and v are the right and left eigenvectors of T corresponding
!>  to lambda; v**H denotes the conjugate transpose of v, and norm(u)
!>  denotes the Euclidean norm. These reciprocal condition numbers always
!>  lie between zero (very badly conditioned) and one (very well
!>  conditioned). If n = 1, S(lambda) is defined to be 1.
!>
!>  An approximate error bound for a computed eigenvalue W(i) is given by
!>
!>                      EPS * norm(T) / S(i)
!>
!>  where EPS is the machine precision.
!>
!>  The reciprocal of the condition number of the right eigenvector u
!>  corresponding to lambda is defined as follows. Suppose
!>
!>              T = ( lambda  c  )
!>                  (   0    T22 )
!>
!>  Then the reciprocal condition number is
!>
!>          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
!>
!>  where sigma-min denotes the smallest singular value. We approximate
!>  the smallest singular value by the reciprocal of an estimate of the
!>  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
!>  defined to be abs(T(1,1)).
!>
!>  An approximate error bound for a computed right eigenvector VR(i)
!>  is given by
!>
!>                      EPS * norm(T) / SEP(i)
!>

Definition at line 246 of file ztrsna.f.

249*
250* -- LAPACK computational routine --
251* -- LAPACK is a software package provided by Univ. of Tennessee, --
252* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
253*
254* .. Scalar Arguments ..
255 CHARACTER HOWMNY, JOB
256 INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
257* ..
258* .. Array Arguments ..
259 LOGICAL SELECT( * )
260 DOUBLE PRECISION RWORK( * ), S( * ), SEP( * )
261 COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
262 $ WORK( LDWORK, * )
263* ..
264*
265* =====================================================================
266*
267* .. Parameters ..
268 DOUBLE PRECISION ZERO, ONE
269 parameter( zero = 0.0d+0, one = 1.0d0+0 )
270* ..
271* .. Local Scalars ..
272 LOGICAL SOMCON, WANTBH, WANTS, WANTSP
273 CHARACTER NORMIN
274 INTEGER I, IERR, IX, J, K, KASE, KS
275 DOUBLE PRECISION BIGNUM, EPS, EST, LNRM, RNRM, SCALE, SMLNUM,
276 $ XNORM
277 COMPLEX*16 CDUM, PROD
278* ..
279* .. Local Arrays ..
280 INTEGER ISAVE( 3 )
281 COMPLEX*16 DUMMY( 1 )
282* ..
283* .. External Functions ..
284 LOGICAL LSAME
285 INTEGER IZAMAX
286 DOUBLE PRECISION DLAMCH, DZNRM2
287 COMPLEX*16 ZDOTC
288 EXTERNAL lsame, izamax, dlamch, dznrm2, zdotc
289* ..
290* .. External Subroutines ..
291 EXTERNAL xerbla, zdrscl, zlacn2, zlacpy, zlatrs, ztrexc,
292 $ dlabad
293* ..
294* .. Intrinsic Functions ..
295 INTRINSIC abs, dble, dimag, max
296* ..
297* .. Statement Functions ..
298 DOUBLE PRECISION CABS1
299* ..
300* .. Statement Function definitions ..
301 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
302* ..
303* .. Executable Statements ..
304*
305* Decode and test the input parameters
306*
307 wantbh = lsame( job, 'B' )
308 wants = lsame( job, 'E' ) .OR. wantbh
309 wantsp = lsame( job, 'V' ) .OR. wantbh
310*
311 somcon = lsame( howmny, 'S' )
312*
313* Set M to the number of eigenpairs for which condition numbers are
314* to be computed.
315*
316 IF( somcon ) THEN
317 m = 0
318 DO 10 j = 1, n
319 IF( SELECT( j ) )
320 $ m = m + 1
321 10 CONTINUE
322 ELSE
323 m = n
324 END IF
325*
326 info = 0
327 IF( .NOT.wants .AND. .NOT.wantsp ) THEN
328 info = -1
329 ELSE IF( .NOT.lsame( howmny, 'A' ) .AND. .NOT.somcon ) THEN
330 info = -2
331 ELSE IF( n.LT.0 ) THEN
332 info = -4
333 ELSE IF( ldt.LT.max( 1, n ) ) THEN
334 info = -6
335 ELSE IF( ldvl.LT.1 .OR. ( wants .AND. ldvl.LT.n ) ) THEN
336 info = -8
337 ELSE IF( ldvr.LT.1 .OR. ( wants .AND. ldvr.LT.n ) ) THEN
338 info = -10
339 ELSE IF( mm.LT.m ) THEN
340 info = -13
341 ELSE IF( ldwork.LT.1 .OR. ( wantsp .AND. ldwork.LT.n ) ) THEN
342 info = -16
343 END IF
344 IF( info.NE.0 ) THEN
345 CALL xerbla( 'ZTRSNA', -info )
346 RETURN
347 END IF
348*
349* Quick return if possible
350*
351 IF( n.EQ.0 )
352 $ RETURN
353*
354 IF( n.EQ.1 ) THEN
355 IF( somcon ) THEN
356 IF( .NOT.SELECT( 1 ) )
357 $ RETURN
358 END IF
359 IF( wants )
360 $ s( 1 ) = one
361 IF( wantsp )
362 $ sep( 1 ) = abs( t( 1, 1 ) )
363 RETURN
364 END IF
365*
366* Get machine constants
367*
368 eps = dlamch( 'P' )
369 smlnum = dlamch( 'S' ) / eps
370 bignum = one / smlnum
371 CALL dlabad( smlnum, bignum )
372*
373 ks = 1
374 DO 50 k = 1, n
375*
376 IF( somcon ) THEN
377 IF( .NOT.SELECT( k ) )
378 $ GO TO 50
379 END IF
380*
381 IF( wants ) THEN
382*
383* Compute the reciprocal condition number of the k-th
384* eigenvalue.
385*
386 prod = zdotc( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
387 rnrm = dznrm2( n, vr( 1, ks ), 1 )
388 lnrm = dznrm2( n, vl( 1, ks ), 1 )
389 s( ks ) = abs( prod ) / ( rnrm*lnrm )
390*
391 END IF
392*
393 IF( wantsp ) THEN
394*
395* Estimate the reciprocal condition number of the k-th
396* eigenvector.
397*
398* Copy the matrix T to the array WORK and swap the k-th
399* diagonal element to the (1,1) position.
400*
401 CALL zlacpy( 'Full', n, n, t, ldt, work, ldwork )
402 CALL ztrexc( 'No Q', n, work, ldwork, dummy, 1, k, 1, ierr )
403*
404* Form C = T22 - lambda*I in WORK(2:N,2:N).
405*
406 DO 20 i = 2, n
407 work( i, i ) = work( i, i ) - work( 1, 1 )
408 20 CONTINUE
409*
410* Estimate a lower bound for the 1-norm of inv(C**H). The 1st
411* and (N+1)th columns of WORK are used to store work vectors.
412*
413 sep( ks ) = zero
414 est = zero
415 kase = 0
416 normin = 'N'
417 30 CONTINUE
418 CALL zlacn2( n-1, work( 1, n+1 ), work, est, kase, isave )
419*
420 IF( kase.NE.0 ) THEN
421 IF( kase.EQ.1 ) THEN
422*
423* Solve C**H*x = scale*b
424*
425 CALL zlatrs( 'Upper', 'Conjugate transpose',
426 $ 'Nonunit', normin, n-1, work( 2, 2 ),
427 $ ldwork, work, scale, rwork, ierr )
428 ELSE
429*
430* Solve C*x = scale*b
431*
432 CALL zlatrs( 'Upper', 'No transpose', 'Nonunit',
433 $ normin, n-1, work( 2, 2 ), ldwork, work,
434 $ scale, rwork, ierr )
435 END IF
436 normin = 'Y'
437 IF( scale.NE.one ) THEN
438*
439* Multiply by 1/SCALE if doing so will not cause
440* overflow.
441*
442 ix = izamax( n-1, work, 1 )
443 xnorm = cabs1( work( ix, 1 ) )
444 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
445 $ GO TO 40
446 CALL zdrscl( n, scale, work, 1 )
447 END IF
448 GO TO 30
449 END IF
450*
451 sep( ks ) = one / max( est, smlnum )
452 END IF
453*
454 40 CONTINUE
455 ks = ks + 1
456 50 CONTINUE
457 RETURN
458*
459* End of ZTRSNA
460*

◆ ztrti2()

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

ZTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).

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

Purpose:
!>
!> ZTRTI2 computes the inverse of a complex upper or lower triangular
!> matrix.
!>
!> This is the Level 2 BLAS version of the algorithm.
!>
Parameters
[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.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, 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.
!>
!>          On exit, the (triangular) inverse of the original matrix, in
!>          the same storage format.
!>
[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 109 of file ztrti2.f.

110*
111* -- LAPACK computational routine --
112* -- LAPACK is a software package provided by Univ. of Tennessee, --
113* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
114*
115* .. Scalar Arguments ..
116 CHARACTER DIAG, UPLO
117 INTEGER INFO, LDA, N
118* ..
119* .. Array Arguments ..
120 COMPLEX*16 A( LDA, * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 COMPLEX*16 ONE
127 parameter( one = ( 1.0d+0, 0.0d+0 ) )
128* ..
129* .. Local Scalars ..
130 LOGICAL NOUNIT, UPPER
131 INTEGER J
132 COMPLEX*16 AJJ
133* ..
134* .. External Functions ..
135 LOGICAL LSAME
136 EXTERNAL lsame
137* ..
138* .. External Subroutines ..
139 EXTERNAL xerbla, zscal, ztrmv
140* ..
141* .. Intrinsic Functions ..
142 INTRINSIC max
143* ..
144* .. Executable Statements ..
145*
146* Test the input parameters.
147*
148 info = 0
149 upper = lsame( uplo, 'U' )
150 nounit = lsame( diag, 'N' )
151 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
152 info = -1
153 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
154 info = -2
155 ELSE IF( n.LT.0 ) THEN
156 info = -3
157 ELSE IF( lda.LT.max( 1, n ) ) THEN
158 info = -5
159 END IF
160 IF( info.NE.0 ) THEN
161 CALL xerbla( 'ZTRTI2', -info )
162 RETURN
163 END IF
164*
165 IF( upper ) THEN
166*
167* Compute inverse of upper triangular matrix.
168*
169 DO 10 j = 1, n
170 IF( nounit ) THEN
171 a( j, j ) = one / a( j, j )
172 ajj = -a( j, j )
173 ELSE
174 ajj = -one
175 END IF
176*
177* Compute elements 1:j-1 of j-th column.
178*
179 CALL ztrmv( 'Upper', 'No transpose', diag, j-1, a, lda,
180 $ a( 1, j ), 1 )
181 CALL zscal( j-1, ajj, a( 1, j ), 1 )
182 10 CONTINUE
183 ELSE
184*
185* Compute inverse of lower triangular matrix.
186*
187 DO 20 j = n, 1, -1
188 IF( nounit ) THEN
189 a( j, j ) = one / a( j, j )
190 ajj = -a( j, j )
191 ELSE
192 ajj = -one
193 END IF
194 IF( j.LT.n ) THEN
195*
196* Compute elements j+1:n of j-th column.
197*
198 CALL ztrmv( 'Lower', 'No transpose', diag, n-j,
199 $ a( j+1, j+1 ), lda, a( j+1, j ), 1 )
200 CALL zscal( n-j, ajj, a( j+1, j ), 1 )
201 END IF
202 20 CONTINUE
203 END IF
204*
205 RETURN
206*
207* End of ZTRTI2
208*

◆ ztrtri()

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

ZTRTRI

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

Purpose:
!>
!> ZTRTRI computes the inverse of a complex upper or lower triangular
!> matrix A.
!>
!> This is the Level 3 BLAS version of the algorithm.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, 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.
!>          On exit, the (triangular) inverse of the original matrix, in
!>          the same storage format.
!>
[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 = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
!>               matrix is singular and its inverse can not be computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 108 of file ztrtri.f.

109*
110* -- LAPACK computational 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 DIAG, UPLO
116 INTEGER INFO, LDA, N
117* ..
118* .. Array Arguments ..
119 COMPLEX*16 A( LDA, * )
120* ..
121*
122* =====================================================================
123*
124* .. Parameters ..
125 COMPLEX*16 ONE, ZERO
126 parameter( one = ( 1.0d+0, 0.0d+0 ),
127 $ zero = ( 0.0d+0, 0.0d+0 ) )
128* ..
129* .. Local Scalars ..
130 LOGICAL NOUNIT, UPPER
131 INTEGER J, JB, NB, NN
132* ..
133* .. External Functions ..
134 LOGICAL LSAME
135 INTEGER ILAENV
136 EXTERNAL lsame, ilaenv
137* ..
138* .. External Subroutines ..
139 EXTERNAL xerbla, ztrmm, ztrsm, ztrti2
140* ..
141* .. Intrinsic Functions ..
142 INTRINSIC max, min
143* ..
144* .. Executable Statements ..
145*
146* Test the input parameters.
147*
148 info = 0
149 upper = lsame( uplo, 'U' )
150 nounit = lsame( diag, 'N' )
151 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
152 info = -1
153 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
154 info = -2
155 ELSE IF( n.LT.0 ) THEN
156 info = -3
157 ELSE IF( lda.LT.max( 1, n ) ) THEN
158 info = -5
159 END IF
160 IF( info.NE.0 ) THEN
161 CALL xerbla( 'ZTRTRI', -info )
162 RETURN
163 END IF
164*
165* Quick return if possible
166*
167 IF( n.EQ.0 )
168 $ RETURN
169*
170* Check for singularity if non-unit.
171*
172 IF( nounit ) THEN
173 DO 10 info = 1, n
174 IF( a( info, info ).EQ.zero )
175 $ RETURN
176 10 CONTINUE
177 info = 0
178 END IF
179*
180* Determine the block size for this environment.
181*
182 nb = ilaenv( 1, 'ZTRTRI', uplo // diag, n, -1, -1, -1 )
183 IF( nb.LE.1 .OR. nb.GE.n ) THEN
184*
185* Use unblocked code
186*
187 CALL ztrti2( uplo, diag, n, a, lda, info )
188 ELSE
189*
190* Use blocked code
191*
192 IF( upper ) THEN
193*
194* Compute inverse of upper triangular matrix
195*
196 DO 20 j = 1, n, nb
197 jb = min( nb, n-j+1 )
198*
199* Compute rows 1:j-1 of current block column
200*
201 CALL ztrmm( 'Left', 'Upper', 'No transpose', diag, j-1,
202 $ jb, one, a, lda, a( 1, j ), lda )
203 CALL ztrsm( 'Right', 'Upper', 'No transpose', diag, j-1,
204 $ jb, -one, a( j, j ), lda, a( 1, j ), lda )
205*
206* Compute inverse of current diagonal block
207*
208 CALL ztrti2( 'Upper', diag, jb, a( j, j ), lda, info )
209 20 CONTINUE
210 ELSE
211*
212* Compute inverse of lower triangular matrix
213*
214 nn = ( ( n-1 ) / nb )*nb + 1
215 DO 30 j = nn, 1, -nb
216 jb = min( nb, n-j+1 )
217 IF( j+jb.LE.n ) THEN
218*
219* Compute rows j+jb:n of current block column
220*
221 CALL ztrmm( 'Left', 'Lower', 'No transpose', diag,
222 $ n-j-jb+1, jb, one, a( j+jb, j+jb ), lda,
223 $ a( j+jb, j ), lda )
224 CALL ztrsm( 'Right', 'Lower', 'No transpose', diag,
225 $ n-j-jb+1, jb, -one, a( j, j ), lda,
226 $ a( j+jb, j ), lda )
227 END IF
228*
229* Compute inverse of current diagonal block
230*
231 CALL ztrti2( 'Lower', diag, jb, a( j, j ), lda, info )
232 30 CONTINUE
233 END IF
234 END IF
235*
236 RETURN
237*
238* End of ZTRTRI
239*
ztrti2
subroutine ztrti2(uplo, diag, n, a, lda, info)
ZTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
Definition ztrti2.f:110

◆ ztrtrs()

subroutine ztrtrs ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZTRTRS

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

Purpose:
!>
!> ZTRTRS solves a triangular system of the form
!>
!>    A * X = B,  A**T * X = B,  or  A**H * X = B,
!>
!> where A is a triangular matrix of order N, and B is an N-by-NRHS
!> matrix.  A check is made to verify that A is nonsingular.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          = 'N':  A is non-unit triangular;
!>          = 'U':  A is unit triangular.
!>
[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 matrix B.  NRHS >= 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]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, if INFO = 0, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, the i-th diagonal element of A is zero,
!>               indicating that the matrix is singular and the solutions
!>               X have not been computed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 138 of file ztrtrs.f.

140*
141* -- LAPACK computational routine --
142* -- LAPACK is a software package provided by Univ. of Tennessee, --
143* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
144*
145* .. Scalar Arguments ..
146 CHARACTER DIAG, TRANS, UPLO
147 INTEGER INFO, LDA, LDB, N, NRHS
148* ..
149* .. Array Arguments ..
150 COMPLEX*16 A( LDA, * ), B( LDB, * )
151* ..
152*
153* =====================================================================
154*
155* .. Parameters ..
156 COMPLEX*16 ZERO, ONE
157 parameter( zero = ( 0.0d+0, 0.0d+0 ),
158 $ one = ( 1.0d+0, 0.0d+0 ) )
159* ..
160* .. Local Scalars ..
161 LOGICAL NOUNIT
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 EXTERNAL lsame
166* ..
167* .. External Subroutines ..
168 EXTERNAL xerbla, ztrsm
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC max
172* ..
173* .. Executable Statements ..
174*
175* Test the input parameters.
176*
177 info = 0
178 nounit = lsame( diag, 'N' )
179 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
180 info = -1
181 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.
182 $ lsame( trans, 'T' ) .AND. .NOT.lsame( trans, 'C' ) ) THEN
183 info = -2
184 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
185 info = -3
186 ELSE IF( n.LT.0 ) THEN
187 info = -4
188 ELSE IF( nrhs.LT.0 ) THEN
189 info = -5
190 ELSE IF( lda.LT.max( 1, n ) ) THEN
191 info = -7
192 ELSE IF( ldb.LT.max( 1, n ) ) THEN
193 info = -9
194 END IF
195 IF( info.NE.0 ) THEN
196 CALL xerbla( 'ZTRTRS', -info )
197 RETURN
198 END IF
199*
200* Quick return if possible
201*
202 IF( n.EQ.0 )
203 $ RETURN
204*
205* Check for singularity.
206*
207 IF( nounit ) THEN
208 DO 10 info = 1, n
209 IF( a( info, info ).EQ.zero )
210 $ RETURN
211 10 CONTINUE
212 END IF
213 info = 0
214*
215* Solve A * x = b, A**T * x = b, or A**H * x = b.
216*
217 CALL ztrsm( 'Left', uplo, trans, diag, n, nrhs, one, a, lda, b,
218 $ ldb )
219*
220 RETURN
221*
222* End of ZTRTRS
223*

◆ ztrttf()

subroutine ztrttf ( character transr,
character uplo,
integer n,
complex*16, dimension( 0: lda-1, 0: * ) a,
integer lda,
complex*16, dimension( 0: * ) arf,
integer info )

ZTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed format (TF).

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

Purpose:
!>
!> ZTRTTF copies a triangular matrix A from standard full format (TR)
!> to rectangular full packed format (TF) .
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  ARF in Normal mode is wanted;
!>          = 'C':  ARF in Conjugate Transpose mode is wanted;
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension ( LDA, N )
!>          On entry, 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.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the matrix A.  LDA >= max(1,N).
!>
[out]ARF
!>          ARF is COMPLEX*16 array, dimension ( N*(N+1)/2 ),
!>          On exit, the upper or lower triangular matrix A stored in
!>          RFP format. For a further discussion see Notes below.
!>
[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.
Further Details:
!>
!>  We first consider Standard Packed Format when N is even.
!>  We give an example where N = 6.
!>
!>      AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  conjugate-transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  conjugate-transpose of the last three columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                -- -- --
!>        03 04 05                33 43 53
!>                                   -- --
!>        13 14 15                00 44 54
!>                                      --
!>        23 24 25                10 11 55
!>
!>        33 34 35                20 21 22
!>        --
!>        00 44 45                30 31 32
!>        -- --
!>        01 11 55                40 41 42
!>        -- -- --
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- -- --                -- -- -- -- -- --
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     -- -- -- -- --                -- -- -- -- --
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     -- -- -- -- -- --                -- -- -- --
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>
!>  We next  consider Standard Packed Format when N is odd.
!>  We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  conjugate-transpose of the first two   columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  conjugate-transpose of the last two   columns of AP lower.
!>  To denote conjugate we place -- above the element. This covers the
!>  case N odd  and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>                                   -- --
!>        02 03 04                00 33 43
!>                                      --
!>        12 13 14                10 11 44
!>
!>        22 23 24                20 21 22
!>        --
!>        00 33 34                30 31 32
!>        -- --
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     -- -- --                   -- -- -- -- -- --
!>     02 12 22 00 01             00 10 20 30 40 50
!>     -- -- -- --                   -- -- -- -- --
!>     03 13 23 33 11             33 11 21 31 41 51
!>     -- -- -- -- --                   -- -- -- --
!>     04 14 24 34 44             43 44 22 32 42 52
!>

Definition at line 215 of file ztrttf.f.

216*
217* -- LAPACK computational routine --
218* -- LAPACK is a software package provided by Univ. of Tennessee, --
219* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
220*
221* .. Scalar Arguments ..
222 CHARACTER TRANSR, UPLO
223 INTEGER INFO, N, LDA
224* ..
225* .. Array Arguments ..
226 COMPLEX*16 A( 0: LDA-1, 0: * ), ARF( 0: * )
227* ..
228*
229* =====================================================================
230*
231* .. Parameters ..
232* ..
233* .. Local Scalars ..
234 LOGICAL LOWER, NISODD, NORMALTRANSR
235 INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2
236* ..
237* .. External Functions ..
238 LOGICAL LSAME
239 EXTERNAL lsame
240* ..
241* .. External Subroutines ..
242 EXTERNAL xerbla
243* ..
244* .. Intrinsic Functions ..
245 INTRINSIC dconjg, max, mod
246* ..
247* .. Executable Statements ..
248*
249* Test the input parameters.
250*
251 info = 0
252 normaltransr = lsame( transr, 'N' )
253 lower = lsame( uplo, 'L' )
254 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
255 info = -1
256 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
257 info = -2
258 ELSE IF( n.LT.0 ) THEN
259 info = -3
260 ELSE IF( lda.LT.max( 1, n ) ) THEN
261 info = -5
262 END IF
263 IF( info.NE.0 ) THEN
264 CALL xerbla( 'ZTRTTF', -info )
265 RETURN
266 END IF
267*
268* Quick return if possible
269*
270 IF( n.LE.1 ) THEN
271 IF( n.EQ.1 ) THEN
272 IF( normaltransr ) THEN
273 arf( 0 ) = a( 0, 0 )
274 ELSE
275 arf( 0 ) = dconjg( a( 0, 0 ) )
276 END IF
277 END IF
278 RETURN
279 END IF
280*
281* Size of array ARF(1:2,0:nt-1)
282*
283 nt = n*( n+1 ) / 2
284*
285* set N1 and N2 depending on LOWER: for N even N1=N2=K
286*
287 IF( lower ) THEN
288 n2 = n / 2
289 n1 = n - n2
290 ELSE
291 n1 = n / 2
292 n2 = n - n1
293 END IF
294*
295* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2.
296* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is
297* N--by--(N+1)/2.
298*
299 IF( mod( n, 2 ).EQ.0 ) THEN
300 k = n / 2
301 nisodd = .false.
302 IF( .NOT.lower )
303 $ np1x2 = n + n + 2
304 ELSE
305 nisodd = .true.
306 IF( .NOT.lower )
307 $ nx2 = n + n
308 END IF
309*
310 IF( nisodd ) THEN
311*
312* N is odd
313*
314 IF( normaltransr ) THEN
315*
316* N is odd and TRANSR = 'N'
317*
318 IF( lower ) THEN
319*
320* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) )
321* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0)
322* T1 -> a(0), T2 -> a(n), S -> a(n1); lda=n
323*
324 ij = 0
325 DO j = 0, n2
326 DO i = n1, n2 + j
327 arf( ij ) = dconjg( a( n2+j, i ) )
328 ij = ij + 1
329 END DO
330 DO i = j, n - 1
331 arf( ij ) = a( i, j )
332 ij = ij + 1
333 END DO
334 END DO
335*
336 ELSE
337*
338* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1)
339* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0)
340* T1 -> a(n2), T2 -> a(n1), S -> a(0); lda=n
341*
342 ij = nt - n
343 DO j = n - 1, n1, -1
344 DO i = 0, j
345 arf( ij ) = a( i, j )
346 ij = ij + 1
347 END DO
348 DO l = j - n1, n1 - 1
349 arf( ij ) = dconjg( a( j-n1, l ) )
350 ij = ij + 1
351 END DO
352 ij = ij - nx2
353 END DO
354*
355 END IF
356*
357 ELSE
358*
359* N is odd and TRANSR = 'C'
360*
361 IF( lower ) THEN
362*
363* SRPA for LOWER, TRANSPOSE and N is odd
364* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1)
365* T1 -> A(0+0) , T2 -> A(1+0) , S -> A(0+n1*n1); lda=n1
366*
367 ij = 0
368 DO j = 0, n2 - 1
369 DO i = 0, j
370 arf( ij ) = dconjg( a( j, i ) )
371 ij = ij + 1
372 END DO
373 DO i = n1 + j, n - 1
374 arf( ij ) = a( i, n1+j )
375 ij = ij + 1
376 END DO
377 END DO
378 DO j = n2, n - 1
379 DO i = 0, n1 - 1
380 arf( ij ) = dconjg( a( j, i ) )
381 ij = ij + 1
382 END DO
383 END DO
384*
385 ELSE
386*
387* SRPA for UPPER, TRANSPOSE and N is odd
388* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0)
389* T1 -> A(n2*n2), T2 -> A(n1*n2), S -> A(0); lda=n2
390*
391 ij = 0
392 DO j = 0, n1
393 DO i = n1, n - 1
394 arf( ij ) = dconjg( a( j, i ) )
395 ij = ij + 1
396 END DO
397 END DO
398 DO j = 0, n1 - 1
399 DO i = 0, j
400 arf( ij ) = a( i, j )
401 ij = ij + 1
402 END DO
403 DO l = n2 + j, n - 1
404 arf( ij ) = dconjg( a( n2+j, l ) )
405 ij = ij + 1
406 END DO
407 END DO
408*
409 END IF
410*
411 END IF
412*
413 ELSE
414*
415* N is even
416*
417 IF( normaltransr ) THEN
418*
419* N is even and TRANSR = 'N'
420*
421 IF( lower ) THEN
422*
423* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) )
424* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0)
425* T1 -> a(1), T2 -> a(0), S -> a(k+1); lda=n+1
426*
427 ij = 0
428 DO j = 0, k - 1
429 DO i = k, k + j
430 arf( ij ) = dconjg( a( k+j, i ) )
431 ij = ij + 1
432 END DO
433 DO i = j, n - 1
434 arf( ij ) = a( i, j )
435 ij = ij + 1
436 END DO
437 END DO
438*
439 ELSE
440*
441* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) )
442* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0)
443* T1 -> a(k+1), T2 -> a(k), S -> a(0); lda=n+1
444*
445 ij = nt - n - 1
446 DO j = n - 1, k, -1
447 DO i = 0, j
448 arf( ij ) = a( i, j )
449 ij = ij + 1
450 END DO
451 DO l = j - k, k - 1
452 arf( ij ) = dconjg( a( j-k, l ) )
453 ij = ij + 1
454 END DO
455 ij = ij - np1x2
456 END DO
457*
458 END IF
459*
460 ELSE
461*
462* N is even and TRANSR = 'C'
463*
464 IF( lower ) THEN
465*
466* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B)
467* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) :
468* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k
469*
470 ij = 0
471 j = k
472 DO i = k, n - 1
473 arf( ij ) = a( i, j )
474 ij = ij + 1
475 END DO
476 DO j = 0, k - 2
477 DO i = 0, j
478 arf( ij ) = dconjg( a( j, i ) )
479 ij = ij + 1
480 END DO
481 DO i = k + 1 + j, n - 1
482 arf( ij ) = a( i, k+1+j )
483 ij = ij + 1
484 END DO
485 END DO
486 DO j = k - 1, n - 1
487 DO i = 0, k - 1
488 arf( ij ) = dconjg( a( j, i ) )
489 ij = ij + 1
490 END DO
491 END DO
492*
493 ELSE
494*
495* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B)
496* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0)
497* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k
498*
499 ij = 0
500 DO j = 0, k
501 DO i = k, n - 1
502 arf( ij ) = dconjg( a( j, i ) )
503 ij = ij + 1
504 END DO
505 END DO
506 DO j = 0, k - 2
507 DO i = 0, j
508 arf( ij ) = a( i, j )
509 ij = ij + 1
510 END DO
511 DO l = k + 1 + j, n - 1
512 arf( ij ) = dconjg( a( k+1+j, l ) )
513 ij = ij + 1
514 END DO
515 END DO
516*
517* Note that here J = K-1
518*
519 DO i = 0, j
520 arf( ij ) = a( i, j )
521 ij = ij + 1
522 END DO
523*
524 END IF
525*
526 END IF
527*
528 END IF
529*
530 RETURN
531*
532* End of ZTRTTF
533*

◆ ztrttp()

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

ZTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (TP).

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

Purpose:
!>
!> ZTRTTP copies a triangular matrix A from full format (TR) to standard
!> packed format (TP).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices AP and A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the triangular 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.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]AP
!>          AP is COMPLEX*16 array, dimension ( N*(N+1)/2 ),
!>          On exit, 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.
!>
[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 103 of file ztrttp.f.

104*
105* -- LAPACK computational 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 INFO, N, LDA
112* ..
113* .. Array Arguments ..
114 COMPLEX*16 A( LDA, * ), AP( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120* ..
121* .. Local Scalars ..
122 LOGICAL LOWER
123 INTEGER I, J, K
124* ..
125* .. External Functions ..
126 LOGICAL LSAME
127 EXTERNAL lsame
128* ..
129* .. External Subroutines ..
130 EXTERNAL xerbla
131* ..
132* .. Executable Statements ..
133*
134* Test the input parameters.
135*
136 info = 0
137 lower = lsame( uplo, 'L' )
138 IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
139 info = -1
140 ELSE IF( n.LT.0 ) THEN
141 info = -2
142 ELSE IF( lda.LT.max( 1, n ) ) THEN
143 info = -4
144 END IF
145 IF( info.NE.0 ) THEN
146 CALL xerbla( 'ZTRTTP', -info )
147 RETURN
148 END IF
149*
150 IF( lower ) THEN
151 k = 0
152 DO j = 1, n
153 DO i = j, n
154 k = k + 1
155 ap( k ) = a( i, j )
156 END DO
157 END DO
158 ELSE
159 k = 0
160 DO j = 1, n
161 DO i = 1, j
162 k = k + 1
163 ap( k ) = a( i, j )
164 END DO
165 END DO
166 END IF
167*
168*
169 RETURN
170*
171* End of ZTRTTP
172*

◆ ztzrqf()

subroutine ztzrqf ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
integer info )

ZTZRQF

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine ZTZRZF.
!>
!> ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A
!> to upper triangular form by means of unitary transformations.
!>
!> The upper trapezoidal matrix A is factored as
!>
!>    A = ( R  0 ) * Z,
!>
!> where Z is an N-by-N unitary matrix and R is an M-by-M upper
!> triangular matrix.
!>
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 >= M.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the leading M-by-N upper trapezoidal part of the
!>          array A must contain the matrix to be factorized.
!>          On exit, the leading M-by-M upper triangular part of A
!>          contains the upper triangular matrix R, and elements M+1 to
!>          N of the first M rows of A, with the array TAU, represent the
!>          unitary matrix Z as a product of M elementary reflectors.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (M)
!>          The scalar factors of the elementary reflectors.
!>
[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.
Further Details:
!>
!>  The  factorization is obtained by Householder's method.  The kth
!>  transformation matrix, Z( k ), whose conjugate transpose is used to
!>  introduce zeros into the (m - k + 1)th row of A, is given in the form
!>
!>     Z( k ) = ( I     0   ),
!>              ( 0  T( k ) )
!>
!>  where
!>
!>     T( k ) = I - tau*u( k )*u( k )**H,   u( k ) = (   1    ),
!>                                                   (   0    )
!>                                                   ( z( k ) )
!>
!>  tau is a scalar and z( k ) is an ( n - m ) element vector.
!>  tau and z( k ) are chosen to annihilate the elements of the kth row
!>  of X.
!>
!>  The scalar tau is returned in the kth element of TAU and the vector
!>  u( k ) in the kth row of A, such that the elements of z( k ) are
!>  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
!>  the upper triangular part of A.
!>
!>  Z is given by
!>
!>     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
!>

Definition at line 137 of file ztzrqf.f.

138*
139* -- LAPACK computational routine --
140* -- LAPACK is a software package provided by Univ. of Tennessee, --
141* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
142*
143* .. Scalar Arguments ..
144 INTEGER INFO, LDA, M, N
145* ..
146* .. Array Arguments ..
147 COMPLEX*16 A( LDA, * ), TAU( * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 COMPLEX*16 CONE, CZERO
154 parameter( cone = ( 1.0d+0, 0.0d+0 ),
155 $ czero = ( 0.0d+0, 0.0d+0 ) )
156* ..
157* .. Local Scalars ..
158 INTEGER I, K, M1
159 COMPLEX*16 ALPHA
160* ..
161* .. Intrinsic Functions ..
162 INTRINSIC dconjg, max, min
163* ..
164* .. External Subroutines ..
165 EXTERNAL xerbla, zaxpy, zcopy, zgemv, zgerc, zlacgv,
166 $ zlarfg
167* ..
168* .. Executable Statements ..
169*
170* Test the input parameters.
171*
172 info = 0
173 IF( m.LT.0 ) THEN
174 info = -1
175 ELSE IF( n.LT.m ) THEN
176 info = -2
177 ELSE IF( lda.LT.max( 1, m ) ) THEN
178 info = -4
179 END IF
180 IF( info.NE.0 ) THEN
181 CALL xerbla( 'ZTZRQF', -info )
182 RETURN
183 END IF
184*
185* Perform the factorization.
186*
187 IF( m.EQ.0 )
188 $ RETURN
189 IF( m.EQ.n ) THEN
190 DO 10 i = 1, n
191 tau( i ) = czero
192 10 CONTINUE
193 ELSE
194 m1 = min( m+1, n )
195 DO 20 k = m, 1, -1
196*
197* Use a Householder reflection to zero the kth row of A.
198* First set up the reflection.
199*
200 a( k, k ) = dconjg( a( k, k ) )
201 CALL zlacgv( n-m, a( k, m1 ), lda )
202 alpha = a( k, k )
203 CALL zlarfg( n-m+1, alpha, a( k, m1 ), lda, tau( k ) )
204 a( k, k ) = alpha
205 tau( k ) = dconjg( tau( k ) )
206*
207 IF( tau( k ).NE.czero .AND. k.GT.1 ) THEN
208*
209* We now perform the operation A := A*P( k )**H.
210*
211* Use the first ( k - 1 ) elements of TAU to store a( k ),
212* where a( k ) consists of the first ( k - 1 ) elements of
213* the kth column of A. Also let B denote the first
214* ( k - 1 ) rows of the last ( n - m ) columns of A.
215*
216 CALL zcopy( k-1, a( 1, k ), 1, tau, 1 )
217*
218* Form w = a( k ) + B*z( k ) in TAU.
219*
220 CALL zgemv( 'No transpose', k-1, n-m, cone, a( 1, m1 ),
221 $ lda, a( k, m1 ), lda, cone, tau, 1 )
222*
223* Now form a( k ) := a( k ) - conjg(tau)*w
224* and B := B - conjg(tau)*w*z( k )**H.
225*
226 CALL zaxpy( k-1, -dconjg( tau( k ) ), tau, 1, a( 1, k ),
227 $ 1 )
228 CALL zgerc( k-1, n-m, -dconjg( tau( k ) ), tau, 1,
229 $ a( k, m1 ), lda, a( 1, m1 ), lda )
230 END IF
231 20 CONTINUE
232 END IF
233*
234 RETURN
235*
236* End of ZTZRQF
237*

◆ ztzrzf()

subroutine ztzrzf ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZTZRZF

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

Purpose:
!>
!> ZTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A
!> to upper triangular form by means of unitary transformations.
!>
!> The upper trapezoidal matrix A is factored as
!>
!>    A = ( R  0 ) * Z,
!>
!> where Z is an N-by-N unitary matrix and R is an M-by-M upper
!> triangular matrix.
!>
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 >= M.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the leading M-by-N upper trapezoidal part of the
!>          array A must contain the matrix to be factorized.
!>          On exit, the leading M-by-M upper triangular part of A
!>          contains the upper triangular matrix R, and elements M+1 to
!>          N of the first M rows of A, with the array TAU, represent the
!>          unitary matrix Z as a product of M elementary reflectors.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (M)
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,M).
!>          For optimum performance LWORK >= M*NB, where NB is
!>          the optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
Further Details:
!>
!>  The N-by-N matrix Z can be computed by
!>
!>     Z =  Z(1)*Z(2)* ... *Z(M)
!>
!>  where each N-by-N Z(k) is given by
!>
!>     Z(k) = I - tau(k)*v(k)*v(k)**H
!>
!>  with v(k) is the kth row vector of the M-by-N matrix
!>
!>     V = ( I   A(:,M+1:N) )
!>
!>  I is the M-by-M identity matrix, A(:,M+1:N)
!>  is the output stored in A on exit from ZTZRZF,
!>  and tau(k) is the kth element of the array TAU.
!>
!>

Definition at line 150 of file ztzrzf.f.

151*
152* -- LAPACK computational routine --
153* -- LAPACK is a software package provided by Univ. of Tennessee, --
154* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
155*
156* .. Scalar Arguments ..
157 INTEGER INFO, LDA, LWORK, M, N
158* ..
159* .. Array Arguments ..
160 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 COMPLEX*16 ZERO
167 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
168* ..
169* .. Local Scalars ..
170 LOGICAL LQUERY
171 INTEGER I, IB, IWS, KI, KK, LDWORK, LWKMIN, LWKOPT,
172 $ M1, MU, NB, NBMIN, NX
173* ..
174* .. External Subroutines ..
175 EXTERNAL xerbla, zlarzb, zlarzt, zlatrz
176* ..
177* .. Intrinsic Functions ..
178 INTRINSIC max, min
179* ..
180* .. External Functions ..
181 INTEGER ILAENV
182 EXTERNAL ilaenv
183* ..
184* .. Executable Statements ..
185*
186* Test the input arguments
187*
188 info = 0
189 lquery = ( lwork.EQ.-1 )
190 IF( m.LT.0 ) THEN
191 info = -1
192 ELSE IF( n.LT.m ) THEN
193 info = -2
194 ELSE IF( lda.LT.max( 1, m ) ) THEN
195 info = -4
196 END IF
197*
198 IF( info.EQ.0 ) THEN
199 IF( m.EQ.0 .OR. m.EQ.n ) THEN
200 lwkopt = 1
201 lwkmin = 1
202 ELSE
203*
204* Determine the block size.
205*
206 nb = ilaenv( 1, 'ZGERQF', ' ', m, n, -1, -1 )
207 lwkopt = m*nb
208 lwkmin = max( 1, m )
209 END IF
210 work( 1 ) = lwkopt
211*
212 IF( lwork.LT.lwkmin .AND. .NOT.lquery ) THEN
213 info = -7
214 END IF
215 END IF
216*
217 IF( info.NE.0 ) THEN
218 CALL xerbla( 'ZTZRZF', -info )
219 RETURN
220 ELSE IF( lquery ) THEN
221 RETURN
222 END IF
223*
224* Quick return if possible
225*
226 IF( m.EQ.0 ) THEN
227 RETURN
228 ELSE IF( m.EQ.n ) THEN
229 DO 10 i = 1, n
230 tau( i ) = zero
231 10 CONTINUE
232 RETURN
233 END IF
234*
235 nbmin = 2
236 nx = 1
237 iws = m
238 IF( nb.GT.1 .AND. nb.LT.m ) THEN
239*
240* Determine when to cross over from blocked to unblocked code.
241*
242 nx = max( 0, ilaenv( 3, 'ZGERQF', ' ', m, n, -1, -1 ) )
243 IF( nx.LT.m ) THEN
244*
245* Determine if workspace is large enough for blocked code.
246*
247 ldwork = m
248 iws = ldwork*nb
249 IF( lwork.LT.iws ) THEN
250*
251* Not enough workspace to use optimal NB: reduce NB and
252* determine the minimum value of NB.
253*
254 nb = lwork / ldwork
255 nbmin = max( 2, ilaenv( 2, 'ZGERQF', ' ', m, n, -1,
256 $ -1 ) )
257 END IF
258 END IF
259 END IF
260*
261 IF( nb.GE.nbmin .AND. nb.LT.m .AND. nx.LT.m ) THEN
262*
263* Use blocked code initially.
264* The last kk rows are handled by the block method.
265*
266 m1 = min( m+1, n )
267 ki = ( ( m-nx-1 ) / nb )*nb
268 kk = min( m, ki+nb )
269*
270 DO 20 i = m - kk + ki + 1, m - kk + 1, -nb
271 ib = min( m-i+1, nb )
272*
273* Compute the TZ factorization of the current block
274* A(i:i+ib-1,i:n)
275*
276 CALL zlatrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),
277 $ work )
278 IF( i.GT.1 ) THEN
279*
280* Form the triangular factor of the block reflector
281* H = H(i+ib-1) . . . H(i+1) H(i)
282*
283 CALL zlarzt( 'Backward', 'Rowwise', n-m, ib, a( i, m1 ),
284 $ lda, tau( i ), work, ldwork )
285*
286* Apply H to A(1:i-1,i:n) from the right
287*
288 CALL zlarzb( 'Right', 'No transpose', 'Backward',
289 $ 'Rowwise', i-1, n-i+1, ib, n-m, a( i, m1 ),
290 $ lda, work, ldwork, a( 1, i ), lda,
291 $ work( ib+1 ), ldwork )
292 END IF
293 20 CONTINUE
294 mu = i + nb - 1
295 ELSE
296 mu = m
297 END IF
298*
299* Use unblocked code to factor the last or only block
300*
301 IF( mu.GT.0 )
302 $ CALL zlatrz( mu, n, n-m, a, lda, tau, work )
303*
304 work( 1 ) = lwkopt
305*
306 RETURN
307*
308* End of ZTZRZF
309*
zlarzt
subroutine zlarzt(direct, storev, n, k, v, ldv, tau, t, ldt)
ZLARZT forms the triangular factor T of a block reflector H = I - vtvH.
Definition zlarzt.f:185
zlarzb
subroutine zlarzb(side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, c, ldc, work, ldwork)
ZLARZB applies a block reflector or its conjugate-transpose to a general matrix.
Definition zlarzb.f:183
zlatrz
subroutine zlatrz(m, n, l, a, lda, tau, work)
ZLATRZ factors an upper trapezoidal matrix by means of unitary transformations.
Definition zlatrz.f:140

◆ zunbdb()

subroutine zunbdb ( character trans,
character signs,
integer m,
integer p,
integer q,
complex*16, dimension( ldx11, * ) x11,
integer ldx11,
complex*16, dimension( ldx12, * ) x12,
integer ldx12,
complex*16, dimension( ldx21, * ) x21,
integer ldx21,
complex*16, dimension( ldx22, * ) x22,
integer ldx22,
double precision, dimension( * ) theta,
double precision, dimension( * ) phi,
complex*16, dimension( * ) taup1,
complex*16, dimension( * ) taup2,
complex*16, dimension( * ) tauq1,
complex*16, dimension( * ) tauq2,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNBDB

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

Purpose:
!>
!> ZUNBDB simultaneously bidiagonalizes the blocks of an M-by-M
!> partitioned unitary matrix X:
!>
!>                                 [ B11 | B12 0  0 ]
!>     [ X11 | X12 ]   [ P1 |    ] [  0  |  0 -I  0 ] [ Q1 |    ]**H
!> X = [-----------] = [---------] [----------------] [---------]   .
!>     [ X21 | X22 ]   [    | P2 ] [ B21 | B22 0  0 ] [    | Q2 ]
!>                                 [  0  |  0  0  I ]
!>
!> X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is
!> not the case, then X must be transposed and/or permuted. This can be
!> done in constant time using the TRANS and SIGNS options. See ZUNCSD
!> for details.)
!>
!> The unitary matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-
!> (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are
!> represented implicitly by Householder vectors.
!>
!> B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented
!> implicitly by angles THETA, PHI.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER
!>          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major
!>                      order;
!>          otherwise:  X, U1, U2, V1T, and V2T are stored in column-
!>                      major order.
!>
[in]SIGNS
!>          SIGNS is CHARACTER
!>          = 'O':      The lower-left block is made nonpositive (the
!>                       convention);
!>          otherwise:  The upper-right block is made nonpositive (the
!>                       convention).
!>
[in]M
!>          M is INTEGER
!>          The number of rows and columns in X.
!>
[in]P
!>          P is INTEGER
!>          The number of rows in X11 and X12. 0 <= P <= M.
!>
[in]Q
!>          Q is INTEGER
!>          The number of columns in X11 and X21. 0 <= Q <=
!>          MIN(P,M-P,M-Q).
!>
[in,out]X11
!>          X11 is COMPLEX*16 array, dimension (LDX11,Q)
!>          On entry, the top-left block of the unitary matrix to be
!>          reduced. On exit, the form depends on TRANS:
!>          If TRANS = 'N', then
!>             the columns of tril(X11) specify reflectors for P1,
!>             the rows of triu(X11,1) specify reflectors for Q1;
!>          else TRANS = 'T', and
!>             the rows of triu(X11) specify reflectors for P1,
!>             the columns of tril(X11,-1) specify reflectors for Q1.
!>
[in]LDX11
!>          LDX11 is INTEGER
!>          The leading dimension of X11. If TRANS = 'N', then LDX11 >=
!>          P; else LDX11 >= Q.
!>
[in,out]X12
!>          X12 is COMPLEX*16 array, dimension (LDX12,M-Q)
!>          On entry, the top-right block of the unitary matrix to
!>          be reduced. On exit, the form depends on TRANS:
!>          If TRANS = 'N', then
!>             the rows of triu(X12) specify the first P reflectors for
!>             Q2;
!>          else TRANS = 'T', and
!>             the columns of tril(X12) specify the first P reflectors
!>             for Q2.
!>
[in]LDX12
!>          LDX12 is INTEGER
!>          The leading dimension of X12. If TRANS = 'N', then LDX12 >=
!>          P; else LDX11 >= M-Q.
!>
[in,out]X21
!>          X21 is COMPLEX*16 array, dimension (LDX21,Q)
!>          On entry, the bottom-left block of the unitary matrix to
!>          be reduced. On exit, the form depends on TRANS:
!>          If TRANS = 'N', then
!>             the columns of tril(X21) specify reflectors for P2;
!>          else TRANS = 'T', and
!>             the rows of triu(X21) specify reflectors for P2.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>          The leading dimension of X21. If TRANS = 'N', then LDX21 >=
!>          M-P; else LDX21 >= Q.
!>
[in,out]X22
!>          X22 is COMPLEX*16 array, dimension (LDX22,M-Q)
!>          On entry, the bottom-right block of the unitary matrix to
!>          be reduced. On exit, the form depends on TRANS:
!>          If TRANS = 'N', then
!>             the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last
!>             M-P-Q reflectors for Q2,
!>          else TRANS = 'T', and
!>             the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last
!>             M-P-Q reflectors for P2.
!>
[in]LDX22
!>          LDX22 is INTEGER
!>          The leading dimension of X22. If TRANS = 'N', then LDX22 >=
!>          M-P; else LDX22 >= M-Q.
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (Q)
!>          The entries of the bidiagonal blocks B11, B12, B21, B22 can
!>          be computed from the angles THETA and PHI. See Further
!>          Details.
!>
[out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>          The entries of the bidiagonal blocks B11, B12, B21, B22 can
!>          be computed from the angles THETA and PHI. See Further
!>          Details.
!>
[out]TAUP1
!>          TAUP1 is COMPLEX*16 array, dimension (P)
!>          The scalar factors of the elementary reflectors that define
!>          P1.
!>
[out]TAUP2
!>          TAUP2 is COMPLEX*16 array, dimension (M-P)
!>          The scalar factors of the elementary reflectors that define
!>          P2.
!>
[out]TAUQ1
!>          TAUQ1 is COMPLEX*16 array, dimension (Q)
!>          The scalar factors of the elementary reflectors that define
!>          Q1.
!>
[out]TAUQ2
!>          TAUQ2 is COMPLEX*16 array, dimension (M-Q)
!>          The scalar factors of the elementary reflectors that define
!>          Q2.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= M-Q.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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.
Further Details:
!>
!>  The bidiagonal blocks B11, B12, B21, and B22 are represented
!>  implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,
!>  PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are
!>  lower bidiagonal. Every entry in each bidiagonal band is a product
!>  of a sine or cosine of a THETA with a sine or cosine of a PHI. See
!>  [1] or ZUNCSD for details.
!>
!>  P1, P2, Q1, and Q2 are represented as products of elementary
!>  reflectors. See ZUNCSD for details on generating P1, P2, Q1, and Q2
!>  using ZUNGQR and ZUNGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 284 of file zunbdb.f.

287*
288* -- LAPACK computational routine --
289* -- LAPACK is a software package provided by Univ. of Tennessee, --
290* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
291*
292* .. Scalar Arguments ..
293 CHARACTER SIGNS, TRANS
294 INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P,
295 $ Q
296* ..
297* .. Array Arguments ..
298 DOUBLE PRECISION PHI( * ), THETA( * )
299 COMPLEX*16 TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ),
300 $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ),
301 $ X21( LDX21, * ), X22( LDX22, * )
302* ..
303*
304* ====================================================================
305*
306* .. Parameters ..
307 DOUBLE PRECISION REALONE
308 parameter( realone = 1.0d0 )
309 COMPLEX*16 ONE
310 parameter( one = (1.0d0,0.0d0) )
311* ..
312* .. Local Scalars ..
313 LOGICAL COLMAJOR, LQUERY
314 INTEGER I, LWORKMIN, LWORKOPT
315 DOUBLE PRECISION Z1, Z2, Z3, Z4
316* ..
317* .. External Subroutines ..
318 EXTERNAL zaxpy, zlarf, zlarfgp, zscal, xerbla
319 EXTERNAL zlacgv
320*
321* ..
322* .. External Functions ..
323 DOUBLE PRECISION DZNRM2
324 LOGICAL LSAME
325 EXTERNAL dznrm2, lsame
326* ..
327* .. Intrinsic Functions
328 INTRINSIC atan2, cos, max, min, sin
329 INTRINSIC dcmplx, dconjg
330* ..
331* .. Executable Statements ..
332*
333* Test input arguments
334*
335 info = 0
336 colmajor = .NOT. lsame( trans, 'T' )
337 IF( .NOT. lsame( signs, 'O' ) ) THEN
338 z1 = realone
339 z2 = realone
340 z3 = realone
341 z4 = realone
342 ELSE
343 z1 = realone
344 z2 = -realone
345 z3 = realone
346 z4 = -realone
347 END IF
348 lquery = lwork .EQ. -1
349*
350 IF( m .LT. 0 ) THEN
351 info = -3
352 ELSE IF( p .LT. 0 .OR. p .GT. m ) THEN
353 info = -4
354 ELSE IF( q .LT. 0 .OR. q .GT. p .OR. q .GT. m-p .OR.
355 $ q .GT. m-q ) THEN
356 info = -5
357 ELSE IF( colmajor .AND. ldx11 .LT. max( 1, p ) ) THEN
358 info = -7
359 ELSE IF( .NOT.colmajor .AND. ldx11 .LT. max( 1, q ) ) THEN
360 info = -7
361 ELSE IF( colmajor .AND. ldx12 .LT. max( 1, p ) ) THEN
362 info = -9
363 ELSE IF( .NOT.colmajor .AND. ldx12 .LT. max( 1, m-q ) ) THEN
364 info = -9
365 ELSE IF( colmajor .AND. ldx21 .LT. max( 1, m-p ) ) THEN
366 info = -11
367 ELSE IF( .NOT.colmajor .AND. ldx21 .LT. max( 1, q ) ) THEN
368 info = -11
369 ELSE IF( colmajor .AND. ldx22 .LT. max( 1, m-p ) ) THEN
370 info = -13
371 ELSE IF( .NOT.colmajor .AND. ldx22 .LT. max( 1, m-q ) ) THEN
372 info = -13
373 END IF
374*
375* Compute workspace
376*
377 IF( info .EQ. 0 ) THEN
378 lworkopt = m - q
379 lworkmin = m - q
380 work(1) = lworkopt
381 IF( lwork .LT. lworkmin .AND. .NOT. lquery ) THEN
382 info = -21
383 END IF
384 END IF
385 IF( info .NE. 0 ) THEN
386 CALL xerbla( 'xORBDB', -info )
387 RETURN
388 ELSE IF( lquery ) THEN
389 RETURN
390 END IF
391*
392* Handle column-major and row-major separately
393*
394 IF( colmajor ) THEN
395*
396* Reduce columns 1, ..., Q of X11, X12, X21, and X22
397*
398 DO i = 1, q
399*
400 IF( i .EQ. 1 ) THEN
401 CALL zscal( p-i+1, dcmplx( z1, 0.0d0 ), x11(i,i), 1 )
402 ELSE
403 CALL zscal( p-i+1, dcmplx( z1*cos(phi(i-1)), 0.0d0 ),
404 $ x11(i,i), 1 )
405 CALL zaxpy( p-i+1, dcmplx( -z1*z3*z4*sin(phi(i-1)),
406 $ 0.0d0 ), x12(i,i-1), 1, x11(i,i), 1 )
407 END IF
408 IF( i .EQ. 1 ) THEN
409 CALL zscal( m-p-i+1, dcmplx( z2, 0.0d0 ), x21(i,i), 1 )
410 ELSE
411 CALL zscal( m-p-i+1, dcmplx( z2*cos(phi(i-1)), 0.0d0 ),
412 $ x21(i,i), 1 )
413 CALL zaxpy( m-p-i+1, dcmplx( -z2*z3*z4*sin(phi(i-1)),
414 $ 0.0d0 ), x22(i,i-1), 1, x21(i,i), 1 )
415 END IF
416*
417 theta(i) = atan2( dznrm2( m-p-i+1, x21(i,i), 1 ),
418 $ dznrm2( p-i+1, x11(i,i), 1 ) )
419*
420 IF( p .GT. i ) THEN
421 CALL zlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
422 ELSE IF ( p .EQ. i ) THEN
423 CALL zlarfgp( p-i+1, x11(i,i), x11(i,i), 1, taup1(i) )
424 END IF
425 x11(i,i) = one
426 IF ( m-p .GT. i ) THEN
427 CALL zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1,
428 $ taup2(i) )
429 ELSE IF ( m-p .EQ. i ) THEN
430 CALL zlarfgp( m-p-i+1, x21(i,i), x21(i,i), 1,
431 $ taup2(i) )
432 END IF
433 x21(i,i) = one
434*
435 IF ( q .GT. i ) THEN
436 CALL zlarf( 'L', p-i+1, q-i, x11(i,i), 1,
437 $ dconjg(taup1(i)), x11(i,i+1), ldx11, work )
438 CALL zlarf( 'L', m-p-i+1, q-i, x21(i,i), 1,
439 $ dconjg(taup2(i)), x21(i,i+1), ldx21, work )
440 END IF
441 IF ( m-q+1 .GT. i ) THEN
442 CALL zlarf( 'L', p-i+1, m-q-i+1, x11(i,i), 1,
443 $ dconjg(taup1(i)), x12(i,i), ldx12, work )
444 CALL zlarf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1,
445 $ dconjg(taup2(i)), x22(i,i), ldx22, work )
446 END IF
447*
448 IF( i .LT. q ) THEN
449 CALL zscal( q-i, dcmplx( -z1*z3*sin(theta(i)), 0.0d0 ),
450 $ x11(i,i+1), ldx11 )
451 CALL zaxpy( q-i, dcmplx( z2*z3*cos(theta(i)), 0.0d0 ),
452 $ x21(i,i+1), ldx21, x11(i,i+1), ldx11 )
453 END IF
454 CALL zscal( m-q-i+1, dcmplx( -z1*z4*sin(theta(i)), 0.0d0 ),
455 $ x12(i,i), ldx12 )
456 CALL zaxpy( m-q-i+1, dcmplx( z2*z4*cos(theta(i)), 0.0d0 ),
457 $ x22(i,i), ldx22, x12(i,i), ldx12 )
458*
459 IF( i .LT. q )
460 $ phi(i) = atan2( dznrm2( q-i, x11(i,i+1), ldx11 ),
461 $ dznrm2( m-q-i+1, x12(i,i), ldx12 ) )
462*
463 IF( i .LT. q ) THEN
464 CALL zlacgv( q-i, x11(i,i+1), ldx11 )
465 IF ( i .EQ. q-1 ) THEN
466 CALL zlarfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,
467 $ tauq1(i) )
468 ELSE
469 CALL zlarfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,
470 $ tauq1(i) )
471 END IF
472 x11(i,i+1) = one
473 END IF
474 IF ( m-q+1 .GT. i ) THEN
475 CALL zlacgv( m-q-i+1, x12(i,i), ldx12 )
476 IF ( m-q .EQ. i ) THEN
477 CALL zlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,
478 $ tauq2(i) )
479 ELSE
480 CALL zlarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,
481 $ tauq2(i) )
482 END IF
483 END IF
484 x12(i,i) = one
485*
486 IF( i .LT. q ) THEN
487 CALL zlarf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),
488 $ x11(i+1,i+1), ldx11, work )
489 CALL zlarf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),
490 $ x21(i+1,i+1), ldx21, work )
491 END IF
492 IF ( p .GT. i ) THEN
493 CALL zlarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),
494 $ x12(i+1,i), ldx12, work )
495 END IF
496 IF ( m-p .GT. i ) THEN
497 CALL zlarf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,
498 $ tauq2(i), x22(i+1,i), ldx22, work )
499 END IF
500*
501 IF( i .LT. q )
502 $ CALL zlacgv( q-i, x11(i,i+1), ldx11 )
503 CALL zlacgv( m-q-i+1, x12(i,i), ldx12 )
504*
505 END DO
506*
507* Reduce columns Q + 1, ..., P of X12, X22
508*
509 DO i = q + 1, p
510*
511 CALL zscal( m-q-i+1, dcmplx( -z1*z4, 0.0d0 ), x12(i,i),
512 $ ldx12 )
513 CALL zlacgv( m-q-i+1, x12(i,i), ldx12 )
514 IF ( i .GE. m-q ) THEN
515 CALL zlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,
516 $ tauq2(i) )
517 ELSE
518 CALL zlarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,
519 $ tauq2(i) )
520 END IF
521 x12(i,i) = one
522*
523 IF ( p .GT. i ) THEN
524 CALL zlarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),
525 $ x12(i+1,i), ldx12, work )
526 END IF
527 IF( m-p-q .GE. 1 )
528 $ CALL zlarf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,
529 $ tauq2(i), x22(q+1,i), ldx22, work )
530*
531 CALL zlacgv( m-q-i+1, x12(i,i), ldx12 )
532*
533 END DO
534*
535* Reduce columns P + 1, ..., M - Q of X12, X22
536*
537 DO i = 1, m - p - q
538*
539 CALL zscal( m-p-q-i+1, dcmplx( z2*z4, 0.0d0 ),
540 $ x22(q+i,p+i), ldx22 )
541 CALL zlacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 )
542 CALL zlarfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),
543 $ ldx22, tauq2(p+i) )
544 x22(q+i,p+i) = one
545 CALL zlarf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,
546 $ tauq2(p+i), x22(q+i+1,p+i), ldx22, work )
547*
548 CALL zlacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 )
549*
550 END DO
551*
552 ELSE
553*
554* Reduce columns 1, ..., Q of X11, X12, X21, X22
555*
556 DO i = 1, q
557*
558 IF( i .EQ. 1 ) THEN
559 CALL zscal( p-i+1, dcmplx( z1, 0.0d0 ), x11(i,i),
560 $ ldx11 )
561 ELSE
562 CALL zscal( p-i+1, dcmplx( z1*cos(phi(i-1)), 0.0d0 ),
563 $ x11(i,i), ldx11 )
564 CALL zaxpy( p-i+1, dcmplx( -z1*z3*z4*sin(phi(i-1)),
565 $ 0.0d0 ), x12(i-1,i), ldx12, x11(i,i), ldx11 )
566 END IF
567 IF( i .EQ. 1 ) THEN
568 CALL zscal( m-p-i+1, dcmplx( z2, 0.0d0 ), x21(i,i),
569 $ ldx21 )
570 ELSE
571 CALL zscal( m-p-i+1, dcmplx( z2*cos(phi(i-1)), 0.0d0 ),
572 $ x21(i,i), ldx21 )
573 CALL zaxpy( m-p-i+1, dcmplx( -z2*z3*z4*sin(phi(i-1)),
574 $ 0.0d0 ), x22(i-1,i), ldx22, x21(i,i), ldx21 )
575 END IF
576*
577 theta(i) = atan2( dznrm2( m-p-i+1, x21(i,i), ldx21 ),
578 $ dznrm2( p-i+1, x11(i,i), ldx11 ) )
579*
580 CALL zlacgv( p-i+1, x11(i,i), ldx11 )
581 CALL zlacgv( m-p-i+1, x21(i,i), ldx21 )
582*
583 CALL zlarfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) )
584 x11(i,i) = one
585 IF ( i .EQ. m-p ) THEN
586 CALL zlarfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,
587 $ taup2(i) )
588 ELSE
589 CALL zlarfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,
590 $ taup2(i) )
591 END IF
592 x21(i,i) = one
593*
594 CALL zlarf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),
595 $ x11(i+1,i), ldx11, work )
596 CALL zlarf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11, taup1(i),
597 $ x12(i,i), ldx12, work )
598 CALL zlarf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),
599 $ x21(i+1,i), ldx21, work )
600 CALL zlarf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,
601 $ taup2(i), x22(i,i), ldx22, work )
602*
603 CALL zlacgv( p-i+1, x11(i,i), ldx11 )
604 CALL zlacgv( m-p-i+1, x21(i,i), ldx21 )
605*
606 IF( i .LT. q ) THEN
607 CALL zscal( q-i, dcmplx( -z1*z3*sin(theta(i)), 0.0d0 ),
608 $ x11(i+1,i), 1 )
609 CALL zaxpy( q-i, dcmplx( z2*z3*cos(theta(i)), 0.0d0 ),
610 $ x21(i+1,i), 1, x11(i+1,i), 1 )
611 END IF
612 CALL zscal( m-q-i+1, dcmplx( -z1*z4*sin(theta(i)), 0.0d0 ),
613 $ x12(i,i), 1 )
614 CALL zaxpy( m-q-i+1, dcmplx( z2*z4*cos(theta(i)), 0.0d0 ),
615 $ x22(i,i), 1, x12(i,i), 1 )
616*
617 IF( i .LT. q )
618 $ phi(i) = atan2( dznrm2( q-i, x11(i+1,i), 1 ),
619 $ dznrm2( m-q-i+1, x12(i,i), 1 ) )
620*
621 IF( i .LT. q ) THEN
622 CALL zlarfgp( q-i, x11(i+1,i), x11(i+2,i), 1, tauq1(i) )
623 x11(i+1,i) = one
624 END IF
625 CALL zlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) )
626 x12(i,i) = one
627*
628 IF( i .LT. q ) THEN
629 CALL zlarf( 'L', q-i, p-i, x11(i+1,i), 1,
630 $ dconjg(tauq1(i)), x11(i+1,i+1), ldx11, work )
631 CALL zlarf( 'L', q-i, m-p-i, x11(i+1,i), 1,
632 $ dconjg(tauq1(i)), x21(i+1,i+1), ldx21, work )
633 END IF
634 CALL zlarf( 'L', m-q-i+1, p-i, x12(i,i), 1,
635 $ dconjg(tauq2(i)), x12(i,i+1), ldx12, work )
636 IF ( m-p .GT. i ) THEN
637 CALL zlarf( 'L', m-q-i+1, m-p-i, x12(i,i), 1,
638 $ dconjg(tauq2(i)), x22(i,i+1), ldx22, work )
639 END IF
640*
641 END DO
642*
643* Reduce columns Q + 1, ..., P of X12, X22
644*
645 DO i = q + 1, p
646*
647 CALL zscal( m-q-i+1, dcmplx( -z1*z4, 0.0d0 ), x12(i,i), 1 )
648 CALL zlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) )
649 x12(i,i) = one
650*
651 IF ( p .GT. i ) THEN
652 CALL zlarf( 'L', m-q-i+1, p-i, x12(i,i), 1,
653 $ dconjg(tauq2(i)), x12(i,i+1), ldx12, work )
654 END IF
655 IF( m-p-q .GE. 1 )
656 $ CALL zlarf( 'L', m-q-i+1, m-p-q, x12(i,i), 1,
657 $ dconjg(tauq2(i)), x22(i,q+1), ldx22, work )
658*
659 END DO
660*
661* Reduce columns P + 1, ..., M - Q of X12, X22
662*
663 DO i = 1, m - p - q
664*
665 CALL zscal( m-p-q-i+1, dcmplx( z2*z4, 0.0d0 ),
666 $ x22(p+i,q+i), 1 )
667 CALL zlarfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1,
668 $ tauq2(p+i) )
669 x22(p+i,q+i) = one
670*
671 IF ( m-p-q .NE. i ) THEN
672 CALL zlarf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1,
673 $ dconjg(tauq2(p+i)), x22(p+i,q+i+1), ldx22,
674 $ work )
675 END IF
676*
677 END DO
678*
679 END IF
680*
681 RETURN
682*
683* End of ZUNBDB
684*
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
zlarfgp
subroutine zlarfgp(n, alpha, x, incx, tau)
ZLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.
Definition zlarfgp.f:104

◆ zunbdb1()

subroutine zunbdb1 ( integer m,
integer p,
integer q,
complex*16, dimension(ldx11,*) x11,
integer ldx11,
complex*16, dimension(ldx21,*) x21,
integer ldx21,
double precision, dimension(*) theta,
double precision, dimension(*) phi,
complex*16, dimension(*) taup1,
complex*16, dimension(*) taup2,
complex*16, dimension(*) tauq1,
complex*16, dimension(*) work,
integer lwork,
integer info )

ZUNBDB1

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

Purpose:
!>
!> ZUNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
!> matrix X with orthonomal columns:
!>
!>                            [ B11 ]
!>      [ X11 ]   [ P1 |    ] [  0  ]
!>      [-----] = [---------] [-----] Q1**T .
!>      [ X21 ]   [    | P2 ] [ B21 ]
!>                            [  0  ]
!>
!> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
!> M-P, or M-Q. Routines ZUNBDB2, ZUNBDB3, and ZUNBDB4 handle cases in
!> which Q is not the minimum dimension.
!>
!> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
!> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
!> Householder vectors.
!>
!> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
!> angles THETA, PHI.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>           The number of rows X11 plus the number of rows in X21.
!>
[in]P
!>          P is INTEGER
!>           The number of rows in X11. 0 <= P <= M.
!>
[in]Q
!>          Q is INTEGER
!>           The number of columns in X11 and X21. 0 <= Q <=
!>           MIN(P,M-P,M-Q).
!>
[in,out]X11
!>          X11 is COMPLEX*16 array, dimension (LDX11,Q)
!>           On entry, the top block of the matrix X to be reduced. On
!>           exit, the columns of tril(X11) specify reflectors for P1 and
!>           the rows of triu(X11,1) specify reflectors for Q1.
!>
[in]LDX11
!>          LDX11 is INTEGER
!>           The leading dimension of X11. LDX11 >= P.
!>
[in,out]X21
!>          X21 is COMPLEX*16 array, dimension (LDX21,Q)
!>           On entry, the bottom block of the matrix X to be reduced. On
!>           exit, the columns of tril(X21) specify reflectors for P2.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>           The leading dimension of X21. LDX21 >= M-P.
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]TAUP1
!>          TAUP1 is COMPLEX*16 array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is COMPLEX*16 array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is COMPLEX*16 array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>           The dimension of the array WORK. LWORK >= M-Q.
!>
!>           If LWORK = -1, then a workspace query is assumed; the routine
!>           only calculates the optimal size of the WORK array, returns
!>           this value as the first entry of the WORK array, and no error
!>           message related to LWORK is issued by XERBLA.
!>
[out]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.
Further Details:
!>
!>  The upper-bidiagonal blocks B11, B21 are represented implicitly by
!>  angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
!>  in each bidiagonal band is a product of a sine or cosine of a THETA
!>  with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
!>  and ZUNGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 201 of file zunbdb1.f.

203*
204* -- LAPACK computational routine --
205* -- LAPACK is a software package provided by Univ. of Tennessee, --
206* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
207*
208* .. Scalar Arguments ..
209 INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
210* ..
211* .. Array Arguments ..
212 DOUBLE PRECISION PHI(*), THETA(*)
213 COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
214 $ X11(LDX11,*), X21(LDX21,*)
215* ..
216*
217* ====================================================================
218*
219* .. Parameters ..
220 COMPLEX*16 ONE
221 parameter( one = (1.0d0,0.0d0) )
222* ..
223* .. Local Scalars ..
224 DOUBLE PRECISION C, S
225 INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
226 $ LWORKMIN, LWORKOPT
227 LOGICAL LQUERY
228* ..
229* .. External Subroutines ..
230 EXTERNAL zlarf, zlarfgp, zunbdb5, zdrot, xerbla
231 EXTERNAL zlacgv
232* ..
233* .. External Functions ..
234 DOUBLE PRECISION DZNRM2
235 EXTERNAL dznrm2
236* ..
237* .. Intrinsic Function ..
238 INTRINSIC atan2, cos, max, sin, sqrt
239* ..
240* .. Executable Statements ..
241*
242* Test input arguments
243*
244 info = 0
245 lquery = lwork .EQ. -1
246*
247 IF( m .LT. 0 ) THEN
248 info = -1
249 ELSE IF( p .LT. q .OR. m-p .LT. q ) THEN
250 info = -2
251 ELSE IF( q .LT. 0 .OR. m-q .LT. q ) THEN
252 info = -3
253 ELSE IF( ldx11 .LT. max( 1, p ) ) THEN
254 info = -5
255 ELSE IF( ldx21 .LT. max( 1, m-p ) ) THEN
256 info = -7
257 END IF
258*
259* Compute workspace
260*
261 IF( info .EQ. 0 ) THEN
262 ilarf = 2
263 llarf = max( p-1, m-p-1, q-1 )
264 iorbdb5 = 2
265 lorbdb5 = q-2
266 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 )
267 lworkmin = lworkopt
268 work(1) = lworkopt
269 IF( lwork .LT. lworkmin .AND. .NOT.lquery ) THEN
270 info = -14
271 END IF
272 END IF
273 IF( info .NE. 0 ) THEN
274 CALL xerbla( 'ZUNBDB1', -info )
275 RETURN
276 ELSE IF( lquery ) THEN
277 RETURN
278 END IF
279*
280* Reduce columns 1, ..., Q of X11 and X21
281*
282 DO i = 1, q
283*
284 CALL zlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
285 CALL zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
286 theta(i) = atan2( dble( x21(i,i) ), dble( x11(i,i) ) )
287 c = cos( theta(i) )
288 s = sin( theta(i) )
289 x11(i,i) = one
290 x21(i,i) = one
291 CALL zlarf( 'L', p-i+1, q-i, x11(i,i), 1, dconjg(taup1(i)),
292 $ x11(i,i+1), ldx11, work(ilarf) )
293 CALL zlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, dconjg(taup2(i)),
294 $ x21(i,i+1), ldx21, work(ilarf) )
295*
296 IF( i .LT. q ) THEN
297 CALL zdrot( q-i, x11(i,i+1), ldx11, x21(i,i+1), ldx21, c,
298 $ s )
299 CALL zlacgv( q-i, x21(i,i+1), ldx21 )
300 CALL zlarfgp( q-i, x21(i,i+1), x21(i,i+2), ldx21, tauq1(i) )
301 s = dble( x21(i,i+1) )
302 x21(i,i+1) = one
303 CALL zlarf( 'R', p-i, q-i, x21(i,i+1), ldx21, tauq1(i),
304 $ x11(i+1,i+1), ldx11, work(ilarf) )
305 CALL zlarf( 'R', m-p-i, q-i, x21(i,i+1), ldx21, tauq1(i),
306 $ x21(i+1,i+1), ldx21, work(ilarf) )
307 CALL zlacgv( q-i, x21(i,i+1), ldx21 )
308 c = sqrt( dznrm2( p-i, x11(i+1,i+1), 1 )**2
309 $ + dznrm2( m-p-i, x21(i+1,i+1), 1 )**2 )
310 phi(i) = atan2( s, c )
311 CALL zunbdb5( p-i, m-p-i, q-i-1, x11(i+1,i+1), 1,
312 $ x21(i+1,i+1), 1, x11(i+1,i+2), ldx11,
313 $ x21(i+1,i+2), ldx21, work(iorbdb5), lorbdb5,
314 $ childinfo )
315 END IF
316*
317 END DO
318*
319 RETURN
320*
321* End of ZUNBDB1
322*
zunbdb5
subroutine zunbdb5(m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
ZUNBDB5
Definition zunbdb5.f:156

◆ zunbdb2()

subroutine zunbdb2 ( integer m,
integer p,
integer q,
complex*16, dimension(ldx11,*) x11,
integer ldx11,
complex*16, dimension(ldx21,*) x21,
integer ldx21,
double precision, dimension(*) theta,
double precision, dimension(*) phi,
complex*16, dimension(*) taup1,
complex*16, dimension(*) taup2,
complex*16, dimension(*) tauq1,
complex*16, dimension(*) work,
integer lwork,
integer info )

ZUNBDB2

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

Purpose:
!>
!> ZUNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
!> matrix X with orthonomal columns:
!>
!>                            [ B11 ]
!>      [ X11 ]   [ P1 |    ] [  0  ]
!>      [-----] = [---------] [-----] Q1**T .
!>      [ X21 ]   [    | P2 ] [ B21 ]
!>                            [  0  ]
!>
!> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
!> Q, or M-Q. Routines ZUNBDB1, ZUNBDB3, and ZUNBDB4 handle cases in
!> which P is not the minimum dimension.
!>
!> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
!> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
!> Householder vectors.
!>
!> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
!> angles THETA, PHI.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>           The number of rows X11 plus the number of rows in X21.
!>
[in]P
!>          P is INTEGER
!>           The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
!>
[in]Q
!>          Q is INTEGER
!>           The number of columns in X11 and X21. 0 <= Q <= M.
!>
[in,out]X11
!>          X11 is COMPLEX*16 array, dimension (LDX11,Q)
!>           On entry, the top block of the matrix X to be reduced. On
!>           exit, the columns of tril(X11) specify reflectors for P1 and
!>           the rows of triu(X11,1) specify reflectors for Q1.
!>
[in]LDX11
!>          LDX11 is INTEGER
!>           The leading dimension of X11. LDX11 >= P.
!>
[in,out]X21
!>          X21 is COMPLEX*16 array, dimension (LDX21,Q)
!>           On entry, the bottom block of the matrix X to be reduced. On
!>           exit, the columns of tril(X21) specify reflectors for P2.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>           The leading dimension of X21. LDX21 >= M-P.
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]TAUP1
!>          TAUP1 is COMPLEX*16 array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is COMPLEX*16 array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is COMPLEX*16 array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>           The dimension of the array WORK. LWORK >= M-Q.
!>
!>           If LWORK = -1, then a workspace query is assumed; the routine
!>           only calculates the optimal size of the WORK array, returns
!>           this value as the first entry of the WORK array, and no error
!>           message related to LWORK is issued by XERBLA.
!>
[out]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.
Further Details:
!>
!>  The upper-bidiagonal blocks B11, B21 are represented implicitly by
!>  angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
!>  in each bidiagonal band is a product of a sine or cosine of a THETA
!>  with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
!>  and ZUNGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 199 of file zunbdb2.f.

201*
202* -- LAPACK computational routine --
203* -- LAPACK is a software package provided by Univ. of Tennessee, --
204* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
205*
206* .. Scalar Arguments ..
207 INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
208* ..
209* .. Array Arguments ..
210 DOUBLE PRECISION PHI(*), THETA(*)
211 COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
212 $ X11(LDX11,*), X21(LDX21,*)
213* ..
214*
215* ====================================================================
216*
217* .. Parameters ..
218 COMPLEX*16 NEGONE, ONE
219 parameter( negone = (-1.0d0,0.0d0),
220 $ one = (1.0d0,0.0d0) )
221* ..
222* .. Local Scalars ..
223 DOUBLE PRECISION C, S
224 INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
225 $ LWORKMIN, LWORKOPT
226 LOGICAL LQUERY
227* ..
228* .. External Subroutines ..
229 EXTERNAL zlarf, zlarfgp, zunbdb5, zdrot, zscal, zlacgv,
230 $ xerbla
231* ..
232* .. External Functions ..
233 DOUBLE PRECISION DZNRM2
234 EXTERNAL dznrm2
235* ..
236* .. Intrinsic Function ..
237 INTRINSIC atan2, cos, max, sin, sqrt
238* ..
239* .. Executable Statements ..
240*
241* Test input arguments
242*
243 info = 0
244 lquery = lwork .EQ. -1
245*
246 IF( m .LT. 0 ) THEN
247 info = -1
248 ELSE IF( p .LT. 0 .OR. p .GT. m-p ) THEN
249 info = -2
250 ELSE IF( q .LT. 0 .OR. q .LT. p .OR. m-q .LT. p ) THEN
251 info = -3
252 ELSE IF( ldx11 .LT. max( 1, p ) ) THEN
253 info = -5
254 ELSE IF( ldx21 .LT. max( 1, m-p ) ) THEN
255 info = -7
256 END IF
257*
258* Compute workspace
259*
260 IF( info .EQ. 0 ) THEN
261 ilarf = 2
262 llarf = max( p-1, m-p, q-1 )
263 iorbdb5 = 2
264 lorbdb5 = q-1
265 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 )
266 lworkmin = lworkopt
267 work(1) = lworkopt
268 IF( lwork .LT. lworkmin .AND. .NOT.lquery ) THEN
269 info = -14
270 END IF
271 END IF
272 IF( info .NE. 0 ) THEN
273 CALL xerbla( 'ZUNBDB2', -info )
274 RETURN
275 ELSE IF( lquery ) THEN
276 RETURN
277 END IF
278*
279* Reduce rows 1, ..., P of X11 and X21
280*
281 DO i = 1, p
282*
283 IF( i .GT. 1 ) THEN
284 CALL zdrot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,
285 $ s )
286 END IF
287 CALL zlacgv( q-i+1, x11(i,i), ldx11 )
288 CALL zlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) )
289 c = dble( x11(i,i) )
290 x11(i,i) = one
291 CALL zlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),
292 $ x11(i+1,i), ldx11, work(ilarf) )
293 CALL zlarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),
294 $ x21(i,i), ldx21, work(ilarf) )
295 CALL zlacgv( q-i+1, x11(i,i), ldx11 )
296 s = sqrt( dznrm2( p-i, x11(i+1,i), 1 )**2
297 $ + dznrm2( m-p-i+1, x21(i,i), 1 )**2 )
298 theta(i) = atan2( s, c )
299*
300 CALL zunbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,
301 $ x11(i+1,i+1), ldx11, x21(i,i+1), ldx21,
302 $ work(iorbdb5), lorbdb5, childinfo )
303 CALL zscal( p-i, negone, x11(i+1,i), 1 )
304 CALL zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
305 IF( i .LT. p ) THEN
306 CALL zlarfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) )
307 phi(i) = atan2( dble( x11(i+1,i) ), dble( x21(i,i) ) )
308 c = cos( phi(i) )
309 s = sin( phi(i) )
310 x11(i+1,i) = one
311 CALL zlarf( 'L', p-i, q-i, x11(i+1,i), 1, dconjg(taup1(i)),
312 $ x11(i+1,i+1), ldx11, work(ilarf) )
313 END IF
314 x21(i,i) = one
315 CALL zlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, dconjg(taup2(i)),
316 $ x21(i,i+1), ldx21, work(ilarf) )
317*
318 END DO
319*
320* Reduce the bottom-right portion of X21 to the identity matrix
321*
322 DO i = p + 1, q
323 CALL zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
324 x21(i,i) = one
325 CALL zlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, dconjg(taup2(i)),
326 $ x21(i,i+1), ldx21, work(ilarf) )
327 END DO
328*
329 RETURN
330*
331* End of ZUNBDB2
332*

◆ zunbdb3()

subroutine zunbdb3 ( integer m,
integer p,
integer q,
complex*16, dimension(ldx11,*) x11,
integer ldx11,
complex*16, dimension(ldx21,*) x21,
integer ldx21,
double precision, dimension(*) theta,
double precision, dimension(*) phi,
complex*16, dimension(*) taup1,
complex*16, dimension(*) taup2,
complex*16, dimension(*) tauq1,
complex*16, dimension(*) work,
integer lwork,
integer info )

ZUNBDB3

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

Purpose:
!>
!> ZUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
!> matrix X with orthonomal columns:
!>
!>                            [ B11 ]
!>      [ X11 ]   [ P1 |    ] [  0  ]
!>      [-----] = [---------] [-----] Q1**T .
!>      [ X21 ]   [    | P2 ] [ B21 ]
!>                            [  0  ]
!>
!> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
!> Q, or M-Q. Routines ZUNBDB1, ZUNBDB2, and ZUNBDB4 handle cases in
!> which M-P is not the minimum dimension.
!>
!> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
!> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
!> Householder vectors.
!>
!> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
!> implicitly by angles THETA, PHI.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>           The number of rows X11 plus the number of rows in X21.
!>
[in]P
!>          P is INTEGER
!>           The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
!>
[in]Q
!>          Q is INTEGER
!>           The number of columns in X11 and X21. 0 <= Q <= M.
!>
[in,out]X11
!>          X11 is COMPLEX*16 array, dimension (LDX11,Q)
!>           On entry, the top block of the matrix X to be reduced. On
!>           exit, the columns of tril(X11) specify reflectors for P1 and
!>           the rows of triu(X11,1) specify reflectors for Q1.
!>
[in]LDX11
!>          LDX11 is INTEGER
!>           The leading dimension of X11. LDX11 >= P.
!>
[in,out]X21
!>          X21 is COMPLEX*16 array, dimension (LDX21,Q)
!>           On entry, the bottom block of the matrix X to be reduced. On
!>           exit, the columns of tril(X21) specify reflectors for P2.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>           The leading dimension of X21. LDX21 >= M-P.
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]TAUP1
!>          TAUP1 is COMPLEX*16 array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is COMPLEX*16 array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is COMPLEX*16 array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>           The dimension of the array WORK. LWORK >= M-Q.
!>
!>           If LWORK = -1, then a workspace query is assumed; the routine
!>           only calculates the optimal size of the WORK array, returns
!>           this value as the first entry of the WORK array, and no error
!>           message related to LWORK is issued by XERBLA.
!>
[out]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.
Further Details:
!>
!>  The upper-bidiagonal blocks B11, B21 are represented implicitly by
!>  angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
!>  in each bidiagonal band is a product of a sine or cosine of a THETA
!>  with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
!>  and ZUNGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 199 of file zunbdb3.f.

201*
202* -- LAPACK computational routine --
203* -- LAPACK is a software package provided by Univ. of Tennessee, --
204* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
205*
206* .. Scalar Arguments ..
207 INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
208* ..
209* .. Array Arguments ..
210 DOUBLE PRECISION PHI(*), THETA(*)
211 COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
212 $ X11(LDX11,*), X21(LDX21,*)
213* ..
214*
215* ====================================================================
216*
217* .. Parameters ..
218 COMPLEX*16 ONE
219 parameter( one = (1.0d0,0.0d0) )
220* ..
221* .. Local Scalars ..
222 DOUBLE PRECISION C, S
223 INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
224 $ LWORKMIN, LWORKOPT
225 LOGICAL LQUERY
226* ..
227* .. External Subroutines ..
228 EXTERNAL zlarf, zlarfgp, zunbdb5, zdrot, zlacgv, xerbla
229* ..
230* .. External Functions ..
231 DOUBLE PRECISION DZNRM2
232 EXTERNAL dznrm2
233* ..
234* .. Intrinsic Function ..
235 INTRINSIC atan2, cos, max, sin, sqrt
236* ..
237* .. Executable Statements ..
238*
239* Test input arguments
240*
241 info = 0
242 lquery = lwork .EQ. -1
243*
244 IF( m .LT. 0 ) THEN
245 info = -1
246 ELSE IF( 2*p .LT. m .OR. p .GT. m ) THEN
247 info = -2
248 ELSE IF( q .LT. m-p .OR. m-q .LT. m-p ) THEN
249 info = -3
250 ELSE IF( ldx11 .LT. max( 1, p ) ) THEN
251 info = -5
252 ELSE IF( ldx21 .LT. max( 1, m-p ) ) THEN
253 info = -7
254 END IF
255*
256* Compute workspace
257*
258 IF( info .EQ. 0 ) THEN
259 ilarf = 2
260 llarf = max( p, m-p-1, q-1 )
261 iorbdb5 = 2
262 lorbdb5 = q-1
263 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 )
264 lworkmin = lworkopt
265 work(1) = lworkopt
266 IF( lwork .LT. lworkmin .AND. .NOT.lquery ) THEN
267 info = -14
268 END IF
269 END IF
270 IF( info .NE. 0 ) THEN
271 CALL xerbla( 'ZUNBDB3', -info )
272 RETURN
273 ELSE IF( lquery ) THEN
274 RETURN
275 END IF
276*
277* Reduce rows 1, ..., M-P of X11 and X21
278*
279 DO i = 1, m-p
280*
281 IF( i .GT. 1 ) THEN
282 CALL zdrot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c,
283 $ s )
284 END IF
285*
286 CALL zlacgv( q-i+1, x21(i,i), ldx21 )
287 CALL zlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) )
288 s = dble( x21(i,i) )
289 x21(i,i) = one
290 CALL zlarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),
291 $ x11(i,i), ldx11, work(ilarf) )
292 CALL zlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),
293 $ x21(i+1,i), ldx21, work(ilarf) )
294 CALL zlacgv( q-i+1, x21(i,i), ldx21 )
295 c = sqrt( dznrm2( p-i+1, x11(i,i), 1 )**2
296 $ + dznrm2( m-p-i, x21(i+1,i), 1 )**2 )
297 theta(i) = atan2( s, c )
298*
299 CALL zunbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,
300 $ x11(i,i+1), ldx11, x21(i+1,i+1), ldx21,
301 $ work(iorbdb5), lorbdb5, childinfo )
302 CALL zlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
303 IF( i .LT. m-p ) THEN
304 CALL zlarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) )
305 phi(i) = atan2( dble( x21(i+1,i) ), dble( x11(i,i) ) )
306 c = cos( phi(i) )
307 s = sin( phi(i) )
308 x21(i+1,i) = one
309 CALL zlarf( 'L', m-p-i, q-i, x21(i+1,i), 1,
310 $ dconjg(taup2(i)), x21(i+1,i+1), ldx21,
311 $ work(ilarf) )
312 END IF
313 x11(i,i) = one
314 CALL zlarf( 'L', p-i+1, q-i, x11(i,i), 1, dconjg(taup1(i)),
315 $ x11(i,i+1), ldx11, work(ilarf) )
316*
317 END DO
318*
319* Reduce the bottom-right portion of X11 to the identity matrix
320*
321 DO i = m-p + 1, q
322 CALL zlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
323 x11(i,i) = one
324 CALL zlarf( 'L', p-i+1, q-i, x11(i,i), 1, dconjg(taup1(i)),
325 $ x11(i,i+1), ldx11, work(ilarf) )
326 END DO
327*
328 RETURN
329*
330* End of ZUNBDB3
331*

◆ zunbdb4()

subroutine zunbdb4 ( integer m,
integer p,
integer q,
complex*16, dimension(ldx11,*) x11,
integer ldx11,
complex*16, dimension(ldx21,*) x21,
integer ldx21,
double precision, dimension(*) theta,
double precision, dimension(*) phi,
complex*16, dimension(*) taup1,
complex*16, dimension(*) taup2,
complex*16, dimension(*) tauq1,
complex*16, dimension(*) phantom,
complex*16, dimension(*) work,
integer lwork,
integer info )

ZUNBDB4

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

Purpose:
!>
!> ZUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
!> matrix X with orthonomal columns:
!>
!>                            [ B11 ]
!>      [ X11 ]   [ P1 |    ] [  0  ]
!>      [-----] = [---------] [-----] Q1**T .
!>      [ X21 ]   [    | P2 ] [ B21 ]
!>                            [  0  ]
!>
!> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
!> M-P, or Q. Routines ZUNBDB1, ZUNBDB2, and ZUNBDB3 handle cases in
!> which M-Q is not the minimum dimension.
!>
!> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
!> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
!> Householder vectors.
!>
!> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
!> implicitly by angles THETA, PHI.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>           The number of rows X11 plus the number of rows in X21.
!>
[in]P
!>          P is INTEGER
!>           The number of rows in X11. 0 <= P <= M.
!>
[in]Q
!>          Q is INTEGER
!>           The number of columns in X11 and X21. 0 <= Q <= M and
!>           M-Q <= min(P,M-P,Q).
!>
[in,out]X11
!>          X11 is COMPLEX*16 array, dimension (LDX11,Q)
!>           On entry, the top block of the matrix X to be reduced. On
!>           exit, the columns of tril(X11) specify reflectors for P1 and
!>           the rows of triu(X11,1) specify reflectors for Q1.
!>
[in]LDX11
!>          LDX11 is INTEGER
!>           The leading dimension of X11. LDX11 >= P.
!>
[in,out]X21
!>          X21 is COMPLEX*16 array, dimension (LDX21,Q)
!>           On entry, the bottom block of the matrix X to be reduced. On
!>           exit, the columns of tril(X21) specify reflectors for P2.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>           The leading dimension of X21. LDX21 >= M-P.
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]TAUP1
!>          TAUP1 is COMPLEX*16 array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is COMPLEX*16 array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is COMPLEX*16 array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]PHANTOM
!>          PHANTOM is COMPLEX*16 array, dimension (M)
!>           The routine computes an M-by-1 column vector Y that is
!>           orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
!>           PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
!>           Y(P+1:M), respectively.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>           The dimension of the array WORK. LWORK >= M-Q.
!>
!>           If LWORK = -1, then a workspace query is assumed; the routine
!>           only calculates the optimal size of the WORK array, returns
!>           this value as the first entry of the WORK array, and no error
!>           message related to LWORK is issued by XERBLA.
!>
[out]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.
Further Details:
!>
!>  The upper-bidiagonal blocks B11, B21 are represented implicitly by
!>  angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
!>  in each bidiagonal band is a product of a sine or cosine of a THETA
!>  with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
!>  and ZUNGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 210 of file zunbdb4.f.

213*
214* -- LAPACK computational routine --
215* -- LAPACK is a software package provided by Univ. of Tennessee, --
216* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
217*
218* .. Scalar Arguments ..
219 INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
220* ..
221* .. Array Arguments ..
222 DOUBLE PRECISION PHI(*), THETA(*)
223 COMPLEX*16 PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
224 $ WORK(*), X11(LDX11,*), X21(LDX21,*)
225* ..
226*
227* ====================================================================
228*
229* .. Parameters ..
230 COMPLEX*16 NEGONE, ONE, ZERO
231 parameter( negone = (-1.0d0,0.0d0), one = (1.0d0,0.0d0),
232 $ zero = (0.0d0,0.0d0) )
233* ..
234* .. Local Scalars ..
235 DOUBLE PRECISION C, S
236 INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
237 $ LORBDB5, LWORKMIN, LWORKOPT
238 LOGICAL LQUERY
239* ..
240* .. External Subroutines ..
241 EXTERNAL zlarf, zlarfgp, zunbdb5, zdrot, zscal, zlacgv,
242 $ xerbla
243* ..
244* .. External Functions ..
245 DOUBLE PRECISION DZNRM2
246 EXTERNAL dznrm2
247* ..
248* .. Intrinsic Function ..
249 INTRINSIC atan2, cos, max, sin, sqrt
250* ..
251* .. Executable Statements ..
252*
253* Test input arguments
254*
255 info = 0
256 lquery = lwork .EQ. -1
257*
258 IF( m .LT. 0 ) THEN
259 info = -1
260 ELSE IF( p .LT. m-q .OR. m-p .LT. m-q ) THEN
261 info = -2
262 ELSE IF( q .LT. m-q .OR. q .GT. m ) THEN
263 info = -3
264 ELSE IF( ldx11 .LT. max( 1, p ) ) THEN
265 info = -5
266 ELSE IF( ldx21 .LT. max( 1, m-p ) ) THEN
267 info = -7
268 END IF
269*
270* Compute workspace
271*
272 IF( info .EQ. 0 ) THEN
273 ilarf = 2
274 llarf = max( q-1, p-1, m-p-1 )
275 iorbdb5 = 2
276 lorbdb5 = q
277 lworkopt = ilarf + llarf - 1
278 lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1 )
279 lworkmin = lworkopt
280 work(1) = lworkopt
281 IF( lwork .LT. lworkmin .AND. .NOT.lquery ) THEN
282 info = -14
283 END IF
284 END IF
285 IF( info .NE. 0 ) THEN
286 CALL xerbla( 'ZUNBDB4', -info )
287 RETURN
288 ELSE IF( lquery ) THEN
289 RETURN
290 END IF
291*
292* Reduce columns 1, ..., M-Q of X11 and X21
293*
294 DO i = 1, m-q
295*
296 IF( i .EQ. 1 ) THEN
297 DO j = 1, m
298 phantom(j) = zero
299 END DO
300 CALL zunbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,
301 $ x11, ldx11, x21, ldx21, work(iorbdb5),
302 $ lorbdb5, childinfo )
303 CALL zscal( p, negone, phantom(1), 1 )
304 CALL zlarfgp( p, phantom(1), phantom(2), 1, taup1(1) )
305 CALL zlarfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) )
306 theta(i) = atan2( dble( phantom(1) ), dble( phantom(p+1) ) )
307 c = cos( theta(i) )
308 s = sin( theta(i) )
309 phantom(1) = one
310 phantom(p+1) = one
311 CALL zlarf( 'L', p, q, phantom(1), 1, dconjg(taup1(1)), x11,
312 $ ldx11, work(ilarf) )
313 CALL zlarf( 'L', m-p, q, phantom(p+1), 1, dconjg(taup2(1)),
314 $ x21, ldx21, work(ilarf) )
315 ELSE
316 CALL zunbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,
317 $ x21(i,i-1), 1, x11(i,i), ldx11, x21(i,i),
318 $ ldx21, work(iorbdb5), lorbdb5, childinfo )
319 CALL zscal( p-i+1, negone, x11(i,i-1), 1 )
320 CALL zlarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) )
321 CALL zlarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,
322 $ taup2(i) )
323 theta(i) = atan2( dble( x11(i,i-1) ), dble( x21(i,i-1) ) )
324 c = cos( theta(i) )
325 s = sin( theta(i) )
326 x11(i,i-1) = one
327 x21(i,i-1) = one
328 CALL zlarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1,
329 $ dconjg(taup1(i)), x11(i,i), ldx11, work(ilarf) )
330 CALL zlarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1,
331 $ dconjg(taup2(i)), x21(i,i), ldx21, work(ilarf) )
332 END IF
333*
334 CALL zdrot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c )
335 CALL zlacgv( q-i+1, x21(i,i), ldx21 )
336 CALL zlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) )
337 c = dble( x21(i,i) )
338 x21(i,i) = one
339 CALL zlarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),
340 $ x11(i+1,i), ldx11, work(ilarf) )
341 CALL zlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),
342 $ x21(i+1,i), ldx21, work(ilarf) )
343 CALL zlacgv( q-i+1, x21(i,i), ldx21 )
344 IF( i .LT. m-q ) THEN
345 s = sqrt( dznrm2( p-i, x11(i+1,i), 1 )**2
346 $ + dznrm2( m-p-i, x21(i+1,i), 1 )**2 )
347 phi(i) = atan2( s, c )
348 END IF
349*
350 END DO
351*
352* Reduce the bottom-right portion of X11 to [ I 0 ]
353*
354 DO i = m - q + 1, p
355 CALL zlacgv( q-i+1, x11(i,i), ldx11 )
356 CALL zlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) )
357 x11(i,i) = one
358 CALL zlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),
359 $ x11(i+1,i), ldx11, work(ilarf) )
360 CALL zlarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),
361 $ x21(m-q+1,i), ldx21, work(ilarf) )
362 CALL zlacgv( q-i+1, x11(i,i), ldx11 )
363 END DO
364*
365* Reduce the bottom-right portion of X21 to [ 0 I ]
366*
367 DO i = p + 1, q
368 CALL zlacgv( q-i+1, x21(m-q+i-p,i), ldx21 )
369 CALL zlarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,
370 $ tauq1(i) )
371 x21(m-q+i-p,i) = one
372 CALL zlarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),
373 $ x21(m-q+i-p+1,i), ldx21, work(ilarf) )
374 CALL zlacgv( q-i+1, x21(m-q+i-p,i), ldx21 )
375 END DO
376*
377 RETURN
378*
379* End of ZUNBDB4
380*

◆ zunbdb5()

subroutine zunbdb5 ( integer m1,
integer m2,
integer n,
complex*16, dimension(*) x1,
integer incx1,
complex*16, dimension(*) x2,
integer incx2,
complex*16, dimension(ldq1,*) q1,
integer ldq1,
complex*16, dimension(ldq2,*) q2,
integer ldq2,
complex*16, dimension(*) work,
integer lwork,
integer info )

ZUNBDB5

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

Purpose:
!>
!> ZUNBDB5 orthogonalizes the column vector
!>      X = [ X1 ]
!>          [ X2 ]
!> with respect to the columns of
!>      Q = [ Q1 ] .
!>          [ Q2 ]
!> The columns of Q must be orthonormal.
!>
!> If the projection is zero according to Kahan's 
!> criterion, then some other vector from the orthogonal complement
!> is returned. This vector is chosen in an arbitrary but deterministic
!> way.
!>
!>
Parameters
[in]M1
!>          M1 is INTEGER
!>           The dimension of X1 and the number of rows in Q1. 0 <= M1.
!>
[in]M2
!>          M2 is INTEGER
!>           The dimension of X2 and the number of rows in Q2. 0 <= M2.
!>
[in]N
!>          N is INTEGER
!>           The number of columns in Q1 and Q2. 0 <= N.
!>
[in,out]X1
!>          X1 is COMPLEX*16 array, dimension (M1)
!>           On entry, the top part of the vector to be orthogonalized.
!>           On exit, the top part of the projected vector.
!>
[in]INCX1
!>          INCX1 is INTEGER
!>           Increment for entries of X1.
!>
[in,out]X2
!>          X2 is COMPLEX*16 array, dimension (M2)
!>           On entry, the bottom part of the vector to be
!>           orthogonalized. On exit, the bottom part of the projected
!>           vector.
!>
[in]INCX2
!>          INCX2 is INTEGER
!>           Increment for entries of X2.
!>
[in]Q1
!>          Q1 is COMPLEX*16 array, dimension (LDQ1, N)
!>           The top part of the orthonormal basis matrix.
!>
[in]LDQ1
!>          LDQ1 is INTEGER
!>           The leading dimension of Q1. LDQ1 >= M1.
!>
[in]Q2
!>          Q2 is COMPLEX*16 array, dimension (LDQ2, N)
!>           The bottom part of the orthonormal basis matrix.
!>
[in]LDQ2
!>          LDQ2 is INTEGER
!>           The leading dimension of Q2. LDQ2 >= M2.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>           The dimension of the array WORK. LWORK >= N.
!>
[out]INFO
!>          INFO is INTEGER
!>           = 0:  successful exit.
!>           < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 154 of file zunbdb5.f.

156*
157* -- LAPACK computational routine --
158* -- LAPACK is a software package provided by Univ. of Tennessee, --
159* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
160*
161* .. Scalar Arguments ..
162 INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
163 $ N
164* ..
165* .. Array Arguments ..
166 COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 COMPLEX*16 ONE, ZERO
173 parameter( one = (1.0d0,0.0d0), zero = (0.0d0,0.0d0) )
174* ..
175* .. Local Scalars ..
176 INTEGER CHILDINFO, I, J
177* ..
178* .. External Subroutines ..
179 EXTERNAL zunbdb6, xerbla
180* ..
181* .. External Functions ..
182 DOUBLE PRECISION DZNRM2
183 EXTERNAL dznrm2
184* ..
185* .. Intrinsic Function ..
186 INTRINSIC max
187* ..
188* .. Executable Statements ..
189*
190* Test input arguments
191*
192 info = 0
193 IF( m1 .LT. 0 ) THEN
194 info = -1
195 ELSE IF( m2 .LT. 0 ) THEN
196 info = -2
197 ELSE IF( n .LT. 0 ) THEN
198 info = -3
199 ELSE IF( incx1 .LT. 1 ) THEN
200 info = -5
201 ELSE IF( incx2 .LT. 1 ) THEN
202 info = -7
203 ELSE IF( ldq1 .LT. max( 1, m1 ) ) THEN
204 info = -9
205 ELSE IF( ldq2 .LT. max( 1, m2 ) ) THEN
206 info = -11
207 ELSE IF( lwork .LT. n ) THEN
208 info = -13
209 END IF
210*
211 IF( info .NE. 0 ) THEN
212 CALL xerbla( 'ZUNBDB5', -info )
213 RETURN
214 END IF
215*
216* Project X onto the orthogonal complement of Q
217*
218 CALL zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,
219 $ work, lwork, childinfo )
220*
221* If the projection is nonzero, then return
222*
223 IF( dznrm2(m1,x1,incx1) .NE. zero
224 $ .OR. dznrm2(m2,x2,incx2) .NE. zero ) THEN
225 RETURN
226 END IF
227*
228* Project each standard basis vector e_1,...,e_M1 in turn, stopping
229* when a nonzero projection is found
230*
231 DO i = 1, m1
232 DO j = 1, m1
233 x1(j) = zero
234 END DO
235 x1(i) = one
236 DO j = 1, m2
237 x2(j) = zero
238 END DO
239 CALL zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,
240 $ ldq2, work, lwork, childinfo )
241 IF( dznrm2(m1,x1,incx1) .NE. zero
242 $ .OR. dznrm2(m2,x2,incx2) .NE. zero ) THEN
243 RETURN
244 END IF
245 END DO
246*
247* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
248* stopping when a nonzero projection is found
249*
250 DO i = 1, m2
251 DO j = 1, m1
252 x1(j) = zero
253 END DO
254 DO j = 1, m2
255 x2(j) = zero
256 END DO
257 x2(i) = one
258 CALL zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,
259 $ ldq2, work, lwork, childinfo )
260 IF( dznrm2(m1,x1,incx1) .NE. zero
261 $ .OR. dznrm2(m2,x2,incx2) .NE. zero ) THEN
262 RETURN
263 END IF
264 END DO
265*
266 RETURN
267*
268* End of ZUNBDB5
269*
zunbdb6
subroutine zunbdb6(m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
ZUNBDB6
Definition zunbdb6.f:154

◆ zunbdb6()

subroutine zunbdb6 ( integer m1,
integer m2,
integer n,
complex*16, dimension(*) x1,
integer incx1,
complex*16, dimension(*) x2,
integer incx2,
complex*16, dimension(ldq1,*) q1,
integer ldq1,
complex*16, dimension(ldq2,*) q2,
integer ldq2,
complex*16, dimension(*) work,
integer lwork,
integer info )

ZUNBDB6

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

Purpose:
!>
!> ZUNBDB6 orthogonalizes the column vector
!>      X = [ X1 ]
!>          [ X2 ]
!> with respect to the columns of
!>      Q = [ Q1 ] .
!>          [ Q2 ]
!> The columns of Q must be orthonormal.
!>
!> If the projection is zero according to Kahan's 
!> criterion, then the zero vector is returned.
!>
!>
Parameters
[in]M1
!>          M1 is INTEGER
!>           The dimension of X1 and the number of rows in Q1. 0 <= M1.
!>
[in]M2
!>          M2 is INTEGER
!>           The dimension of X2 and the number of rows in Q2. 0 <= M2.
!>
[in]N
!>          N is INTEGER
!>           The number of columns in Q1 and Q2. 0 <= N.
!>
[in,out]X1
!>          X1 is COMPLEX*16 array, dimension (M1)
!>           On entry, the top part of the vector to be orthogonalized.
!>           On exit, the top part of the projected vector.
!>
[in]INCX1
!>          INCX1 is INTEGER
!>           Increment for entries of X1.
!>
[in,out]X2
!>          X2 is COMPLEX*16 array, dimension (M2)
!>           On entry, the bottom part of the vector to be
!>           orthogonalized. On exit, the bottom part of the projected
!>           vector.
!>
[in]INCX2
!>          INCX2 is INTEGER
!>           Increment for entries of X2.
!>
[in]Q1
!>          Q1 is COMPLEX*16 array, dimension (LDQ1, N)
!>           The top part of the orthonormal basis matrix.
!>
[in]LDQ1
!>          LDQ1 is INTEGER
!>           The leading dimension of Q1. LDQ1 >= M1.
!>
[in]Q2
!>          Q2 is COMPLEX*16 array, dimension (LDQ2, N)
!>           The bottom part of the orthonormal basis matrix.
!>
[in]LDQ2
!>          LDQ2 is INTEGER
!>           The leading dimension of Q2. LDQ2 >= M2.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>           The dimension of the array WORK. LWORK >= N.
!>
[out]INFO
!>          INFO is INTEGER
!>           = 0:  successful exit.
!>           < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 152 of file zunbdb6.f.

154*
155* -- LAPACK computational routine --
156* -- LAPACK is a software package provided by Univ. of Tennessee, --
157* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
158*
159* .. Scalar Arguments ..
160 INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
161 $ N
162* ..
163* .. Array Arguments ..
164 COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 DOUBLE PRECISION ALPHASQ, REALONE, REALZERO
171 parameter( alphasq = 0.01d0, realone = 1.0d0,
172 $ realzero = 0.0d0 )
173 COMPLEX*16 NEGONE, ONE, ZERO
174 parameter( negone = (-1.0d0,0.0d0), one = (1.0d0,0.0d0),
175 $ zero = (0.0d0,0.0d0) )
176* ..
177* .. Local Scalars ..
178 INTEGER I
179 DOUBLE PRECISION NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
180* ..
181* .. External Subroutines ..
182 EXTERNAL zgemv, zlassq, xerbla
183* ..
184* .. Intrinsic Function ..
185 INTRINSIC max
186* ..
187* .. Executable Statements ..
188*
189* Test input arguments
190*
191 info = 0
192 IF( m1 .LT. 0 ) THEN
193 info = -1
194 ELSE IF( m2 .LT. 0 ) THEN
195 info = -2
196 ELSE IF( n .LT. 0 ) THEN
197 info = -3
198 ELSE IF( incx1 .LT. 1 ) THEN
199 info = -5
200 ELSE IF( incx2 .LT. 1 ) THEN
201 info = -7
202 ELSE IF( ldq1 .LT. max( 1, m1 ) ) THEN
203 info = -9
204 ELSE IF( ldq2 .LT. max( 1, m2 ) ) THEN
205 info = -11
206 ELSE IF( lwork .LT. n ) THEN
207 info = -13
208 END IF
209*
210 IF( info .NE. 0 ) THEN
211 CALL xerbla( 'ZUNBDB6', -info )
212 RETURN
213 END IF
214*
215* First, project X onto the orthogonal complement of Q's column
216* space
217*
218 scl1 = realzero
219 ssq1 = realone
220 CALL zlassq( m1, x1, incx1, scl1, ssq1 )
221 scl2 = realzero
222 ssq2 = realone
223 CALL zlassq( m2, x2, incx2, scl2, ssq2 )
224 normsq1 = scl1**2*ssq1 + scl2**2*ssq2
225*
226 IF( m1 .EQ. 0 ) THEN
227 DO i = 1, n
228 work(i) = zero
229 END DO
230 ELSE
231 CALL zgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,
232 $ 1 )
233 END IF
234*
235 CALL zgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 )
236*
237 CALL zgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,
238 $ incx1 )
239 CALL zgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,
240 $ incx2 )
241*
242 scl1 = realzero
243 ssq1 = realone
244 CALL zlassq( m1, x1, incx1, scl1, ssq1 )
245 scl2 = realzero
246 ssq2 = realone
247 CALL zlassq( m2, x2, incx2, scl2, ssq2 )
248 normsq2 = scl1**2*ssq1 + scl2**2*ssq2
249*
250* If projection is sufficiently large in norm, then stop.
251* If projection is zero, then stop.
252* Otherwise, project again.
253*
254 IF( normsq2 .GE. alphasq*normsq1 ) THEN
255 RETURN
256 END IF
257*
258 IF( normsq2 .EQ. zero ) THEN
259 RETURN
260 END IF
261*
262 normsq1 = normsq2
263*
264 DO i = 1, n
265 work(i) = zero
266 END DO
267*
268 IF( m1 .EQ. 0 ) THEN
269 DO i = 1, n
270 work(i) = zero
271 END DO
272 ELSE
273 CALL zgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,
274 $ 1 )
275 END IF
276*
277 CALL zgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 )
278*
279 CALL zgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,
280 $ incx1 )
281 CALL zgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,
282 $ incx2 )
283*
284 scl1 = realzero
285 ssq1 = realone
286 CALL zlassq( m1, x1, incx1, scl1, ssq1 )
287 scl2 = realzero
288 ssq2 = realone
289 CALL zlassq( m1, x1, incx1, scl1, ssq1 )
290 normsq2 = scl1**2*ssq1 + scl2**2*ssq2
291*
292* If second projection is sufficiently large in norm, then do
293* nothing more. Alternatively, if it shrunk significantly, then
294* truncate it to zero.
295*
296 IF( normsq2 .LT. alphasq*normsq1 ) THEN
297 DO i = 1, m1
298 x1(i) = zero
299 END DO
300 DO i = 1, m2
301 x2(i) = zero
302 END DO
303 END IF
304*
305 RETURN
306*
307* End of ZUNBDB6
308*

◆ zuncsd()

recursive subroutine zuncsd ( character jobu1,
character jobu2,
character jobv1t,
character jobv2t,
character trans,
character signs,
integer m,
integer p,
integer q,
complex*16, dimension( ldx11, * ) x11,
integer ldx11,
complex*16, dimension( ldx12, * ) x12,
integer ldx12,
complex*16, dimension( ldx21, * ) x21,
integer ldx21,
complex*16, dimension( ldx22, * ) x22,
integer ldx22,
double precision, dimension( * ) theta,
complex*16, dimension( ldu1, * ) u1,
integer ldu1,
complex*16, dimension( ldu2, * ) u2,
integer ldu2,
complex*16, dimension( ldv1t, * ) v1t,
integer ldv1t,
complex*16, dimension( ldv2t, * ) v2t,
integer ldv2t,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer lrwork,
integer, dimension( * ) iwork,
integer info )

ZUNCSD

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

Purpose:
!>
!> ZUNCSD computes the CS decomposition of an M-by-M partitioned
!> unitary matrix X:
!>
!>                                 [  I  0  0 |  0  0  0 ]
!>                                 [  0  C  0 |  0 -S  0 ]
!>     [ X11 | X12 ]   [ U1 |    ] [  0  0  0 |  0  0 -I ] [ V1 |    ]**H
!> X = [-----------] = [---------] [---------------------] [---------]   .
!>     [ X21 | X22 ]   [    | U2 ] [  0  0  0 |  I  0  0 ] [    | V2 ]
!>                                 [  0  S  0 |  0  C  0 ]
!>                                 [  0  0  I |  0  0  0 ]
!>
!> X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,
!> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
!> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
!> which R = MIN(P,M-P,Q,M-Q).
!>
Parameters
[in]JOBU1
!>          JOBU1 is CHARACTER
!>          = 'Y':      U1 is computed;
!>          otherwise:  U1 is not computed.
!>
[in]JOBU2
!>          JOBU2 is CHARACTER
!>          = 'Y':      U2 is computed;
!>          otherwise:  U2 is not computed.
!>
[in]JOBV1T
!>          JOBV1T is CHARACTER
!>          = 'Y':      V1T is computed;
!>          otherwise:  V1T is not computed.
!>
[in]JOBV2T
!>          JOBV2T is CHARACTER
!>          = 'Y':      V2T is computed;
!>          otherwise:  V2T is not computed.
!>
[in]TRANS
!>          TRANS is CHARACTER
!>          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major
!>                      order;
!>          otherwise:  X, U1, U2, V1T, and V2T are stored in column-
!>                      major order.
!>
[in]SIGNS
!>          SIGNS is CHARACTER
!>          = 'O':      The lower-left block is made nonpositive (the
!>                       convention);
!>          otherwise:  The upper-right block is made nonpositive (the
!>                       convention).
!>
[in]M
!>          M is INTEGER
!>          The number of rows and columns in X.
!>
[in]P
!>          P is INTEGER
!>          The number of rows in X11 and X12. 0 <= P <= M.
!>
[in]Q
!>          Q is INTEGER
!>          The number of columns in X11 and X21. 0 <= Q <= M.
!>
[in,out]X11
!>          X11 is COMPLEX*16 array, dimension (LDX11,Q)
!>          On entry, part of the unitary matrix whose CSD is desired.
!>
[in]LDX11
!>          LDX11 is INTEGER
!>          The leading dimension of X11. LDX11 >= MAX(1,P).
!>
[in,out]X12
!>          X12 is COMPLEX*16 array, dimension (LDX12,M-Q)
!>          On entry, part of the unitary matrix whose CSD is desired.
!>
[in]LDX12
!>          LDX12 is INTEGER
!>          The leading dimension of X12. LDX12 >= MAX(1,P).
!>
[in,out]X21
!>          X21 is COMPLEX*16 array, dimension (LDX21,Q)
!>          On entry, part of the unitary matrix whose CSD is desired.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>          The leading dimension of X11. LDX21 >= MAX(1,M-P).
!>
[in,out]X22
!>          X22 is COMPLEX*16 array, dimension (LDX22,M-Q)
!>          On entry, part of the unitary matrix whose CSD is desired.
!>
[in]LDX22
!>          LDX22 is INTEGER
!>          The leading dimension of X11. LDX22 >= MAX(1,M-P).
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (R), in which R =
!>          MIN(P,M-P,Q,M-Q).
!>          C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
!>          S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
!>
[out]U1
!>          U1 is COMPLEX*16 array, dimension (LDU1,P)
!>          If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.
!>
[in]LDU1
!>          LDU1 is INTEGER
!>          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
!>          MAX(1,P).
!>
[out]U2
!>          U2 is COMPLEX*16 array, dimension (LDU2,M-P)
!>          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary
!>          matrix U2.
!>
[in]LDU2
!>          LDU2 is INTEGER
!>          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
!>          MAX(1,M-P).
!>
[out]V1T
!>          V1T is COMPLEX*16 array, dimension (LDV1T,Q)
!>          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary
!>          matrix V1**H.
!>
[in]LDV1T
!>          LDV1T is INTEGER
!>          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
!>          MAX(1,Q).
!>
[out]V2T
!>          V2T is COMPLEX*16 array, dimension (LDV2T,M-Q)
!>          If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary
!>          matrix V2**H.
!>
[in]LDV2T
!>          LDV2T is INTEGER
!>          The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=
!>          MAX(1,M-Q).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the work array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension MAX(1,LRWORK)
!>          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
!>          If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),
!>          ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
!>          define the matrix in intermediate bidiagonal-block form
!>          remaining after nonconvergence. INFO specifies the number
!>          of nonzero PHI's.
!>
[in]LRWORK
!>          LRWORK is INTEGER
!>          The dimension of the array RWORK.
!>
!>          If LRWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the RWORK array, returns
!>          this value as the first entry of the work array, and no error
!>          message related to LRWORK is issued by XERBLA.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  ZBBCSD did not converge. See the description of RWORK
!>                above for details.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 314 of file zuncsd.f.

320*
321* -- LAPACK computational routine --
322* -- LAPACK is a software package provided by Univ. of Tennessee, --
323* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
324*
325* .. Scalar Arguments ..
326 CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS
327 INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LDX11, LDX12,
328 $ LDX21, LDX22, LRWORK, LWORK, M, P, Q
329* ..
330* .. Array Arguments ..
331 INTEGER IWORK( * )
332 DOUBLE PRECISION THETA( * )
333 DOUBLE PRECISION RWORK( * )
334 COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
335 $ V2T( LDV2T, * ), WORK( * ), X11( LDX11, * ),
336 $ X12( LDX12, * ), X21( LDX21, * ), X22( LDX22,
337 $ * )
338* ..
339*
340* ===================================================================
341*
342* .. Parameters ..
343 COMPLEX*16 ONE, ZERO
344 parameter( one = (1.0d0,0.0d0),
345 $ zero = (0.0d0,0.0d0) )
346* ..
347* .. Local Scalars ..
348 CHARACTER TRANST, SIGNST
349 INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
350 $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
351 $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
352 $ ITAUQ2, J, LBBCSDWORK, LBBCSDWORKMIN,
353 $ LBBCSDWORKOPT, LORBDBWORK, LORBDBWORKMIN,
354 $ LORBDBWORKOPT, LORGLQWORK, LORGLQWORKMIN,
355 $ LORGLQWORKOPT, LORGQRWORK, LORGQRWORKMIN,
356 $ LORGQRWORKOPT, LWORKMIN, LWORKOPT, P1, Q1
357 LOGICAL COLMAJOR, DEFAULTSIGNS, LQUERY, WANTU1, WANTU2,
358 $ WANTV1T, WANTV2T
359 INTEGER LRWORKMIN, LRWORKOPT
360 LOGICAL LRQUERY
361* ..
362* .. External Subroutines ..
363 EXTERNAL xerbla, zbbcsd, zlacpy, zlapmr, zlapmt,
364 $ zunbdb, zunglq, zungqr
365* ..
366* .. External Functions ..
367 LOGICAL LSAME
368 EXTERNAL lsame
369* ..
370* .. Intrinsic Functions
371 INTRINSIC int, max, min
372* ..
373* .. Executable Statements ..
374*
375* Test input arguments
376*
377 info = 0
378 wantu1 = lsame( jobu1, 'Y' )
379 wantu2 = lsame( jobu2, 'Y' )
380 wantv1t = lsame( jobv1t, 'Y' )
381 wantv2t = lsame( jobv2t, 'Y' )
382 colmajor = .NOT. lsame( trans, 'T' )
383 defaultsigns = .NOT. lsame( signs, 'O' )
384 lquery = lwork .EQ. -1
385 lrquery = lrwork .EQ. -1
386 IF( m .LT. 0 ) THEN
387 info = -7
388 ELSE IF( p .LT. 0 .OR. p .GT. m ) THEN
389 info = -8
390 ELSE IF( q .LT. 0 .OR. q .GT. m ) THEN
391 info = -9
392 ELSE IF ( colmajor .AND. ldx11 .LT. max( 1, p ) ) THEN
393 info = -11
394 ELSE IF (.NOT. colmajor .AND. ldx11 .LT. max( 1, q ) ) THEN
395 info = -11
396 ELSE IF (colmajor .AND. ldx12 .LT. max( 1, p ) ) THEN
397 info = -13
398 ELSE IF (.NOT. colmajor .AND. ldx12 .LT. max( 1, m-q ) ) THEN
399 info = -13
400 ELSE IF (colmajor .AND. ldx21 .LT. max( 1, m-p ) ) THEN
401 info = -15
402 ELSE IF (.NOT. colmajor .AND. ldx21 .LT. max( 1, q ) ) THEN
403 info = -15
404 ELSE IF (colmajor .AND. ldx22 .LT. max( 1, m-p ) ) THEN
405 info = -17
406 ELSE IF (.NOT. colmajor .AND. ldx22 .LT. max( 1, m-q ) ) THEN
407 info = -17
408 ELSE IF( wantu1 .AND. ldu1 .LT. p ) THEN
409 info = -20
410 ELSE IF( wantu2 .AND. ldu2 .LT. m-p ) THEN
411 info = -22
412 ELSE IF( wantv1t .AND. ldv1t .LT. q ) THEN
413 info = -24
414 ELSE IF( wantv2t .AND. ldv2t .LT. m-q ) THEN
415 info = -26
416 END IF
417*
418* Work with transpose if convenient
419*
420 IF( info .EQ. 0 .AND. min( p, m-p ) .LT. min( q, m-q ) ) THEN
421 IF( colmajor ) THEN
422 transt = 'T'
423 ELSE
424 transt = 'N'
425 END IF
426 IF( defaultsigns ) THEN
427 signst = 'O'
428 ELSE
429 signst = 'D'
430 END IF
431 CALL zuncsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,
432 $ q, p, x11, ldx11, x21, ldx21, x12, ldx12, x22,
433 $ ldx22, theta, v1t, ldv1t, v2t, ldv2t, u1, ldu1,
434 $ u2, ldu2, work, lwork, rwork, lrwork, iwork,
435 $ info )
436 RETURN
437 END IF
438*
439* Work with permutation [ 0 I; I 0 ] * X * [ 0 I; I 0 ] if
440* convenient
441*
442 IF( info .EQ. 0 .AND. m-q .LT. q ) THEN
443 IF( defaultsigns ) THEN
444 signst = 'O'
445 ELSE
446 signst = 'D'
447 END IF
448 CALL zuncsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,
449 $ m-p, m-q, x22, ldx22, x21, ldx21, x12, ldx12, x11,
450 $ ldx11, theta, u2, ldu2, u1, ldu1, v2t, ldv2t, v1t,
451 $ ldv1t, work, lwork, rwork, lrwork, iwork, info )
452 RETURN
453 END IF
454*
455* Compute workspace
456*
457 IF( info .EQ. 0 ) THEN
458*
459* Real workspace
460*
461 iphi = 2
462 ib11d = iphi + max( 1, q - 1 )
463 ib11e = ib11d + max( 1, q )
464 ib12d = ib11e + max( 1, q - 1 )
465 ib12e = ib12d + max( 1, q )
466 ib21d = ib12e + max( 1, q - 1 )
467 ib21e = ib21d + max( 1, q )
468 ib22d = ib21e + max( 1, q - 1 )
469 ib22e = ib22d + max( 1, q )
470 ibbcsd = ib22e + max( 1, q - 1 )
471 CALL zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,
472 $ theta, theta, u1, ldu1, u2, ldu2, v1t, ldv1t,
473 $ v2t, ldv2t, theta, theta, theta, theta, theta,
474 $ theta, theta, theta, rwork, -1, childinfo )
475 lbbcsdworkopt = int( rwork(1) )
476 lbbcsdworkmin = lbbcsdworkopt
477 lrworkopt = ibbcsd + lbbcsdworkopt - 1
478 lrworkmin = ibbcsd + lbbcsdworkmin - 1
479 rwork(1) = lrworkopt
480*
481* Complex workspace
482*
483 itaup1 = 2
484 itaup2 = itaup1 + max( 1, p )
485 itauq1 = itaup2 + max( 1, m - p )
486 itauq2 = itauq1 + max( 1, q )
487 iorgqr = itauq2 + max( 1, m - q )
488 CALL zungqr( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,
489 $ childinfo )
490 lorgqrworkopt = int( work(1) )
491 lorgqrworkmin = max( 1, m - q )
492 iorglq = itauq2 + max( 1, m - q )
493 CALL zunglq( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,
494 $ childinfo )
495 lorglqworkopt = int( work(1) )
496 lorglqworkmin = max( 1, m - q )
497 iorbdb = itauq2 + max( 1, m - q )
498 CALL zunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,
499 $ x21, ldx21, x22, ldx22, theta, theta, u1, u2,
500 $ v1t, v2t, work, -1, childinfo )
501 lorbdbworkopt = int( work(1) )
502 lorbdbworkmin = lorbdbworkopt
503 lworkopt = max( iorgqr + lorgqrworkopt, iorglq + lorglqworkopt,
504 $ iorbdb + lorbdbworkopt ) - 1
505 lworkmin = max( iorgqr + lorgqrworkmin, iorglq + lorglqworkmin,
506 $ iorbdb + lorbdbworkmin ) - 1
507 work(1) = max(lworkopt,lworkmin)
508*
509 IF( lwork .LT. lworkmin
510 $ .AND. .NOT. ( lquery .OR. lrquery ) ) THEN
511 info = -22
512 ELSE IF( lrwork .LT. lrworkmin
513 $ .AND. .NOT. ( lquery .OR. lrquery ) ) THEN
514 info = -24
515 ELSE
516 lorgqrwork = lwork - iorgqr + 1
517 lorglqwork = lwork - iorglq + 1
518 lorbdbwork = lwork - iorbdb + 1
519 lbbcsdwork = lrwork - ibbcsd + 1
520 END IF
521 END IF
522*
523* Abort if any illegal arguments
524*
525 IF( info .NE. 0 ) THEN
526 CALL xerbla( 'ZUNCSD', -info )
527 RETURN
528 ELSE IF( lquery .OR. lrquery ) THEN
529 RETURN
530 END IF
531*
532* Transform to bidiagonal block form
533*
534 CALL zunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,
535 $ ldx21, x22, ldx22, theta, rwork(iphi), work(itaup1),
536 $ work(itaup2), work(itauq1), work(itauq2),
537 $ work(iorbdb), lorbdbwork, childinfo )
538*
539* Accumulate Householder reflectors
540*
541 IF( colmajor ) THEN
542 IF( wantu1 .AND. p .GT. 0 ) THEN
543 CALL zlacpy( 'L', p, q, x11, ldx11, u1, ldu1 )
544 CALL zungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),
545 $ lorgqrwork, info)
546 END IF
547 IF( wantu2 .AND. m-p .GT. 0 ) THEN
548 CALL zlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 )
549 CALL zungqr( m-p, m-p, q, u2, ldu2, work(itaup2),
550 $ work(iorgqr), lorgqrwork, info )
551 END IF
552 IF( wantv1t .AND. q .GT. 0 ) THEN
553 CALL zlacpy( 'U', q-1, q-1, x11(1,2), ldx11, v1t(2,2),
554 $ ldv1t )
555 v1t(1, 1) = one
556 DO j = 2, q
557 v1t(1,j) = zero
558 v1t(j,1) = zero
559 END DO
560 CALL zunglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),
561 $ work(iorglq), lorglqwork, info )
562 END IF
563 IF( wantv2t .AND. m-q .GT. 0 ) THEN
564 CALL zlacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t )
565 IF( m-p .GT. q) THEN
566 CALL zlacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,
567 $ v2t(p+1,p+1), ldv2t )
568 END IF
569 IF( m .GT. q ) THEN
570 CALL zunglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),
571 $ work(iorglq), lorglqwork, info )
572 END IF
573 END IF
574 ELSE
575 IF( wantu1 .AND. p .GT. 0 ) THEN
576 CALL zlacpy( 'U', q, p, x11, ldx11, u1, ldu1 )
577 CALL zunglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),
578 $ lorglqwork, info)
579 END IF
580 IF( wantu2 .AND. m-p .GT. 0 ) THEN
581 CALL zlacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 )
582 CALL zunglq( m-p, m-p, q, u2, ldu2, work(itaup2),
583 $ work(iorglq), lorglqwork, info )
584 END IF
585 IF( wantv1t .AND. q .GT. 0 ) THEN
586 CALL zlacpy( 'L', q-1, q-1, x11(2,1), ldx11, v1t(2,2),
587 $ ldv1t )
588 v1t(1, 1) = one
589 DO j = 2, q
590 v1t(1,j) = zero
591 v1t(j,1) = zero
592 END DO
593 CALL zungqr( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),
594 $ work(iorgqr), lorgqrwork, info )
595 END IF
596 IF( wantv2t .AND. m-q .GT. 0 ) THEN
597 p1 = min( p+1, m )
598 q1 = min( q+1, m )
599 CALL zlacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t )
600 IF( m .GT. p+q ) THEN
601 CALL zlacpy( 'L', m-p-q, m-p-q, x22(p1,q1), ldx22,
602 $ v2t(p+1,p+1), ldv2t )
603 END IF
604 CALL zungqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),
605 $ work(iorgqr), lorgqrwork, info )
606 END IF
607 END IF
608*
609* Compute the CSD of the matrix in bidiagonal-block form
610*
611 CALL zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,
612 $ rwork(iphi), u1, ldu1, u2, ldu2, v1t, ldv1t, v2t,
613 $ ldv2t, rwork(ib11d), rwork(ib11e), rwork(ib12d),
614 $ rwork(ib12e), rwork(ib21d), rwork(ib21e),
615 $ rwork(ib22d), rwork(ib22e), rwork(ibbcsd),
616 $ lbbcsdwork, info )
617*
618* Permute rows and columns to place identity submatrices in top-
619* left corner of (1,1)-block and/or bottom-right corner of (1,2)-
620* block and/or bottom-right corner of (2,1)-block and/or top-left
621* corner of (2,2)-block
622*
623 IF( q .GT. 0 .AND. wantu2 ) THEN
624 DO i = 1, q
625 iwork(i) = m - p - q + i
626 END DO
627 DO i = q + 1, m - p
628 iwork(i) = i - q
629 END DO
630 IF( colmajor ) THEN
631 CALL zlapmt( .false., m-p, m-p, u2, ldu2, iwork )
632 ELSE
633 CALL zlapmr( .false., m-p, m-p, u2, ldu2, iwork )
634 END IF
635 END IF
636 IF( m .GT. 0 .AND. wantv2t ) THEN
637 DO i = 1, p
638 iwork(i) = m - p - q + i
639 END DO
640 DO i = p + 1, m - q
641 iwork(i) = i - p
642 END DO
643 IF( .NOT. colmajor ) THEN
644 CALL zlapmt( .false., m-q, m-q, v2t, ldv2t, iwork )
645 ELSE
646 CALL zlapmr( .false., m-q, m-q, v2t, ldv2t, iwork )
647 END IF
648 END IF
649*
650 RETURN
651*
652* End ZUNCSD
653*
zlapmr
subroutine zlapmr(forwrd, m, n, x, ldx, k)
ZLAPMR rearranges rows of a matrix as specified by a permutation vector.
Definition zlapmr.f:104
zunbdb
subroutine zunbdb(trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, lwork, info)
ZUNBDB
Definition zunbdb.f:287
zuncsd
recursive subroutine zuncsd(jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, work, lwork, rwork, lrwork, iwork, info)
ZUNCSD
Definition zuncsd.f:320
zunglq
subroutine zunglq(m, n, k, a, lda, tau, work, lwork, info)
ZUNGLQ
Definition zunglq.f:127
zungqr
subroutine zungqr(m, n, k, a, lda, tau, work, lwork, info)
ZUNGQR
Definition zungqr.f:128
zbbcsd
subroutine zbbcsd(jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta, phi, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, rwork, lrwork, info)
ZBBCSD
Definition zbbcsd.f:332

◆ zuncsd2by1()

subroutine zuncsd2by1 ( character jobu1,
character jobu2,
character jobv1t,
integer m,
integer p,
integer q,
complex*16, dimension(ldx11,*) x11,
integer ldx11,
complex*16, dimension(ldx21,*) x21,
integer ldx21,
double precision, dimension(*) theta,
complex*16, dimension(ldu1,*) u1,
integer ldu1,
complex*16, dimension(ldu2,*) u2,
integer ldu2,
complex*16, dimension(ldv1t,*) v1t,
integer ldv1t,
complex*16, dimension(*) work,
integer lwork,
double precision, dimension(*) rwork,
integer lrwork,
integer, dimension(*) iwork,
integer info )

ZUNCSD2BY1

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

Purpose:
!>
!> ZUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
!> orthonormal columns that has been partitioned into a 2-by-1 block
!> structure:
!>
!>                                [  I1 0  0 ]
!>                                [  0  C  0 ]
!>          [ X11 ]   [ U1 |    ] [  0  0  0 ]
!>      X = [-----] = [---------] [----------] V1**T .
!>          [ X21 ]   [    | U2 ] [  0  0  0 ]
!>                                [  0  S  0 ]
!>                                [  0  0  I2]
!>
!> X11 is P-by-Q. The unitary matrices U1, U2, and V1 are P-by-P,
!> (M-P)-by-(M-P), and Q-by-Q, respectively. C and S are R-by-R
!> nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which
!> R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a
!> K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0).
!>
Parameters
[in]JOBU1
!>          JOBU1 is CHARACTER
!>          = 'Y':      U1 is computed;
!>          otherwise:  U1 is not computed.
!>
[in]JOBU2
!>          JOBU2 is CHARACTER
!>          = 'Y':      U2 is computed;
!>          otherwise:  U2 is not computed.
!>
[in]JOBV1T
!>          JOBV1T is CHARACTER
!>          = 'Y':      V1T is computed;
!>          otherwise:  V1T is not computed.
!>
[in]M
!>          M is INTEGER
!>          The number of rows in X.
!>
[in]P
!>          P is INTEGER
!>          The number of rows in X11. 0 <= P <= M.
!>
[in]Q
!>          Q is INTEGER
!>          The number of columns in X11 and X21. 0 <= Q <= M.
!>
[in,out]X11
!>          X11 is COMPLEX*16 array, dimension (LDX11,Q)
!>          On entry, part of the unitary matrix whose CSD is desired.
!>
[in]LDX11
!>          LDX11 is INTEGER
!>          The leading dimension of X11. LDX11 >= MAX(1,P).
!>
[in,out]X21
!>          X21 is COMPLEX*16 array, dimension (LDX21,Q)
!>          On entry, part of the unitary matrix whose CSD is desired.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>          The leading dimension of X21. LDX21 >= MAX(1,M-P).
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (R), in which R =
!>          MIN(P,M-P,Q,M-Q).
!>          C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
!>          S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
!>
[out]U1
!>          U1 is COMPLEX*16 array, dimension (P)
!>          If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.
!>
[in]LDU1
!>          LDU1 is INTEGER
!>          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
!>          MAX(1,P).
!>
[out]U2
!>          U2 is COMPLEX*16 array, dimension (M-P)
!>          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary
!>          matrix U2.
!>
[in]LDU2
!>          LDU2 is INTEGER
!>          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
!>          MAX(1,M-P).
!>
[out]V1T
!>          V1T is COMPLEX*16 array, dimension (Q)
!>          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary
!>          matrix V1**T.
!>
[in]LDV1T
!>          LDV1T is INTEGER
!>          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
!>          MAX(1,Q).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK and RWORK
!>          arrays, returns this value as the first entry of the WORK
!>          and RWORK array, respectively, and no error message related
!>          to LWORK or LRWORK is issued by XERBLA.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
!>          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
!>          If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),
!>          ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
!>          define the matrix in intermediate bidiagonal-block form
!>          remaining after nonconvergence. INFO specifies the number
!>          of nonzero PHI's.
!>
[in]LRWORK
!>          LRWORK is INTEGER
!>          The dimension of the array RWORK.
!>
!>          If LRWORK=-1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK and RWORK
!>          arrays, returns this value as the first entry of the WORK
!>          and RWORK array, respectively, and no error message related
!>          to LWORK or LRWORK is issued by XERBLA.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  ZBBCSD did not converge. See the description of WORK
!>                above for details.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 252 of file zuncsd2by1.f.

256*
257* -- LAPACK computational routine --
258* -- LAPACK is a software package provided by Univ. of Tennessee, --
259* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
260*
261* .. Scalar Arguments ..
262 CHARACTER JOBU1, JOBU2, JOBV1T
263 INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
264 $ M, P, Q
265 INTEGER LRWORK, LRWORKMIN, LRWORKOPT
266* ..
267* .. Array Arguments ..
268 DOUBLE PRECISION RWORK(*)
269 DOUBLE PRECISION THETA(*)
270 COMPLEX*16 U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
271 $ X11(LDX11,*), X21(LDX21,*)
272 INTEGER IWORK(*)
273* ..
274*
275* =====================================================================
276*
277* .. Parameters ..
278 COMPLEX*16 ONE, ZERO
279 parameter( one = (1.0d0,0.0d0), zero = (0.0d0,0.0d0) )
280* ..
281* .. Local Scalars ..
282 INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
283 $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
284 $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
285 $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
286 $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
287 $ LWORKMIN, LWORKOPT, R
288 LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
289* ..
290* .. Local Arrays ..
291 DOUBLE PRECISION DUM( 1 )
292 COMPLEX*16 CDUM( 1, 1 )
293* ..
294* .. External Subroutines ..
295 EXTERNAL zbbcsd, zcopy, zlacpy, zlapmr, zlapmt, zunbdb1,
296 $ zunbdb2, zunbdb3, zunbdb4, zunglq, zungqr,
297 $ xerbla
298* ..
299* .. External Functions ..
300 LOGICAL LSAME
301 EXTERNAL lsame
302* ..
303* .. Intrinsic Function ..
304 INTRINSIC int, max, min
305* ..
306* .. Executable Statements ..
307*
308* Test input arguments
309*
310 info = 0
311 wantu1 = lsame( jobu1, 'Y' )
312 wantu2 = lsame( jobu2, 'Y' )
313 wantv1t = lsame( jobv1t, 'Y' )
314 lquery = ( lwork.EQ.-1 ) .OR. ( lrwork.EQ.-1 )
315*
316 IF( m .LT. 0 ) THEN
317 info = -4
318 ELSE IF( p .LT. 0 .OR. p .GT. m ) THEN
319 info = -5
320 ELSE IF( q .LT. 0 .OR. q .GT. m ) THEN
321 info = -6
322 ELSE IF( ldx11 .LT. max( 1, p ) ) THEN
323 info = -8
324 ELSE IF( ldx21 .LT. max( 1, m-p ) ) THEN
325 info = -10
326 ELSE IF( wantu1 .AND. ldu1 .LT. max( 1, p ) ) THEN
327 info = -13
328 ELSE IF( wantu2 .AND. ldu2 .LT. max( 1, m - p ) ) THEN
329 info = -15
330 ELSE IF( wantv1t .AND. ldv1t .LT. max( 1, q ) ) THEN
331 info = -17
332 END IF
333*
334 r = min( p, m-p, q, m-q )
335*
336* Compute workspace
337*
338* WORK layout:
339* |-----------------------------------------|
340* | LWORKOPT (1) |
341* |-----------------------------------------|
342* | TAUP1 (MAX(1,P)) |
343* | TAUP2 (MAX(1,M-P)) |
344* | TAUQ1 (MAX(1,Q)) |
345* |-----------------------------------------|
346* | ZUNBDB WORK | ZUNGQR WORK | ZUNGLQ WORK |
347* | | | |
348* | | | |
349* | | | |
350* | | | |
351* |-----------------------------------------|
352* RWORK layout:
353* |------------------|
354* | LRWORKOPT (1) |
355* |------------------|
356* | PHI (MAX(1,R-1)) |
357* |------------------|
358* | B11D (R) |
359* | B11E (R-1) |
360* | B12D (R) |
361* | B12E (R-1) |
362* | B21D (R) |
363* | B21E (R-1) |
364* | B22D (R) |
365* | B22E (R-1) |
366* | ZBBCSD RWORK |
367* |------------------|
368*
369 IF( info .EQ. 0 ) THEN
370 iphi = 2
371 ib11d = iphi + max( 1, r-1 )
372 ib11e = ib11d + max( 1, r )
373 ib12d = ib11e + max( 1, r - 1 )
374 ib12e = ib12d + max( 1, r )
375 ib21d = ib12e + max( 1, r - 1 )
376 ib21e = ib21d + max( 1, r )
377 ib22d = ib21e + max( 1, r - 1 )
378 ib22e = ib22d + max( 1, r )
379 ibbcsd = ib22e + max( 1, r - 1 )
380 itaup1 = 2
381 itaup2 = itaup1 + max( 1, p )
382 itauq1 = itaup2 + max( 1, m-p )
383 iorbdb = itauq1 + max( 1, q )
384 iorgqr = itauq1 + max( 1, q )
385 iorglq = itauq1 + max( 1, q )
386 lorgqrmin = 1
387 lorgqropt = 1
388 lorglqmin = 1
389 lorglqopt = 1
390 IF( r .EQ. q ) THEN
391 CALL zunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, dum,
392 $ cdum, cdum, cdum, work, -1, childinfo )
393 lorbdb = int( work(1) )
394 IF( wantu1 .AND. p .GT. 0 ) THEN
395 CALL zungqr( p, p, q, u1, ldu1, cdum, work(1), -1,
396 $ childinfo )
397 lorgqrmin = max( lorgqrmin, p )
398 lorgqropt = max( lorgqropt, int( work(1) ) )
399 ENDIF
400 IF( wantu2 .AND. m-p .GT. 0 ) THEN
401 CALL zungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,
402 $ childinfo )
403 lorgqrmin = max( lorgqrmin, m-p )
404 lorgqropt = max( lorgqropt, int( work(1) ) )
405 END IF
406 IF( wantv1t .AND. q .GT. 0 ) THEN
407 CALL zunglq( q-1, q-1, q-1, v1t, ldv1t,
408 $ cdum, work(1), -1, childinfo )
409 lorglqmin = max( lorglqmin, q-1 )
410 lorglqopt = max( lorglqopt, int( work(1) ) )
411 END IF
412 CALL zbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,
413 $ dum, u1, ldu1, u2, ldu2, v1t, ldv1t, cdum, 1,
414 $ dum, dum, dum, dum, dum, dum, dum, dum,
415 $ rwork(1), -1, childinfo )
416 lbbcsd = int( rwork(1) )
417 ELSE IF( r .EQ. p ) THEN
418 CALL zunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, dum,
419 $ cdum, cdum, cdum, work(1), -1, childinfo )
420 lorbdb = int( work(1) )
421 IF( wantu1 .AND. p .GT. 0 ) THEN
422 CALL zungqr( p-1, p-1, p-1, u1(2,2), ldu1, cdum, work(1),
423 $ -1, childinfo )
424 lorgqrmin = max( lorgqrmin, p-1 )
425 lorgqropt = max( lorgqropt, int( work(1) ) )
426 END IF
427 IF( wantu2 .AND. m-p .GT. 0 ) THEN
428 CALL zungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,
429 $ childinfo )
430 lorgqrmin = max( lorgqrmin, m-p )
431 lorgqropt = max( lorgqropt, int( work(1) ) )
432 END IF
433 IF( wantv1t .AND. q .GT. 0 ) THEN
434 CALL zunglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,
435 $ childinfo )
436 lorglqmin = max( lorglqmin, q )
437 lorglqopt = max( lorglqopt, int( work(1) ) )
438 END IF
439 CALL zbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,
440 $ dum, v1t, ldv1t, cdum, 1, u1, ldu1, u2, ldu2,
441 $ dum, dum, dum, dum, dum, dum, dum, dum,
442 $ rwork(1), -1, childinfo )
443 lbbcsd = int( rwork(1) )
444 ELSE IF( r .EQ. m-p ) THEN
445 CALL zunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, dum,
446 $ cdum, cdum, cdum, work(1), -1, childinfo )
447 lorbdb = int( work(1) )
448 IF( wantu1 .AND. p .GT. 0 ) THEN
449 CALL zungqr( p, p, q, u1, ldu1, cdum, work(1), -1,
450 $ childinfo )
451 lorgqrmin = max( lorgqrmin, p )
452 lorgqropt = max( lorgqropt, int( work(1) ) )
453 END IF
454 IF( wantu2 .AND. m-p .GT. 0 ) THEN
455 CALL zungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2, cdum,
456 $ work(1), -1, childinfo )
457 lorgqrmin = max( lorgqrmin, m-p-1 )
458 lorgqropt = max( lorgqropt, int( work(1) ) )
459 END IF
460 IF( wantv1t .AND. q .GT. 0 ) THEN
461 CALL zunglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,
462 $ childinfo )
463 lorglqmin = max( lorglqmin, q )
464 lorglqopt = max( lorglqopt, int( work(1) ) )
465 END IF
466 CALL zbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,
467 $ theta, dum, cdum, 1, v1t, ldv1t, u2, ldu2, u1,
468 $ ldu1, dum, dum, dum, dum, dum, dum, dum, dum,
469 $ rwork(1), -1, childinfo )
470 lbbcsd = int( rwork(1) )
471 ELSE
472 CALL zunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, dum,
473 $ cdum, cdum, cdum, cdum, work(1), -1, childinfo
474 $ )
475 lorbdb = m + int( work(1) )
476 IF( wantu1 .AND. p .GT. 0 ) THEN
477 CALL zungqr( p, p, m-q, u1, ldu1, cdum, work(1), -1,
478 $ childinfo )
479 lorgqrmin = max( lorgqrmin, p )
480 lorgqropt = max( lorgqropt, int( work(1) ) )
481 END IF
482 IF( wantu2 .AND. m-p .GT. 0 ) THEN
483 CALL zungqr( m-p, m-p, m-q, u2, ldu2, cdum, work(1), -1,
484 $ childinfo )
485 lorgqrmin = max( lorgqrmin, m-p )
486 lorgqropt = max( lorgqropt, int( work(1) ) )
487 END IF
488 IF( wantv1t .AND. q .GT. 0 ) THEN
489 CALL zunglq( q, q, q, v1t, ldv1t, cdum, work(1), -1,
490 $ childinfo )
491 lorglqmin = max( lorglqmin, q )
492 lorglqopt = max( lorglqopt, int( work(1) ) )
493 END IF
494 CALL zbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,
495 $ theta, dum, u2, ldu2, u1, ldu1, cdum, 1, v1t,
496 $ ldv1t, dum, dum, dum, dum, dum, dum, dum, dum,
497 $ rwork(1), -1, childinfo )
498 lbbcsd = int( rwork(1) )
499 END IF
500 lrworkmin = ibbcsd+lbbcsd-1
501 lrworkopt = lrworkmin
502 rwork(1) = lrworkopt
503 lworkmin = max( iorbdb+lorbdb-1,
504 $ iorgqr+lorgqrmin-1,
505 $ iorglq+lorglqmin-1 )
506 lworkopt = max( iorbdb+lorbdb-1,
507 $ iorgqr+lorgqropt-1,
508 $ iorglq+lorglqopt-1 )
509 work(1) = lworkopt
510 IF( lwork .LT. lworkmin .AND. .NOT.lquery ) THEN
511 info = -19
512 END IF
513 IF( lrwork .LT. lrworkmin .AND. .NOT.lquery ) THEN
514 info = -21
515 END IF
516 END IF
517 IF( info .NE. 0 ) THEN
518 CALL xerbla( 'ZUNCSD2BY1', -info )
519 RETURN
520 ELSE IF( lquery ) THEN
521 RETURN
522 END IF
523 lorgqr = lwork-iorgqr+1
524 lorglq = lwork-iorglq+1
525*
526* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
527* in which R = MIN(P,M-P,Q,M-Q)
528*
529 IF( r .EQ. q ) THEN
530*
531* Case 1: R = Q
532*
533* Simultaneously bidiagonalize X11 and X21
534*
535 CALL zunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,
536 $ rwork(iphi), work(itaup1), work(itaup2),
537 $ work(itauq1), work(iorbdb), lorbdb, childinfo )
538*
539* Accumulate Householder reflectors
540*
541 IF( wantu1 .AND. p .GT. 0 ) THEN
542 CALL zlacpy( 'L', p, q, x11, ldx11, u1, ldu1 )
543 CALL zungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),
544 $ lorgqr, childinfo )
545 END IF
546 IF( wantu2 .AND. m-p .GT. 0 ) THEN
547 CALL zlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 )
548 CALL zungqr( m-p, m-p, q, u2, ldu2, work(itaup2),
549 $ work(iorgqr), lorgqr, childinfo )
550 END IF
551 IF( wantv1t .AND. q .GT. 0 ) THEN
552 v1t(1,1) = one
553 DO j = 2, q
554 v1t(1,j) = zero
555 v1t(j,1) = zero
556 END DO
557 CALL zlacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),
558 $ ldv1t )
559 CALL zunglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),
560 $ work(iorglq), lorglq, childinfo )
561 END IF
562*
563* Simultaneously diagonalize X11 and X21.
564*
565 CALL zbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,
566 $ rwork(iphi), u1, ldu1, u2, ldu2, v1t, ldv1t, cdum,
567 $ 1, rwork(ib11d), rwork(ib11e), rwork(ib12d),
568 $ rwork(ib12e), rwork(ib21d), rwork(ib21e),
569 $ rwork(ib22d), rwork(ib22e), rwork(ibbcsd),
570 $ lrwork-ibbcsd+1, childinfo )
571*
572* Permute rows and columns to place zero submatrices in
573* preferred positions
574*
575 IF( q .GT. 0 .AND. wantu2 ) THEN
576 DO i = 1, q
577 iwork(i) = m - p - q + i
578 END DO
579 DO i = q + 1, m - p
580 iwork(i) = i - q
581 END DO
582 CALL zlapmt( .false., m-p, m-p, u2, ldu2, iwork )
583 END IF
584 ELSE IF( r .EQ. p ) THEN
585*
586* Case 2: R = P
587*
588* Simultaneously bidiagonalize X11 and X21
589*
590 CALL zunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,
591 $ rwork(iphi), work(itaup1), work(itaup2),
592 $ work(itauq1), work(iorbdb), lorbdb, childinfo )
593*
594* Accumulate Householder reflectors
595*
596 IF( wantu1 .AND. p .GT. 0 ) THEN
597 u1(1,1) = one
598 DO j = 2, p
599 u1(1,j) = zero
600 u1(j,1) = zero
601 END DO
602 CALL zlacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 )
603 CALL zungqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),
604 $ work(iorgqr), lorgqr, childinfo )
605 END IF
606 IF( wantu2 .AND. m-p .GT. 0 ) THEN
607 CALL zlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 )
608 CALL zungqr( m-p, m-p, q, u2, ldu2, work(itaup2),
609 $ work(iorgqr), lorgqr, childinfo )
610 END IF
611 IF( wantv1t .AND. q .GT. 0 ) THEN
612 CALL zlacpy( 'U', p, q, x11, ldx11, v1t, ldv1t )
613 CALL zunglq( q, q, r, v1t, ldv1t, work(itauq1),
614 $ work(iorglq), lorglq, childinfo )
615 END IF
616*
617* Simultaneously diagonalize X11 and X21.
618*
619 CALL zbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,
620 $ rwork(iphi), v1t, ldv1t, cdum, 1, u1, ldu1, u2,
621 $ ldu2, rwork(ib11d), rwork(ib11e), rwork(ib12d),
622 $ rwork(ib12e), rwork(ib21d), rwork(ib21e),
623 $ rwork(ib22d), rwork(ib22e), rwork(ibbcsd), lbbcsd,
624 $ childinfo )
625*
626* Permute rows and columns to place identity submatrices in
627* preferred positions
628*
629 IF( q .GT. 0 .AND. wantu2 ) THEN
630 DO i = 1, q
631 iwork(i) = m - p - q + i
632 END DO
633 DO i = q + 1, m - p
634 iwork(i) = i - q
635 END DO
636 CALL zlapmt( .false., m-p, m-p, u2, ldu2, iwork )
637 END IF
638 ELSE IF( r .EQ. m-p ) THEN
639*
640* Case 3: R = M-P
641*
642* Simultaneously bidiagonalize X11 and X21
643*
644 CALL zunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,
645 $ rwork(iphi), work(itaup1), work(itaup2),
646 $ work(itauq1), work(iorbdb), lorbdb, childinfo )
647*
648* Accumulate Householder reflectors
649*
650 IF( wantu1 .AND. p .GT. 0 ) THEN
651 CALL zlacpy( 'L', p, q, x11, ldx11, u1, ldu1 )
652 CALL zungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),
653 $ lorgqr, childinfo )
654 END IF
655 IF( wantu2 .AND. m-p .GT. 0 ) THEN
656 u2(1,1) = one
657 DO j = 2, m-p
658 u2(1,j) = zero
659 u2(j,1) = zero
660 END DO
661 CALL zlacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),
662 $ ldu2 )
663 CALL zungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,
664 $ work(itaup2), work(iorgqr), lorgqr, childinfo )
665 END IF
666 IF( wantv1t .AND. q .GT. 0 ) THEN
667 CALL zlacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t )
668 CALL zunglq( q, q, r, v1t, ldv1t, work(itauq1),
669 $ work(iorglq), lorglq, childinfo )
670 END IF
671*
672* Simultaneously diagonalize X11 and X21.
673*
674 CALL zbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,
675 $ theta, rwork(iphi), cdum, 1, v1t, ldv1t, u2, ldu2,
676 $ u1, ldu1, rwork(ib11d), rwork(ib11e),
677 $ rwork(ib12d), rwork(ib12e), rwork(ib21d),
678 $ rwork(ib21e), rwork(ib22d), rwork(ib22e),
679 $ rwork(ibbcsd), lbbcsd, childinfo )
680*
681* Permute rows and columns to place identity submatrices in
682* preferred positions
683*
684 IF( q .GT. r ) THEN
685 DO i = 1, r
686 iwork(i) = q - r + i
687 END DO
688 DO i = r + 1, q
689 iwork(i) = i - r
690 END DO
691 IF( wantu1 ) THEN
692 CALL zlapmt( .false., p, q, u1, ldu1, iwork )
693 END IF
694 IF( wantv1t ) THEN
695 CALL zlapmr( .false., q, q, v1t, ldv1t, iwork )
696 END IF
697 END IF
698 ELSE
699*
700* Case 4: R = M-Q
701*
702* Simultaneously bidiagonalize X11 and X21
703*
704 CALL zunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,
705 $ rwork(iphi), work(itaup1), work(itaup2),
706 $ work(itauq1), work(iorbdb), work(iorbdb+m),
707 $ lorbdb-m, childinfo )
708*
709* Accumulate Householder reflectors
710*
711 IF( wantu2 .AND. m-p .GT. 0 ) THEN
712 CALL zcopy( m-p, work(iorbdb+p), 1, u2, 1 )
713 END IF
714 IF( wantu1 .AND. p .GT. 0 ) THEN
715 CALL zcopy( p, work(iorbdb), 1, u1, 1 )
716 DO j = 2, p
717 u1(1,j) = zero
718 END DO
719 CALL zlacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),
720 $ ldu1 )
721 CALL zungqr( p, p, m-q, u1, ldu1, work(itaup1),
722 $ work(iorgqr), lorgqr, childinfo )
723 END IF
724 IF( wantu2 .AND. m-p .GT. 0 ) THEN
725 DO j = 2, m-p
726 u2(1,j) = zero
727 END DO
728 CALL zlacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),
729 $ ldu2 )
730 CALL zungqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),
731 $ work(iorgqr), lorgqr, childinfo )
732 END IF
733 IF( wantv1t .AND. q .GT. 0 ) THEN
734 CALL zlacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t )
735 CALL zlacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,
736 $ v1t(m-q+1,m-q+1), ldv1t )
737 CALL zlacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,
738 $ v1t(p+1,p+1), ldv1t )
739 CALL zunglq( q, q, q, v1t, ldv1t, work(itauq1),
740 $ work(iorglq), lorglq, childinfo )
741 END IF
742*
743* Simultaneously diagonalize X11 and X21.
744*
745 CALL zbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,
746 $ theta, rwork(iphi), u2, ldu2, u1, ldu1, cdum, 1,
747 $ v1t, ldv1t, rwork(ib11d), rwork(ib11e),
748 $ rwork(ib12d), rwork(ib12e), rwork(ib21d),
749 $ rwork(ib21e), rwork(ib22d), rwork(ib22e),
750 $ rwork(ibbcsd), lbbcsd, childinfo )
751*
752* Permute rows and columns to place identity submatrices in
753* preferred positions
754*
755 IF( p .GT. r ) THEN
756 DO i = 1, r
757 iwork(i) = p - r + i
758 END DO
759 DO i = r + 1, p
760 iwork(i) = i - r
761 END DO
762 IF( wantu1 ) THEN
763 CALL zlapmt( .false., p, p, u1, ldu1, iwork )
764 END IF
765 IF( wantv1t ) THEN
766 CALL zlapmr( .false., p, q, v1t, ldv1t, iwork )
767 END IF
768 END IF
769 END IF
770*
771 RETURN
772*
773* End of ZUNCSD2BY1
774*
zunbdb3
subroutine zunbdb3(m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
ZUNBDB3
Definition zunbdb3.f:201
zunbdb4
subroutine zunbdb4(m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, phantom, work, lwork, info)
ZUNBDB4
Definition zunbdb4.f:213
zunbdb1
subroutine zunbdb1(m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
ZUNBDB1
Definition zunbdb1.f:203
zunbdb2
subroutine zunbdb2(m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
ZUNBDB2
Definition zunbdb2.f:201

◆ zung2l()

subroutine zung2l ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer info )

ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm).

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

Purpose:
!>
!> ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
!> which is defined as the last n columns of a product of k elementary
!> reflectors of order m
!>
!>       Q  =  H(k) . . . H(2) H(1)
!>
!> as returned by ZGEQLF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q. M >= N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. N >= K >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the (n-k+i)-th column must contain the vector which
!>          defines the elementary reflector H(i), for i = 1,2,...,k, as
!>          returned by ZGEQLF in the last k columns of its array
!>          argument A.
!>          On exit, the m-by-n matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The first dimension of the array A. LDA >= max(1,M).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGEQLF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument has an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 113 of file zung2l.f.

114*
115* -- LAPACK computational 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 INFO, K, LDA, M, N
121* ..
122* .. Array Arguments ..
123 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 COMPLEX*16 ONE, ZERO
130 parameter( one = ( 1.0d+0, 0.0d+0 ),
131 $ zero = ( 0.0d+0, 0.0d+0 ) )
132* ..
133* .. Local Scalars ..
134 INTEGER I, II, J, L
135* ..
136* .. External Subroutines ..
137 EXTERNAL xerbla, zlarf, zscal
138* ..
139* .. Intrinsic Functions ..
140 INTRINSIC max
141* ..
142* .. Executable Statements ..
143*
144* Test the input arguments
145*
146 info = 0
147 IF( m.LT.0 ) THEN
148 info = -1
149 ELSE IF( n.LT.0 .OR. n.GT.m ) THEN
150 info = -2
151 ELSE IF( k.LT.0 .OR. k.GT.n ) THEN
152 info = -3
153 ELSE IF( lda.LT.max( 1, m ) ) THEN
154 info = -5
155 END IF
156 IF( info.NE.0 ) THEN
157 CALL xerbla( 'ZUNG2L', -info )
158 RETURN
159 END IF
160*
161* Quick return if possible
162*
163 IF( n.LE.0 )
164 $ RETURN
165*
166* Initialise columns 1:n-k to columns of the unit matrix
167*
168 DO 20 j = 1, n - k
169 DO 10 l = 1, m
170 a( l, j ) = zero
171 10 CONTINUE
172 a( m-n+j, j ) = one
173 20 CONTINUE
174*
175 DO 40 i = 1, k
176 ii = n - k + i
177*
178* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
179*
180 a( m-n+ii, ii ) = one
181 CALL zlarf( 'Left', m-n+ii, ii-1, a( 1, ii ), 1, tau( i ), a,
182 $ lda, work )
183 CALL zscal( m-n+ii-1, -tau( i ), a( 1, ii ), 1 )
184 a( m-n+ii, ii ) = one - tau( i )
185*
186* Set A(m-k+i+1:m,n-k+i) to zero
187*
188 DO 30 l = m - n + ii + 1, m
189 a( l, ii ) = zero
190 30 CONTINUE
191 40 CONTINUE
192 RETURN
193*
194* End of ZUNG2L
195*

◆ zung2r()

subroutine zung2r ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer info )

ZUNG2R

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

Purpose:
!>
!> ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
!> which is defined as the first n columns of a product of k elementary
!> reflectors of order m
!>
!>       Q  =  H(1) H(2) . . . H(k)
!>
!> as returned by ZGEQRF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q. M >= N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. N >= K >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the i-th column must contain the vector which
!>          defines the elementary reflector H(i), for i = 1,2,...,k, as
!>          returned by ZGEQRF in the first k columns of its array
!>          argument A.
!>          On exit, the m by n matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The first dimension of the array A. LDA >= max(1,M).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGEQRF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument has an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 113 of file zung2r.f.

114*
115* -- LAPACK computational 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 INFO, K, LDA, M, N
121* ..
122* .. Array Arguments ..
123 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 COMPLEX*16 ONE, ZERO
130 parameter( one = ( 1.0d+0, 0.0d+0 ),
131 $ zero = ( 0.0d+0, 0.0d+0 ) )
132* ..
133* .. Local Scalars ..
134 INTEGER I, J, L
135* ..
136* .. External Subroutines ..
137 EXTERNAL xerbla, zlarf, zscal
138* ..
139* .. Intrinsic Functions ..
140 INTRINSIC max
141* ..
142* .. Executable Statements ..
143*
144* Test the input arguments
145*
146 info = 0
147 IF( m.LT.0 ) THEN
148 info = -1
149 ELSE IF( n.LT.0 .OR. n.GT.m ) THEN
150 info = -2
151 ELSE IF( k.LT.0 .OR. k.GT.n ) THEN
152 info = -3
153 ELSE IF( lda.LT.max( 1, m ) ) THEN
154 info = -5
155 END IF
156 IF( info.NE.0 ) THEN
157 CALL xerbla( 'ZUNG2R', -info )
158 RETURN
159 END IF
160*
161* Quick return if possible
162*
163 IF( n.LE.0 )
164 $ RETURN
165*
166* Initialise columns k+1:n to columns of the unit matrix
167*
168 DO 20 j = k + 1, n
169 DO 10 l = 1, m
170 a( l, j ) = zero
171 10 CONTINUE
172 a( j, j ) = one
173 20 CONTINUE
174*
175 DO 40 i = k, 1, -1
176*
177* Apply H(i) to A(i:m,i:n) from the left
178*
179 IF( i.LT.n ) THEN
180 a( i, i ) = one
181 CALL zlarf( 'Left', m-i+1, n-i, a( i, i ), 1, tau( i ),
182 $ a( i, i+1 ), lda, work )
183 END IF
184 IF( i.LT.m )
185 $ CALL zscal( m-i, -tau( i ), a( i+1, i ), 1 )
186 a( i, i ) = one - tau( i )
187*
188* Set A(1:i-1,i) to zero
189*
190 DO 30 l = 1, i - 1
191 a( l, i ) = zero
192 30 CONTINUE
193 40 CONTINUE
194 RETURN
195*
196* End of ZUNG2R
197*

◆ zunghr()

subroutine zunghr ( integer n,
integer ilo,
integer ihi,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNGHR

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

Purpose:
!>
!> ZUNGHR generates a complex unitary matrix Q which is defined as the
!> product of IHI-ILO elementary reflectors of order N, as returned by
!> ZGEHRD:
!>
!> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix Q. N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
!>          ILO and IHI must have the same values as in the previous call
!>          of ZGEHRD. Q is equal to the unit matrix except in the
!>          submatrix Q(ilo+1:ihi,ilo+1:ihi).
!>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the vectors which define the elementary reflectors,
!>          as returned by ZGEHRD.
!>          On exit, the N-by-N unitary matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGEHRD.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= IHI-ILO.
!>          For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
!>          the optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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 125 of file zunghr.f.

126*
127* -- LAPACK computational 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 INTEGER IHI, ILO, INFO, LDA, LWORK, N
133* ..
134* .. Array Arguments ..
135 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
136* ..
137*
138* =====================================================================
139*
140* .. Parameters ..
141 COMPLEX*16 ZERO, ONE
142 parameter( zero = ( 0.0d+0, 0.0d+0 ),
143 $ one = ( 1.0d+0, 0.0d+0 ) )
144* ..
145* .. Local Scalars ..
146 LOGICAL LQUERY
147 INTEGER I, IINFO, J, LWKOPT, NB, NH
148* ..
149* .. External Subroutines ..
150 EXTERNAL xerbla, zungqr
151* ..
152* .. External Functions ..
153 INTEGER ILAENV
154 EXTERNAL ilaenv
155* ..
156* .. Intrinsic Functions ..
157 INTRINSIC max, min
158* ..
159* .. Executable Statements ..
160*
161* Test the input arguments
162*
163 info = 0
164 nh = ihi - ilo
165 lquery = ( lwork.EQ.-1 )
166 IF( n.LT.0 ) THEN
167 info = -1
168 ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
169 info = -2
170 ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
171 info = -3
172 ELSE IF( lda.LT.max( 1, n ) ) THEN
173 info = -5
174 ELSE IF( lwork.LT.max( 1, nh ) .AND. .NOT.lquery ) THEN
175 info = -8
176 END IF
177*
178 IF( info.EQ.0 ) THEN
179 nb = ilaenv( 1, 'ZUNGQR', ' ', nh, nh, nh, -1 )
180 lwkopt = max( 1, nh )*nb
181 work( 1 ) = lwkopt
182 END IF
183*
184 IF( info.NE.0 ) THEN
185 CALL xerbla( 'ZUNGHR', -info )
186 RETURN
187 ELSE IF( lquery ) THEN
188 RETURN
189 END IF
190*
191* Quick return if possible
192*
193 IF( n.EQ.0 ) THEN
194 work( 1 ) = 1
195 RETURN
196 END IF
197*
198* Shift the vectors which define the elementary reflectors one
199* column to the right, and set the first ilo and the last n-ihi
200* rows and columns to those of the unit matrix
201*
202 DO 40 j = ihi, ilo + 1, -1
203 DO 10 i = 1, j - 1
204 a( i, j ) = zero
205 10 CONTINUE
206 DO 20 i = j + 1, ihi
207 a( i, j ) = a( i, j-1 )
208 20 CONTINUE
209 DO 30 i = ihi + 1, n
210 a( i, j ) = zero
211 30 CONTINUE
212 40 CONTINUE
213 DO 60 j = 1, ilo
214 DO 50 i = 1, n
215 a( i, j ) = zero
216 50 CONTINUE
217 a( j, j ) = one
218 60 CONTINUE
219 DO 80 j = ihi + 1, n
220 DO 70 i = 1, n
221 a( i, j ) = zero
222 70 CONTINUE
223 a( j, j ) = one
224 80 CONTINUE
225*
226 IF( nh.GT.0 ) THEN
227*
228* Generate Q(ilo+1:ihi,ilo+1:ihi)
229*
230 CALL zungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),
231 $ work, lwork, iinfo )
232 END IF
233 work( 1 ) = lwkopt
234 RETURN
235*
236* End of ZUNGHR
237*

◆ zungl2()

subroutine zungl2 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer info )

ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (unblocked algorithm).

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

Purpose:
!>
!> ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
!> which is defined as the first m rows of a product of k elementary
!> reflectors of order n
!>
!>       Q  =  H(k)**H . . . H(2)**H H(1)**H
!>
!> as returned by ZGELQF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q. N >= M.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. M >= K >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the i-th row must contain the vector which defines
!>          the elementary reflector H(i), for i = 1,2,...,k, as returned
!>          by ZGELQF in the first k rows of its array argument A.
!>          On exit, the m by n matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The first dimension of the array A. LDA >= max(1,M).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGELQF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (M)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument has an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 112 of file zungl2.f.

113*
114* -- LAPACK computational routine --
115* -- LAPACK is a software package provided by Univ. of Tennessee, --
116* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
117*
118* .. Scalar Arguments ..
119 INTEGER INFO, K, LDA, M, N
120* ..
121* .. Array Arguments ..
122 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 COMPLEX*16 ONE, ZERO
129 parameter( one = ( 1.0d+0, 0.0d+0 ),
130 $ zero = ( 0.0d+0, 0.0d+0 ) )
131* ..
132* .. Local Scalars ..
133 INTEGER I, J, L
134* ..
135* .. External Subroutines ..
136 EXTERNAL xerbla, zlacgv, zlarf, zscal
137* ..
138* .. Intrinsic Functions ..
139 INTRINSIC dconjg, max
140* ..
141* .. Executable Statements ..
142*
143* Test the input arguments
144*
145 info = 0
146 IF( m.LT.0 ) THEN
147 info = -1
148 ELSE IF( n.LT.m ) THEN
149 info = -2
150 ELSE IF( k.LT.0 .OR. k.GT.m ) THEN
151 info = -3
152 ELSE IF( lda.LT.max( 1, m ) ) THEN
153 info = -5
154 END IF
155 IF( info.NE.0 ) THEN
156 CALL xerbla( 'ZUNGL2', -info )
157 RETURN
158 END IF
159*
160* Quick return if possible
161*
162 IF( m.LE.0 )
163 $ RETURN
164*
165 IF( k.LT.m ) THEN
166*
167* Initialise rows k+1:m to rows of the unit matrix
168*
169 DO 20 j = 1, n
170 DO 10 l = k + 1, m
171 a( l, j ) = zero
172 10 CONTINUE
173 IF( j.GT.k .AND. j.LE.m )
174 $ a( j, j ) = one
175 20 CONTINUE
176 END IF
177*
178 DO 40 i = k, 1, -1
179*
180* Apply H(i)**H to A(i:m,i:n) from the right
181*
182 IF( i.LT.n ) THEN
183 CALL zlacgv( n-i, a( i, i+1 ), lda )
184 IF( i.LT.m ) THEN
185 a( i, i ) = one
186 CALL zlarf( 'Right', m-i, n-i+1, a( i, i ), lda,
187 $ dconjg( tau( i ) ), a( i+1, i ), lda, work )
188 END IF
189 CALL zscal( n-i, -tau( i ), a( i, i+1 ), lda )
190 CALL zlacgv( n-i, a( i, i+1 ), lda )
191 END IF
192 a( i, i ) = one - dconjg( tau( i ) )
193*
194* Set A(i,1:i-1) to zero
195*
196 DO 30 l = 1, i - 1
197 a( i, l ) = zero
198 30 CONTINUE
199 40 CONTINUE
200 RETURN
201*
202* End of ZUNGL2
203*

◆ zunglq()

subroutine zunglq ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNGLQ

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

Purpose:
!>
!> ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
!> which is defined as the first M rows of a product of K elementary
!> reflectors of order N
!>
!>       Q  =  H(k)**H . . . H(2)**H H(1)**H
!>
!> as returned by ZGELQF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q. N >= M.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. M >= K >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the i-th row must contain the vector which defines
!>          the elementary reflector H(i), for i = 1,2,...,k, as returned
!>          by ZGELQF in the first k rows of its array argument A.
!>          On exit, the M-by-N matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The first dimension of the array A. LDA >= max(1,M).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGELQF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,M).
!>          For optimum performance LWORK >= M*NB, where NB is
!>          the optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit;
!>          < 0:  if INFO = -i, the i-th argument has an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 126 of file zunglq.f.

127*
128* -- LAPACK computational routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 INTEGER INFO, K, LDA, LWORK, M, N
134* ..
135* .. Array Arguments ..
136 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 COMPLEX*16 ZERO
143 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
144* ..
145* .. Local Scalars ..
146 LOGICAL LQUERY
147 INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
148 $ LWKOPT, NB, NBMIN, NX
149* ..
150* .. External Subroutines ..
151 EXTERNAL xerbla, zlarfb, zlarft, zungl2
152* ..
153* .. Intrinsic Functions ..
154 INTRINSIC max, min
155* ..
156* .. External Functions ..
157 INTEGER ILAENV
158 EXTERNAL ilaenv
159* ..
160* .. Executable Statements ..
161*
162* Test the input arguments
163*
164 info = 0
165 nb = ilaenv( 1, 'ZUNGLQ', ' ', m, n, k, -1 )
166 lwkopt = max( 1, m )*nb
167 work( 1 ) = lwkopt
168 lquery = ( lwork.EQ.-1 )
169 IF( m.LT.0 ) THEN
170 info = -1
171 ELSE IF( n.LT.m ) THEN
172 info = -2
173 ELSE IF( k.LT.0 .OR. k.GT.m ) THEN
174 info = -3
175 ELSE IF( lda.LT.max( 1, m ) ) THEN
176 info = -5
177 ELSE IF( lwork.LT.max( 1, m ) .AND. .NOT.lquery ) THEN
178 info = -8
179 END IF
180 IF( info.NE.0 ) THEN
181 CALL xerbla( 'ZUNGLQ', -info )
182 RETURN
183 ELSE IF( lquery ) THEN
184 RETURN
185 END IF
186*
187* Quick return if possible
188*
189 IF( m.LE.0 ) THEN
190 work( 1 ) = 1
191 RETURN
192 END IF
193*
194 nbmin = 2
195 nx = 0
196 iws = m
197 IF( nb.GT.1 .AND. nb.LT.k ) THEN
198*
199* Determine when to cross over from blocked to unblocked code.
200*
201 nx = max( 0, ilaenv( 3, 'ZUNGLQ', ' ', m, n, k, -1 ) )
202 IF( nx.LT.k ) THEN
203*
204* Determine if workspace is large enough for blocked code.
205*
206 ldwork = m
207 iws = ldwork*nb
208 IF( lwork.LT.iws ) THEN
209*
210* Not enough workspace to use optimal NB: reduce NB and
211* determine the minimum value of NB.
212*
213 nb = lwork / ldwork
214 nbmin = max( 2, ilaenv( 2, 'ZUNGLQ', ' ', m, n, k, -1 ) )
215 END IF
216 END IF
217 END IF
218*
219 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
220*
221* Use blocked code after the last block.
222* The first kk rows are handled by the block method.
223*
224 ki = ( ( k-nx-1 ) / nb )*nb
225 kk = min( k, ki+nb )
226*
227* Set A(kk+1:m,1:kk) to zero.
228*
229 DO 20 j = 1, kk
230 DO 10 i = kk + 1, m
231 a( i, j ) = zero
232 10 CONTINUE
233 20 CONTINUE
234 ELSE
235 kk = 0
236 END IF
237*
238* Use unblocked code for the last or only block.
239*
240 IF( kk.LT.m )
241 $ CALL zungl2( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda,
242 $ tau( kk+1 ), work, iinfo )
243*
244 IF( kk.GT.0 ) THEN
245*
246* Use blocked code
247*
248 DO 50 i = ki + 1, 1, -nb
249 ib = min( nb, k-i+1 )
250 IF( i+ib.LE.m ) THEN
251*
252* Form the triangular factor of the block reflector
253* H = H(i) H(i+1) . . . H(i+ib-1)
254*
255 CALL zlarft( 'Forward', 'Rowwise', n-i+1, ib, a( i, i ),
256 $ lda, tau( i ), work, ldwork )
257*
258* Apply H**H to A(i+ib:m,i:n) from the right
259*
260 CALL zlarfb( 'Right', 'Conjugate transpose', 'Forward',
261 $ 'Rowwise', m-i-ib+1, n-i+1, ib, a( i, i ),
262 $ lda, work, ldwork, a( i+ib, i ), lda,
263 $ work( ib+1 ), ldwork )
264 END IF
265*
266* Apply H**H to columns i:n of current block
267*
268 CALL zungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,
269 $ iinfo )
270*
271* Set columns 1:i-1 of current block to zero
272*
273 DO 40 j = 1, i - 1
274 DO 30 l = i, i + ib - 1
275 a( l, j ) = zero
276 30 CONTINUE
277 40 CONTINUE
278 50 CONTINUE
279 END IF
280*
281 work( 1 ) = iws
282 RETURN
283*
284* End of ZUNGLQ
285*
zlarfb
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.
Definition zlarfb.f:197
zlarft
subroutine zlarft(direct, storev, n, k, v, ldv, tau, t, ldt)
ZLARFT forms the triangular factor T of a block reflector H = I - vtvH
Definition zlarft.f:163
zungl2
subroutine zungl2(m, n, k, a, lda, tau, work, info)
ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (u...
Definition zungl2.f:113

◆ zungql()

subroutine zungql ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNGQL

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

Purpose:
!>
!> ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,
!> which is defined as the last N columns of a product of K elementary
!> reflectors of order M
!>
!>       Q  =  H(k) . . . H(2) H(1)
!>
!> as returned by ZGEQLF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q. M >= N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. N >= K >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the (n-k+i)-th column must contain the vector which
!>          defines the elementary reflector H(i), for i = 1,2,...,k, as
!>          returned by ZGEQLF in the last k columns of its array
!>          argument A.
!>          On exit, the M-by-N matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The first dimension of the array A. LDA >= max(1,M).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGEQLF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,N).
!>          For optimum performance LWORK >= N*NB, where NB is the
!>          optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument has an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 127 of file zungql.f.

128*
129* -- LAPACK computational 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 INTEGER INFO, K, LDA, LWORK, M, N
135* ..
136* .. Array Arguments ..
137 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 COMPLEX*16 ZERO
144 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
145* ..
146* .. Local Scalars ..
147 LOGICAL LQUERY
148 INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
149 $ NB, NBMIN, NX
150* ..
151* .. External Subroutines ..
152 EXTERNAL xerbla, zlarfb, zlarft, zung2l
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC max, min
156* ..
157* .. External Functions ..
158 INTEGER ILAENV
159 EXTERNAL ilaenv
160* ..
161* .. Executable Statements ..
162*
163* Test the input arguments
164*
165 info = 0
166 lquery = ( lwork.EQ.-1 )
167 IF( m.LT.0 ) THEN
168 info = -1
169 ELSE IF( n.LT.0 .OR. n.GT.m ) THEN
170 info = -2
171 ELSE IF( k.LT.0 .OR. k.GT.n ) THEN
172 info = -3
173 ELSE IF( lda.LT.max( 1, m ) ) THEN
174 info = -5
175 END IF
176*
177 IF( info.EQ.0 ) THEN
178 IF( n.EQ.0 ) THEN
179 lwkopt = 1
180 ELSE
181 nb = ilaenv( 1, 'ZUNGQL', ' ', m, n, k, -1 )
182 lwkopt = n*nb
183 END IF
184 work( 1 ) = lwkopt
185*
186 IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
187 info = -8
188 END IF
189 END IF
190*
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'ZUNGQL', -info )
193 RETURN
194 ELSE IF( lquery ) THEN
195 RETURN
196 END IF
197*
198* Quick return if possible
199*
200 IF( n.LE.0 ) THEN
201 RETURN
202 END IF
203*
204 nbmin = 2
205 nx = 0
206 iws = n
207 IF( nb.GT.1 .AND. nb.LT.k ) THEN
208*
209* Determine when to cross over from blocked to unblocked code.
210*
211 nx = max( 0, ilaenv( 3, 'ZUNGQL', ' ', m, n, k, -1 ) )
212 IF( nx.LT.k ) THEN
213*
214* Determine if workspace is large enough for blocked code.
215*
216 ldwork = n
217 iws = ldwork*nb
218 IF( lwork.LT.iws ) THEN
219*
220* Not enough workspace to use optimal NB: reduce NB and
221* determine the minimum value of NB.
222*
223 nb = lwork / ldwork
224 nbmin = max( 2, ilaenv( 2, 'ZUNGQL', ' ', m, n, k, -1 ) )
225 END IF
226 END IF
227 END IF
228*
229 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
230*
231* Use blocked code after the first block.
232* The last kk columns are handled by the block method.
233*
234 kk = min( k, ( ( k-nx+nb-1 ) / nb )*nb )
235*
236* Set A(m-kk+1:m,1:n-kk) to zero.
237*
238 DO 20 j = 1, n - kk
239 DO 10 i = m - kk + 1, m
240 a( i, j ) = zero
241 10 CONTINUE
242 20 CONTINUE
243 ELSE
244 kk = 0
245 END IF
246*
247* Use unblocked code for the first or only block.
248*
249 CALL zung2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo )
250*
251 IF( kk.GT.0 ) THEN
252*
253* Use blocked code
254*
255 DO 50 i = k - kk + 1, k, nb
256 ib = min( nb, k-i+1 )
257 IF( n-k+i.GT.1 ) THEN
258*
259* Form the triangular factor of the block reflector
260* H = H(i+ib-1) . . . H(i+1) H(i)
261*
262 CALL zlarft( 'Backward', 'Columnwise', m-k+i+ib-1, ib,
263 $ a( 1, n-k+i ), lda, tau( i ), work, ldwork )
264*
265* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
266*
267 CALL zlarfb( 'Left', 'No transpose', 'Backward',
268 $ 'Columnwise', m-k+i+ib-1, n-k+i-1, ib,
269 $ a( 1, n-k+i ), lda, work, ldwork, a, lda,
270 $ work( ib+1 ), ldwork )
271 END IF
272*
273* Apply H to rows 1:m-k+i+ib-1 of current block
274*
275 CALL zung2l( m-k+i+ib-1, ib, ib, a( 1, n-k+i ), lda,
276 $ tau( i ), work, iinfo )
277*
278* Set rows m-k+i+ib:m of current block to zero
279*
280 DO 40 j = n - k + i, n - k + i + ib - 1
281 DO 30 l = m - k + i + ib, m
282 a( l, j ) = zero
283 30 CONTINUE
284 40 CONTINUE
285 50 CONTINUE
286 END IF
287*
288 work( 1 ) = iws
289 RETURN
290*
291* End of ZUNGQL
292*
zung2l
subroutine zung2l(m, n, k, a, lda, tau, work, info)
ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (un...
Definition zung2l.f:114

◆ zungqr()

subroutine zungqr ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNGQR

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

Purpose:
!>
!> ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,
!> which is defined as the first N columns of a product of K elementary
!> reflectors of order M
!>
!>       Q  =  H(1) H(2) . . . H(k)
!>
!> as returned by ZGEQRF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q. M >= N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. N >= K >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the i-th column must contain the vector which
!>          defines the elementary reflector H(i), for i = 1,2,...,k, as
!>          returned by ZGEQRF in the first k columns of its array
!>          argument A.
!>          On exit, the M-by-N matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The first dimension of the array A. LDA >= max(1,M).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGEQRF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,N).
!>          For optimum performance LWORK >= N*NB, where NB is the
!>          optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument has an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 127 of file zungqr.f.

128*
129* -- LAPACK computational 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 INTEGER INFO, K, LDA, LWORK, M, N
135* ..
136* .. Array Arguments ..
137 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 COMPLEX*16 ZERO
144 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
145* ..
146* .. Local Scalars ..
147 LOGICAL LQUERY
148 INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
149 $ LWKOPT, NB, NBMIN, NX
150* ..
151* .. External Subroutines ..
152 EXTERNAL xerbla, zlarfb, zlarft, zung2r
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC max, min
156* ..
157* .. External Functions ..
158 INTEGER ILAENV
159 EXTERNAL ilaenv
160* ..
161* .. Executable Statements ..
162*
163* Test the input arguments
164*
165 info = 0
166 nb = ilaenv( 1, 'ZUNGQR', ' ', m, n, k, -1 )
167 lwkopt = max( 1, n )*nb
168 work( 1 ) = lwkopt
169 lquery = ( lwork.EQ.-1 )
170 IF( m.LT.0 ) THEN
171 info = -1
172 ELSE IF( n.LT.0 .OR. n.GT.m ) THEN
173 info = -2
174 ELSE IF( k.LT.0 .OR. k.GT.n ) THEN
175 info = -3
176 ELSE IF( lda.LT.max( 1, m ) ) THEN
177 info = -5
178 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
179 info = -8
180 END IF
181 IF( info.NE.0 ) THEN
182 CALL xerbla( 'ZUNGQR', -info )
183 RETURN
184 ELSE IF( lquery ) THEN
185 RETURN
186 END IF
187*
188* Quick return if possible
189*
190 IF( n.LE.0 ) THEN
191 work( 1 ) = 1
192 RETURN
193 END IF
194*
195 nbmin = 2
196 nx = 0
197 iws = n
198 IF( nb.GT.1 .AND. nb.LT.k ) THEN
199*
200* Determine when to cross over from blocked to unblocked code.
201*
202 nx = max( 0, ilaenv( 3, 'ZUNGQR', ' ', m, n, k, -1 ) )
203 IF( nx.LT.k ) THEN
204*
205* Determine if workspace is large enough for blocked code.
206*
207 ldwork = n
208 iws = ldwork*nb
209 IF( lwork.LT.iws ) THEN
210*
211* Not enough workspace to use optimal NB: reduce NB and
212* determine the minimum value of NB.
213*
214 nb = lwork / ldwork
215 nbmin = max( 2, ilaenv( 2, 'ZUNGQR', ' ', m, n, k, -1 ) )
216 END IF
217 END IF
218 END IF
219*
220 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
221*
222* Use blocked code after the last block.
223* The first kk columns are handled by the block method.
224*
225 ki = ( ( k-nx-1 ) / nb )*nb
226 kk = min( k, ki+nb )
227*
228* Set A(1:kk,kk+1:n) to zero.
229*
230 DO 20 j = kk + 1, n
231 DO 10 i = 1, kk
232 a( i, j ) = zero
233 10 CONTINUE
234 20 CONTINUE
235 ELSE
236 kk = 0
237 END IF
238*
239* Use unblocked code for the last or only block.
240*
241 IF( kk.LT.n )
242 $ CALL zung2r( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda,
243 $ tau( kk+1 ), work, iinfo )
244*
245 IF( kk.GT.0 ) THEN
246*
247* Use blocked code
248*
249 DO 50 i = ki + 1, 1, -nb
250 ib = min( nb, k-i+1 )
251 IF( i+ib.LE.n ) THEN
252*
253* Form the triangular factor of the block reflector
254* H = H(i) H(i+1) . . . H(i+ib-1)
255*
256 CALL zlarft( 'Forward', 'Columnwise', m-i+1, ib,
257 $ a( i, i ), lda, tau( i ), work, ldwork )
258*
259* Apply H to A(i:m,i+ib:n) from the left
260*
261 CALL zlarfb( 'Left', 'No transpose', 'Forward',
262 $ 'Columnwise', m-i+1, n-i-ib+1, ib,
263 $ a( i, i ), lda, work, ldwork, a( i, i+ib ),
264 $ lda, work( ib+1 ), ldwork )
265 END IF
266*
267* Apply H to rows i:m of current block
268*
269 CALL zung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,
270 $ iinfo )
271*
272* Set rows 1:i-1 of current block to zero
273*
274 DO 40 j = i, i + ib - 1
275 DO 30 l = 1, i - 1
276 a( l, j ) = zero
277 30 CONTINUE
278 40 CONTINUE
279 50 CONTINUE
280 END IF
281*
282 work( 1 ) = iws
283 RETURN
284*
285* End of ZUNGQR
286*

◆ zungr2()

subroutine zungr2 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer info )

ZUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cgerqf (unblocked algorithm).

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

Purpose:
!>
!> ZUNGR2 generates an m by n complex matrix Q with orthonormal rows,
!> which is defined as the last m rows of a product of k elementary
!> reflectors of order n
!>
!>       Q  =  H(1)**H H(2)**H . . . H(k)**H
!>
!> as returned by ZGERQF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q. N >= M.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. M >= K >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the (m-k+i)-th row must contain the vector which
!>          defines the elementary reflector H(i), for i = 1,2,...,k, as
!>          returned by ZGERQF in the last k rows of its array argument
!>          A.
!>          On exit, the m-by-n matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The first dimension of the array A. LDA >= max(1,M).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGERQF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (M)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument has an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 113 of file zungr2.f.

114*
115* -- LAPACK computational 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 INFO, K, LDA, M, N
121* ..
122* .. Array Arguments ..
123 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 COMPLEX*16 ONE, ZERO
130 parameter( one = ( 1.0d+0, 0.0d+0 ),
131 $ zero = ( 0.0d+0, 0.0d+0 ) )
132* ..
133* .. Local Scalars ..
134 INTEGER I, II, J, L
135* ..
136* .. External Subroutines ..
137 EXTERNAL xerbla, zlacgv, zlarf, zscal
138* ..
139* .. Intrinsic Functions ..
140 INTRINSIC dconjg, max
141* ..
142* .. Executable Statements ..
143*
144* Test the input arguments
145*
146 info = 0
147 IF( m.LT.0 ) THEN
148 info = -1
149 ELSE IF( n.LT.m ) THEN
150 info = -2
151 ELSE IF( k.LT.0 .OR. k.GT.m ) THEN
152 info = -3
153 ELSE IF( lda.LT.max( 1, m ) ) THEN
154 info = -5
155 END IF
156 IF( info.NE.0 ) THEN
157 CALL xerbla( 'ZUNGR2', -info )
158 RETURN
159 END IF
160*
161* Quick return if possible
162*
163 IF( m.LE.0 )
164 $ RETURN
165*
166 IF( k.LT.m ) THEN
167*
168* Initialise rows 1:m-k to rows of the unit matrix
169*
170 DO 20 j = 1, n
171 DO 10 l = 1, m - k
172 a( l, j ) = zero
173 10 CONTINUE
174 IF( j.GT.n-m .AND. j.LE.n-k )
175 $ a( m-n+j, j ) = one
176 20 CONTINUE
177 END IF
178*
179 DO 40 i = 1, k
180 ii = m - k + i
181*
182* Apply H(i)**H to A(1:m-k+i,1:n-k+i) from the right
183*
184 CALL zlacgv( n-m+ii-1, a( ii, 1 ), lda )
185 a( ii, n-m+ii ) = one
186 CALL zlarf( 'Right', ii-1, n-m+ii, a( ii, 1 ), lda,
187 $ dconjg( tau( i ) ), a, lda, work )
188 CALL zscal( n-m+ii-1, -tau( i ), a( ii, 1 ), lda )
189 CALL zlacgv( n-m+ii-1, a( ii, 1 ), lda )
190 a( ii, n-m+ii ) = one - dconjg( tau( i ) )
191*
192* Set A(m-k+i,n-k+i+1:n) to zero
193*
194 DO 30 l = n - m + ii + 1, n
195 a( ii, l ) = zero
196 30 CONTINUE
197 40 CONTINUE
198 RETURN
199*
200* End of ZUNGR2
201*

◆ zungrq()

subroutine zungrq ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNGRQ

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

Purpose:
!>
!> ZUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,
!> which is defined as the last M rows of a product of K elementary
!> reflectors of order N
!>
!>       Q  =  H(1)**H H(2)**H . . . H(k)**H
!>
!> as returned by ZGERQF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q. N >= M.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. M >= K >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the (m-k+i)-th row must contain the vector which
!>          defines the elementary reflector H(i), for i = 1,2,...,k, as
!>          returned by ZGERQF in the last k rows of its array argument
!>          A.
!>          On exit, the M-by-N matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The first dimension of the array A. LDA >= max(1,M).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGERQF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,M).
!>          For optimum performance LWORK >= M*NB, where NB is the
!>          optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument has an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 127 of file zungrq.f.

128*
129* -- LAPACK computational 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 INTEGER INFO, K, LDA, LWORK, M, N
135* ..
136* .. Array Arguments ..
137 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 COMPLEX*16 ZERO
144 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
145* ..
146* .. Local Scalars ..
147 LOGICAL LQUERY
148 INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
149 $ LWKOPT, NB, NBMIN, NX
150* ..
151* .. External Subroutines ..
152 EXTERNAL xerbla, zlarfb, zlarft, zungr2
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC max, min
156* ..
157* .. External Functions ..
158 INTEGER ILAENV
159 EXTERNAL ilaenv
160* ..
161* .. Executable Statements ..
162*
163* Test the input arguments
164*
165 info = 0
166 lquery = ( lwork.EQ.-1 )
167 IF( m.LT.0 ) THEN
168 info = -1
169 ELSE IF( n.LT.m ) THEN
170 info = -2
171 ELSE IF( k.LT.0 .OR. k.GT.m ) THEN
172 info = -3
173 ELSE IF( lda.LT.max( 1, m ) ) THEN
174 info = -5
175 END IF
176*
177 IF( info.EQ.0 ) THEN
178 IF( m.LE.0 ) THEN
179 lwkopt = 1
180 ELSE
181 nb = ilaenv( 1, 'ZUNGRQ', ' ', m, n, k, -1 )
182 lwkopt = m*nb
183 END IF
184 work( 1 ) = lwkopt
185*
186 IF( lwork.LT.max( 1, m ) .AND. .NOT.lquery ) THEN
187 info = -8
188 END IF
189 END IF
190*
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'ZUNGRQ', -info )
193 RETURN
194 ELSE IF( lquery ) THEN
195 RETURN
196 END IF
197*
198* Quick return if possible
199*
200 IF( m.LE.0 ) THEN
201 RETURN
202 END IF
203*
204 nbmin = 2
205 nx = 0
206 iws = m
207 IF( nb.GT.1 .AND. nb.LT.k ) THEN
208*
209* Determine when to cross over from blocked to unblocked code.
210*
211 nx = max( 0, ilaenv( 3, 'ZUNGRQ', ' ', m, n, k, -1 ) )
212 IF( nx.LT.k ) THEN
213*
214* Determine if workspace is large enough for blocked code.
215*
216 ldwork = m
217 iws = ldwork*nb
218 IF( lwork.LT.iws ) THEN
219*
220* Not enough workspace to use optimal NB: reduce NB and
221* determine the minimum value of NB.
222*
223 nb = lwork / ldwork
224 nbmin = max( 2, ilaenv( 2, 'ZUNGRQ', ' ', m, n, k, -1 ) )
225 END IF
226 END IF
227 END IF
228*
229 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
230*
231* Use blocked code after the first block.
232* The last kk rows are handled by the block method.
233*
234 kk = min( k, ( ( k-nx+nb-1 ) / nb )*nb )
235*
236* Set A(1:m-kk,n-kk+1:n) to zero.
237*
238 DO 20 j = n - kk + 1, n
239 DO 10 i = 1, m - kk
240 a( i, j ) = zero
241 10 CONTINUE
242 20 CONTINUE
243 ELSE
244 kk = 0
245 END IF
246*
247* Use unblocked code for the first or only block.
248*
249 CALL zungr2( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo )
250*
251 IF( kk.GT.0 ) THEN
252*
253* Use blocked code
254*
255 DO 50 i = k - kk + 1, k, nb
256 ib = min( nb, k-i+1 )
257 ii = m - k + i
258 IF( ii.GT.1 ) THEN
259*
260* Form the triangular factor of the block reflector
261* H = H(i+ib-1) . . . H(i+1) H(i)
262*
263 CALL zlarft( 'Backward', 'Rowwise', n-k+i+ib-1, ib,
264 $ a( ii, 1 ), lda, tau( i ), work, ldwork )
265*
266* Apply H**H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
267*
268 CALL zlarfb( 'Right', 'Conjugate transpose', 'Backward',
269 $ 'Rowwise', ii-1, n-k+i+ib-1, ib, a( ii, 1 ),
270 $ lda, work, ldwork, a, lda, work( ib+1 ),
271 $ ldwork )
272 END IF
273*
274* Apply H**H to columns 1:n-k+i+ib-1 of current block
275*
276 CALL zungr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),
277 $ work, iinfo )
278*
279* Set columns n-k+i+ib:n of current block to zero
280*
281 DO 40 l = n - k + i + ib, n
282 DO 30 j = ii, ii + ib - 1
283 a( j, l ) = zero
284 30 CONTINUE
285 40 CONTINUE
286 50 CONTINUE
287 END IF
288*
289 work( 1 ) = iws
290 RETURN
291*
292* End of ZUNGRQ
293*
zungr2
subroutine zungr2(m, n, k, a, lda, tau, work, info)
ZUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cgerqf (u...
Definition zungr2.f:114

◆ zungtr()

subroutine zungtr ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNGTR

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

Purpose:
!>
!> ZUNGTR generates a complex unitary matrix Q which is defined as the
!> product of n-1 elementary reflectors of order N, as returned by
!> ZHETRD:
!>
!> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
!>
!> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U': Upper triangle of A contains elementary reflectors
!>                 from ZHETRD;
!>          = 'L': Lower triangle of A contains elementary reflectors
!>                 from ZHETRD.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix Q. N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the vectors which define the elementary reflectors,
!>          as returned by ZHETRD.
!>          On exit, the N-by-N unitary matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= N.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZHETRD.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= N-1.
!>          For optimum performance LWORK >= (N-1)*NB, where NB is
!>          the optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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 122 of file zungtr.f.

123*
124* -- LAPACK computational routine --
125* -- LAPACK is a software package provided by Univ. of Tennessee, --
126* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
127*
128* .. Scalar Arguments ..
129 CHARACTER UPLO
130 INTEGER INFO, LDA, LWORK, N
131* ..
132* .. Array Arguments ..
133 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
134* ..
135*
136* =====================================================================
137*
138* .. Parameters ..
139 COMPLEX*16 ZERO, ONE
140 parameter( zero = ( 0.0d+0, 0.0d+0 ),
141 $ one = ( 1.0d+0, 0.0d+0 ) )
142* ..
143* .. Local Scalars ..
144 LOGICAL LQUERY, UPPER
145 INTEGER I, IINFO, J, LWKOPT, NB
146* ..
147* .. External Functions ..
148 LOGICAL LSAME
149 INTEGER ILAENV
150 EXTERNAL lsame, ilaenv
151* ..
152* .. External Subroutines ..
153 EXTERNAL xerbla, zungql, zungqr
154* ..
155* .. Intrinsic Functions ..
156 INTRINSIC max
157* ..
158* .. Executable Statements ..
159*
160* Test the input arguments
161*
162 info = 0
163 lquery = ( lwork.EQ.-1 )
164 upper = lsame( uplo, 'U' )
165 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
166 info = -1
167 ELSE IF( n.LT.0 ) THEN
168 info = -2
169 ELSE IF( lda.LT.max( 1, n ) ) THEN
170 info = -4
171 ELSE IF( lwork.LT.max( 1, n-1 ) .AND. .NOT.lquery ) THEN
172 info = -7
173 END IF
174*
175 IF( info.EQ.0 ) THEN
176 IF( upper ) THEN
177 nb = ilaenv( 1, 'ZUNGQL', ' ', n-1, n-1, n-1, -1 )
178 ELSE
179 nb = ilaenv( 1, 'ZUNGQR', ' ', n-1, n-1, n-1, -1 )
180 END IF
181 lwkopt = max( 1, n-1 )*nb
182 work( 1 ) = lwkopt
183 END IF
184*
185 IF( info.NE.0 ) THEN
186 CALL xerbla( 'ZUNGTR', -info )
187 RETURN
188 ELSE IF( lquery ) THEN
189 RETURN
190 END IF
191*
192* Quick return if possible
193*
194 IF( n.EQ.0 ) THEN
195 work( 1 ) = 1
196 RETURN
197 END IF
198*
199 IF( upper ) THEN
200*
201* Q was determined by a call to ZHETRD with UPLO = 'U'
202*
203* Shift the vectors which define the elementary reflectors one
204* column to the left, and set the last row and column of Q to
205* those of the unit matrix
206*
207 DO 20 j = 1, n - 1
208 DO 10 i = 1, j - 1
209 a( i, j ) = a( i, j+1 )
210 10 CONTINUE
211 a( n, j ) = zero
212 20 CONTINUE
213 DO 30 i = 1, n - 1
214 a( i, n ) = zero
215 30 CONTINUE
216 a( n, n ) = one
217*
218* Generate Q(1:n-1,1:n-1)
219*
220 CALL zungql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
221*
222 ELSE
223*
224* Q was determined by a call to ZHETRD with UPLO = 'L'.
225*
226* Shift the vectors which define the elementary reflectors one
227* column to the right, and set the first row and column of Q to
228* those of the unit matrix
229*
230 DO 50 j = n, 2, -1
231 a( 1, j ) = zero
232 DO 40 i = j + 1, n
233 a( i, j ) = a( i, j-1 )
234 40 CONTINUE
235 50 CONTINUE
236 a( 1, 1 ) = one
237 DO 60 i = 2, n
238 a( i, 1 ) = zero
239 60 CONTINUE
240 IF( n.GT.1 ) THEN
241*
242* Generate Q(2:n,2:n)
243*
244 CALL zungqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,
245 $ lwork, iinfo )
246 END IF
247 END IF
248 work( 1 ) = lwkopt
249 RETURN
250*
251* End of ZUNGTR
252*
zungql
subroutine zungql(m, n, k, a, lda, tau, work, lwork, info)
ZUNGQL
Definition zungql.f:128

◆ zungtsqr()

subroutine zungtsqr ( integer m,
integer n,
integer mb,
integer nb,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNGTSQR

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

Purpose:
!>
!> ZUNGTSQR generates an M-by-N complex matrix Q_out with orthonormal
!> columns, which are the first N columns of a product of comlpex unitary
!> matrices of order M which are returned by ZLATSQR
!>
!>      Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ).
!>
!> See the documentation for ZLATSQR.
!>
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. M >= N >= 0.
!>
[in]MB
!>          MB is INTEGER
!>          The row block size used by ZLATSQR to return
!>          arrays A and T. MB > N.
!>          (Note that if MB > M, then M is used instead of MB
!>          as the row block size).
!>
[in]NB
!>          NB is INTEGER
!>          The column block size used by ZLATSQR to return
!>          arrays A and T. NB >= 1.
!>          (Note that if NB > N, then N is used instead of NB
!>          as the column block size).
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>
!>          On entry:
!>
!>             The elements on and above the diagonal are not accessed.
!>             The elements below the diagonal represent the unit
!>             lower-trapezoidal blocked matrix V computed by ZLATSQR
!>             that defines the input matrices Q_in(k) (ones on the
!>             diagonal are not stored) (same format as the output A
!>             below the diagonal in ZLATSQR).
!>
!>          On exit:
!>
!>             The array A contains an M-by-N orthonormal matrix Q_out,
!>             i.e the columns of A are orthogonal unit vectors.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in]T
!>          T is COMPLEX*16 array,
!>          dimension (LDT, N * NIRB)
!>          where NIRB = Number_of_input_row_blocks
!>                     = MAX( 1, CEIL((M-N)/(MB-N)) )
!>          Let NICB = Number_of_input_col_blocks
!>                   = CEIL(N/NB)
!>
!>          The upper-triangular block reflectors used to define the
!>          input matrices Q_in(k), k=(1:NIRB*NICB). The block
!>          reflectors are stored in compact form in NIRB block
!>          reflector sequences. Each of NIRB block reflector sequences
!>          is stored in a larger NB-by-N column block of T and consists
!>          of NICB smaller NB-by-NB upper-triangular column blocks.
!>          (same format as the output T in ZLATSQR).
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.
!>          LDT >= max(1,min(NB1,N)).
!>
[out]WORK
!>          (workspace) COMPLEX*16 array, dimension (MAX(2,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          The dimension of the array WORK.  LWORK >= (M+NB)*N.
!>          If LWORK = -1, then a workspace query is assumed.
!>          The routine only calculates the optimal size of the WORK
!>          array, returns this value as the first entry of the WORK
!>          array, and no error message related to LWORK is issued
!>          by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!> November 2019, Igor Kozachenko,
!>                Computer Science Division,
!>                University of California, Berkeley
!>
!>

Definition at line 173 of file zungtsqr.f.

175 IMPLICIT NONE
176*
177* -- LAPACK computational routine --
178* -- LAPACK is a software package provided by Univ. of Tennessee, --
179* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
180*
181* .. Scalar Arguments ..
182 INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB
183* ..
184* .. Array Arguments ..
185 COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * )
186* ..
187*
188* =====================================================================
189*
190* .. Parameters ..
191 COMPLEX*16 CONE, CZERO
192 parameter( cone = ( 1.0d+0, 0.0d+0 ),
193 $ czero = ( 0.0d+0, 0.0d+0 ) )
194* ..
195* .. Local Scalars ..
196 LOGICAL LQUERY
197 INTEGER IINFO, LDC, LWORKOPT, LC, LW, NBLOCAL, J
198* ..
199* .. External Subroutines ..
200 EXTERNAL zcopy, zlamtsqr, zlaset, xerbla
201* ..
202* .. Intrinsic Functions ..
203 INTRINSIC dcmplx, max, min
204* ..
205* .. Executable Statements ..
206*
207* Test the input parameters
208*
209 lquery = lwork.EQ.-1
210 info = 0
211 IF( m.LT.0 ) THEN
212 info = -1
213 ELSE IF( n.LT.0 .OR. m.LT.n ) THEN
214 info = -2
215 ELSE IF( mb.LE.n ) THEN
216 info = -3
217 ELSE IF( nb.LT.1 ) THEN
218 info = -4
219 ELSE IF( lda.LT.max( 1, m ) ) THEN
220 info = -6
221 ELSE IF( ldt.LT.max( 1, min( nb, n ) ) ) THEN
222 info = -8
223 ELSE
224*
225* Test the input LWORK for the dimension of the array WORK.
226* This workspace is used to store array C(LDC, N) and WORK(LWORK)
227* in the call to ZLAMTSQR. See the documentation for ZLAMTSQR.
228*
229 IF( lwork.LT.2 .AND. (.NOT.lquery) ) THEN
230 info = -10
231 ELSE
232*
233* Set block size for column blocks
234*
235 nblocal = min( nb, n )
236*
237* LWORK = -1, then set the size for the array C(LDC,N)
238* in ZLAMTSQR call and set the optimal size of the work array
239* WORK(LWORK) in ZLAMTSQR call.
240*
241 ldc = m
242 lc = ldc*n
243 lw = n * nblocal
244*
245 lworkopt = lc+lw
246*
247 IF( ( lwork.LT.max( 1, lworkopt ) ).AND.(.NOT.lquery) ) THEN
248 info = -10
249 END IF
250 END IF
251*
252 END IF
253*
254* Handle error in the input parameters and return workspace query.
255*
256 IF( info.NE.0 ) THEN
257 CALL xerbla( 'ZUNGTSQR', -info )
258 RETURN
259 ELSE IF ( lquery ) THEN
260 work( 1 ) = dcmplx( lworkopt )
261 RETURN
262 END IF
263*
264* Quick return if possible
265*
266 IF( min( m, n ).EQ.0 ) THEN
267 work( 1 ) = dcmplx( lworkopt )
268 RETURN
269 END IF
270*
271* (1) Form explicitly the tall-skinny M-by-N left submatrix Q1_in
272* of M-by-M orthogonal matrix Q_in, which is implicitly stored in
273* the subdiagonal part of input array A and in the input array T.
274* Perform by the following operation using the routine ZLAMTSQR.
275*
276* Q1_in = Q_in * ( I ), where I is a N-by-N identity matrix,
277* ( 0 ) 0 is a (M-N)-by-N zero matrix.
278*
279* (1a) Form M-by-N matrix in the array WORK(1:LDC*N) with ones
280* on the diagonal and zeros elsewhere.
281*
282 CALL zlaset( 'F', m, n, czero, cone, work, ldc )
283*
284* (1b) On input, WORK(1:LDC*N) stores ( I );
285* ( 0 )
286*
287* On output, WORK(1:LDC*N) stores Q1_in.
288*
289 CALL zlamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,
290 $ work, ldc, work( lc+1 ), lw, iinfo )
291*
292* (2) Copy the result from the part of the work array (1:M,1:N)
293* with the leading dimension LDC that starts at WORK(1) into
294* the output array A(1:M,1:N) column-by-column.
295*
296 DO j = 1, n
297 CALL zcopy( m, work( (j-1)*ldc + 1 ), 1, a( 1, j ), 1 )
298 END DO
299*
300 work( 1 ) = dcmplx( lworkopt )
301 RETURN
302*
303* End of ZUNGTSQR
304*
zlamtsqr
subroutine zlamtsqr(side, trans, m, n, k, mb, nb, a, lda, t, ldt, c, ldc, work, lwork, info)
ZLAMTSQR
Definition zlamtsqr.f:197

◆ zungtsqr_row()

subroutine zungtsqr_row ( integer m,
integer n,
integer mb,
integer nb,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNGTSQR_ROW

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

Purpose:
!>
!> ZUNGTSQR_ROW generates an M-by-N complex matrix Q_out with
!> orthonormal columns from the output of ZLATSQR. These N orthonormal
!> columns are the first N columns of a product of complex unitary
!> matrices Q(k)_in of order M, which are returned by ZLATSQR in
!> a special format.
!>
!>      Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ).
!>
!> The input matrices Q(k)_in are stored in row and column blocks in A.
!> See the documentation of ZLATSQR for more details on the format of
!> Q(k)_in, where each Q(k)_in is represented by block Householder
!> transformations. This routine calls an auxiliary routine ZLARFB_GETT,
!> where the computation is performed on each individual block. The
!> algorithm first sweeps NB-sized column blocks from the right to left
!> starting in the bottom row block and continues to the top row block
!> (hence _ROW in the routine name). This sweep is in reverse order of
!> the order in which ZLATSQR generates the output blocks.
!>
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. M >= N >= 0.
!>
[in]MB
!>          MB is INTEGER
!>          The row block size used by ZLATSQR to return
!>          arrays A and T. MB > N.
!>          (Note that if MB > M, then M is used instead of MB
!>          as the row block size).
!>
[in]NB
!>          NB is INTEGER
!>          The column block size used by ZLATSQR to return
!>          arrays A and T. NB >= 1.
!>          (Note that if NB > N, then N is used instead of NB
!>          as the column block size).
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>
!>          On entry:
!>
!>             The elements on and above the diagonal are not used as
!>             input. The elements below the diagonal represent the unit
!>             lower-trapezoidal blocked matrix V computed by ZLATSQR
!>             that defines the input matrices Q_in(k) (ones on the
!>             diagonal are not stored). See ZLATSQR for more details.
!>
!>          On exit:
!>
!>             The array A contains an M-by-N orthonormal matrix Q_out,
!>             i.e the columns of A are orthogonal unit vectors.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in]T
!>          T is COMPLEX*16 array,
!>          dimension (LDT, N * NIRB)
!>          where NIRB = Number_of_input_row_blocks
!>                     = MAX( 1, CEIL((M-N)/(MB-N)) )
!>          Let NICB = Number_of_input_col_blocks
!>                   = CEIL(N/NB)
!>
!>          The upper-triangular block reflectors used to define the
!>          input matrices Q_in(k), k=(1:NIRB*NICB). The block
!>          reflectors are stored in compact form in NIRB block
!>          reflector sequences. Each of the NIRB block reflector
!>          sequences is stored in a larger NB-by-N column block of T
!>          and consists of NICB smaller NB-by-NB upper-triangular
!>          column blocks. See ZLATSQR for more details on the format
!>          of T.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.
!>          LDT >= max(1,min(NB,N)).
!>
[out]WORK
!>          (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          The dimension of the array WORK.
!>          LWORK >= NBLOCAL * MAX(NBLOCAL,(N-NBLOCAL)),
!>          where NBLOCAL=MIN(NB,N).
!>          If LWORK = -1, then a workspace query is assumed.
!>          The routine only calculates the optimal size of the WORK
!>          array, returns this value as the first entry of the WORK
!>          array, and no error message related to LWORK is issued
!>          by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!> November 2020, Igor Kozachenko,
!>                Computer Science Division,
!>                University of California, Berkeley
!>
!>

Definition at line 186 of file zungtsqr_row.f.

188 IMPLICIT NONE
189*
190* -- LAPACK computational routine --
191* -- LAPACK is a software package provided by Univ. of Tennessee, --
192* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
193*
194* .. Scalar Arguments ..
195 INTEGER INFO, LDA, LDT, LWORK, M, N, MB, NB
196* ..
197* .. Array Arguments ..
198 COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * )
199* ..
200*
201* =====================================================================
202*
203* .. Parameters ..
204 COMPLEX*16 CONE, CZERO
205 parameter( cone = ( 1.0d+0, 0.0d+0 ),
206 $ czero = ( 0.0d+0, 0.0d+0 ) )
207* ..
208* .. Local Scalars ..
209 LOGICAL LQUERY
210 INTEGER NBLOCAL, MB2, M_PLUS_ONE, ITMP, IB_BOTTOM,
211 $ LWORKOPT, NUM_ALL_ROW_BLOCKS, JB_T, IB, IMB,
212 $ KB, KB_LAST, KNB, MB1
213* ..
214* .. Local Arrays ..
215 COMPLEX*16 DUMMY( 1, 1 )
216* ..
217* .. External Subroutines ..
218 EXTERNAL zlarfb_gett, zlaset, xerbla
219* ..
220* .. Intrinsic Functions ..
221 INTRINSIC dcmplx, max, min
222* ..
223* .. Executable Statements ..
224*
225* Test the input parameters
226*
227 info = 0
228 lquery = lwork.EQ.-1
229 IF( m.LT.0 ) THEN
230 info = -1
231 ELSE IF( n.LT.0 .OR. m.LT.n ) THEN
232 info = -2
233 ELSE IF( mb.LE.n ) THEN
234 info = -3
235 ELSE IF( nb.LT.1 ) THEN
236 info = -4
237 ELSE IF( lda.LT.max( 1, m ) ) THEN
238 info = -6
239 ELSE IF( ldt.LT.max( 1, min( nb, n ) ) ) THEN
240 info = -8
241 ELSE IF( lwork.LT.1 .AND. .NOT.lquery ) THEN
242 info = -10
243 END IF
244*
245 nblocal = min( nb, n )
246*
247* Determine the workspace size.
248*
249 IF( info.EQ.0 ) THEN
250 lworkopt = nblocal * max( nblocal, ( n - nblocal ) )
251 END IF
252*
253* Handle error in the input parameters and handle the workspace query.
254*
255 IF( info.NE.0 ) THEN
256 CALL xerbla( 'ZUNGTSQR_ROW', -info )
257 RETURN
258 ELSE IF ( lquery ) THEN
259 work( 1 ) = dcmplx( lworkopt )
260 RETURN
261 END IF
262*
263* Quick return if possible
264*
265 IF( min( m, n ).EQ.0 ) THEN
266 work( 1 ) = dcmplx( lworkopt )
267 RETURN
268 END IF
269*
270* (0) Set the upper-triangular part of the matrix A to zero and
271* its diagonal elements to one.
272*
273 CALL zlaset('U', m, n, czero, cone, a, lda )
274*
275* KB_LAST is the column index of the last column block reflector
276* in the matrices T and V.
277*
278 kb_last = ( ( n-1 ) / nblocal ) * nblocal + 1
279*
280*
281* (1) Bottom-up loop over row blocks of A, except the top row block.
282* NOTE: If MB>=M, then the loop is never executed.
283*
284 IF ( mb.LT.m ) THEN
285*
286* MB2 is the row blocking size for the row blocks before the
287* first top row block in the matrix A. IB is the row index for
288* the row blocks in the matrix A before the first top row block.
289* IB_BOTTOM is the row index for the last bottom row block
290* in the matrix A. JB_T is the column index of the corresponding
291* column block in the matrix T.
292*
293* Initialize variables.
294*
295* NUM_ALL_ROW_BLOCKS is the number of row blocks in the matrix A
296* including the first row block.
297*
298 mb2 = mb - n
299 m_plus_one = m + 1
300 itmp = ( m - mb - 1 ) / mb2
301 ib_bottom = itmp * mb2 + mb + 1
302 num_all_row_blocks = itmp + 2
303 jb_t = num_all_row_blocks * n + 1
304*
305 DO ib = ib_bottom, mb+1, -mb2
306*
307* Determine the block size IMB for the current row block
308* in the matrix A.
309*
310 imb = min( m_plus_one - ib, mb2 )
311*
312* Determine the column index JB_T for the current column block
313* in the matrix T.
314*
315 jb_t = jb_t - n
316*
317* Apply column blocks of H in the row block from right to left.
318*
319* KB is the column index of the current column block reflector
320* in the matrices T and V.
321*
322 DO kb = kb_last, 1, -nblocal
323*
324* Determine the size of the current column block KNB in
325* the matrices T and V.
326*
327 knb = min( nblocal, n - kb + 1 )
328*
329 CALL zlarfb_gett( 'I', imb, n-kb+1, knb,
330 $ t( 1, jb_t+kb-1 ), ldt, a( kb, kb ), lda,
331 $ a( ib, kb ), lda, work, knb )
332*
333 END DO
334*
335 END DO
336*
337 END IF
338*
339* (2) Top row block of A.
340* NOTE: If MB>=M, then we have only one row block of A of size M
341* and we work on the entire matrix A.
342*
343 mb1 = min( mb, m )
344*
345* Apply column blocks of H in the top row block from right to left.
346*
347* KB is the column index of the current block reflector in
348* the matrices T and V.
349*
350 DO kb = kb_last, 1, -nblocal
351*
352* Determine the size of the current column block KNB in
353* the matrices T and V.
354*
355 knb = min( nblocal, n - kb + 1 )
356*
357 IF( mb1-kb-knb+1.EQ.0 ) THEN
358*
359* In SLARFB_GETT parameters, when M=0, then the matrix B
360* does not exist, hence we need to pass a dummy array
361* reference DUMMY(1,1) to B with LDDUMMY=1.
362*
363 CALL zlarfb_gett( 'N', 0, n-kb+1, knb,
364 $ t( 1, kb ), ldt, a( kb, kb ), lda,
365 $ dummy( 1, 1 ), 1, work, knb )
366 ELSE
367 CALL zlarfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,
368 $ t( 1, kb ), ldt, a( kb, kb ), lda,
369 $ a( kb+knb, kb), lda, work, knb )
370
371 END IF
372*
373 END DO
374*
375 work( 1 ) = dcmplx( lworkopt )
376 RETURN
377*
378* End of ZUNGTSQR_ROW
379*
zlarfb_gett
subroutine zlarfb_gett(ident, m, n, k, t, ldt, a, lda, b, ldb, work, ldwork)
ZLARFB_GETT
Definition zlarfb_gett.f:392

◆ zunhr_col()

subroutine zunhr_col ( integer m,
integer n,
integer nb,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( * ) d,
integer info )

ZUNHR_COL

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

Purpose:
!>
!>  ZUNHR_COL takes an M-by-N complex matrix Q_in with orthonormal columns
!>  as input, stored in A, and performs Householder Reconstruction (HR),
!>  i.e. reconstructs Householder vectors V(i) implicitly representing
!>  another M-by-N matrix Q_out, with the property that Q_in = Q_out*S,
!>  where S is an N-by-N diagonal matrix with diagonal entries
!>  equal to +1 or -1. The Householder vectors (columns V(i) of V) are
!>  stored in A on output, and the diagonal entries of S are stored in D.
!>  Block reflectors are also returned in T
!>  (same output format as ZGEQRT).
!>
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. M >= N >= 0.
!>
[in]NB
!>          NB is INTEGER
!>          The column block size to be used in the reconstruction
!>          of Householder column vector blocks in the array A and
!>          corresponding block reflectors in the array T. NB >= 1.
!>          (Note that if NB > N, then N is used instead of NB
!>          as the column block size.)
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>
!>          On entry:
!>
!>             The array A contains an M-by-N orthonormal matrix Q_in,
!>             i.e the columns of A are orthogonal unit vectors.
!>
!>          On exit:
!>
!>             The elements below the diagonal of A represent the unit
!>             lower-trapezoidal matrix V of Householder column vectors
!>             V(i). The unit diagonal entries of V are not stored
!>             (same format as the output below the diagonal in A from
!>             ZGEQRT). The matrix T and the matrix V stored on output
!>             in A implicitly define Q_out.
!>
!>             The elements above the diagonal contain the factor U
!>             of the  LU-decomposition:
!>                Q_in - ( S ) = V * U
!>                       ( 0 )
!>             where 0 is a (M-N)-by-(M-N) zero matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is COMPLEX*16 array,
!>          dimension (LDT, N)
!>
!>          Let NOCB = Number_of_output_col_blocks
!>                   = CEIL(N/NB)
!>
!>          On exit, T(1:NB, 1:N) contains NOCB upper-triangular
!>          block reflectors used to define Q_out stored in compact
!>          form as a sequence of upper-triangular NB-by-NB column
!>          blocks (same format as the output T in ZGEQRT).
!>          The matrix T and the matrix V stored on output in A
!>          implicitly define Q_out. NOTE: The lower triangles
!>          below the upper-triangular blocks will be filled with
!>          zeros. See Further Details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.
!>          LDT >= max(1,min(NB,N)).
!>
[out]D
!>          D is COMPLEX*16 array, dimension min(M,N).
!>          The elements can be only plus or minus one.
!>
!>          D(i) is constructed as D(i) = -SIGN(Q_in_i(i,i)), where
!>          1 <= i <= min(M,N), and Q_in_i is Q_in after performing
!>          i-1 steps of “modified” Gaussian elimination.
!>          See Further Details.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Further Details:
!>
!> The computed M-by-M unitary factor Q_out is defined implicitly as
!> a product of unitary matrices Q_out(i). Each Q_out(i) is stored in
!> the compact WY-representation format in the corresponding blocks of
!> matrices V (stored in A) and T.
!>
!> The M-by-N unit lower-trapezoidal matrix V stored in the M-by-N
!> matrix A contains the column vectors V(i) in NB-size column
!> blocks VB(j). For example, VB(1) contains the columns
!> V(1), V(2), ... V(NB). NOTE: The unit entries on
!> the diagonal of Y are not stored in A.
!>
!> The number of column blocks is
!>
!>     NOCB = Number_of_output_col_blocks = CEIL(N/NB)
!>
!> where each block is of order NB except for the last block, which
!> is of order LAST_NB = N - (NOCB-1)*NB.
!>
!> For example, if M=6,  N=5 and NB=2, the matrix V is
!>
!>
!>     V = (    VB(1),   VB(2), VB(3) ) =
!>
!>       = (   1                      )
!>         ( v21    1                 )
!>         ( v31  v32    1            )
!>         ( v41  v42  v43   1        )
!>         ( v51  v52  v53  v54    1  )
!>         ( v61  v62  v63  v54   v65 )
!>
!>
!> For each of the column blocks VB(i), an upper-triangular block
!> reflector TB(i) is computed. These blocks are stored as
!> a sequence of upper-triangular column blocks in the NB-by-N
!> matrix T. The size of each TB(i) block is NB-by-NB, except
!> for the last block, whose size is LAST_NB-by-LAST_NB.
!>
!> For example, if M=6,  N=5 and NB=2, the matrix T is
!>
!>     T  = (    TB(1),    TB(2), TB(3) ) =
!>
!>        = ( t11  t12  t13  t14   t15  )
!>          (      t22       t24        )
!>
!>
!> The M-by-M factor Q_out is given as a product of NOCB
!> unitary M-by-M matrices Q_out(i).
!>
!>     Q_out = Q_out(1) * Q_out(2) * ... * Q_out(NOCB),
!>
!> where each matrix Q_out(i) is given by the WY-representation
!> using corresponding blocks from the matrices V and T:
!>
!>     Q_out(i) = I - VB(i) * TB(i) * (VB(i))**T,
!>
!> where I is the identity matrix. Here is the formula with matrix
!> dimensions:
!>
!>  Q(i){M-by-M} = I{M-by-M} -
!>    VB(i){M-by-INB} * TB(i){INB-by-INB} * (VB(i))**T {INB-by-M},
!>
!> where INB = NB, except for the last block NOCB
!> for which INB=LAST_NB.
!>
!> =====
!> NOTE:
!> =====
!>
!> If Q_in is the result of doing a QR factorization
!> B = Q_in * R_in, then:
!>
!> B = (Q_out*S) * R_in = Q_out * (S * R_in) = Q_out * R_out.
!>
!> So if one wants to interpret Q_out as the result
!> of the QR factorization of B, then the corresponding R_out
!> should be equal to R_out = S * R_in, i.e. some rows of R_in
!> should be multiplied by -1.
!>
!> For the details of the algorithm, see [1].
!>
!> [1] ,
!>     G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen,
!>     E. Solomonik, J. Parallel Distrib. Comput.,
!>     vol. 85, pp. 3-31, 2015.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!> November   2019, Igor Kozachenko,
!>            Computer Science Division,
!>            University of California, Berkeley
!>
!>

Definition at line 258 of file zunhr_col.f.

259 IMPLICIT NONE
260*
261* -- LAPACK computational routine --
262* -- LAPACK is a software package provided by Univ. of Tennessee, --
263* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
264*
265* .. Scalar Arguments ..
266 INTEGER INFO, LDA, LDT, M, N, NB
267* ..
268* .. Array Arguments ..
269 COMPLEX*16 A( LDA, * ), D( * ), T( LDT, * )
270* ..
271*
272* =====================================================================
273*
274* .. Parameters ..
275 COMPLEX*16 CONE, CZERO
276 parameter( cone = ( 1.0d+0, 0.0d+0 ),
277 $ czero = ( 0.0d+0, 0.0d+0 ) )
278* ..
279* .. Local Scalars ..
280 INTEGER I, IINFO, J, JB, JBTEMP1, JBTEMP2, JNB,
281 $ NPLUSONE
282* ..
283* .. External Subroutines ..
284 EXTERNAL zcopy, zlaunhr_col_getrfnp, zscal, ztrsm,
285 $ xerbla
286* ..
287* .. Intrinsic Functions ..
288 INTRINSIC max, min
289* ..
290* .. Executable Statements ..
291*
292* Test the input parameters
293*
294 info = 0
295 IF( m.LT.0 ) THEN
296 info = -1
297 ELSE IF( n.LT.0 .OR. n.GT.m ) THEN
298 info = -2
299 ELSE IF( nb.LT.1 ) THEN
300 info = -3
301 ELSE IF( lda.LT.max( 1, m ) ) THEN
302 info = -5
303 ELSE IF( ldt.LT.max( 1, min( nb, n ) ) ) THEN
304 info = -7
305 END IF
306*
307* Handle error in the input parameters.
308*
309 IF( info.NE.0 ) THEN
310 CALL xerbla( 'ZUNHR_COL', -info )
311 RETURN
312 END IF
313*
314* Quick return if possible
315*
316 IF( min( m, n ).EQ.0 ) THEN
317 RETURN
318 END IF
319*
320* On input, the M-by-N matrix A contains the unitary
321* M-by-N matrix Q_in.
322*
323* (1) Compute the unit lower-trapezoidal V (ones on the diagonal
324* are not stored) by performing the "modified" LU-decomposition.
325*
326* Q_in - ( S ) = V * U = ( V1 ) * U,
327* ( 0 ) ( V2 )
328*
329* where 0 is an (M-N)-by-N zero matrix.
330*
331* (1-1) Factor V1 and U.
332
333 CALL zlaunhr_col_getrfnp( n, n, a, lda, d, iinfo )
334*
335* (1-2) Solve for V2.
336*
337 IF( m.GT.n ) THEN
338 CALL ztrsm( 'R', 'U', 'N', 'N', m-n, n, cone, a, lda,
339 $ a( n+1, 1 ), lda )
340 END IF
341*
342* (2) Reconstruct the block reflector T stored in T(1:NB, 1:N)
343* as a sequence of upper-triangular blocks with NB-size column
344* blocking.
345*
346* Loop over the column blocks of size NB of the array A(1:M,1:N)
347* and the array T(1:NB,1:N), JB is the column index of a column
348* block, JNB is the column block size at each step JB.
349*
350 nplusone = n + 1
351 DO jb = 1, n, nb
352*
353* (2-0) Determine the column block size JNB.
354*
355 jnb = min( nplusone-jb, nb )
356*
357* (2-1) Copy the upper-triangular part of the current JNB-by-JNB
358* diagonal block U(JB) (of the N-by-N matrix U) stored
359* in A(JB:JB+JNB-1,JB:JB+JNB-1) into the upper-triangular part
360* of the current JNB-by-JNB block T(1:JNB,JB:JB+JNB-1)
361* column-by-column, total JNB*(JNB+1)/2 elements.
362*
363 jbtemp1 = jb - 1
364 DO j = jb, jb+jnb-1
365 CALL zcopy( j-jbtemp1, a( jb, j ), 1, t( 1, j ), 1 )
366 END DO
367*
368* (2-2) Perform on the upper-triangular part of the current
369* JNB-by-JNB diagonal block U(JB) (of the N-by-N matrix U) stored
370* in T(1:JNB,JB:JB+JNB-1) the following operation in place:
371* (-1)*U(JB)*S(JB), i.e the result will be stored in the upper-
372* triangular part of T(1:JNB,JB:JB+JNB-1). This multiplication
373* of the JNB-by-JNB diagonal block U(JB) by the JNB-by-JNB
374* diagonal block S(JB) of the N-by-N sign matrix S from the
375* right means changing the sign of each J-th column of the block
376* U(JB) according to the sign of the diagonal element of the block
377* S(JB), i.e. S(J,J) that is stored in the array element D(J).
378*
379 DO j = jb, jb+jnb-1
380 IF( d( j ).EQ.cone ) THEN
381 CALL zscal( j-jbtemp1, -cone, t( 1, j ), 1 )
382 END IF
383 END DO
384*
385* (2-3) Perform the triangular solve for the current block
386* matrix X(JB):
387*
388* X(JB) * (A(JB)**T) = B(JB), where:
389*
390* A(JB)**T is a JNB-by-JNB unit upper-triangular
391* coefficient block, and A(JB)=V1(JB), which
392* is a JNB-by-JNB unit lower-triangular block
393* stored in A(JB:JB+JNB-1,JB:JB+JNB-1).
394* The N-by-N matrix V1 is the upper part
395* of the M-by-N lower-trapezoidal matrix V
396* stored in A(1:M,1:N);
397*
398* B(JB) is a JNB-by-JNB upper-triangular right-hand
399* side block, B(JB) = (-1)*U(JB)*S(JB), and
400* B(JB) is stored in T(1:JNB,JB:JB+JNB-1);
401*
402* X(JB) is a JNB-by-JNB upper-triangular solution
403* block, X(JB) is the upper-triangular block
404* reflector T(JB), and X(JB) is stored
405* in T(1:JNB,JB:JB+JNB-1).
406*
407* In other words, we perform the triangular solve for the
408* upper-triangular block T(JB):
409*
410* T(JB) * (V1(JB)**T) = (-1)*U(JB)*S(JB).
411*
412* Even though the blocks X(JB) and B(JB) are upper-
413* triangular, the routine ZTRSM will access all JNB**2
414* elements of the square T(1:JNB,JB:JB+JNB-1). Therefore,
415* we need to set to zero the elements of the block
416* T(1:JNB,JB:JB+JNB-1) below the diagonal before the call
417* to ZTRSM.
418*
419* (2-3a) Set the elements to zero.
420*
421 jbtemp2 = jb - 2
422 DO j = jb, jb+jnb-2
423 DO i = j-jbtemp2, nb
424 t( i, j ) = czero
425 END DO
426 END DO
427*
428* (2-3b) Perform the triangular solve.
429*
430 CALL ztrsm( 'R', 'L', 'C', 'U', jnb, jnb, cone,
431 $ a( jb, jb ), lda, t( 1, jb ), ldt )
432*
433 END DO
434*
435 RETURN
436*
437* End of ZUNHR_COL
438*
zlaunhr_col_getrfnp
subroutine zlaunhr_col_getrfnp(m, n, a, lda, d, info)
ZLAUNHR_COL_GETRFNP
Definition zlaunhr_col_getrfnp.f:146

◆ zunm2l()

subroutine zunm2l ( character side,
character trans,
integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer info )

ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf (unblocked algorithm).

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

Purpose:
!>
!> ZUNM2L overwrites the general complex m-by-n matrix C with
!>
!>       Q * C  if SIDE = 'L' and TRANS = 'N', or
!>
!>       Q**H* C  if SIDE = 'L' and TRANS = 'C', or
!>
!>       C * Q  if SIDE = 'R' and TRANS = 'N', or
!>
!>       C * Q**H if SIDE = 'R' and TRANS = 'C',
!>
!> where Q is a complex unitary matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(k) . . . H(2) H(1)
!>
!> as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n
!> if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left
!>          = 'R': apply Q or Q**H from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'C': apply Q**H (Conjugate transpose)
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,K)
!>          The i-th column must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          ZGEQLF in the last k columns of its array argument A.
!>          A is modified by the routine but restored on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If SIDE = 'L', LDA >= max(1,M);
!>          if SIDE = 'R', LDA >= max(1,N).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGEQLF.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[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',
!>                                   (M) if SIDE = 'R'
!>
[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 157 of file zunm2l.f.

159*
160* -- LAPACK computational routine --
161* -- LAPACK is a software package provided by Univ. of Tennessee, --
162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*
164* .. Scalar Arguments ..
165 CHARACTER SIDE, TRANS
166 INTEGER INFO, K, LDA, LDC, M, N
167* ..
168* .. Array Arguments ..
169 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 COMPLEX*16 ONE
176 parameter( one = ( 1.0d+0, 0.0d+0 ) )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, MI, NI, NQ
181 COMPLEX*16 AII, TAUI
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL xerbla, zlarf
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC dconjg, max
192* ..
193* .. Executable Statements ..
194*
195* Test the input arguments
196*
197 info = 0
198 left = lsame( side, 'L' )
199 notran = lsame( trans, 'N' )
200*
201* NQ is the order of Q
202*
203 IF( left ) THEN
204 nq = m
205 ELSE
206 nq = n
207 END IF
208 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
209 info = -1
210 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
211 info = -2
212 ELSE IF( m.LT.0 ) THEN
213 info = -3
214 ELSE IF( n.LT.0 ) THEN
215 info = -4
216 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
217 info = -5
218 ELSE IF( lda.LT.max( 1, nq ) ) THEN
219 info = -7
220 ELSE IF( ldc.LT.max( 1, m ) ) THEN
221 info = -10
222 END IF
223 IF( info.NE.0 ) THEN
224 CALL xerbla( 'ZUNM2L', -info )
225 RETURN
226 END IF
227*
228* Quick return if possible
229*
230 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 )
231 $ RETURN
232*
233 IF( ( left .AND. notran .OR. .NOT.left .AND. .NOT.notran ) ) THEN
234 i1 = 1
235 i2 = k
236 i3 = 1
237 ELSE
238 i1 = k
239 i2 = 1
240 i3 = -1
241 END IF
242*
243 IF( left ) THEN
244 ni = n
245 ELSE
246 mi = m
247 END IF
248*
249 DO 10 i = i1, i2, i3
250 IF( left ) THEN
251*
252* H(i) or H(i)**H is applied to C(1:m-k+i,1:n)
253*
254 mi = m - k + i
255 ELSE
256*
257* H(i) or H(i)**H is applied to C(1:m,1:n-k+i)
258*
259 ni = n - k + i
260 END IF
261*
262* Apply H(i) or H(i)**H
263*
264 IF( notran ) THEN
265 taui = tau( i )
266 ELSE
267 taui = dconjg( tau( i ) )
268 END IF
269 aii = a( nq-k+i, i )
270 a( nq-k+i, i ) = one
271 CALL zlarf( side, mi, ni, a( 1, i ), 1, taui, c, ldc, work )
272 a( nq-k+i, i ) = aii
273 10 CONTINUE
274 RETURN
275*
276* End of ZUNM2L
277*

◆ zunm2r()

subroutine zunm2r ( character side,
character trans,
integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer info )

ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm).

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

Purpose:
!>
!> ZUNM2R overwrites the general complex m-by-n matrix C with
!>
!>       Q * C  if SIDE = 'L' and TRANS = 'N', or
!>
!>       Q**H* C  if SIDE = 'L' and TRANS = 'C', or
!>
!>       C * Q  if SIDE = 'R' and TRANS = 'N', or
!>
!>       C * Q**H if SIDE = 'R' and TRANS = 'C',
!>
!> where Q is a complex unitary matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1) H(2) . . . H(k)
!>
!> as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n
!> if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left
!>          = 'R': apply Q or Q**H from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'C': apply Q**H (Conjugate transpose)
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,K)
!>          The i-th column must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          ZGEQRF in the first k columns of its array argument A.
!>          A is modified by the routine but restored on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If SIDE = 'L', LDA >= max(1,M);
!>          if SIDE = 'R', LDA >= max(1,N).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGEQRF.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[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',
!>                                   (M) if SIDE = 'R'
!>
[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 157 of file zunm2r.f.

159*
160* -- LAPACK computational routine --
161* -- LAPACK is a software package provided by Univ. of Tennessee, --
162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*
164* .. Scalar Arguments ..
165 CHARACTER SIDE, TRANS
166 INTEGER INFO, K, LDA, LDC, M, N
167* ..
168* .. Array Arguments ..
169 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 COMPLEX*16 ONE
176 parameter( one = ( 1.0d+0, 0.0d+0 ) )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
181 COMPLEX*16 AII, TAUI
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL xerbla, zlarf
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC dconjg, max
192* ..
193* .. Executable Statements ..
194*
195* Test the input arguments
196*
197 info = 0
198 left = lsame( side, 'L' )
199 notran = lsame( trans, 'N' )
200*
201* NQ is the order of Q
202*
203 IF( left ) THEN
204 nq = m
205 ELSE
206 nq = n
207 END IF
208 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
209 info = -1
210 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
211 info = -2
212 ELSE IF( m.LT.0 ) THEN
213 info = -3
214 ELSE IF( n.LT.0 ) THEN
215 info = -4
216 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
217 info = -5
218 ELSE IF( lda.LT.max( 1, nq ) ) THEN
219 info = -7
220 ELSE IF( ldc.LT.max( 1, m ) ) THEN
221 info = -10
222 END IF
223 IF( info.NE.0 ) THEN
224 CALL xerbla( 'ZUNM2R', -info )
225 RETURN
226 END IF
227*
228* Quick return if possible
229*
230 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 )
231 $ RETURN
232*
233 IF( ( left .AND. .NOT.notran .OR. .NOT.left .AND. notran ) ) THEN
234 i1 = 1
235 i2 = k
236 i3 = 1
237 ELSE
238 i1 = k
239 i2 = 1
240 i3 = -1
241 END IF
242*
243 IF( left ) THEN
244 ni = n
245 jc = 1
246 ELSE
247 mi = m
248 ic = 1
249 END IF
250*
251 DO 10 i = i1, i2, i3
252 IF( left ) THEN
253*
254* H(i) or H(i)**H is applied to C(i:m,1:n)
255*
256 mi = m - i + 1
257 ic = i
258 ELSE
259*
260* H(i) or H(i)**H is applied to C(1:m,i:n)
261*
262 ni = n - i + 1
263 jc = i
264 END IF
265*
266* Apply H(i) or H(i)**H
267*
268 IF( notran ) THEN
269 taui = tau( i )
270 ELSE
271 taui = dconjg( tau( i ) )
272 END IF
273 aii = a( i, i )
274 a( i, i ) = one
275 CALL zlarf( side, mi, ni, a( i, i ), 1, taui, c( ic, jc ), ldc,
276 $ work )
277 a( i, i ) = aii
278 10 CONTINUE
279 RETURN
280*
281* End of ZUNM2R
282*

◆ zunmbr()

subroutine zunmbr ( character vect,
character side,
character trans,
integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNMBR

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

Purpose:
!>
!> If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C
!> with
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q * C          C * Q
!> TRANS = 'C':      Q**H * C       C * Q**H
!>
!> If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C
!> with
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      P * C          C * P
!> TRANS = 'C':      P**H * C       C * P**H
!>
!> Here Q and P**H are the unitary matrices determined by ZGEBRD when
!> reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q
!> and P**H are defined as products of elementary reflectors H(i) and
!> G(i) respectively.
!>
!> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
!> order of the unitary matrix Q or P**H that is applied.
!>
!> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
!> if nq >= k, Q = H(1) H(2) . . . H(k);
!> if nq < k, Q = H(1) H(2) . . . H(nq-1).
!>
!> If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
!> if k < nq, P = G(1) G(2) . . . G(k);
!> if k >= nq, P = G(1) G(2) . . . G(nq-1).
!>
Parameters
[in]VECT
!>          VECT is CHARACTER*1
!>          = 'Q': apply Q or Q**H;
!>          = 'P': apply P or P**H.
!>
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q, Q**H, P or P**H from the Left;
!>          = 'R': apply Q, Q**H, P or P**H from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q or P;
!>          = 'C':  Conjugate transpose, apply Q**H or P**H.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          If VECT = 'Q', the number of columns in the original
!>          matrix reduced by ZGEBRD.
!>          If VECT = 'P', the number of rows in the original
!>          matrix reduced by ZGEBRD.
!>          K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension
!>                                (LDA,min(nq,K)) if VECT = 'Q'
!>                                (LDA,nq)        if VECT = 'P'
!>          The vectors which define the elementary reflectors H(i) and
!>          G(i), whose products determine the matrices Q and P, as
!>          returned by ZGEBRD.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If VECT = 'Q', LDA >= max(1,nq);
!>          if VECT = 'P', LDA >= max(1,min(nq,K)).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (min(nq,K))
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i) or G(i) which determines Q or P, as returned
!>          by ZGEBRD in the array argument TAUQ or TAUP.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q
!>          or P*C or P**H*C or C*P or C*P**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 (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M);
!>          if N = 0 or M = 0, LWORK >= 1.
!>          For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',
!>          and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the
!>          optimal blocksize. (NB = 0 if M = 0 or N = 0.)
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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 194 of file zunmbr.f.

196*
197* -- LAPACK computational 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 CHARACTER SIDE, TRANS, VECT
203 INTEGER INFO, K, LDA, LDC, LWORK, M, N
204* ..
205* .. Array Arguments ..
206 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
207* ..
208*
209* =====================================================================
210*
211* .. Local Scalars ..
212 LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
213 CHARACTER TRANST
214 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
215* ..
216* .. External Functions ..
217 LOGICAL LSAME
218 INTEGER ILAENV
219 EXTERNAL lsame, ilaenv
220* ..
221* .. External Subroutines ..
222 EXTERNAL xerbla, zunmlq, zunmqr
223* ..
224* .. Intrinsic Functions ..
225 INTRINSIC max, min
226* ..
227* .. Executable Statements ..
228*
229* Test the input arguments
230*
231 info = 0
232 applyq = lsame( vect, 'Q' )
233 left = lsame( side, 'L' )
234 notran = lsame( trans, 'N' )
235 lquery = ( lwork.EQ.-1 )
236*
237* NQ is the order of Q or P and NW is the minimum dimension of WORK
238*
239 IF( left ) THEN
240 nq = m
241 nw = max( 1, n )
242 ELSE
243 nq = n
244 nw = max( 1, m )
245 END IF
246 IF( .NOT.applyq .AND. .NOT.lsame( vect, 'P' ) ) THEN
247 info = -1
248 ELSE IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
249 info = -2
250 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
251 info = -3
252 ELSE IF( m.LT.0 ) THEN
253 info = -4
254 ELSE IF( n.LT.0 ) THEN
255 info = -5
256 ELSE IF( k.LT.0 ) THEN
257 info = -6
258 ELSE IF( ( applyq .AND. lda.LT.max( 1, nq ) ) .OR.
259 $ ( .NOT.applyq .AND. lda.LT.max( 1, min( nq, k ) ) ) )
260 $ THEN
261 info = -8
262 ELSE IF( ldc.LT.max( 1, m ) ) THEN
263 info = -11
264 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
265 info = -13
266 END IF
267*
268 IF( info.EQ.0 ) THEN
269 IF( m.GT.0 .AND. n.GT.0 ) THEN
270 IF( applyq ) THEN
271 IF( left ) THEN
272 nb = ilaenv( 1, 'ZUNMQR', side // trans, m-1, n, m-1,
273 $ -1 )
274 ELSE
275 nb = ilaenv( 1, 'ZUNMQR', side // trans, m, n-1, n-1,
276 $ -1 )
277 END IF
278 ELSE
279 IF( left ) THEN
280 nb = ilaenv( 1, 'ZUNMLQ', side // trans, m-1, n, m-1,
281 $ -1 )
282 ELSE
283 nb = ilaenv( 1, 'ZUNMLQ', side // trans, m, n-1, n-1,
284 $ -1 )
285 END IF
286 END IF
287 lwkopt = nw*nb
288 ELSE
289 lwkopt = 1
290 END IF
291 work( 1 ) = lwkopt
292 END IF
293*
294 IF( info.NE.0 ) THEN
295 CALL xerbla( 'ZUNMBR', -info )
296 RETURN
297 ELSE IF( lquery ) THEN
298 RETURN
299 END IF
300*
301* Quick return if possible
302*
303 IF( m.EQ.0 .OR. n.EQ.0 )
304 $ RETURN
305*
306 IF( applyq ) THEN
307*
308* Apply Q
309*
310 IF( nq.GE.k ) THEN
311*
312* Q was determined by a call to ZGEBRD with nq >= k
313*
314 CALL zunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,
315 $ work, lwork, iinfo )
316 ELSE IF( nq.GT.1 ) THEN
317*
318* Q was determined by a call to ZGEBRD with nq < k
319*
320 IF( left ) THEN
321 mi = m - 1
322 ni = n
323 i1 = 2
324 i2 = 1
325 ELSE
326 mi = m
327 ni = n - 1
328 i1 = 1
329 i2 = 2
330 END IF
331 CALL zunmqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,
332 $ c( i1, i2 ), ldc, work, lwork, iinfo )
333 END IF
334 ELSE
335*
336* Apply P
337*
338 IF( notran ) THEN
339 transt = 'C'
340 ELSE
341 transt = 'N'
342 END IF
343 IF( nq.GT.k ) THEN
344*
345* P was determined by a call to ZGEBRD with nq > k
346*
347 CALL zunmlq( side, transt, m, n, k, a, lda, tau, c, ldc,
348 $ work, lwork, iinfo )
349 ELSE IF( nq.GT.1 ) THEN
350*
351* P was determined by a call to ZGEBRD with nq <= k
352*
353 IF( left ) THEN
354 mi = m - 1
355 ni = n
356 i1 = 2
357 i2 = 1
358 ELSE
359 mi = m
360 ni = n - 1
361 i1 = 1
362 i2 = 2
363 END IF
364 CALL zunmlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,
365 $ tau, c( i1, i2 ), ldc, work, lwork, iinfo )
366 END IF
367 END IF
368 work( 1 ) = lwkopt
369 RETURN
370*
371* End of ZUNMBR
372*
zunmlq
subroutine zunmlq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMLQ
Definition zunmlq.f:167

◆ zunmhr()

subroutine zunmhr ( character side,
character trans,
integer m,
integer n,
integer ilo,
integer ihi,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNMHR

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

Purpose:
!>
!> ZUNMHR overwrites the general complex M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q * C          C * Q
!> TRANS = 'C':      Q**H * C       C * Q**H
!>
!> where Q is a complex unitary matrix of order nq, with nq = m if
!> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!> IHI-ILO elementary reflectors, as returned by ZGEHRD:
!>
!> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'C': apply Q**H (Conjugate transpose)
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
!>          ILO and IHI must have the same values as in the previous call
!>          of ZGEHRD. Q is equal to the unit matrix except in the
!>          submatrix Q(ilo+1:ihi,ilo+1:ihi).
!>          If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
!>          ILO = 1 and IHI = 0, if M = 0;
!>          if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
!>          ILO = 1 and IHI = 0, if N = 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension
!>                               (LDA,M) if SIDE = 'L'
!>                               (LDA,N) if SIDE = 'R'
!>          The vectors which define the elementary reflectors, as
!>          returned by ZGEHRD.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension
!>                               (M-1) if SIDE = 'L'
!>                               (N-1) if SIDE = 'R'
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGEHRD.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!>          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!>          blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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 176 of file zunmhr.f.

178*
179* -- LAPACK computational routine --
180* -- LAPACK is a software package provided by Univ. of Tennessee, --
181* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
182*
183* .. Scalar Arguments ..
184 CHARACTER SIDE, TRANS
185 INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
186* ..
187* .. Array Arguments ..
188 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
189* ..
190*
191* =====================================================================
192*
193* .. Local Scalars ..
194 LOGICAL LEFT, LQUERY
195 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
196* ..
197* .. External Functions ..
198 LOGICAL LSAME
199 INTEGER ILAENV
200 EXTERNAL lsame, ilaenv
201* ..
202* .. External Subroutines ..
203 EXTERNAL xerbla, zunmqr
204* ..
205* .. Intrinsic Functions ..
206 INTRINSIC max, min
207* ..
208* .. Executable Statements ..
209*
210* Test the input arguments
211*
212 info = 0
213 nh = ihi - ilo
214 left = lsame( side, 'L' )
215 lquery = ( lwork.EQ.-1 )
216*
217* NQ is the order of Q and NW is the minimum dimension of WORK
218*
219 IF( left ) THEN
220 nq = m
221 nw = max( 1, n )
222 ELSE
223 nq = n
224 nw = max( 1, m )
225 END IF
226 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
227 info = -1
228 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) )
229 $ THEN
230 info = -2
231 ELSE IF( m.LT.0 ) THEN
232 info = -3
233 ELSE IF( n.LT.0 ) THEN
234 info = -4
235 ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, nq ) ) THEN
236 info = -5
237 ELSE IF( ihi.LT.min( ilo, nq ) .OR. ihi.GT.nq ) THEN
238 info = -6
239 ELSE IF( lda.LT.max( 1, nq ) ) THEN
240 info = -8
241 ELSE IF( ldc.LT.max( 1, m ) ) THEN
242 info = -11
243 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
244 info = -13
245 END IF
246*
247 IF( info.EQ.0 ) THEN
248 IF( left ) THEN
249 nb = ilaenv( 1, 'ZUNMQR', side // trans, nh, n, nh, -1 )
250 ELSE
251 nb = ilaenv( 1, 'ZUNMQR', side // trans, m, nh, nh, -1 )
252 END IF
253 lwkopt = nw*nb
254 work( 1 ) = lwkopt
255 END IF
256*
257 IF( info.NE.0 ) THEN
258 CALL xerbla( 'ZUNMHR', -info )
259 RETURN
260 ELSE IF( lquery ) THEN
261 RETURN
262 END IF
263*
264* Quick return if possible
265*
266 IF( m.EQ.0 .OR. n.EQ.0 .OR. nh.EQ.0 ) THEN
267 work( 1 ) = 1
268 RETURN
269 END IF
270*
271 IF( left ) THEN
272 mi = nh
273 ni = n
274 i1 = ilo + 1
275 i2 = 1
276 ELSE
277 mi = m
278 ni = nh
279 i1 = 1
280 i2 = ilo + 1
281 END IF
282*
283 CALL zunmqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,
284 $ tau( ilo ), c( i1, i2 ), ldc, work, lwork, iinfo )
285*
286 work( 1 ) = lwkopt
287 RETURN
288*
289* End of ZUNMHR
290*

◆ zunml2()

subroutine zunml2 ( character side,
character trans,
integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer info )

ZUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf (unblocked algorithm).

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

Purpose:
!>
!> ZUNML2 overwrites the general complex m-by-n matrix C with
!>
!>       Q * C  if SIDE = 'L' and TRANS = 'N', or
!>
!>       Q**H* C  if SIDE = 'L' and TRANS = 'C', or
!>
!>       C * Q  if SIDE = 'R' and TRANS = 'N', or
!>
!>       C * Q**H if SIDE = 'R' and TRANS = 'C',
!>
!> where Q is a complex unitary matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(k)**H . . . H(2)**H H(1)**H
!>
!> as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n
!> if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left
!>          = 'R': apply Q or Q**H from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'C': apply Q**H (Conjugate transpose)
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension
!>                               (LDA,M) if SIDE = 'L',
!>                               (LDA,N) if SIDE = 'R'
!>          The i-th row must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          ZGELQF in the first k rows of its array argument A.
!>          A is modified by the routine but restored on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,K).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGELQF.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[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',
!>                                   (M) if SIDE = 'R'
!>
[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 157 of file zunml2.f.

159*
160* -- LAPACK computational routine --
161* -- LAPACK is a software package provided by Univ. of Tennessee, --
162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*
164* .. Scalar Arguments ..
165 CHARACTER SIDE, TRANS
166 INTEGER INFO, K, LDA, LDC, M, N
167* ..
168* .. Array Arguments ..
169 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 COMPLEX*16 ONE
176 parameter( one = ( 1.0d+0, 0.0d+0 ) )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
181 COMPLEX*16 AII, TAUI
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL xerbla, zlacgv, zlarf
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC dconjg, max
192* ..
193* .. Executable Statements ..
194*
195* Test the input arguments
196*
197 info = 0
198 left = lsame( side, 'L' )
199 notran = lsame( trans, 'N' )
200*
201* NQ is the order of Q
202*
203 IF( left ) THEN
204 nq = m
205 ELSE
206 nq = n
207 END IF
208 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
209 info = -1
210 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
211 info = -2
212 ELSE IF( m.LT.0 ) THEN
213 info = -3
214 ELSE IF( n.LT.0 ) THEN
215 info = -4
216 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
217 info = -5
218 ELSE IF( lda.LT.max( 1, k ) ) THEN
219 info = -7
220 ELSE IF( ldc.LT.max( 1, m ) ) THEN
221 info = -10
222 END IF
223 IF( info.NE.0 ) THEN
224 CALL xerbla( 'ZUNML2', -info )
225 RETURN
226 END IF
227*
228* Quick return if possible
229*
230 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 )
231 $ RETURN
232*
233 IF( ( left .AND. notran .OR. .NOT.left .AND. .NOT.notran ) ) THEN
234 i1 = 1
235 i2 = k
236 i3 = 1
237 ELSE
238 i1 = k
239 i2 = 1
240 i3 = -1
241 END IF
242*
243 IF( left ) THEN
244 ni = n
245 jc = 1
246 ELSE
247 mi = m
248 ic = 1
249 END IF
250*
251 DO 10 i = i1, i2, i3
252 IF( left ) THEN
253*
254* H(i) or H(i)**H is applied to C(i:m,1:n)
255*
256 mi = m - i + 1
257 ic = i
258 ELSE
259*
260* H(i) or H(i)**H is applied to C(1:m,i:n)
261*
262 ni = n - i + 1
263 jc = i
264 END IF
265*
266* Apply H(i) or H(i)**H
267*
268 IF( notran ) THEN
269 taui = dconjg( tau( i ) )
270 ELSE
271 taui = tau( i )
272 END IF
273 IF( i.LT.nq )
274 $ CALL zlacgv( nq-i, a( i, i+1 ), lda )
275 aii = a( i, i )
276 a( i, i ) = one
277 CALL zlarf( side, mi, ni, a( i, i ), lda, taui, c( ic, jc ),
278 $ ldc, work )
279 a( i, i ) = aii
280 IF( i.LT.nq )
281 $ CALL zlacgv( nq-i, a( i, i+1 ), lda )
282 10 CONTINUE
283 RETURN
284*
285* End of ZUNML2
286*

◆ zunmlq()

subroutine zunmlq ( character side,
character trans,
integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNMLQ

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

Purpose:
!>
!> ZUNMLQ overwrites the general complex M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q * C          C * Q
!> TRANS = 'C':      Q**H * C       C * Q**H
!>
!> where Q is a complex unitary matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(k)**H . . . H(2)**H H(1)**H
!>
!> as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N
!> if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate transpose, apply Q**H.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension
!>                               (LDA,M) if SIDE = 'L',
!>                               (LDA,N) if SIDE = 'R'
!>          The i-th row must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          ZGELQF in the first k rows of its array argument A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,K).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGELQF.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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 165 of file zunmlq.f.

167*
168* -- LAPACK computational 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 CHARACTER SIDE, TRANS
174 INTEGER INFO, K, LDA, LDC, LWORK, M, N
175* ..
176* .. Array Arguments ..
177 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 INTEGER NBMAX, LDT, TSIZE
184 parameter( nbmax = 64, ldt = nbmax+1,
185 $ tsize = ldt*nbmax )
186* ..
187* .. Local Scalars ..
188 LOGICAL LEFT, LQUERY, NOTRAN
189 CHARACTER TRANST
190 INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
191 $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
192* ..
193* .. External Functions ..
194 LOGICAL LSAME
195 INTEGER ILAENV
196 EXTERNAL lsame, ilaenv
197* ..
198* .. External Subroutines ..
199 EXTERNAL xerbla, zlarfb, zlarft, zunml2
200* ..
201* .. Intrinsic Functions ..
202 INTRINSIC max, min
203* ..
204* .. Executable Statements ..
205*
206* Test the input arguments
207*
208 info = 0
209 left = lsame( side, 'L' )
210 notran = lsame( trans, 'N' )
211 lquery = ( lwork.EQ.-1 )
212*
213* NQ is the order of Q and NW is the minimum dimension of WORK
214*
215 IF( left ) THEN
216 nq = m
217 nw = max( 1, n )
218 ELSE
219 nq = n
220 nw = max( 1, m )
221 END IF
222 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
223 info = -1
224 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
225 info = -2
226 ELSE IF( m.LT.0 ) THEN
227 info = -3
228 ELSE IF( n.LT.0 ) THEN
229 info = -4
230 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
231 info = -5
232 ELSE IF( lda.LT.max( 1, k ) ) THEN
233 info = -7
234 ELSE IF( ldc.LT.max( 1, m ) ) THEN
235 info = -10
236 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
237 info = -12
238 END IF
239*
240 IF( info.EQ.0 ) THEN
241*
242* Compute the workspace requirements
243*
244 nb = min( nbmax, ilaenv( 1, 'ZUNMLQ', side // trans, m, n, k,
245 $ -1 ) )
246 lwkopt = nw*nb + tsize
247 work( 1 ) = lwkopt
248 END IF
249*
250 IF( info.NE.0 ) THEN
251 CALL xerbla( 'ZUNMLQ', -info )
252 RETURN
253 ELSE IF( lquery ) THEN
254 RETURN
255 END IF
256*
257* Quick return if possible
258*
259 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) THEN
260 work( 1 ) = 1
261 RETURN
262 END IF
263*
264 nbmin = 2
265 ldwork = nw
266 IF( nb.GT.1 .AND. nb.LT.k ) THEN
267 IF( lwork.LT.lwkopt ) THEN
268 nb = (lwork-tsize) / ldwork
269 nbmin = max( 2, ilaenv( 2, 'ZUNMLQ', side // trans, m, n, k,
270 $ -1 ) )
271 END IF
272 END IF
273*
274 IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
275*
276* Use unblocked code
277*
278 CALL zunml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,
279 $ iinfo )
280 ELSE
281*
282* Use blocked code
283*
284 iwt = 1 + nw*nb
285 IF( ( left .AND. notran ) .OR.
286 $ ( .NOT.left .AND. .NOT.notran ) ) THEN
287 i1 = 1
288 i2 = k
289 i3 = nb
290 ELSE
291 i1 = ( ( k-1 ) / nb )*nb + 1
292 i2 = 1
293 i3 = -nb
294 END IF
295*
296 IF( left ) THEN
297 ni = n
298 jc = 1
299 ELSE
300 mi = m
301 ic = 1
302 END IF
303*
304 IF( notran ) THEN
305 transt = 'C'
306 ELSE
307 transt = 'N'
308 END IF
309*
310 DO 10 i = i1, i2, i3
311 ib = min( nb, k-i+1 )
312*
313* Form the triangular factor of the block reflector
314* H = H(i) H(i+1) . . . H(i+ib-1)
315*
316 CALL zlarft( 'Forward', 'Rowwise', nq-i+1, ib, a( i, i ),
317 $ lda, tau( i ), work( iwt ), ldt )
318 IF( left ) THEN
319*
320* H or H**H is applied to C(i:m,1:n)
321*
322 mi = m - i + 1
323 ic = i
324 ELSE
325*
326* H or H**H is applied to C(1:m,i:n)
327*
328 ni = n - i + 1
329 jc = i
330 END IF
331*
332* Apply H or H**H
333*
334 CALL zlarfb( side, transt, 'Forward', 'Rowwise', mi, ni, ib,
335 $ a( i, i ), lda, work( iwt ), ldt,
336 $ c( ic, jc ), ldc, work, ldwork )
337 10 CONTINUE
338 END IF
339 work( 1 ) = lwkopt
340 RETURN
341*
342* End of ZUNMLQ
343*
zunml2
subroutine zunml2(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf...
Definition zunml2.f:159

◆ zunmql()

subroutine zunmql ( character side,
character trans,
integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNMQL

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

Purpose:
!>
!> ZUNMQL overwrites the general complex M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q * C          C * Q
!> TRANS = 'C':      Q**H * C       C * Q**H
!>
!> where Q is a complex unitary matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(k) . . . H(2) H(1)
!>
!> as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N
!> if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate transpose, apply Q**H.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,K)
!>          The i-th column must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          ZGEQLF in the last k columns of its array argument A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If SIDE = 'L', LDA >= max(1,M);
!>          if SIDE = 'R', LDA >= max(1,N).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGEQLF.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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 165 of file zunmql.f.

167*
168* -- LAPACK computational 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 CHARACTER SIDE, TRANS
174 INTEGER INFO, K, LDA, LDC, LWORK, M, N
175* ..
176* .. Array Arguments ..
177 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 INTEGER NBMAX, LDT, TSIZE
184 parameter( nbmax = 64, ldt = nbmax+1,
185 $ tsize = ldt*nbmax )
186* ..
187* .. Local Scalars ..
188 LOGICAL LEFT, LQUERY, NOTRAN
189 INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT,
190 $ MI, NB, NBMIN, NI, NQ, NW
191* ..
192* .. External Functions ..
193 LOGICAL LSAME
194 INTEGER ILAENV
195 EXTERNAL lsame, ilaenv
196* ..
197* .. External Subroutines ..
198 EXTERNAL xerbla, zlarfb, zlarft, zunm2l
199* ..
200* .. Intrinsic Functions ..
201 INTRINSIC max, min
202* ..
203* .. Executable Statements ..
204*
205* Test the input arguments
206*
207 info = 0
208 left = lsame( side, 'L' )
209 notran = lsame( trans, 'N' )
210 lquery = ( lwork.EQ.-1 )
211*
212* NQ is the order of Q and NW is the minimum dimension of WORK
213*
214 IF( left ) THEN
215 nq = m
216 nw = max( 1, n )
217 ELSE
218 nq = n
219 nw = max( 1, m )
220 END IF
221 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
222 info = -1
223 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
224 info = -2
225 ELSE IF( m.LT.0 ) THEN
226 info = -3
227 ELSE IF( n.LT.0 ) THEN
228 info = -4
229 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
230 info = -5
231 ELSE IF( lda.LT.max( 1, nq ) ) THEN
232 info = -7
233 ELSE IF( ldc.LT.max( 1, m ) ) THEN
234 info = -10
235 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
236 info = -12
237 END IF
238*
239 IF( info.EQ.0 ) THEN
240*
241* Compute the workspace requirements
242*
243 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
244 lwkopt = 1
245 ELSE
246 nb = min( nbmax, ilaenv( 1, 'ZUNMQL', side // trans, m, n,
247 $ k, -1 ) )
248 lwkopt = nw*nb + tsize
249 END IF
250 work( 1 ) = lwkopt
251 END IF
252*
253 IF( info.NE.0 ) THEN
254 CALL xerbla( 'ZUNMQL', -info )
255 RETURN
256 ELSE IF( lquery ) THEN
257 RETURN
258 END IF
259*
260* Quick return if possible
261*
262 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
263 RETURN
264 END IF
265*
266 nbmin = 2
267 ldwork = nw
268 IF( nb.GT.1 .AND. nb.LT.k ) THEN
269 IF( lwork.LT.lwkopt ) THEN
270 nb = (lwork-tsize) / ldwork
271 nbmin = max( 2, ilaenv( 2, 'ZUNMQL', side // trans, m, n, k,
272 $ -1 ) )
273 END IF
274 END IF
275*
276 IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
277*
278* Use unblocked code
279*
280 CALL zunm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,
281 $ iinfo )
282 ELSE
283*
284* Use blocked code
285*
286 iwt = 1 + nw*nb
287 IF( ( left .AND. notran ) .OR.
288 $ ( .NOT.left .AND. .NOT.notran ) ) THEN
289 i1 = 1
290 i2 = k
291 i3 = nb
292 ELSE
293 i1 = ( ( k-1 ) / nb )*nb + 1
294 i2 = 1
295 i3 = -nb
296 END IF
297*
298 IF( left ) THEN
299 ni = n
300 ELSE
301 mi = m
302 END IF
303*
304 DO 10 i = i1, i2, i3
305 ib = min( nb, k-i+1 )
306*
307* Form the triangular factor of the block reflector
308* H = H(i+ib-1) . . . H(i+1) H(i)
309*
310 CALL zlarft( 'Backward', 'Columnwise', nq-k+i+ib-1, ib,
311 $ a( 1, i ), lda, tau( i ), work( iwt ), ldt )
312 IF( left ) THEN
313*
314* H or H**H is applied to C(1:m-k+i+ib-1,1:n)
315*
316 mi = m - k + i + ib - 1
317 ELSE
318*
319* H or H**H is applied to C(1:m,1:n-k+i+ib-1)
320*
321 ni = n - k + i + ib - 1
322 END IF
323*
324* Apply H or H**H
325*
326 CALL zlarfb( side, trans, 'Backward', 'Columnwise', mi, ni,
327 $ ib, a( 1, i ), lda, work( iwt ), ldt, c, ldc,
328 $ work, ldwork )
329 10 CONTINUE
330 END IF
331 work( 1 ) = lwkopt
332 RETURN
333*
334* End of ZUNMQL
335*
zunm2l
subroutine zunm2l(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf...
Definition zunm2l.f:159

◆ zunmqr()

subroutine zunmqr ( character side,
character trans,
integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNMQR

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

Purpose:
!>
!> ZUNMQR overwrites the general complex M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q * C          C * Q
!> TRANS = 'C':      Q**H * C       C * Q**H
!>
!> where Q is a complex unitary matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1) H(2) . . . H(k)
!>
!> as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N
!> if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate transpose, apply Q**H.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,K)
!>          The i-th column must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          ZGEQRF in the first k columns of its array argument A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If SIDE = 'L', LDA >= max(1,M);
!>          if SIDE = 'R', LDA >= max(1,N).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGEQRF.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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 165 of file zunmqr.f.

167*
168* -- LAPACK computational 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 CHARACTER SIDE, TRANS
174 INTEGER INFO, K, LDA, LDC, LWORK, M, N
175* ..
176* .. Array Arguments ..
177 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 INTEGER NBMAX, LDT, TSIZE
184 parameter( nbmax = 64, ldt = nbmax+1,
185 $ tsize = ldt*nbmax )
186* ..
187* .. Local Scalars ..
188 LOGICAL LEFT, LQUERY, NOTRAN
189 INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
190 $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
191* ..
192* .. External Functions ..
193 LOGICAL LSAME
194 INTEGER ILAENV
195 EXTERNAL lsame, ilaenv
196* ..
197* .. External Subroutines ..
198 EXTERNAL xerbla, zlarfb, zlarft, zunm2r
199* ..
200* .. Intrinsic Functions ..
201 INTRINSIC max, min
202* ..
203* .. Executable Statements ..
204*
205* Test the input arguments
206*
207 info = 0
208 left = lsame( side, 'L' )
209 notran = lsame( trans, 'N' )
210 lquery = ( lwork.EQ.-1 )
211*
212* NQ is the order of Q and NW is the minimum dimension of WORK
213*
214 IF( left ) THEN
215 nq = m
216 nw = max( 1, n )
217 ELSE
218 nq = n
219 nw = max( 1, m )
220 END IF
221 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
222 info = -1
223 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
224 info = -2
225 ELSE IF( m.LT.0 ) THEN
226 info = -3
227 ELSE IF( n.LT.0 ) THEN
228 info = -4
229 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
230 info = -5
231 ELSE IF( lda.LT.max( 1, nq ) ) THEN
232 info = -7
233 ELSE IF( ldc.LT.max( 1, m ) ) THEN
234 info = -10
235 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
236 info = -12
237 END IF
238*
239 IF( info.EQ.0 ) THEN
240*
241* Compute the workspace requirements
242*
243 nb = min( nbmax, ilaenv( 1, 'ZUNMQR', side // trans, m, n, k,
244 $ -1 ) )
245 lwkopt = nw*nb + tsize
246 work( 1 ) = lwkopt
247 END IF
248*
249 IF( info.NE.0 ) THEN
250 CALL xerbla( 'ZUNMQR', -info )
251 RETURN
252 ELSE IF( lquery ) THEN
253 RETURN
254 END IF
255*
256* Quick return if possible
257*
258 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) THEN
259 work( 1 ) = 1
260 RETURN
261 END IF
262*
263 nbmin = 2
264 ldwork = nw
265 IF( nb.GT.1 .AND. nb.LT.k ) THEN
266 IF( lwork.LT.lwkopt ) THEN
267 nb = (lwork-tsize) / ldwork
268 nbmin = max( 2, ilaenv( 2, 'ZUNMQR', side // trans, m, n, k,
269 $ -1 ) )
270 END IF
271 END IF
272*
273 IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
274*
275* Use unblocked code
276*
277 CALL zunm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,
278 $ iinfo )
279 ELSE
280*
281* Use blocked code
282*
283 iwt = 1 + nw*nb
284 IF( ( left .AND. .NOT.notran ) .OR.
285 $ ( .NOT.left .AND. notran ) ) THEN
286 i1 = 1
287 i2 = k
288 i3 = nb
289 ELSE
290 i1 = ( ( k-1 ) / nb )*nb + 1
291 i2 = 1
292 i3 = -nb
293 END IF
294*
295 IF( left ) THEN
296 ni = n
297 jc = 1
298 ELSE
299 mi = m
300 ic = 1
301 END IF
302*
303 DO 10 i = i1, i2, i3
304 ib = min( nb, k-i+1 )
305*
306* Form the triangular factor of the block reflector
307* H = H(i) H(i+1) . . . H(i+ib-1)
308*
309 CALL zlarft( 'Forward', 'Columnwise', nq-i+1, ib, a( i, i ),
310 $ lda, tau( i ), work( iwt ), ldt )
311 IF( left ) THEN
312*
313* H or H**H is applied to C(i:m,1:n)
314*
315 mi = m - i + 1
316 ic = i
317 ELSE
318*
319* H or H**H is applied to C(1:m,i:n)
320*
321 ni = n - i + 1
322 jc = i
323 END IF
324*
325* Apply H or H**H
326*
327 CALL zlarfb( side, trans, 'Forward', 'Columnwise', mi, ni,
328 $ ib, a( i, i ), lda, work( iwt ), ldt,
329 $ c( ic, jc ), ldc, work, ldwork )
330 10 CONTINUE
331 END IF
332 work( 1 ) = lwkopt
333 RETURN
334*
335* End of ZUNMQR
336*

◆ zunmr2()

subroutine zunmr2 ( character side,
character trans,
integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer info )

ZUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf (unblocked algorithm).

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

Purpose:
!>
!> ZUNMR2 overwrites the general complex m-by-n matrix C with
!>
!>       Q * C  if SIDE = 'L' and TRANS = 'N', or
!>
!>       Q**H* C  if SIDE = 'L' and TRANS = 'C', or
!>
!>       C * Q  if SIDE = 'R' and TRANS = 'N', or
!>
!>       C * Q**H if SIDE = 'R' and TRANS = 'C',
!>
!> where Q is a complex unitary matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1)**H H(2)**H . . . H(k)**H
!>
!> as returned by ZGERQF. Q is of order m if SIDE = 'L' and of order n
!> if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left
!>          = 'R': apply Q or Q**H from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'C': apply Q**H (Conjugate transpose)
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension
!>                               (LDA,M) if SIDE = 'L',
!>                               (LDA,N) if SIDE = 'R'
!>          The i-th row must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          ZGERQF in the last k rows of its array argument A.
!>          A is modified by the routine but restored on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,K).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGERQF.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[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',
!>                                   (M) if SIDE = 'R'
!>
[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 157 of file zunmr2.f.

159*
160* -- LAPACK computational routine --
161* -- LAPACK is a software package provided by Univ. of Tennessee, --
162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*
164* .. Scalar Arguments ..
165 CHARACTER SIDE, TRANS
166 INTEGER INFO, K, LDA, LDC, M, N
167* ..
168* .. Array Arguments ..
169 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 COMPLEX*16 ONE
176 parameter( one = ( 1.0d+0, 0.0d+0 ) )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, MI, NI, NQ
181 COMPLEX*16 AII, TAUI
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL xerbla, zlacgv, zlarf
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC dconjg, max
192* ..
193* .. Executable Statements ..
194*
195* Test the input arguments
196*
197 info = 0
198 left = lsame( side, 'L' )
199 notran = lsame( trans, 'N' )
200*
201* NQ is the order of Q
202*
203 IF( left ) THEN
204 nq = m
205 ELSE
206 nq = n
207 END IF
208 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
209 info = -1
210 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
211 info = -2
212 ELSE IF( m.LT.0 ) THEN
213 info = -3
214 ELSE IF( n.LT.0 ) THEN
215 info = -4
216 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
217 info = -5
218 ELSE IF( lda.LT.max( 1, k ) ) THEN
219 info = -7
220 ELSE IF( ldc.LT.max( 1, m ) ) THEN
221 info = -10
222 END IF
223 IF( info.NE.0 ) THEN
224 CALL xerbla( 'ZUNMR2', -info )
225 RETURN
226 END IF
227*
228* Quick return if possible
229*
230 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 )
231 $ RETURN
232*
233 IF( ( left .AND. .NOT.notran .OR. .NOT.left .AND. notran ) ) THEN
234 i1 = 1
235 i2 = k
236 i3 = 1
237 ELSE
238 i1 = k
239 i2 = 1
240 i3 = -1
241 END IF
242*
243 IF( left ) THEN
244 ni = n
245 ELSE
246 mi = m
247 END IF
248*
249 DO 10 i = i1, i2, i3
250 IF( left ) THEN
251*
252* H(i) or H(i)**H is applied to C(1:m-k+i,1:n)
253*
254 mi = m - k + i
255 ELSE
256*
257* H(i) or H(i)**H is applied to C(1:m,1:n-k+i)
258*
259 ni = n - k + i
260 END IF
261*
262* Apply H(i) or H(i)**H
263*
264 IF( notran ) THEN
265 taui = dconjg( tau( i ) )
266 ELSE
267 taui = tau( i )
268 END IF
269 CALL zlacgv( nq-k+i-1, a( i, 1 ), lda )
270 aii = a( i, nq-k+i )
271 a( i, nq-k+i ) = one
272 CALL zlarf( side, mi, ni, a( i, 1 ), lda, taui, c, ldc, work )
273 a( i, nq-k+i ) = aii
274 CALL zlacgv( nq-k+i-1, a( i, 1 ), lda )
275 10 CONTINUE
276 RETURN
277*
278* End of ZUNMR2
279*

◆ zunmr3()

subroutine zunmr3 ( character side,
character trans,
integer m,
integer n,
integer k,
integer l,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer info )

ZUNMR3 multiplies a general matrix by the unitary matrix from a RZ factorization determined by ctzrzf (unblocked algorithm).

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

Purpose:
!>
!> ZUNMR3 overwrites the general complex m by n matrix C with
!>
!>       Q * C  if SIDE = 'L' and TRANS = 'N', or
!>
!>       Q**H* C  if SIDE = 'L' and TRANS = 'C', or
!>
!>       C * Q  if SIDE = 'R' and TRANS = 'N', or
!>
!>       C * Q**H if SIDE = 'R' and TRANS = 'C',
!>
!> where Q is a complex unitary matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1) H(2) . . . H(k)
!>
!> as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n
!> if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left
!>          = 'R': apply Q or Q**H from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'C': apply Q**H (Conjugate transpose)
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of columns of the matrix A containing
!>          the meaningful part of the Householder reflectors.
!>          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension
!>                               (LDA,M) if SIDE = 'L',
!>                               (LDA,N) if SIDE = 'R'
!>          The i-th row must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          ZTZRZF in the last k rows of its array argument A.
!>          A is modified by the routine but restored on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,K).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZTZRZF.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[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',
!>                                   (M) if SIDE = 'R'
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
Further Details:
!>

Definition at line 176 of file zunmr3.f.

178*
179* -- LAPACK computational routine --
180* -- LAPACK is a software package provided by Univ. of Tennessee, --
181* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
182*
183* .. Scalar Arguments ..
184 CHARACTER SIDE, TRANS
185 INTEGER INFO, K, L, LDA, LDC, M, N
186* ..
187* .. Array Arguments ..
188 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
189* ..
190*
191* =====================================================================
192*
193* .. Local Scalars ..
194 LOGICAL LEFT, NOTRAN
195 INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
196 COMPLEX*16 TAUI
197* ..
198* .. External Functions ..
199 LOGICAL LSAME
200 EXTERNAL lsame
201* ..
202* .. External Subroutines ..
203 EXTERNAL xerbla, zlarz
204* ..
205* .. Intrinsic Functions ..
206 INTRINSIC dconjg, max
207* ..
208* .. Executable Statements ..
209*
210* Test the input arguments
211*
212 info = 0
213 left = lsame( side, 'L' )
214 notran = lsame( trans, 'N' )
215*
216* NQ is the order of Q
217*
218 IF( left ) THEN
219 nq = m
220 ELSE
221 nq = n
222 END IF
223 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
224 info = -1
225 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
226 info = -2
227 ELSE IF( m.LT.0 ) THEN
228 info = -3
229 ELSE IF( n.LT.0 ) THEN
230 info = -4
231 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
232 info = -5
233 ELSE IF( l.LT.0 .OR. ( left .AND. ( l.GT.m ) ) .OR.
234 $ ( .NOT.left .AND. ( l.GT.n ) ) ) THEN
235 info = -6
236 ELSE IF( lda.LT.max( 1, k ) ) THEN
237 info = -8
238 ELSE IF( ldc.LT.max( 1, m ) ) THEN
239 info = -11
240 END IF
241 IF( info.NE.0 ) THEN
242 CALL xerbla( 'ZUNMR3', -info )
243 RETURN
244 END IF
245*
246* Quick return if possible
247*
248 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 )
249 $ RETURN
250*
251 IF( ( left .AND. .NOT.notran .OR. .NOT.left .AND. notran ) ) THEN
252 i1 = 1
253 i2 = k
254 i3 = 1
255 ELSE
256 i1 = k
257 i2 = 1
258 i3 = -1
259 END IF
260*
261 IF( left ) THEN
262 ni = n
263 ja = m - l + 1
264 jc = 1
265 ELSE
266 mi = m
267 ja = n - l + 1
268 ic = 1
269 END IF
270*
271 DO 10 i = i1, i2, i3
272 IF( left ) THEN
273*
274* H(i) or H(i)**H is applied to C(i:m,1:n)
275*
276 mi = m - i + 1
277 ic = i
278 ELSE
279*
280* H(i) or H(i)**H is applied to C(1:m,i:n)
281*
282 ni = n - i + 1
283 jc = i
284 END IF
285*
286* Apply H(i) or H(i)**H
287*
288 IF( notran ) THEN
289 taui = tau( i )
290 ELSE
291 taui = dconjg( tau( i ) )
292 END IF
293 CALL zlarz( side, mi, ni, l, a( i, ja ), lda, taui,
294 $ c( ic, jc ), ldc, work )
295*
296 10 CONTINUE
297*
298 RETURN
299*
300* End of ZUNMR3
301*

◆ zunmrq()

subroutine zunmrq ( character side,
character trans,
integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNMRQ

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

Purpose:
!>
!> ZUNMRQ overwrites the general complex M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q * C          C * Q
!> TRANS = 'C':      Q**H * C       C * Q**H
!>
!> where Q is a complex unitary matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1)**H H(2)**H . . . H(k)**H
!>
!> as returned by ZGERQF. Q is of order M if SIDE = 'L' and of order N
!> if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate transpose, apply Q**H.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension
!>                               (LDA,M) if SIDE = 'L',
!>                               (LDA,N) if SIDE = 'R'
!>          The i-th row must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          ZGERQF in the last k rows of its array argument A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,K).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZGERQF.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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 165 of file zunmrq.f.

167*
168* -- LAPACK computational 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 CHARACTER SIDE, TRANS
174 INTEGER INFO, K, LDA, LDC, LWORK, M, N
175* ..
176* .. Array Arguments ..
177 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 INTEGER NBMAX, LDT, TSIZE
184 parameter( nbmax = 64, ldt = nbmax+1,
185 $ tsize = ldt*nbmax )
186* ..
187* .. Local Scalars ..
188 LOGICAL LEFT, LQUERY, NOTRAN
189 CHARACTER TRANST
190 INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT,
191 $ MI, NB, NBMIN, NI, NQ, NW
192* ..
193* .. External Functions ..
194 LOGICAL LSAME
195 INTEGER ILAENV
196 EXTERNAL lsame, ilaenv
197* ..
198* .. External Subroutines ..
199 EXTERNAL xerbla, zlarfb, zlarft, zunmr2
200* ..
201* .. Intrinsic Functions ..
202 INTRINSIC max, min
203* ..
204* .. Executable Statements ..
205*
206* Test the input arguments
207*
208 info = 0
209 left = lsame( side, 'L' )
210 notran = lsame( trans, 'N' )
211 lquery = ( lwork.EQ.-1 )
212*
213* NQ is the order of Q and NW is the minimum dimension of WORK
214*
215 IF( left ) THEN
216 nq = m
217 nw = max( 1, n )
218 ELSE
219 nq = n
220 nw = max( 1, m )
221 END IF
222 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
223 info = -1
224 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
225 info = -2
226 ELSE IF( m.LT.0 ) THEN
227 info = -3
228 ELSE IF( n.LT.0 ) THEN
229 info = -4
230 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
231 info = -5
232 ELSE IF( lda.LT.max( 1, k ) ) THEN
233 info = -7
234 ELSE IF( ldc.LT.max( 1, m ) ) THEN
235 info = -10
236 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
237 info = -12
238 END IF
239*
240 IF( info.EQ.0 ) THEN
241*
242* Compute the workspace requirements
243*
244 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
245 lwkopt = 1
246 ELSE
247 nb = min( nbmax, ilaenv( 1, 'ZUNMRQ', side // trans, m, n,
248 $ k, -1 ) )
249 lwkopt = nw*nb + tsize
250 END IF
251 work( 1 ) = lwkopt
252 END IF
253*
254 IF( info.NE.0 ) THEN
255 CALL xerbla( 'ZUNMRQ', -info )
256 RETURN
257 ELSE IF( lquery ) THEN
258 RETURN
259 END IF
260*
261* Quick return if possible
262*
263 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
264 RETURN
265 END IF
266*
267 nbmin = 2
268 ldwork = nw
269 IF( nb.GT.1 .AND. nb.LT.k ) THEN
270 IF( lwork.LT.lwkopt ) THEN
271 nb = (lwork-tsize) / ldwork
272 nbmin = max( 2, ilaenv( 2, 'ZUNMRQ', side // trans, m, n, k,
273 $ -1 ) )
274 END IF
275 END IF
276*
277 IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
278*
279* Use unblocked code
280*
281 CALL zunmr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,
282 $ iinfo )
283 ELSE
284*
285* Use blocked code
286*
287 iwt = 1 + nw*nb
288 IF( ( left .AND. .NOT.notran ) .OR.
289 $ ( .NOT.left .AND. notran ) ) THEN
290 i1 = 1
291 i2 = k
292 i3 = nb
293 ELSE
294 i1 = ( ( k-1 ) / nb )*nb + 1
295 i2 = 1
296 i3 = -nb
297 END IF
298*
299 IF( left ) THEN
300 ni = n
301 ELSE
302 mi = m
303 END IF
304*
305 IF( notran ) THEN
306 transt = 'C'
307 ELSE
308 transt = 'N'
309 END IF
310*
311 DO 10 i = i1, i2, i3
312 ib = min( nb, k-i+1 )
313*
314* Form the triangular factor of the block reflector
315* H = H(i+ib-1) . . . H(i+1) H(i)
316*
317 CALL zlarft( 'Backward', 'Rowwise', nq-k+i+ib-1, ib,
318 $ a( i, 1 ), lda, tau( i ), work( iwt ), ldt )
319 IF( left ) THEN
320*
321* H or H**H is applied to C(1:m-k+i+ib-1,1:n)
322*
323 mi = m - k + i + ib - 1
324 ELSE
325*
326* H or H**H is applied to C(1:m,1:n-k+i+ib-1)
327*
328 ni = n - k + i + ib - 1
329 END IF
330*
331* Apply H or H**H
332*
333 CALL zlarfb( side, transt, 'Backward', 'Rowwise', mi, ni,
334 $ ib, a( i, 1 ), lda, work( iwt ), ldt, c, ldc,
335 $ work, ldwork )
336 10 CONTINUE
337 END IF
338 work( 1 ) = lwkopt
339 RETURN
340*
341* End of ZUNMRQ
342*

◆ zunmrz()

subroutine zunmrz ( character side,
character trans,
integer m,
integer n,
integer k,
integer l,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNMRZ

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

Purpose:
!>
!> ZUNMRZ overwrites the general complex M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q * C          C * Q
!> TRANS = 'C':      Q**H * C       C * Q**H
!>
!> where Q is a complex unitary matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1) H(2) . . . H(k)
!>
!> as returned by ZTZRZF. Q is of order M if SIDE = 'L' and of order N
!> if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate transpose, apply Q**H.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of columns of the matrix A containing
!>          the meaningful part of the Householder reflectors.
!>          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension
!>                               (LDA,M) if SIDE = 'L',
!>                               (LDA,N) if SIDE = 'R'
!>          The i-th row must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          ZTZRZF in the last k rows of its array argument A.
!>          A is modified by the routine but restored on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,K).
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZTZRZF.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
Further Details:
!>

Definition at line 185 of file zunmrz.f.

187*
188* -- LAPACK computational routine --
189* -- LAPACK is a software package provided by Univ. of Tennessee, --
190* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
191*
192* .. Scalar Arguments ..
193 CHARACTER SIDE, TRANS
194 INTEGER INFO, K, L, LDA, LDC, LWORK, M, N
195* ..
196* .. Array Arguments ..
197 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
198* ..
199*
200* =====================================================================
201*
202* .. Parameters ..
203 INTEGER NBMAX, LDT, TSIZE
204 parameter( nbmax = 64, ldt = nbmax+1,
205 $ tsize = ldt*nbmax )
206* ..
207* .. Local Scalars ..
208 LOGICAL LEFT, LQUERY, NOTRAN
209 CHARACTER TRANST
210 INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JA, JC,
211 $ LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW
212* ..
213* .. External Functions ..
214 LOGICAL LSAME
215 INTEGER ILAENV
216 EXTERNAL lsame, ilaenv
217* ..
218* .. External Subroutines ..
219 EXTERNAL xerbla, zlarzb, zlarzt, zunmr3
220* ..
221* .. Intrinsic Functions ..
222 INTRINSIC max, min
223* ..
224* .. Executable Statements ..
225*
226* Test the input arguments
227*
228 info = 0
229 left = lsame( side, 'L' )
230 notran = lsame( trans, 'N' )
231 lquery = ( lwork.EQ.-1 )
232*
233* NQ is the order of Q and NW is the minimum dimension of WORK
234*
235 IF( left ) THEN
236 nq = m
237 nw = max( 1, n )
238 ELSE
239 nq = n
240 nw = max( 1, m )
241 END IF
242 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
243 info = -1
244 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
245 info = -2
246 ELSE IF( m.LT.0 ) THEN
247 info = -3
248 ELSE IF( n.LT.0 ) THEN
249 info = -4
250 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
251 info = -5
252 ELSE IF( l.LT.0 .OR. ( left .AND. ( l.GT.m ) ) .OR.
253 $ ( .NOT.left .AND. ( l.GT.n ) ) ) THEN
254 info = -6
255 ELSE IF( lda.LT.max( 1, k ) ) THEN
256 info = -8
257 ELSE IF( ldc.LT.max( 1, m ) ) THEN
258 info = -11
259 ELSE IF( lwork.LT.max( 1, nw ) .AND. .NOT.lquery ) THEN
260 info = -13
261 END IF
262*
263 IF( info.EQ.0 ) THEN
264*
265* Compute the workspace requirements
266*
267 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
268 lwkopt = 1
269 ELSE
270 nb = min( nbmax, ilaenv( 1, 'ZUNMRQ', side // trans, m, n,
271 $ k, -1 ) )
272 lwkopt = nw*nb + tsize
273 END IF
274 work( 1 ) = lwkopt
275 END IF
276*
277 IF( info.NE.0 ) THEN
278 CALL xerbla( 'ZUNMRZ', -info )
279 RETURN
280 ELSE IF( lquery ) THEN
281 RETURN
282 END IF
283*
284* Quick return if possible
285*
286 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
287 RETURN
288 END IF
289*
290* Determine the block size. NB may be at most NBMAX, where NBMAX
291* is used to define the local array T.
292*
293 nb = min( nbmax, ilaenv( 1, 'ZUNMRQ', side // trans, m, n, k,
294 $ -1 ) )
295 nbmin = 2
296 ldwork = nw
297 IF( nb.GT.1 .AND. nb.LT.k ) THEN
298 IF( lwork.LT.lwkopt ) THEN
299 nb = (lwork-tsize) / ldwork
300 nbmin = max( 2, ilaenv( 2, 'ZUNMRQ', side // trans, m, n, k,
301 $ -1 ) )
302 END IF
303 END IF
304*
305 IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
306*
307* Use unblocked code
308*
309 CALL zunmr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,
310 $ work, iinfo )
311 ELSE
312*
313* Use blocked code
314*
315 iwt = 1 + nw*nb
316 IF( ( left .AND. .NOT.notran ) .OR.
317 $ ( .NOT.left .AND. notran ) ) THEN
318 i1 = 1
319 i2 = k
320 i3 = nb
321 ELSE
322 i1 = ( ( k-1 ) / nb )*nb + 1
323 i2 = 1
324 i3 = -nb
325 END IF
326*
327 IF( left ) THEN
328 ni = n
329 jc = 1
330 ja = m - l + 1
331 ELSE
332 mi = m
333 ic = 1
334 ja = n - l + 1
335 END IF
336*
337 IF( notran ) THEN
338 transt = 'C'
339 ELSE
340 transt = 'N'
341 END IF
342*
343 DO 10 i = i1, i2, i3
344 ib = min( nb, k-i+1 )
345*
346* Form the triangular factor of the block reflector
347* H = H(i+ib-1) . . . H(i+1) H(i)
348*
349 CALL zlarzt( 'Backward', 'Rowwise', l, ib, a( i, ja ), lda,
350 $ tau( i ), work( iwt ), ldt )
351*
352 IF( left ) THEN
353*
354* H or H**H is applied to C(i:m,1:n)
355*
356 mi = m - i + 1
357 ic = i
358 ELSE
359*
360* H or H**H is applied to C(1:m,i:n)
361*
362 ni = n - i + 1
363 jc = i
364 END IF
365*
366* Apply H or H**H
367*
368 CALL zlarzb( side, transt, 'Backward', 'Rowwise', mi, ni,
369 $ ib, l, a( i, ja ), lda, work( iwt ), ldt,
370 $ c( ic, jc ), ldc, work, ldwork )
371 10 CONTINUE
372*
373 END IF
374*
375 work( 1 ) = lwkopt
376*
377 RETURN
378*
379* End of ZUNMRZ
380*
zunmr3
subroutine zunmr3(side, trans, m, n, k, l, a, lda, tau, c, ldc, work, info)
ZUNMR3 multiplies a general matrix by the unitary matrix from a RZ factorization determined by ctzrzf...
Definition zunmr3.f:178

◆ zunmtr()

subroutine zunmtr ( character side,
character uplo,
character trans,
integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNMTR

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

Purpose:
!>
!> ZUNMTR overwrites the general complex M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q * C          C * Q
!> TRANS = 'C':      Q**H * C       C * Q**H
!>
!> where Q is a complex unitary matrix of order nq, with nq = m if
!> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!> nq-1 elementary reflectors, as returned by ZHETRD:
!>
!> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
!>
!> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U': Upper triangle of A contains elementary reflectors
!>                 from ZHETRD;
!>          = 'L': Lower triangle of A contains elementary reflectors
!>                 from ZHETRD.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate transpose, apply Q**H.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension
!>                               (LDA,M) if SIDE = 'L'
!>                               (LDA,N) if SIDE = 'R'
!>          The vectors which define the elementary reflectors, as
!>          returned by ZHETRD.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension
!>                               (M-1) if SIDE = 'L'
!>                               (N-1) if SIDE = 'R'
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZHETRD.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!>          LWORK >=M*NB if SIDE = 'R', where NB is the optimal
!>          blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]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 169 of file zunmtr.f.

171*
172* -- LAPACK computational routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 CHARACTER SIDE, TRANS, UPLO
178 INTEGER INFO, LDA, LDC, LWORK, M, N
179* ..
180* .. Array Arguments ..
181 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
182* ..
183*
184* =====================================================================
185*
186* .. Local Scalars ..
187 LOGICAL LEFT, LQUERY, UPPER
188 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
189* ..
190* .. External Functions ..
191 LOGICAL LSAME
192 INTEGER ILAENV
193 EXTERNAL lsame, ilaenv
194* ..
195* .. External Subroutines ..
196 EXTERNAL xerbla, zunmql, zunmqr
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC max
200* ..
201* .. Executable Statements ..
202*
203* Test the input arguments
204*
205 info = 0
206 left = lsame( side, 'L' )
207 upper = lsame( uplo, 'U' )
208 lquery = ( lwork.EQ.-1 )
209*
210* NQ is the order of Q and NW is the minimum dimension of WORK
211*
212 IF( left ) THEN
213 nq = m
214 nw = max( 1, n )
215 ELSE
216 nq = n
217 nw = max( 1, m )
218 END IF
219 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
220 info = -1
221 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
222 info = -2
223 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) )
224 $ THEN
225 info = -3
226 ELSE IF( m.LT.0 ) THEN
227 info = -4
228 ELSE IF( n.LT.0 ) THEN
229 info = -5
230 ELSE IF( lda.LT.max( 1, nq ) ) THEN
231 info = -7
232 ELSE IF( ldc.LT.max( 1, m ) ) THEN
233 info = -10
234 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
235 info = -12
236 END IF
237*
238 IF( info.EQ.0 ) THEN
239 IF( upper ) THEN
240 IF( left ) THEN
241 nb = ilaenv( 1, 'ZUNMQL', side // trans, m-1, n, m-1,
242 $ -1 )
243 ELSE
244 nb = ilaenv( 1, 'ZUNMQL', side // trans, m, n-1, n-1,
245 $ -1 )
246 END IF
247 ELSE
248 IF( left ) THEN
249 nb = ilaenv( 1, 'ZUNMQR', side // trans, m-1, n, m-1,
250 $ -1 )
251 ELSE
252 nb = ilaenv( 1, 'ZUNMQR', side // trans, m, n-1, n-1,
253 $ -1 )
254 END IF
255 END IF
256 lwkopt = nw*nb
257 work( 1 ) = lwkopt
258 END IF
259*
260 IF( info.NE.0 ) THEN
261 CALL xerbla( 'ZUNMTR', -info )
262 RETURN
263 ELSE IF( lquery ) THEN
264 RETURN
265 END IF
266*
267* Quick return if possible
268*
269 IF( m.EQ.0 .OR. n.EQ.0 .OR. nq.EQ.1 ) THEN
270 work( 1 ) = 1
271 RETURN
272 END IF
273*
274 IF( left ) THEN
275 mi = m - 1
276 ni = n
277 ELSE
278 mi = m
279 ni = n - 1
280 END IF
281*
282 IF( upper ) THEN
283*
284* Q was determined by a call to ZHETRD with UPLO = 'U'
285*
286 CALL zunmql( side, trans, mi, ni, nq-1, a( 1, 2 ), lda, tau, c,
287 $ ldc, work, lwork, iinfo )
288 ELSE
289*
290* Q was determined by a call to ZHETRD with UPLO = 'L'
291*
292 IF( left ) THEN
293 i1 = 2
294 i2 = 1
295 ELSE
296 i1 = 1
297 i2 = 2
298 END IF
299 CALL zunmqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,
300 $ c( i1, i2 ), ldc, work, lwork, iinfo )
301 END IF
302 work( 1 ) = lwkopt
303 RETURN
304*
305* End of ZUNMTR
306*
zunmql
subroutine zunmql(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMQL
Definition zunmql.f:167

◆ zupgtr()

subroutine zupgtr ( character uplo,
integer n,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) tau,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( * ) work,
integer info )

ZUPGTR

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

Purpose:
!>
!> ZUPGTR generates a complex unitary matrix Q which is defined as the
!> product of n-1 elementary reflectors H(i) of order n, as returned by
!> ZHPTRD using packed storage:
!>
!> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
!>
!> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U': Upper triangular packed storage used in previous
!>                 call to ZHPTRD;
!>          = 'L': Lower triangular packed storage used in previous
!>                 call to ZHPTRD.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix Q. N >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The vectors which define the elementary reflectors, as
!>          returned by ZHPTRD.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZHPTRD.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          The N-by-N unitary matrix Q.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N-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 113 of file zupgtr.f.

114*
115* -- LAPACK computational routine --
116* -- LAPACK is a software package provided by Univ. of Tennessee, --
117* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
118*
119* .. Scalar Arguments ..
120 CHARACTER UPLO
121 INTEGER INFO, LDQ, N
122* ..
123* .. Array Arguments ..
124 COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 COMPLEX*16 CZERO, CONE
131 parameter( czero = ( 0.0d+0, 0.0d+0 ),
132 $ cone = ( 1.0d+0, 0.0d+0 ) )
133* ..
134* .. Local Scalars ..
135 LOGICAL UPPER
136 INTEGER I, IINFO, IJ, J
137* ..
138* .. External Functions ..
139 LOGICAL LSAME
140 EXTERNAL lsame
141* ..
142* .. External Subroutines ..
143 EXTERNAL xerbla, zung2l, zung2r
144* ..
145* .. Intrinsic Functions ..
146 INTRINSIC max
147* ..
148* .. Executable Statements ..
149*
150* Test the input arguments
151*
152 info = 0
153 upper = lsame( uplo, 'U' )
154 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
155 info = -1
156 ELSE IF( n.LT.0 ) THEN
157 info = -2
158 ELSE IF( ldq.LT.max( 1, n ) ) THEN
159 info = -6
160 END IF
161 IF( info.NE.0 ) THEN
162 CALL xerbla( 'ZUPGTR', -info )
163 RETURN
164 END IF
165*
166* Quick return if possible
167*
168 IF( n.EQ.0 )
169 $ RETURN
170*
171 IF( upper ) THEN
172*
173* Q was determined by a call to ZHPTRD with UPLO = 'U'
174*
175* Unpack the vectors which define the elementary reflectors and
176* set the last row and column of Q equal to those of the unit
177* matrix
178*
179 ij = 2
180 DO 20 j = 1, n - 1
181 DO 10 i = 1, j - 1
182 q( i, j ) = ap( ij )
183 ij = ij + 1
184 10 CONTINUE
185 ij = ij + 2
186 q( n, j ) = czero
187 20 CONTINUE
188 DO 30 i = 1, n - 1
189 q( i, n ) = czero
190 30 CONTINUE
191 q( n, n ) = cone
192*
193* Generate Q(1:n-1,1:n-1)
194*
195 CALL zung2l( n-1, n-1, n-1, q, ldq, tau, work, iinfo )
196*
197 ELSE
198*
199* Q was determined by a call to ZHPTRD with UPLO = 'L'.
200*
201* Unpack the vectors which define the elementary reflectors and
202* set the first row and column of Q equal to those of the unit
203* matrix
204*
205 q( 1, 1 ) = cone
206 DO 40 i = 2, n
207 q( i, 1 ) = czero
208 40 CONTINUE
209 ij = 3
210 DO 60 j = 2, n
211 q( 1, j ) = czero
212 DO 50 i = j + 1, n
213 q( i, j ) = ap( ij )
214 ij = ij + 1
215 50 CONTINUE
216 ij = ij + 2
217 60 CONTINUE
218 IF( n.GT.1 ) THEN
219*
220* Generate Q(2:n,2:n)
221*
222 CALL zung2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,
223 $ iinfo )
224 END IF
225 END IF
226 RETURN
227*
228* End of ZUPGTR
229*

◆ zupmtr()

subroutine zupmtr ( character side,
character uplo,
character trans,
integer m,
integer n,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer info )

ZUPMTR

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

Purpose:
!>
!> ZUPMTR overwrites the general complex M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q * C          C * Q
!> TRANS = 'C':      Q**H * C       C * Q**H
!>
!> where Q is a complex unitary matrix of order nq, with nq = m if
!> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!> nq-1 elementary reflectors, as returned by ZHPTRD using packed
!> storage:
!>
!> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
!>
!> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U': Upper triangular packed storage used in previous
!>                 call to ZHPTRD;
!>          = 'L': Lower triangular packed storage used in previous
!>                 call to ZHPTRD.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate transpose, apply Q**H.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension
!>                               (M*(M+1)/2) if SIDE = 'L'
!>                               (N*(N+1)/2) if SIDE = 'R'
!>          The vectors which define the elementary reflectors, as
!>          returned by ZHPTRD.  AP is modified by the routine but
!>          restored on exit.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (M-1) if SIDE = 'L'
!>                                     or (N-1) if SIDE = 'R'
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by ZHPTRD.
!>
[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 Q*C or Q**H*C or C*Q**H or C*Q.
!>
[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'
!>                                   (M) if SIDE = 'R'
!>
[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 148 of file zupmtr.f.

150*
151* -- LAPACK computational routine --
152* -- LAPACK is a software package provided by Univ. of Tennessee, --
153* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
154*
155* .. Scalar Arguments ..
156 CHARACTER SIDE, TRANS, UPLO
157 INTEGER INFO, LDC, M, N
158* ..
159* .. Array Arguments ..
160 COMPLEX*16 AP( * ), C( LDC, * ), TAU( * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 COMPLEX*16 ONE
167 parameter( one = ( 1.0d+0, 0.0d+0 ) )
168* ..
169* .. Local Scalars ..
170 LOGICAL FORWRD, LEFT, NOTRAN, UPPER
171 INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ
172 COMPLEX*16 AII, TAUI
173* ..
174* .. External Functions ..
175 LOGICAL LSAME
176 EXTERNAL lsame
177* ..
178* .. External Subroutines ..
179 EXTERNAL xerbla, zlarf
180* ..
181* .. Intrinsic Functions ..
182 INTRINSIC dconjg, max
183* ..
184* .. Executable Statements ..
185*
186* Test the input arguments
187*
188 info = 0
189 left = lsame( side, 'L' )
190 notran = lsame( trans, 'N' )
191 upper = lsame( uplo, 'U' )
192*
193* NQ is the order of Q
194*
195 IF( left ) THEN
196 nq = m
197 ELSE
198 nq = n
199 END IF
200 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
201 info = -1
202 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
203 info = -2
204 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'C' ) ) THEN
205 info = -3
206 ELSE IF( m.LT.0 ) THEN
207 info = -4
208 ELSE IF( n.LT.0 ) THEN
209 info = -5
210 ELSE IF( ldc.LT.max( 1, m ) ) THEN
211 info = -9
212 END IF
213 IF( info.NE.0 ) THEN
214 CALL xerbla( 'ZUPMTR', -info )
215 RETURN
216 END IF
217*
218* Quick return if possible
219*
220 IF( m.EQ.0 .OR. n.EQ.0 )
221 $ RETURN
222*
223 IF( upper ) THEN
224*
225* Q was determined by a call to ZHPTRD with UPLO = 'U'
226*
227 forwrd = ( left .AND. notran ) .OR.
228 $ ( .NOT.left .AND. .NOT.notran )
229*
230 IF( forwrd ) THEN
231 i1 = 1
232 i2 = nq - 1
233 i3 = 1
234 ii = 2
235 ELSE
236 i1 = nq - 1
237 i2 = 1
238 i3 = -1
239 ii = nq*( nq+1 ) / 2 - 1
240 END IF
241*
242 IF( left ) THEN
243 ni = n
244 ELSE
245 mi = m
246 END IF
247*
248 DO 10 i = i1, i2, i3
249 IF( left ) THEN
250*
251* H(i) or H(i)**H is applied to C(1:i,1:n)
252*
253 mi = i
254 ELSE
255*
256* H(i) or H(i)**H is applied to C(1:m,1:i)
257*
258 ni = i
259 END IF
260*
261* Apply H(i) or H(i)**H
262*
263 IF( notran ) THEN
264 taui = tau( i )
265 ELSE
266 taui = dconjg( tau( i ) )
267 END IF
268 aii = ap( ii )
269 ap( ii ) = one
270 CALL zlarf( side, mi, ni, ap( ii-i+1 ), 1, taui, c, ldc,
271 $ work )
272 ap( ii ) = aii
273*
274 IF( forwrd ) THEN
275 ii = ii + i + 2
276 ELSE
277 ii = ii - i - 1
278 END IF
279 10 CONTINUE
280 ELSE
281*
282* Q was determined by a call to ZHPTRD with UPLO = 'L'.
283*
284 forwrd = ( left .AND. .NOT.notran ) .OR.
285 $ ( .NOT.left .AND. notran )
286*
287 IF( forwrd ) THEN
288 i1 = 1
289 i2 = nq - 1
290 i3 = 1
291 ii = 2
292 ELSE
293 i1 = nq - 1
294 i2 = 1
295 i3 = -1
296 ii = nq*( nq+1 ) / 2 - 1
297 END IF
298*
299 IF( left ) THEN
300 ni = n
301 jc = 1
302 ELSE
303 mi = m
304 ic = 1
305 END IF
306*
307 DO 20 i = i1, i2, i3
308 aii = ap( ii )
309 ap( ii ) = one
310 IF( left ) THEN
311*
312* H(i) or H(i)**H is applied to C(i+1:m,1:n)
313*
314 mi = m - i
315 ic = i + 1
316 ELSE
317*
318* H(i) or H(i)**H is applied to C(1:m,i+1:n)
319*
320 ni = n - i
321 jc = i + 1
322 END IF
323*
324* Apply H(i) or H(i)**H
325*
326 IF( notran ) THEN
327 taui = tau( i )
328 ELSE
329 taui = dconjg( tau( i ) )
330 END IF
331 CALL zlarf( side, mi, ni, ap( ii ), 1, taui, c( ic, jc ),
332 $ ldc, work )
333 ap( ii ) = aii
334*
335 IF( forwrd ) THEN
336 ii = ii + nq - i + 1
337 ELSE
338 ii = ii - nq + i - 2
339 END IF
340 20 CONTINUE
341 END IF
342 RETURN
343*
344* End of ZUPMTR
345*