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

Functions

subroutine cbbcsd (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)
 CBBCSD
subroutine cbdsqr (uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, rwork, info)
 CBDSQR
subroutine cgghd3 (compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, work, lwork, info)
 CGGHD3
subroutine cgghrd (compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, info)
 CGGHRD
subroutine cggqrf (n, m, p, a, lda, taua, b, ldb, taub, work, lwork, info)
 CGGQRF
subroutine cggrqf (m, p, n, a, lda, taua, b, ldb, taub, work, lwork, info)
 CGGRQF
subroutine cggsvp3 (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)
 CGGSVP3
subroutine cgsvj0 (jobv, m, n, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
 CGSVJ0 pre-processor for the routine cgesvj.
subroutine cgsvj1 (jobv, m, n, n1, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
 CGSVJ1 pre-processor for the routine cgesvj, applies Jacobi rotations targeting only particular pivots.
subroutine chbgst (vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x, ldx, work, rwork, info)
 CHBGST
subroutine chbtrd (vect, uplo, n, kd, ab, ldab, d, e, q, ldq, work, info)
 CHBTRD
subroutine chetrd_hb2st (stage1, vect, uplo, n, kd, ab, ldab, d, e, hous, lhous, work, lwork, info)
 CHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric tridiagonal form T
subroutine chfrk (transr, uplo, trans, n, k, alpha, a, lda, beta, c)
 CHFRK performs a Hermitian rank-k operation for matrix in RFP format.
subroutine chpcon (uplo, n, ap, ipiv, anorm, rcond, work, info)
 CHPCON
subroutine chpgst (itype, uplo, n, ap, bp, info)
 CHPGST
subroutine chprfs (uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 CHPRFS
subroutine chptrd (uplo, n, ap, d, e, tau, info)
 CHPTRD
subroutine chptrf (uplo, n, ap, ipiv, info)
 CHPTRF
subroutine chptri (uplo, n, ap, ipiv, work, info)
 CHPTRI
subroutine chptrs (uplo, n, nrhs, ap, ipiv, b, ldb, info)
 CHPTRS
subroutine chsein (side, eigsrc, initv, select, n, h, ldh, w, vl, ldvl, vr, ldvr, mm, m, work, rwork, ifaill, ifailr, info)
 CHSEIN
subroutine chseqr (job, compz, n, ilo, ihi, h, ldh, w, z, ldz, work, lwork, info)
 CHSEQR
subroutine cla_lin_berr (n, nz, nrhs, res, ayb, berr)
 CLA_LIN_BERR computes a component-wise relative backward error.
subroutine cla_wwaddw (n, x, y, w)
 CLA_WWADDW adds a vector into a doubled-single vector.
subroutine claed0 (qsiz, n, d, e, q, ldq, qstore, ldqs, rwork, iwork, info)
 CLAED0 used by CSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method.
subroutine claed7 (n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, ldq, rho, indxq, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, rwork, iwork, info)
 CLAED7 used by CSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense.
subroutine claed8 (k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda, q2, ldq2, w, indxp, indx, indxq, perm, givptr, givcol, givnum, info)
 CLAED8 used by CSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense.
subroutine clals0 (icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx, perm, givptr, givcol, ldgcol, givnum, ldgnum, poles, difl, difr, z, k, c, s, rwork, info)
 CLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd.
subroutine clalsa (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)
 CLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd.
subroutine clalsd (uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond, rank, work, rwork, iwork, info)
 CLALSD uses the singular value decomposition of A to solve the least squares problem.
real function clanhf (norm, transr, uplo, n, a, work)
 CLANHF 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 clarscl2 (m, n, d, x, ldx)
 CLARSCL2 performs reciprocal diagonal scaling on a vector.
subroutine clarz (side, m, n, l, v, incv, tau, c, ldc, work)
 CLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix.
subroutine clarzb (side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, c, ldc, work, ldwork)
 CLARZB applies a block reflector or its conjugate-transpose to a general matrix.
subroutine clarzt (direct, storev, n, k, v, ldv, tau, t, ldt)
 CLARZT forms the triangular factor T of a block reflector H = I - vtvH.
subroutine clascl2 (m, n, d, x, ldx)
 CLASCL2 performs diagonal scaling on a vector.
subroutine clatrz (m, n, l, a, lda, tau, work)
 CLATRZ factors an upper trapezoidal matrix by means of unitary transformations.
subroutine cpbcon (uplo, n, kd, ab, ldab, anorm, rcond, work, rwork, info)
 CPBCON
subroutine cpbequ (uplo, n, kd, ab, ldab, s, scond, amax, info)
 CPBEQU
subroutine cpbrfs (uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 CPBRFS
subroutine cpbstf (uplo, n, kd, ab, ldab, info)
 CPBSTF
subroutine cpbtf2 (uplo, n, kd, ab, ldab, info)
 CPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (unblocked algorithm).
subroutine cpbtrf (uplo, n, kd, ab, ldab, info)
 CPBTRF
subroutine cpbtrs (uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
 CPBTRS
subroutine cpftrf (transr, uplo, n, a, info)
 CPFTRF
subroutine cpftri (transr, uplo, n, a, info)
 CPFTRI
subroutine cpftrs (transr, uplo, n, nrhs, a, b, ldb, info)
 CPFTRS
subroutine cppcon (uplo, n, ap, anorm, rcond, work, rwork, info)
 CPPCON
subroutine cppequ (uplo, n, ap, s, scond, amax, info)
 CPPEQU
subroutine cpprfs (uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 CPPRFS
subroutine cpptrf (uplo, n, ap, info)
 CPPTRF
subroutine cpptri (uplo, n, ap, info)
 CPPTRI
subroutine cpptrs (uplo, n, nrhs, ap, b, ldb, info)
 CPPTRS
subroutine cpstf2 (uplo, n, a, lda, piv, rank, tol, work, info)
 CPSTF2 computes the Cholesky factorization with complete pivoting of complex Hermitian positive semidefinite matrix.
subroutine cpstrf (uplo, n, a, lda, piv, rank, tol, work, info)
 CPSTRF computes the Cholesky factorization with complete pivoting of complex Hermitian positive semidefinite matrix.
subroutine cspcon (uplo, n, ap, ipiv, anorm, rcond, work, info)
 CSPCON
subroutine csprfs (uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 CSPRFS
subroutine csptrf (uplo, n, ap, ipiv, info)
 CSPTRF
subroutine csptri (uplo, n, ap, ipiv, work, info)
 CSPTRI
subroutine csptrs (uplo, n, nrhs, ap, ipiv, b, ldb, info)
 CSPTRS
subroutine cstedc (compz, n, d, e, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
 CSTEDC
subroutine cstegr (jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
 CSTEGR
subroutine cstein (n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
 CSTEIN
subroutine cstemr (jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
 CSTEMR
subroutine csteqr (compz, n, d, e, z, ldz, work, info)
 CSTEQR
subroutine ctbcon (norm, uplo, diag, n, kd, ab, ldab, rcond, work, rwork, info)
 CTBCON
subroutine ctbrfs (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 CTBRFS
subroutine ctbtrs (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, info)
 CTBTRS
subroutine ctfsm (transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
 CTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
subroutine ctftri (transr, uplo, diag, n, a, info)
 CTFTRI
subroutine ctfttp (transr, uplo, n, arf, ap, info)
 CTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed format (TP).
subroutine ctfttr (transr, uplo, n, arf, a, lda, info)
 CTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full format (TR).
subroutine ctgsen (ijob, wantq, wantz, select, n, a, lda, b, ldb, alpha, beta, q, ldq, z, ldz, m, pl, pr, dif, work, lwork, iwork, liwork, info)
 CTGSEN
subroutine ctgsja (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)
 CTGSJA
subroutine ctgsna (job, howmny, select, n, a, lda, b, ldb, vl, ldvl, vr, ldvr, s, dif, mm, m, work, lwork, iwork, info)
 CTGSNA
subroutine ctpcon (norm, uplo, diag, n, ap, rcond, work, rwork, info)
 CTPCON
subroutine ctpmqrt (side, trans, m, n, k, l, nb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
 CTPMQRT
subroutine ctpqrt (m, n, l, nb, a, lda, b, ldb, t, ldt, work, info)
 CTPQRT
subroutine ctpqrt2 (m, n, l, a, lda, b, ldb, t, ldt, info)
 CTPQRT2 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 ctprfs (uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 CTPRFS
subroutine ctptri (uplo, diag, n, ap, info)
 CTPTRI
subroutine ctptrs (uplo, trans, diag, n, nrhs, ap, b, ldb, info)
 CTPTRS
subroutine ctpttf (transr, uplo, n, ap, arf, info)
 CTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed format (TF).
subroutine ctpttr (uplo, n, ap, a, lda, info)
 CTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (TR).
subroutine ctrcon (norm, uplo, diag, n, a, lda, rcond, work, rwork, info)
 CTRCON
subroutine ctrevc (side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, rwork, info)
 CTREVC
subroutine ctrevc3 (side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, lwork, rwork, lrwork, info)
 CTREVC3
subroutine ctrexc (compq, n, t, ldt, q, ldq, ifst, ilst, info)
 CTREXC
subroutine ctrrfs (uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 CTRRFS
subroutine ctrsen (job, compq, select, n, t, ldt, q, ldq, w, m, s, sep, work, lwork, info)
 CTRSEN
subroutine ctrsna (job, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, s, sep, mm, m, work, ldwork, rwork, info)
 CTRSNA
subroutine ctrti2 (uplo, diag, n, a, lda, info)
 CTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
subroutine ctrtri (uplo, diag, n, a, lda, info)
 CTRTRI
subroutine ctrtrs (uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
 CTRTRS
subroutine ctrttf (transr, uplo, n, a, lda, arf, info)
 CTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed format (TF).
subroutine ctrttp (uplo, n, a, lda, ap, info)
 CTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (TP).
subroutine ctzrzf (m, n, a, lda, tau, work, lwork, info)
 CTZRZF
subroutine cunbdb (trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, lwork, info)
 CUNBDB
subroutine cunbdb1 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 CUNBDB1
subroutine cunbdb2 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 CUNBDB2
subroutine cunbdb3 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 CUNBDB3
subroutine cunbdb4 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, phantom, work, lwork, info)
 CUNBDB4
subroutine cunbdb5 (m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
 CUNBDB5
subroutine cunbdb6 (m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
 CUNBDB6
recursive subroutine cuncsd (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)
 CUNCSD
subroutine cuncsd2by1 (jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, rwork, lrwork, iwork, info)
 CUNCSD2BY1
subroutine cung2l (m, n, k, a, lda, tau, work, info)
 CUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm).
subroutine cung2r (m, n, k, a, lda, tau, work, info)
 CUNG2R
subroutine cunghr (n, ilo, ihi, a, lda, tau, work, lwork, info)
 CUNGHR
subroutine cungl2 (m, n, k, a, lda, tau, work, info)
 CUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (unblocked algorithm).
subroutine cunglq (m, n, k, a, lda, tau, work, lwork, info)
 CUNGLQ
subroutine cungql (m, n, k, a, lda, tau, work, lwork, info)
 CUNGQL
subroutine cungqr (m, n, k, a, lda, tau, work, lwork, info)
 CUNGQR
subroutine cungr2 (m, n, k, a, lda, tau, work, info)
 CUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cgerqf (unblocked algorithm).
subroutine cungrq (m, n, k, a, lda, tau, work, lwork, info)
 CUNGRQ
subroutine cungtr (uplo, n, a, lda, tau, work, lwork, info)
 CUNGTR
subroutine cungtsqr (m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
 CUNGTSQR
subroutine cungtsqr_row (m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
 CUNGTSQR_ROW
subroutine cunhr_col (m, n, nb, a, lda, t, ldt, d, info)
 CUNHR_COL
subroutine cunm22 (side, trans, m, n, n1, n2, q, ldq, c, ldc, work, lwork, info)
 CUNM22 multiplies a general matrix by a banded unitary matrix.
subroutine cunm2l (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 CUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf (unblocked algorithm).
subroutine cunm2r (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 CUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm).
subroutine cunmbr (vect, side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 CUNMBR
subroutine cunmhr (side, trans, m, n, ilo, ihi, a, lda, tau, c, ldc, work, lwork, info)
 CUNMHR
subroutine cunml2 (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 CUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf (unblocked algorithm).
subroutine cunmlq (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 CUNMLQ
subroutine cunmql (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 CUNMQL
subroutine cunmqr (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 CUNMQR
subroutine cunmr2 (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 CUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf (unblocked algorithm).
subroutine cunmr3 (side, trans, m, n, k, l, a, lda, tau, c, ldc, work, info)
 CUNMR3 multiplies a general matrix by the unitary matrix from a RZ factorization determined by ctzrzf (unblocked algorithm).
subroutine cunmrq (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 CUNMRQ
subroutine cunmrz (side, trans, m, n, k, l, a, lda, tau, c, ldc, work, lwork, info)
 CUNMRZ
subroutine cunmtr (side, uplo, trans, m, n, a, lda, tau, c, ldc, work, lwork, info)
 CUNMTR
subroutine cupgtr (uplo, n, ap, tau, q, ldq, work, info)
 CUPGTR
subroutine cupmtr (side, uplo, trans, m, n, ap, tau, c, ldc, work, info)
 CUPMTR
subroutine cggsvp (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)
 CGGSVP
subroutine clatzm (side, m, n, v, incv, tau, c1, c2, ldc, work)
 CLATZM
subroutine ctzrqf (m, n, a, lda, tau, info)
 CTZRQF
subroutine dorm22 (side, trans, m, n, n1, n2, q, ldq, c, ldc, work, lwork, info)
 DORM22 multiplies a general matrix by a banded orthogonal matrix.
subroutine sorm22 (side, trans, m, n, n1, n2, q, ldq, c, ldc, work, lwork, info)
 SORM22 multiplies a general matrix by a banded orthogonal matrix.
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.

Detailed Description

This is the group of complex other Computational routines

Function Documentation

◆ cbbcsd()

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

CBBCSD

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

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

◆ cbdsqr()

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

CBDSQR

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

Purpose:
!>
!> CBDSQR 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 CGEBRD, 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 REAL array, dimension (N)
!>          On entry, the n diagonal elements of the bidiagonal matrix B.
!>          On exit, if INFO=0, the singular values of B in decreasing
!>          order.
!>
[in,out]E
!>          E is REAL array, dimension (N-1)
!>          On entry, the N-1 offdiagonal elements of the bidiagonal
!>          matrix B.
!>          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
!>          will contain the diagonal and superdiagonal elements of a
!>          bidiagonal matrix orthogonally equivalent to the one given
!>          as input.
!>
[in,out]VT
!>          VT is COMPLEX 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 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 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 REAL array, dimension (4*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  If INFO = -i, the i-th argument had an illegal value
!>          > 0:  the algorithm did not converge; D and E contain the
!>                elements of a bidiagonal matrix which is orthogonally
!>                similar to the input matrix B;  if INFO = i, i
!>                elements of E have not converged to zero.
!>
Internal Parameters:
!>  TOLMUL  REAL, default = max(10,min(100,EPS**(-1/8)))
!>          TOLMUL controls the convergence criterion of the QR loop.
!>          If it is positive, TOLMUL*EPS is the desired relative
!>             precision in the computed singular values.
!>          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
!>             desired absolute accuracy in the computed singular
!>             values (corresponds to relative accuracy
!>             abs(TOLMUL*EPS) in the largest singular value.
!>          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
!>             between 10 (for fast convergence) and .1/EPS
!>             (for there to be some accuracy in the results).
!>          Default is to lose at either one eighth or 2 of the
!>             available decimal digits in each computed singular value
!>             (whichever is smaller).
!>
!>  MAXITR  INTEGER, default = 6
!>          MAXITR controls the maximum number of passes of the
!>          algorithm through its inner loop. The algorithms stops
!>          (and so fails to converge) if the number of passes
!>          through the inner loop exceeds MAXITR*N**2.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 220 of file cbdsqr.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 REAL D( * ), E( * ), RWORK( * )
233 COMPLEX C( LDC, * ), U( LDU, * ), VT( LDVT, * )
234* ..
235*
236* =====================================================================
237*
238* .. Parameters ..
239 REAL ZERO
240 parameter( zero = 0.0e0 )
241 REAL ONE
242 parameter( one = 1.0e0 )
243 REAL NEGONE
244 parameter( negone = -1.0e0 )
245 REAL HNDRTH
246 parameter( hndrth = 0.01e0 )
247 REAL TEN
248 parameter( ten = 10.0e0 )
249 REAL HNDRD
250 parameter( hndrd = 100.0e0 )
251 REAL MEIGTH
252 parameter( meigth = -0.125e0 )
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 REAL 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 REAL SLAMCH
268 EXTERNAL lsame, slamch
269* ..
270* .. External Subroutines ..
271 EXTERNAL clasr, csrot, csscal, cswap, slartg, slas2,
272 $ slasq1, slasv2, xerbla
273* ..
274* .. Intrinsic Functions ..
275 INTRINSIC abs, max, min, real, 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( 'CBDSQR', -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 slasq1( 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 = slamch( 'Epsilon' )
334 unfl = slamch( '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 slartg( 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 clasr( 'R', 'V', 'F', nru, n, rwork( 1 ), rwork( n ),
353 $ u, ldu )
354 IF( ncc.GT.0 )
355 $ CALL clasr( '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( real( 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 slasv2( 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 csrot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt,
474 $ cosr, sinr )
475 IF( nru.GT.0 )
476 $ CALL csrot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl )
477 IF( ncc.GT.0 )
478 $ CALL csrot( 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 slas2( d( m-1 ), e( m-1 ), d( m ), shift, r )
578 ELSE
579 sll = abs( d( m ) )
580 CALL slas2( 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 slartg( d( i )*cs, e( i ), cs, sn, r )
607 IF( i.GT.ll )
608 $ e( i-1 ) = oldsn*r
609 CALL slartg( 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 clasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),
623 $ rwork( n ), vt( ll, 1 ), ldvt )
624 IF( nru.GT.0 )
625 $ CALL clasr( '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 clasr( '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 slartg( d( i )*cs, e( i-1 ), cs, sn, r )
645 IF( i.LT.m )
646 $ e( i ) = oldsn*r
647 CALL slartg( 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 clasr( '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 clasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),
664 $ rwork( n ), u( 1, ll ), ldu )
665 IF( ncc.GT.0 )
666 $ CALL clasr( '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 slartg( 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 slartg( 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 clasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),
713 $ rwork( n ), vt( ll, 1 ), ldvt )
714 IF( nru.GT.0 )
715 $ CALL clasr( '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 clasr( '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 slartg( 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 slartg( 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 clasr( '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 clasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),
769 $ rwork( n ), u( 1, ll ), ldu )
770 IF( ncc.GT.0 )
771 $ CALL clasr( '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 csscal( 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 cswap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),
817 $ ldvt )
818 IF( nru.GT.0 )
819 $ CALL cswap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 )
820 IF( ncc.GT.0 )
821 $ CALL cswap( 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 CBDSQR
838*
slasv2
subroutine slasv2(f, g, h, ssmin, ssmax, snr, csr, snl, csl)
SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
Definition slasv2.f:138
slartg
subroutine slartg(f, g, c, s, r)
SLARTG generates a plane rotation with real cosine and real sine.
Definition slartg.f90:113
slasq1
subroutine slasq1(n, d, e, work, info)
SLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr.
Definition slasq1.f:108
csscal
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
csrot
subroutine csrot(n, cx, incx, cy, incy, c, s)
CSROT
Definition csrot.f:98

◆ cgghd3()

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

CGGHD3

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

Purpose:
!>
!>
!> CGGHD3 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 CGGHD3 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 CGGBAL; 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 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 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 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 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 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 229 of file cgghd3.f.

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

◆ cgghrd()

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

CGGHRD

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

Purpose:
!>
!> CGGHRD 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 CGGHRD 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 CGGBAL; 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 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 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 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 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 cgghrd.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 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
215 $ Z( LDZ, * )
216* ..
217*
218* =====================================================================
219*
220* .. Parameters ..
221 COMPLEX CONE, CZERO
222 parameter( cone = ( 1.0e+0, 0.0e+0 ),
223 $ czero = ( 0.0e+0, 0.0e+0 ) )
224* ..
225* .. Local Scalars ..
226 LOGICAL ILQ, ILZ
227 INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
228 REAL C
229 COMPLEX CTEMP, S
230* ..
231* .. External Functions ..
232 LOGICAL LSAME
233 EXTERNAL lsame
234* ..
235* .. External Subroutines ..
236 EXTERNAL clartg, claset, crot, xerbla
237* ..
238* .. Intrinsic Functions ..
239 INTRINSIC conjg, 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( 'CGGHRD', -info )
297 RETURN
298 END IF
299*
300* Initialize Q and Z if desired.
301*
302 IF( icompq.EQ.3 )
303 $ CALL claset( 'Full', n, n, czero, cone, q, ldq )
304 IF( icompz.EQ.3 )
305 $ CALL claset( '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 clartg( ctemp, a( jrow, jcol ), c, s,
330 $ a( jrow-1, jcol ) )
331 a( jrow, jcol ) = czero
332 CALL crot( n-jcol, a( jrow-1, jcol+1 ), lda,
333 $ a( jrow, jcol+1 ), lda, c, s )
334 CALL crot( n+2-jrow, b( jrow-1, jrow-1 ), ldb,
335 $ b( jrow, jrow-1 ), ldb, c, s )
336 IF( ilq )
337 $ CALL crot( n, q( 1, jrow-1 ), 1, q( 1, jrow ), 1, c,
338 $ conjg( s ) )
339*
340* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
341*
342 ctemp = b( jrow, jrow )
343 CALL clartg( ctemp, b( jrow, jrow-1 ), c, s,
344 $ b( jrow, jrow ) )
345 b( jrow, jrow-1 ) = czero
346 CALL crot( ihi, a( 1, jrow ), 1, a( 1, jrow-1 ), 1, c, s )
347 CALL crot( jrow-1, b( 1, jrow ), 1, b( 1, jrow-1 ), 1, c,
348 $ s )
349 IF( ilz )
350 $ CALL crot( 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 CGGHRD
357*

◆ cggqrf()

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

CGGQRF

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

Purpose:
!>
!> CGGQRF 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' 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 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 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 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 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 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 CUNMQR.
!>
!>          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 CUNGQR.
!>  To use Q to update another matrix, use LAPACK subroutine CUNMQR.
!>
!>  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 CUNGRQ.
!>  To use Z to update another matrix, use LAPACK subroutine CUNMRQ.
!>

Definition at line 213 of file cggqrf.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 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 cgeqrf, cgerqf, cunmqr, xerbla
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, 'CGEQRF', ' ', n, m, -1, -1 )
250 nb2 = ilaenv( 1, 'CGERQF', ' ', n, p, -1, -1 )
251 nb3 = ilaenv( 1, 'CUNMQR', ' ', 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( 'CGGQRF', -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 cgeqrf( n, m, a, lda, taua, work, lwork, info )
279 lopt = real( work( 1 ) )
280*
281* Update B := Q**H*B.
282*
283 CALL cunmqr( '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 cgerqf( n, p, b, ldb, taub, work, lwork, info )
290 work( 1 ) = max( lopt, int( work( 1 ) ) )
291*
292 RETURN
293*
294* End of CGGQRF
295*
cgeqrf
subroutine cgeqrf(m, n, a, lda, tau, work, lwork, info)
CGEQRF
Definition cgeqrf.f:146
cgerqf
subroutine cgerqf(m, n, a, lda, tau, work, lwork, info)
CGERQF
Definition cgerqf.f:139
cunmqr
subroutine cunmqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
CUNMQR
Definition cunmqr.f:168

◆ cggrqf()

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

CGGRQF

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

Purpose:
!>
!> CGGRQF 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 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 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 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 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 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 CUNMRQ.
!>
!>          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 CUNGRQ.
!>  To use Q to update another matrix, use LAPACK subroutine CUNMRQ.
!>
!>  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 CUNGQR.
!>  To use Z to update another matrix, use LAPACK subroutine CUNMQR.
!>

Definition at line 212 of file cggrqf.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 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 cgeqrf, cgerqf, cunmrq, xerbla
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, 'CGERQF', ' ', m, n, -1, -1 )
249 nb2 = ilaenv( 1, 'CGEQRF', ' ', p, n, -1, -1 )
250 nb3 = ilaenv( 1, 'CUNMRQ', ' ', 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( 'CGGRQF', -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 cgerqf( m, n, a, lda, taua, work, lwork, info )
278 lopt = real( work( 1 ) )
279*
280* Update B := B*Q**H
281*
282 CALL cunmrq( '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 cgeqrf( p, n, b, ldb, taub, work, lwork, info )
290 work( 1 ) = max( lopt, int( work( 1 ) ) )
291*
292 RETURN
293*
294* End of CGGRQF
295*
cunmrq
subroutine cunmrq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
CUNMRQ
Definition cunmrq.f:168

◆ cggsvp()

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

CGGSVP

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine CGGSVP3.
!>
!> CGGSVP 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
!> CGGSVD.
!>
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 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 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 REAL
!>
[in]TOLB
!>          TOLB is REAL
!>
!>          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)*MACHEPS,
!>             TOLB = MAX(P,N)*norm(B)*MACHEPS.
!>          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 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 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 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 REAL array, dimension (2*N)
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (N)
!>
[out]WORK
!>          WORK is COMPLEX 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 CGEQPF 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 259 of file cggsvp.f.

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

◆ cggsvp3()

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

CGGSVP3

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

Purpose:
!>
!> CGGSVP3 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
!> CGGSVD3.
!>
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 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 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 REAL
!>
[in]TOLB
!>          TOLB is REAL
!>
!>          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)*MACHEPS,
!>             TOLB = MAX(P,N)*norm(B)*MACHEPS.
!>          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 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 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 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 REAL array, dimension (2*N)
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (N)
!>
[out]WORK
!>          WORK is COMPLEX 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 CGEQP3 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.
!>
!>  CGGSVP3 replaces the deprecated subroutine CGGSVP.
!>
!>

Definition at line 275 of file cggsvp3.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 REAL TOLA, TOLB
290* ..
291* .. Array Arguments ..
292 INTEGER IWORK( * )
293 REAL RWORK( * )
294 COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
295 $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
296* ..
297*
298* =====================================================================
299*
300* .. Parameters ..
301 COMPLEX CZERO, CONE
302 parameter( czero = ( 0.0e+0, 0.0e+0 ),
303 $ cone = ( 1.0e+0, 0.0e+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 cgeqp3, cgeqr2, cgerq2, clacpy, clapmt,
315 $ claset, cung2r, cunm2r, cunmr2, xerbla
316* ..
317* .. Intrinsic Functions ..
318 INTRINSIC abs, aimag, max, min, real
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 cgeqp3( 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 cgeqp3( 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 ) = cmplx( lwkopt )
377 END IF
378*
379 IF( info.NE.0 ) THEN
380 CALL xerbla( 'CGGSVP3', -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 cgeqp3( p, n, b, ldb, iwork, tau, work, lwork, rwork, info )
394*
395* Update A := A*P
396*
397 CALL clapmt( 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 claset( 'Full', p, p, czero, czero, v, ldv )
412 IF( p.GT.1 )
413 $ CALL clacpy( 'Lower', p-1, n, b( 2, 1 ), ldb, v( 2, 1 ),
414 $ ldv )
415 CALL cung2r( 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 claset( '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 claset( 'Full', n, n, czero, cone, q, ldq )
433 CALL clapmt( 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 cgerq2( l, n, b, ldb, tau, work, info )
441*
442* Update A := A*Z**H
443*
444 CALL cunmr2( '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 cunmr2( '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 claset( '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 cgeqp3( 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 cunm2r( '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 claset( 'Full', m, m, czero, czero, u, ldu )
497 IF( m.GT.1 )
498 $ CALL clacpy( 'Lower', m-1, n-l, a( 2, 1 ), lda, u( 2, 1 ),
499 $ ldu )
500 CALL cung2r( 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 clapmt( 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 claset( '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 cgerq2( 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 cunmr2( '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 claset( '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 cgeqr2( 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 cunm2r( '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 ) = cmplx( lwkopt )
572 RETURN
573*
574* End of CGGSVP3
575*
cgeqp3
subroutine cgeqp3(m, n, a, lda, jpvt, tau, work, lwork, rwork, info)
CGEQP3
Definition cgeqp3.f:159

◆ cgsvj0()

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

CGSVJ0 pre-processor for the routine cgesvj.

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

Purpose:
!>
!> CGSVJ0 is called from CGESVJ as a pre-processor and that is its main
!> purpose. It applies Jacobi rotations in the same way as CGESVJ 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 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 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 REAL 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 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 REAL
!>          EPS = SLAMCH('Epsilon')
!>
[in]SFMIN
!>          SFMIN is REAL
!>          SFMIN = SLAMCH('Safe Minimum')
!>
[in]TOL
!>          TOL is REAL
!>          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 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:
CGSVJ0 is used just to enable CGESVJ 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 cgsvj0.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 REAL EPS, SFMIN, TOL
227 CHARACTER*1 JOBV
228* ..
229* .. Array Arguments ..
230 COMPLEX A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK )
231 REAL SVA( N )
232* ..
233*
234* =====================================================================
235*
236* .. Local Parameters ..
237 REAL ZERO, HALF, ONE
238 parameter( zero = 0.0e0, half = 0.5e0, one = 1.0e0)
239 COMPLEX CZERO, CONE
240 parameter( czero = (0.0e0, 0.0e0), cone = (1.0e0, 0.0e0) )
241* ..
242* .. Local Scalars ..
243 COMPLEX AAPQ, OMPQ
244 REAL 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, real, min, sign, sqrt
256* ..
257* .. External Functions ..
258 REAL SCNRM2
259 COMPLEX CDOTC
260 INTEGER ISAMAX
261 LOGICAL LSAME
262 EXTERNAL isamax, lsame, cdotc, scnrm2
263* ..
264* ..
265* .. External Subroutines ..
266* ..
267* from BLAS
268 EXTERNAL ccopy, crot, cswap, caxpy
269* from LAPACK
270 EXTERNAL clascl, classq, 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( 'CGSVJ0', -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 CGESVJ is used as a computational routine in the preconditioned
333* Jacobi SVD algorithm CGEJSV. 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 = isamax( n-p+1, sva( p ), 1 ) + p - 1
393 IF( p.NE.q ) THEN
394 CALL cswap( m, a( 1, p ), 1, a( 1, q ), 1 )
395 IF( rsvec )CALL cswap( 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=CDOTC(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, SCNRM2 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 SCNRM2 is available, the IF-THEN-ELSE-END IF
417* below should be replaced with "AAPP = SCNRM2( M, A(1,p), 1 )".
418*
419 IF( ( sva( p ).LT.rootbig ) .AND.
420 $ ( sva( p ).GT.rootsfmin ) ) THEN
421 sva( p ) = scnrm2( m, a( 1, p ), 1 )
422 ELSE
423 temp1 = zero
424 aapp = one
425 CALL classq( 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 = ( cdotc( m, a( 1, p ), 1,
448 $ a( 1, q ), 1 ) / aaqq ) / aapp
449 ELSE
450 CALL ccopy( m, a( 1, p ), 1,
451 $ work, 1 )
452 CALL clascl( 'G', 0, 0, aapp, one,
453 $ m, 1, work, lda, ierr )
454 aapq = cdotc( 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 = ( cdotc( m, a( 1, p ), 1,
461 $ a( 1, q ), 1 ) / aapp ) / aaqq
462 ELSE
463 CALL ccopy( m, a( 1, q ), 1,
464 $ work, 1 )
465 CALL clascl( 'G', 0, 0, aaqq,
466 $ one, m, 1,
467 $ work, lda, ierr )
468 aapq = cdotc( 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 crot( m, a(1,p), 1, a(1,q), 1,
503 $ cs, conjg(ompq)*t )
504 IF ( rsvec ) THEN
505 CALL crot( 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 crot( m, a(1,p), 1, a(1,q), 1,
532 $ cs, conjg(ompq)*sn )
533 IF ( rsvec ) THEN
534 CALL crot( 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 ccopy( m, a( 1, p ), 1,
543 $ work, 1 )
544 CALL clascl( 'G', 0, 0, aapp, one, m,
545 $ 1, work, lda,
546 $ ierr )
547 CALL clascl( 'G', 0, 0, aaqq, one, m,
548 $ 1, a( 1, q ), lda, ierr )
549 CALL caxpy( m, -aapq, work, 1,
550 $ a( 1, q ), 1 )
551 CALL clascl( '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 ) = scnrm2( m, a( 1, q ), 1 )
567 ELSE
568 t = zero
569 aaqq = one
570 CALL classq( 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 = scnrm2( m, a( 1, p ), 1 )
579 ELSE
580 t = zero
581 aapp = one
582 CALL classq( 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 = ( cdotc( m, a( 1, p ), 1,
664 $ a( 1, q ), 1 ) / aaqq ) / aapp
665 ELSE
666 CALL ccopy( m, a( 1, p ), 1,
667 $ work, 1 )
668 CALL clascl( 'G', 0, 0, aapp,
669 $ one, m, 1,
670 $ work, lda, ierr )
671 aapq = cdotc( 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 = ( cdotc( m, a( 1, p ), 1,
682 $ a( 1, q ), 1 ) / max(aaqq,aapp) )
683 $ / min(aaqq,aapp)
684 ELSE
685 CALL ccopy( m, a( 1, q ), 1,
686 $ work, 1 )
687 CALL clascl( 'G', 0, 0, aaqq,
688 $ one, m, 1,
689 $ work, lda, ierr )
690 aapq = cdotc( 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 crot( m, a(1,p), 1, a(1,q), 1,
719 $ cs, conjg(ompq)*t )
720 IF( rsvec ) THEN
721 CALL crot( 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 crot( m, a(1,p), 1, a(1,q), 1,
746 $ cs, conjg(ompq)*sn )
747 IF( rsvec ) THEN
748 CALL crot( 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 ccopy( m, a( 1, p ), 1,
758 $ work, 1 )
759 CALL clascl( 'G', 0, 0, aapp, one,
760 $ m, 1, work,lda,
761 $ ierr )
762 CALL clascl( 'G', 0, 0, aaqq, one,
763 $ m, 1, a( 1, q ), lda,
764 $ ierr )
765 CALL caxpy( m, -aapq, work,
766 $ 1, a( 1, q ), 1 )
767 CALL clascl( '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 ccopy( m, a( 1, q ), 1,
775 $ work, 1 )
776 CALL clascl( 'G', 0, 0, aaqq, one,
777 $ m, 1, work,lda,
778 $ ierr )
779 CALL clascl( 'G', 0, 0, aapp, one,
780 $ m, 1, a( 1, p ), lda,
781 $ ierr )
782 CALL caxpy( m, -conjg(aapq),
783 $ work, 1, a( 1, p ), 1 )
784 CALL clascl( '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 ) = scnrm2( m, a( 1, q ), 1)
801 ELSE
802 t = zero
803 aaqq = one
804 CALL classq( 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 = scnrm2( m, a( 1, p ), 1 )
813 ELSE
814 t = zero
815 aapp = one
816 CALL classq( 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 ) = scnrm2( m, a( 1, n ), 1 )
879 ELSE
880 t = zero
881 aapp = one
882 CALL classq( 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( real( n ) )*
892 $ tol ) .AND. ( real( 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 = isamax( 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 cswap( m, a( 1, p ), 1, a( 1, q ), 1 )
924 IF( rsvec )CALL cswap( mvl, v( 1, p ), 1, v( 1, q ), 1 )
925 END IF
926 5991 CONTINUE
927*
928 RETURN
929* ..
930* .. END OF CGSVJ0
931* ..
classq
subroutine classq(n, x, incx, scl, sumsq)
CLASSQ updates a sum of squares represented in scaled form.
Definition classq.f90:137
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
clascl
subroutine clascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition clascl.f:143
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
Definition caxpy.f:88
cdotc
complex function cdotc(n, cx, incx, cy, incy)
CDOTC
Definition cdotc.f:83
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
scnrm2
real(wp) function scnrm2(n, x, incx)
SCNRM2
Definition scnrm2.f90:90

◆ cgsvj1()

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

CGSVJ1 pre-processor for the routine cgesvj, applies Jacobi rotations targeting only particular pivots.

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

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

◆ chbgst()

subroutine chbgst ( character vect,
character uplo,
integer n,
integer ka,
integer kb,
complex, dimension( ldab, * ) ab,
integer ldab,
complex, dimension( ldbb, * ) bb,
integer ldbb,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CHBGST

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

Purpose:
!>
!> CHBGST 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 CPBSTF, 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 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 array, dimension (LDBB,N)
!>          The banded factor S from the split Cholesky factorization of
!>          B, as returned by CPBSTF, 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 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 array, dimension (N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 163 of file chbgst.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 REAL RWORK( * )
176 COMPLEX AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
177 $ X( LDX, * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 COMPLEX CZERO, CONE
184 REAL ONE
185 parameter( czero = ( 0.0e+0, 0.0e+0 ),
186 $ cone = ( 1.0e+0, 0.0e+0 ), one = 1.0e+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 REAL BII
193 COMPLEX RA, RA1, T
194* ..
195* .. External Functions ..
196 LOGICAL LSAME
197 EXTERNAL lsame
198* ..
199* .. External Subroutines ..
200 EXTERNAL cgerc, cgeru, clacgv, clar2v, clargv, clartg,
201 $ clartv, claset, crot, csscal, xerbla
202* ..
203* .. Intrinsic Functions ..
204 INTRINSIC conjg, max, min, real
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( 'CHBGST', -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 claset( '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 CPBSTF. 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 = real( bb( kb1, i ) )
346 ab( ka1, i ) = ( real( 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 $ conjg( ab( k-i+ka1, i ) ) -
358 $ conjg( bb( k-i+kb1, i ) )*
359 $ ab( j-i+ka1, i ) +
360 $ real( ab( ka1, i ) )*
361 $ bb( j-i+kb1, i )*
362 $ conjg( 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 $ conjg( 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 csscal( n-m, one / bii, x( m+1, i ), 1 )
382 IF( kbt.GT.0 )
383 $ CALL cgerc( 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 clartg( 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 $ conjg( 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 clargv( 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 clartv( 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 clar2v( 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 clacgv( 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 clartv( 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 crot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,
482 $ rwork( j-m ), conjg( 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 clartv( 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 clargv( 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 clartv( 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 clar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),
557 $ ab( ka, j2+1 ), inca, rwork( j2 ),
558 $ work( j2 ), ka1 )
559*
560 CALL clacgv( 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 clartv( 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 crot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,
579 $ rwork( j ), conjg( 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 clartv( 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 = real( bb( 1, i ) )
614 ab( 1, i ) = ( real( 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 )*conjg( ab( i-k+1,
625 $ k ) ) - conjg( bb( i-k+1, k ) )*
626 $ ab( i-j+1, j ) + real( ab( 1, i ) )*
627 $ bb( i-j+1, j )*conjg( 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 $ conjg( 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 csscal( n-m, one / bii, x( m+1, i ), 1 )
648 IF( kbt.GT.0 )
649 $ CALL cgeru( 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 clartg( 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 $ conjg( work( i-k+ka-m ) )*ab( ka1, i-k )
682 ab( ka1, i-k ) = work( i-k+ka-m )*t +
683 $ rwork( i-k+ka-m )*ab( ka1, i-k )
684 ra1 = ra
685 END IF
686 END IF
687 j2 = i - k - 1 + max( 1, k-i0+2 )*ka1
688 nr = ( n-j2+ka ) / ka1
689 j1 = j2 + ( nr-1 )*ka1
690 IF( update ) THEN
691 j2t = max( j2, i+2*ka-k+1 )
692 ELSE
693 j2t = j2
694 END IF
695 nrt = ( n-j2t+ka ) / ka1
696 DO 320 j = j2t, j1, ka1
697*
698* create nonzero element a(j+1,j-ka) outside the band
699* and store it in WORK(j-m)
700*
701 work( j-m ) = work( j-m )*ab( ka1, j-ka+1 )
702 ab( ka1, j-ka+1 ) = rwork( j-m )*ab( ka1, j-ka+1 )
703 320 CONTINUE
704*
705* generate rotations in 1st set to annihilate elements which
706* have been created outside the band
707*
708 IF( nrt.GT.0 )
709 $ CALL clargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),
710 $ ka1, rwork( j2t-m ), ka1 )
711 IF( nr.GT.0 ) THEN
712*
713* apply rotations in 1st set from the left
714*
715 DO 330 l = 1, ka - 1
716 CALL clartv( nr, ab( l+1, j2-l ), inca,
717 $ ab( l+2, j2-l ), inca, rwork( j2-m ),
718 $ work( j2-m ), ka1 )
719 330 CONTINUE
720*
721* apply rotations in 1st set from both sides to diagonal
722* blocks
723*
724 CALL clar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),
725 $ inca, rwork( j2-m ), work( j2-m ), ka1 )
726*
727 CALL clacgv( nr, work( j2-m ), ka1 )
728 END IF
729*
730* start applying rotations in 1st set from the right
731*
732 DO 340 l = ka - 1, kb - k + 1, -1
733 nrt = ( n-j2+l ) / ka1
734 IF( nrt.GT.0 )
735 $ CALL clartv( nrt, ab( ka1-l+1, j2 ), inca,
736 $ ab( ka1-l, j2+1 ), inca, rwork( j2-m ),
737 $ work( j2-m ), ka1 )
738 340 CONTINUE
739*
740 IF( wantx ) THEN
741*
742* post-multiply X by product of rotations in 1st set
743*
744 DO 350 j = j2, j1, ka1
745 CALL crot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,
746 $ rwork( j-m ), work( j-m ) )
747 350 CONTINUE
748 END IF
749 360 CONTINUE
750*
751 IF( update ) THEN
752 IF( i2.LE.n .AND. kbt.GT.0 ) THEN
753*
754* create nonzero element a(i-kbt+ka+1,i-kbt) outside the
755* band and store it in WORK(i-kbt)
756*
757 work( i-kbt ) = -bb( kbt+1, i-kbt )*ra1
758 END IF
759 END IF
760*
761 DO 400 k = kb, 1, -1
762 IF( update ) THEN
763 j2 = i - k - 1 + max( 2, k-i0+1 )*ka1
764 ELSE
765 j2 = i - k - 1 + max( 1, k-i0+1 )*ka1
766 END IF
767*
768* finish applying rotations in 2nd set from the right
769*
770 DO 370 l = kb - k, 1, -1
771 nrt = ( n-j2+ka+l ) / ka1
772 IF( nrt.GT.0 )
773 $ CALL clartv( nrt, ab( ka1-l+1, j2-ka ), inca,
774 $ ab( ka1-l, j2-ka+1 ), inca,
775 $ rwork( j2-ka ), work( j2-ka ), ka1 )
776 370 CONTINUE
777 nr = ( n-j2+ka ) / ka1
778 j1 = j2 + ( nr-1 )*ka1
779 DO 380 j = j1, j2, -ka1
780 work( j ) = work( j-ka )
781 rwork( j ) = rwork( j-ka )
782 380 CONTINUE
783 DO 390 j = j2, j1, ka1
784*
785* create nonzero element a(j+1,j-ka) outside the band
786* and store it in WORK(j)
787*
788 work( j ) = work( j )*ab( ka1, j-ka+1 )
789 ab( ka1, j-ka+1 ) = rwork( j )*ab( ka1, j-ka+1 )
790 390 CONTINUE
791 IF( update ) THEN
792 IF( i-k.LT.n-ka .AND. k.LE.kbt )
793 $ work( i-k+ka ) = work( i-k )
794 END IF
795 400 CONTINUE
796*
797 DO 440 k = kb, 1, -1
798 j2 = i - k - 1 + max( 1, k-i0+1 )*ka1
799 nr = ( n-j2+ka ) / ka1
800 j1 = j2 + ( nr-1 )*ka1
801 IF( nr.GT.0 ) THEN
802*
803* generate rotations in 2nd set to annihilate elements
804* which have been created outside the band
805*
806 CALL clargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,
807 $ rwork( j2 ), ka1 )
808*
809* apply rotations in 2nd set from the left
810*
811 DO 410 l = 1, ka - 1
812 CALL clartv( nr, ab( l+1, j2-l ), inca,
813 $ ab( l+2, j2-l ), inca, rwork( j2 ),
814 $ work( j2 ), ka1 )
815 410 CONTINUE
816*
817* apply rotations in 2nd set from both sides to diagonal
818* blocks
819*
820 CALL clar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),
821 $ inca, rwork( j2 ), work( j2 ), ka1 )
822*
823 CALL clacgv( nr, work( j2 ), ka1 )
824 END IF
825*
826* start applying rotations in 2nd set from the right
827*
828 DO 420 l = ka - 1, kb - k + 1, -1
829 nrt = ( n-j2+l ) / ka1
830 IF( nrt.GT.0 )
831 $ CALL clartv( nrt, ab( ka1-l+1, j2 ), inca,
832 $ ab( ka1-l, j2+1 ), inca, rwork( j2 ),
833 $ work( j2 ), ka1 )
834 420 CONTINUE
835*
836 IF( wantx ) THEN
837*
838* post-multiply X by product of rotations in 2nd set
839*
840 DO 430 j = j2, j1, ka1
841 CALL crot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,
842 $ rwork( j ), work( j ) )
843 430 CONTINUE
844 END IF
845 440 CONTINUE
846*
847 DO 460 k = 1, kb - 1
848 j2 = i - k - 1 + max( 1, k-i0+2 )*ka1
849*
850* finish applying rotations in 1st set from the right
851*
852 DO 450 l = kb - k, 1, -1
853 nrt = ( n-j2+l ) / ka1
854 IF( nrt.GT.0 )
855 $ CALL clartv( nrt, ab( ka1-l+1, j2 ), inca,
856 $ ab( ka1-l, j2+1 ), inca, rwork( j2-m ),
857 $ work( j2-m ), ka1 )
858 450 CONTINUE
859 460 CONTINUE
860*
861 IF( kb.GT.1 ) THEN
862 DO 470 j = n - 1, j2 + ka, -1
863 rwork( j-m ) = rwork( j-ka-m )
864 work( j-m ) = work( j-ka-m )
865 470 CONTINUE
866 END IF
867*
868 END IF
869*
870 GO TO 10
871*
872 480 CONTINUE
873*
874* **************************** Phase 2 *****************************
875*
876* The logical structure of this phase is:
877*
878* UPDATE = .TRUE.
879* DO I = 1, M
880* use S(i) to update A and create a new bulge
881* apply rotations to push all bulges KA positions upward
882* END DO
883* UPDATE = .FALSE.
884* DO I = M - KA - 1, 2, -1
885* apply rotations to push all bulges KA positions upward
886* END DO
887*
888* To avoid duplicating code, the two loops are merged.
889*
890 update = .true.
891 i = 0
892 490 CONTINUE
893 IF( update ) THEN
894 i = i + 1
895 kbt = min( kb, m-i )
896 i0 = i + 1
897 i1 = max( 1, i-ka )
898 i2 = i + kbt - ka1
899 IF( i.GT.m ) THEN
900 update = .false.
901 i = i - 1
902 i0 = m + 1
903 IF( ka.EQ.0 )
904 $ RETURN
905 GO TO 490
906 END IF
907 ELSE
908 i = i - ka
909 IF( i.LT.2 )
910 $ RETURN
911 END IF
912*
913 IF( i.LT.m-kbt ) THEN
914 nx = m
915 ELSE
916 nx = n
917 END IF
918*
919 IF( upper ) THEN
920*
921* Transform A, working with the upper triangle
922*
923 IF( update ) THEN
924*
925* Form inv(S(i))**H * A * inv(S(i))
926*
927 bii = real( bb( kb1, i ) )
928 ab( ka1, i ) = ( real( ab( ka1, i ) ) / bii ) / bii
929 DO 500 j = i1, i - 1
930 ab( j-i+ka1, i ) = ab( j-i+ka1, i ) / bii
931 500 CONTINUE
932 DO 510 j = i + 1, min( n, i+ka )
933 ab( i-j+ka1, j ) = ab( i-j+ka1, j ) / bii
934 510 CONTINUE
935 DO 540 k = i + 1, i + kbt
936 DO 520 j = k, i + kbt
937 ab( k-j+ka1, j ) = ab( k-j+ka1, j ) -
938 $ bb( i-j+kb1, j )*
939 $ conjg( ab( i-k+ka1, k ) ) -
940 $ conjg( bb( i-k+kb1, k ) )*
941 $ ab( i-j+ka1, j ) +
942 $ real( ab( ka1, i ) )*
943 $ bb( i-j+kb1, j )*
944 $ conjg( bb( i-k+kb1, k ) )
945 520 CONTINUE
946 DO 530 j = i + kbt + 1, min( n, i+ka )
947 ab( k-j+ka1, j ) = ab( k-j+ka1, j ) -
948 $ conjg( bb( i-k+kb1, k ) )*
949 $ ab( i-j+ka1, j )
950 530 CONTINUE
951 540 CONTINUE
952 DO 560 j = i1, i
953 DO 550 k = i + 1, min( j+ka, i+kbt )
954 ab( j-k+ka1, k ) = ab( j-k+ka1, k ) -
955 $ bb( i-k+kb1, k )*ab( j-i+ka1, i )
956 550 CONTINUE
957 560 CONTINUE
958*
959 IF( wantx ) THEN
960*
961* post-multiply X by inv(S(i))
962*
963 CALL csscal( nx, one / bii, x( 1, i ), 1 )
964 IF( kbt.GT.0 )
965 $ CALL cgeru( nx, kbt, -cone, x( 1, i ), 1,
966 $ bb( kb, i+1 ), ldbb-1, x( 1, i+1 ), ldx )
967 END IF
968*
969* store a(i1,i) in RA1 for use in next loop over K
970*
971 ra1 = ab( i1-i+ka1, i )
972 END IF
973*
974* Generate and apply vectors of rotations to chase all the
975* existing bulges KA positions up toward the top of the band
976*
977 DO 610 k = 1, kb - 1
978 IF( update ) THEN
979*
980* Determine the rotations which would annihilate the bulge
981* which has in theory just been created
982*
983 IF( i+k-ka1.GT.0 .AND. i+k.LT.m ) THEN
984*
985* generate rotation to annihilate a(i+k-ka-1,i)
986*
987 CALL clartg( ab( k+1, i ), ra1, rwork( i+k-ka ),
988 $ work( i+k-ka ), ra )
989*
990* create nonzero element a(i+k-ka-1,i+k) outside the
991* band and store it in WORK(m-kb+i+k)
992*
993 t = -bb( kb1-k, i+k )*ra1
994 work( m-kb+i+k ) = rwork( i+k-ka )*t -
995 $ conjg( work( i+k-ka ) )*
996 $ ab( 1, i+k )
997 ab( 1, i+k ) = work( i+k-ka )*t +
998 $ rwork( i+k-ka )*ab( 1, i+k )
999 ra1 = ra
1000 END IF
1001 END IF
1002 j2 = i + k + 1 - max( 1, k+i0-m+1 )*ka1
1003 nr = ( j2+ka-1 ) / ka1
1004 j1 = j2 - ( nr-1 )*ka1
1005 IF( update ) THEN
1006 j2t = min( j2, i-2*ka+k-1 )
1007 ELSE
1008 j2t = j2
1009 END IF
1010 nrt = ( j2t+ka-1 ) / ka1
1011 DO 570 j = j1, j2t, ka1
1012*
1013* create nonzero element a(j-1,j+ka) outside the band
1014* and store it in WORK(j)
1015*
1016 work( j ) = work( j )*ab( 1, j+ka-1 )
1017 ab( 1, j+ka-1 ) = rwork( j )*ab( 1, j+ka-1 )
1018 570 CONTINUE
1019*
1020* generate rotations in 1st set to annihilate elements which
1021* have been created outside the band
1022*
1023 IF( nrt.GT.0 )
1024 $ CALL clargv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,
1025 $ rwork( j1 ), ka1 )
1026 IF( nr.GT.0 ) THEN
1027*
1028* apply rotations in 1st set from the left
1029*
1030 DO 580 l = 1, ka - 1
1031 CALL clartv( nr, ab( ka1-l, j1+l ), inca,
1032 $ ab( ka-l, j1+l ), inca, rwork( j1 ),
1033 $ work( j1 ), ka1 )
1034 580 CONTINUE
1035*
1036* apply rotations in 1st set from both sides to diagonal
1037* blocks
1038*
1039 CALL clar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),
1040 $ ab( ka, j1 ), inca, rwork( j1 ), work( j1 ),
1041 $ ka1 )
1042*
1043 CALL clacgv( nr, work( j1 ), ka1 )
1044 END IF
1045*
1046* start applying rotations in 1st set from the right
1047*
1048 DO 590 l = ka - 1, kb - k + 1, -1
1049 nrt = ( j2+l-1 ) / ka1
1050 j1t = j2 - ( nrt-1 )*ka1
1051 IF( nrt.GT.0 )
1052 $ CALL clartv( nrt, ab( l, j1t ), inca,
1053 $ ab( l+1, j1t-1 ), inca, rwork( j1t ),
1054 $ work( j1t ), ka1 )
1055 590 CONTINUE
1056*
1057 IF( wantx ) THEN
1058*
1059* post-multiply X by product of rotations in 1st set
1060*
1061 DO 600 j = j1, j2, ka1
1062 CALL crot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,
1063 $ rwork( j ), work( j ) )
1064 600 CONTINUE
1065 END IF
1066 610 CONTINUE
1067*
1068 IF( update ) THEN
1069 IF( i2.GT.0 .AND. kbt.GT.0 ) THEN
1070*
1071* create nonzero element a(i+kbt-ka-1,i+kbt) outside the
1072* band and store it in WORK(m-kb+i+kbt)
1073*
1074 work( m-kb+i+kbt ) = -bb( kb1-kbt, i+kbt )*ra1
1075 END IF
1076 END IF
1077*
1078 DO 650 k = kb, 1, -1
1079 IF( update ) THEN
1080 j2 = i + k + 1 - max( 2, k+i0-m )*ka1
1081 ELSE
1082 j2 = i + k + 1 - max( 1, k+i0-m )*ka1
1083 END IF
1084*
1085* finish applying rotations in 2nd set from the right
1086*
1087 DO 620 l = kb - k, 1, -1
1088 nrt = ( j2+ka+l-1 ) / ka1
1089 j1t = j2 - ( nrt-1 )*ka1
1090 IF( nrt.GT.0 )
1091 $ CALL clartv( nrt, ab( l, j1t+ka ), inca,
1092 $ ab( l+1, j1t+ka-1 ), inca,
1093 $ rwork( m-kb+j1t+ka ),
1094 $ work( m-kb+j1t+ka ), ka1 )
1095 620 CONTINUE
1096 nr = ( j2+ka-1 ) / ka1
1097 j1 = j2 - ( nr-1 )*ka1
1098 DO 630 j = j1, j2, ka1
1099 work( m-kb+j ) = work( m-kb+j+ka )
1100 rwork( m-kb+j ) = rwork( m-kb+j+ka )
1101 630 CONTINUE
1102 DO 640 j = j1, j2, ka1
1103*
1104* create nonzero element a(j-1,j+ka) outside the band
1105* and store it in WORK(m-kb+j)
1106*
1107 work( m-kb+j ) = work( m-kb+j )*ab( 1, j+ka-1 )
1108 ab( 1, j+ka-1 ) = rwork( m-kb+j )*ab( 1, j+ka-1 )
1109 640 CONTINUE
1110 IF( update ) THEN
1111 IF( i+k.GT.ka1 .AND. k.LE.kbt )
1112 $ work( m-kb+i+k-ka ) = work( m-kb+i+k )
1113 END IF
1114 650 CONTINUE
1115*
1116 DO 690 k = kb, 1, -1
1117 j2 = i + k + 1 - max( 1, k+i0-m )*ka1
1118 nr = ( j2+ka-1 ) / ka1
1119 j1 = j2 - ( nr-1 )*ka1
1120 IF( nr.GT.0 ) THEN
1121*
1122* generate rotations in 2nd set to annihilate elements
1123* which have been created outside the band
1124*
1125 CALL clargv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),
1126 $ ka1, rwork( m-kb+j1 ), ka1 )
1127*
1128* apply rotations in 2nd set from the left
1129*
1130 DO 660 l = 1, ka - 1
1131 CALL clartv( nr, ab( ka1-l, j1+l ), inca,
1132 $ ab( ka-l, j1+l ), inca, rwork( m-kb+j1 ),
1133 $ work( m-kb+j1 ), ka1 )
1134 660 CONTINUE
1135*
1136* apply rotations in 2nd set from both sides to diagonal
1137* blocks
1138*
1139 CALL clar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),
1140 $ ab( ka, j1 ), inca, rwork( m-kb+j1 ),
1141 $ work( m-kb+j1 ), ka1 )
1142*
1143 CALL clacgv( nr, work( m-kb+j1 ), ka1 )
1144 END IF
1145*
1146* start applying rotations in 2nd set from the right
1147*
1148 DO 670 l = ka - 1, kb - k + 1, -1
1149 nrt = ( j2+l-1 ) / ka1
1150 j1t = j2 - ( nrt-1 )*ka1
1151 IF( nrt.GT.0 )
1152 $ CALL clartv( nrt, ab( l, j1t ), inca,
1153 $ ab( l+1, j1t-1 ), inca,
1154 $ rwork( m-kb+j1t ), work( m-kb+j1t ),
1155 $ ka1 )
1156 670 CONTINUE
1157*
1158 IF( wantx ) THEN
1159*
1160* post-multiply X by product of rotations in 2nd set
1161*
1162 DO 680 j = j1, j2, ka1
1163 CALL crot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,
1164 $ rwork( m-kb+j ), work( m-kb+j ) )
1165 680 CONTINUE
1166 END IF
1167 690 CONTINUE
1168*
1169 DO 710 k = 1, kb - 1
1170 j2 = i + k + 1 - max( 1, k+i0-m+1 )*ka1
1171*
1172* finish applying rotations in 1st set from the right
1173*
1174 DO 700 l = kb - k, 1, -1
1175 nrt = ( j2+l-1 ) / ka1
1176 j1t = j2 - ( nrt-1 )*ka1
1177 IF( nrt.GT.0 )
1178 $ CALL clartv( nrt, ab( l, j1t ), inca,
1179 $ ab( l+1, j1t-1 ), inca, rwork( j1t ),
1180 $ work( j1t ), ka1 )
1181 700 CONTINUE
1182 710 CONTINUE
1183*
1184 IF( kb.GT.1 ) THEN
1185 DO 720 j = 2, i2 - ka
1186 rwork( j ) = rwork( j+ka )
1187 work( j ) = work( j+ka )
1188 720 CONTINUE
1189 END IF
1190*
1191 ELSE
1192*
1193* Transform A, working with the lower triangle
1194*
1195 IF( update ) THEN
1196*
1197* Form inv(S(i))**H * A * inv(S(i))
1198*
1199 bii = real( bb( 1, i ) )
1200 ab( 1, i ) = ( real( ab( 1, i ) ) / bii ) / bii
1201 DO 730 j = i1, i - 1
1202 ab( i-j+1, j ) = ab( i-j+1, j ) / bii
1203 730 CONTINUE
1204 DO 740 j = i + 1, min( n, i+ka )
1205 ab( j-i+1, i ) = ab( j-i+1, i ) / bii
1206 740 CONTINUE
1207 DO 770 k = i + 1, i + kbt
1208 DO 750 j = k, i + kbt
1209 ab( j-k+1, k ) = ab( j-k+1, k ) -
1210 $ bb( j-i+1, i )*conjg( ab( k-i+1,
1211 $ i ) ) - conjg( bb( k-i+1, i ) )*
1212 $ ab( j-i+1, i ) + real( ab( 1, i ) )*
1213 $ bb( j-i+1, i )*conjg( bb( k-i+1,
1214 $ i ) )
1215 750 CONTINUE
1216 DO 760 j = i + kbt + 1, min( n, i+ka )
1217 ab( j-k+1, k ) = ab( j-k+1, k ) -
1218 $ conjg( bb( k-i+1, i ) )*
1219 $ ab( j-i+1, i )
1220 760 CONTINUE
1221 770 CONTINUE
1222 DO 790 j = i1, i
1223 DO 780 k = i + 1, min( j+ka, i+kbt )
1224 ab( k-j+1, j ) = ab( k-j+1, j ) -
1225 $ bb( k-i+1, i )*ab( i-j+1, j )
1226 780 CONTINUE
1227 790 CONTINUE
1228*
1229 IF( wantx ) THEN
1230*
1231* post-multiply X by inv(S(i))
1232*
1233 CALL csscal( nx, one / bii, x( 1, i ), 1 )
1234 IF( kbt.GT.0 )
1235 $ CALL cgerc( nx, kbt, -cone, x( 1, i ), 1, bb( 2, i ),
1236 $ 1, x( 1, i+1 ), ldx )
1237 END IF
1238*
1239* store a(i,i1) in RA1 for use in next loop over K
1240*
1241 ra1 = ab( i-i1+1, i1 )
1242 END IF
1243*
1244* Generate and apply vectors of rotations to chase all the
1245* existing bulges KA positions up toward the top of the band
1246*
1247 DO 840 k = 1, kb - 1
1248 IF( update ) THEN
1249*
1250* Determine the rotations which would annihilate the bulge
1251* which has in theory just been created
1252*
1253 IF( i+k-ka1.GT.0 .AND. i+k.LT.m ) THEN
1254*
1255* generate rotation to annihilate a(i,i+k-ka-1)
1256*
1257 CALL clartg( ab( ka1-k, i+k-ka ), ra1,
1258 $ rwork( i+k-ka ), work( i+k-ka ), ra )
1259*
1260* create nonzero element a(i+k,i+k-ka-1) outside the
1261* band and store it in WORK(m-kb+i+k)
1262*
1263 t = -bb( k+1, i )*ra1
1264 work( m-kb+i+k ) = rwork( i+k-ka )*t -
1265 $ conjg( work( i+k-ka ) )*
1266 $ ab( ka1, i+k-ka )
1267 ab( ka1, i+k-ka ) = work( i+k-ka )*t +
1268 $ rwork( i+k-ka )*ab( ka1, i+k-ka )
1269 ra1 = ra
1270 END IF
1271 END IF
1272 j2 = i + k + 1 - max( 1, k+i0-m+1 )*ka1
1273 nr = ( j2+ka-1 ) / ka1
1274 j1 = j2 - ( nr-1 )*ka1
1275 IF( update ) THEN
1276 j2t = min( j2, i-2*ka+k-1 )
1277 ELSE
1278 j2t = j2
1279 END IF
1280 nrt = ( j2t+ka-1 ) / ka1
1281 DO 800 j = j1, j2t, ka1
1282*
1283* create nonzero element a(j+ka,j-1) outside the band
1284* and store it in WORK(j)
1285*
1286 work( j ) = work( j )*ab( ka1, j-1 )
1287 ab( ka1, j-1 ) = rwork( j )*ab( ka1, j-1 )
1288 800 CONTINUE
1289*
1290* generate rotations in 1st set to annihilate elements which
1291* have been created outside the band
1292*
1293 IF( nrt.GT.0 )
1294 $ CALL clargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,
1295 $ rwork( j1 ), ka1 )
1296 IF( nr.GT.0 ) THEN
1297*
1298* apply rotations in 1st set from the right
1299*
1300 DO 810 l = 1, ka - 1
1301 CALL clartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),
1302 $ inca, rwork( j1 ), work( j1 ), ka1 )
1303 810 CONTINUE
1304*
1305* apply rotations in 1st set from both sides to diagonal
1306* blocks
1307*
1308 CALL clar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),
1309 $ ab( 2, j1-1 ), inca, rwork( j1 ),
1310 $ work( j1 ), ka1 )
1311*
1312 CALL clacgv( nr, work( j1 ), ka1 )
1313 END IF
1314*
1315* start applying rotations in 1st set from the left
1316*
1317 DO 820 l = ka - 1, kb - k + 1, -1
1318 nrt = ( j2+l-1 ) / ka1
1319 j1t = j2 - ( nrt-1 )*ka1
1320 IF( nrt.GT.0 )
1321 $ CALL clartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,
1322 $ ab( ka1-l, j1t-ka1+l ), inca,
1323 $ rwork( j1t ), work( j1t ), ka1 )
1324 820 CONTINUE
1325*
1326 IF( wantx ) THEN
1327*
1328* post-multiply X by product of rotations in 1st set
1329*
1330 DO 830 j = j1, j2, ka1
1331 CALL crot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,
1332 $ rwork( j ), conjg( work( j ) ) )
1333 830 CONTINUE
1334 END IF
1335 840 CONTINUE
1336*
1337 IF( update ) THEN
1338 IF( i2.GT.0 .AND. kbt.GT.0 ) THEN
1339*
1340* create nonzero element a(i+kbt,i+kbt-ka-1) outside the
1341* band and store it in WORK(m-kb+i+kbt)
1342*
1343 work( m-kb+i+kbt ) = -bb( kbt+1, i )*ra1
1344 END IF
1345 END IF
1346*
1347 DO 880 k = kb, 1, -1
1348 IF( update ) THEN
1349 j2 = i + k + 1 - max( 2, k+i0-m )*ka1
1350 ELSE
1351 j2 = i + k + 1 - max( 1, k+i0-m )*ka1
1352 END IF
1353*
1354* finish applying rotations in 2nd set from the left
1355*
1356 DO 850 l = kb - k, 1, -1
1357 nrt = ( j2+ka+l-1 ) / ka1
1358 j1t = j2 - ( nrt-1 )*ka1
1359 IF( nrt.GT.0 )
1360 $ CALL clartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,
1361 $ ab( ka1-l, j1t+l-1 ), inca,
1362 $ rwork( m-kb+j1t+ka ),
1363 $ work( m-kb+j1t+ka ), ka1 )
1364 850 CONTINUE
1365 nr = ( j2+ka-1 ) / ka1
1366 j1 = j2 - ( nr-1 )*ka1
1367 DO 860 j = j1, j2, ka1
1368 work( m-kb+j ) = work( m-kb+j+ka )
1369 rwork( m-kb+j ) = rwork( m-kb+j+ka )
1370 860 CONTINUE
1371 DO 870 j = j1, j2, ka1
1372*
1373* create nonzero element a(j+ka,j-1) outside the band
1374* and store it in WORK(m-kb+j)
1375*
1376 work( m-kb+j ) = work( m-kb+j )*ab( ka1, j-1 )
1377 ab( ka1, j-1 ) = rwork( m-kb+j )*ab( ka1, j-1 )
1378 870 CONTINUE
1379 IF( update ) THEN
1380 IF( i+k.GT.ka1 .AND. k.LE.kbt )
1381 $ work( m-kb+i+k-ka ) = work( m-kb+i+k )
1382 END IF
1383 880 CONTINUE
1384*
1385 DO 920 k = kb, 1, -1
1386 j2 = i + k + 1 - max( 1, k+i0-m )*ka1
1387 nr = ( j2+ka-1 ) / ka1
1388 j1 = j2 - ( nr-1 )*ka1
1389 IF( nr.GT.0 ) THEN
1390*
1391* generate rotations in 2nd set to annihilate elements
1392* which have been created outside the band
1393*
1394 CALL clargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),
1395 $ ka1, rwork( m-kb+j1 ), ka1 )
1396*
1397* apply rotations in 2nd set from the right
1398*
1399 DO 890 l = 1, ka - 1
1400 CALL clartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),
1401 $ inca, rwork( m-kb+j1 ), work( m-kb+j1 ),
1402 $ ka1 )
1403 890 CONTINUE
1404*
1405* apply rotations in 2nd set from both sides to diagonal
1406* blocks
1407*
1408 CALL clar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),
1409 $ ab( 2, j1-1 ), inca, rwork( m-kb+j1 ),
1410 $ work( m-kb+j1 ), ka1 )
1411*
1412 CALL clacgv( nr, work( m-kb+j1 ), ka1 )
1413 END IF
1414*
1415* start applying rotations in 2nd set from the left
1416*
1417 DO 900 l = ka - 1, kb - k + 1, -1
1418 nrt = ( j2+l-1 ) / ka1
1419 j1t = j2 - ( nrt-1 )*ka1
1420 IF( nrt.GT.0 )
1421 $ CALL clartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,
1422 $ ab( ka1-l, j1t-ka1+l ), inca,
1423 $ rwork( m-kb+j1t ), work( m-kb+j1t ),
1424 $ ka1 )
1425 900 CONTINUE
1426*
1427 IF( wantx ) THEN
1428*
1429* post-multiply X by product of rotations in 2nd set
1430*
1431 DO 910 j = j1, j2, ka1
1432 CALL crot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,
1433 $ rwork( m-kb+j ), conjg( work( m-kb+j ) ) )
1434 910 CONTINUE
1435 END IF
1436 920 CONTINUE
1437*
1438 DO 940 k = 1, kb - 1
1439 j2 = i + k + 1 - max( 1, k+i0-m+1 )*ka1
1440*
1441* finish applying rotations in 1st set from the left
1442*
1443 DO 930 l = kb - k, 1, -1
1444 nrt = ( j2+l-1 ) / ka1
1445 j1t = j2 - ( nrt-1 )*ka1
1446 IF( nrt.GT.0 )
1447 $ CALL clartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,
1448 $ ab( ka1-l, j1t-ka1+l ), inca,
1449 $ rwork( j1t ), work( j1t ), ka1 )
1450 930 CONTINUE
1451 940 CONTINUE
1452*
1453 IF( kb.GT.1 ) THEN
1454 DO 950 j = 2, i2 - ka
1455 rwork( j ) = rwork( j+ka )
1456 work( j ) = work( j+ka )
1457 950 CONTINUE
1458 END IF
1459*
1460 END IF
1461*
1462 GO TO 490
1463*
1464* End of CHBGST
1465*
clar2v
subroutine clar2v(n, x, y, z, incx, c, s, incc)
CLAR2V applies a vector of plane rotations with real cosines and complex sines from both sides to a s...
Definition clar2v.f:111
clacgv
subroutine clacgv(n, x, incx)
CLACGV conjugates a complex vector.
Definition clacgv.f:74
clargv
subroutine clargv(n, x, incx, y, incy, c, incc)
CLARGV generates a vector of plane rotations with real cosines and complex sines.
Definition clargv.f:122
clartv
subroutine clartv(n, x, incx, y, incy, c, s, incc)
CLARTV applies a vector of plane rotations with real cosines and complex sines to the elements of a p...
Definition clartv.f:107
cgerc
subroutine cgerc(m, n, alpha, x, incx, y, incy, a, lda)
CGERC
Definition cgerc.f:130
cgeru
subroutine cgeru(m, n, alpha, x, incx, y, incy, a, lda)
CGERU
Definition cgeru.f:130

◆ chbtrd()

subroutine chbtrd ( character vect,
character uplo,
integer n,
integer kd,
complex, dimension( ldab, * ) ab,
integer ldab,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( ldq, * ) q,
integer ldq,
complex, dimension( * ) work,
integer info )

CHBTRD

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

Purpose:
!>
!> CHBTRD 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 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 REAL array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T.
!>
[out]E
!>          E is REAL 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 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 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 chbtrd.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 REAL D( * ), E( * )
174 COMPLEX AB( LDAB, * ), Q( LDQ, * ), WORK( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 REAL ZERO
181 parameter( zero = 0.0e+0 )
182 COMPLEX CZERO, CONE
183 parameter( czero = ( 0.0e+0, 0.0e+0 ),
184 $ cone = ( 1.0e+0, 0.0e+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 REAL ABST
192 COMPLEX T, TEMP
193* ..
194* .. External Subroutines ..
195 EXTERNAL clacgv, clar2v, clargv, clartg, clartv, claset,
196 $ crot, cscal, xerbla
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, conjg, max, min, real
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( 'CHBTRD', -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 claset( '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 ) = real( 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 clargv( 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* CLARTV or CROT is used
287*
288 IF( nr.GE.2*kd-1 ) THEN
289 DO 10 l = 1, kd - 1
290 CALL clartv( 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 crot( 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 clartg( 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 crot( 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 clar2v( 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 clacgv( nr, work( j1 ), kd1 )
339 IF( 2*kd-1.LT.nr ) THEN
340*
341* Dependent on the the number of diagonals either
342* CLARTV or CROT 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 clartv( 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 crot( 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 crot( 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 crot( nq, q( iqb, j-1 ), 1, q( iqb, j ),
395 $ 1, d( j ), conjg( work( j ) ) )
396 50 CONTINUE
397 ELSE
398*
399 DO 60 j = j1, j2, kd1
400 CALL crot( n, q( 1, j-1 ), 1, q( 1, j ), 1,
401 $ d( j ), conjg( 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 cscal( n, conjg( 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 ) = real( 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 ) = real( 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 clargv( 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* CLARTV or CROT is used
495*
496 IF( nr.GT.2*kd-1 ) THEN
497 DO 130 l = 1, kd - 1
498 CALL clartv( 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 crot( 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 clartg( 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 crot( 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 clar2v( 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* CLARTV or CROT is used
546*
547 IF( nr.GT.0 ) THEN
548 CALL clacgv( 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 clartv( 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 crot( 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 crot( 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 crot( 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 crot( 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 cscal( 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 ) = real( ab( 1, i ) )
667 240 CONTINUE
668 END IF
669*
670 RETURN
671*
672* End of CHBTRD
673*

◆ chetrd_hb2st()

subroutine chetrd_hb2st ( character stage1,
character vect,
character uplo,
integer n,
integer kd,
complex, dimension( ldab, * ) ab,
integer ldab,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( * ) hous,
integer lhous,
complex, dimension( * ) work,
integer lwork,
integer info )

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

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

Purpose:
!>
!> CHETRD_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 chetrd_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 chetrd_he2hb 
!>                  routine has been called to produce AB (e.g., AB is
!>                  the output of chetrd_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 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 REAL array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T.
!>
[out]E
!>          E is REAL 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 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 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 chetrd_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 REAL D( * ), E( * )
248 COMPLEX AB( LDAB, * ), HOUS( * ), WORK( * )
249* ..
250*
251* =====================================================================
252*
253* .. Parameters ..
254 REAL RZERO
255 COMPLEX ZERO, ONE
256 parameter( rzero = 0.0e+0,
257 $ zero = ( 0.0e+0, 0.0e+0 ),
258 $ one = ( 1.0e+0, 0.0e+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 $ SICEV, SIZETAU, LDV, LHMIN, LWMIN
269 REAL ABSTMP
270 COMPLEX TMP
271* ..
272* .. External Subroutines ..
273 EXTERNAL chb2st_kernels, clacpy, claset, xerbla
274* ..
275* .. Intrinsic Functions ..
276 INTRINSIC min, max, ceiling, 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, 'CHETRD_HB2ST', vect, n, kd, -1, -1 )
298 lhmin = ilaenv2stage( 3, 'CHETRD_HB2ST', vect, n, kd, ib, -1 )
299 lwmin = ilaenv2stage( 4, 'CHETRD_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( 'CHETRD_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 sicev = 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 ) = real( 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 ) = real( 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 CSCAL( N, CONJG( 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 CSCAL( 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 clacpy( "A", kd+1, n, ab, ldab, work( apos ), lda )
458 CALL claset( "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 IF( ttype.NE.1 ) THEN
514!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1))
515!$OMP$ DEPEND(in:WORK(MYID-1))
516!$OMP$ DEPEND(out:WORK(MYID))
517 tid = omp_get_thread_num()
518 CALL chb2st_kernels( uplo, wantq, ttype,
519 $ stind, edind, sweepid, n, kd, ib,
520 $ work( inda ), lda,
521 $ hous( indv ), hous( indtau ), ldv,
522 $ work( indw + tid*kd ) )
523!$OMP END TASK
524 ELSE
525!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1))
526!$OMP$ DEPEND(out:WORK(MYID))
527 tid = omp_get_thread_num()
528 CALL chb2st_kernels( uplo, wantq, ttype,
529 $ stind, edind, sweepid, n, kd, ib,
530 $ work( inda ), lda,
531 $ hous( indv ), hous( indtau ), ldv,
532 $ work( indw + tid*kd ) )
533!$OMP END TASK
534 ENDIF
535#else
536 CALL chb2st_kernels( uplo, wantq, ttype,
537 $ stind, edind, sweepid, n, kd, ib,
538 $ work( inda ), lda,
539 $ hous( indv ), hous( indtau ), ldv,
540 $ work( indw + tid*kd ) )
541#endif
542 IF ( blklastind.GE.(n-1) ) THEN
543 stt = stt + 1
544 EXIT
545 ENDIF
546 140 CONTINUE
547 130 CONTINUE
548 120 CONTINUE
549 110 CONTINUE
550 100 CONTINUE
551*
552#if defined(_OPENMP)
553!$OMP END MASTER
554!$OMP END PARALLEL
555#endif
556*
557* Copy the diagonal from A to D. Note that D is REAL thus only
558* the Real part is needed, the imaginary part should be zero.
559*
560 DO 150 i = 1, n
561 d( i ) = real( work( dpos+(i-1)*lda ) )
562 150 CONTINUE
563*
564* Copy the off diagonal from A to E. Note that E is REAL thus only
565* the Real part is needed, the imaginary part should be zero.
566*
567 IF( upper ) THEN
568 DO 160 i = 1, n-1
569 e( i ) = real( work( ofdpos+i*lda ) )
570 160 CONTINUE
571 ELSE
572 DO 170 i = 1, n-1
573 e( i ) = real( work( ofdpos+(i-1)*lda ) )
574 170 CONTINUE
575 ENDIF
576*
577 hous( 1 ) = lhmin
578 work( 1 ) = lwmin
579 RETURN
580*
581* End of CHETRD_HB2ST
582*
chb2st_kernels
subroutine chb2st_kernels(uplo, wantz, ttype, st, ed, sweep, n, nb, ib, a, lda, v, tau, ldvt, work)
CHB2ST_KERNELS
Definition chb2st_kernels.f:170
ilaenv2stage
integer function ilaenv2stage(ispec, name, opts, n1, n2, n3, n4)
ILAENV2STAGE
Definition ilaenv2stage.f:149

◆ chfrk()

subroutine chfrk ( character transr,
character uplo,
character trans,
integer n,
integer k,
real alpha,
complex, dimension( lda, * ) a,
integer lda,
real beta,
complex, dimension( * ) c )

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

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

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

◆ chpcon()

subroutine chpcon ( character uplo,
integer n,
complex, dimension( * ) ap,
integer, dimension( * ) ipiv,
real anorm,
real rcond,
complex, dimension( * ) work,
integer info )

CHPCON

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

Purpose:
!>
!> CHPCON 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 CHPTRF.
!>
!> 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 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 CHPTRF, 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 CHPTRF.
!>
[in]ANORM
!>          ANORM is REAL
!>          The 1-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is REAL
!>          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 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 chpcon.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 REAL ANORM, RCOND
127* ..
128* .. Array Arguments ..
129 INTEGER IPIV( * )
130 COMPLEX AP( * ), WORK( * )
131* ..
132*
133* =====================================================================
134*
135* .. Parameters ..
136 REAL ONE, ZERO
137 parameter( one = 1.0e+0, zero = 0.0e+0 )
138* ..
139* .. Local Scalars ..
140 LOGICAL UPPER
141 INTEGER I, IP, KASE
142 REAL 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 chptrs, clacn2, xerbla
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( 'CHPCON', -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 clacn2( 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 chptrs( 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 CHPCON
227*
clacn2
subroutine clacn2(n, v, x, est, kase, isave)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
Definition clacn2.f:133
chptrs
subroutine chptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
CHPTRS
Definition chptrs.f:115

◆ chpgst()

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

CHPGST

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

Purpose:
!>
!> CHPGST 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 CPPTRF.
!>
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 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 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 CPPTRF.
!>
[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 chpgst.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 AP( * ), BP( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 REAL ONE, HALF
130 parameter( one = 1.0e+0, half = 0.5e+0 )
131 COMPLEX CONE
132 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
133* ..
134* .. Local Scalars ..
135 LOGICAL UPPER
136 INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK
137 REAL AJJ, AKK, BJJ, BKK
138 COMPLEX CT
139* ..
140* .. External Subroutines ..
141 EXTERNAL caxpy, chpmv, chpr2, csscal, ctpmv, ctpsv,
142 $ xerbla
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC real
146* ..
147* .. External Functions ..
148 LOGICAL LSAME
149 COMPLEX CDOTC
150 EXTERNAL lsame, cdotc
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( 'CHPGST', -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 ) = real( ap( jj ) )
185 bjj = real( bp( jj ) )
186 CALL ctpsv( uplo, 'Conjugate transpose', 'Non-unit', j,
187 $ bp, ap( j1 ), 1 )
188 CALL chpmv( uplo, j-1, -cone, ap, bp( j1 ), 1, cone,
189 $ ap( j1 ), 1 )
190 CALL csscal( j-1, one / bjj, ap( j1 ), 1 )
191 ap( jj ) = ( ap( jj )-cdotc( 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 = real( ap( kk ) )
207 bkk = real( bp( kk ) )
208 akk = akk / bkk**2
209 ap( kk ) = akk
210 IF( k.LT.n ) THEN
211 CALL csscal( n-k, one / bkk, ap( kk+1 ), 1 )
212 ct = -half*akk
213 CALL caxpy( n-k, ct, bp( kk+1 ), 1, ap( kk+1 ), 1 )
214 CALL chpr2( uplo, n-k, -cone, ap( kk+1 ), 1,
215 $ bp( kk+1 ), 1, ap( k1k1 ) )
216 CALL caxpy( n-k, ct, bp( kk+1 ), 1, ap( kk+1 ), 1 )
217 CALL ctpsv( 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 = real( ap( kk ) )
238 bkk = real( bp( kk ) )
239 CALL ctpmv( uplo, 'No transpose', 'Non-unit', k-1, bp,
240 $ ap( k1 ), 1 )
241 ct = half*akk
242 CALL caxpy( k-1, ct, bp( k1 ), 1, ap( k1 ), 1 )
243 CALL chpr2( uplo, k-1, cone, ap( k1 ), 1, bp( k1 ), 1,
244 $ ap )
245 CALL caxpy( k-1, ct, bp( k1 ), 1, ap( k1 ), 1 )
246 CALL csscal( 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 = real( ap( jj ) )
262 bjj = real( bp( jj ) )
263 ap( jj ) = ajj*bjj + cdotc( n-j, ap( jj+1 ), 1,
264 $ bp( jj+1 ), 1 )
265 CALL csscal( n-j, bjj, ap( jj+1 ), 1 )
266 CALL chpmv( uplo, n-j, cone, ap( j1j1 ), bp( jj+1 ), 1,
267 $ cone, ap( jj+1 ), 1 )
268 CALL ctpmv( 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 CHPGST
277*
ctpmv
subroutine ctpmv(uplo, trans, diag, n, ap, x, incx)
CTPMV
Definition ctpmv.f:142
chpr2
subroutine chpr2(uplo, n, alpha, x, incx, y, incy, ap)
CHPR2
Definition chpr2.f:145
ctpsv
subroutine ctpsv(uplo, trans, diag, n, ap, x, incx)
CTPSV
Definition ctpsv.f:144
chpmv
subroutine chpmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
CHPMV
Definition chpmv.f:149

◆ chprfs()

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

CHPRFS

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

Purpose:
!>
!> CHPRFS 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 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 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 CHPTRF, 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 CHPTRF.
!>
[in]B
!>          B is COMPLEX 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 array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by CHPTRS.
!>          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 REAL 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 REAL 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 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
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 chprfs.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 REAL BERR( * ), FERR( * ), RWORK( * )
192 COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
193 $ X( LDX, * )
194* ..
195*
196* =====================================================================
197*
198* .. Parameters ..
199 INTEGER ITMAX
200 parameter( itmax = 5 )
201 REAL ZERO
202 parameter( zero = 0.0e+0 )
203 COMPLEX ONE
204 parameter( one = ( 1.0e+0, 0.0e+0 ) )
205 REAL TWO
206 parameter( two = 2.0e+0 )
207 REAL THREE
208 parameter( three = 3.0e+0 )
209* ..
210* .. Local Scalars ..
211 LOGICAL UPPER
212 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
213 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
214 COMPLEX ZDUM
215* ..
216* .. Local Arrays ..
217 INTEGER ISAVE( 3 )
218* ..
219* .. External Subroutines ..
220 EXTERNAL caxpy, ccopy, chpmv, chptrs, clacn2, xerbla
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC abs, aimag, max, real
224* ..
225* .. External Functions ..
226 LOGICAL LSAME
227 REAL SLAMCH
228 EXTERNAL lsame, slamch
229* ..
230* .. Statement Functions ..
231 REAL CABS1
232* ..
233* .. Statement Function definitions ..
234 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CHPRFS', -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 = slamch( 'Epsilon' )
272 safmin = slamch( '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 ccopy( n, b( 1, j ), 1, work, 1 )
289 CALL chpmv( 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( real( 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( real( 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 chptrs( uplo, n, 1, afp, ipiv, work, n, info )
359 CALL caxpy( 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 CLACN2 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 clacn2( 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 chptrs( 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 chptrs( 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 CHPRFS
434*

◆ chptrd()

subroutine chptrd ( character uplo,
integer n,
complex, dimension( * ) ap,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( * ) tau,
integer info )

CHPTRD

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

Purpose:
!>
!> CHPTRD 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 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 REAL array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is REAL 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 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 chptrd.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 REAL D( * ), E( * )
162 COMPLEX AP( * ), TAU( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 COMPLEX ONE, ZERO, HALF
169 parameter( one = ( 1.0e+0, 0.0e+0 ),
170 $ zero = ( 0.0e+0, 0.0e+0 ),
171 $ half = ( 0.5e+0, 0.0e+0 ) )
172* ..
173* .. Local Scalars ..
174 LOGICAL UPPER
175 INTEGER I, I1, I1I1, II
176 COMPLEX ALPHA, TAUI
177* ..
178* .. External Subroutines ..
179 EXTERNAL caxpy, chpmv, chpr2, clarfg, xerbla
180* ..
181* .. External Functions ..
182 LOGICAL LSAME
183 COMPLEX CDOTC
184 EXTERNAL lsame, cdotc
185* ..
186* .. Intrinsic Functions ..
187 INTRINSIC real
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( 'CHPTRD', -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 ) = real( 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 clarfg( i, alpha, ap( i1 ), 1, taui )
224 e( i ) = real( 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 chpmv( 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*cdotc( i, tau, 1, ap( i1 ), 1 )
240 CALL caxpy( 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 chpr2( uplo, i, -one, ap( i1 ), 1, tau, 1, ap )
246*
247 END IF
248 ap( i1+i-1 ) = e( i )
249 d( i+1 ) = real( ap( i1+i ) )
250 tau( i ) = taui
251 i1 = i1 - i
252 10 CONTINUE
253 d( 1 ) = real( 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 ) = real( 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 clarfg( n-i, alpha, ap( ii+2 ), 1, taui )
269 e( i ) = real( 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 chpmv( 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*cdotc( n-i, tau( i ), 1, ap( ii+1 ),
285 $ 1 )
286 CALL caxpy( 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 chpr2( 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 ) = real( ap( ii ) )
297 tau( i ) = taui
298 ii = i1i1
299 20 CONTINUE
300 d( n ) = real( ap( ii ) )
301 END IF
302*
303 RETURN
304*
305* End of CHPTRD
306*
clarfg
subroutine clarfg(n, alpha, x, incx, tau)
CLARFG generates an elementary reflector (Householder matrix).
Definition clarfg.f:106

◆ chptrf()

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

CHPTRF

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

Purpose:
!>
!> CHPTRF 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 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 chptrf.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 AP( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 REAL ZERO, ONE
177 parameter( zero = 0.0e+0, one = 1.0e+0 )
178 REAL EIGHT, SEVTEN
179 parameter( eight = 8.0e+0, sevten = 17.0e+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 REAL ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, ROWMAX,
186 $ TT
187 COMPLEX D12, D21, T, WK, WKM1, WKP1, ZDUM
188* ..
189* .. External Functions ..
190 LOGICAL LSAME
191 INTEGER ICAMAX
192 REAL SLAPY2
193 EXTERNAL lsame, icamax, slapy2
194* ..
195* .. External Subroutines ..
196 EXTERNAL chpr, csscal, cswap, xerbla
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, aimag, cmplx, conjg, max, real, sqrt
200* ..
201* .. Statement Functions ..
202 REAL CABS1
203* ..
204* .. Statement Function definitions ..
205 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CHPTRF', -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( real( 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 = icamax( 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 ) = real( 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 = icamax( 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( real( 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 cswap( 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 = conjg( ap( knc+j-1 ) )
330 ap( knc+j-1 ) = conjg( ap( kx ) )
331 ap( kx ) = t
332 30 CONTINUE
333 ap( kx+kk-1 ) = conjg( ap( kx+kk-1 ) )
334 r1 = real( ap( knc+kk-1 ) )
335 ap( knc+kk-1 ) = real( ap( kpc+kp-1 ) )
336 ap( kpc+kp-1 ) = r1
337 IF( kstep.EQ.2 ) THEN
338 ap( kc+k-1 ) = real( 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 ) = real( ap( kc+k-1 ) )
345 IF( kstep.EQ.2 )
346 $ ap( kc-1 ) = real( 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 / real( ap( kc+k-1 ) )
364 CALL chpr( uplo, k-1, -r1, ap( kc ), 1, ap )
365*
366* Store U(k) in column k
367*
368 CALL csscal( 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 = slapy2( real( ap( k-1+( k-1 )*k / 2 ) ),
386 $ aimag( ap( k-1+( k-1 )*k / 2 ) ) )
387 d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2 ) ) / d
388 d11 = real( 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 $ conjg( 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 )*conjg( wk ) -
401 $ ap( i+( k-2 )*( k-1 ) / 2 )*conjg( 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 ) = cmplx( real( ap( j+( j-1 )*
406 $ j / 2 ) ), 0.0e+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( real( 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 + icamax( 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 ) = real( 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 + icamax( 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( real( 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 cswap( 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 = conjg( ap( knc+j-kk ) )
533 ap( knc+j-kk ) = conjg( ap( kx ) )
534 ap( kx ) = t
535 80 CONTINUE
536 ap( knc+kp-kk ) = conjg( ap( knc+kp-kk ) )
537 r1 = real( ap( knc ) )
538 ap( knc ) = real( ap( kpc ) )
539 ap( kpc ) = r1
540 IF( kstep.EQ.2 ) THEN
541 ap( kc ) = real( 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 ) = real( ap( kc ) )
548 IF( kstep.EQ.2 )
549 $ ap( knc ) = real( 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 / real( ap( kc ) )
569 CALL chpr( 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 csscal( 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 = slapy2( real( ap( k+1+( k-1 )*( 2*n-k ) / 2 ) ),
596 $ aimag( ap( k+1+( k-1 )*( 2*n-k ) / 2 ) ) )
597 d11 = real( ap( k+1+k*( 2*n-k-1 ) / 2 ) ) / d
598 d22 = real( 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 $ conjg( d21 )*ap( j+( k-1 )*( 2*n-k ) / 2 ) )
608 DO 90 i = j, n
609 ap( i+( j-1 )*( 2*n-j ) / 2 ) = ap( i+( j-1 )*
610 $ ( 2*n-j ) / 2 ) - ap( i+( k-1 )*( 2*n-k ) /
611 $ 2 )*conjg( wk ) - ap( i+k*( 2*n-k-1 ) / 2 )*
612 $ conjg( wkp1 )
613 90 CONTINUE
614 ap( j+( k-1 )*( 2*n-k ) / 2 ) = wk
615 ap( j+k*( 2*n-k-1 ) / 2 ) = wkp1
616 ap( j+( j-1 )*( 2*n-j ) / 2 )
617 $ = cmplx( real( ap( j+( j-1 )*( 2*n-j ) / 2 ) ),
618 $ 0.0e+0 )
619 100 CONTINUE
620 END IF
621 END IF
622 END IF
623*
624* Store details of the interchanges in IPIV
625*
626 IF( kstep.EQ.1 ) THEN
627 ipiv( k ) = kp
628 ELSE
629 ipiv( k ) = -kp
630 ipiv( k+1 ) = -kp
631 END IF
632*
633* Increase K and return to the start of the main loop
634*
635 k = k + kstep
636 kc = knc + n - k + 2
637 GO TO 60
638*
639 END IF
640*
641 110 CONTINUE
642 RETURN
643*
644* End of CHPTRF
645*
slapy2
real function slapy2(x, y)
SLAPY2 returns sqrt(x2+y2).
Definition slapy2.f:63
icamax
integer function icamax(n, cx, incx)
ICAMAX
Definition icamax.f:71
chpr
subroutine chpr(uplo, n, alpha, x, incx, ap)
CHPR
Definition chpr.f:130

◆ chptri()

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

CHPTRI

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

Purpose:
!>
!> CHPTRI 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 CHPTRF.
!>
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 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 CHPTRF,
!>          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 CHPTRF.
!>
[out]WORK
!>          WORK is COMPLEX 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 chptri.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 AP( * ), WORK( * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 REAL ONE
127 COMPLEX CONE, ZERO
128 parameter( one = 1.0e+0, cone = ( 1.0e+0, 0.0e+0 ),
129 $ zero = ( 0.0e+0, 0.0e+0 ) )
130* ..
131* .. Local Scalars ..
132 LOGICAL UPPER
133 INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
134 REAL AK, AKP1, D, T
135 COMPLEX AKKP1, TEMP
136* ..
137* .. External Functions ..
138 LOGICAL LSAME
139 COMPLEX CDOTC
140 EXTERNAL lsame, cdotc
141* ..
142* .. External Subroutines ..
143 EXTERNAL ccopy, chpmv, cswap, xerbla
144* ..
145* .. Intrinsic Functions ..
146 INTRINSIC abs, conjg, real
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( 'CHPTRI', -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 / real( ap( kc+k-1 ) )
218*
219* Compute column K of the inverse.
220*
221 IF( k.GT.1 ) THEN
222 CALL ccopy( k-1, ap( kc ), 1, work, 1 )
223 CALL chpmv( uplo, k-1, -cone, ap, work, 1, zero,
224 $ ap( kc ), 1 )
225 ap( kc+k-1 ) = ap( kc+k-1 ) -
226 $ real( cdotc( 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 = real( ap( kc+k-1 ) ) / t
237 akp1 = real( 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 ccopy( k-1, ap( kc ), 1, work, 1 )
248 CALL chpmv( uplo, k-1, -cone, ap, work, 1, zero,
249 $ ap( kc ), 1 )
250 ap( kc+k-1 ) = ap( kc+k-1 ) -
251 $ real( cdotc( k-1, work, 1, ap( kc ), 1 ) )
252 ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -
253 $ cdotc( k-1, ap( kc ), 1, ap( kcnext ),
254 $ 1 )
255 CALL ccopy( k-1, ap( kcnext ), 1, work, 1 )
256 CALL chpmv( uplo, k-1, -cone, ap, work, 1, zero,
257 $ ap( kcnext ), 1 )
258 ap( kcnext+k ) = ap( kcnext+k ) -
259 $ real( cdotc( 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 cswap( 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 = conjg( ap( kc+j-1 ) )
278 ap( kc+j-1 ) = conjg( ap( kx ) )
279 ap( kx ) = temp
280 40 CONTINUE
281 ap( kc+kp-1 ) = conjg( 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 / real( ap( kc ) )
322*
323* Compute column K of the inverse.
324*
325 IF( k.LT.n ) THEN
326 CALL ccopy( n-k, ap( kc+1 ), 1, work, 1 )
327 CALL chpmv( uplo, n-k, -cone, ap( kc+n-k+1 ), work, 1,
328 $ zero, ap( kc+1 ), 1 )
329 ap( kc ) = ap( kc ) - real( cdotc( 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 = real( ap( kcnext ) ) / t
341 akp1 = real( 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 ccopy( n-k, ap( kc+1 ), 1, work, 1 )
352 CALL chpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,
353 $ 1, zero, ap( kc+1 ), 1 )
354 ap( kc ) = ap( kc ) - real( cdotc( n-k, work, 1,
355 $ ap( kc+1 ), 1 ) )
356 ap( kcnext+1 ) = ap( kcnext+1 ) -
357 $ cdotc( n-k, ap( kc+1 ), 1,
358 $ ap( kcnext+2 ), 1 )
359 CALL ccopy( n-k, ap( kcnext+2 ), 1, work, 1 )
360 CALL chpmv( uplo, n-k, -cone, ap( kc+( n-k+1 ) ), work,
361 $ 1, zero, ap( kcnext+2 ), 1 )
362 ap( kcnext ) = ap( kcnext ) -
363 $ real( cdotc( 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 cswap( 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 = conjg( ap( kc+j-k ) )
383 ap( kc+j-k ) = conjg( ap( kx ) )
384 ap( kx ) = temp
385 70 CONTINUE
386 ap( kc+kp-k ) = conjg( 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 CHPTRI
406*

◆ chptrs()

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

CHPTRS

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

Purpose:
!>
!> CHPTRS 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 CHPTRF.
!>
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 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 CHPTRF, 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 CHPTRF.
!>
[in,out]B
!>          B is COMPLEX 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 chptrs.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 AP( * ), B( LDB, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 COMPLEX ONE
133 parameter( one = ( 1.0e+0, 0.0e+0 ) )
134* ..
135* .. Local Scalars ..
136 LOGICAL UPPER
137 INTEGER J, K, KC, KP
138 REAL S
139 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 EXTERNAL lsame
144* ..
145* .. External Subroutines ..
146 EXTERNAL cgemv, cgeru, clacgv, csscal, cswap, xerbla
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC conjg, max, real
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( 'CHPTRS', -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 cswap( 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 cgeru( 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 = real( one ) / real( ap( kc+k-1 ) )
212 CALL csscal( 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 cswap( 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 cgeru( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
228 $ b( 1, 1 ), ldb )
229 CALL cgeru( 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 ) / conjg( akm1k )
237 denom = akm1*ak - one
238 DO 20 j = 1, nrhs
239 bkm1 = b( k-1, j ) / akm1k
240 bk = b( k, j ) / conjg( 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 clacgv( nrhs, b( k, 1 ), ldb )
274 CALL cgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
275 $ ldb, ap( kc ), 1, one, b( k, 1 ), ldb )
276 CALL clacgv( 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 cswap( 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 clacgv( nrhs, b( k, 1 ), ldb )
295 CALL cgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
296 $ ldb, ap( kc ), 1, one, b( k, 1 ), ldb )
297 CALL clacgv( nrhs, b( k, 1 ), ldb )
298*
299 CALL clacgv( nrhs, b( k+1, 1 ), ldb )
300 CALL cgemv( 'Conjugate transpose', k-1, nrhs, -one, b,
301 $ ldb, ap( kc+k ), 1, one, b( k+1, 1 ), ldb )
302 CALL clacgv( 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 cswap( 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 cswap( 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 cgeru( 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 = real( one ) / real( ap( kc ) )
355 CALL csscal( 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 cswap( 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 cgeru( n-k-1, nrhs, -one, ap( kc+2 ), 1, b( k, 1 ),
373 $ ldb, b( k+2, 1 ), ldb )
374 CALL cgeru( 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 ) / conjg( 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 ) / conjg( 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 clacgv( nrhs, b( k, 1 ), ldb )
421 CALL cgemv( 'Conjugate transpose', n-k, nrhs, -one,
422 $ b( k+1, 1 ), ldb, ap( kc+1 ), 1, one,
423 $ b( k, 1 ), ldb )
424 CALL clacgv( 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 cswap( 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 clacgv( nrhs, b( k, 1 ), ldb )
442 CALL cgemv( 'Conjugate transpose', n-k, nrhs, -one,
443 $ b( k+1, 1 ), ldb, ap( kc+1 ), 1, one,
444 $ b( k, 1 ), ldb )
445 CALL clacgv( nrhs, b( k, 1 ), ldb )
446*
447 CALL clacgv( nrhs, b( k-1, 1 ), ldb )
448 CALL cgemv( '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 clacgv( 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 cswap( 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 CHPTRS
470*

◆ chsein()

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

CHSEIN

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

Purpose:
!>
!> CHSEIN 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 CHSEQR; 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 CHSEIN 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, CHSEIN 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 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 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 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 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 array, dimension (N*N)
!>
[out]RWORK
!>          RWORK is REAL 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 chsein.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 REAL RWORK( * )
258 COMPLEX H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
259 $ W( * ), WORK( * )
260* ..
261*
262* =====================================================================
263*
264* .. Parameters ..
265 COMPLEX ZERO
266 parameter( zero = ( 0.0e+0, 0.0e+0 ) )
267 REAL RZERO
268 parameter( rzero = 0.0e+0 )
269* ..
270* .. Local Scalars ..
271 LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, RIGHTV
272 INTEGER I, IINFO, K, KL, KLN, KR, KS, LDWORK
273 REAL EPS3, HNORM, SMLNUM, ULP, UNFL
274 COMPLEX CDUM, WK
275* ..
276* .. External Functions ..
277 LOGICAL LSAME, SISNAN
278 REAL CLANHS, SLAMCH
279 EXTERNAL lsame, clanhs, slamch, sisnan
280* ..
281* .. External Subroutines ..
282 EXTERNAL claein, xerbla
283* ..
284* .. Intrinsic Functions ..
285 INTRINSIC abs, aimag, max, real
286* ..
287* .. Statement Functions ..
288 REAL CABS1
289* ..
290* .. Statement Function definitions ..
291 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( 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( 'CHSEIN', -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 = slamch( 'Safe minimum' )
345 ulp = slamch( '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 = clanhs( 'I', kr-kl+1, h( kl, kl ), ldh, rwork )
400 IF( sisnan( 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 claein( .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 claein( .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 CHSEIN
464*
sisnan
logical function sisnan(sin)
SISNAN tests input for NaN.
Definition sisnan.f:59
claein
subroutine claein(rightv, noinit, n, h, ldh, w, v, b, ldb, rwork, eps3, smlnum, info)
CLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse iterat...
Definition claein.f:149
clanhs
real function clanhs(norm, n, a, lda, work)
CLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clanhs.f:109

◆ chseqr()

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

CHSEQR

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

Purpose:
!>
!>    CHSEQR 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 CGEBAL, and then passed to ZGEHRD
!>           when the matrix output by CGEBAL is reduced to Hessenberg
!>           form. Otherwise ILO and IHI should be set to 1 and N
!>           respectively.  If N > 0, then 1 <= ILO <= IHI <= N.
!>           If N = 0, then ILO = 1 and IHI = 0.
!>
[in,out]H
!>          H is COMPLEX array, dimension (LDH,N)
!>           On entry, the upper Hessenberg matrix H.
!>           On exit, if INFO = 0 and 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 CHSEQR, 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 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 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 CUNGHR
!>           after the call to CGEHRD 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 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 CHSEQR does a workspace query.
!>           In this case, CHSEQR 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, CHSEQR 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,'CHSEQR',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 CLAHQR vs CLAQR0 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
!>                       CLAHQR 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 chseqr.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 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* . CLAHQR 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 CLAHQR 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 ZERO, ONE
331 parameter( zero = ( 0.0e0, 0.0e0 ),
332 $ one = ( 1.0e0, 0.0e0 ) )
333 REAL RZERO
334 parameter( rzero = 0.0e0 )
335* ..
336* .. Local Arrays ..
337 COMPLEX 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 ccopy, clacpy, clahqr, claqr0, claset, xerbla
350* ..
351* .. Intrinsic Functions ..
352 INTRINSIC cmplx, max, min, real
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 ) = cmplx( real( 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( 'CHSEQR', -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 claqr0( 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 ) = cmplx( max( real( work( 1 ) ), real( max( 1,
405 $ n ) ) ), rzero )
406 RETURN
407*
408 ELSE
409*
410* ==== copy eigenvalues isolated by CGEBAL ====
411*
412 IF( ilo.GT.1 )
413 $ CALL ccopy( ilo-1, h, ldh+1, w, 1 )
414 IF( ihi.LT.n )
415 $ CALL ccopy( 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 claset( '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* ==== CLAHQR/CLAQR0 crossover point ====
430*
431 nmin = ilaenv( 12, 'CHSEQR', job( : 1 ) // compz( : 1 ), n,
432 $ ilo, ihi, lwork )
433 nmin = max( ntiny, nmin )
434*
435* ==== CLAQR0 for big matrices; CLAHQR for small ones ====
436*
437 IF( n.GT.nmin ) THEN
438 CALL claqr0( 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 clahqr( 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 CLAHQR failure! CLAQR0 sometimes succeeds
450* . when CLAHQR fails. ====
451*
452 kbot = info
453*
454 IF( n.GE.nl ) THEN
455*
456* ==== Larger matrices have enough subdiagonal scratch
457* . space to call CLAQR0 directly. ====
458*
459 CALL claqr0( 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 CLAQR0. Hence,
466* . tiny matrices must be copied into a larger
467* . array before calling CLAQR0. ====
468*
469 CALL clacpy( 'A', n, n, h, ldh, hl, nl )
470 hl( n+1, n ) = zero
471 CALL claset( 'A', nl, nl-n, zero, zero, hl( 1, n+1 ),
472 $ nl )
473 CALL claqr0( 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 clacpy( '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 claset( '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 ) = cmplx( max( real( max( 1, n ) ),
490 $ real( work( 1 ) ) ), rzero )
491 END IF
492*
493* ==== End of CHSEQR ====
494*
clahqr
subroutine clahqr(wantt, wantz, n, ilo, ihi, h, ldh, w, iloz, ihiz, z, ldz, info)
CLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix,...
Definition clahqr.f:195
claqr0
subroutine claqr0(wantt, wantz, n, ilo, ihi, h, ldh, w, iloz, ihiz, z, ldz, work, lwork, info)
CLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur de...
Definition claqr0.f:240
nl
character *2 function nl()
Definition message.F:2354

◆ cla_lin_berr()

subroutine cla_lin_berr ( integer n,
integer nz,
integer nrhs,
complex, dimension( n, nrhs ) res,
real, dimension( n, nrhs ) ayb,
real, dimension( nrhs ) berr )

CLA_LIN_BERR computes a component-wise relative backward error.

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

Purpose:
!>
!>    CLA_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 array, dimension (N,NRHS)
!>     The residual matrix, i.e., the matrix R in the relative backward
!>     error formula above.
!>
[in]AYB
!>          AYB is REAL 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 cla_gerfsx_extended.f).
!>
[out]BERR
!>          BERR is REAL 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 cla_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 REAL AYB( N, NRHS ), BERR( NRHS )
111 COMPLEX RES( N, NRHS )
112* ..
113*
114* =====================================================================
115*
116* .. Local Scalars ..
117 REAL TMP
118 INTEGER I, J
119 COMPLEX CDUM
120* ..
121* .. Intrinsic Functions ..
122 INTRINSIC abs, real, aimag, max
123* ..
124* .. External Functions ..
125 EXTERNAL slamch
126 REAL SLAMCH
127 REAL SAFE1
128* ..
129* .. Statement Functions ..
130 COMPLEX CABS1
131* ..
132* .. Statement Function Definitions ..
133 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( 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 = slamch( 'Safe minimum' )
142 safe1 = (nz+1)*safe1
143
144 DO j = 1, nrhs
145 berr(j) = 0.0
146 DO i = 1, n
147 IF (ayb(i,j) .NE. 0.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 CLA_LIN_BERR
159*

◆ cla_wwaddw()

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

CLA_WWADDW adds a vector into a doubled-single vector.

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

Purpose:
!>
!>    CLA_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 array, dimension (N)
!>            The first part of the doubled-single accumulation vector.
!>
[in,out]Y
!>          Y is COMPLEX array, dimension (N)
!>            The second part of the doubled-single accumulation vector.
!>
[in]W
!>          W is COMPLEX 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 cla_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 X( * ), Y( * ), W( * )
91* ..
92*
93* =====================================================================
94*
95* .. Local Scalars ..
96 COMPLEX S
97 INTEGER I
98* ..
99* .. Executable Statements ..
100*
101 DO 10 i = 1, n
102 s = x(i) + w(i)
103 s = (s + s) - s
104 y(i) = ((x(i) - s) + w(i)) + y(i)
105 x(i) = s
106 10 CONTINUE
107 RETURN
108*
109* End of CLA_WWADDW
110*

◆ claed0()

subroutine claed0 ( integer qsiz,
integer n,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( ldq, * ) q,
integer ldq,
complex, dimension( ldqs, * ) qstore,
integer ldqs,
real, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer info )

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

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

Purpose:
!>
!> Using the divide and conquer method, CLAED0 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 REAL array, dimension (N)
!>         On entry, the diagonal elements of the tridiagonal matrix.
!>         On exit, the eigenvalues in ascending order.
!>
[in,out]E
!>          E is REAL 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 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 REAL 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 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 claed0.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 REAL D( * ), E( * ), RWORK( * )
156 COMPLEX Q( LDQ, * ), QSTORE( LDQS, * )
157* ..
158*
159* =====================================================================
160*
161* Warning: N could be as big as QSIZ!
162*
163* .. Parameters ..
164 REAL TWO
165 parameter( two = 2.e+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 REAL TEMP
173* ..
174* .. External Subroutines ..
175 EXTERNAL ccopy, clacrm, claed7, scopy, ssteqr, xerbla
176* ..
177* .. External Functions ..
178 INTEGER ILAENV
179 EXTERNAL ilaenv
180* ..
181* .. Intrinsic Functions ..
182 INTRINSIC abs, int, log, max, real
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( 'CLAED0', -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, 'CLAED0', ' ', 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( real( 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 ssteqr( 'I', matsiz, d( submat ), e( submat ),
287 $ rwork( ll ), matsiz, rwork, info )
288 CALL clacrm( 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. CLAED7 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 claed7( 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 ccopy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 )
361 100 CONTINUE
362 CALL scopy( n, rwork, 1, d, 1 )
363*
364 RETURN
365*
366* End of CLAED0
367*
ssteqr
subroutine ssteqr(compz, n, d, e, z, ldz, work, info)
SSTEQR
Definition ssteqr.f:131
clacrm
subroutine clacrm(m, n, a, lda, b, ldb, c, ldc, rwork)
CLACRM multiplies a complex matrix by a square real matrix.
Definition clacrm.f:114
claed7
subroutine claed7(n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, ldq, rho, indxq, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, rwork, iwork, info)
CLAED7 used by CSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a ...
Definition claed7.f:249
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82

◆ claed7()

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

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

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

Purpose:
!>
!> CLAED7 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 SLAED2.
!>
!>       The second stage consists of calculating the updated
!>       eigenvalues. This is done by finding the roots of the secular
!>       equation via the routine SLAED4 (as called by SLAED3).
!>       This routine also calculates the eigenvectors of the current
!>       problem.
!>
!>       The final stage consists of computing the updated eigenvectors
!>       directly using the updated eigenvalues.  The eigenvectors for
!>       the current problem are multiplied with the eigenvectors from
!>       the overall problem.
!>
Parameters
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in]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 REAL array, dimension (N)
!>         On entry, the eigenvalues of the rank-1-perturbed matrix.
!>         On exit, the eigenvalues of the repaired matrix.
!>
[in,out]Q
!>          Q is COMPLEX 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 REAL
!>         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 REAL array,
!>                                 dimension (3*N+2*QSIZ*N)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (QSIZ*N)
!>
[in,out]QSTORE
!>          QSTORE is REAL array, dimension (N**2+1)
!>         Stores eigenvectors of submatrices encountered during
!>         divide and conquer, packed together. QPTR points to
!>         beginning of the submatrices.
!>
[in,out]QPTR
!>          QPTR is INTEGER array, dimension (N+2)
!>         List of indices pointing to beginning of submatrices stored
!>         in QSTORE. The submatrices are numbered starting at the
!>         bottom left of the divide and conquer tree, from left to
!>         right and bottom to top.
!>
[in]PRMPTR
!>          PRMPTR is INTEGER array, dimension (N lg N)
!>         Contains a list of pointers which indicate where in PERM a
!>         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
!>         indicates the size of the permutation and also the size of
!>         the full, non-deflated problem.
!>
[in]PERM
!>          PERM is INTEGER array, dimension (N lg N)
!>         Contains the permutations (from deflation and sorting) to be
!>         applied to each eigenblock.
!>
[in]GIVPTR
!>          GIVPTR is INTEGER array, dimension (N lg N)
!>         Contains a list of pointers which indicate where in GIVCOL a
!>         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
!>         indicates the number of Givens rotations.
!>
[in]GIVCOL
!>          GIVCOL is INTEGER array, dimension (2, N lg N)
!>         Each pair of numbers indicates a pair of columns to take place
!>         in a Givens rotation.
!>
[in]GIVNUM
!>          GIVNUM is REAL array, dimension (2, N lg N)
!>         Each number indicates the S value to be used in the
!>         corresponding Givens rotation.
!>
[out]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 claed7.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 REAL RHO
258* ..
259* .. Array Arguments ..
260 INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
261 $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
262 REAL D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
263 COMPLEX 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 clacrm, claed8, slaed9, slaeda, slamrg, xerbla
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( 'CLAED7', -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 SLAED2 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 slaeda( 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 claed8( 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 slaed9( k, 1, k, n, d, rwork( iq ), k, rho,
357 $ rwork( idlmda ), rwork( iw ),
358 $ qstore( qptr( curr ) ), k, info )
359 CALL clacrm( 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 slamrg( 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 CLAED7
381*
slamrg
subroutine slamrg(n1, n2, a, strd1, strd2, index)
SLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single...
Definition slamrg.f:99
slaed9
subroutine slaed9(k, kstart, kstop, n, d, q, ldq, rho, dlamda, w, s, lds, info)
SLAED9 used by SSTEDC. Finds the roots of the secular equation and updates the eigenvectors....
Definition slaed9.f:156
slaeda
subroutine slaeda(n, tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, info)
SLAEDA used by SSTEDC. Computes the Z vector determining the rank-one modification of the diagonal ma...
Definition slaeda.f:166
claed8
subroutine claed8(k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda, q2, ldq2, w, indxp, indx, indxq, perm, givptr, givcol, givnum, info)
CLAED8 used by CSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matri...
Definition claed8.f:228

◆ claed8()

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

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

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

Purpose:
!>
!> CLAED8 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 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 REAL array, dimension (N)
!>         On entry, D contains the eigenvalues of the two submatrices to
!>         be combined.  On exit, D contains the trailing (N-K) updated
!>         eigenvalues (those which were deflated) sorted into increasing
!>         order.
!>
[in,out]RHO
!>          RHO is REAL
!>         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 SLAED3.
!>
[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 REAL 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 REAL array, dimension (N)
!>         Contains a copy of the first K eigenvalues which will be used
!>         by SLAED3 to form the secular equation.
!>
[out]Q2
!>          Q2 is COMPLEX 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 SLAED7 in a matrix multiply (SGEMM) to update the new
!>         eigenvectors.
!>
[in]LDQ2
!>          LDQ2 is INTEGER
!>         The leading dimension of the array Q2.  LDQ2 >= max( 1, N ).
!>
[out]W
!>          W is REAL array, dimension (N)
!>         This will hold the first k values of the final
!>         deflation-altered z-vector and will be passed to SLAED3.
!>
[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 REAL 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 claed8.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 REAL RHO
236* ..
237* .. Array Arguments ..
238 INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
239 $ INDXQ( * ), PERM( * )
240 REAL D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ),
241 $ Z( * )
242 COMPLEX Q( LDQ, * ), Q2( LDQ2, * )
243* ..
244*
245* =====================================================================
246*
247* .. Parameters ..
248 REAL MONE, ZERO, ONE, TWO, EIGHT
249 parameter( mone = -1.0e0, zero = 0.0e0, one = 1.0e0,
250 $ two = 2.0e0, eight = 8.0e0 )
251* ..
252* .. Local Scalars ..
253 INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
254 REAL C, EPS, S, T, TAU, TOL
255* ..
256* .. External Functions ..
257 INTEGER ISAMAX
258 REAL SLAMCH, SLAPY2
259 EXTERNAL isamax, slamch, slapy2
260* ..
261* .. External Subroutines ..
262 EXTERNAL ccopy, clacpy, csrot, scopy, slamrg, sscal,
263 $ xerbla
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( 'CLAED8', -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 sscal( 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 sscal( 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 slamrg( 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 = isamax( n, z, 1 )
339 jmax = isamax( n, d, 1 )
340 eps = slamch( '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 ccopy( qsiz, q( 1, perm( j ) ), 1, q2( 1, j ), 1 )
352 50 CONTINUE
353 CALL clacpy( '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 = slapy2( 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 csrot( 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 ccopy( 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 scopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 )
475 CALL clacpy( '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 CLAED8
482*
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79

◆ clals0()

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

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

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

Purpose:
!>
!> CLALS0 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 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 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL
!>         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 REAL
!>         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 REAL 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 clals0.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 REAL C, S
279* ..
280* .. Array Arguments ..
281 INTEGER GIVCOL( LDGCOL, * ), PERM( * )
282 REAL DIFL( * ), DIFR( LDGNUM, * ),
283 $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
284 $ RWORK( * ), Z( * )
285 COMPLEX B( LDB, * ), BX( LDBX, * )
286* ..
287*
288* =====================================================================
289*
290* .. Parameters ..
291 REAL ONE, ZERO, NEGONE
292 parameter( one = 1.0e0, zero = 0.0e0, negone = -1.0e0 )
293* ..
294* .. Local Scalars ..
295 INTEGER I, J, JCOL, JROW, M, N, NLP1
296 REAL DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
297* ..
298* .. External Subroutines ..
299 EXTERNAL ccopy, clacpy, clascl, csrot, csscal, sgemv,
300 $ xerbla
301* ..
302* .. External Functions ..
303 REAL SLAMC3, SNRM2
304 EXTERNAL slamc3, snrm2
305* ..
306* .. Intrinsic Functions ..
307 INTRINSIC aimag, cmplx, max, real
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( 'CLALS0', -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 csrot( 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 ccopy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx )
362 DO 20 i = 2, n
363 CALL ccopy( 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 ccopy( nrhs, bx, ldbx, b, ldb )
371 IF( z( 1 ).LT.zero ) THEN
372 CALL csscal( 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 $ ( slamc3( 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 $ ( slamc3( poles( i, 2 ), dsigjp )+
407 $ difrj ) / ( poles( i, 2 )+dj )
408 END IF
409 40 CONTINUE
410 rwork( 1 ) = negone
411 temp = snrm2( k, rwork, 1 )
412*
413* Since B and BX are complex, the following call to SGEMV
414* is performed in two steps (real and imaginary parts).
415*
416* CALL SGEMV( '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 ) = real( bx( jrow, jcol ) )
424 50 CONTINUE
425 60 CONTINUE
426 CALL sgemv( '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 ) = aimag( bx( jrow, jcol ) )
433 70 CONTINUE
434 80 CONTINUE
435 CALL sgemv( '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 ) = cmplx( rwork( jcol+k ),
439 $ rwork( jcol+k+nrhs ) )
440 90 CONTINUE
441 CALL clascl( '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 clacpy( '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 ccopy( 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 ) / ( slamc3( 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 ) / ( slamc3( 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 SGEMV
489* is performed in two steps (real and imaginary parts).
490*
491* CALL SGEMV( '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 ) = real( b( jrow, jcol ) )
499 130 CONTINUE
500 140 CONTINUE
501 CALL sgemv( '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 ) = aimag( b( jrow, jcol ) )
508 150 CONTINUE
509 160 CONTINUE
510 CALL sgemv( '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 ) = cmplx( 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 ccopy( nrhs, b( m, 1 ), ldb, bx( m, 1 ), ldbx )
524 CALL csrot( nrhs, bx( 1, 1 ), ldbx, bx( m, 1 ), ldbx, c, s )
525 END IF
526 IF( k.LT.max( m, n ) )
527 $ CALL clacpy( 'A', n-k, nrhs, b( k+1, 1 ), ldb,
528 $ bx( k+1, 1 ), ldbx )
529*
530* Step (3R): permute rows of B.
531*
532 CALL ccopy( nrhs, bx( 1, 1 ), ldbx, b( nlp1, 1 ), ldb )
533 IF( sqre.EQ.1 ) THEN
534 CALL ccopy( nrhs, bx( m, 1 ), ldbx, b( m, 1 ), ldb )
535 END IF
536 DO 190 i = 2, n
537 CALL ccopy( 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 csrot( 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 CLALS0
552*
snrm2
real(wp) function snrm2(n, x, incx)
SNRM2
Definition snrm2.f90:89
sgemv
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SGEMV
Definition sgemv.f:156
slamc3
real function slamc3(a, b)
SLAMC3
Definition slamch.f:169

◆ clalsa()

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

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

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

Purpose:
!>
!> CLALSA 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, CLALSA applies the inverse of the left singular vector
!> matrix of an upper bidiagonal matrix to the right hand side; and if
!> ICOMPQ = 1, CLALSA applies the right singular vector matrix to the
!> right hand side. The singular vector matrices were generated in
!> compact form by CLALSA.
!>
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 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 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 REAL 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 REAL 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 REAL array, dimension ( LDU, NLVL ).
!>         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
!>
[in]DIFR
!>          DIFR is REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 clalsa.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 REAL C( * ), DIFL( LDU, * ), DIFR( LDU, * ),
280 $ GIVNUM( LDU, * ), POLES( LDU, * ), RWORK( * ),
281 $ S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * )
282 COMPLEX B( LDB, * ), BX( LDBX, * )
283* ..
284*
285* =====================================================================
286*
287* .. Parameters ..
288 REAL ZERO, ONE
289 parameter( zero = 0.0e0, one = 1.0e0 )
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 ccopy, clals0, sgemm, slasdt, xerbla
298* ..
299* .. Intrinsic Functions ..
300 INTRINSIC aimag, cmplx, real
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( 'CLALSA', -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 slasdt( 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 SLASDQ. 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 SGEMM
368* is performed in two steps (real and imaginary parts).
369*
370* CALL SGEMM( '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 ) = real( b( jrow, jcol ) )
378 10 CONTINUE
379 20 CONTINUE
380 CALL sgemm( '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 ) = aimag( b( jrow, jcol ) )
387 30 CONTINUE
388 40 CONTINUE
389 CALL sgemm( '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 ) = cmplx( rwork( jreal ),
399 $ rwork( jimag ) )
400 50 CONTINUE
401 60 CONTINUE
402*
403* Since B and BX are complex, the following call to SGEMM
404* is performed in two steps (real and imaginary parts).
405*
406* CALL SGEMM( '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 ) = real( b( jrow, jcol ) )
414 70 CONTINUE
415 80 CONTINUE
416 CALL sgemm( '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 ) = aimag( b( jrow, jcol ) )
423 90 CONTINUE
424 100 CONTINUE
425 CALL sgemm( '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 ) = cmplx( 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 ccopy( 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 clals0( 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 clals0( 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 SLASDQ. 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 SGEMM is
551* performed in two steps (real and imaginary parts).
552*
553* CALL SGEMM( '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 ) = real( b( jrow, jcol ) )
561 200 CONTINUE
562 210 CONTINUE
563 CALL sgemm( '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 ) = aimag( b( jrow, jcol ) )
571 220 CONTINUE
572 230 CONTINUE
573 CALL sgemm( '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 ) = cmplx( rwork( jreal ),
583 $ rwork( jimag ) )
584 240 CONTINUE
585 250 CONTINUE
586*
587* Since B and BX are complex, the following call to SGEMM is
588* performed in two steps (real and imaginary parts).
589*
590* CALL SGEMM( '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 ) = real( b( jrow, jcol ) )
598 260 CONTINUE
599 270 CONTINUE
600 CALL sgemm( '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 ) = aimag( b( jrow, jcol ) )
608 280 CONTINUE
609 290 CONTINUE
610 CALL sgemm( '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 ) = cmplx( 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 CLALSA
631*
slasdt
subroutine slasdt(n, lvl, nd, inode, ndiml, ndimr, msub)
SLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc.
Definition slasdt.f:105
clals0
subroutine clals0(icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx, perm, givptr, givcol, ldgcol, givnum, ldgnum, poles, difl, difr, z, k, c, s, rwork, info)
CLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer...
Definition clals0.f:270
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187

◆ clalsd()

subroutine clalsd ( character uplo,
integer smlsiz,
integer n,
integer nrhs,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( ldb, * ) b,
integer ldb,
real rcond,
integer rank,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer info )

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

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

Purpose:
!>
!> CLALSD 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 REAL 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 REAL 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 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 REAL
!>         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 array, dimension (N * NRHS).
!>
[out]RWORK
!>          RWORK is REAL 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 (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 184 of file clalsd.f.

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

◆ clanhf()

real function clanhf ( character norm,
character transr,
character uplo,
integer n,
complex, dimension( 0: * ) a,
real, dimension( 0: * ) work )

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

Purpose:
!>
!> CLANHF  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
CLANHF 
!>
!>    CLANHF = ( 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 CLANHF 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, CLANHF is
!>            set to zero.
!>
[in]A
!>          A is COMPLEX 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 REAL 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 clanhf.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 REAL WORK( 0: * )
257 COMPLEX A( 0: * )
258* ..
259*
260* =====================================================================
261*
262* .. Parameters ..
263 REAL ONE, ZERO
264 parameter( one = 1.0e+0, zero = 0.0e+0 )
265* ..
266* .. Local Scalars ..
267 INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA
268 REAL SCALE, S, VALUE, AA, TEMP
269* ..
270* .. External Functions ..
271 LOGICAL LSAME, SISNAN
272 EXTERNAL lsame, sisnan
273* ..
274* .. External Subroutines ..
275 EXTERNAL classq
276* ..
277* .. Intrinsic Functions ..
278 INTRINSIC abs, real, sqrt
279* ..
280* .. Executable Statements ..
281*
282 IF( n.EQ.0 ) THEN
283 clanhf = zero
284 RETURN
285 ELSE IF( n.EQ.1 ) THEN
286 clanhf = abs(real(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( real( a( j+j*lda ) ) )
339 IF( VALUE .LT. temp .OR. sisnan( temp ) )
340 $ VALUE = temp
341 DO i = 1, n - 1
342 temp = abs( a( i+j*lda ) )
343 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
350 $ VALUE = temp
351 END DO
352 i = j - 1
353* L(k+j,k+j)
354 temp = abs( real( a( i+j*lda ) ) )
355 IF( VALUE .LT. temp .OR. sisnan( temp ) )
356 $ VALUE = temp
357 i = j
358* -> L(j,j)
359 temp = abs( real( a( i+j*lda ) ) )
360 IF( VALUE .LT. temp .OR. sisnan( temp ) )
361 $ VALUE = temp
362 DO i = j + 1, n - 1
363 temp = abs( a( i+j*lda ) )
364 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
374 $ VALUE = temp
375 END DO
376 i = k + j - 1
377* -> U(i,i)
378 temp = abs( real( a( i+j*lda ) ) )
379 IF( VALUE .LT. temp .OR. sisnan( temp ) )
380 $ VALUE = temp
381 i = i + 1
382* =k+j; i -> U(j,j)
383 temp = abs( real( a( i+j*lda ) ) )
384 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( 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. sisnan( temp ) )
395 $ VALUE = temp
396* j=k-1
397 END DO
398* i=n-1 -> U(n-1,n-1)
399 temp = abs( real( a( i+j*lda ) ) )
400 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
411 $ VALUE = temp
412 END DO
413 i = j
414* L(i,i)
415 temp = abs( real( a( i+j*lda ) ) )
416 IF( VALUE .LT. temp .OR. sisnan( temp ) )
417 $ VALUE = temp
418 i = j + 1
419* L(j+k,j+k)
420 temp = abs( real( a( i+j*lda ) ) )
421 IF( VALUE .LT. temp .OR. sisnan( temp ) )
422 $ VALUE = temp
423 DO i = j + 2, k - 1
424 temp = abs( a( i+j*lda ) )
425 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
433 $ VALUE = temp
434 END DO
435 i = k - 1
436* -> L(i,i) is at A(i,j)
437 temp = abs( real( a( i+j*lda ) ) )
438 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( 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. sisnan( 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( real( a( 0+j*lda ) ) )
459 IF( VALUE .LT. temp .OR. sisnan( temp ) )
460 $ VALUE = temp
461 DO i = 1, k - 1
462 temp = abs( a( i+j*lda ) )
463 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
470 $ VALUE = temp
471 END DO
472 i = j - k
473* -> U(i,i) at A(i,j)
474 temp = abs( real( a( i+j*lda ) ) )
475 IF( VALUE .LT. temp .OR. sisnan( temp ) )
476 $ VALUE = temp
477 i = j - k + 1
478* U(j,j)
479 temp = abs( real( a( i+j*lda ) ) )
480 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( 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( real( a( j+j*lda ) ) )
499 IF( VALUE .LT. temp .OR. sisnan( temp ) )
500 $ VALUE = temp
501 temp = abs( real( a( j+1+j*lda ) ) )
502 IF( VALUE .LT. temp .OR. sisnan( temp ) )
503 $ VALUE = temp
504 DO i = 2, n
505 temp = abs( a( i+j*lda ) )
506 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
513 $ VALUE = temp
514 END DO
515 i = j
516* L(k+j,k+j)
517 temp = abs( real( a( i+j*lda ) ) )
518 IF( VALUE .LT. temp .OR. sisnan( temp ) )
519 $ VALUE = temp
520 i = j + 1
521* -> L(j,j)
522 temp = abs( real( a( i+j*lda ) ) )
523 IF( VALUE .LT. temp .OR. sisnan( temp ) )
524 $ VALUE = temp
525 DO i = j + 2, n
526 temp = abs( a( i+j*lda ) )
527 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
537 $ VALUE = temp
538 END DO
539 i = k + j
540* -> U(i,i)
541 temp = abs( real( a( i+j*lda ) ) )
542 IF( VALUE .LT. temp .OR. sisnan( temp ) )
543 $ VALUE = temp
544 i = i + 1
545* =k+j+1; i -> U(j,j)
546 temp = abs( real( a( i+j*lda ) ) )
547 IF( VALUE .LT. temp .OR. sisnan( temp ) )
548 $ VALUE = temp
549 DO i = k + j + 2, n
550 temp = abs( a( i+j*lda ) )
551 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
558 $ VALUE = temp
559* j=k-1
560 END DO
561* i=n-1 -> U(n-1,n-1)
562 temp = abs( real( a( i+j*lda ) ) )
563 IF( VALUE .LT. temp .OR. sisnan( temp ) )
564 $ VALUE = temp
565 i = n
566* -> U(k-1,k-1)
567 temp = abs( real( a( i+j*lda ) ) )
568 IF( VALUE .LT. temp .OR. sisnan( 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( real( a( j+j*lda ) ) )
578 IF( VALUE .LT. temp .OR. sisnan( temp ) )
579 $ VALUE = temp
580 DO i = 1, k - 1
581 temp = abs( a( i+j*lda ) )
582 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
589 $ VALUE = temp
590 END DO
591 i = j - 1
592* L(i,i)
593 temp = abs( real( a( i+j*lda ) ) )
594 IF( VALUE .LT. temp .OR. sisnan( temp ) )
595 $ VALUE = temp
596 i = j
597* L(j+k,j+k)
598 temp = abs( real( a( i+j*lda ) ) )
599 IF( VALUE .LT. temp .OR. sisnan( temp ) )
600 $ VALUE = temp
601 DO i = j + 1, k - 1
602 temp = abs( a( i+j*lda ) )
603 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
611 $ VALUE = temp
612 END DO
613 i = k - 1
614* -> L(i,i) is at A(i,j)
615 temp = abs( real( a( i+j*lda ) ) )
616 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( 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. sisnan( 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( real( a( 0+j*lda ) ) )
637 IF( VALUE .LT. temp .OR. sisnan( temp ) )
638 $ VALUE = temp
639 DO i = 1, k - 1
640 temp = abs( a( i+j*lda ) )
641 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( temp ) )
648 $ VALUE = temp
649 END DO
650 i = j - k - 1
651* -> U(i,i) at A(i,j)
652 temp = abs( real( a( i+j*lda ) ) )
653 IF( VALUE .LT. temp .OR. sisnan( temp ) )
654 $ VALUE = temp
655 i = j - k
656* U(j,j)
657 temp = abs( real( a( i+j*lda ) ) )
658 IF( VALUE .LT. temp .OR. sisnan( 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. sisnan( 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. sisnan( temp ) )
670 $ VALUE = temp
671 END DO
672 i = k - 1
673* U(k,k) at A(i,j)
674 temp = abs( real( a( i+j*lda ) ) )
675 IF( VALUE .LT. temp .OR. sisnan( 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( real( 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( real( 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. sisnan( 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( real( 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( real( 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. sisnan( 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( real( a( i+j*lda ) ) )
788* -> A(j+k,j+k)
789 work( j+k ) = s + aa
790 i = i + 1
791 aa = abs( real( 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. sisnan( 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( real( 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( real( 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. sisnan( 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( real( 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( real( 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( real( 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. sisnan( 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( real( 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( real( 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( real( 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. sisnan( 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( real( 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( real( 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( real( 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( real( 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. sisnan( 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( real( 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( real( 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( real( 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( real( 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. sisnan( 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 classq( 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 classq( 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 = real( 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 = real( 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 = real( 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 classq( 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 classq( 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 = real( 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 = real( 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 = real( 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 classq( 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 classq( 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 classq( 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 = real( 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 = real( 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 = real( 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 classq( 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 classq( 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 classq( 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 = real( 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 = real( 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 = real( 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 classq( 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 classq( 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 = real( 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 = real( 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 classq( 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 classq( 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 = real( 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 = real( 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 classq( 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 classq( 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 classq( 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 = real( 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 = real( 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 = real( 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 = real( 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 classq( 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 classq( 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 classq( 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 = real( 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 = real( 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 = real( 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 = real( 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 clanhf = VALUE
1566 RETURN
1567*
1568* End of CLANHF
1569*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
clanhf
real function clanhf(norm, transr, uplo, n, a, work)
CLANHF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanhf.f:246

◆ clarscl2()

subroutine clarscl2 ( integer m,
integer n,
real, dimension( * ) d,
complex, dimension( ldx, * ) x,
integer ldx )

CLARSCL2 performs reciprocal diagonal scaling on a vector.

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

Purpose:
!>
!> CLARSCL2 performs a reciprocal diagonal scaling on an vector:
!>   x <-- inv(D) * x
!> where the REAL diagonal matrix D is stored as a vector.
!>
!> Eventually to be replaced by BLAS_cge_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 REAL array, length M
!>     Diagonal matrix D, stored as a vector of length M.
!>
[in,out]X
!>          X is COMPLEX 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 clarscl2.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 X( LDX, * )
101 REAL 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

◆ clarz()

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

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

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

Purpose:
!>
!> CLARZ 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 CTZRZF.
!>
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 array, dimension (1+(L-1)*abs(INCV))
!>          The vector v in the representation of H as returned by
!>          CTZRZF. V is not used if TAU = 0.
!>
[in]INCV
!>          INCV is INTEGER
!>          The increment between elements of v. INCV <> 0.
!>
[in]TAU
!>          TAU is COMPLEX
!>          The value tau in the representation of H.
!>
[in,out]C
!>          C is COMPLEX array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
!>          or C * H if SIDE = 'R'.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                         (N) if SIDE = 'L'
!>                      or (M) if SIDE = 'R'
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
Further Details:
!>

Definition at line 146 of file clarz.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 TAU
156* ..
157* .. Array Arguments ..
158 COMPLEX C( LDC, * ), V( * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 COMPLEX ONE, ZERO
165 parameter( one = ( 1.0e+0, 0.0e+0 ),
166 $ zero = ( 0.0e+0, 0.0e+0 ) )
167* ..
168* .. External Subroutines ..
169 EXTERNAL caxpy, ccopy, cgemv, cgerc, cgeru, clacgv
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 ccopy( n, c, ldc, work, 1 )
186 CALL clacgv( 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 cgemv( 'Conjugate transpose', l, n, one, c( m-l+1, 1 ),
191 $ ldc, v, incv, one, work, 1 )
192 CALL clacgv( n, work, 1 )
193*
194* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
195*
196 CALL caxpy( 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 cgeru( 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 ccopy( 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 cgemv( '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 caxpy( 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 cgerc( 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 CLARZ
237*

◆ clarzb()

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

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

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

Purpose:
!>
!> CLARZB 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 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 array, dimension (LDT,K)
!>          The triangular K-by-K matrix T in the representation of the
!>          block reflector.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= K.
!>
[in,out]C
!>          C is COMPLEX array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LDWORK,K)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.
!>          If SIDE = 'L', LDWORK >= max(1,N);
!>          if SIDE = 'R', LDWORK >= max(1,M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
Further Details:
!>

Definition at line 181 of file clarzb.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 C( LDC, * ), T( LDT, * ), V( LDV, * ),
194 $ WORK( LDWORK, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 COMPLEX ONE
201 parameter( one = ( 1.0e+0, 0.0e+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 ccopy, cgemm, clacgv, ctrmm, xerbla
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( 'CLARZB', -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 ccopy( 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 cgemm( '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 ctrmm( '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 cgemm( '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 ccopy( 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 cgemm( '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 clacgv( k-j+1, t( j, j ), 1 )
300 50 CONTINUE
301 CALL ctrmm( 'Right', 'Lower', trans, 'Non-unit', m, k, one, t,
302 $ ldt, work, ldwork )
303 DO 60 j = 1, k
304 CALL clacgv( 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 clacgv( k, v( 1, j ), 1 )
320 90 CONTINUE
321 IF( l.GT.0 )
322 $ CALL cgemm( '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 clacgv( k, v( 1, j ), 1 )
326 100 CONTINUE
327*
328 END IF
329*
330 RETURN
331*
332* End of CLARZB
333*
ctrmm
subroutine ctrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRMM
Definition ctrmm.f:177

◆ clarzt()

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

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

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

Purpose:
!>
!> CLARZT 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 array, dimension
!>                               (LDV,K) if STOREV = 'C'
!>                               (LDV,N) if STOREV = 'R'
!>          The matrix V. See further details.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V.
!>          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
!>
[in]TAU
!>          TAU is COMPLEX array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i).
!>
[out]T
!>          T is COMPLEX array, dimension (LDT,K)
!>          The k by k triangular factor T of the block reflector.
!>          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
!>          lower triangular. The rest of the array is not used.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= K.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
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 clarzt.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 T( LDT, * ), TAU( * ), V( LDV, * )
196* ..
197*
198* =====================================================================
199*
200* .. Parameters ..
201 COMPLEX ZERO
202 parameter( zero = ( 0.0e+0, 0.0e+0 ) )
203* ..
204* .. Local Scalars ..
205 INTEGER I, INFO, J
206* ..
207* .. External Subroutines ..
208 EXTERNAL cgemv, clacgv, ctrmv, xerbla
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( 'CLARZT', -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 clacgv( n, v( i, 1 ), ldv )
246 CALL cgemv( '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 clacgv( 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 ctrmv( '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 CLARZT
262*

◆ clascl2()

subroutine clascl2 ( integer m,
integer n,
real, dimension( * ) d,
complex, dimension( ldx, * ) x,
integer ldx )

CLASCL2 performs diagonal scaling on a vector.

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

Purpose:
!>
!> CLASCL2 performs a diagonal scaling on a vector:
!>   x <-- D * x
!> where the diagonal REAL matrix D is stored as a vector.
!>
!> Eventually to be replaced by BLAS_cge_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 REAL array, length M
!>     Diagonal matrix D, stored as a vector of length M.
!>
[in,out]X
!>          X is COMPLEX 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 clascl2.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 REAL D( * )
101 COMPLEX 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

◆ clatrz()

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

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

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

Purpose:
!>
!> CLATRZ 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 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 array, dimension (M)
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is COMPLEX 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 clatrz.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 A( LDA, * ), TAU( * ), WORK( * )
150* ..
151*
152* =====================================================================
153*
154* .. Parameters ..
155 COMPLEX ZERO
156 parameter( zero = ( 0.0e+0, 0.0e+0 ) )
157* ..
158* .. Local Scalars ..
159 INTEGER I
160 COMPLEX ALPHA
161* ..
162* .. External Subroutines ..
163 EXTERNAL clacgv, clarfg, clarz
164* ..
165* .. Intrinsic Functions ..
166 INTRINSIC conjg
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 clacgv( l, a( i, n-l+1 ), lda )
187 alpha = conjg( a( i, i ) )
188 CALL clarfg( l+1, alpha, a( i, n-l+1 ), lda, tau( i ) )
189 tau( i ) = conjg( tau( i ) )
190*
191* Apply H(i) to A(1:i-1,i:n) from the right
192*
193 CALL clarz( 'Right', i-1, n-i+1, l, a( i, n-l+1 ), lda,
194 $ conjg( tau( i ) ), a( 1, i ), lda, work )
195 a( i, i ) = conjg( alpha )
196*
197 20 CONTINUE
198*
199 RETURN
200*
201* End of CLATRZ
202*
clarz
subroutine clarz(side, m, n, l, v, incv, tau, c, ldc, work)
CLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix.
Definition clarz.f:147

◆ clatzm()

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

CLATZM

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine CUNMRZ.
!>
!> CLATZM applies a Householder matrix generated by CTZRQF 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 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
!>          The value tau in the representation of P.
!>
[in,out]C1
!>          C1 is COMPLEX 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 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 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 clatzm.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 TAU
161* ..
162* .. Array Arguments ..
163 COMPLEX C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
164* ..
165*
166* =====================================================================
167*
168* .. Parameters ..
169 COMPLEX ONE, ZERO
170 parameter( one = ( 1.0e+0, 0.0e+0 ),
171 $ zero = ( 0.0e+0, 0.0e+0 ) )
172* ..
173* .. External Subroutines ..
174 EXTERNAL caxpy, ccopy, cgemv, cgerc, cgeru, clacgv
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 ccopy( n, c1, ldc, work, 1 )
193 CALL clacgv( n, work, 1 )
194 CALL cgemv( '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 clacgv( n, work, 1 )
201 CALL caxpy( n, -tau, work, 1, c1, ldc )
202 CALL cgeru( 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 ccopy( m, c1, 1, work, 1 )
209 CALL cgemv( '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 caxpy( m, -tau, work, 1, c1, 1 )
215 CALL cgerc( m, n-1, -tau, work, 1, v, incv, c2, ldc )
216 END IF
217*
218 RETURN
219*
220* End of CLATZM
221*

◆ cpbcon()

subroutine cpbcon ( character uplo,
integer n,
integer kd,
complex, dimension( ldab, * ) ab,
integer ldab,
real anorm,
real rcond,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CPBCON

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

Purpose:
!>
!> CPBCON 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
!> CPBTRF.
!>
!> 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 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 REAL
!>          The 1-norm (or infinity-norm) of the Hermitian band matrix A.
!>
[out]RCOND
!>          RCOND is REAL
!>          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 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 131 of file cpbcon.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 REAL ANORM, RCOND
142* ..
143* .. Array Arguments ..
144 REAL RWORK( * )
145 COMPLEX AB( LDAB, * ), WORK( * )
146* ..
147*
148* =====================================================================
149*
150* .. Parameters ..
151 REAL ONE, ZERO
152 parameter( one = 1.0e+0, zero = 0.0e+0 )
153* ..
154* .. Local Scalars ..
155 LOGICAL UPPER
156 CHARACTER NORMIN
157 INTEGER IX, KASE
158 REAL AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
159 COMPLEX ZDUM
160* ..
161* .. Local Arrays ..
162 INTEGER ISAVE( 3 )
163* ..
164* .. External Functions ..
165 LOGICAL LSAME
166 INTEGER ICAMAX
167 REAL SLAMCH
168 EXTERNAL lsame, icamax, slamch
169* ..
170* .. External Subroutines ..
171 EXTERNAL clacn2, clatbs, csrscl, xerbla
172* ..
173* .. Intrinsic Functions ..
174 INTRINSIC abs, aimag, real
175* ..
176* .. Statement Functions ..
177 REAL CABS1
178* ..
179* .. Statement Function definitions ..
180 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CPBCON', -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 = slamch( 'Safe minimum' )
215*
216* Estimate the 1-norm of the inverse.
217*
218 kase = 0
219 normin = 'N'
220 10 CONTINUE
221 CALL clacn2( 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 clatbs( '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 clatbs( '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 clatbs( '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 clatbs( '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 = icamax( n, work, 1 )
256 IF( scale.LT.cabs1( work( ix ) )*smlnum .OR. scale.EQ.zero )
257 $ GO TO 20
258 CALL csrscl( 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 CPBCON
273*
clatbs
subroutine clatbs(uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
CLATBS solves a triangular banded system of equations.
Definition clatbs.f:243
csrscl
subroutine csrscl(n, sa, sx, incx)
CSRSCL multiplies a vector by the reciprocal of a real scalar.
Definition csrscl.f:84

◆ cpbequ()

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

CPBEQU

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

Purpose:
!>
!> CPBEQU 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 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 REAL array, dimension (N)
!>          If INFO = 0, S contains the scale factors for A.
!>
[out]SCOND
!>          SCOND is REAL
!>          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 REAL
!>          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 cpbequ.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 REAL AMAX, SCOND
139* ..
140* .. Array Arguments ..
141 REAL S( * )
142 COMPLEX AB( LDAB, * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 REAL ZERO, ONE
149 parameter( zero = 0.0e+0, one = 1.0e+0 )
150* ..
151* .. Local Scalars ..
152 LOGICAL UPPER
153 INTEGER I, J
154 REAL SMIN
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 EXTERNAL lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL xerbla
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC max, min, real, 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( 'CPBEQU', -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 ) = real( 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 ) = real( 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 CPBEQU
240*

◆ cpbrfs()

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

CPBRFS

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

Purpose:
!>
!> CPBRFS 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 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 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
!>          CPBTRF, 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 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 array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by CPBTRS.
!>          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 REAL 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 REAL 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 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
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 cpbrfs.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 REAL BERR( * ), FERR( * ), RWORK( * )
200 COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
201 $ WORK( * ), X( LDX, * )
202* ..
203*
204* =====================================================================
205*
206* .. Parameters ..
207 INTEGER ITMAX
208 parameter( itmax = 5 )
209 REAL ZERO
210 parameter( zero = 0.0e+0 )
211 COMPLEX ONE
212 parameter( one = ( 1.0e+0, 0.0e+0 ) )
213 REAL TWO
214 parameter( two = 2.0e+0 )
215 REAL THREE
216 parameter( three = 3.0e+0 )
217* ..
218* .. Local Scalars ..
219 LOGICAL UPPER
220 INTEGER COUNT, I, J, K, KASE, L, NZ
221 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
222 COMPLEX ZDUM
223* ..
224* .. Local Arrays ..
225 INTEGER ISAVE( 3 )
226* ..
227* .. External Subroutines ..
228 EXTERNAL caxpy, ccopy, chbmv, clacn2, cpbtrs, xerbla
229* ..
230* .. Intrinsic Functions ..
231 INTRINSIC abs, aimag, max, min, real
232* ..
233* .. External Functions ..
234 LOGICAL LSAME
235 REAL SLAMCH
236 EXTERNAL lsame, slamch
237* ..
238* .. Statement Functions ..
239 REAL CABS1
240* ..
241* .. Statement Function definitions ..
242 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CPBRFS', -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 = slamch( 'Epsilon' )
286 safmin = slamch( '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 ccopy( n, b( 1, j ), 1, work, 1 )
303 CALL chbmv( 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( real( 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( real( 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 cpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info )
369 CALL caxpy( 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 CLACN2 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 clacn2( 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 cpbtrs( 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 cpbtrs( 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 CPBRFS
444*
cpbtrs
subroutine cpbtrs(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
CPBTRS
Definition cpbtrs.f:121
chbmv
subroutine chbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
CHBMV
Definition chbmv.f:187

◆ cpbstf()

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

CPBSTF

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

Purpose:
!>
!> CPBSTF computes a split Cholesky factorization of a complex
!> Hermitian positive definite band matrix A.
!>
!> This routine is designed to be used in conjunction with CHBGST.
!>
!> 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 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 cpbstf.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 AB( LDAB, * )
164* ..
165*
166* =====================================================================
167*
168* .. Parameters ..
169 REAL ONE, ZERO
170 parameter( one = 1.0e+0, zero = 0.0e+0 )
171* ..
172* .. Local Scalars ..
173 LOGICAL UPPER
174 INTEGER J, KLD, KM, M
175 REAL AJJ
176* ..
177* .. External Functions ..
178 LOGICAL LSAME
179 EXTERNAL lsame
180* ..
181* .. External Subroutines ..
182 EXTERNAL cher, clacgv, csscal, xerbla
183* ..
184* .. Intrinsic Functions ..
185 INTRINSIC max, min, real, 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( 'CPBSTF', -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 = real( 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 csscal( km, one / ajj, ab( kd+1-km, j ), 1 )
239 CALL cher( '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 = real( 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 csscal( km, one / ajj, ab( kd, j+1 ), kld )
263 CALL clacgv( km, ab( kd, j+1 ), kld )
264 CALL cher( 'Upper', km, -one, ab( kd, j+1 ), kld,
265 $ ab( kd+1, j+1 ), kld )
266 CALL clacgv( 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 = real( 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 csscal( km, one / ajj, ab( km+1, j-km ), kld )
290 CALL clacgv( km, ab( km+1, j-km ), kld )
291 CALL cher( 'Lower', km, -one, ab( km+1, j-km ), kld,
292 $ ab( 1, j-km ), kld )
293 CALL clacgv( 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 = real( 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 csscal( km, one / ajj, ab( 2, j ), 1 )
316 CALL cher( '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 CPBSTF
328*
cher
subroutine cher(uplo, n, alpha, x, incx, a, lda)
CHER
Definition cher.f:135

◆ cpbtf2()

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

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

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

Purpose:
!>
!> CPBTF2 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 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 cpbtf2.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 AB( LDAB, * )
153* ..
154*
155* =====================================================================
156*
157* .. Parameters ..
158 REAL ONE, ZERO
159 parameter( one = 1.0e+0, zero = 0.0e+0 )
160* ..
161* .. Local Scalars ..
162 LOGICAL UPPER
163 INTEGER J, KLD, KN
164 REAL AJJ
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 EXTERNAL lsame
169* ..
170* .. External Subroutines ..
171 EXTERNAL cher, clacgv, csscal, xerbla
172* ..
173* .. Intrinsic Functions ..
174 INTRINSIC max, min, real, 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( 'CPBTF2', -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 = real( 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 csscal( kn, one / ajj, ab( kd, j+1 ), kld )
225 CALL clacgv( kn, ab( kd, j+1 ), kld )
226 CALL cher( 'Upper', kn, -one, ab( kd, j+1 ), kld,
227 $ ab( kd+1, j+1 ), kld )
228 CALL clacgv( 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 = real( 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 csscal( kn, one / ajj, ab( 2, j ), 1 )
253 CALL cher( '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 CPBTF2
265*

◆ cpbtrf()

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

CPBTRF

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

Purpose:
!>
!> CPBTRF 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 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 cpbtrf.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 AB( LDAB, * )
153* ..
154*
155* =====================================================================
156*
157* .. Parameters ..
158 REAL ONE, ZERO
159 parameter( one = 1.0e+0, zero = 0.0e+0 )
160 COMPLEX CONE
161 parameter( cone = ( 1.0e+0, 0.0e+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 WORK( LDWORK, NBMAX )
170* ..
171* .. External Functions ..
172 LOGICAL LSAME
173 INTEGER ILAENV
174 EXTERNAL lsame, ilaenv
175* ..
176* .. External Subroutines ..
177 EXTERNAL cgemm, cherk, cpbtf2, cpotf2, ctrsm, xerbla
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( 'CPBTRF', -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, 'CPBTRF', 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 cpbtf2( 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 cpotf2( 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 ctrsm( '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 cherk( '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 ctrsm( '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 cgemm( '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 cherk( '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 cpotf2( 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 ctrsm( '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 cherk( '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 ctrsm( '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 cgemm( '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 cherk( '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 CPBTRF
438*
cpbtf2
subroutine cpbtf2(uplo, n, kd, ab, ldab, info)
CPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (un...
Definition cpbtf2.f:142
cpotf2
subroutine cpotf2(uplo, n, a, lda, info)
CPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblock...
Definition cpotf2.f:109
ctrsm
subroutine ctrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRSM
Definition ctrsm.f:180

◆ cpbtrs()

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

CPBTRS

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

Purpose:
!>
!> CPBTRS 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 CPBTRF.
!>
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 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 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 cpbtrs.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 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 ctbsv, xerbla
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( 'CPBTRS', -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 ctbsv( '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 ctbsv( '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 ctbsv( '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 ctbsv( '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 CPBTRS
216*
ctbsv
subroutine ctbsv(uplo, trans, diag, n, k, a, lda, x, incx)
CTBSV
Definition ctbsv.f:189

◆ cpftrf()

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

CPFTRF

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

Purpose:
!>
!> CPFTRF 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 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 cpftrf.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 A( 0: * )
222*
223* =====================================================================
224*
225* .. Parameters ..
226 REAL ONE
227 COMPLEX CONE
228 parameter( one = 1.0e+0, cone = ( 1.0e+0, 0.0e+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, cherk, cpotrf, ctrsm
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( 'CPFTRF', -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 cpotrf( 'L', n1, a( 0 ), n, info )
305 IF( info.GT.0 )
306 $ RETURN
307 CALL ctrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0 ), n,
308 $ a( n1 ), n )
309 CALL cherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,
310 $ a( n ), n )
311 CALL cpotrf( '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 cpotrf( 'L', n1, a( n2 ), n, info )
322 IF( info.GT.0 )
323 $ RETURN
324 CALL ctrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,
325 $ a( 0 ), n )
326 CALL cherk( 'U', 'C', n2, n1, -one, a( 0 ), n, one,
327 $ a( n1 ), n )
328 CALL cpotrf( '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 cpotrf( 'U', n1, a( 0 ), n1, info )
345 IF( info.GT.0 )
346 $ RETURN
347 CALL ctrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0 ), n1,
348 $ a( n1*n1 ), n1 )
349 CALL cherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,
350 $ a( 1 ), n1 )
351 CALL cpotrf( '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 cpotrf( 'U', n1, a( n2*n2 ), n2, info )
362 IF( info.GT.0 )
363 $ RETURN
364 CALL ctrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),
365 $ n2, a( 0 ), n2 )
366 CALL cherk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,
367 $ a( n1*n2 ), n2 )
368 CALL cpotrf( '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 cpotrf( 'L', k, a( 1 ), n+1, info )
391 IF( info.GT.0 )
392 $ RETURN
393 CALL ctrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1 ), n+1,
394 $ a( k+1 ), n+1 )
395 CALL cherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,
396 $ a( 0 ), n+1 )
397 CALL cpotrf( '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 cpotrf( 'L', k, a( k+1 ), n+1, info )
408 IF( info.GT.0 )
409 $ RETURN
410 CALL ctrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),
411 $ n+1, a( 0 ), n+1 )
412 CALL cherk( 'U', 'C', k, k, -one, a( 0 ), n+1, one,
413 $ a( k ), n+1 )
414 CALL cpotrf( '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 cpotrf( 'U', k, a( 0+k ), k, info )
431 IF( info.GT.0 )
432 $ RETURN
433 CALL ctrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,
434 $ a( k*( k+1 ) ), k )
435 CALL cherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,
436 $ a( 0 ), k )
437 CALL cpotrf( '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 cpotrf( 'U', k, a( k*( k+1 ) ), k, info )
448 IF( info.GT.0 )
449 $ RETURN
450 CALL ctrsm( 'R', 'U', 'N', 'N', k, k, cone,
451 $ a( k*( k+1 ) ), k, a( 0 ), k )
452 CALL cherk( 'L', 'N', k, k, -one, a( 0 ), k, one,
453 $ a( k*k ), k )
454 CALL cpotrf( '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 CPFTRF
467*
cpotrf
subroutine cpotrf(uplo, n, a, lda, info)
CPOTRF
Definition cpotrf.f:107

◆ cpftri()

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

CPFTRI

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

Purpose:
!>
!> CPFTRI 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 CPFTRF.
!>
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 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 cpftri.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 A( 0: * )
222* ..
223*
224* =====================================================================
225*
226* .. Parameters ..
227 REAL ONE
228 COMPLEX CONE
229 parameter( one = 1.0e+0, cone = ( 1.0e+0, 0.0e+0 ) )
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, ctftri, clauum, ctrmm, cherk
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( 'CPFTRI', -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 ctftri( 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 clauum( 'L', n1, a( 0 ), n, info )
313 CALL cherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,
314 $ a( 0 ), n )
315 CALL ctrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,
316 $ a( n1 ), n )
317 CALL clauum( '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 clauum( 'L', n1, a( n2 ), n, info )
326 CALL cherk( 'L', 'N', n1, n2, one, a( 0 ), n, one,
327 $ a( n2 ), n )
328 CALL ctrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,
329 $ a( 0 ), n )
330 CALL clauum( '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 clauum( 'U', n1, a( 0 ), n1, info )
344 CALL cherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,
345 $ a( 0 ), n1 )
346 CALL ctrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1 ), n1,
347 $ a( n1*n1 ), n1 )
348 CALL clauum( '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 clauum( 'U', n1, a( n2*n2 ), n2, info )
356 CALL cherk( 'U', 'C', n1, n2, one, a( 0 ), n2, one,
357 $ a( n2*n2 ), n2 )
358 CALL ctrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),
359 $ n2, a( 0 ), n2 )
360 CALL clauum( '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 clauum( 'L', k, a( 1 ), n+1, info )
381 CALL cherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,
382 $ a( 1 ), n+1 )
383 CALL ctrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0 ), n+1,
384 $ a( k+1 ), n+1 )
385 CALL clauum( '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 clauum( 'L', k, a( k+1 ), n+1, info )
394 CALL cherk( 'L', 'N', k, k, one, a( 0 ), n+1, one,
395 $ a( k+1 ), n+1 )
396 CALL ctrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,
397 $ a( 0 ), n+1 )
398 CALL clauum( '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 clauum( 'U', k, a( k ), k, info )
413 CALL cherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,
414 $ a( k ), k )
415 CALL ctrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0 ), k,
416 $ a( k*( k+1 ) ), k )
417 CALL clauum( '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 clauum( 'U', k, a( k*( k+1 ) ), k, info )
426 CALL cherk( 'U', 'C', k, k, one, a( 0 ), k, one,
427 $ a( k*( k+1 ) ), k )
428 CALL ctrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,
429 $ a( 0 ), k )
430 CALL clauum( '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 CPFTRI
441*
clauum
subroutine clauum(uplo, n, a, lda, info)
CLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked...
Definition clauum.f:102
ctftri
subroutine ctftri(transr, uplo, diag, n, a, info)
CTFTRI
Definition ctftri.f:221

◆ cpftrs()

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

CPFTRS

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

Purpose:
!>
!> CPFTRS 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 CPFTRF.
!>
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 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 CPFTRF.
!>          See note below for more details about RFP A.
!>
[in,out]B
!>          B is COMPLEX 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 cpftrs.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 A( 0: * ), B( LDB, * )
231* ..
232*
233* =====================================================================
234*
235* .. Parameters ..
236 COMPLEX CONE
237 parameter( cone = ( 1.0e+0, 0.0e+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, ctfsm
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( 'CPFTRS', -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 ctfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,
284 $ ldb )
285 CALL ctfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,
286 $ ldb )
287 ELSE
288 CALL ctfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,
289 $ ldb )
290 CALL ctfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,
291 $ ldb )
292 END IF
293*
294 RETURN
295*
296* End of CPFTRS
297*
ctfsm
subroutine ctfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
CTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition ctfsm.f:298

◆ cppcon()

subroutine cppcon ( character uplo,
integer n,
complex, dimension( * ) ap,
real anorm,
real rcond,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CPPCON

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

Purpose:
!>
!> CPPCON 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
!> CPPTRF.
!>
!> 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 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 REAL
!>          The 1-norm (or infinity-norm) of the Hermitian matrix A.
!>
[out]RCOND
!>          RCOND is REAL
!>          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 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file cppcon.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 REAL ANORM, RCOND
127* ..
128* .. Array Arguments ..
129 REAL RWORK( * )
130 COMPLEX AP( * ), WORK( * )
131* ..
132*
133* =====================================================================
134*
135* .. Parameters ..
136 REAL ONE, ZERO
137 parameter( one = 1.0e+0, zero = 0.0e+0 )
138* ..
139* .. Local Scalars ..
140 LOGICAL UPPER
141 CHARACTER NORMIN
142 INTEGER IX, KASE
143 REAL AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
144 COMPLEX ZDUM
145* ..
146* .. Local Arrays ..
147 INTEGER ISAVE( 3 )
148* ..
149* .. External Functions ..
150 LOGICAL LSAME
151 INTEGER ICAMAX
152 REAL SLAMCH
153 EXTERNAL lsame, icamax, slamch
154* ..
155* .. External Subroutines ..
156 EXTERNAL clacn2, clatps, csrscl, xerbla
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC abs, aimag, real
160* ..
161* .. Statement Functions ..
162 REAL CABS1
163* ..
164* .. Statement Function definitions ..
165 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CPPCON', -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 = slamch( 'Safe minimum' )
196*
197* Estimate the 1-norm of the inverse.
198*
199 kase = 0
200 normin = 'N'
201 10 CONTINUE
202 CALL clacn2( 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 clatps( '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 clatps( 'Upper', 'No transpose', 'Non-unit', normin, n,
215 $ ap, work, scaleu, rwork, info )
216 ELSE
217*
218* Multiply by inv(L).
219*
220 CALL clatps( '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 clatps( '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 = icamax( n, work, 1 )
235 IF( scale.LT.cabs1( work( ix ) )*smlnum .OR. scale.EQ.zero )
236 $ GO TO 20
237 CALL csrscl( 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 CPPCON
251*
clatps
subroutine clatps(uplo, trans, diag, normin, n, ap, x, scale, cnorm, info)
CLATPS solves a triangular system of equations with the matrix held in packed storage.
Definition clatps.f:231

◆ cppequ()

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

CPPEQU

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

Purpose:
!>
!> CPPEQU 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 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 REAL array, dimension (N)
!>          If INFO = 0, S contains the scale factors for A.
!>
[out]SCOND
!>          SCOND is REAL
!>          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 REAL
!>          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 cppequ.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 REAL AMAX, SCOND
126* ..
127* .. Array Arguments ..
128 REAL S( * )
129 COMPLEX AP( * )
130* ..
131*
132* =====================================================================
133*
134* .. Parameters ..
135 REAL ONE, ZERO
136 parameter( one = 1.0e+0, zero = 0.0e+0 )
137* ..
138* .. Local Scalars ..
139 LOGICAL UPPER
140 INTEGER I, JJ
141 REAL SMIN
142* ..
143* .. External Functions ..
144 LOGICAL LSAME
145 EXTERNAL lsame
146* ..
147* .. External Subroutines ..
148 EXTERNAL xerbla
149* ..
150* .. Intrinsic Functions ..
151 INTRINSIC max, min, real, 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( 'CPPEQU', -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 ) = real( 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 ) = real( 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 ) = real( 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 CPPEQU
236*

◆ cpprfs()

subroutine cpprfs ( character uplo,
integer n,
integer nrhs,
complex, dimension( * ) ap,
complex, dimension( * ) afp,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldx, * ) x,
integer ldx,
real, dimension( * ) ferr,
real, dimension( * ) berr,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CPPRFS

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

Purpose:
!>
!> CPPRFS 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 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 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 SPPTRF/CPPTRF,
!>          packed columnwise in a linear array in the same format as A
!>          (see AP).
!>
[in]B
!>          B is COMPLEX 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 array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by CPPTRS.
!>          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 REAL 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 REAL 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 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
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 cpprfs.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 REAL BERR( * ), FERR( * ), RWORK( * )
182 COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
183 $ X( LDX, * )
184* ..
185*
186* ====================================================================
187*
188* .. Parameters ..
189 INTEGER ITMAX
190 parameter( itmax = 5 )
191 REAL ZERO
192 parameter( zero = 0.0e+0 )
193 COMPLEX CONE
194 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
195 REAL TWO
196 parameter( two = 2.0e+0 )
197 REAL THREE
198 parameter( three = 3.0e+0 )
199* ..
200* .. Local Scalars ..
201 LOGICAL UPPER
202 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
203 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
204 COMPLEX ZDUM
205* ..
206* .. Local Arrays ..
207 INTEGER ISAVE( 3 )
208* ..
209* .. External Subroutines ..
210 EXTERNAL caxpy, ccopy, chpmv, clacn2, cpptrs, xerbla
211* ..
212* .. Intrinsic Functions ..
213 INTRINSIC abs, aimag, max, real
214* ..
215* .. External Functions ..
216 LOGICAL LSAME
217 REAL SLAMCH
218 EXTERNAL lsame, slamch
219* ..
220* .. Statement Functions ..
221 REAL CABS1
222* ..
223* .. Statement Function definitions ..
224 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CPPRFS', -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 = slamch( 'Epsilon' )
262 safmin = slamch( '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 ccopy( n, b( 1, j ), 1, work, 1 )
279 CALL chpmv( 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( real( 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( real( 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 cpptrs( uplo, n, 1, afp, work, n, info )
349 CALL caxpy( 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 CLACN2 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 clacn2( 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 cpptrs( 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 cpptrs( 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 CPPRFS
424*
cpptrs
subroutine cpptrs(uplo, n, nrhs, ap, b, ldb, info)
CPPTRS
Definition cpptrs.f:108

◆ cpptrf()

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

CPPTRF

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

Purpose:
!>
!> CPPTRF 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 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 cpptrf.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 AP( * )
130* ..
131*
132* =====================================================================
133*
134* .. Parameters ..
135 REAL ZERO, ONE
136 parameter( zero = 0.0e+0, one = 1.0e+0 )
137* ..
138* .. Local Scalars ..
139 LOGICAL UPPER
140 INTEGER J, JC, JJ
141 REAL AJJ
142* ..
143* .. External Functions ..
144 LOGICAL LSAME
145 COMPLEX CDOTC
146 EXTERNAL lsame, cdotc
147* ..
148* .. External Subroutines ..
149 EXTERNAL chpr, csscal, ctpsv, xerbla
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC real, 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( 'CPPTRF', -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 ctpsv( '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 = real( real( ap( jj ) ) - cdotc( 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 = real( 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 csscal( n-j, one / ajj, ap( jj+1 ), 1 )
222 CALL chpr( '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 CPPTRF
237*
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ cpptri()

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

CPPTRI

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

Purpose:
!>
!> CPPTRI 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 CPPTRF.
!>
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 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 cpptri.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 AP( * )
104* ..
105*
106* =====================================================================
107*
108* .. Parameters ..
109 REAL ONE
110 parameter( one = 1.0e+0 )
111* ..
112* .. Local Scalars ..
113 LOGICAL UPPER
114 INTEGER J, JC, JJ, JJN
115 REAL AJJ
116* ..
117* .. External Functions ..
118 LOGICAL LSAME
119 COMPLEX CDOTC
120 EXTERNAL lsame, cdotc
121* ..
122* .. External Subroutines ..
123 EXTERNAL chpr, csscal, ctpmv, ctptri, xerbla
124* ..
125* .. Intrinsic Functions ..
126 INTRINSIC real
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( 'CPPTRI', -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 ctptri( 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 chpr( 'Upper', j-1, one, ap( jc ), 1, ap )
164 ajj = real( ap( jj ) )
165 CALL csscal( 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 ) = real( cdotc( n-j+1, ap( jj ), 1, ap( jj ), 1 ) )
176 IF( j.LT.n )
177 $ CALL ctpmv( '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 CPPTRI
186*
ctptri
subroutine ctptri(uplo, diag, n, ap, info)
CTPTRI
Definition ctptri.f:117

◆ cpptrs()

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

CPPTRS

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

Purpose:
!>
!> CPPTRS 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 CPPTRF.
!>
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 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 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 cpptrs.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 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 ctpsv, xerbla
133* ..
134* .. Intrinsic Functions ..
135 INTRINSIC max
136* ..
137* .. Executable Statements ..
138*
139* Test the input parameters.
140*
141 info = 0
142 upper = lsame( uplo, 'U' )
143 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
144 info = -1
145 ELSE IF( n.LT.0 ) THEN
146 info = -2
147 ELSE IF( 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( 'CPPTRS', -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 ctpsv( '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 ctpsv( '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 ctpsv( '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 ctpsv( '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 CPPTRS
199*

◆ cpstf2()

subroutine cpstf2 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( n ) piv,
integer rank,
real tol,
real, dimension( 2*n ) work,
integer info )

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

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

Purpose:
!>
!> CPSTF2 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 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 REAL
!>          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 REAL 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 cpstf2.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 REAL TOL
149 INTEGER INFO, LDA, N, RANK
150 CHARACTER UPLO
151* ..
152* .. Array Arguments ..
153 COMPLEX A( LDA, * )
154 REAL WORK( 2*N )
155 INTEGER PIV( N )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 REAL ONE, ZERO
162 parameter( one = 1.0e+0, zero = 0.0e+0 )
163 COMPLEX CONE
164 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
165* ..
166* .. Local Scalars ..
167 COMPLEX CTEMP
168 REAL AJJ, SSTOP, STEMP
169 INTEGER I, ITEMP, J, PVT
170 LOGICAL UPPER
171* ..
172* .. External Functions ..
173 REAL SLAMCH
174 LOGICAL LSAME, SISNAN
175 EXTERNAL slamch, lsame, sisnan
176* ..
177* .. External Subroutines ..
178 EXTERNAL cgemv, clacgv, csscal, cswap, xerbla
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC conjg, max, real, 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( 'CPSTF2', -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 ) = real( a( i, i ) )
216 110 CONTINUE
217 pvt = maxloc( work( 1:n ), 1 )
218 ajj = real( a( pvt, pvt ) )
219 IF( ajj.LE.zero.OR.sisnan( 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 sstop = n * slamch( 'Epsilon' ) * ajj
229 ELSE
230 sstop = 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 $ real( conjg( a( j-1, i ) )*
254 $ a( j-1, i ) )
255 END IF
256 work( n+i ) = real( 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.sstop.OR.sisnan( 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 cswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 )
276 IF( pvt.LT.n )
277 $ CALL cswap( n-pvt, a( j, pvt+1 ), lda,
278 $ a( pvt, pvt+1 ), lda )
279 DO 140 i = j + 1, pvt - 1
280 ctemp = conjg( a( j, i ) )
281 a( j, i ) = conjg( a( i, pvt ) )
282 a( i, pvt ) = ctemp
283 140 CONTINUE
284 a( j, pvt ) = conjg( a( j, pvt ) )
285*
286* Swap dot products and PIV
287*
288 stemp = work( j )
289 work( j ) = work( pvt )
290 work( pvt ) = stemp
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 clacgv( j-1, a( 1, j ), 1 )
303 CALL cgemv( 'Trans', j-1, n-j, -cone, a( 1, j+1 ), lda,
304 $ a( 1, j ), 1, cone, a( j, j+1 ), lda )
305 CALL clacgv( j-1, a( 1, j ), 1 )
306 CALL csscal( 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 $ real( conjg( a( i, j-1 ) )*
326 $ a( i, j-1 ) )
327 END IF
328 work( n+i ) = real( 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.sstop.OR.sisnan( 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 cswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda )
348 IF( pvt.LT.n )
349 $ CALL cswap( n-pvt, a( pvt+1, j ), 1, a( pvt+1, pvt ),
350 $ 1 )
351 DO 170 i = j + 1, pvt - 1
352 ctemp = conjg( a( i, j ) )
353 a( i, j ) = conjg( a( pvt, i ) )
354 a( pvt, i ) = ctemp
355 170 CONTINUE
356 a( pvt, j ) = conjg( a( pvt, j ) )
357*
358* Swap dot products and PIV
359*
360 stemp = work( j )
361 work( j ) = work( pvt )
362 work( pvt ) = stemp
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 clacgv( j-1, a( j, 1 ), lda )
375 CALL cgemv( '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 clacgv( j-1, a( j, 1 ), lda )
378 CALL csscal( 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 CPSTF2
402*

◆ cpstrf()

subroutine cpstrf ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( n ) piv,
integer rank,
real tol,
real, dimension( 2*n ) work,
integer info )

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

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

Purpose:
!>
!> CPSTRF 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 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 REAL
!>          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 REAL 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 cpstrf.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 REAL TOL
149 INTEGER INFO, LDA, N, RANK
150 CHARACTER UPLO
151* ..
152* .. Array Arguments ..
153 COMPLEX A( LDA, * )
154 REAL WORK( 2*N )
155 INTEGER PIV( N )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 REAL ONE, ZERO
162 parameter( one = 1.0e+0, zero = 0.0e+0 )
163 COMPLEX CONE
164 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
165* ..
166* .. Local Scalars ..
167 COMPLEX CTEMP
168 REAL AJJ, SSTOP, STEMP
169 INTEGER I, ITEMP, J, JB, K, NB, PVT
170 LOGICAL UPPER
171* ..
172* .. External Functions ..
173 REAL SLAMCH
174 INTEGER ILAENV
175 LOGICAL LSAME, SISNAN
176 EXTERNAL slamch, ilaenv, lsame, sisnan
177* ..
178* .. External Subroutines ..
179 EXTERNAL cgemv, cherk, clacgv, cpstf2, csscal, cswap,
180 $ xerbla
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC conjg, max, min, real, 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( 'CPSTRF', -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, 'CPOTRF', uplo, n, -1, -1, -1 )
211 IF( nb.LE.1 .OR. nb.GE.n ) THEN
212*
213* Use unblocked code
214*
215 CALL cpstf2( 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 ) = real( a( i, i ) )
231 110 CONTINUE
232 pvt = maxloc( work( 1:n ), 1 )
233 ajj = real( a( pvt, pvt ) )
234 IF( ajj.LE.zero.OR.sisnan( 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 sstop = n * slamch( 'Epsilon' ) * ajj
244 ELSE
245 sstop = 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 $ real( conjg( a( j-1, i ) )*
277 $ a( j-1, i ) )
278 END IF
279 work( n+i ) = real( 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.sstop.OR.sisnan( 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 cswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 )
299 IF( pvt.LT.n )
300 $ CALL cswap( n-pvt, a( j, pvt+1 ), lda,
301 $ a( pvt, pvt+1 ), lda )
302 DO 140 i = j + 1, pvt - 1
303 ctemp = conjg( a( j, i ) )
304 a( j, i ) = conjg( a( i, pvt ) )
305 a( i, pvt ) = ctemp
306 140 CONTINUE
307 a( j, pvt ) = conjg( a( j, pvt ) )
308*
309* Swap dot products and PIV
310*
311 stemp = work( j )
312 work( j ) = work( pvt )
313 work( pvt ) = stemp
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 clacgv( j-1, a( 1, j ), 1 )
326 CALL cgemv( '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 clacgv( j-1, a( 1, j ), 1 )
330 CALL csscal( 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 cherk( '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 $ real( conjg( a( i, j-1 ) )*
372 $ a( i, j-1 ) )
373 END IF
374 work( n+i ) = real( 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.sstop.OR.sisnan( 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 cswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda )
394 IF( pvt.LT.n )
395 $ CALL cswap( n-pvt, a( pvt+1, j ), 1,
396 $ a( pvt+1, pvt ), 1 )
397 DO 190 i = j + 1, pvt - 1
398 ctemp = conjg( a( i, j ) )
399 a( i, j ) = conjg( a( pvt, i ) )
400 a( pvt, i ) = ctemp
401 190 CONTINUE
402 a( pvt, j ) = conjg( a( pvt, j ) )
403*
404* Swap dot products and PIV
405*
406 stemp = work( j )
407 work( j ) = work( pvt )
408 work( pvt ) = stemp
409 itemp = piv( pvt )
410 piv( pvt ) = piv( j )
411 piv( j ) = itemp
412 END IF
413*
414 ajj = sqrt( ajj )
415 a( j, j ) = ajj
416*
417* Compute elements J+1:N of column J.
418*
419 IF( j.LT.n ) THEN
420 CALL clacgv( j-1, a( j, 1 ), lda )
421 CALL cgemv( 'No Trans', n-j, j-k, -cone,
422 $ a( j+1, k ), lda, a( j, k ), lda, cone,
423 $ a( j+1, j ), 1 )
424 CALL clacgv( j-1, a( j, 1 ), lda )
425 CALL csscal( n-j, one / ajj, a( j+1, j ), 1 )
426 END IF
427*
428 200 CONTINUE
429*
430* Update trailing matrix, J already incremented
431*
432 IF( k+jb.LE.n ) THEN
433 CALL cherk( 'Lower', 'No Trans', n-j+1, jb, -one,
434 $ a( j, k ), lda, one, a( j, j ), lda )
435 END IF
436*
437 210 CONTINUE
438*
439 END IF
440 END IF
441*
442* Ran to completion, A has full rank
443*
444 rank = n
445*
446 GO TO 230
447 220 CONTINUE
448*
449* Rank is the number of steps completed. Set INFO = 1 to signal
450* that the factorization cannot be used to solve a system.
451*
452 rank = j - 1
453 info = 1
454*
455 230 CONTINUE
456 RETURN
457*
458* End of CPSTRF
459*
cpstf2
subroutine cpstf2(uplo, n, a, lda, piv, rank, tol, work, info)
CPSTF2 computes the Cholesky factorization with complete pivoting of complex Hermitian positive semid...
Definition cpstf2.f:142

◆ cspcon()

subroutine cspcon ( character uplo,
integer n,
complex, dimension( * ) ap,
integer, dimension( * ) ipiv,
real anorm,
real rcond,
complex, dimension( * ) work,
integer info )

CSPCON

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

Purpose:
!>
!> CSPCON 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 CSPTRF.
!>
!> 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 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 CSPTRF, 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 CSPTRF.
!>
[in]ANORM
!>          ANORM is REAL
!>          The 1-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is REAL
!>          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 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 cspcon.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 REAL ANORM, RCOND
127* ..
128* .. Array Arguments ..
129 INTEGER IPIV( * )
130 COMPLEX AP( * ), WORK( * )
131* ..
132*
133* =====================================================================
134*
135* .. Parameters ..
136 REAL ONE, ZERO
137 parameter( one = 1.0e+0, zero = 0.0e+0 )
138* ..
139* .. Local Scalars ..
140 LOGICAL UPPER
141 INTEGER I, IP, KASE
142 REAL 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 clacn2, csptrs, xerbla
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( 'CSPCON', -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 clacn2( 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 csptrs( 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 CSPCON
227*
csptrs
subroutine csptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
CSPTRS
Definition csptrs.f:115

◆ csprfs()

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

CSPRFS

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

Purpose:
!>
!> CSPRFS 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 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 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 CSPTRF, 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 CSPTRF.
!>
[in]B
!>          B is COMPLEX 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 array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by CSPTRS.
!>          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 REAL 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 REAL 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 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
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 csprfs.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 REAL BERR( * ), FERR( * ), RWORK( * )
192 COMPLEX AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
193 $ X( LDX, * )
194* ..
195*
196* =====================================================================
197*
198* .. Parameters ..
199 INTEGER ITMAX
200 parameter( itmax = 5 )
201 REAL ZERO
202 parameter( zero = 0.0e+0 )
203 COMPLEX ONE
204 parameter( one = ( 1.0e+0, 0.0e+0 ) )
205 REAL TWO
206 parameter( two = 2.0e+0 )
207 REAL THREE
208 parameter( three = 3.0e+0 )
209* ..
210* .. Local Scalars ..
211 LOGICAL UPPER
212 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
213 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
214 COMPLEX ZDUM
215* ..
216* .. Local Arrays ..
217 INTEGER ISAVE( 3 )
218* ..
219* .. External Subroutines ..
220 EXTERNAL caxpy, ccopy, clacn2, cspmv, csptrs, xerbla
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC abs, aimag, max, real
224* ..
225* .. External Functions ..
226 LOGICAL LSAME
227 REAL SLAMCH
228 EXTERNAL lsame, slamch
229* ..
230* .. Statement Functions ..
231 REAL CABS1
232* ..
233* .. Statement Function definitions ..
234 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CSPRFS', -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 = slamch( 'Epsilon' )
272 safmin = slamch( '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 ccopy( n, b( 1, j ), 1, work, 1 )
289 CALL cspmv( 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 csptrs( uplo, n, 1, afp, ipiv, work, n, info )
358 CALL caxpy( 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 CLACN2 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 clacn2( 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 csptrs( 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 csptrs( 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 CSPRFS
433*
cspmv
subroutine cspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
CSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix
Definition cspmv.f:151

◆ csptrf()

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

CSPTRF

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

Purpose:
!>
!> CSPTRF 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 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 csptrf.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 AP( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 REAL ZERO, ONE
176 parameter( zero = 0.0e+0, one = 1.0e+0 )
177 REAL EIGHT, SEVTEN
178 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
179 COMPLEX CONE
180 parameter( cone = ( 1.0e+0, 0.0e+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 REAL ABSAKK, ALPHA, COLMAX, ROWMAX
187 COMPLEX D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, ZDUM
188* ..
189* .. External Functions ..
190 LOGICAL LSAME
191 INTEGER ICAMAX
192 EXTERNAL lsame, icamax
193* ..
194* .. External Subroutines ..
195 EXTERNAL cscal, cspr, cswap, xerbla
196* ..
197* .. Intrinsic Functions ..
198 INTRINSIC abs, aimag, max, real, sqrt
199* ..
200* .. Statement Functions ..
201 REAL CABS1
202* ..
203* .. Statement Function definitions ..
204 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CSPTRF', -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 = icamax( 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 = icamax( 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 cswap( 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 cspr( uplo, k-1, -r1, ap( kc ), 1, ap )
353*
354* Store U(k) in column k
355*
356 CALL cscal( 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 + icamax( 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 + icamax( 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 cswap( 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 cspr( 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 cscal( 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 CSPTRF
615*
cspr
subroutine cspr(uplo, n, alpha, x, incx, ap)
CSPR performs the symmetrical rank-1 update of a complex symmetric packed matrix.
Definition cspr.f:132

◆ csptri()

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

CSPTRI

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

Purpose:
!>
!> CSPTRI 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 CSPTRF.
!>
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 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 CSPTRF,
!>          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 CSPTRF.
!>
[out]WORK
!>          WORK is COMPLEX 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 csptri.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 AP( * ), WORK( * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 COMPLEX ONE, ZERO
127 parameter( one = ( 1.0e+0, 0.0e+0 ),
128 $ zero = ( 0.0e+0, 0.0e+0 ) )
129* ..
130* .. Local Scalars ..
131 LOGICAL UPPER
132 INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
133 COMPLEX AK, AKKP1, AKP1, D, T, TEMP
134* ..
135* .. External Functions ..
136 LOGICAL LSAME
137 COMPLEX CDOTU
138 EXTERNAL lsame, cdotu
139* ..
140* .. External Subroutines ..
141 EXTERNAL ccopy, cspmv, cswap, xerbla
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( 'CSPTRI', -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 ccopy( k-1, ap( kc ), 1, work, 1 )
221 CALL cspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
222 $ 1 )
223 ap( kc+k-1 ) = ap( kc+k-1 ) -
224 $ cdotu( 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 ccopy( k-1, ap( kc ), 1, work, 1 )
246 CALL cspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
247 $ 1 )
248 ap( kc+k-1 ) = ap( kc+k-1 ) -
249 $ cdotu( k-1, work, 1, ap( kc ), 1 )
250 ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -
251 $ cdotu( k-1, ap( kc ), 1, ap( kcnext ),
252 $ 1 )
253 CALL ccopy( k-1, ap( kcnext ), 1, work, 1 )
254 CALL cspmv( uplo, k-1, -one, ap, work, 1, zero,
255 $ ap( kcnext ), 1 )
256 ap( kcnext+k ) = ap( kcnext+k ) -
257 $ cdotu( 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 cswap( 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 ccopy( n-k, ap( kc+1 ), 1, work, 1 )
323 CALL cspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1,
324 $ zero, ap( kc+1 ), 1 )
325 ap( kc ) = ap( kc ) - cdotu( 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 ccopy( n-k, ap( kc+1 ), 1, work, 1 )
348 CALL cspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
349 $ zero, ap( kc+1 ), 1 )
350 ap( kc ) = ap( kc ) - cdotu( n-k, work, 1, ap( kc+1 ),
351 $ 1 )
352 ap( kcnext+1 ) = ap( kcnext+1 ) -
353 $ cdotu( n-k, ap( kc+1 ), 1,
354 $ ap( kcnext+2 ), 1 )
355 CALL ccopy( n-k, ap( kcnext+2 ), 1, work, 1 )
356 CALL cspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
357 $ zero, ap( kcnext+2 ), 1 )
358 ap( kcnext ) = ap( kcnext ) -
359 $ cdotu( 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 cswap( 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 CSPTRI
400*
cdotu
complex function cdotu(n, cx, incx, cy, incy)
CDOTU
Definition cdotu.f:83

◆ csptrs()

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

CSPTRS

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

Purpose:
!>
!> CSPTRS 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 CSPTRF.
!>
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 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 CSPTRF, 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 CSPTRF.
!>
[in,out]B
!>          B is COMPLEX 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 csptrs.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 AP( * ), B( LDB, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 COMPLEX ONE
133 parameter( one = ( 1.0e+0, 0.0e+0 ) )
134* ..
135* .. Local Scalars ..
136 LOGICAL UPPER
137 INTEGER J, K, KC, KP
138 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
139* ..
140* .. External Functions ..
141 LOGICAL LSAME
142 EXTERNAL lsame
143* ..
144* .. External Subroutines ..
145 EXTERNAL cgemv, cgeru, cscal, cswap, xerbla
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( 'CSPTRS', -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 cswap( 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 cgeru( 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 cscal( 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 cswap( 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 cgeru( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
226 $ b( 1, 1 ), ldb )
227 CALL cgeru( 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 cgemv( '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 cswap( 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 cgemv( 'Transpose', k-1, nrhs, -one, b, ldb, ap( kc ),
288 $ 1, one, b( k, 1 ), ldb )
289 CALL cgemv( '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 cswap( 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 cswap( 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 cgeru( 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 cscal( 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 cswap( 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 cgeru( n-k-1, nrhs, -one, ap( kc+2 ), 1, b( k, 1 ),
359 $ ldb, b( k+2, 1 ), ldb )
360 CALL cgeru( 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 cgemv( '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 cswap( 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 cgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
424 $ ldb, ap( kc+1 ), 1, one, b( k, 1 ), ldb )
425 CALL cgemv( '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 cswap( 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 CSPTRS
446*

◆ cstedc()

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

CSTEDC

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

Purpose:
!>
!> CSTEDC 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 CHETRD or CHPTRD or CHBTRD has been used to reduce this
!> matrix to tridiagonal form.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.  See SLAED3 for details.
!>
Parameters
[in]COMPZ
!>          COMPZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only.
!>          = 'I':  Compute eigenvectors of tridiagonal matrix also.
!>          = 'V':  Compute eigenvectors of original 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 REAL array, dimension (N)
!>          On entry, the diagonal elements of the tridiagonal matrix.
!>          On exit, if INFO = 0, the eigenvalues in ascending order.
!>
[in,out]E
!>          E is REAL array, dimension (N-1)
!>          On entry, the subdiagonal elements of the tridiagonal matrix.
!>          On exit, E has been destroyed.
!>
[in,out]Z
!>          Z is COMPLEX 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 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 REAL 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 cstedc.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 REAL D( * ), E( * ), RWORK( * )
224 COMPLEX WORK( * ), Z( LDZ, * )
225* ..
226*
227* =====================================================================
228*
229* .. Parameters ..
230 REAL ZERO, ONE, TWO
231 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
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 REAL EPS, ORGNRM, P, TINY
238* ..
239* .. External Functions ..
240 LOGICAL LSAME
241 INTEGER ILAENV
242 REAL SLAMCH, SLANST
243 EXTERNAL ilaenv, lsame, slamch, slanst
244* ..
245* .. External Subroutines ..
246 EXTERNAL xerbla, clacpy, clacrm, claed0, csteqr, cswap,
247 $ slascl, slaset, sstedc, ssteqr, ssterf
248* ..
249* .. Intrinsic Functions ..
250 INTRINSIC abs, int, log, max, mod, real, 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, 'CSTEDC', ' ', 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( real( 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( 'CSTEDC', -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 SSTERF 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 SSTERF to compute the eigenvalues.
344*
345 IF( icompz.EQ.0 ) THEN
346 CALL ssterf( 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 csteqr( compz, n, d, e, z, ldz, rwork, info )
356*
357 ELSE
358*
359* If COMPZ = 'I', we simply call SSTEDC instead.
360*
361 IF( icompz.EQ.2 ) THEN
362 CALL slaset( 'Full', n, n, zero, one, rwork, n )
363 ll = n*n + 1
364 CALL sstedc( '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 = slanst( 'M', n, d, e )
380 IF( orgnrm.EQ.zero )
381 $ GO TO 70
382*
383 eps = slamch( '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 = slanst( 'M', m, d( start ), e( start ) )
417 CALL slascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,
418 $ info )
419 CALL slascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),
420 $ m-1, info )
421*
422 CALL claed0( 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 slascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,
433 $ info )
434*
435 ELSE
436 CALL ssteqr( 'I', m, d( start ), e( start ), rwork, m,
437 $ rwork( m*m+1 ), info )
438 CALL clacrm( n, m, z( 1, start ), ldz, rwork, m, work, n,
439 $ rwork( m*m+1 ) )
440 CALL clacpy( '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 cswap( 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 CSTEDC
482*
sstedc
subroutine sstedc(compz, n, d, e, z, ldz, work, lwork, iwork, liwork, info)
SSTEDC
Definition sstedc.f:188
ssterf
subroutine ssterf(n, d, e, info)
SSTERF
Definition ssterf.f:86
claed0
subroutine claed0(qsiz, n, d, e, q, ldq, qstore, ldqs, rwork, iwork, info)
CLAED0 used by CSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmet...
Definition claed0.f:145
csteqr
subroutine csteqr(compz, n, d, e, z, ldz, work, info)
CSTEQR
Definition csteqr.f:132

◆ cstegr()

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

CSTEGR

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

Purpose:
!>
!> CSTEGR 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.
!>
!> CSTEGR is a compatibility wrapper around the improved CSTEMR routine.
!> See SSTEMR for further details.
!>
!> One important change is that the ABSTOL parameter no longer provides any
!> benefit and hence is no longer used.
!>
!> Note : CSTEGR and CSTEMR 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 REAL array, dimension (N)
!>          On entry, the N diagonal elements of the tridiagonal matrix
!>          T. On exit, D is overwritten.
!>
[in,out]E
!>          E is REAL 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 REAL
!>
!>          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 REAL
!>
!>          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 REAL
!>          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 REAL array, dimension (N)
!>          The first M elements contain the selected eigenvalues in
!>          ascending order.
!>
[out]Z
!>          Z is COMPLEX 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 REAL 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 SLARRE,
!>                if INFO = 2X, internal error in CLARRV.
!>                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
!>                the nonzero error code returned by SLARRE or
!>                CLARRV, 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 cstegr.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 REAL ABSTOL, VL, VU
274* ..
275* .. Array Arguments ..
276 INTEGER ISUPPZ( * ), IWORK( * )
277 REAL D( * ), E( * ), W( * ), WORK( * )
278 COMPLEX Z( LDZ, * )
279* ..
280*
281* =====================================================================
282*
283* .. Local Scalars ..
284 LOGICAL TRYRAC
285* ..
286* .. External Subroutines ..
287 EXTERNAL cstemr
288* ..
289* .. Executable Statements ..
290 info = 0
291 tryrac = .false.
292
293 CALL cstemr( 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 CSTEGR
298*
cstemr
subroutine cstemr(jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
CSTEMR
Definition cstemr.f:338

◆ cstein()

subroutine cstein ( integer n,
real, dimension( * ) d,
real, dimension( * ) e,
integer m,
real, dimension( * ) w,
integer, dimension( * ) iblock,
integer, dimension( * ) isplit,
complex, dimension( ldz, * ) z,
integer ldz,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer, dimension( * ) ifail,
integer info )

CSTEIN

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

Purpose:
!>
!> CSTEIN 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 CUNMTR or CUPMTR 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 REAL array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix T.
!>
[in]E
!>          E is REAL array, dimension (N-1)
!>          The (n-1) 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 REAL 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 SSTEBZ 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 SSTEBZ 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 SSTEBZ is expected here. )
!>
[out]Z
!>          Z is COMPLEX 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 REAL 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 cstein.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 REAL D( * ), E( * ), W( * ), WORK( * )
194 COMPLEX Z( LDZ, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 COMPLEX CZERO, CONE
201 parameter( czero = ( 0.0e+0, 0.0e+0 ),
202 $ cone = ( 1.0e+0, 0.0e+0 ) )
203 REAL ZERO, ONE, TEN, ODM3, ODM1
204 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 1.0e+1,
205 $ odm3 = 1.0e-3, odm1 = 1.0e-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 REAL CTR, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
214 $ SCL, SEP, STPCRT, TOL, XJ, XJM
215* ..
216* .. Local Arrays ..
217 INTEGER ISEED( 4 )
218* ..
219* .. External Functions ..
220 INTEGER ISAMAX
221 REAL SLAMCH, SNRM2
222 EXTERNAL isamax, slamch, snrm2
223* ..
224* .. External Subroutines ..
225 EXTERNAL scopy, slagtf, slagts, slarnv, sscal, xerbla
226* ..
227* .. Intrinsic Functions ..
228 INTRINSIC abs, cmplx, max, real, 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( 'CSTEIN', -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 = slamch( 'Precision' )
277*
278* Initialize seed for random number generator SLARNV.
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 stpcrt = 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 slarnv( 2, iseed, blksiz, work( indrv1+1 ) )
358*
359* Copy the matrix T so it won't be destroyed in factorization.
360*
361 CALL scopy( blksiz, d( b1 ), 1, work( indrv4+1 ), 1 )
362 CALL scopy( blksiz-1, e( b1 ), 1, work( indrv2+2 ), 1 )
363 CALL scopy( 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 slagtf( 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 = isamax( blksiz, work( indrv1+1 ), 1 )
382 scl = blksiz*onenrm*max( eps,
383 $ abs( work( indrv4+blksiz ) ) ) /
384 $ abs( work( indrv1+jmax ) )
385 CALL sscal( blksiz, scl, work( indrv1+1 ), 1 )
386*
387* Solve the system LU = Pb.
388*
389 CALL slagts( -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 ctr = zero
403 DO 80 jr = 1, blksiz
404 ctr = ctr + work( indrv1+jr )*
405 $ real( z( b1-1+jr, i ) )
406 80 CONTINUE
407 DO 90 jr = 1, blksiz
408 work( indrv1+jr ) = work( indrv1+jr ) -
409 $ ctr*real( 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 = isamax( 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.stpcrt )
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 / snrm2( blksiz, work( indrv1+1 ), 1 )
442 jmax = isamax( blksiz, work( indrv1+1 ), 1 )
443 IF( work( indrv1+jmax ).LT.zero )
444 $ scl = -scl
445 CALL sscal( 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 ) = cmplx( 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 CSTEIN
465*
slarnv
subroutine slarnv(idist, iseed, n, x)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition slarnv.f:97
slagts
subroutine slagts(job, n, a, b, c, d, in, y, tol, info)
SLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal ma...
Definition slagts.f:161
slagtf
subroutine slagtf(n, a, lambda, b, c, tol, d, in, info)
SLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix,...
Definition slagtf.f:156

◆ cstemr()

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

CSTEMR

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

Purpose:
!>
!> CSTEMR 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.CSTEMR 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,
!> CSTEMR accepts complex workspace to facilitate interoperability
!> with CUNMTR or CUPMTR.
!>
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 REAL array, dimension (N)
!>          On entry, the N diagonal elements of the tridiagonal matrix
!>          T. On exit, D is overwritten.
!>
[in,out]E
!>          E is REAL 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 REAL
!>
!>          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 REAL
!>
!>          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 REAL array, dimension (N)
!>          The first M elements contain the selected eigenvalues in
!>          ascending order.
!>
[out]Z
!>          Z is COMPLEX 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 REAL 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 SLARRE,
!>                if INFO = 2X, internal error in CLARRV.
!>                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
!>                the nonzero error code returned by SLARRE or
!>                CLARRV, 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 cstemr.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 REAL VL, VU
348* ..
349* .. Array Arguments ..
350 INTEGER ISUPPZ( * ), IWORK( * )
351 REAL D( * ), E( * ), W( * ), WORK( * )
352 COMPLEX Z( LDZ, * )
353* ..
354*
355* =====================================================================
356*
357* .. Parameters ..
358 REAL ZERO, ONE, FOUR, MINRGP
359 parameter( zero = 0.0e0, one = 1.0e0,
360 $ four = 4.0e0,
361 $ minrgp = 3.0e-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 REAL 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 REAL SLAMCH, SLANST
378 EXTERNAL lsame, slamch, slanst
379* ..
380* .. External Subroutines ..
381 EXTERNAL clarrv, cswap, scopy, slae2, slaev2, slarrc,
382 $ slarre, slarrj, slarrr, slasrt, sscal, xerbla
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* SSTEMR needs WORK of size 6*N, IWORK of size 3*N.
402* In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N.
403* Furthermore, CLARRV 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 SLARRE.
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 = slamch( 'Safe minimum' )
455 eps = slamch( '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 slarrc( '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( 'CSTEMR', -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 slae2( d(1), e(1), d(2), r1, r2 )
519 ELSE IF( wantz.AND.(.NOT.zquery) ) THEN
520 CALL slaev2( 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 SLARRD. 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 = slanst( '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 sscal( n, scale, d, 1 )
601 CALL sscal( 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 SLARRE
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 slarrr( 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 scopy(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* SLARRE computes the eigenvalues to full precision.
647 rtol1 = four * eps
648 rtol2 = four * eps
649 ELSE
650* SLARRE computes the eigenvalues to less than full precision.
651* CLARRV will refine the eigenvalue approximations, and we only
652* need less accurate initial bisection in SLARRE.
653* Note: these settings do only affect the subset case and SLARRE
654 rtol1 = max( sqrt(eps)*5.0e-2, four * eps )
655 rtol2 = max( sqrt(eps)*5.0e-3, four * eps )
656 ENDIF
657 CALL slarre( 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', SLARRE 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 clarrv( 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* SLARRE computes eigenvalues of the (shifted) root representation
689* CLARRV 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 SLARRE 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 slarrj( 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 sscal( 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 slasrt( '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 cswap( 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 CSTEMR
787*
slarrr
subroutine slarrr(n, d, e, info)
SLARRR performs tests to decide whether the symmetric tridiagonal matrix T warrants expensive computa...
Definition slarrr.f:94
slarre
subroutine slarre(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)
SLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduce...
Definition slarre.f:305
slarrj
subroutine slarrj(n, d, e2, ifirst, ilast, rtol, offset, w, werr, work, iwork, pivmin, spdiam, info)
SLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T.
Definition slarrj.f:168
slae2
subroutine slae2(a, b, c, rt1, rt2)
SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.
Definition slae2.f:102
slaev2
subroutine slaev2(a, b, c, rt1, rt2, cs1, sn1)
SLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
Definition slaev2.f:120
slarrc
subroutine slarrc(jobt, n, vl, vu, d, e, pivmin, eigcnt, lcnt, rcnt, info)
SLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix.
Definition slarrc.f:137
clarrv
subroutine clarrv(n, vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, z, ldz, isuppz, work, iwork, info)
CLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues ...
Definition clarrv.f:286

◆ csteqr()

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

CSTEQR

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

Purpose:
!>
!> CSTEQR 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 CHETRD or CHPTRD or CHBTRD 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 REAL array, dimension (N)
!>          On entry, the diagonal elements of the tridiagonal matrix.
!>          On exit, if INFO = 0, the eigenvalues in ascending order.
!>
[in,out]E
!>          E is REAL array, dimension (N-1)
!>          On entry, the (n-1) subdiagonal elements of the tridiagonal
!>          matrix.
!>          On exit, E has been destroyed.
!>
[in,out]Z
!>          Z is COMPLEX 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 REAL array, dimension (max(1,2*N-2))
!>          If COMPZ = 'N', then WORK is not referenced.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  the algorithm has failed to find all the eigenvalues in
!>                a total of 30*N iterations; if INFO = i, then i
!>                elements of E have not converged to zero; on exit, D
!>                and E contain the elements of a symmetric tridiagonal
!>                matrix which is 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 csteqr.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 REAL D( * ), E( * ), WORK( * )
143 COMPLEX Z( LDZ, * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 REAL ZERO, ONE, TWO, THREE
150 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
151 $ three = 3.0e0 )
152 COMPLEX CZERO, CONE
153 parameter( czero = ( 0.0e0, 0.0e0 ),
154 $ cone = ( 1.0e0, 0.0e0 ) )
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 REAL 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 REAL SLAMCH, SLANST, SLAPY2
168 EXTERNAL lsame, slamch, slanst, slapy2
169* ..
170* .. External Subroutines ..
171 EXTERNAL claset, clasr, cswap, slae2, slaev2, slartg,
172 $ slascl, slasrt, xerbla
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( 'CSTEQR', -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 = slamch( 'E' )
219 eps2 = eps**2
220 safmin = slamch( '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 claset( '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 = slanst( '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 slascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,
278 $ info )
279 CALL slascl( '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 slascl( 'G', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n,
284 $ info )
285 CALL slascl( '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 SLAE2 or SLAEV2
322* to compute its eigensystem.
323*
324 IF( m.EQ.l+1 ) THEN
325 IF( icompz.GT.0 ) THEN
326 CALL slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
327 work( l ) = c
328 work( n-1+l ) = s
329 CALL clasr( 'R', 'V', 'B', n, 2, work( l ),
330 $ work( n-1+l ), z( 1, l ), ldz )
331 ELSE
332 CALL slae2( 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 = slapy2( 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 slartg( 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 clasr( '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 SLAE2 or SLAEV2
429* to compute its eigensystem.
430*
431 IF( m.EQ.l-1 ) THEN
432 IF( icompz.GT.0 ) THEN
433 CALL slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
434 work( m ) = c
435 work( n-1+m ) = s
436 CALL clasr( 'R', 'V', 'F', n, 2, work( m ),
437 $ work( n-1+m ), z( 1, l-1 ), ldz )
438 ELSE
439 CALL slae2( 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 = slapy2( 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 slartg( 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 clasr( '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 slascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,
517 $ d( lsv ), n, info )
518 CALL slascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),
519 $ n, info )
520 ELSE IF( iscale.EQ.2 ) THEN
521 CALL slascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,
522 $ d( lsv ), n, info )
523 CALL slascl( '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 slasrt( '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 cswap( n, z( 1, i ), 1, z( 1, k ), 1 )
566 END IF
567 180 CONTINUE
568 END IF
569 RETURN
570*
571* End of CSTEQR
572*

◆ ctbcon()

subroutine ctbcon ( character norm,
character uplo,
character diag,
integer n,
integer kd,
complex, dimension( ldab, * ) ab,
integer ldab,
real rcond,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CTBCON

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

Purpose:
!>
!> CTBCON 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 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 REAL
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 141 of file ctbcon.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 REAL RCOND
152* ..
153* .. Array Arguments ..
154 REAL RWORK( * )
155 COMPLEX AB( LDAB, * ), WORK( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 REAL ONE, ZERO
162 parameter( one = 1.0e+0, zero = 0.0e+0 )
163* ..
164* .. Local Scalars ..
165 LOGICAL NOUNIT, ONENRM, UPPER
166 CHARACTER NORMIN
167 INTEGER IX, KASE, KASE1
168 REAL AINVNM, ANORM, SCALE, SMLNUM, XNORM
169 COMPLEX ZDUM
170* ..
171* .. Local Arrays ..
172 INTEGER ISAVE( 3 )
173* ..
174* .. External Functions ..
175 LOGICAL LSAME
176 INTEGER ICAMAX
177 REAL CLANTB, SLAMCH
178 EXTERNAL lsame, icamax, clantb, slamch
179* ..
180* .. External Subroutines ..
181 EXTERNAL clacn2, clatbs, csrscl, xerbla
182* ..
183* .. Intrinsic Functions ..
184 INTRINSIC abs, aimag, max, real
185* ..
186* .. Statement Functions ..
187 REAL CABS1
188* ..
189* .. Statement Function definitions ..
190 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CTBCON', -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 = slamch( 'Safe minimum' )*real( max( n, 1 ) )
228*
229* Compute the 1-norm of the triangular matrix A or A**H.
230*
231 anorm = clantb( 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 clacn2( 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 clatbs( 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 clatbs( 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 = icamax( n, work, 1 )
269 xnorm = cabs1( work( ix ) )
270 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
271 $ GO TO 20
272 CALL csrscl( 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 CTBCON
287*
clantb
real function clantb(norm, uplo, diag, n, k, ab, ldab, work)
CLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clantb.f:141

◆ ctbrfs()

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

CTBRFS

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

Purpose:
!>
!> CTBRFS 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 CTBTRS or some other
!> means before entering this routine.  CTBRFS 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 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 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 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 REAL 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 REAL 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 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 186 of file ctbrfs.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 REAL BERR( * ), FERR( * ), RWORK( * )
199 COMPLEX AB( LDAB, * ), B( LDB, * ), WORK( * ),
200 $ X( LDX, * )
201* ..
202*
203* =====================================================================
204*
205* .. Parameters ..
206 REAL ZERO
207 parameter( zero = 0.0e+0 )
208 COMPLEX ONE
209 parameter( one = ( 1.0e+0, 0.0e+0 ) )
210* ..
211* .. Local Scalars ..
212 LOGICAL NOTRAN, NOUNIT, UPPER
213 CHARACTER TRANSN, TRANST
214 INTEGER I, J, K, KASE, NZ
215 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
216 COMPLEX ZDUM
217* ..
218* .. Local Arrays ..
219 INTEGER ISAVE( 3 )
220* ..
221* .. External Subroutines ..
222 EXTERNAL caxpy, ccopy, clacn2, ctbmv, ctbsv, xerbla
223* ..
224* .. Intrinsic Functions ..
225 INTRINSIC abs, aimag, max, min, real
226* ..
227* .. External Functions ..
228 LOGICAL LSAME
229 REAL SLAMCH
230 EXTERNAL lsame, slamch
231* ..
232* .. Statement Functions ..
233 REAL CABS1
234* ..
235* .. Statement Function definitions ..
236 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CTBRFS', -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 = slamch( 'Epsilon' )
294 safmin = slamch( '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 ccopy( n, x( 1, j ), 1, work, 1 )
306 CALL ctbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
307 CALL caxpy( 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 CLACN2 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 clacn2( 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 ctbsv( 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 ctbsv( 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 CTBRFS
493*
ctbmv
subroutine ctbmv(uplo, trans, diag, n, k, a, lda, x, incx)
CTBMV
Definition ctbmv.f:186

◆ ctbtrs()

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

CTBTRS

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

Purpose:
!>
!> CTBTRS 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 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 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 ctbtrs.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 AB( LDAB, * ), B( LDB, * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 COMPLEX ZERO
163 parameter( zero = ( 0.0e+0, 0.0e+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 ctbsv, xerbla
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( 'CTBTRS', -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 ctbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1, j ), 1 )
235 30 CONTINUE
236*
237 RETURN
238*
239* End of CTBTRS
240*

◆ ctfsm()

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

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

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

Purpose:
!>
!> Level 3 BLAS like routine for A in RFP Format.
!>
!> CTFSM 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
!>           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 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 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 ctfsm.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 ALPHA
307* ..
308* .. Array Arguments ..
309 COMPLEX A( 0: * ), B( 0: LDB-1, 0: * )
310* ..
311*
312* =====================================================================
313* ..
314* .. Parameters ..
315 COMPLEX CONE, CZERO
316 parameter( cone = ( 1.0e+0, 0.0e+0 ),
317 $ czero = ( 0.0e+0, 0.0e+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, cgemm, ctrsm
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( 'CTFSM ', -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.(0E+0,0E+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 ctrsm( 'L', 'L', 'N', diag, m1, n, alpha,
423 $ a, m, b, ldb )
424 ELSE
425 CALL ctrsm( 'L', 'L', 'N', diag, m1, n, alpha,
426 $ a( 0 ), m, b, ldb )
427 CALL cgemm( 'N', 'N', m2, n, m1, -cone, a( m1 ),
428 $ m, b, ldb, alpha, b( m1, 0 ), ldb )
429 CALL ctrsm( '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 ctrsm( 'L', 'L', 'C', diag, m1, n, alpha,
440 $ a( 0 ), m, b, ldb )
441 ELSE
442 CALL ctrsm( 'L', 'U', 'N', diag, m2, n, alpha,
443 $ a( m ), m, b( m1, 0 ), ldb )
444 CALL cgemm( 'C', 'N', m1, n, m2, -cone, a( m1 ),
445 $ m, b( m1, 0 ), ldb, alpha, b, ldb )
446 CALL ctrsm( '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 ctrsm( 'L', 'L', 'N', diag, m1, n, alpha,
462 $ a( m2 ), m, b, ldb )
463 CALL cgemm( 'C', 'N', m2, n, m1, -cone, a( 0 ), m,
464 $ b, ldb, alpha, b( m1, 0 ), ldb )
465 CALL ctrsm( '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 ctrsm( 'L', 'U', 'N', diag, m2, n, alpha,
474 $ a( m1 ), m, b( m1, 0 ), ldb )
475 CALL cgemm( 'N', 'N', m1, n, m2, -cone, a( 0 ), m,
476 $ b( m1, 0 ), ldb, alpha, b, ldb )
477 CALL ctrsm( '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 ctrsm( 'L', 'U', 'C', diag, m1, n, alpha,
499 $ a( 0 ), m1, b, ldb )
500 ELSE
501 CALL ctrsm( 'L', 'U', 'C', diag, m1, n, alpha,
502 $ a( 0 ), m1, b, ldb )
503 CALL cgemm( 'C', 'N', m2, n, m1, -cone,
504 $ a( m1*m1 ), m1, b, ldb, alpha,
505 $ b( m1, 0 ), ldb )
506 CALL ctrsm( '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 ctrsm( 'L', 'U', 'N', diag, m1, n, alpha,
517 $ a( 0 ), m1, b, ldb )
518 ELSE
519 CALL ctrsm( 'L', 'L', 'C', diag, m2, n, alpha,
520 $ a( 1 ), m1, b( m1, 0 ), ldb )
521 CALL cgemm( 'N', 'N', m1, n, m2, -cone,
522 $ a( m1*m1 ), m1, b( m1, 0 ), ldb,
523 $ alpha, b, ldb )
524 CALL ctrsm( '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 ctrsm( 'L', 'U', 'C', diag, m1, n, alpha,
540 $ a( m2*m2 ), m2, b, ldb )
541 CALL cgemm( 'N', 'N', m2, n, m1, -cone, a( 0 ), m2,
542 $ b, ldb, alpha, b( m1, 0 ), ldb )
543 CALL ctrsm( '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 ctrsm( 'L', 'L', 'C', diag, m2, n, alpha,
552 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
553 CALL cgemm( 'C', 'N', m1, n, m2, -cone, a( 0 ), m2,
554 $ b( m1, 0 ), ldb, alpha, b, ldb )
555 CALL ctrsm( '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 ctrsm( 'L', 'L', 'N', diag, k, n, alpha,
582 $ a( 1 ), m+1, b, ldb )
583 CALL cgemm( 'N', 'N', k, n, k, -cone, a( k+1 ),
584 $ m+1, b, ldb, alpha, b( k, 0 ), ldb )
585 CALL ctrsm( '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 ctrsm( 'L', 'U', 'N', diag, k, n, alpha,
594 $ a( 0 ), m+1, b( k, 0 ), ldb )
595 CALL cgemm( 'C', 'N', k, n, k, -cone, a( k+1 ),
596 $ m+1, b( k, 0 ), ldb, alpha, b, ldb )
597 CALL ctrsm( '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 ctrsm( 'L', 'L', 'N', diag, k, n, alpha,
612 $ a( k+1 ), m+1, b, ldb )
613 CALL cgemm( 'C', 'N', k, n, k, -cone, a( 0 ), m+1,
614 $ b, ldb, alpha, b( k, 0 ), ldb )
615 CALL ctrsm( '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 ctrsm( 'L', 'U', 'N', diag, k, n, alpha,
623 $ a( k ), m+1, b( k, 0 ), ldb )
624 CALL cgemm( 'N', 'N', k, n, k, -cone, a( 0 ), m+1,
625 $ b( k, 0 ), ldb, alpha, b, ldb )
626 CALL ctrsm( '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 ctrsm( 'L', 'U', 'C', diag, k, n, alpha,
647 $ a( k ), k, b, ldb )
648 CALL cgemm( 'C', 'N', k, n, k, -cone,
649 $ a( k*( k+1 ) ), k, b, ldb, alpha,
650 $ b( k, 0 ), ldb )
651 CALL ctrsm( '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 ctrsm( 'L', 'L', 'C', diag, k, n, alpha,
660 $ a( 0 ), k, b( k, 0 ), ldb )
661 CALL cgemm( 'N', 'N', k, n, k, -cone,
662 $ a( k*( k+1 ) ), k, b( k, 0 ), ldb,
663 $ alpha, b, ldb )
664 CALL ctrsm( '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 ctrsm( 'L', 'U', 'C', diag, k, n, alpha,
679 $ a( k*( k+1 ) ), k, b, ldb )
680 CALL cgemm( 'N', 'N', k, n, k, -cone, a( 0 ), k, b,
681 $ ldb, alpha, b( k, 0 ), ldb )
682 CALL ctrsm( '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 ctrsm( 'L', 'L', 'C', diag, k, n, alpha,
691 $ a( k*k ), k, b( k, 0 ), ldb )
692 CALL cgemm( 'C', 'N', k, n, k, -cone, a( 0 ), k,
693 $ b( k, 0 ), ldb, alpha, b, ldb )
694 CALL ctrsm( '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 ctrsm( 'R', 'U', 'C', diag, m, n2, alpha,
745 $ a( n ), n, b( 0, n1 ), ldb )
746 CALL cgemm( 'N', 'N', m, n1, n2, -cone, b( 0, n1 ),
747 $ ldb, a( n1 ), n, alpha, b( 0, 0 ),
748 $ ldb )
749 CALL ctrsm( '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 ctrsm( 'R', 'L', 'C', diag, m, n1, alpha,
758 $ a( 0 ), n, b( 0, 0 ), ldb )
759 CALL cgemm( 'N', 'C', m, n2, n1, -cone, b( 0, 0 ),
760 $ ldb, a( n1 ), n, alpha, b( 0, n1 ),
761 $ ldb )
762 CALL ctrsm( '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 ctrsm( 'R', 'L', 'C', diag, m, n1, alpha,
777 $ a( n2 ), n, b( 0, 0 ), ldb )
778 CALL cgemm( 'N', 'N', m, n2, n1, -cone, b( 0, 0 ),
779 $ ldb, a( 0 ), n, alpha, b( 0, n1 ),
780 $ ldb )
781 CALL ctrsm( '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 ctrsm( 'R', 'U', 'C', diag, m, n2, alpha,
790 $ a( n1 ), n, b( 0, n1 ), ldb )
791 CALL cgemm( 'N', 'C', m, n1, n2, -cone, b( 0, n1 ),
792 $ ldb, a( 0 ), n, alpha, b( 0, 0 ), ldb )
793 CALL ctrsm( '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 ctrsm( 'R', 'L', 'N', diag, m, n2, alpha,
814 $ a( 1 ), n1, b( 0, n1 ), ldb )
815 CALL cgemm( 'N', 'C', m, n1, n2, -cone, b( 0, n1 ),
816 $ ldb, a( n1*n1 ), n1, alpha, b( 0, 0 ),
817 $ ldb )
818 CALL ctrsm( '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 ctrsm( 'R', 'U', 'N', diag, m, n1, alpha,
827 $ a( 0 ), n1, b( 0, 0 ), ldb )
828 CALL cgemm( 'N', 'N', m, n2, n1, -cone, b( 0, 0 ),
829 $ ldb, a( n1*n1 ), n1, alpha, b( 0, n1 ),
830 $ ldb )
831 CALL ctrsm( '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 ctrsm( 'R', 'U', 'N', diag, m, n1, alpha,
846 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
847 CALL cgemm( 'N', 'C', m, n2, n1, -cone, b( 0, 0 ),
848 $ ldb, a( 0 ), n2, alpha, b( 0, n1 ),
849 $ ldb )
850 CALL ctrsm( '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 ctrsm( 'R', 'L', 'N', diag, m, n2, alpha,
859 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
860 CALL cgemm( 'N', 'N', m, n1, n2, -cone, b( 0, n1 ),
861 $ ldb, a( 0 ), n2, alpha, b( 0, 0 ),
862 $ ldb )
863 CALL ctrsm( '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 ctrsm( 'R', 'U', 'C', diag, m, k, alpha,
890 $ a( 0 ), n+1, b( 0, k ), ldb )
891 CALL cgemm( 'N', 'N', m, k, k, -cone, b( 0, k ),
892 $ ldb, a( k+1 ), n+1, alpha, b( 0, 0 ),
893 $ ldb )
894 CALL ctrsm( '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 ctrsm( 'R', 'L', 'C', diag, m, k, alpha,
903 $ a( 1 ), n+1, b( 0, 0 ), ldb )
904 CALL cgemm( 'N', 'C', m, k, k, -cone, b( 0, 0 ),
905 $ ldb, a( k+1 ), n+1, alpha, b( 0, k ),
906 $ ldb )
907 CALL ctrsm( '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 ctrsm( 'R', 'L', 'C', diag, m, k, alpha,
922 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
923 CALL cgemm( 'N', 'N', m, k, k, -cone, b( 0, 0 ),
924 $ ldb, a( 0 ), n+1, alpha, b( 0, k ),
925 $ ldb )
926 CALL ctrsm( '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 ctrsm( 'R', 'U', 'C', diag, m, k, alpha,
935 $ a( k ), n+1, b( 0, k ), ldb )
936 CALL cgemm( 'N', 'C', m, k, k, -cone, b( 0, k ),
937 $ ldb, a( 0 ), n+1, alpha, b( 0, 0 ),
938 $ ldb )
939 CALL ctrsm( '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 ctrsm( 'R', 'L', 'N', diag, m, k, alpha,
960 $ a( 0 ), k, b( 0, k ), ldb )
961 CALL cgemm( 'N', 'C', m, k, k, -cone, b( 0, k ),
962 $ ldb, a( ( k+1 )*k ), k, alpha,
963 $ b( 0, 0 ), ldb )
964 CALL ctrsm( '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 ctrsm( 'R', 'U', 'N', diag, m, k, alpha,
973 $ a( k ), k, b( 0, 0 ), ldb )
974 CALL cgemm( 'N', 'N', m, k, k, -cone, b( 0, 0 ),
975 $ ldb, a( ( k+1 )*k ), k, alpha,
976 $ b( 0, k ), ldb )
977 CALL ctrsm( '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 ctrsm( 'R', 'U', 'N', diag, m, k, alpha,
992 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
993 CALL cgemm( 'N', 'C', m, k, k, -cone, b( 0, 0 ),
994 $ ldb, a( 0 ), k, alpha, b( 0, k ), ldb )
995 CALL ctrsm( '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 ctrsm( 'R', 'L', 'N', diag, m, k, alpha,
1004 $ a( k*k ), k, b( 0, k ), ldb )
1005 CALL cgemm( 'N', 'N', m, k, k, -cone, b( 0, k ),
1006 $ ldb, a( 0 ), k, alpha, b( 0, 0 ), ldb )
1007 CALL ctrsm( '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 CTFSM
1022*

◆ ctftri()

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

CTFTRI

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

Purpose:
!>
!> CTFTRI 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 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 ctftri.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 A( 0: * )
232* ..
233*
234* =====================================================================
235*
236* .. Parameters ..
237 COMPLEX CONE
238 parameter( cone = ( 1.0e+0, 0.0e+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, ctrmm, ctrtri
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( 'CTFTRI', -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 ctrtri( 'L', diag, n1, a( 0 ), n, info )
319 IF( info.GT.0 )
320 $ RETURN
321 CALL ctrmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0 ),
322 $ n, a( n1 ), n )
323 CALL ctrtri( '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 ctrmm( '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 ctrtri( 'L', diag, n1, a( n2 ), n, info )
338 IF( info.GT.0 )
339 $ RETURN
340 CALL ctrmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),
341 $ n, a( 0 ), n )
342 CALL ctrtri( '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 ctrmm( '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 ctrtri( 'U', diag, n1, a( 0 ), n1, info )
362 IF( info.GT.0 )
363 $ RETURN
364 CALL ctrmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0 ),
365 $ n1, a( n1*n1 ), n1 )
366 CALL ctrtri( '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 ctrmm( '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 ctrtri( 'U', diag, n1, a( n2*n2 ), n2, info )
380 IF( info.GT.0 )
381 $ RETURN
382 CALL ctrmm( 'R', 'U', 'C', diag, n2, n1, -cone,
383 $ a( n2*n2 ), n2, a( 0 ), n2 )
384 CALL ctrtri( '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 ctrmm( '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 ctrtri( 'L', diag, k, a( 1 ), n+1, info )
410 IF( info.GT.0 )
411 $ RETURN
412 CALL ctrmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1 ),
413 $ n+1, a( k+1 ), n+1 )
414 CALL ctrtri( '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 ctrmm( '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 ctrtri( 'L', diag, k, a( k+1 ), n+1, info )
429 IF( info.GT.0 )
430 $ RETURN
431 CALL ctrmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),
432 $ n+1, a( 0 ), n+1 )
433 CALL ctrtri( '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 ctrmm( '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 ctrtri( 'U', diag, k, a( k ), k, info )
452 IF( info.GT.0 )
453 $ RETURN
454 CALL ctrmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,
455 $ a( k*( k+1 ) ), k )
456 CALL ctrtri( '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 ctrmm( '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 ctrtri( 'U', diag, k, a( k*( k+1 ) ), k, info )
470 IF( info.GT.0 )
471 $ RETURN
472 CALL ctrmm( 'R', 'U', 'C', diag, k, k, -cone,
473 $ a( k*( k+1 ) ), k, a( 0 ), k )
474 CALL ctrtri( '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 ctrmm( '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 CTFTRI
488*
ctrtri
subroutine ctrtri(uplo, diag, n, a, lda, info)
CTRTRI
Definition ctrtri.f:109

◆ ctfttp()

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

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

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

Purpose:
!>
!> CTFTTP 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 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 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 ctfttp.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 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 conjg
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( 'CTFTTP', -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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 CTFTTP
539*

◆ ctfttr()

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

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

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

Purpose:
!>
!> CTFTTR 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 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 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 ctfttr.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 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 conjg, 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( 'CTFTTR', -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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 CTFTTR
534*

◆ ctgsen()

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

CTGSEN

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

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

◆ ctgsja()

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

CTGSJA

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

Purpose:
!>
!> CTGSJA 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 CGGSVP
!> 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 CTGSJA.
!>          See Further Details.
!>
[in,out]A
!>          A is COMPLEX 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 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 REAL
!>
[in]TOLB
!>          TOLB is REAL
!>
!>          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)*MACHEPS,
!>              TOLB = MAX(P,N)*norm(B)*MACHEPS.
!>
[out]ALPHA
!>          ALPHA is REAL array, dimension (N)
!>
[out]BETA
!>          BETA is REAL 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
!>            BETA(K+L+1:N)  = 0.
!>
[in,out]U
!>          U is COMPLEX array, dimension (LDU,M)
!>          On entry, if JOBU = 'U', U must contain a matrix U1 (usually
!>          the unitary matrix returned by CGGSVP).
!>          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 array, dimension (LDV,P)
!>          On entry, if JOBV = 'V', V must contain a matrix V1 (usually
!>          the unitary matrix returned by CGGSVP).
!>          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 array, dimension (LDQ,N)
!>          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
!>          the unitary matrix returned by CGGSVP).
!>          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 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:
!>
!>  CTGSJA 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 ctgsja.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 REAL TOLA, TOLB
389* ..
390* .. Array Arguments ..
391 REAL ALPHA( * ), BETA( * )
392 COMPLEX 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 REAL ZERO, ONE, HUGENUM
402 parameter( zero = 0.0e+0, one = 1.0e+0 )
403 COMPLEX CZERO, CONE
404 parameter( czero = ( 0.0e+0, 0.0e+0 ),
405 $ cone = ( 1.0e+0, 0.0e+0 ) )
406* ..
407* .. Local Scalars ..
408*
409 LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
410 INTEGER I, J, KCYCLE
411 REAL A1, A3, B1, B3, CSQ, CSU, CSV, ERROR, GAMMA,
412 $ RWK, SSMIN
413 COMPLEX A2, B2, SNQ, SNU, SNV
414* ..
415* .. External Functions ..
416 LOGICAL LSAME
417 EXTERNAL lsame
418* ..
419* .. External Subroutines ..
420 EXTERNAL ccopy, clags2, clapll, claset, crot, csscal,
421 $ slartg, xerbla
422* ..
423* .. Intrinsic Functions ..
424 INTRINSIC abs, conjg, max, min, real, 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( 'CTGSJA', -info )
466 RETURN
467 END IF
468*
469* Initialize U, V and Q, if necessary
470*
471 IF( initu )
472 $ CALL claset( 'Full', m, m, czero, cone, u, ldu )
473 IF( initv )
474 $ CALL claset( 'Full', p, p, czero, cone, v, ldv )
475 IF( initq )
476 $ CALL claset( '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 = real( a( k+i, n-l+i ) )
493 IF( k+j.LE.m )
494 $ a3 = real( a( k+j, n-l+j ) )
495*
496 b1 = real( b( i, n-l+i ) )
497 b3 = real( 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 clags2( 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 crot( l, a( k+j, n-l+1 ), lda, a( k+i, n-l+1 ),
516 $ lda, csu, conjg( snu ) )
517*
518* Update I-th and J-th rows of matrix B: V**H *B
519*
520 CALL crot( l, b( j, n-l+1 ), ldb, b( i, n-l+1 ), ldb,
521 $ csv, conjg( 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 crot( min( k+l, m ), a( 1, n-l+j ), 1,
527 $ a( 1, n-l+i ), 1, csq, snq )
528*
529 CALL crot( 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 ) = real( a( k+i, n-l+i ) )
546 IF( k+j.LE.m )
547 $ a( k+j, n-l+j ) = real( a( k+j, n-l+j ) )
548 b( i, n-l+i ) = real( b( i, n-l+i ) )
549 b( j, n-l+j ) = real( 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 crot( m, u( 1, k+j ), 1, u( 1, k+i ), 1, csu,
555 $ snu )
556*
557 IF( wantv )
558 $ CALL crot( p, v( 1, j ), 1, v( 1, i ), 1, csv, snv )
559*
560 IF( wantq )
561 $ CALL crot( 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 ccopy( l-i+1, a( k+i, n-l+i ), lda, work, 1 )
578 CALL ccopy( l-i+1, b( i, n-l+i ), ldb, work( l+1 ), 1 )
579 CALL clapll( 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 = real( a( k+i, n-l+i ) )
610 b1 = real( 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 csscal( l-i+1, -one, b( i, n-l+i ), ldb )
617 IF( wantv )
618 $ CALL csscal( p, -one, v( 1, i ), 1 )
619 END IF
620*
621 CALL slartg( abs( gamma ), one, beta( k+i ), alpha( k+i ),
622 $ rwk )
623*
624 IF( alpha( k+i ).GE.beta( k+i ) ) THEN
625 CALL csscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),
626 $ lda )
627 ELSE
628 CALL csscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),
629 $ ldb )
630 CALL ccopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),
631 $ lda )
632 END IF
633*
634 ELSE
635 alpha( k+i ) = zero
636 beta( k+i ) = one
637 CALL ccopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),
638 $ lda )
639 END IF
640 70 CONTINUE
641*
642* Post-assignment
643*
644 DO 80 i = m + 1, k + l
645 alpha( i ) = zero
646 beta( i ) = one
647 80 CONTINUE
648*
649 IF( k+l.LT.n ) THEN
650 DO 90 i = k + l + 1, n
651 alpha( i ) = zero
652 beta( i ) = zero
653 90 CONTINUE
654 END IF
655*
656 100 CONTINUE
657 ncycle = kcycle
658*
659 RETURN
660*
661* End of CTGSJA
662*
clags2
subroutine clags2(upper, a1, a2, a3, b1, b2, b3, csu, snu, csv, snv, csq, snq)
CLAGS2
Definition clags2.f:158
clapll
subroutine clapll(n, x, incx, y, incy, ssmin)
CLAPLL measures the linear dependence of two vectors.
Definition clapll.f:100

◆ ctgsna()

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

CTGSNA

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

Purpose:
!>
!> CTGSNA 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 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 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 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 CTGEVC.
!>          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 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 CTGEVC.
!>          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 REAL 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 REAL 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 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 CLATDF.
!>
!>  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 ctgsna.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 REAL DIF( * ), S( * )
324 COMPLEX A( LDA, * ), B( LDB, * ), VL( LDVL, * ),
325 $ VR( LDVR, * ), WORK( * )
326* ..
327*
328* =====================================================================
329*
330* .. Parameters ..
331 REAL ZERO, ONE
332 INTEGER IDIFJB
333 parameter( zero = 0.0e+0, one = 1.0e+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 REAL BIGNUM, COND, EPS, LNRM, RNRM, SCALE, SMLNUM
339 COMPLEX YHAX, YHBX
340* ..
341* .. Local Arrays ..
342 COMPLEX DUMMY( 1 ), DUMMY1( 1 )
343* ..
344* .. External Functions ..
345 LOGICAL LSAME
346 REAL SCNRM2, SLAMCH, SLAPY2
347 COMPLEX CDOTC
348 EXTERNAL lsame, scnrm2, slamch, slapy2, cdotc
349* ..
350* .. External Subroutines ..
351 EXTERNAL cgemv, clacpy, ctgexc, ctgsyl, slabad, xerbla
352* ..
353* .. Intrinsic Functions ..
354 INTRINSIC abs, cmplx, 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( 'CTGSNA', -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 = slamch( 'P' )
429 smlnum = slamch( 'S' ) / eps
430 bignum = one / smlnum
431 CALL slabad( 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 = scnrm2( n, vr( 1, ks ), 1 )
451 lnrm = scnrm2( n, vl( 1, ks ), 1 )
452 CALL cgemv( 'N', n, n, cmplx( one, zero ), a, lda,
453 $ vr( 1, ks ), 1, cmplx( zero, zero ), work, 1 )
454 yhax = cdotc( n, work, 1, vl( 1, ks ), 1 )
455 CALL cgemv( 'N', n, n, cmplx( one, zero ), b, ldb,
456 $ vr( 1, ks ), 1, cmplx( zero, zero ), work, 1 )
457 yhbx = cdotc( n, work, 1, vl( 1, ks ), 1 )
458 cond = slapy2( 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 ) = slapy2( 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 clacpy( 'Full', n, n, a, lda, work, n )
478 CALL clacpy( 'Full', n, n, b, ldb, work( n*n+1 ), n )
479 ifst = k
480 ilst = 1
481*
482 CALL ctgexc( .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 ctgsyl( '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 CTGSNA
515*
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74

◆ ctpcon()

subroutine ctpcon ( character norm,
character uplo,
character diag,
integer n,
complex, dimension( * ) ap,
real rcond,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CTPCON

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

Purpose:
!>
!> CTPCON 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 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 REAL
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 128 of file ctpcon.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 REAL RCOND
139* ..
140* .. Array Arguments ..
141 REAL RWORK( * )
142 COMPLEX AP( * ), WORK( * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 REAL ONE, ZERO
149 parameter( one = 1.0e+0, zero = 0.0e+0 )
150* ..
151* .. Local Scalars ..
152 LOGICAL NOUNIT, ONENRM, UPPER
153 CHARACTER NORMIN
154 INTEGER IX, KASE, KASE1
155 REAL AINVNM, ANORM, SCALE, SMLNUM, XNORM
156 COMPLEX ZDUM
157* ..
158* .. Local Arrays ..
159 INTEGER ISAVE( 3 )
160* ..
161* .. External Functions ..
162 LOGICAL LSAME
163 INTEGER ICAMAX
164 REAL CLANTP, SLAMCH
165 EXTERNAL lsame, icamax, clantp, slamch
166* ..
167* .. External Subroutines ..
168 EXTERNAL clacn2, clatps, csrscl, xerbla
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC abs, aimag, max, real
172* ..
173* .. Statement Functions ..
174 REAL CABS1
175* ..
176* .. Statement Function definitions ..
177 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CTPCON', -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 = slamch( 'Safe minimum' )*real( max( 1, n ) )
211*
212* Compute the norm of the triangular matrix A.
213*
214 anorm = clantp( 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 clacn2( 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 clatps( uplo, 'No transpose', diag, normin, n, ap,
238 $ work, scale, rwork, info )
239 ELSE
240*
241* Multiply by inv(A**H).
242*
243 CALL clatps( 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 = icamax( n, work, 1 )
252 xnorm = cabs1( work( ix ) )
253 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
254 $ GO TO 20
255 CALL csrscl( 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 CTPCON
270*
clantp
real function clantp(norm, uplo, diag, n, ap, work)
CLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clantp.f:125

◆ ctpmqrt()

subroutine ctpmqrt ( character side,
character trans,
integer m,
integer n,
integer k,
integer l,
integer nb,
complex, dimension( ldv, * ) v,
integer ldv,
complex, dimension( ldt, * ) t,
integer ldt,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( * ) work,
integer info )

CTPMQRT

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

Purpose:
!>
!> CTPMQRT 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 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 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 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 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 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 ctpmqrt.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 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 ctprfb, 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( 'CTPMQRT', -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 ctprfb( '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 ctprfb( '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 ctprfb( '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 ctprfb( '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 CTPMQRT
364*
ctprfb
subroutine ctprfb(side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, a, lda, b, ldb, work, ldwork)
CTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matri...
Definition ctprfb.f:251

◆ ctpqrt()

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

CTPQRT

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

Purpose:
!>
!> CTPQRT 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 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 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 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 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 ctpqrt.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 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 ctpqrt2, ctprfb, 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( 'CTPQRT', -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 ctpqrt2( 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 ctprfb( '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 CTPQRT
266*
ctpqrt2
subroutine ctpqrt2(m, n, l, a, lda, b, ldb, t, ldt, info)
CTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix,...
Definition ctpqrt2.f:173

◆ ctpqrt2()

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

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

Purpose:
!>
!> CTPQRT2 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 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 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 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 ctpqrt2.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 A( LDA, * ), B( LDB, * ), T( LDT, * )
183* ..
184*
185* =====================================================================
186*
187* .. Parameters ..
188 COMPLEX 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 ALPHA
194* ..
195* .. External Subroutines ..
196 EXTERNAL clarfg, cgemv, cgerc, ctrmv, 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( 'CTPQRT2', -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 clarfg( 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 cgemv( '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 cgerc( 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 ctrmv( 'U', 'C', 'N', p, b( mp, 1 ), ldb,
274 $ t( 1, i ), 1 )
275*
276* Rectangular part of B2
277*
278 CALL cgemv( '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 cgemv( '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 ctrmv( '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 CTPQRT2
298*

◆ ctprfs()

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

CTPRFS

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

Purpose:
!>
!> CTPRFS 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 CTPTRS or some other
!> means before entering this routine.  CTPRFS 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 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 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 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 REAL 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 REAL 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 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 172 of file ctprfs.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 REAL BERR( * ), FERR( * ), RWORK( * )
185 COMPLEX AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
186* ..
187*
188* =====================================================================
189*
190* .. Parameters ..
191 REAL ZERO
192 parameter( zero = 0.0e+0 )
193 COMPLEX ONE
194 parameter( one = ( 1.0e+0, 0.0e+0 ) )
195* ..
196* .. Local Scalars ..
197 LOGICAL NOTRAN, NOUNIT, UPPER
198 CHARACTER TRANSN, TRANST
199 INTEGER I, J, K, KASE, KC, NZ
200 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
201 COMPLEX ZDUM
202* ..
203* .. Local Arrays ..
204 INTEGER ISAVE( 3 )
205* ..
206* .. External Subroutines ..
207 EXTERNAL caxpy, ccopy, clacn2, ctpmv, ctpsv, xerbla
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC abs, aimag, max, real
211* ..
212* .. External Functions ..
213 LOGICAL LSAME
214 REAL SLAMCH
215 EXTERNAL lsame, slamch
216* ..
217* .. Statement Functions ..
218 REAL CABS1
219* ..
220* .. Statement Function definitions ..
221 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CTPRFS', -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 = slamch( 'Epsilon' )
275 safmin = slamch( '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 ccopy( n, x( 1, j ), 1, work, 1 )
287 CALL ctpmv( uplo, trans, diag, n, ap, work, 1 )
288 CALL caxpy( 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 CLACN2 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 clacn2( 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 ctpsv( 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 ctpsv( 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 CTPRFS
480*

◆ ctptri()

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

CTPTRI

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

Purpose:
!>
!> CTPTRI 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 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 ctptri.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 AP( * )
128* ..
129*
130* =====================================================================
131*
132* .. Parameters ..
133 COMPLEX ONE, ZERO
134 parameter( one = ( 1.0e+0, 0.0e+0 ),
135 $ zero = ( 0.0e+0, 0.0e+0 ) )
136* ..
137* .. Local Scalars ..
138 LOGICAL NOUNIT, UPPER
139 INTEGER J, JC, JCLAST, JJ
140 COMPLEX AJJ
141* ..
142* .. External Functions ..
143 LOGICAL LSAME
144 EXTERNAL lsame
145* ..
146* .. External Subroutines ..
147 EXTERNAL cscal, ctpmv, xerbla
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( 'CTPTRI', -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 ctpmv( 'Upper', 'No transpose', diag, j-1, ap,
205 $ ap( jc ), 1 )
206 CALL cscal( 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 ctpmv( 'Lower', 'No transpose', diag, n-j,
227 $ ap( jclast ), ap( jc+1 ), 1 )
228 CALL cscal( 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 CTPTRI
238*

◆ ctptrs()

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

CTPTRS

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

Purpose:
!>
!> CTPTRS 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 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 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 ctptrs.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 AP( * ), B( LDB, * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 COMPLEX ZERO
147 parameter( zero = ( 0.0e+0, 0.0e+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 ctpsv, xerbla
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( 'CTPTRS', -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 ctpsv( uplo, trans, diag, n, ap, b( 1, j ), 1 )
219 30 CONTINUE
220*
221 RETURN
222*
223* End of CTPTRS
224*

◆ ctpttf()

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

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

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

Purpose:
!>
!> CTPTTF 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 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 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 ctpttf.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 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 conjg, 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( 'CTPTTF', -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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 CTPTTF
535*

◆ ctpttr()

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

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

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

Purpose:
!>
!> CTPTTR 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 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 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 ctpttr.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 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( 'CTPTTR', -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 CTPTTR
172*

◆ ctrcon()

subroutine ctrcon ( character norm,
character uplo,
character diag,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real rcond,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CTRCON

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

Purpose:
!>
!> CTRCON 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 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 REAL
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 135 of file ctrcon.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 REAL RCOND
146* ..
147* .. Array Arguments ..
148 REAL RWORK( * )
149 COMPLEX A( LDA, * ), WORK( * )
150* ..
151*
152* =====================================================================
153*
154* .. Parameters ..
155 REAL ONE, ZERO
156 parameter( one = 1.0e+0, zero = 0.0e+0 )
157* ..
158* .. Local Scalars ..
159 LOGICAL NOUNIT, ONENRM, UPPER
160 CHARACTER NORMIN
161 INTEGER IX, KASE, KASE1
162 REAL AINVNM, ANORM, SCALE, SMLNUM, XNORM
163 COMPLEX ZDUM
164* ..
165* .. Local Arrays ..
166 INTEGER ISAVE( 3 )
167* ..
168* .. External Functions ..
169 LOGICAL LSAME
170 INTEGER ICAMAX
171 REAL CLANTR, SLAMCH
172 EXTERNAL lsame, icamax, clantr, slamch
173* ..
174* .. External Subroutines ..
175 EXTERNAL clacn2, clatrs, csrscl, xerbla
176* ..
177* .. Intrinsic Functions ..
178 INTRINSIC abs, aimag, max, real
179* ..
180* .. Statement Functions ..
181 REAL CABS1
182* ..
183* .. Statement Function definitions ..
184 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CTRCON', -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 = slamch( 'Safe minimum' )*real( max( 1, n ) )
220*
221* Compute the norm of the triangular matrix A.
222*
223 anorm = clantr( 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 clacn2( 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 clatrs( 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 clatrs( 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 = icamax( n, work, 1 )
261 xnorm = cabs1( work( ix ) )
262 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
263 $ GO TO 20
264 CALL csrscl( 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 CTRCON
279*
clantr
real function clantr(norm, uplo, diag, m, n, a, lda, work)
CLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clantr.f:142
clatrs
subroutine clatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
CLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition clatrs.f:239

◆ ctrevc()

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

CTREVC

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

Purpose:
!>
!> CTREVC 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 CHSEQR.
!>
!> 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 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 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 CHSEQR).
!>          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 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 CHSEQR).
!>          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 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
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 ctrevc.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 REAL RWORK( * )
230 COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
231 $ WORK( * )
232* ..
233*
234* =====================================================================
235*
236* .. Parameters ..
237 REAL ZERO, ONE
238 parameter( zero = 0.0e+0, one = 1.0e+0 )
239 COMPLEX CMZERO, CMONE
240 parameter( cmzero = ( 0.0e+0, 0.0e+0 ),
241 $ cmone = ( 1.0e+0, 0.0e+0 ) )
242* ..
243* .. Local Scalars ..
244 LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
245 INTEGER I, II, IS, J, K, KI
246 REAL OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
247 COMPLEX CDUM
248* ..
249* .. External Functions ..
250 LOGICAL LSAME
251 INTEGER ICAMAX
252 REAL SCASUM, SLAMCH
253 EXTERNAL lsame, icamax, scasum, slamch
254* ..
255* .. External Subroutines ..
256 EXTERNAL ccopy, cgemv, clatrs, csscal, slabad, xerbla
257* ..
258* .. Intrinsic Functions ..
259 INTRINSIC abs, aimag, cmplx, conjg, max, real
260* ..
261* .. Statement Functions ..
262 REAL CABS1
263* ..
264* .. Statement Function definitions ..
265 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( 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( 'CTREVC', -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 = slamch( 'Safe minimum' )
321 ovfl = one / unfl
322 CALL slabad( unfl, ovfl )
323 ulp = slamch( '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 ) = scasum( 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 clatrs( '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 ccopy( ki, work( 1 ), 1, vr( 1, is ), 1 )
381*
382 ii = icamax( ki, vr( 1, is ), 1 )
383 remax = one / cabs1( vr( ii, is ) )
384 CALL csscal( 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 cgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1 ),
392 $ 1, cmplx( scale ), vr( 1, ki ), 1 )
393*
394 ii = icamax( n, vr( 1, ki ), 1 )
395 remax = one / cabs1( vr( ii, ki ) )
396 CALL csscal( 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 ) = -conjg( 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 clatrs( '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 ccopy( n-ki+1, work( ki ), 1, vl( ki, is ), 1 )
450*
451 ii = icamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
452 remax = one / cabs1( vl( ii, is ) )
453 CALL csscal( 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 cgemv( 'N', n, n-ki, cmone, vl( 1, ki+1 ), ldvl,
461 $ work( ki+1 ), 1, cmplx( scale ),
462 $ vl( 1, ki ), 1 )
463*
464 ii = icamax( n, vl( 1, ki ), 1 )
465 remax = one / cabs1( vl( ii, ki ) )
466 CALL csscal( 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 CTREVC
482*
scasum
real function scasum(n, cx, incx)
SCASUM
Definition scasum.f:72

◆ ctrevc3()

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

CTREVC3

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

Purpose:
!>
!> CTREVC3 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 CHSEQR.
!>
!> 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 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 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 CHSEQR).
!>          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 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 CHSEQR).
!>          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 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 REAL 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 ctrevc3.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 REAL RWORK( * )
257 COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
258 $ WORK( * )
259* ..
260*
261* =====================================================================
262*
263* .. Parameters ..
264 REAL ZERO, ONE
265 parameter( zero = 0.0e+0, one = 1.0e+0 )
266 COMPLEX CZERO, CONE
267 parameter( czero = ( 0.0e+0, 0.0e+0 ),
268 $ cone = ( 1.0e+0, 0.0e+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 REAL OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
276 COMPLEX CDUM
277* ..
278* .. External Functions ..
279 LOGICAL LSAME
280 INTEGER ILAENV, ICAMAX
281 REAL SLAMCH, SCASUM
282 EXTERNAL lsame, ilaenv, icamax, slamch, scasum
283* ..
284* .. External Subroutines ..
285 EXTERNAL xerbla, ccopy, claset, csscal, cgemm, cgemv,
286 $ clatrs, clacpy, slabad
287* ..
288* .. Intrinsic Functions ..
289 INTRINSIC abs, real, cmplx, conjg, aimag, max
290* ..
291* .. Statement Functions ..
292 REAL CABS1
293* ..
294* .. Statement Function definitions ..
295 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( 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, 'CTREVC', 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( 'CTREVC3', -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 claset( '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 = slamch( 'Safe minimum' )
373 ovfl = one / unfl
374 CALL slabad( unfl, ovfl )
375 ulp = slamch( '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 ) = scasum( 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 clatrs( '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 ccopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 )
443*
444 ii = icamax( ki, vr( 1, is ), 1 )
445 remax = one / cabs1( vr( ii, is ) )
446 CALL csscal( 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 cgemv( 'N', n, ki-1, cone, vr, ldvr,
457 $ work( 1 + iv*n ), 1, cmplx( scale ),
458 $ vr( 1, ki ), 1 )
459*
460 ii = icamax( n, vr( 1, ki ), 1 )
461 remax = one / cabs1( vr( ii, ki ) )
462 CALL csscal( 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 cgemm( '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 = icamax( n, work( 1 + (nb+k)*n ), 1 )
484 remax = one / cabs1( work( ii + (nb+k)*n ) )
485 CALL csscal( n, remax, work( 1 + (nb+k)*n ), 1 )
486 END DO
487 CALL clacpy( '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 clatrs( '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 ccopy( n-ki+1, work( ki + iv*n ), 1, vl(ki,is), 1 )
558*
559 ii = icamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
560 remax = one / cabs1( vl( ii, is ) )
561 CALL csscal( 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 cgemv( 'N', n, n-ki, cone, vl( 1, ki+1 ), ldvl,
572 $ work( ki+1 + iv*n ), 1, cmplx( scale ),
573 $ vl( 1, ki ), 1 )
574*
575 ii = icamax( n, vl( 1, ki ), 1 )
576 remax = one / cabs1( vl( ii, ki ) )
577 CALL csscal( 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 cgemm( '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 = icamax( n, work( 1 + (nb+k)*n ), 1 )
600 remax = one / cabs1( work( ii + (nb+k)*n ) )
601 CALL csscal( n, remax, work( 1 + (nb+k)*n ), 1 )
602 END DO
603 CALL clacpy( '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 CTREVC3
625*

◆ ctrexc()

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

CTREXC

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

Purpose:
!>
!> CTREXC 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 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 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 ctrexc.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 Q( LDQ, * ), T( LDT, * )
137* ..
138*
139* =====================================================================
140*
141* .. Local Scalars ..
142 LOGICAL WANTQ
143 INTEGER K, M1, M2, M3
144 REAL CS
145 COMPLEX SN, T11, T22, TEMP
146* ..
147* .. External Functions ..
148 LOGICAL LSAME
149 EXTERNAL lsame
150* ..
151* .. External Subroutines ..
152 EXTERNAL clartg, crot, xerbla
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC conjg, 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( 'CTREXC', -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 clartg( 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 crot( n-k-1, t( k, k+2 ), ldt, t( k+1, k+2 ), ldt, cs,
217 $ sn )
218 CALL crot( k-1, t( 1, k ), 1, t( 1, k+1 ), 1, cs, conjg( sn ) )
219*
220 t( k, k ) = t22
221 t( k+1, k+1 ) = t11
222*
223 IF( wantq ) THEN
224*
225* Accumulate transformation in the matrix Q.
226*
227 CALL crot( n, q( 1, k ), 1, q( 1, k+1 ), 1, cs,
228 $ conjg( sn ) )
229 END IF
230*
231 10 CONTINUE
232*
233 RETURN
234*
235* End of CTREXC
236*

◆ ctrrfs()

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

CTRRFS

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

Purpose:
!>
!> CTRRFS 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 CTRTRS or some other
!> means before entering this routine.  CTRRFS 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 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 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 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 REAL 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 REAL 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 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 180 of file ctrrfs.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 REAL BERR( * ), FERR( * ), RWORK( * )
193 COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ),
194 $ X( LDX, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 REAL ZERO
201 parameter( zero = 0.0e+0 )
202 COMPLEX ONE
203 parameter( one = ( 1.0e+0, 0.0e+0 ) )
204* ..
205* .. Local Scalars ..
206 LOGICAL NOTRAN, NOUNIT, UPPER
207 CHARACTER TRANSN, TRANST
208 INTEGER I, J, K, KASE, NZ
209 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
210 COMPLEX ZDUM
211* ..
212* .. Local Arrays ..
213 INTEGER ISAVE( 3 )
214* ..
215* .. External Subroutines ..
216 EXTERNAL caxpy, ccopy, clacn2, ctrmv, ctrsv, xerbla
217* ..
218* .. Intrinsic Functions ..
219 INTRINSIC abs, aimag, max, real
220* ..
221* .. External Functions ..
222 LOGICAL LSAME
223 REAL SLAMCH
224 EXTERNAL lsame, slamch
225* ..
226* .. Statement Functions ..
227 REAL CABS1
228* ..
229* .. Statement Function definitions ..
230 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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( 'CTRRFS', -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 = slamch( 'Epsilon' )
286 safmin = slamch( '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 ccopy( n, x( 1, j ), 1, work, 1 )
298 CALL ctrmv( uplo, trans, diag, n, a, lda, work, 1 )
299 CALL caxpy( 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 CLACN2 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 clacn2( 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 ctrsv( 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 ctrsv( 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 CTRRFS
475*
ctrsv
subroutine ctrsv(uplo, trans, diag, n, a, lda, x, incx)
CTRSV
Definition ctrsv.f:149

◆ ctrsen()

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

CTRSEN

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

Purpose:
!>
!> CTRSEN 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 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 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 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 REAL
!>          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 REAL
!>          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 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:
!>
!>  CTRSEN 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 ctrsen.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 REAL S, SEP
273* ..
274* .. Array Arguments ..
275 LOGICAL SELECT( * )
276 COMPLEX Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
277* ..
278*
279* =====================================================================
280*
281* .. Parameters ..
282 REAL ZERO, ONE
283 parameter( zero = 0.0e+0, one = 1.0e+0 )
284* ..
285* .. Local Scalars ..
286 LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP
287 INTEGER IERR, K, KASE, KS, LWMIN, N1, N2, NN
288 REAL EST, RNORM, SCALE
289* ..
290* .. Local Arrays ..
291 INTEGER ISAVE( 3 )
292 REAL RWORK( 1 )
293* ..
294* .. External Functions ..
295 LOGICAL LSAME
296 REAL CLANGE
297 EXTERNAL lsame, clange
298* ..
299* .. External Subroutines ..
300 EXTERNAL clacn2, clacpy, ctrexc, ctrsyl, xerbla
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( 'CTRSEN', -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 = clange( '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 ctrexc( 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 clacpy( 'F', n1, n2, t( 1, n1+1 ), ldt, work, n1 )
394 CALL ctrsyl( '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 = clange( '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 clacn2( 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 ctrsyl( '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 ctrsyl( '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 CTRSEN
452*
clange
real function clange(norm, m, n, a, lda, work)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clange.f:115
ctrexc
subroutine ctrexc(compq, n, t, ldt, q, ldq, ifst, ilst, info)
CTREXC
Definition ctrexc.f:126
ctrsyl
subroutine ctrsyl(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
CTRSYL
Definition ctrsyl.f:157

◆ ctrsna()

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

CTRSNA

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

Purpose:
!>
!> CTRSNA 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 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 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
!>          CHSEIN or CTREVC.
!>          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 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
!>          CHSEIN or CTREVC.
!>          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 REAL 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 REAL 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 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 REAL 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 ctrsna.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 REAL RWORK( * ), S( * ), SEP( * )
261 COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
262 $ WORK( LDWORK, * )
263* ..
264*
265* =====================================================================
266*
267* .. Parameters ..
268 REAL ZERO, ONE
269 parameter( zero = 0.0e+0, one = 1.0+0 )
270* ..
271* .. Local Scalars ..
272 LOGICAL SOMCON, WANTBH, WANTS, WANTSP
273 CHARACTER NORMIN
274 INTEGER I, IERR, IX, J, K, KASE, KS
275 REAL BIGNUM, EPS, EST, LNRM, RNRM, SCALE, SMLNUM,
276 $ XNORM
277 COMPLEX CDUM, PROD
278* ..
279* .. Local Arrays ..
280 INTEGER ISAVE( 3 )
281 COMPLEX DUMMY( 1 )
282* ..
283* .. External Functions ..
284 LOGICAL LSAME
285 INTEGER ICAMAX
286 REAL SCNRM2, SLAMCH
287 COMPLEX CDOTC
288 EXTERNAL lsame, icamax, scnrm2, slamch, cdotc
289* ..
290* .. External Subroutines ..
291 EXTERNAL clacn2, clacpy, clatrs, csrscl, ctrexc, slabad,
292 $ xerbla
293* ..
294* .. Intrinsic Functions ..
295 INTRINSIC abs, aimag, max, real
296* ..
297* .. Statement Functions ..
298 REAL CABS1
299* ..
300* .. Statement Function definitions ..
301 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( 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( 'CTRSNA', -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 = slamch( 'P' )
369 smlnum = slamch( 'S' ) / eps
370 bignum = one / smlnum
371 CALL slabad( 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 = cdotc( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
387 rnrm = scnrm2( n, vr( 1, ks ), 1 )
388 lnrm = scnrm2( 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 clacpy( 'Full', n, n, t, ldt, work, ldwork )
402 CALL ctrexc( '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 clacn2( 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 clatrs( '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 clatrs( '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 = icamax( 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 csrscl( 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 CTRSNA
460*

◆ ctrti2()

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

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

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

Purpose:
!>
!> CTRTI2 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 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 ctrti2.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 A( LDA, * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 COMPLEX ONE
127 parameter( one = ( 1.0e+0, 0.0e+0 ) )
128* ..
129* .. Local Scalars ..
130 LOGICAL NOUNIT, UPPER
131 INTEGER J
132 COMPLEX AJJ
133* ..
134* .. External Functions ..
135 LOGICAL LSAME
136 EXTERNAL lsame
137* ..
138* .. External Subroutines ..
139 EXTERNAL cscal, ctrmv, xerbla
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( 'CTRTI2', -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 ctrmv( 'Upper', 'No transpose', diag, j-1, a, lda,
180 $ a( 1, j ), 1 )
181 CALL cscal( 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 ctrmv( 'Lower', 'No transpose', diag, n-j,
199 $ a( j+1, j+1 ), lda, a( j+1, j ), 1 )
200 CALL cscal( n-j, ajj, a( j+1, j ), 1 )
201 END IF
202 20 CONTINUE
203 END IF
204*
205 RETURN
206*
207* End of CTRTI2
208*

◆ ctrtri()

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

CTRTRI

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

Purpose:
!>
!> CTRTRI 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 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 ctrtri.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 A( LDA, * )
120* ..
121*
122* =====================================================================
123*
124* .. Parameters ..
125 COMPLEX ONE, ZERO
126 parameter( one = ( 1.0e+0, 0.0e+0 ),
127 $ zero = ( 0.0e+0, 0.0e+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 ctrmm, ctrsm, ctrti2, xerbla
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( 'CTRTRI', -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, 'CTRTRI', uplo // diag, n, -1, -1, -1 )
183 IF( nb.LE.1 .OR. nb.GE.n ) THEN
184*
185* Use unblocked code
186*
187 CALL ctrti2( 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 ctrmm( 'Left', 'Upper', 'No transpose', diag, j-1,
202 $ jb, one, a, lda, a( 1, j ), lda )
203 CALL ctrsm( '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 ctrti2( '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 ctrmm( '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 ctrsm( '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 ctrti2( 'Lower', diag, jb, a( j, j ), lda, info )
232 30 CONTINUE
233 END IF
234 END IF
235*
236 RETURN
237*
238* End of CTRTRI
239*
ctrti2
subroutine ctrti2(uplo, diag, n, a, lda, info)
CTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
Definition ctrti2.f:110

◆ ctrtrs()

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

CTRTRS

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

Purpose:
!>
!> CTRTRS 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 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 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 ctrtrs.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 A( LDA, * ), B( LDB, * )
151* ..
152*
153* =====================================================================
154*
155* .. Parameters ..
156 COMPLEX ZERO, ONE
157 parameter( zero = ( 0.0e+0, 0.0e+0 ),
158 $ one = ( 1.0e+0, 0.0e+0 ) )
159* ..
160* .. Local Scalars ..
161 LOGICAL NOUNIT
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 EXTERNAL lsame
166* ..
167* .. External Subroutines ..
168 EXTERNAL ctrsm, xerbla
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( 'CTRTRS', -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 ctrsm( 'Left', uplo, trans, diag, n, nrhs, one, a, lda, b,
218 $ ldb )
219*
220 RETURN
221*
222* End of CTRTRS
223*

◆ ctrttf()

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

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

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

Purpose:
!>
!> CTRTTF 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 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 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 ctrttf.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 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 conjg, 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( 'CTRTTF', -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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 ) = conjg( 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 CTRTTF
533*

◆ ctrttp()

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

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

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

Purpose:
!>
!> CTRTTP 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 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 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 ctrttp.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 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( 'CTRTTP', -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 CTRTTP
172*

◆ ctzrqf()

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

CTZRQF

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine CTZRZF.
!>
!> CTZRQF 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 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 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 ctzrqf.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 A( LDA, * ), TAU( * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 COMPLEX CONE, CZERO
154 parameter( cone = ( 1.0e+0, 0.0e+0 ),
155 $ czero = ( 0.0e+0, 0.0e+0 ) )
156* ..
157* .. Local Scalars ..
158 INTEGER I, K, M1
159 COMPLEX ALPHA
160* ..
161* .. Intrinsic Functions ..
162 INTRINSIC conjg, max, min
163* ..
164* .. External Subroutines ..
165 EXTERNAL caxpy, ccopy, cgemv, cgerc, clacgv, clarfg,
166 $ xerbla
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( 'CTZRQF', -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 ) = conjg( a( k, k ) )
201 CALL clacgv( n-m, a( k, m1 ), lda )
202 alpha = a( k, k )
203 CALL clarfg( n-m+1, alpha, a( k, m1 ), lda, tau( k ) )
204 a( k, k ) = alpha
205 tau( k ) = conjg( 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 ccopy( k-1, a( 1, k ), 1, tau, 1 )
217*
218* Form w = a( k ) + B*z( k ) in TAU.
219*
220 CALL cgemv( '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 caxpy( k-1, -conjg( tau( k ) ), tau, 1, a( 1, k ),
227 $ 1 )
228 CALL cgerc( k-1, n-m, -conjg( 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 CTZRQF
237*

◆ ctzrzf()

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

CTZRZF

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

Purpose:
!>
!> CTZRZF 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 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 array, dimension (M)
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is COMPLEX 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 CTZRZF,
!>  and tau(k) is the kth element of the array TAU.
!>
!>

Definition at line 150 of file ctzrzf.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 A( LDA, * ), TAU( * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 COMPLEX ZERO
167 parameter( zero = ( 0.0e+0, 0.0e+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, clarzb, clarzt, clatrz
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, 'CGERQF', ' ', 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( 'CTZRZF', -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, 'CGERQF', ' ', 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, 'CGERQF', ' ', 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 clatrz( 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 clarzt( '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 clarzb( '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 clatrz( mu, n, n-m, a, lda, tau, work )
303*
304 work( 1 ) = lwkopt
305*
306 RETURN
307*
308* End of CTZRZF
309*
clarzt
subroutine clarzt(direct, storev, n, k, v, ldv, tau, t, ldt)
CLARZT forms the triangular factor T of a block reflector H = I - vtvH.
Definition clarzt.f:185
clatrz
subroutine clatrz(m, n, l, a, lda, tau, work)
CLATRZ factors an upper trapezoidal matrix by means of unitary transformations.
Definition clatrz.f:140
clarzb
subroutine clarzb(side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, c, ldc, work, ldwork)
CLARZB applies a block reflector or its conjugate-transpose to a general matrix.
Definition clarzb.f:183

◆ cunbdb()

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

CUNBDB

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

Purpose:
!>
!> CUNBDB 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 CUNCSD
!> 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 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 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 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 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 REAL 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 REAL 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 array, dimension (P)
!>          The scalar factors of the elementary reflectors that define
!>          P1.
!>
[out]TAUP2
!>          TAUP2 is COMPLEX array, dimension (M-P)
!>          The scalar factors of the elementary reflectors that define
!>          P2.
!>
[out]TAUQ1
!>          TAUQ1 is COMPLEX array, dimension (Q)
!>          The scalar factors of the elementary reflectors that define
!>          Q1.
!>
[out]TAUQ2
!>          TAUQ2 is COMPLEX array, dimension (M-Q)
!>          The scalar factors of the elementary reflectors that define
!>          Q2.
!>
[out]WORK
!>          WORK is COMPLEX 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 CUNCSD for details.
!>
!>  P1, P2, Q1, and Q2 are represented as products of elementary
!>  reflectors. See CUNCSD for details on generating P1, P2, Q1, and Q2
!>  using CUNGQR and CUNGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 284 of file cunbdb.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 REAL PHI( * ), THETA( * )
299 COMPLEX TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ),
300 $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ),
301 $ X21( LDX21, * ), X22( LDX22, * )
302* ..
303*
304* ====================================================================
305*
306* .. Parameters ..
307 REAL REALONE
308 parameter( realone = 1.0e0 )
309 COMPLEX ONE
310 parameter( one = (1.0e0,0.0e0) )
311* ..
312* .. Local Scalars ..
313 LOGICAL COLMAJOR, LQUERY
314 INTEGER I, LWORKMIN, LWORKOPT
315 REAL Z1, Z2, Z3, Z4
316* ..
317* .. External Subroutines ..
318 EXTERNAL caxpy, clarf, clarfgp, cscal, xerbla
319 EXTERNAL clacgv
320*
321* ..
322* .. External Functions ..
323 REAL SCNRM2
324 LOGICAL LSAME
325 EXTERNAL scnrm2, lsame
326* ..
327* .. Intrinsic Functions
328 INTRINSIC atan2, cos, max, min, sin
329 INTRINSIC cmplx, conjg
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 cscal( p-i+1, cmplx( z1, 0.0e0 ), x11(i,i), 1 )
402 ELSE
403 CALL cscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0e0 ),
404 $ x11(i,i), 1 )
405 CALL caxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),
406 $ 0.0e0 ), x12(i,i-1), 1, x11(i,i), 1 )
407 END IF
408 IF( i .EQ. 1 ) THEN
409 CALL cscal( m-p-i+1, cmplx( z2, 0.0e0 ), x21(i,i), 1 )
410 ELSE
411 CALL cscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0e0 ),
412 $ x21(i,i), 1 )
413 CALL caxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),
414 $ 0.0e0 ), x22(i,i-1), 1, x21(i,i), 1 )
415 END IF
416*
417 theta(i) = atan2( scnrm2( m-p-i+1, x21(i,i), 1 ),
418 $ scnrm2( p-i+1, x11(i,i), 1 ) )
419*
420 IF( p .GT. i ) THEN
421 CALL clarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
422 ELSE IF ( p .EQ. i ) THEN
423 CALL clarfgp( 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 clarfgp( 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 clarfgp( 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 clarf( 'L', p-i+1, q-i, x11(i,i), 1,
437 $ conjg(taup1(i)), x11(i,i+1), ldx11, work )
438 CALL clarf( 'L', m-p-i+1, q-i, x21(i,i), 1,
439 $ conjg(taup2(i)), x21(i,i+1), ldx21, work )
440 END IF
441 IF ( m-q+1 .GT. i ) THEN
442 CALL clarf( 'L', p-i+1, m-q-i+1, x11(i,i), 1,
443 $ conjg(taup1(i)), x12(i,i), ldx12, work )
444 CALL clarf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1,
445 $ conjg(taup2(i)), x22(i,i), ldx22, work )
446 END IF
447*
448 IF( i .LT. q ) THEN
449 CALL cscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0e0 ),
450 $ x11(i,i+1), ldx11 )
451 CALL caxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0e0 ),
452 $ x21(i,i+1), ldx21, x11(i,i+1), ldx11 )
453 END IF
454 CALL cscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0e0 ),
455 $ x12(i,i), ldx12 )
456 CALL caxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0e0 ),
457 $ x22(i,i), ldx22, x12(i,i), ldx12 )
458*
459 IF( i .LT. q )
460 $ phi(i) = atan2( scnrm2( q-i, x11(i,i+1), ldx11 ),
461 $ scnrm2( m-q-i+1, x12(i,i), ldx12 ) )
462*
463 IF( i .LT. q ) THEN
464 CALL clacgv( q-i, x11(i,i+1), ldx11 )
465 IF ( i .EQ. q-1 ) THEN
466 CALL clarfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,
467 $ tauq1(i) )
468 ELSE
469 CALL clarfgp( 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 clacgv( m-q-i+1, x12(i,i), ldx12 )
476 IF ( m-q .EQ. i ) THEN
477 CALL clarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,
478 $ tauq2(i) )
479 ELSE
480 CALL clarfgp( 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 clarf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),
488 $ x11(i+1,i+1), ldx11, work )
489 CALL clarf( '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 clarf( '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 clarf( '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 clacgv( q-i, x11(i,i+1), ldx11 )
503 CALL clacgv( 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 cscal( m-q-i+1, cmplx( -z1*z4, 0.0e0 ), x12(i,i),
512 $ ldx12 )
513 CALL clacgv( m-q-i+1, x12(i,i), ldx12 )
514 IF ( i .GE. m-q ) THEN
515 CALL clarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,
516 $ tauq2(i) )
517 ELSE
518 CALL clarfgp( 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 clarf( '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 clarf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,
529 $ tauq2(i), x22(q+1,i), ldx22, work )
530*
531 CALL clacgv( 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 cscal( m-p-q-i+1, cmplx( z2*z4, 0.0e0 ),
540 $ x22(q+i,p+i), ldx22 )
541 CALL clacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 )
542 CALL clarfgp( 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 clarf( '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 clacgv( 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 cscal( p-i+1, cmplx( z1, 0.0e0 ), x11(i,i),
560 $ ldx11 )
561 ELSE
562 CALL cscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0e0 ),
563 $ x11(i,i), ldx11 )
564 CALL caxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),
565 $ 0.0e0 ), x12(i-1,i), ldx12, x11(i,i), ldx11 )
566 END IF
567 IF( i .EQ. 1 ) THEN
568 CALL cscal( m-p-i+1, cmplx( z2, 0.0e0 ), x21(i,i),
569 $ ldx21 )
570 ELSE
571 CALL cscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0e0 ),
572 $ x21(i,i), ldx21 )
573 CALL caxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),
574 $ 0.0e0 ), x22(i-1,i), ldx22, x21(i,i), ldx21 )
575 END IF
576*
577 theta(i) = atan2( scnrm2( m-p-i+1, x21(i,i), ldx21 ),
578 $ scnrm2( p-i+1, x11(i,i), ldx11 ) )
579*
580 CALL clacgv( p-i+1, x11(i,i), ldx11 )
581 CALL clacgv( m-p-i+1, x21(i,i), ldx21 )
582*
583 CALL clarfgp( 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 clarfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,
587 $ taup2(i) )
588 ELSE
589 CALL clarfgp( 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 clarf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),
595 $ x11(i+1,i), ldx11, work )
596 CALL clarf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11, taup1(i),
597 $ x12(i,i), ldx12, work )
598 CALL clarf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),
599 $ x21(i+1,i), ldx21, work )
600 CALL clarf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,
601 $ taup2(i), x22(i,i), ldx22, work )
602*
603 CALL clacgv( p-i+1, x11(i,i), ldx11 )
604 CALL clacgv( m-p-i+1, x21(i,i), ldx21 )
605*
606 IF( i .LT. q ) THEN
607 CALL cscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0e0 ),
608 $ x11(i+1,i), 1 )
609 CALL caxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0e0 ),
610 $ x21(i+1,i), 1, x11(i+1,i), 1 )
611 END IF
612 CALL cscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0e0 ),
613 $ x12(i,i), 1 )
614 CALL caxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0e0 ),
615 $ x22(i,i), 1, x12(i,i), 1 )
616*
617 IF( i .LT. q )
618 $ phi(i) = atan2( scnrm2( q-i, x11(i+1,i), 1 ),
619 $ scnrm2( m-q-i+1, x12(i,i), 1 ) )
620*
621 IF( i .LT. q ) THEN
622 CALL clarfgp( q-i, x11(i+1,i), x11(i+2,i), 1, tauq1(i) )
623 x11(i+1,i) = one
624 END IF
625 CALL clarfgp( 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 clarf( 'L', q-i, p-i, x11(i+1,i), 1,
630 $ conjg(tauq1(i)), x11(i+1,i+1), ldx11, work )
631 CALL clarf( 'L', q-i, m-p-i, x11(i+1,i), 1,
632 $ conjg(tauq1(i)), x21(i+1,i+1), ldx21, work )
633 END IF
634 CALL clarf( 'L', m-q-i+1, p-i, x12(i,i), 1, conjg(tauq2(i)),
635 $ x12(i,i+1), ldx12, work )
636
637 IF ( m-p .GT. i ) THEN
638 CALL clarf( 'L', m-q-i+1, m-p-i, x12(i,i), 1,
639 $ conjg(tauq2(i)), x22(i,i+1), ldx22, work )
640 END IF
641 END DO
642*
643* Reduce columns Q + 1, ..., P of X12, X22
644*
645 DO i = q + 1, p
646*
647 CALL cscal( m-q-i+1, cmplx( -z1*z4, 0.0e0 ), x12(i,i), 1 )
648 CALL clarfgp( 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 clarf( 'L', m-q-i+1, p-i, x12(i,i), 1,
653 $ conjg(tauq2(i)), x12(i,i+1), ldx12, work )
654 END IF
655 IF( m-p-q .GE. 1 )
656 $ CALL clarf( 'L', m-q-i+1, m-p-q, x12(i,i), 1,
657 $ conjg(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 cscal( m-p-q-i+1, cmplx( z2*z4, 0.0e0 ),
666 $ x22(p+i,q+i), 1 )
667 CALL clarfgp( 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 IF ( m-p-q .NE. i ) THEN
671 CALL clarf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1,
672 $ conjg(tauq2(p+i)), x22(p+i,q+i+1), ldx22,
673 $ work )
674 END IF
675 END DO
676*
677 END IF
678*
679 RETURN
680*
681* End of CUNBDB
682*
clarfgp
subroutine clarfgp(n, alpha, x, incx, tau)
CLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.
Definition clarfgp.f:104
clarf
subroutine clarf(side, m, n, v, incv, tau, c, ldc, work)
CLARF applies an elementary reflector to a general rectangular matrix.
Definition clarf.f:128

◆ cunbdb1()

subroutine cunbdb1 ( integer m,
integer p,
integer q,
complex, dimension(ldx11,*) x11,
integer ldx11,
complex, dimension(ldx21,*) x21,
integer ldx21,
real, dimension(*) theta,
real, dimension(*) phi,
complex, dimension(*) taup1,
complex, dimension(*) taup2,
complex, dimension(*) tauq1,
complex, dimension(*) work,
integer lwork,
integer info )

CUNBDB1

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

Purpose:
!>
!> CUNBDB1 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 CUNBDB2, CUNBDB3, and CUNBDB4 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 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 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 REAL array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is REAL 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 array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is COMPLEX array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is COMPLEX array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is COMPLEX 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 CUNCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
!>  and CUNGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 200 of file cunbdb1.f.

202*
203* -- LAPACK computational routine --
204* -- LAPACK is a software package provided by Univ. of Tennessee, --
205* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
206*
207* .. Scalar Arguments ..
208 INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
209* ..
210* .. Array Arguments ..
211 REAL PHI(*), THETA(*)
212 COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
213 $ X11(LDX11,*), X21(LDX21,*)
214* ..
215*
216* ====================================================================
217*
218* .. Parameters ..
219 COMPLEX ONE
220 parameter( one = (1.0e0,0.0e0) )
221* ..
222* .. Local Scalars ..
223 REAL C, S
224 INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
225 $ LWORKMIN, LWORKOPT
226 LOGICAL LQUERY
227* ..
228* .. External Subroutines ..
229 EXTERNAL clarf, clarfgp, cunbdb5, csrot, xerbla
230 EXTERNAL clacgv
231* ..
232* .. External Functions ..
233 REAL SCNRM2
234 EXTERNAL scnrm2
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. q .OR. m-p .LT. q ) THEN
249 info = -2
250 ELSE IF( q .LT. 0 .OR. m-q .LT. q ) 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-1, q-1 )
263 iorbdb5 = 2
264 lorbdb5 = q-2
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( 'CUNBDB1', -info )
274 RETURN
275 ELSE IF( lquery ) THEN
276 RETURN
277 END IF
278*
279* Reduce columns 1, ..., Q of X11 and X21
280*
281 DO i = 1, q
282*
283 CALL clarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
284 CALL clarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
285 theta(i) = atan2( real( x21(i,i) ), real( x11(i,i) ) )
286 c = cos( theta(i) )
287 s = sin( theta(i) )
288 x11(i,i) = one
289 x21(i,i) = one
290 CALL clarf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),
291 $ x11(i,i+1), ldx11, work(ilarf) )
292 CALL clarf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),
293 $ x21(i,i+1), ldx21, work(ilarf) )
294*
295 IF( i .LT. q ) THEN
296 CALL csrot( q-i, x11(i,i+1), ldx11, x21(i,i+1), ldx21, c,
297 $ s )
298 CALL clacgv( q-i, x21(i,i+1), ldx21 )
299 CALL clarfgp( q-i, x21(i,i+1), x21(i,i+2), ldx21, tauq1(i) )
300 s = real( x21(i,i+1) )
301 x21(i,i+1) = one
302 CALL clarf( 'R', p-i, q-i, x21(i,i+1), ldx21, tauq1(i),
303 $ x11(i+1,i+1), ldx11, work(ilarf) )
304 CALL clarf( 'R', m-p-i, q-i, x21(i,i+1), ldx21, tauq1(i),
305 $ x21(i+1,i+1), ldx21, work(ilarf) )
306 CALL clacgv( q-i, x21(i,i+1), ldx21 )
307 c = sqrt( scnrm2( p-i, x11(i+1,i+1), 1 )**2
308 $ + scnrm2( m-p-i, x21(i+1,i+1), 1 )**2 )
309 phi(i) = atan2( s, c )
310 CALL cunbdb5( p-i, m-p-i, q-i-1, x11(i+1,i+1), 1,
311 $ x21(i+1,i+1), 1, x11(i+1,i+2), ldx11,
312 $ x21(i+1,i+2), ldx21, work(iorbdb5), lorbdb5,
313 $ childinfo )
314 END IF
315*
316 END DO
317*
318 RETURN
319*
320* End of CUNBDB1
321*
cunbdb5
subroutine cunbdb5(m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
CUNBDB5
Definition cunbdb5.f:156

◆ cunbdb2()

subroutine cunbdb2 ( integer m,
integer p,
integer q,
complex, dimension(ldx11,*) x11,
integer ldx11,
complex, dimension(ldx21,*) x21,
integer ldx21,
real, dimension(*) theta,
real, dimension(*) phi,
complex, dimension(*) taup1,
complex, dimension(*) taup2,
complex, dimension(*) tauq1,
complex, dimension(*) work,
integer lwork,
integer info )

CUNBDB2

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

Purpose:
!>
!> CUNBDB2 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 CUNBDB1, CUNBDB3, and CUNBDB4 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 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 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 REAL array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is REAL 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 array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is COMPLEX array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is COMPLEX array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is COMPLEX 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 CUNCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
!>  and CUNGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 200 of file cunbdb2.f.

202*
203* -- LAPACK computational routine --
204* -- LAPACK is a software package provided by Univ. of Tennessee, --
205* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
206*
207* .. Scalar Arguments ..
208 INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
209* ..
210* .. Array Arguments ..
211 REAL PHI(*), THETA(*)
212 COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
213 $ X11(LDX11,*), X21(LDX21,*)
214* ..
215*
216* ====================================================================
217*
218* .. Parameters ..
219 COMPLEX NEGONE, ONE
220 parameter( negone = (-1.0e0,0.0e0),
221 $ one = (1.0e0,0.0e0) )
222* ..
223* .. Local Scalars ..
224 REAL C, S
225 INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
226 $ LWORKMIN, LWORKOPT
227 LOGICAL LQUERY
228* ..
229* .. External Subroutines ..
230 EXTERNAL clarf, clarfgp, cunbdb5, csrot, cscal, clacgv,
231 $ xerbla
232* ..
233* .. External Functions ..
234 REAL SCNRM2
235 EXTERNAL scnrm2
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. 0 .OR. p .GT. m-p ) THEN
250 info = -2
251 ELSE IF( q .LT. 0 .OR. q .LT. p .OR. m-q .LT. p ) 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, q-1 )
264 iorbdb5 = 2
265 lorbdb5 = q-1
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( 'CUNBDB2', -info )
275 RETURN
276 ELSE IF( lquery ) THEN
277 RETURN
278 END IF
279*
280* Reduce rows 1, ..., P of X11 and X21
281*
282 DO i = 1, p
283*
284 IF( i .GT. 1 ) THEN
285 CALL csrot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,
286 $ s )
287 END IF
288 CALL clacgv( q-i+1, x11(i,i), ldx11 )
289 CALL clarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) )
290 c = real( x11(i,i) )
291 x11(i,i) = one
292 CALL clarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),
293 $ x11(i+1,i), ldx11, work(ilarf) )
294 CALL clarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),
295 $ x21(i,i), ldx21, work(ilarf) )
296 CALL clacgv( q-i+1, x11(i,i), ldx11 )
297 s = sqrt( scnrm2( p-i, x11(i+1,i), 1 )**2
298 $ + scnrm2( m-p-i+1, x21(i,i), 1 )**2 )
299 theta(i) = atan2( s, c )
300*
301 CALL cunbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,
302 $ x11(i+1,i+1), ldx11, x21(i,i+1), ldx21,
303 $ work(iorbdb5), lorbdb5, childinfo )
304 CALL cscal( p-i, negone, x11(i+1,i), 1 )
305 CALL clarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
306 IF( i .LT. p ) THEN
307 CALL clarfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) )
308 phi(i) = atan2( real( x11(i+1,i) ), real( x21(i,i) ) )
309 c = cos( phi(i) )
310 s = sin( phi(i) )
311 x11(i+1,i) = one
312 CALL clarf( 'L', p-i, q-i, x11(i+1,i), 1, conjg(taup1(i)),
313 $ x11(i+1,i+1), ldx11, work(ilarf) )
314 END IF
315 x21(i,i) = one
316 CALL clarf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),
317 $ x21(i,i+1), ldx21, work(ilarf) )
318*
319 END DO
320*
321* Reduce the bottom-right portion of X21 to the identity matrix
322*
323 DO i = p + 1, q
324 CALL clarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
325 x21(i,i) = one
326 CALL clarf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),
327 $ x21(i,i+1), ldx21, work(ilarf) )
328 END DO
329*
330 RETURN
331*
332* End of CUNBDB2
333*

◆ cunbdb3()

subroutine cunbdb3 ( integer m,
integer p,
integer q,
complex, dimension(ldx11,*) x11,
integer ldx11,
complex, dimension(ldx21,*) x21,
integer ldx21,
real, dimension(*) theta,
real, dimension(*) phi,
complex, dimension(*) taup1,
complex, dimension(*) taup2,
complex, dimension(*) tauq1,
complex, dimension(*) work,
integer lwork,
integer info )

CUNBDB3

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

Purpose:
!>
!> CUNBDB3 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 CUNBDB1, CUNBDB2, and CUNBDB4 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 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 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 REAL array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is REAL 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 array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is COMPLEX array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is COMPLEX array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is COMPLEX 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 CUNCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
!>  and CUNGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 200 of file cunbdb3.f.

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

◆ cunbdb4()

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

CUNBDB4

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

Purpose:
!>
!> CUNBDB4 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 CUNBDB1, CUNBDB2, and CUNBDB3 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 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 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 REAL array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is REAL 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 array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is COMPLEX array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is COMPLEX array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]PHANTOM
!>          PHANTOM is COMPLEX 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 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 CUNCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
!>  and CUNGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 210 of file cunbdb4.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 REAL PHI(*), THETA(*)
223 COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
224 $ WORK(*), X11(LDX11,*), X21(LDX21,*)
225* ..
226*
227* ====================================================================
228*
229* .. Parameters ..
230 COMPLEX NEGONE, ONE, ZERO
231 parameter( negone = (-1.0e0,0.0e0), one = (1.0e0,0.0e0),
232 $ zero = (0.0e0,0.0e0) )
233* ..
234* .. Local Scalars ..
235 REAL C, S
236 INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
237 $ LORBDB5, LWORKMIN, LWORKOPT
238 LOGICAL LQUERY
239* ..
240* .. External Subroutines ..
241 EXTERNAL clarf, clarfgp, cunbdb5, csrot, cscal, clacgv,
242 $ xerbla
243* ..
244* .. External Functions ..
245 REAL SCNRM2
246 EXTERNAL scnrm2
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( 'CUNBDB4', -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 cunbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,
301 $ x11, ldx11, x21, ldx21, work(iorbdb5),
302 $ lorbdb5, childinfo )
303 CALL cscal( p, negone, phantom(1), 1 )
304 CALL clarfgp( p, phantom(1), phantom(2), 1, taup1(1) )
305 CALL clarfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) )
306 theta(i) = atan2( real( phantom(1) ), real( phantom(p+1) ) )
307 c = cos( theta(i) )
308 s = sin( theta(i) )
309 phantom(1) = one
310 phantom(p+1) = one
311 CALL clarf( 'L', p, q, phantom(1), 1, conjg(taup1(1)), x11,
312 $ ldx11, work(ilarf) )
313 CALL clarf( 'L', m-p, q, phantom(p+1), 1, conjg(taup2(1)),
314 $ x21, ldx21, work(ilarf) )
315 ELSE
316 CALL cunbdb5( 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 cscal( p-i+1, negone, x11(i,i-1), 1 )
320 CALL clarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) )
321 CALL clarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,
322 $ taup2(i) )
323 theta(i) = atan2( real( x11(i,i-1) ), real( 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 clarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1,
329 $ conjg(taup1(i)), x11(i,i), ldx11, work(ilarf) )
330 CALL clarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1,
331 $ conjg(taup2(i)), x21(i,i), ldx21, work(ilarf) )
332 END IF
333*
334 CALL csrot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c )
335 CALL clacgv( q-i+1, x21(i,i), ldx21 )
336 CALL clarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) )
337 c = real( x21(i,i) )
338 x21(i,i) = one
339 CALL clarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),
340 $ x11(i+1,i), ldx11, work(ilarf) )
341 CALL clarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),
342 $ x21(i+1,i), ldx21, work(ilarf) )
343 CALL clacgv( q-i+1, x21(i,i), ldx21 )
344 IF( i .LT. m-q ) THEN
345 s = sqrt( scnrm2( p-i, x11(i+1,i), 1 )**2
346 $ + scnrm2( 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 clacgv( q-i+1, x11(i,i), ldx11 )
356 CALL clarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) )
357 x11(i,i) = one
358 CALL clarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),
359 $ x11(i+1,i), ldx11, work(ilarf) )
360 CALL clarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),
361 $ x21(m-q+1,i), ldx21, work(ilarf) )
362 CALL clacgv( 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 clacgv( q-i+1, x21(m-q+i-p,i), ldx21 )
369 CALL clarfgp( 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 clarf( '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 clacgv( q-i+1, x21(m-q+i-p,i), ldx21 )
375 END DO
376*
377 RETURN
378*
379* End of CUNBDB4
380*

◆ cunbdb5()

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

CUNBDB5

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

Purpose:
!>
!> CUNBDB5 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 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 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 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 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 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 cunbdb5.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 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 COMPLEX ONE, ZERO
173 parameter( one = (1.0e0,0.0e0), zero = (0.0e0,0.0e0) )
174* ..
175* .. Local Scalars ..
176 INTEGER CHILDINFO, I, J
177* ..
178* .. External Subroutines ..
179 EXTERNAL cunbdb6, xerbla
180* ..
181* .. External Functions ..
182 REAL SCNRM2
183 EXTERNAL scnrm2
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( 'CUNBDB5', -info )
213 RETURN
214 END IF
215*
216* Project X onto the orthogonal complement of Q
217*
218 CALL cunbdb6( 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( scnrm2(m1,x1,incx1) .NE. zero
224 $ .OR. scnrm2(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 cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,
240 $ ldq2, work, lwork, childinfo )
241 IF( scnrm2(m1,x1,incx1) .NE. zero
242 $ .OR. scnrm2(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 cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,
259 $ ldq2, work, lwork, childinfo )
260 IF( scnrm2(m1,x1,incx1) .NE. zero
261 $ .OR. scnrm2(m2,x2,incx2) .NE. zero ) THEN
262 RETURN
263 END IF
264 END DO
265*
266 RETURN
267*
268* End of CUNBDB5
269*
cunbdb6
subroutine cunbdb6(m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
CUNBDB6
Definition cunbdb6.f:154

◆ cunbdb6()

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

CUNBDB6

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

Purpose:
!>
!> CUNBDB6 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 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 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 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 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 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 cunbdb6.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 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 REAL ALPHASQ, REALONE, REALZERO
171 parameter( alphasq = 0.01e0, realone = 1.0e0,
172 $ realzero = 0.0e0 )
173 COMPLEX NEGONE, ONE, ZERO
174 parameter( negone = (-1.0e0,0.0e0), one = (1.0e0,0.0e0),
175 $ zero = (0.0e0,0.0e0) )
176* ..
177* .. Local Scalars ..
178 INTEGER I
179 REAL NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
180* ..
181* .. External Subroutines ..
182 EXTERNAL cgemv, classq, 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( 'CUNBDB6', -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 classq( m1, x1, incx1, scl1, ssq1 )
221 scl2 = realzero
222 ssq2 = realone
223 CALL classq( 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 cgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,
232 $ 1 )
233 END IF
234*
235 CALL cgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 )
236*
237 CALL cgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,
238 $ incx1 )
239 CALL cgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,
240 $ incx2 )
241*
242 scl1 = realzero
243 ssq1 = realone
244 CALL classq( m1, x1, incx1, scl1, ssq1 )
245 scl2 = realzero
246 ssq2 = realone
247 CALL classq( 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 cgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,
274 $ 1 )
275 END IF
276*
277 CALL cgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 )
278*
279 CALL cgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,
280 $ incx1 )
281 CALL cgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,
282 $ incx2 )
283*
284 scl1 = realzero
285 ssq1 = realone
286 CALL classq( m1, x1, incx1, scl1, ssq1 )
287 scl2 = realzero
288 ssq2 = realone
289 CALL classq( 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 CUNBDB6
308*

◆ cuncsd()

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

CUNCSD

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

Purpose:
!>
!> CUNCSD 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 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 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 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 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 REAL 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 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 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 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 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 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 REAL 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:  CBBCSD 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 cuncsd.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 REAL THETA( * )
333 REAL RWORK( * )
334 COMPLEX 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 ONE, ZERO
344 parameter( one = (1.0e0,0.0e0),
345 $ zero = (0.0e0,0.0e0) )
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, cbbcsd, clacpy, clapmr, clapmt,
364 $ cunbdb, cunglq, cungqr
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 cuncsd( 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 cuncsd( 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 cbbcsd( 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 cungqr( 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 cunglq( 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 cunbdb( 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( 'CUNCSD', -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 cunbdb( 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 clacpy( 'L', p, q, x11, ldx11, u1, ldu1 )
544 CALL cungqr( 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 clacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 )
549 CALL cungqr( 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 clacpy( '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 cunglq( 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 clacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t )
565 IF( m-p .GT. q ) THEN
566 CALL clacpy( '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 cunglq( 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 clacpy( 'U', q, p, x11, ldx11, u1, ldu1 )
577 CALL cunglq( 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 clacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 )
582 CALL cunglq( 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 clacpy( '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 cungqr( 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 clacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t )
600 IF ( m .GT. p+q ) THEN
601 CALL clacpy( 'L', m-p-q, m-p-q, x22(p1,q1), ldx22,
602 $ v2t(p+1,p+1), ldv2t )
603 END IF
604 CALL cungqr( 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 cbbcsd( 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 clapmt( .false., m-p, m-p, u2, ldu2, iwork )
632 ELSE
633 CALL clapmr( .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 clapmt( .false., m-q, m-q, v2t, ldv2t, iwork )
645 ELSE
646 CALL clapmr( .false., m-q, m-q, v2t, ldv2t, iwork )
647 END IF
648 END IF
649*
650 RETURN
651*
652* End CUNCSD
653*
clapmr
subroutine clapmr(forwrd, m, n, x, ldx, k)
CLAPMR rearranges rows of a matrix as specified by a permutation vector.
Definition clapmr.f:104
cunglq
subroutine cunglq(m, n, k, a, lda, tau, work, lwork, info)
CUNGLQ
Definition cunglq.f:127
cbbcsd
subroutine cbbcsd(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)
CBBCSD
Definition cbbcsd.f:332
cunbdb
subroutine cunbdb(trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, lwork, info)
CUNBDB
Definition cunbdb.f:287
cuncsd
recursive subroutine cuncsd(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)
CUNCSD
Definition cuncsd.f:320
cungqr
subroutine cungqr(m, n, k, a, lda, tau, work, lwork, info)
CUNGQR
Definition cungqr.f:128

◆ cuncsd2by1()

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

CUNCSD2BY1

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

Purpose:
!>
!> CUNCSD2BY1 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 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 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 REAL 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 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 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 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 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 REAL 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:  CBBCSD 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 253 of file cuncsd2by1.f.

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

◆ cung2l()

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

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

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

Purpose:
!>
!> CUNG2L 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 CGEQLF.
!>
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 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 CGEQLF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGEQLF.
!>
[out]WORK
!>          WORK is COMPLEX 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 cung2l.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 A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 COMPLEX ONE, ZERO
130 parameter( one = ( 1.0e+0, 0.0e+0 ),
131 $ zero = ( 0.0e+0, 0.0e+0 ) )
132* ..
133* .. Local Scalars ..
134 INTEGER I, II, J, L
135* ..
136* .. External Subroutines ..
137 EXTERNAL clarf, cscal, xerbla
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( 'CUNG2L', -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 clarf( 'Left', m-n+ii, ii-1, a( 1, ii ), 1, tau( i ), a,
182 $ lda, work )
183 CALL cscal( 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 CUNG2L
195*

◆ cung2r()

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

CUNG2R

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

Purpose:
!>
!> CUNG2R 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 CGEQRF.
!>
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 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 CGEQRF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGEQRF.
!>
[out]WORK
!>          WORK is COMPLEX 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 cung2r.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 A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 COMPLEX ONE, ZERO
130 parameter( one = ( 1.0e+0, 0.0e+0 ),
131 $ zero = ( 0.0e+0, 0.0e+0 ) )
132* ..
133* .. Local Scalars ..
134 INTEGER I, J, L
135* ..
136* .. External Subroutines ..
137 EXTERNAL clarf, cscal, xerbla
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( 'CUNG2R', -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 clarf( '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 cscal( 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 CUNG2R
197*

◆ cunghr()

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

CUNGHR

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

Purpose:
!>
!> CUNGHR generates a complex unitary matrix Q which is defined as the
!> product of IHI-ILO elementary reflectors of order N, as returned by
!> CGEHRD:
!>
!> 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 CGEHRD. 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 array, dimension (LDA,N)
!>          On entry, the vectors which define the elementary reflectors,
!>          as returned by CGEHRD.
!>          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 array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGEHRD.
!>
[out]WORK
!>          WORK is COMPLEX 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 cunghr.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 A( LDA, * ), TAU( * ), WORK( * )
136* ..
137*
138* =====================================================================
139*
140* .. Parameters ..
141 COMPLEX ZERO, ONE
142 parameter( zero = ( 0.0e+0, 0.0e+0 ),
143 $ one = ( 1.0e+0, 0.0e+0 ) )
144* ..
145* .. Local Scalars ..
146 LOGICAL LQUERY
147 INTEGER I, IINFO, J, LWKOPT, NB, NH
148* ..
149* .. External Subroutines ..
150 EXTERNAL cungqr, xerbla
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, 'CUNGQR', ' ', 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( 'CUNGHR', -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 cungqr( 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 CUNGHR
237*

◆ cungl2()

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

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

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

Purpose:
!>
!> CUNGL2 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 CGELQF.
!>
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 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 CGELQF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGELQF.
!>
[out]WORK
!>          WORK is COMPLEX 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 cungl2.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 A( LDA, * ), TAU( * ), WORK( * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 COMPLEX ONE, ZERO
129 parameter( one = ( 1.0e+0, 0.0e+0 ),
130 $ zero = ( 0.0e+0, 0.0e+0 ) )
131* ..
132* .. Local Scalars ..
133 INTEGER I, J, L
134* ..
135* .. External Subroutines ..
136 EXTERNAL clacgv, clarf, cscal, xerbla
137* ..
138* .. Intrinsic Functions ..
139 INTRINSIC conjg, 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( 'CUNGL2', -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 clacgv( n-i, a( i, i+1 ), lda )
184 IF( i.LT.m ) THEN
185 a( i, i ) = one
186 CALL clarf( 'Right', m-i, n-i+1, a( i, i ), lda,
187 $ conjg( tau( i ) ), a( i+1, i ), lda, work )
188 END IF
189 CALL cscal( n-i, -tau( i ), a( i, i+1 ), lda )
190 CALL clacgv( n-i, a( i, i+1 ), lda )
191 END IF
192 a( i, i ) = one - conjg( tau( i ) )
193*
194* Set A(i,1:i-1,i) 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 CUNGL2
203*

◆ cunglq()

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

CUNGLQ

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

Purpose:
!>
!> CUNGLQ 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 CGELQF.
!>
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 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 CGELQF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGELQF.
!>
[out]WORK
!>          WORK is COMPLEX 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 cunglq.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 A( LDA, * ), TAU( * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 COMPLEX ZERO
143 parameter( zero = ( 0.0e+0, 0.0e+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 clarfb, clarft, cungl2, xerbla
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, 'CUNGLQ', ' ', 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( 'CUNGLQ', -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, 'CUNGLQ', ' ', 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, 'CUNGLQ', ' ', 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 cungl2( 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 clarft( '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 clarfb( '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 cungl2( 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 CUNGLQ
285*
clarfb
subroutine clarfb(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
CLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
Definition clarfb.f:197
clarft
subroutine clarft(direct, storev, n, k, v, ldv, tau, t, ldt)
CLARFT forms the triangular factor T of a block reflector H = I - vtvH
Definition clarft.f:163
cungl2
subroutine cungl2(m, n, k, a, lda, tau, work, info)
CUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (u...
Definition cungl2.f:113

◆ cungql()

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

CUNGQL

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

Purpose:
!>
!> CUNGQL 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 CGEQLF.
!>
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 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 CGEQLF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGEQLF.
!>
[out]WORK
!>          WORK is COMPLEX 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 cungql.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 A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 COMPLEX ZERO
144 parameter( zero = ( 0.0e+0, 0.0e+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 clarfb, clarft, cung2l, xerbla
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, 'CUNGQL', ' ', 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( 'CUNGQL', -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, 'CUNGQL', ' ', 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, 'CUNGQL', ' ', 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 cung2l( 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 clarft( '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 clarfb( '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 cung2l( 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 CUNGQL
292*
cung2l
subroutine cung2l(m, n, k, a, lda, tau, work, info)
CUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (un...
Definition cung2l.f:114

◆ cungqr()

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

CUNGQR

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

Purpose:
!>
!> CUNGQR 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 CGEQRF.
!>
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 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 CGEQRF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGEQRF.
!>
[out]WORK
!>          WORK is COMPLEX 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 cungqr.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 A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 COMPLEX ZERO
144 parameter( zero = ( 0.0e+0, 0.0e+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 clarfb, clarft, cung2r, xerbla
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, 'CUNGQR', ' ', 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( 'CUNGQR', -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, 'CUNGQR', ' ', 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, 'CUNGQR', ' ', 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 cung2r( 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 clarft( '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 clarfb( '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 cung2r( 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 CUNGQR
286*

◆ cungr2()

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

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

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

Purpose:
!>
!> CUNGR2 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 CGERQF.
!>
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 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 CGERQF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGERQF.
!>
[out]WORK
!>          WORK is COMPLEX 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 cungr2.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 A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 COMPLEX ONE, ZERO
130 parameter( one = ( 1.0e+0, 0.0e+0 ),
131 $ zero = ( 0.0e+0, 0.0e+0 ) )
132* ..
133* .. Local Scalars ..
134 INTEGER I, II, J, L
135* ..
136* .. External Subroutines ..
137 EXTERNAL clacgv, clarf, cscal, xerbla
138* ..
139* .. Intrinsic Functions ..
140 INTRINSIC conjg, 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( 'CUNGR2', -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 clacgv( n-m+ii-1, a( ii, 1 ), lda )
185 a( ii, n-m+ii ) = one
186 CALL clarf( 'Right', ii-1, n-m+ii, a( ii, 1 ), lda,
187 $ conjg( tau( i ) ), a, lda, work )
188 CALL cscal( n-m+ii-1, -tau( i ), a( ii, 1 ), lda )
189 CALL clacgv( n-m+ii-1, a( ii, 1 ), lda )
190 a( ii, n-m+ii ) = one - conjg( 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 CUNGR2
201*

◆ cungrq()

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

CUNGRQ

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

Purpose:
!>
!> CUNGRQ 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 CGERQF.
!>
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 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 CGERQF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGERQF.
!>
[out]WORK
!>          WORK is COMPLEX 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 cungrq.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 A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 COMPLEX ZERO
144 parameter( zero = ( 0.0e+0, 0.0e+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 clarfb, clarft, cungr2, xerbla
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, 'CUNGRQ', ' ', 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( 'CUNGRQ', -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, 'CUNGRQ', ' ', 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, 'CUNGRQ', ' ', 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 cungr2( 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 clarft( '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 clarfb( '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 cungr2( 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 CUNGRQ
293*
cungr2
subroutine cungr2(m, n, k, a, lda, tau, work, info)
CUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cgerqf (u...
Definition cungr2.f:114

◆ cungtr()

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

CUNGTR

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

Purpose:
!>
!> CUNGTR generates a complex unitary matrix Q which is defined as the
!> product of n-1 elementary reflectors of order N, as returned by
!> CHETRD:
!>
!> 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 CHETRD;
!>          = 'L': Lower triangle of A contains elementary reflectors
!>                 from CHETRD.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix Q. N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the vectors which define the elementary reflectors,
!>          as returned by CHETRD.
!>          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 array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CHETRD.
!>
[out]WORK
!>          WORK is COMPLEX 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 cungtr.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 A( LDA, * ), TAU( * ), WORK( * )
134* ..
135*
136* =====================================================================
137*
138* .. Parameters ..
139 COMPLEX ZERO, ONE
140 parameter( zero = ( 0.0e+0, 0.0e+0 ),
141 $ one = ( 1.0e+0, 0.0e+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 ilaenv, lsame
151* ..
152* .. External Subroutines ..
153 EXTERNAL cungql, cungqr, xerbla
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, 'CUNGQL', ' ', n-1, n-1, n-1, -1 )
178 ELSE
179 nb = ilaenv( 1, 'CUNGQR', ' ', 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( 'CUNGTR', -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 CHETRD 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 cungql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
221*
222 ELSE
223*
224* Q was determined by a call to CHETRD 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 cungqr( 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 CUNGTR
252*
cungql
subroutine cungql(m, n, k, a, lda, tau, work, lwork, info)
CUNGQL
Definition cungql.f:128

◆ cungtsqr()

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

CUNGTSQR

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

Purpose:
!>
!> CUNGTSQR 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 CLATSQR
!>
!>      Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ).
!>
!> See the documentation for CLATSQR.
!>
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 CLATSQR 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 CLATSQR 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 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 CLATSQR
!>             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 CLATSQR).
!>
!>          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 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 CLATSQR).
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.
!>          LDT >= max(1,min(NB1,N)).
!>
[out]WORK
!>          (workspace) COMPLEX 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 cungtsqr.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 A( LDA, * ), T( LDT, * ), WORK( * )
186* ..
187*
188* =====================================================================
189*
190* .. Parameters ..
191 COMPLEX CONE, CZERO
192 parameter( cone = ( 1.0e+0, 0.0e+0 ),
193 $ czero = ( 0.0e+0, 0.0e+0 ) )
194* ..
195* .. Local Scalars ..
196 LOGICAL LQUERY
197 INTEGER IINFO, LDC, LWORKOPT, LC, LW, NBLOCAL, J
198* ..
199* .. External Subroutines ..
200 EXTERNAL ccopy, clamtsqr, claset, xerbla
201* ..
202* .. Intrinsic Functions ..
203 INTRINSIC cmplx, 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 CLAMTSQR. See the documentation for CLAMTSQR.
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 CLAMTSQR call and set the optimal size of the work array
239* WORK(LWORK) in CLAMTSQR 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( 'CUNGTSQR', -info )
258 RETURN
259 ELSE IF ( lquery ) THEN
260 work( 1 ) = cmplx( lworkopt )
261 RETURN
262 END IF
263*
264* Quick return if possible
265*
266 IF( min( m, n ).EQ.0 ) THEN
267 work( 1 ) = cmplx( 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 CLAMTSQR.
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 claset( '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 clamtsqr( '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 ccopy( m, work( (j-1)*ldc + 1 ), 1, a( 1, j ), 1 )
298 END DO
299*
300 work( 1 ) = cmplx( lworkopt )
301 RETURN
302*
303* End of CUNGTSQR
304*
clamtsqr
subroutine clamtsqr(side, trans, m, n, k, mb, nb, a, lda, t, ldt, c, ldc, work, lwork, info)
CLAMTSQR
Definition clamtsqr.f:197

◆ cungtsqr_row()

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

CUNGTSQR_ROW

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

Purpose:
!>
!> CUNGTSQR_ROW generates an M-by-N complex matrix Q_out with
!> orthonormal columns from the output of CLATSQR. 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 CLATSQR 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 CLATSQR 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 CLARFB_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 CLATSQR 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 CLATSQR 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 CLATSQR 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 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 CLATSQR
!>             that defines the input matrices Q_in(k) (ones on the
!>             diagonal are not stored). See CLATSQR 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 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 CLATSQR 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 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 cungtsqr_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 A( LDA, * ), T( LDT, * ), WORK( * )
199* ..
200*
201* =====================================================================
202*
203* .. Parameters ..
204 COMPLEX CONE, CZERO
205 parameter( cone = ( 1.0e+0, 0.0e+0 ),
206 $ czero = ( 0.0e+0, 0.0e+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 DUMMY( 1, 1 )
216* ..
217* .. External Subroutines ..
218 EXTERNAL clarfb_gett, claset, xerbla
219* ..
220* .. Intrinsic Functions ..
221 INTRINSIC cmplx, 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( 'CUNGTSQR_ROW', -info )
257 RETURN
258 ELSE IF ( lquery ) THEN
259 work( 1 ) = cmplx( lworkopt )
260 RETURN
261 END IF
262*
263* Quick return if possible
264*
265 IF( min( m, n ).EQ.0 ) THEN
266 work( 1 ) = cmplx( 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 claset('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 clarfb_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 clarfb_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 clarfb_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 ) = cmplx( lworkopt )
376 RETURN
377*
378* End of CUNGTSQR_ROW
379*
clarfb_gett
subroutine clarfb_gett(ident, m, n, k, t, ldt, a, lda, b, ldb, work, ldwork)
CLARFB_GETT
Definition clarfb_gett.f:392

◆ cunhr_col()

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

CUNHR_COL

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

Purpose:
!>
!>  CUNHR_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 CGEQRT).
!>
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 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
!>             CGEQRT). 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 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 CGEQRT).
!>          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 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 cunhr_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 A( LDA, * ), D( * ), T( LDT, * )
270* ..
271*
272* =====================================================================
273*
274* .. Parameters ..
275 COMPLEX CONE, CZERO
276 parameter( cone = ( 1.0e+0, 0.0e+0 ),
277 $ czero = ( 0.0e+0, 0.0e+0 ) )
278* ..
279* .. Local Scalars ..
280 INTEGER I, IINFO, J, JB, JBTEMP1, JBTEMP2, JNB,
281 $ NPLUSONE
282* ..
283* .. External Subroutines ..
284 EXTERNAL ccopy, claunhr_col_getrfnp, cscal, ctrsm,
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( 'CUNHR_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 claunhr_col_getrfnp( n, n, a, lda, d, iinfo )
334*
335* (1-2) Solve for V2.
336*
337 IF( m.GT.n ) THEN
338 CALL ctrsm( '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 ccopy( 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 cscal( 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 CTRSM 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 CTRSM.
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 ctrsm( '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 CUNHR_COL
438*
claunhr_col_getrfnp
subroutine claunhr_col_getrfnp(m, n, a, lda, d, info)
CLAUNHR_COL_GETRFNP
Definition claunhr_col_getrfnp.f:146

◆ cunm22()

subroutine cunm22 ( character side,
character trans,
integer m,
integer n,
integer n1,
integer n2,
complex, dimension( ldq, * ) q,
integer ldq,
complex, dimension( ldc, * ) c,
integer ldc,
complex, dimension( * ) work,
integer lwork,
integer info )

CUNM22 multiplies a general matrix by a banded unitary matrix.

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

Purpose
!>
!>  CUNM22 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'.
!>  The unitary matrix Q processes a 2-by-2 block structure
!>
!>         [  Q11  Q12  ]
!>     Q = [            ]
!>         [  Q21  Q22  ],
!>
!>  where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an
!>  N2-by-N2 upper triangular matrix.
!>
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]N1
[in]N2
!>          N1 is INTEGER
!>          N2 is INTEGER
!>          The dimension of Q12 and Q21, respectively. N1, N2 >= 0.
!>          The following requirement must be satisfied:
!>          N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'.
!>
[in]Q
!>          Q is COMPLEX array, dimension
!>                              (LDQ,M) if SIDE = 'L'
!>                              (LDQ,N) if SIDE = 'R'
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'.
!>
[in,out]C
!>          C is COMPLEX 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 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 >= M*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.

Definition at line 160 of file cunm22.f.

162*
163* -- LAPACK computational routine --
164* -- LAPACK is a software package provided by Univ. of Tennessee, --
165* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
166*
167 IMPLICIT NONE
168*
169* .. Scalar Arguments ..
170 CHARACTER SIDE, TRANS
171 INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO
172* ..
173* .. Array Arguments ..
174 COMPLEX Q( LDQ, * ), C( LDC, * ), WORK( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 COMPLEX ONE
181 parameter( one = ( 1.0e+0, 0.0e+0 ) )
182*
183* .. Local Scalars ..
184 LOGICAL LEFT, LQUERY, NOTRAN
185 INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW
186* ..
187* .. External Functions ..
188 LOGICAL LSAME
189 EXTERNAL lsame
190* ..
191* .. External Subroutines ..
192 EXTERNAL cgemm, clacpy, ctrmm, xerbla
193* ..
194* .. Intrinsic Functions ..
195 INTRINSIC cmplx, max, min
196* ..
197* .. Executable Statements ..
198*
199* Test the input arguments
200*
201 info = 0
202 left = lsame( side, 'L' )
203 notran = lsame( trans, 'N' )
204 lquery = ( lwork.EQ.-1 )
205*
206* NQ is the order of Q;
207* NW is the minimum dimension of WORK.
208*
209 IF( left ) THEN
210 nq = m
211 ELSE
212 nq = n
213 END IF
214 nw = nq
215 IF( n1.EQ.0 .OR. n2.EQ.0 ) nw = 1
216 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
217 info = -1
218 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) )
219 $ THEN
220 info = -2
221 ELSE IF( m.LT.0 ) THEN
222 info = -3
223 ELSE IF( n.LT.0 ) THEN
224 info = -4
225 ELSE IF( n1.LT.0 .OR. n1+n2.NE.nq ) THEN
226 info = -5
227 ELSE IF( n2.LT.0 ) THEN
228 info = -6
229 ELSE IF( ldq.LT.max( 1, nq ) ) THEN
230 info = -8
231 ELSE IF( ldc.LT.max( 1, m ) ) THEN
232 info = -10
233 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
234 info = -12
235 END IF
236*
237 IF( info.EQ.0 ) THEN
238 lwkopt = m*n
239 work( 1 ) = cmplx( lwkopt )
240 END IF
241*
242 IF( info.NE.0 ) THEN
243 CALL xerbla( 'CUNM22', -info )
244 RETURN
245 ELSE IF( lquery ) THEN
246 RETURN
247 END IF
248*
249* Quick return if possible
250*
251 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
252 work( 1 ) = 1
253 RETURN
254 END IF
255*
256* Degenerate cases (N1 = 0 or N2 = 0) are handled using CTRMM.
257*
258 IF( n1.EQ.0 ) THEN
259 CALL ctrmm( side, 'Upper', trans, 'Non-Unit', m, n, one,
260 $ q, ldq, c, ldc )
261 work( 1 ) = one
262 RETURN
263 ELSE IF( n2.EQ.0 ) THEN
264 CALL ctrmm( side, 'Lower', trans, 'Non-Unit', m, n, one,
265 $ q, ldq, c, ldc )
266 work( 1 ) = one
267 RETURN
268 END IF
269*
270* Compute the largest chunk size available from the workspace.
271*
272 nb = max( 1, min( lwork, lwkopt ) / nq )
273*
274 IF( left ) THEN
275 IF( notran ) THEN
276 DO i = 1, n, nb
277 len = min( nb, n-i+1 )
278 ldwork = m
279*
280* Multiply bottom part of C by Q12.
281*
282 CALL clacpy( 'All', n1, len, c( n2+1, i ), ldc, work,
283 $ ldwork )
284 CALL ctrmm( 'Left', 'Lower', 'No Transpose', 'Non-Unit',
285 $ n1, len, one, q( 1, n2+1 ), ldq, work,
286 $ ldwork )
287*
288* Multiply top part of C by Q11.
289*
290 CALL cgemm( 'No Transpose', 'No Transpose', n1, len, n2,
291 $ one, q, ldq, c( 1, i ), ldc, one, work,
292 $ ldwork )
293*
294* Multiply top part of C by Q21.
295*
296 CALL clacpy( 'All', n2, len, c( 1, i ), ldc,
297 $ work( n1+1 ), ldwork )
298 CALL ctrmm( 'Left', 'Upper', 'No Transpose', 'Non-Unit',
299 $ n2, len, one, q( n1+1, 1 ), ldq,
300 $ work( n1+1 ), ldwork )
301*
302* Multiply bottom part of C by Q22.
303*
304 CALL cgemm( 'No Transpose', 'No Transpose', n2, len, n1,
305 $ one, q( n1+1, n2+1 ), ldq, c( n2+1, i ), ldc,
306 $ one, work( n1+1 ), ldwork )
307*
308* Copy everything back.
309*
310 CALL clacpy( 'All', m, len, work, ldwork, c( 1, i ),
311 $ ldc )
312 END DO
313 ELSE
314 DO i = 1, n, nb
315 len = min( nb, n-i+1 )
316 ldwork = m
317*
318* Multiply bottom part of C by Q21**H.
319*
320 CALL clacpy( 'All', n2, len, c( n1+1, i ), ldc, work,
321 $ ldwork )
322 CALL ctrmm( 'Left', 'Upper', 'Conjugate', 'Non-Unit',
323 $ n2, len, one, q( n1+1, 1 ), ldq, work,
324 $ ldwork )
325*
326* Multiply top part of C by Q11**H.
327*
328 CALL cgemm( 'Conjugate', 'No Transpose', n2, len, n1,
329 $ one, q, ldq, c( 1, i ), ldc, one, work,
330 $ ldwork )
331*
332* Multiply top part of C by Q12**H.
333*
334 CALL clacpy( 'All', n1, len, c( 1, i ), ldc,
335 $ work( n2+1 ), ldwork )
336 CALL ctrmm( 'Left', 'Lower', 'Conjugate', 'Non-Unit',
337 $ n1, len, one, q( 1, n2+1 ), ldq,
338 $ work( n2+1 ), ldwork )
339*
340* Multiply bottom part of C by Q22**H.
341*
342 CALL cgemm( 'Conjugate', 'No Transpose', n1, len, n2,
343 $ one, q( n1+1, n2+1 ), ldq, c( n1+1, i ), ldc,
344 $ one, work( n2+1 ), ldwork )
345*
346* Copy everything back.
347*
348 CALL clacpy( 'All', m, len, work, ldwork, c( 1, i ),
349 $ ldc )
350 END DO
351 END IF
352 ELSE
353 IF( notran ) THEN
354 DO i = 1, m, nb
355 len = min( nb, m-i+1 )
356 ldwork = len
357*
358* Multiply right part of C by Q21.
359*
360 CALL clacpy( 'All', len, n2, c( i, n1+1 ), ldc, work,
361 $ ldwork )
362 CALL ctrmm( 'Right', 'Upper', 'No Transpose', 'Non-Unit',
363 $ len, n2, one, q( n1+1, 1 ), ldq, work,
364 $ ldwork )
365*
366* Multiply left part of C by Q11.
367*
368 CALL cgemm( 'No Transpose', 'No Transpose', len, n2, n1,
369 $ one, c( i, 1 ), ldc, q, ldq, one, work,
370 $ ldwork )
371*
372* Multiply left part of C by Q12.
373*
374 CALL clacpy( 'All', len, n1, c( i, 1 ), ldc,
375 $ work( 1 + n2*ldwork ), ldwork )
376 CALL ctrmm( 'Right', 'Lower', 'No Transpose', 'Non-Unit',
377 $ len, n1, one, q( 1, n2+1 ), ldq,
378 $ work( 1 + n2*ldwork ), ldwork )
379*
380* Multiply right part of C by Q22.
381*
382 CALL cgemm( 'No Transpose', 'No Transpose', len, n1, n2,
383 $ one, c( i, n1+1 ), ldc, q( n1+1, n2+1 ), ldq,
384 $ one, work( 1 + n2*ldwork ), ldwork )
385*
386* Copy everything back.
387*
388 CALL clacpy( 'All', len, n, work, ldwork, c( i, 1 ),
389 $ ldc )
390 END DO
391 ELSE
392 DO i = 1, m, nb
393 len = min( nb, m-i+1 )
394 ldwork = len
395*
396* Multiply right part of C by Q12**H.
397*
398 CALL clacpy( 'All', len, n1, c( i, n2+1 ), ldc, work,
399 $ ldwork )
400 CALL ctrmm( 'Right', 'Lower', 'Conjugate', 'Non-Unit',
401 $ len, n1, one, q( 1, n2+1 ), ldq, work,
402 $ ldwork )
403*
404* Multiply left part of C by Q11**H.
405*
406 CALL cgemm( 'No Transpose', 'Conjugate', len, n1, n2,
407 $ one, c( i, 1 ), ldc, q, ldq, one, work,
408 $ ldwork )
409*
410* Multiply left part of C by Q21**H.
411*
412 CALL clacpy( 'All', len, n2, c( i, 1 ), ldc,
413 $ work( 1 + n1*ldwork ), ldwork )
414 CALL ctrmm( 'Right', 'Upper', 'Conjugate', 'Non-Unit',
415 $ len, n2, one, q( n1+1, 1 ), ldq,
416 $ work( 1 + n1*ldwork ), ldwork )
417*
418* Multiply right part of C by Q22**H.
419*
420 CALL cgemm( 'No Transpose', 'Conjugate', len, n2, n1,
421 $ one, c( i, n2+1 ), ldc, q( n1+1, n2+1 ), ldq,
422 $ one, work( 1 + n1*ldwork ), ldwork )
423*
424* Copy everything back.
425*
426 CALL clacpy( 'All', len, n, work, ldwork, c( i, 1 ),
427 $ ldc )
428 END DO
429 END IF
430 END IF
431*
432 work( 1 ) = cmplx( lwkopt )
433 RETURN
434*
435* End of CUNM22
436*

◆ cunm2l()

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

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

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

Purpose:
!>
!> CUNM2L 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 CGEQLF. 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 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
!>          CGEQLF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGEQLF.
!>
[in,out]C
!>          C is COMPLEX 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 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 cunm2l.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 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 COMPLEX ONE
176 parameter( one = ( 1.0e+0, 0.0e+0 ) )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, MI, NI, NQ
181 COMPLEX AII, TAUI
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL clarf, xerbla
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC conjg, 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( 'CUNM2L', -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 = conjg( tau( i ) )
268 END IF
269 aii = a( nq-k+i, i )
270 a( nq-k+i, i ) = one
271 CALL clarf( 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 CUNM2L
277*

◆ cunm2r()

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

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

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

Purpose:
!>
!> CUNM2R 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 CGEQRF. 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 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
!>          CGEQRF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGEQRF.
!>
[in,out]C
!>          C is COMPLEX 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 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 cunm2r.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 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 COMPLEX ONE
176 parameter( one = ( 1.0e+0, 0.0e+0 ) )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
181 COMPLEX AII, TAUI
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL clarf, xerbla
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC conjg, 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( 'CUNM2R', -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 = conjg( tau( i ) )
272 END IF
273 aii = a( i, i )
274 a( i, i ) = one
275 CALL clarf( 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 CUNM2R
282*

◆ cunmbr()

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

CUNMBR

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

Purpose:
!>
!> If VECT = 'Q', CUNMBR 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', CUNMBR 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 CGEBRD 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 CGEBRD.
!>          If VECT = 'P', the number of rows in the original
!>          matrix reduced by CGEBRD.
!>          K >= 0.
!>
[in]A
!>          A is COMPLEX 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 CGEBRD.
!>
[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 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 CGEBRD in the array argument TAUQ or TAUP.
!>
[in,out]C
!>          C is COMPLEX 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 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 195 of file cunmbr.f.

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

◆ cunmhr()

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

CUNMHR

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

Purpose:
!>
!> CUNMHR 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 CGEHRD:
!>
!> 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 CGEHRD. 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 array, dimension
!>                               (LDA,M) if SIDE = 'L'
!>                               (LDA,N) if SIDE = 'R'
!>          The vectors which define the elementary reflectors, as
!>          returned by CGEHRD.
!>
[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 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 CGEHRD.
!>
[in,out]C
!>          C is COMPLEX 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 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 177 of file cunmhr.f.

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

◆ cunml2()

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

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

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

Purpose:
!>
!> CUNML2 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 CGELQF. 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 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
!>          CGELQF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGELQF.
!>
[in,out]C
!>          C is COMPLEX 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 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 cunml2.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 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 COMPLEX ONE
176 parameter( one = ( 1.0e+0, 0.0e+0 ) )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
181 COMPLEX AII, TAUI
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL clacgv, clarf, xerbla
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC conjg, 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( 'CUNML2', -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 = conjg( tau( i ) )
270 ELSE
271 taui = tau( i )
272 END IF
273 IF( i.LT.nq )
274 $ CALL clacgv( nq-i, a( i, i+1 ), lda )
275 aii = a( i, i )
276 a( i, i ) = one
277 CALL clarf( 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 clacgv( nq-i, a( i, i+1 ), lda )
282 10 CONTINUE
283 RETURN
284*
285* End of CUNML2
286*

◆ cunmlq()

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

CUNMLQ

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

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

◆ cunmql()

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

CUNMQL

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

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

◆ cunmqr()

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

CUNMQR

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

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

◆ cunmr2()

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

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

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

Purpose:
!>
!> CUNMR2 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 CGERQF. 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 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
!>          CGERQF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CGERQF.
!>
[in,out]C
!>          C is COMPLEX 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 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 cunmr2.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 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 COMPLEX ONE
176 parameter( one = ( 1.0e+0, 0.0e+0 ) )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, MI, NI, NQ
181 COMPLEX AII, TAUI
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL clacgv, clarf, xerbla
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC conjg, 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( 'CUNMR2', -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 = conjg( tau( i ) )
266 ELSE
267 taui = tau( i )
268 END IF
269 CALL clacgv( nq-k+i-1, a( i, 1 ), lda )
270 aii = a( i, nq-k+i )
271 a( i, nq-k+i ) = one
272 CALL clarf( side, mi, ni, a( i, 1 ), lda, taui, c, ldc, work )
273 a( i, nq-k+i ) = aii
274 CALL clacgv( nq-k+i-1, a( i, 1 ), lda )
275 10 CONTINUE
276 RETURN
277*
278* End of CUNMR2
279*

◆ cunmr3()

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

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

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

Purpose:
!>
!> CUNMR3 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 CTZRZF. 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 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
!>          CTZRZF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CTZRZF.
!>
[in,out]C
!>          C is COMPLEX 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 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 cunmr3.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 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 TAUI
197* ..
198* .. External Functions ..
199 LOGICAL LSAME
200 EXTERNAL lsame
201* ..
202* .. External Subroutines ..
203 EXTERNAL clarz, xerbla
204* ..
205* .. Intrinsic Functions ..
206 INTRINSIC conjg, 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( 'CUNMR3', -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 = conjg( tau( i ) )
292 END IF
293 CALL clarz( 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 CUNMR3
301*

◆ cunmrq()

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

CUNMRQ

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

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

◆ cunmrz()

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

CUNMRZ

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

Purpose:
!>
!> CUNMRZ 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 CTZRZF. 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 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
!>          CTZRZF 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 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CTZRZF.
!>
[in,out]C
!>          C is COMPLEX 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 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 cunmrz.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 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 clarzb, clarzt, cunmr3, xerbla
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.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, 'CUNMRQ', 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( 'CUNMRZ', -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.
291*
292 nb = min( nbmax, ilaenv( 1, 'CUNMRQ', side // trans, m, n, k,
293 $ -1 ) )
294 nbmin = 2
295 ldwork = nw
296 IF( nb.GT.1 .AND. nb.LT.k ) THEN
297 IF( lwork.LT.lwkopt ) THEN
298 nb = (lwork-tsize) / ldwork
299 nbmin = max( 2, ilaenv( 2, 'CUNMRQ', side // trans, m, n, k,
300 $ -1 ) )
301 END IF
302 END IF
303*
304 IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
305*
306* Use unblocked code
307*
308 CALL cunmr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,
309 $ work, iinfo )
310 ELSE
311*
312* Use blocked code
313*
314 iwt = 1 + nw*nb
315 IF( ( left .AND. .NOT.notran ) .OR.
316 $ ( .NOT.left .AND. notran ) ) THEN
317 i1 = 1
318 i2 = k
319 i3 = nb
320 ELSE
321 i1 = ( ( k-1 ) / nb )*nb + 1
322 i2 = 1
323 i3 = -nb
324 END IF
325*
326 IF( left ) THEN
327 ni = n
328 jc = 1
329 ja = m - l + 1
330 ELSE
331 mi = m
332 ic = 1
333 ja = n - l + 1
334 END IF
335*
336 IF( notran ) THEN
337 transt = 'C'
338 ELSE
339 transt = 'N'
340 END IF
341*
342 DO 10 i = i1, i2, i3
343 ib = min( nb, k-i+1 )
344*
345* Form the triangular factor of the block reflector
346* H = H(i+ib-1) . . . H(i+1) H(i)
347*
348 CALL clarzt( 'Backward', 'Rowwise', l, ib, a( i, ja ), lda,
349 $ tau( i ), work( iwt ), ldt )
350*
351 IF( left ) THEN
352*
353* H or H**H is applied to C(i:m,1:n)
354*
355 mi = m - i + 1
356 ic = i
357 ELSE
358*
359* H or H**H is applied to C(1:m,i:n)
360*
361 ni = n - i + 1
362 jc = i
363 END IF
364*
365* Apply H or H**H
366*
367 CALL clarzb( side, transt, 'Backward', 'Rowwise', mi, ni,
368 $ ib, l, a( i, ja ), lda, work( iwt ), ldt,
369 $ c( ic, jc ), ldc, work, ldwork )
370 10 CONTINUE
371*
372 END IF
373*
374 work( 1 ) = lwkopt
375*
376 RETURN
377*
378* End of CUNMRZ
379*
cunmr3
subroutine cunmr3(side, trans, m, n, k, l, a, lda, tau, c, ldc, work, info)
CUNMR3 multiplies a general matrix by the unitary matrix from a RZ factorization determined by ctzrzf...
Definition cunmr3.f:178

◆ cunmtr()

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

CUNMTR

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

Purpose:
!>
!> CUNMTR 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 CHETRD:
!>
!> 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 CHETRD;
!>          = 'L': Lower triangle of A contains elementary reflectors
!>                 from CHETRD.
!>
[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 array, dimension
!>                               (LDA,M) if SIDE = 'L'
!>                               (LDA,N) if SIDE = 'R'
!>          The vectors which define the elementary reflectors, as
!>          returned by CHETRD.
!>
[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 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 CHETRD.
!>
[in,out]C
!>          C is COMPLEX 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 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 170 of file cunmtr.f.

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

◆ cupgtr()

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

CUPGTR

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

Purpose:
!>
!> CUPGTR 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
!> CHPTRD 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 CHPTRD;
!>          = 'L': Lower triangular packed storage used in previous
!>                 call to CHPTRD.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix Q. N >= 0.
!>
[in]AP
!>          AP is COMPLEX array, dimension (N*(N+1)/2)
!>          The vectors which define the elementary reflectors, as
!>          returned by CHPTRD.
!>
[in]TAU
!>          TAU is COMPLEX array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by CHPTRD.
!>
[out]Q
!>          Q is COMPLEX 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 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 cupgtr.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 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 COMPLEX CZERO, CONE
131 parameter( czero = ( 0.0e+0, 0.0e+0 ),
132 $ cone = ( 1.0e+0, 0.0e+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 cung2l, cung2r, xerbla
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( 'CUPGTR', -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 CHPTRD 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 cung2l( n-1, n-1, n-1, q, ldq, tau, work, iinfo )
196*
197 ELSE
198*
199* Q was determined by a call to CHPTRD 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 cung2r( 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 CUPGTR
229*

◆ cupmtr()

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

CUPMTR

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

Purpose:
!>
!> CUPMTR 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 CHPTRD 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 CHPTRD;
!>          = 'L': Lower triangular packed storage used in previous
!>                 call to CHPTRD.
!>
[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 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 CHPTRD.  AP is modified by the routine but
!>          restored on exit.
!>
[in]TAU
!>          TAU is COMPLEX 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 CHPTRD.
!>
[in,out]C
!>          C is COMPLEX 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 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 cupmtr.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 AP( * ), C( LDC, * ), TAU( * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 COMPLEX ONE
167 parameter( one = ( 1.0e+0, 0.0e+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 AII, TAUI
173* ..
174* .. External Functions ..
175 LOGICAL LSAME
176 EXTERNAL lsame
177* ..
178* .. External Subroutines ..
179 EXTERNAL clarf, xerbla
180* ..
181* .. Intrinsic Functions ..
182 INTRINSIC conjg, 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( 'CUPMTR', -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 CHPTRD 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 = conjg( tau( i ) )
267 END IF
268 aii = ap( ii )
269 ap( ii ) = one
270 CALL clarf( 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 CHPTRD 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 = conjg( tau( i ) )
330 END IF
331 CALL clarf( 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 CUPMTR
345*

◆ dorm22()

subroutine dorm22 ( character side,
character trans,
integer m,
integer n,
integer n1,
integer n2,
double precision, dimension( ldq, * ) q,
integer ldq,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) work,
integer lwork,
integer info )

DORM22 multiplies a general matrix by a banded orthogonal matrix.

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

Purpose
!>
!>
!>  DORM22 overwrites the general real M-by-N matrix C with
!>
!>                  SIDE = 'L'     SIDE = 'R'
!>  TRANS = 'N':      Q * C          C * Q
!>  TRANS = 'T':      Q**T * C       C * Q**T
!>
!>  where Q is a real orthogonal matrix of order NQ, with NQ = M if
!>  SIDE = 'L' and NQ = N if SIDE = 'R'.
!>  The orthogonal matrix Q processes a 2-by-2 block structure
!>
!>         [  Q11  Q12  ]
!>     Q = [            ]
!>         [  Q21  Q22  ],
!>
!>  where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an
!>  N2-by-N2 upper triangular matrix.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**T from the Left;
!>          = 'R': apply Q or Q**T from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  apply Q (No transpose);
!>          = 'C':  apply Q**T (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]N1
[in]N2
!>          N1 is INTEGER
!>          N2 is INTEGER
!>          The dimension of Q12 and Q21, respectively. N1, N2 >= 0.
!>          The following requirement must be satisfied:
!>          N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'.
!>
[in]Q
!>          Q is DOUBLE PRECISION array, dimension
!>                                       (LDQ,M) if SIDE = 'L'
!>                                       (LDQ,N) if SIDE = 'R'
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For optimum performance LWORK >= M*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.

Definition at line 161 of file dorm22.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 IMPLICIT NONE
169*
170* .. Scalar Arguments ..
171 CHARACTER SIDE, TRANS
172 INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO
173* ..
174* .. Array Arguments ..
175 DOUBLE PRECISION Q( LDQ, * ), C( LDC, * ), WORK( * )
176* ..
177*
178* =====================================================================
179*
180* .. Parameters ..
181 DOUBLE PRECISION ONE
182 parameter( one = 1.0d+0 )
183*
184* .. Local Scalars ..
185 LOGICAL LEFT, LQUERY, NOTRAN
186 INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 EXTERNAL lsame
191* ..
192* .. External Subroutines ..
193 EXTERNAL dgemm, dlacpy, dtrmm, xerbla
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC dble, max, min
197* ..
198* .. Executable Statements ..
199*
200* Test the input arguments
201*
202 info = 0
203 left = lsame( side, 'L' )
204 notran = lsame( trans, 'N' )
205 lquery = ( lwork.EQ.-1 )
206*
207* NQ is the order of Q;
208* NW is the minimum dimension of WORK.
209*
210 IF( left ) THEN
211 nq = m
212 ELSE
213 nq = n
214 END IF
215 nw = nq
216 IF( n1.EQ.0 .OR. n2.EQ.0 ) nw = 1
217 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
218 info = -1
219 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'T' ) )
220 $ THEN
221 info = -2
222 ELSE IF( m.LT.0 ) THEN
223 info = -3
224 ELSE IF( n.LT.0 ) THEN
225 info = -4
226 ELSE IF( n1.LT.0 .OR. n1+n2.NE.nq ) THEN
227 info = -5
228 ELSE IF( n2.LT.0 ) THEN
229 info = -6
230 ELSE IF( ldq.LT.max( 1, nq ) ) THEN
231 info = -8
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 lwkopt = m*n
240 work( 1 ) = dble( lwkopt )
241 END IF
242*
243 IF( info.NE.0 ) THEN
244 CALL xerbla( 'DORM22', -info )
245 RETURN
246 ELSE IF( lquery ) THEN
247 RETURN
248 END IF
249*
250* Quick return if possible
251*
252 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
253 work( 1 ) = 1
254 RETURN
255 END IF
256*
257* Degenerate cases (N1 = 0 or N2 = 0) are handled using DTRMM.
258*
259 IF( n1.EQ.0 ) THEN
260 CALL dtrmm( side, 'Upper', trans, 'Non-Unit', m, n, one,
261 $ q, ldq, c, ldc )
262 work( 1 ) = one
263 RETURN
264 ELSE IF( n2.EQ.0 ) THEN
265 CALL dtrmm( side, 'Lower', trans, 'Non-Unit', m, n, one,
266 $ q, ldq, c, ldc )
267 work( 1 ) = one
268 RETURN
269 END IF
270*
271* Compute the largest chunk size available from the workspace.
272*
273 nb = max( 1, min( lwork, lwkopt ) / nq )
274*
275 IF( left ) THEN
276 IF( notran ) THEN
277 DO i = 1, n, nb
278 len = min( nb, n-i+1 )
279 ldwork = m
280*
281* Multiply bottom part of C by Q12.
282*
283 CALL dlacpy( 'All', n1, len, c( n2+1, i ), ldc, work,
284 $ ldwork )
285 CALL dtrmm( 'Left', 'Lower', 'No Transpose', 'Non-Unit',
286 $ n1, len, one, q( 1, n2+1 ), ldq, work,
287 $ ldwork )
288*
289* Multiply top part of C by Q11.
290*
291 CALL dgemm( 'No Transpose', 'No Transpose', n1, len, n2,
292 $ one, q, ldq, c( 1, i ), ldc, one, work,
293 $ ldwork )
294*
295* Multiply top part of C by Q21.
296*
297 CALL dlacpy( 'All', n2, len, c( 1, i ), ldc,
298 $ work( n1+1 ), ldwork )
299 CALL dtrmm( 'Left', 'Upper', 'No Transpose', 'Non-Unit',
300 $ n2, len, one, q( n1+1, 1 ), ldq,
301 $ work( n1+1 ), ldwork )
302*
303* Multiply bottom part of C by Q22.
304*
305 CALL dgemm( 'No Transpose', 'No Transpose', n2, len, n1,
306 $ one, q( n1+1, n2+1 ), ldq, c( n2+1, i ), ldc,
307 $ one, work( n1+1 ), ldwork )
308*
309* Copy everything back.
310*
311 CALL dlacpy( 'All', m, len, work, ldwork, c( 1, i ),
312 $ ldc )
313 END DO
314 ELSE
315 DO i = 1, n, nb
316 len = min( nb, n-i+1 )
317 ldwork = m
318*
319* Multiply bottom part of C by Q21**T.
320*
321 CALL dlacpy( 'All', n2, len, c( n1+1, i ), ldc, work,
322 $ ldwork )
323 CALL dtrmm( 'Left', 'Upper', 'Transpose', 'Non-Unit',
324 $ n2, len, one, q( n1+1, 1 ), ldq, work,
325 $ ldwork )
326*
327* Multiply top part of C by Q11**T.
328*
329 CALL dgemm( 'Transpose', 'No Transpose', n2, len, n1,
330 $ one, q, ldq, c( 1, i ), ldc, one, work,
331 $ ldwork )
332*
333* Multiply top part of C by Q12**T.
334*
335 CALL dlacpy( 'All', n1, len, c( 1, i ), ldc,
336 $ work( n2+1 ), ldwork )
337 CALL dtrmm( 'Left', 'Lower', 'Transpose', 'Non-Unit',
338 $ n1, len, one, q( 1, n2+1 ), ldq,
339 $ work( n2+1 ), ldwork )
340*
341* Multiply bottom part of C by Q22**T.
342*
343 CALL dgemm( 'Transpose', 'No Transpose', n1, len, n2,
344 $ one, q( n1+1, n2+1 ), ldq, c( n1+1, i ), ldc,
345 $ one, work( n2+1 ), ldwork )
346*
347* Copy everything back.
348*
349 CALL dlacpy( 'All', m, len, work, ldwork, c( 1, i ),
350 $ ldc )
351 END DO
352 END IF
353 ELSE
354 IF( notran ) THEN
355 DO i = 1, m, nb
356 len = min( nb, m-i+1 )
357 ldwork = len
358*
359* Multiply right part of C by Q21.
360*
361 CALL dlacpy( 'All', len, n2, c( i, n1+1 ), ldc, work,
362 $ ldwork )
363 CALL dtrmm( 'Right', 'Upper', 'No Transpose', 'Non-Unit',
364 $ len, n2, one, q( n1+1, 1 ), ldq, work,
365 $ ldwork )
366*
367* Multiply left part of C by Q11.
368*
369 CALL dgemm( 'No Transpose', 'No Transpose', len, n2, n1,
370 $ one, c( i, 1 ), ldc, q, ldq, one, work,
371 $ ldwork )
372*
373* Multiply left part of C by Q12.
374*
375 CALL dlacpy( 'All', len, n1, c( i, 1 ), ldc,
376 $ work( 1 + n2*ldwork ), ldwork )
377 CALL dtrmm( 'Right', 'Lower', 'No Transpose', 'Non-Unit',
378 $ len, n1, one, q( 1, n2+1 ), ldq,
379 $ work( 1 + n2*ldwork ), ldwork )
380*
381* Multiply right part of C by Q22.
382*
383 CALL dgemm( 'No Transpose', 'No Transpose', len, n1, n2,
384 $ one, c( i, n1+1 ), ldc, q( n1+1, n2+1 ), ldq,
385 $ one, work( 1 + n2*ldwork ), ldwork )
386*
387* Copy everything back.
388*
389 CALL dlacpy( 'All', len, n, work, ldwork, c( i, 1 ),
390 $ ldc )
391 END DO
392 ELSE
393 DO i = 1, m, nb
394 len = min( nb, m-i+1 )
395 ldwork = len
396*
397* Multiply right part of C by Q12**T.
398*
399 CALL dlacpy( 'All', len, n1, c( i, n2+1 ), ldc, work,
400 $ ldwork )
401 CALL dtrmm( 'Right', 'Lower', 'Transpose', 'Non-Unit',
402 $ len, n1, one, q( 1, n2+1 ), ldq, work,
403 $ ldwork )
404*
405* Multiply left part of C by Q11**T.
406*
407 CALL dgemm( 'No Transpose', 'Transpose', len, n1, n2,
408 $ one, c( i, 1 ), ldc, q, ldq, one, work,
409 $ ldwork )
410*
411* Multiply left part of C by Q21**T.
412*
413 CALL dlacpy( 'All', len, n2, c( i, 1 ), ldc,
414 $ work( 1 + n1*ldwork ), ldwork )
415 CALL dtrmm( 'Right', 'Upper', 'Transpose', 'Non-Unit',
416 $ len, n2, one, q( n1+1, 1 ), ldq,
417 $ work( 1 + n1*ldwork ), ldwork )
418*
419* Multiply right part of C by Q22**T.
420*
421 CALL dgemm( 'No Transpose', 'Transpose', len, n2, n1,
422 $ one, c( i, n2+1 ), ldc, q( n1+1, n2+1 ), ldq,
423 $ one, work( 1 + n1*ldwork ), ldwork )
424*
425* Copy everything back.
426*
427 CALL dlacpy( 'All', len, n, work, ldwork, c( i, 1 ),
428 $ ldc )
429 END DO
430 END IF
431 END IF
432*
433 work( 1 ) = dble( lwkopt )
434 RETURN
435*
436* End of DORM22
437*
dlacpy
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
Definition dlacpy.f:103
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187
dtrmm
subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRMM
Definition dtrmm.f:177

◆ sorm22()

subroutine sorm22 ( character side,
character trans,
integer m,
integer n,
integer n1,
integer n2,
real, dimension( ldq, * ) q,
integer ldq,
real, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) work,
integer lwork,
integer info )

SORM22 multiplies a general matrix by a banded orthogonal matrix.

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

Purpose
!>
!>
!>  SORM22 overwrites the general real M-by-N matrix C with
!>
!>                  SIDE = 'L'     SIDE = 'R'
!>  TRANS = 'N':      Q * C          C * Q
!>  TRANS = 'T':      Q**T * C       C * Q**T
!>
!>  where Q is a real orthogonal matrix of order NQ, with NQ = M if
!>  SIDE = 'L' and NQ = N if SIDE = 'R'.
!>  The orthogonal matrix Q processes a 2-by-2 block structure
!>
!>         [  Q11  Q12  ]
!>     Q = [            ]
!>         [  Q21  Q22  ],
!>
!>  where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an
!>  N2-by-N2 upper triangular matrix.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**T from the Left;
!>          = 'R': apply Q or Q**T from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  apply Q (No transpose);
!>          = 'C':  apply Q**T (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]N1
[in]N2
!>          N1 is INTEGER
!>          N2 is INTEGER
!>          The dimension of Q12 and Q21, respectively. N1, N2 >= 0.
!>          The following requirement must be satisfied:
!>          N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'.
!>
[in]Q
!>          Q is REAL array, dimension
!>                              (LDQ,M) if SIDE = 'L'
!>                              (LDQ,N) if SIDE = 'R'
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'.
!>
[in,out]C
!>          C is REAL array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For optimum performance LWORK >= M*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.

Definition at line 161 of file sorm22.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 IMPLICIT NONE
169*
170* .. Scalar Arguments ..
171 CHARACTER SIDE, TRANS
172 INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO
173* ..
174* .. Array Arguments ..
175 REAL Q( LDQ, * ), C( LDC, * ), WORK( * )
176* ..
177*
178* =====================================================================
179*
180* .. Parameters ..
181 REAL ONE
182 parameter( one = 1.0e+0 )
183*
184* .. Local Scalars ..
185 LOGICAL LEFT, LQUERY, NOTRAN
186 INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 EXTERNAL lsame
191* ..
192* .. External Subroutines ..
193 EXTERNAL sgemm, slacpy, strmm, xerbla
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC real, max, min
197* ..
198* .. Executable Statements ..
199*
200* Test the input arguments
201*
202 info = 0
203 left = lsame( side, 'L' )
204 notran = lsame( trans, 'N' )
205 lquery = ( lwork.EQ.-1 )
206*
207* NQ is the order of Q;
208* NW is the minimum dimension of WORK.
209*
210 IF( left ) THEN
211 nq = m
212 ELSE
213 nq = n
214 END IF
215 nw = nq
216 IF( n1.EQ.0 .OR. n2.EQ.0 ) nw = 1
217 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
218 info = -1
219 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'T' ) )
220 $ THEN
221 info = -2
222 ELSE IF( m.LT.0 ) THEN
223 info = -3
224 ELSE IF( n.LT.0 ) THEN
225 info = -4
226 ELSE IF( n1.LT.0 .OR. n1+n2.NE.nq ) THEN
227 info = -5
228 ELSE IF( n2.LT.0 ) THEN
229 info = -6
230 ELSE IF( ldq.LT.max( 1, nq ) ) THEN
231 info = -8
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 lwkopt = m*n
240 work( 1 ) = real( lwkopt )
241 END IF
242*
243 IF( info.NE.0 ) THEN
244 CALL xerbla( 'SORM22', -info )
245 RETURN
246 ELSE IF( lquery ) THEN
247 RETURN
248 END IF
249*
250* Quick return if possible
251*
252 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
253 work( 1 ) = 1
254 RETURN
255 END IF
256*
257* Degenerate cases (N1 = 0 or N2 = 0) are handled using STRMM.
258*
259 IF( n1.EQ.0 ) THEN
260 CALL strmm( side, 'Upper', trans, 'Non-Unit', m, n, one,
261 $ q, ldq, c, ldc )
262 work( 1 ) = one
263 RETURN
264 ELSE IF( n2.EQ.0 ) THEN
265 CALL strmm( side, 'Lower', trans, 'Non-Unit', m, n, one,
266 $ q, ldq, c, ldc )
267 work( 1 ) = one
268 RETURN
269 END IF
270*
271* Compute the largest chunk size available from the workspace.
272*
273 nb = max( 1, min( lwork, lwkopt ) / nq )
274*
275 IF( left ) THEN
276 IF( notran ) THEN
277 DO i = 1, n, nb
278 len = min( nb, n-i+1 )
279 ldwork = m
280*
281* Multiply bottom part of C by Q12.
282*
283 CALL slacpy( 'All', n1, len, c( n2+1, i ), ldc, work,
284 $ ldwork )
285 CALL strmm( 'Left', 'Lower', 'No Transpose', 'Non-Unit',
286 $ n1, len, one, q( 1, n2+1 ), ldq, work,
287 $ ldwork )
288*
289* Multiply top part of C by Q11.
290*
291 CALL sgemm( 'No Transpose', 'No Transpose', n1, len, n2,
292 $ one, q, ldq, c( 1, i ), ldc, one, work,
293 $ ldwork )
294*
295* Multiply top part of C by Q21.
296*
297 CALL slacpy( 'All', n2, len, c( 1, i ), ldc,
298 $ work( n1+1 ), ldwork )
299 CALL strmm( 'Left', 'Upper', 'No Transpose', 'Non-Unit',
300 $ n2, len, one, q( n1+1, 1 ), ldq,
301 $ work( n1+1 ), ldwork )
302*
303* Multiply bottom part of C by Q22.
304*
305 CALL sgemm( 'No Transpose', 'No Transpose', n2, len, n1,
306 $ one, q( n1+1, n2+1 ), ldq, c( n2+1, i ), ldc,
307 $ one, work( n1+1 ), ldwork )
308*
309* Copy everything back.
310*
311 CALL slacpy( 'All', m, len, work, ldwork, c( 1, i ),
312 $ ldc )
313 END DO
314 ELSE
315 DO i = 1, n, nb
316 len = min( nb, n-i+1 )
317 ldwork = m
318*
319* Multiply bottom part of C by Q21**T.
320*
321 CALL slacpy( 'All', n2, len, c( n1+1, i ), ldc, work,
322 $ ldwork )
323 CALL strmm( 'Left', 'Upper', 'Transpose', 'Non-Unit',
324 $ n2, len, one, q( n1+1, 1 ), ldq, work,
325 $ ldwork )
326*
327* Multiply top part of C by Q11**T.
328*
329 CALL sgemm( 'Transpose', 'No Transpose', n2, len, n1,
330 $ one, q, ldq, c( 1, i ), ldc, one, work,
331 $ ldwork )
332*
333* Multiply top part of C by Q12**T.
334*
335 CALL slacpy( 'All', n1, len, c( 1, i ), ldc,
336 $ work( n2+1 ), ldwork )
337 CALL strmm( 'Left', 'Lower', 'Transpose', 'Non-Unit',
338 $ n1, len, one, q( 1, n2+1 ), ldq,
339 $ work( n2+1 ), ldwork )
340*
341* Multiply bottom part of C by Q22**T.
342*
343 CALL sgemm( 'Transpose', 'No Transpose', n1, len, n2,
344 $ one, q( n1+1, n2+1 ), ldq, c( n1+1, i ), ldc,
345 $ one, work( n2+1 ), ldwork )
346*
347* Copy everything back.
348*
349 CALL slacpy( 'All', m, len, work, ldwork, c( 1, i ),
350 $ ldc )
351 END DO
352 END IF
353 ELSE
354 IF( notran ) THEN
355 DO i = 1, m, nb
356 len = min( nb, m-i+1 )
357 ldwork = len
358*
359* Multiply right part of C by Q21.
360*
361 CALL slacpy( 'All', len, n2, c( i, n1+1 ), ldc, work,
362 $ ldwork )
363 CALL strmm( 'Right', 'Upper', 'No Transpose', 'Non-Unit',
364 $ len, n2, one, q( n1+1, 1 ), ldq, work,
365 $ ldwork )
366*
367* Multiply left part of C by Q11.
368*
369 CALL sgemm( 'No Transpose', 'No Transpose', len, n2, n1,
370 $ one, c( i, 1 ), ldc, q, ldq, one, work,
371 $ ldwork )
372*
373* Multiply left part of C by Q12.
374*
375 CALL slacpy( 'All', len, n1, c( i, 1 ), ldc,
376 $ work( 1 + n2*ldwork ), ldwork )
377 CALL strmm( 'Right', 'Lower', 'No Transpose', 'Non-Unit',
378 $ len, n1, one, q( 1, n2+1 ), ldq,
379 $ work( 1 + n2*ldwork ), ldwork )
380*
381* Multiply right part of C by Q22.
382*
383 CALL sgemm( 'No Transpose', 'No Transpose', len, n1, n2,
384 $ one, c( i, n1+1 ), ldc, q( n1+1, n2+1 ), ldq,
385 $ one, work( 1 + n2*ldwork ), ldwork )
386*
387* Copy everything back.
388*
389 CALL slacpy( 'All', len, n, work, ldwork, c( i, 1 ),
390 $ ldc )
391 END DO
392 ELSE
393 DO i = 1, m, nb
394 len = min( nb, m-i+1 )
395 ldwork = len
396*
397* Multiply right part of C by Q12**T.
398*
399 CALL slacpy( 'All', len, n1, c( i, n2+1 ), ldc, work,
400 $ ldwork )
401 CALL strmm( 'Right', 'Lower', 'Transpose', 'Non-Unit',
402 $ len, n1, one, q( 1, n2+1 ), ldq, work,
403 $ ldwork )
404*
405* Multiply left part of C by Q11**T.
406*
407 CALL sgemm( 'No Transpose', 'Transpose', len, n1, n2,
408 $ one, c( i, 1 ), ldc, q, ldq, one, work,
409 $ ldwork )
410*
411* Multiply left part of C by Q21**T.
412*
413 CALL slacpy( 'All', len, n2, c( i, 1 ), ldc,
414 $ work( 1 + n1*ldwork ), ldwork )
415 CALL strmm( 'Right', 'Upper', 'Transpose', 'Non-Unit',
416 $ len, n2, one, q( n1+1, 1 ), ldq,
417 $ work( 1 + n1*ldwork ), ldwork )
418*
419* Multiply right part of C by Q22**T.
420*
421 CALL sgemm( 'No Transpose', 'Transpose', len, n2, n1,
422 $ one, c( i, n2+1 ), ldc, q( n1+1, n2+1 ), ldq,
423 $ one, work( 1 + n1*ldwork ), ldwork )
424*
425* Copy everything back.
426*
427 CALL slacpy( 'All', len, n, work, ldwork, c( i, 1 ),
428 $ ldc )
429 END DO
430 END IF
431 END IF
432*
433 work( 1 ) = real( lwkopt )
434 RETURN
435*
436* End of SORM22
437*
slacpy
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
Definition slacpy.f:103
strmm
subroutine strmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRMM
Definition strmm.f:177

◆ zunm22()

subroutine zunm22 ( character side,
character trans,
integer m,
integer n,
integer n1,
integer n2,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer lwork,
integer info )

ZUNM22 multiplies a general matrix by a banded unitary matrix.

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

Purpose
!>
!>  ZUNM22 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'.
!>  The unitary matrix Q processes a 2-by-2 block structure
!>
!>         [  Q11  Q12  ]
!>     Q = [            ]
!>         [  Q21  Q22  ],
!>
!>  where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an
!>  N2-by-N2 upper triangular matrix.
!>
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]N1
[in]N2
!>          N1 is INTEGER
!>          N2 is INTEGER
!>          The dimension of Q12 and Q21, respectively. N1, N2 >= 0.
!>          The following requirement must be satisfied:
!>          N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'.
!>
[in]Q
!>          Q is COMPLEX*16 array, dimension
!>                              (LDQ,M) if SIDE = 'L'
!>                              (LDQ,N) if SIDE = 'R'
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'.
!>
[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 >= M*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.

Definition at line 160 of file zunm22.f.

162*
163* -- LAPACK computational routine --
164* -- LAPACK is a software package provided by Univ. of Tennessee, --
165* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
166*
167 IMPLICIT NONE
168*
169* .. Scalar Arguments ..
170 CHARACTER SIDE, TRANS
171 INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO
172* ..
173* .. Array Arguments ..
174 COMPLEX*16 Q( LDQ, * ), C( LDC, * ), WORK( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 COMPLEX*16 ONE
181 parameter( one = ( 1.0d+0, 0.0d+0 ) )
182*
183* .. Local Scalars ..
184 LOGICAL LEFT, LQUERY, NOTRAN
185 INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW
186* ..
187* .. External Functions ..
188 LOGICAL LSAME
189 EXTERNAL lsame
190* ..
191* .. External Subroutines ..
192 EXTERNAL zgemm, zlacpy, ztrmm, xerbla
193* ..
194* .. Intrinsic Functions ..
195 INTRINSIC dcmplx, max, min
196* ..
197* .. Executable Statements ..
198*
199* Test the input arguments
200*
201 info = 0
202 left = lsame( side, 'L' )
203 notran = lsame( trans, 'N' )
204 lquery = ( lwork.EQ.-1 )
205*
206* NQ is the order of Q;
207* NW is the minimum dimension of WORK.
208*
209 IF( left ) THEN
210 nq = m
211 ELSE
212 nq = n
213 END IF
214 nw = nq
215 IF( n1.EQ.0 .OR. n2.EQ.0 ) nw = 1
216 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
217 info = -1
218 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) )
219 $ THEN
220 info = -2
221 ELSE IF( m.LT.0 ) THEN
222 info = -3
223 ELSE IF( n.LT.0 ) THEN
224 info = -4
225 ELSE IF( n1.LT.0 .OR. n1+n2.NE.nq ) THEN
226 info = -5
227 ELSE IF( n2.LT.0 ) THEN
228 info = -6
229 ELSE IF( ldq.LT.max( 1, nq ) ) THEN
230 info = -8
231 ELSE IF( ldc.LT.max( 1, m ) ) THEN
232 info = -10
233 ELSE IF( lwork.LT.nw .AND. .NOT.lquery ) THEN
234 info = -12
235 END IF
236*
237 IF( info.EQ.0 ) THEN
238 lwkopt = m*n
239 work( 1 ) = dcmplx( lwkopt )
240 END IF
241*
242 IF( info.NE.0 ) THEN
243 CALL xerbla( 'ZUNM22', -info )
244 RETURN
245 ELSE IF( lquery ) THEN
246 RETURN
247 END IF
248*
249* Quick return if possible
250*
251 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
252 work( 1 ) = 1
253 RETURN
254 END IF
255*
256* Degenerate cases (N1 = 0 or N2 = 0) are handled using ZTRMM.
257*
258 IF( n1.EQ.0 ) THEN
259 CALL ztrmm( side, 'Upper', trans, 'Non-Unit', m, n, one,
260 $ q, ldq, c, ldc )
261 work( 1 ) = one
262 RETURN
263 ELSE IF( n2.EQ.0 ) THEN
264 CALL ztrmm( side, 'Lower', trans, 'Non-Unit', m, n, one,
265 $ q, ldq, c, ldc )
266 work( 1 ) = one
267 RETURN
268 END IF
269*
270* Compute the largest chunk size available from the workspace.
271*
272 nb = max( 1, min( lwork, lwkopt ) / nq )
273*
274 IF( left ) THEN
275 IF( notran ) THEN
276 DO i = 1, n, nb
277 len = min( nb, n-i+1 )
278 ldwork = m
279*
280* Multiply bottom part of C by Q12.
281*
282 CALL zlacpy( 'All', n1, len, c( n2+1, i ), ldc, work,
283 $ ldwork )
284 CALL ztrmm( 'Left', 'Lower', 'No Transpose', 'Non-Unit',
285 $ n1, len, one, q( 1, n2+1 ), ldq, work,
286 $ ldwork )
287*
288* Multiply top part of C by Q11.
289*
290 CALL zgemm( 'No Transpose', 'No Transpose', n1, len, n2,
291 $ one, q, ldq, c( 1, i ), ldc, one, work,
292 $ ldwork )
293*
294* Multiply top part of C by Q21.
295*
296 CALL zlacpy( 'All', n2, len, c( 1, i ), ldc,
297 $ work( n1+1 ), ldwork )
298 CALL ztrmm( 'Left', 'Upper', 'No Transpose', 'Non-Unit',
299 $ n2, len, one, q( n1+1, 1 ), ldq,
300 $ work( n1+1 ), ldwork )
301*
302* Multiply bottom part of C by Q22.
303*
304 CALL zgemm( 'No Transpose', 'No Transpose', n2, len, n1,
305 $ one, q( n1+1, n2+1 ), ldq, c( n2+1, i ), ldc,
306 $ one, work( n1+1 ), ldwork )
307*
308* Copy everything back.
309*
310 CALL zlacpy( 'All', m, len, work, ldwork, c( 1, i ),
311 $ ldc )
312 END DO
313 ELSE
314 DO i = 1, n, nb
315 len = min( nb, n-i+1 )
316 ldwork = m
317*
318* Multiply bottom part of C by Q21**H.
319*
320 CALL zlacpy( 'All', n2, len, c( n1+1, i ), ldc, work,
321 $ ldwork )
322 CALL ztrmm( 'Left', 'Upper', 'Conjugate', 'Non-Unit',
323 $ n2, len, one, q( n1+1, 1 ), ldq, work,
324 $ ldwork )
325*
326* Multiply top part of C by Q11**H.
327*
328 CALL zgemm( 'Conjugate', 'No Transpose', n2, len, n1,
329 $ one, q, ldq, c( 1, i ), ldc, one, work,
330 $ ldwork )
331*
332* Multiply top part of C by Q12**H.
333*
334 CALL zlacpy( 'All', n1, len, c( 1, i ), ldc,
335 $ work( n2+1 ), ldwork )
336 CALL ztrmm( 'Left', 'Lower', 'Conjugate', 'Non-Unit',
337 $ n1, len, one, q( 1, n2+1 ), ldq,
338 $ work( n2+1 ), ldwork )
339*
340* Multiply bottom part of C by Q22**H.
341*
342 CALL zgemm( 'Conjugate', 'No Transpose', n1, len, n2,
343 $ one, q( n1+1, n2+1 ), ldq, c( n1+1, i ), ldc,
344 $ one, work( n2+1 ), ldwork )
345*
346* Copy everything back.
347*
348 CALL zlacpy( 'All', m, len, work, ldwork, c( 1, i ),
349 $ ldc )
350 END DO
351 END IF
352 ELSE
353 IF( notran ) THEN
354 DO i = 1, m, nb
355 len = min( nb, m-i+1 )
356 ldwork = len
357*
358* Multiply right part of C by Q21.
359*
360 CALL zlacpy( 'All', len, n2, c( i, n1+1 ), ldc, work,
361 $ ldwork )
362 CALL ztrmm( 'Right', 'Upper', 'No Transpose', 'Non-Unit',
363 $ len, n2, one, q( n1+1, 1 ), ldq, work,
364 $ ldwork )
365*
366* Multiply left part of C by Q11.
367*
368 CALL zgemm( 'No Transpose', 'No Transpose', len, n2, n1,
369 $ one, c( i, 1 ), ldc, q, ldq, one, work,
370 $ ldwork )
371*
372* Multiply left part of C by Q12.
373*
374 CALL zlacpy( 'All', len, n1, c( i, 1 ), ldc,
375 $ work( 1 + n2*ldwork ), ldwork )
376 CALL ztrmm( 'Right', 'Lower', 'No Transpose', 'Non-Unit',
377 $ len, n1, one, q( 1, n2+1 ), ldq,
378 $ work( 1 + n2*ldwork ), ldwork )
379*
380* Multiply right part of C by Q22.
381*
382 CALL zgemm( 'No Transpose', 'No Transpose', len, n1, n2,
383 $ one, c( i, n1+1 ), ldc, q( n1+1, n2+1 ), ldq,
384 $ one, work( 1 + n2*ldwork ), ldwork )
385*
386* Copy everything back.
387*
388 CALL zlacpy( 'All', len, n, work, ldwork, c( i, 1 ),
389 $ ldc )
390 END DO
391 ELSE
392 DO i = 1, m, nb
393 len = min( nb, m-i+1 )
394 ldwork = len
395*
396* Multiply right part of C by Q12**H.
397*
398 CALL zlacpy( 'All', len, n1, c( i, n2+1 ), ldc, work,
399 $ ldwork )
400 CALL ztrmm( 'Right', 'Lower', 'Conjugate', 'Non-Unit',
401 $ len, n1, one, q( 1, n2+1 ), ldq, work,
402 $ ldwork )
403*
404* Multiply left part of C by Q11**H.
405*
406 CALL zgemm( 'No Transpose', 'Conjugate', len, n1, n2,
407 $ one, c( i, 1 ), ldc, q, ldq, one, work,
408 $ ldwork )
409*
410* Multiply left part of C by Q21**H.
411*
412 CALL zlacpy( 'All', len, n2, c( i, 1 ), ldc,
413 $ work( 1 + n1*ldwork ), ldwork )
414 CALL ztrmm( 'Right', 'Upper', 'Conjugate', 'Non-Unit',
415 $ len, n2, one, q( n1+1, 1 ), ldq,
416 $ work( 1 + n1*ldwork ), ldwork )
417*
418* Multiply right part of C by Q22**H.
419*
420 CALL zgemm( 'No Transpose', 'Conjugate', len, n2, n1,
421 $ one, c( i, n2+1 ), ldc, q( n1+1, n2+1 ), ldq,
422 $ one, work( 1 + n1*ldwork ), ldwork )
423*
424* Copy everything back.
425*
426 CALL zlacpy( 'All', len, n, work, ldwork, c( i, 1 ),
427 $ ldc )
428 END DO
429 END IF
430 END IF
431*
432 work( 1 ) = dcmplx( lwkopt )
433 RETURN
434*
435* End of ZUNM22
436*
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
ztrmm
subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRMM
Definition ztrmm.f:177
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187