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

Functions

subroutine sggsvp (jobu, jobv, jobq, m, p, n, a, lda, b, ldb, tola, tolb, k, l, u, ldu, v, ldv, q, ldq, iwork, tau, work, info)
 SGGSVP
subroutine slatzm (side, m, n, v, incv, tau, c1, c2, ldc, work)
 SLATZM
subroutine stzrqf (m, n, a, lda, tau, info)
 STZRQF
subroutine sbbcsd (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, work, lwork, info)
 SBBCSD
subroutine sgghd3 (compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, work, lwork, info)
 SGGHD3
subroutine sgghrd (compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, info)
 SGGHRD
subroutine sggqrf (n, m, p, a, lda, taua, b, ldb, taub, work, lwork, info)
 SGGQRF
subroutine sggrqf (m, p, n, a, lda, taua, b, ldb, taub, work, lwork, info)
 SGGRQF
subroutine sggsvp3 (jobu, jobv, jobq, m, p, n, a, lda, b, ldb, tola, tolb, k, l, u, ldu, v, ldv, q, ldq, iwork, tau, work, lwork, info)
 SGGSVP3
subroutine sgsvj0 (jobv, m, n, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
 SGSVJ0 pre-processor for the routine sgesvj.
subroutine sgsvj1 (jobv, m, n, n1, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
 SGSVJ1 pre-processor for the routine sgesvj, applies Jacobi rotations targeting only particular pivots.
subroutine shsein (side, eigsrc, initv, select, n, h, ldh, wr, wi, vl, ldvl, vr, ldvr, mm, m, work, ifaill, ifailr, info)
 SHSEIN
subroutine shseqr (job, compz, n, ilo, ihi, h, ldh, wr, wi, z, ldz, work, lwork, info)
 SHSEQR
subroutine sla_lin_berr (n, nz, nrhs, res, ayb, berr)
 SLA_LIN_BERR computes a component-wise relative backward error.
subroutine sla_wwaddw (n, x, y, w)
 SLA_WWADDW adds a vector into a doubled-single vector.
subroutine slals0 (icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx, perm, givptr, givcol, ldgcol, givnum, ldgnum, poles, difl, difr, z, k, c, s, work, info)
 SLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd.
subroutine slalsa (icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u, ldu, vt, k, difl, difr, z, poles, givptr, givcol, ldgcol, perm, givnum, c, s, work, iwork, info)
 SLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd.
subroutine slalsd (uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond, rank, work, iwork, info)
 SLALSD uses the singular value decomposition of A to solve the least squares problem.
real function slansf (norm, transr, uplo, n, a, work)
 SLANSF
subroutine slarscl2 (m, n, d, x, ldx)
 SLARSCL2 performs reciprocal diagonal scaling on a vector.
subroutine slarz (side, m, n, l, v, incv, tau, c, ldc, work)
 SLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix.
subroutine slarzb (side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, c, ldc, work, ldwork)
 SLARZB applies a block reflector or its transpose to a general matrix.
subroutine slarzt (direct, storev, n, k, v, ldv, tau, t, ldt)
 SLARZT forms the triangular factor T of a block reflector H = I - vtvH.
subroutine slascl2 (m, n, d, x, ldx)
 SLASCL2 performs diagonal scaling on a vector.
subroutine slatrz (m, n, l, a, lda, tau, work)
 SLATRZ factors an upper trapezoidal matrix by means of orthogonal transformations.
subroutine sopgtr (uplo, n, ap, tau, q, ldq, work, info)
 SOPGTR
subroutine sopmtr (side, uplo, trans, m, n, ap, tau, c, ldc, work, info)
 SOPMTR
subroutine sorbdb (trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, lwork, info)
 SORBDB
subroutine sorbdb1 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 SORBDB1
subroutine sorbdb2 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 SORBDB2
subroutine sorbdb3 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 SORBDB3
subroutine sorbdb4 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, phantom, work, lwork, info)
 SORBDB4
subroutine sorbdb5 (m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
 SORBDB5
subroutine sorbdb6 (m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
 SORBDB6
recursive subroutine sorcsd (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, iwork, info)
 SORCSD
subroutine sorcsd2by1 (jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, iwork, info)
 SORCSD2BY1
subroutine sorg2l (m, n, k, a, lda, tau, work, info)
 SORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm).
subroutine sorg2r (m, n, k, a, lda, tau, work, info)
 SORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm).
subroutine sorghr (n, ilo, ihi, a, lda, tau, work, lwork, info)
 SORGHR
subroutine sorgl2 (m, n, k, a, lda, tau, work, info)
 SORGL2
subroutine sorglq (m, n, k, a, lda, tau, work, lwork, info)
 SORGLQ
subroutine sorgql (m, n, k, a, lda, tau, work, lwork, info)
 SORGQL
subroutine sorgqr (m, n, k, a, lda, tau, work, lwork, info)
 SORGQR
subroutine sorgr2 (m, n, k, a, lda, tau, work, info)
 SORGR2 generates all or part of the orthogonal matrix Q from an RQ factorization determined by sgerqf (unblocked algorithm).
subroutine sorgrq (m, n, k, a, lda, tau, work, lwork, info)
 SORGRQ
subroutine sorgtr (uplo, n, a, lda, tau, work, lwork, info)
 SORGTR
subroutine sorm2l (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 SORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sgeqlf (unblocked algorithm).
subroutine sorm2r (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 SORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm).
subroutine sormbr (vect, side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 SORMBR
subroutine sormhr (side, trans, m, n, ilo, ihi, a, lda, tau, c, ldc, work, lwork, info)
 SORMHR
subroutine sorml2 (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 SORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm).
subroutine sormlq (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 SORMLQ
subroutine sormql (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 SORMQL
subroutine sormqr (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 SORMQR
subroutine sormr2 (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 SORMR2 multiplies a general matrix by the orthogonal matrix from a RQ factorization determined by sgerqf (unblocked algorithm).
subroutine sormr3 (side, trans, m, n, k, l, a, lda, tau, c, ldc, work, info)
 SORMR3 multiplies a general matrix by the orthogonal matrix from a RZ factorization determined by stzrzf (unblocked algorithm).
subroutine sormrq (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 SORMRQ
subroutine sormrz (side, trans, m, n, k, l, a, lda, tau, c, ldc, work, lwork, info)
 SORMRZ
subroutine sormtr (side, uplo, trans, m, n, a, lda, tau, c, ldc, work, lwork, info)
 SORMTR
subroutine spbcon (uplo, n, kd, ab, ldab, anorm, rcond, work, iwork, info)
 SPBCON
subroutine spbequ (uplo, n, kd, ab, ldab, s, scond, amax, info)
 SPBEQU
subroutine spbrfs (uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 SPBRFS
subroutine spbstf (uplo, n, kd, ab, ldab, info)
 SPBSTF
subroutine spbtf2 (uplo, n, kd, ab, ldab, info)
 SPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (unblocked algorithm).
subroutine spbtrf (uplo, n, kd, ab, ldab, info)
 SPBTRF
subroutine spbtrs (uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
 SPBTRS
subroutine spftrf (transr, uplo, n, a, info)
 SPFTRF
subroutine spftri (transr, uplo, n, a, info)
 SPFTRI
subroutine spftrs (transr, uplo, n, nrhs, a, b, ldb, info)
 SPFTRS
subroutine sppcon (uplo, n, ap, anorm, rcond, work, iwork, info)
 SPPCON
subroutine sppequ (uplo, n, ap, s, scond, amax, info)
 SPPEQU
subroutine spprfs (uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 SPPRFS
subroutine spptrf (uplo, n, ap, info)
 SPPTRF
subroutine spptri (uplo, n, ap, info)
 SPPTRI
subroutine spptrs (uplo, n, nrhs, ap, b, ldb, info)
 SPPTRS
subroutine spstf2 (uplo, n, a, lda, piv, rank, tol, work, info)
 SPSTF2 computes the Cholesky factorization with complete pivoting of a real symmetric positive semidefinite matrix.
subroutine spstrf (uplo, n, a, lda, piv, rank, tol, work, info)
 SPSTRF computes the Cholesky factorization with complete pivoting of a real symmetric positive semidefinite matrix.
subroutine ssbgst (vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x, ldx, work, info)
 SSBGST
subroutine ssbtrd (vect, uplo, n, kd, ab, ldab, d, e, q, ldq, work, info)
 SSBTRD
subroutine ssfrk (transr, uplo, trans, n, k, alpha, a, lda, beta, c)
 SSFRK performs a symmetric rank-k operation for matrix in RFP format.
subroutine sspcon (uplo, n, ap, ipiv, anorm, rcond, work, iwork, info)
 SSPCON
subroutine sspgst (itype, uplo, n, ap, bp, info)
 SSPGST
subroutine ssprfs (uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 SSPRFS
subroutine ssptrd (uplo, n, ap, d, e, tau, info)
 SSPTRD
subroutine ssptrf (uplo, n, ap, ipiv, info)
 SSPTRF
subroutine ssptri (uplo, n, ap, ipiv, work, info)
 SSPTRI
subroutine ssptrs (uplo, n, nrhs, ap, ipiv, b, ldb, info)
 SSPTRS
subroutine sstegr (jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
 SSTEGR
subroutine sstein (n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
 SSTEIN
subroutine sstemr (jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
 SSTEMR
subroutine stbcon (norm, uplo, diag, n, kd, ab, ldab, rcond, work, iwork, info)
 STBCON
subroutine stbrfs (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 STBRFS
subroutine stbtrs (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, info)
 STBTRS
subroutine stfsm (transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
 STFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
subroutine stftri (transr, uplo, diag, n, a, info)
 STFTRI
subroutine stfttp (transr, uplo, n, arf, ap, info)
 STFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed format (TP).
subroutine stfttr (transr, uplo, n, arf, a, lda, info)
 STFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full format (TR).
subroutine stgsen (ijob, wantq, wantz, select, n, a, lda, b, ldb, alphar, alphai, beta, q, ldq, z, ldz, m, pl, pr, dif, work, lwork, iwork, liwork, info)
 STGSEN
subroutine stgsja (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)
 STGSJA
subroutine stgsna (job, howmny, select, n, a, lda, b, ldb, vl, ldvl, vr, ldvr, s, dif, mm, m, work, lwork, iwork, info)
 STGSNA
subroutine stpcon (norm, uplo, diag, n, ap, rcond, work, iwork, info)
 STPCON
subroutine stpmqrt (side, trans, m, n, k, l, nb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
 STPMQRT
subroutine stpqrt (m, n, l, nb, a, lda, b, ldb, t, ldt, work, info)
 STPQRT
subroutine stpqrt2 (m, n, l, a, lda, b, ldb, t, ldt, info)
 STPQRT2 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 stprfs (uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 STPRFS
subroutine stptri (uplo, diag, n, ap, info)
 STPTRI
subroutine stptrs (uplo, trans, diag, n, nrhs, ap, b, ldb, info)
 STPTRS
subroutine stpttf (transr, uplo, n, ap, arf, info)
 STPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed format (TF).
subroutine stpttr (uplo, n, ap, a, lda, info)
 STPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (TR).
subroutine strcon (norm, uplo, diag, n, a, lda, rcond, work, iwork, info)
 STRCON
subroutine strevc (side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, info)
 STREVC
subroutine strevc3 (side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, lwork, info)
 STREVC3
subroutine strexc (compq, n, t, ldt, q, ldq, ifst, ilst, work, info)
 STREXC
subroutine strrfs (uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 STRRFS
subroutine strsen (job, compq, select, n, t, ldt, q, ldq, wr, wi, m, s, sep, work, lwork, iwork, liwork, info)
 STRSEN
subroutine strsna (job, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, s, sep, mm, m, work, ldwork, iwork, info)
 STRSNA
subroutine strti2 (uplo, diag, n, a, lda, info)
 STRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
subroutine strtri (uplo, diag, n, a, lda, info)
 STRTRI
subroutine strtrs (uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
 STRTRS
subroutine strttf (transr, uplo, n, a, lda, arf, info)
 STRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed format (TF).
subroutine strttp (uplo, n, a, lda, ap, info)
 STRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (TP).
subroutine stzrzf (m, n, a, lda, tau, work, lwork, info)
 STZRZF

Detailed Description

This is the group of real other Computational routines

Function Documentation

◆ sbbcsd()

subroutine sbbcsd ( character jobu1,
character jobu2,
character jobv1t,
character jobv2t,
character trans,
integer m,
integer p,
integer q,
real, dimension( * ) theta,
real, dimension( * ) phi,
real, dimension( ldu1, * ) u1,
integer ldu1,
real, dimension( ldu2, * ) u2,
integer ldu2,
real, dimension( ldv1t, * ) v1t,
integer ldv1t,
real, 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( * ) work,
integer lwork,
integer info )

SBBCSD

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

Purpose:
!>
!> SBBCSD computes the CS decomposition of an orthogonal 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 |    ]**T
!>                 = [---------] [---------------] [---------]   .
!>                   [    | 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 SORCSD for details.)
!>
!> The bidiagonal matrices B11, B12, B21, and B22 are represented
!> implicitly by angles THETA(1:Q) and PHI(1:Q-1).
!>
!> The orthogonal 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 orthogonal 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 REAL 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 REAL 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 REAL array, dimension (LDV1T,Q)
!>          On entry, a Q-by-Q matrix. On exit, V1T is premultiplied
!>          by the 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 REAL array, dimension (LDV2T,M-Q)
!>          On entry, an (M-Q)-by-(M-Q) matrix. On exit, V2T is
!>          premultiplied by the 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 SBBCSD converges, B11D contains the cosines of THETA(1),
!>          ..., THETA(Q). If SBBCSD 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 SBBCSD converges, B11E contains zeros. If SBBCSD fails
!>          to converge, then B11E contains the superdiagonal of the
!>          partially reduced top-left block.
!>
[out]B12D
!>          B12D is REAL array, dimension (Q)
!>          When SBBCSD converges, B12D contains the negative sines of
!>          THETA(1), ..., THETA(Q). If SBBCSD 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 SBBCSD converges, B12E contains zeros. If SBBCSD fails
!>          to converge, then B12E contains the subdiagonal of the
!>          partially reduced top-right block.
!>
[out]B21D
!>          B21D is REAL array, dimension (Q)
!>          When SBBCSD converges, B21D contains the negative sines of
!>          THETA(1), ..., THETA(Q). If SBBCSD 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 SBBCSD converges, B21E contains zeros. If SBBCSD fails
!>          to converge, then B21E contains the subdiagonal of the
!>          partially reduced bottom-left block.
!>
[out]B22D
!>          B22D is REAL array, dimension (Q)
!>          When SBBCSD converges, B22D contains the negative sines of
!>          THETA(1), ..., THETA(Q). If SBBCSD 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 SBBCSD converges, B22E contains zeros. If SBBCSD fails
!>          to converge, then B22E contains the subdiagonal of the
!>          partially reduced bottom-right block.
!>
[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. LWORK >= MAX(1,8*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.
!>          > 0:  if SBBCSD 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 sbbcsd.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, LWORK, M, P, Q
340* ..
341* .. Array Arguments ..
342 REAL B11D( * ), B11E( * ), B12D( * ), B12E( * ),
343 $ B21D( * ), B21E( * ), B22D( * ), B22E( * ),
344 $ PHI( * ), THETA( * ), WORK( * )
345 REAL 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 REAL NEGONE
358 parameter( negone = -1.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 $ LWORKMIN, LWORKOPT, 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 slasr, sscal, sswap, 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 = lwork .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 lworkmin = 1
420 work(1) = lworkmin
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 lworkopt = iv2tsn + q - 1
436 lworkmin = lworkopt
437 work(1) = lworkopt
438 IF( lwork .LT. lworkmin .AND. .NOT. lquery ) THEN
439 info = -28
440 END IF
441 END IF
442*
443 IF( info .NE. 0 ) THEN
444 CALL xerbla( 'SBBCSD', -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 $ work(iv1tcs+imin-1), work(iv1tsn+imin-1) )
589 ELSE
590 CALL slartgs( b21d(imin), b21e(imin), nu,
591 $ work(iv1tcs+imin-1), work(iv1tsn+imin-1) )
592 END IF
593*
594 temp = work(iv1tcs+imin-1)*b11d(imin) +
595 $ work(iv1tsn+imin-1)*b11e(imin)
596 b11e(imin) = work(iv1tcs+imin-1)*b11e(imin) -
597 $ work(iv1tsn+imin-1)*b11d(imin)
598 b11d(imin) = temp
599 b11bulge = work(iv1tsn+imin-1)*b11d(imin+1)
600 b11d(imin+1) = work(iv1tcs+imin-1)*b11d(imin+1)
601 temp = work(iv1tcs+imin-1)*b21d(imin) +
602 $ work(iv1tsn+imin-1)*b21e(imin)
603 b21e(imin) = work(iv1tcs+imin-1)*b21e(imin) -
604 $ work(iv1tsn+imin-1)*b21d(imin)
605 b21d(imin) = temp
606 b21bulge = work(iv1tsn+imin-1)*b21d(imin+1)
607 b21d(imin+1) = work(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), work(iu1sn+imin-1),
618 $ work(iu1cs+imin-1), r )
619 ELSE IF( mu .LE. nu ) THEN
620 CALL slartgs( b11e( imin ), b11d( imin + 1 ), mu,
621 $ work(iu1cs+imin-1), work(iu1sn+imin-1) )
622 ELSE
623 CALL slartgs( b12d( imin ), b12e( imin ), nu,
624 $ work(iu1cs+imin-1), work(iu1sn+imin-1) )
625 END IF
626 IF( b21d(imin)**2+b21bulge**2 .GT. thresh**2 ) THEN
627 CALL slartgp( b21bulge, b21d(imin), work(iu2sn+imin-1),
628 $ work(iu2cs+imin-1), r )
629 ELSE IF( nu .LT. mu ) THEN
630 CALL slartgs( b21e( imin ), b21d( imin + 1 ), nu,
631 $ work(iu2cs+imin-1), work(iu2sn+imin-1) )
632 ELSE
633 CALL slartgs( b22d(imin), b22e(imin), mu,
634 $ work(iu2cs+imin-1), work(iu2sn+imin-1) )
635 END IF
636 work(iu2cs+imin-1) = -work(iu2cs+imin-1)
637 work(iu2sn+imin-1) = -work(iu2sn+imin-1)
638*
639 temp = work(iu1cs+imin-1)*b11e(imin) +
640 $ work(iu1sn+imin-1)*b11d(imin+1)
641 b11d(imin+1) = work(iu1cs+imin-1)*b11d(imin+1) -
642 $ work(iu1sn+imin-1)*b11e(imin)
643 b11e(imin) = temp
644 IF( imax .GT. imin+1 ) THEN
645 b11bulge = work(iu1sn+imin-1)*b11e(imin+1)
646 b11e(imin+1) = work(iu1cs+imin-1)*b11e(imin+1)
647 END IF
648 temp = work(iu1cs+imin-1)*b12d(imin) +
649 $ work(iu1sn+imin-1)*b12e(imin)
650 b12e(imin) = work(iu1cs+imin-1)*b12e(imin) -
651 $ work(iu1sn+imin-1)*b12d(imin)
652 b12d(imin) = temp
653 b12bulge = work(iu1sn+imin-1)*b12d(imin+1)
654 b12d(imin+1) = work(iu1cs+imin-1)*b12d(imin+1)
655 temp = work(iu2cs+imin-1)*b21e(imin) +
656 $ work(iu2sn+imin-1)*b21d(imin+1)
657 b21d(imin+1) = work(iu2cs+imin-1)*b21d(imin+1) -
658 $ work(iu2sn+imin-1)*b21e(imin)
659 b21e(imin) = temp
660 IF( imax .GT. imin+1 ) THEN
661 b21bulge = work(iu2sn+imin-1)*b21e(imin+1)
662 b21e(imin+1) = work(iu2cs+imin-1)*b21e(imin+1)
663 END IF
664 temp = work(iu2cs+imin-1)*b22d(imin) +
665 $ work(iu2sn+imin-1)*b22e(imin)
666 b22e(imin) = work(iu2cs+imin-1)*b22e(imin) -
667 $ work(iu2sn+imin-1)*b22d(imin)
668 b22d(imin) = temp
669 b22bulge = work(iu2sn+imin-1)*b22d(imin+1)
670 b22d(imin+1) = work(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, work(iv1tsn+i-1), work(iv1tcs+i-1),
701 $ r )
702 ELSE IF( .NOT. restart11 .AND. restart21 ) THEN
703 CALL slartgp( b11bulge, b11e(i-1), work(iv1tsn+i-1),
704 $ work(iv1tcs+i-1), r )
705 ELSE IF( restart11 .AND. .NOT. restart21 ) THEN
706 CALL slartgp( b21bulge, b21e(i-1), work(iv1tsn+i-1),
707 $ work(iv1tcs+i-1), r )
708 ELSE IF( mu .LE. nu ) THEN
709 CALL slartgs( b11d(i), b11e(i), mu, work(iv1tcs+i-1),
710 $ work(iv1tsn+i-1) )
711 ELSE
712 CALL slartgs( b21d(i), b21e(i), nu, work(iv1tcs+i-1),
713 $ work(iv1tsn+i-1) )
714 END IF
715 work(iv1tcs+i-1) = -work(iv1tcs+i-1)
716 work(iv1tsn+i-1) = -work(iv1tsn+i-1)
717 IF( .NOT. restart12 .AND. .NOT. restart22 ) THEN
718 CALL slartgp( y2, y1, work(iv2tsn+i-1-1),
719 $ work(iv2tcs+i-1-1), r )
720 ELSE IF( .NOT. restart12 .AND. restart22 ) THEN
721 CALL slartgp( b12bulge, b12d(i-1), work(iv2tsn+i-1-1),
722 $ work(iv2tcs+i-1-1), r )
723 ELSE IF( restart12 .AND. .NOT. restart22 ) THEN
724 CALL slartgp( b22bulge, b22d(i-1), work(iv2tsn+i-1-1),
725 $ work(iv2tcs+i-1-1), r )
726 ELSE IF( nu .LT. mu ) THEN
727 CALL slartgs( b12e(i-1), b12d(i), nu, work(iv2tcs+i-1-1),
728 $ work(iv2tsn+i-1-1) )
729 ELSE
730 CALL slartgs( b22e(i-1), b22d(i), mu, work(iv2tcs+i-1-1),
731 $ work(iv2tsn+i-1-1) )
732 END IF
733*
734 temp = work(iv1tcs+i-1)*b11d(i) + work(iv1tsn+i-1)*b11e(i)
735 b11e(i) = work(iv1tcs+i-1)*b11e(i) -
736 $ work(iv1tsn+i-1)*b11d(i)
737 b11d(i) = temp
738 b11bulge = work(iv1tsn+i-1)*b11d(i+1)
739 b11d(i+1) = work(iv1tcs+i-1)*b11d(i+1)
740 temp = work(iv1tcs+i-1)*b21d(i) + work(iv1tsn+i-1)*b21e(i)
741 b21e(i) = work(iv1tcs+i-1)*b21e(i) -
742 $ work(iv1tsn+i-1)*b21d(i)
743 b21d(i) = temp
744 b21bulge = work(iv1tsn+i-1)*b21d(i+1)
745 b21d(i+1) = work(iv1tcs+i-1)*b21d(i+1)
746 temp = work(iv2tcs+i-1-1)*b12e(i-1) +
747 $ work(iv2tsn+i-1-1)*b12d(i)
748 b12d(i) = work(iv2tcs+i-1-1)*b12d(i) -
749 $ work(iv2tsn+i-1-1)*b12e(i-1)
750 b12e(i-1) = temp
751 b12bulge = work(iv2tsn+i-1-1)*b12e(i)
752 b12e(i) = work(iv2tcs+i-1-1)*b12e(i)
753 temp = work(iv2tcs+i-1-1)*b22e(i-1) +
754 $ work(iv2tsn+i-1-1)*b22d(i)
755 b22d(i) = work(iv2tcs+i-1-1)*b22d(i) -
756 $ work(iv2tsn+i-1-1)*b22e(i-1)
757 b22e(i-1) = temp
758 b22bulge = work(iv2tsn+i-1-1)*b22e(i)
759 b22e(i) = work(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, work(iu1sn+i-1), work(iu1cs+i-1),
784 $ r )
785 ELSE IF( .NOT. restart11 .AND. restart12 ) THEN
786 CALL slartgp( b11bulge, b11d(i), work(iu1sn+i-1),
787 $ work(iu1cs+i-1), r )
788 ELSE IF( restart11 .AND. .NOT. restart12 ) THEN
789 CALL slartgp( b12bulge, b12e(i-1), work(iu1sn+i-1),
790 $ work(iu1cs+i-1), r )
791 ELSE IF( mu .LE. nu ) THEN
792 CALL slartgs( b11e(i), b11d(i+1), mu, work(iu1cs+i-1),
793 $ work(iu1sn+i-1) )
794 ELSE
795 CALL slartgs( b12d(i), b12e(i), nu, work(iu1cs+i-1),
796 $ work(iu1sn+i-1) )
797 END IF
798 IF( .NOT. restart21 .AND. .NOT. restart22 ) THEN
799 CALL slartgp( y2, y1, work(iu2sn+i-1), work(iu2cs+i-1),
800 $ r )
801 ELSE IF( .NOT. restart21 .AND. restart22 ) THEN
802 CALL slartgp( b21bulge, b21d(i), work(iu2sn+i-1),
803 $ work(iu2cs+i-1), r )
804 ELSE IF( restart21 .AND. .NOT. restart22 ) THEN
805 CALL slartgp( b22bulge, b22e(i-1), work(iu2sn+i-1),
806 $ work(iu2cs+i-1), r )
807 ELSE IF( nu .LT. mu ) THEN
808 CALL slartgs( b21e(i), b21e(i+1), nu, work(iu2cs+i-1),
809 $ work(iu2sn+i-1) )
810 ELSE
811 CALL slartgs( b22d(i), b22e(i), mu, work(iu2cs+i-1),
812 $ work(iu2sn+i-1) )
813 END IF
814 work(iu2cs+i-1) = -work(iu2cs+i-1)
815 work(iu2sn+i-1) = -work(iu2sn+i-1)
816*
817 temp = work(iu1cs+i-1)*b11e(i) + work(iu1sn+i-1)*b11d(i+1)
818 b11d(i+1) = work(iu1cs+i-1)*b11d(i+1) -
819 $ work(iu1sn+i-1)*b11e(i)
820 b11e(i) = temp
821 IF( i .LT. imax - 1 ) THEN
822 b11bulge = work(iu1sn+i-1)*b11e(i+1)
823 b11e(i+1) = work(iu1cs+i-1)*b11e(i+1)
824 END IF
825 temp = work(iu2cs+i-1)*b21e(i) + work(iu2sn+i-1)*b21d(i+1)
826 b21d(i+1) = work(iu2cs+i-1)*b21d(i+1) -
827 $ work(iu2sn+i-1)*b21e(i)
828 b21e(i) = temp
829 IF( i .LT. imax - 1 ) THEN
830 b21bulge = work(iu2sn+i-1)*b21e(i+1)
831 b21e(i+1) = work(iu2cs+i-1)*b21e(i+1)
832 END IF
833 temp = work(iu1cs+i-1)*b12d(i) + work(iu1sn+i-1)*b12e(i)
834 b12e(i) = work(iu1cs+i-1)*b12e(i) - work(iu1sn+i-1)*b12d(i)
835 b12d(i) = temp
836 b12bulge = work(iu1sn+i-1)*b12d(i+1)
837 b12d(i+1) = work(iu1cs+i-1)*b12d(i+1)
838 temp = work(iu2cs+i-1)*b22d(i) + work(iu2sn+i-1)*b22e(i)
839 b22e(i) = work(iu2cs+i-1)*b22e(i) - work(iu2sn+i-1)*b22d(i)
840 b22d(i) = temp
841 b22bulge = work(iu2sn+i-1)*b22d(i+1)
842 b22d(i+1) = work(iu2cs+i-1)*b22d(i+1)
843*
844 END DO
845*
846* Compute PHI(IMAX-1)
847*
848 x1 = sin(theta(imax-1))*b11e(imax-1) +
849 $ cos(theta(imax-1))*b21e(imax-1)
850 y1 = sin(theta(imax-1))*b12d(imax-1) +
851 $ cos(theta(imax-1))*b22d(imax-1)
852 y2 = sin(theta(imax-1))*b12bulge + cos(theta(imax-1))*b22bulge
853*
854 phi(imax-1) = atan2( abs(x1), sqrt(y1**2+y2**2) )
855*
856* Chase bulges from B12(IMAX-1,IMAX) and B22(IMAX-1,IMAX)
857*
858 restart12 = b12d(imax-1)**2 + b12bulge**2 .LE. thresh**2
859 restart22 = b22d(imax-1)**2 + b22bulge**2 .LE. thresh**2
860*
861 IF( .NOT. restart12 .AND. .NOT. restart22 ) THEN
862 CALL slartgp( y2, y1, work(iv2tsn+imax-1-1),
863 $ work(iv2tcs+imax-1-1), r )
864 ELSE IF( .NOT. restart12 .AND. restart22 ) THEN
865 CALL slartgp( b12bulge, b12d(imax-1), work(iv2tsn+imax-1-1),
866 $ work(iv2tcs+imax-1-1), r )
867 ELSE IF( restart12 .AND. .NOT. restart22 ) THEN
868 CALL slartgp( b22bulge, b22d(imax-1), work(iv2tsn+imax-1-1),
869 $ work(iv2tcs+imax-1-1), r )
870 ELSE IF( nu .LT. mu ) THEN
871 CALL slartgs( b12e(imax-1), b12d(imax), nu,
872 $ work(iv2tcs+imax-1-1), work(iv2tsn+imax-1-1) )
873 ELSE
874 CALL slartgs( b22e(imax-1), b22d(imax), mu,
875 $ work(iv2tcs+imax-1-1), work(iv2tsn+imax-1-1) )
876 END IF
877*
878 temp = work(iv2tcs+imax-1-1)*b12e(imax-1) +
879 $ work(iv2tsn+imax-1-1)*b12d(imax)
880 b12d(imax) = work(iv2tcs+imax-1-1)*b12d(imax) -
881 $ work(iv2tsn+imax-1-1)*b12e(imax-1)
882 b12e(imax-1) = temp
883 temp = work(iv2tcs+imax-1-1)*b22e(imax-1) +
884 $ work(iv2tsn+imax-1-1)*b22d(imax)
885 b22d(imax) = work(iv2tcs+imax-1-1)*b22d(imax) -
886 $ work(iv2tsn+imax-1-1)*b22e(imax-1)
887 b22e(imax-1) = temp
888*
889* Update singular vectors
890*
891 IF( wantu1 ) THEN
892 IF( colmajor ) THEN
893 CALL slasr( 'R', 'V', 'F', p, imax-imin+1,
894 $ work(iu1cs+imin-1), work(iu1sn+imin-1),
895 $ u1(1,imin), ldu1 )
896 ELSE
897 CALL slasr( 'L', 'V', 'F', imax-imin+1, p,
898 $ work(iu1cs+imin-1), work(iu1sn+imin-1),
899 $ u1(imin,1), ldu1 )
900 END IF
901 END IF
902 IF( wantu2 ) THEN
903 IF( colmajor ) THEN
904 CALL slasr( 'R', 'V', 'F', m-p, imax-imin+1,
905 $ work(iu2cs+imin-1), work(iu2sn+imin-1),
906 $ u2(1,imin), ldu2 )
907 ELSE
908 CALL slasr( 'L', 'V', 'F', imax-imin+1, m-p,
909 $ work(iu2cs+imin-1), work(iu2sn+imin-1),
910 $ u2(imin,1), ldu2 )
911 END IF
912 END IF
913 IF( wantv1t ) THEN
914 IF( colmajor ) THEN
915 CALL slasr( 'L', 'V', 'F', imax-imin+1, q,
916 $ work(iv1tcs+imin-1), work(iv1tsn+imin-1),
917 $ v1t(imin,1), ldv1t )
918 ELSE
919 CALL slasr( 'R', 'V', 'F', q, imax-imin+1,
920 $ work(iv1tcs+imin-1), work(iv1tsn+imin-1),
921 $ v1t(1,imin), ldv1t )
922 END IF
923 END IF
924 IF( wantv2t ) THEN
925 IF( colmajor ) THEN
926 CALL slasr( 'L', 'V', 'F', imax-imin+1, m-q,
927 $ work(iv2tcs+imin-1), work(iv2tsn+imin-1),
928 $ v2t(imin,1), ldv2t )
929 ELSE
930 CALL slasr( 'R', 'V', 'F', m-q, imax-imin+1,
931 $ work(iv2tcs+imin-1), work(iv2tsn+imin-1),
932 $ v2t(1,imin), ldv2t )
933 END IF
934 END IF
935*
936* Fix signs on B11(IMAX-1,IMAX) and B21(IMAX-1,IMAX)
937*
938 IF( b11e(imax-1)+b21e(imax-1) .GT. 0 ) THEN
939 b11d(imax) = -b11d(imax)
940 b21d(imax) = -b21d(imax)
941 IF( wantv1t ) THEN
942 IF( colmajor ) THEN
943 CALL sscal( q, negone, v1t(imax,1), ldv1t )
944 ELSE
945 CALL sscal( q, negone, v1t(1,imax), 1 )
946 END IF
947 END IF
948 END IF
949*
950* Compute THETA(IMAX)
951*
952 x1 = cos(phi(imax-1))*b11d(imax) +
953 $ sin(phi(imax-1))*b12e(imax-1)
954 y1 = cos(phi(imax-1))*b21d(imax) +
955 $ sin(phi(imax-1))*b22e(imax-1)
956*
957 theta(imax) = atan2( abs(y1), abs(x1) )
958*
959* Fix signs on B11(IMAX,IMAX), B12(IMAX,IMAX-1), B21(IMAX,IMAX),
960* and B22(IMAX,IMAX-1)
961*
962 IF( b11d(imax)+b12e(imax-1) .LT. 0 ) THEN
963 b12d(imax) = -b12d(imax)
964 IF( wantu1 ) THEN
965 IF( colmajor ) THEN
966 CALL sscal( p, negone, u1(1,imax), 1 )
967 ELSE
968 CALL sscal( p, negone, u1(imax,1), ldu1 )
969 END IF
970 END IF
971 END IF
972 IF( b21d(imax)+b22e(imax-1) .GT. 0 ) THEN
973 b22d(imax) = -b22d(imax)
974 IF( wantu2 ) THEN
975 IF( colmajor ) THEN
976 CALL sscal( m-p, negone, u2(1,imax), 1 )
977 ELSE
978 CALL sscal( m-p, negone, u2(imax,1), ldu2 )
979 END IF
980 END IF
981 END IF
982*
983* Fix signs on B12(IMAX,IMAX) and B22(IMAX,IMAX)
984*
985 IF( b12d(imax)+b22d(imax) .LT. 0 ) THEN
986 IF( wantv2t ) THEN
987 IF( colmajor ) THEN
988 CALL sscal( m-q, negone, v2t(imax,1), ldv2t )
989 ELSE
990 CALL sscal( m-q, negone, v2t(1,imax), 1 )
991 END IF
992 END IF
993 END IF
994*
995* Test for negligible sines or cosines
996*
997 DO i = imin, imax
998 IF( theta(i) .LT. thresh ) THEN
999 theta(i) = zero
1000 ELSE IF( theta(i) .GT. piover2-thresh ) THEN
1001 theta(i) = piover2
1002 END IF
1003 END DO
1004 DO i = imin, imax-1
1005 IF( phi(i) .LT. thresh ) THEN
1006 phi(i) = zero
1007 ELSE IF( phi(i) .GT. piover2-thresh ) THEN
1008 phi(i) = piover2
1009 END IF
1010 END DO
1011*
1012* Deflate
1013*
1014 IF (imax .GT. 1) THEN
1015 DO WHILE( phi(imax-1) .EQ. zero )
1016 imax = imax - 1
1017 IF (imax .LE. 1) EXIT
1018 END DO
1019 END IF
1020 IF( imin .GT. imax - 1 )
1021 $ imin = imax - 1
1022 IF (imin .GT. 1) THEN
1023 DO WHILE (phi(imin-1) .NE. zero)
1024 imin = imin - 1
1025 IF (imin .LE. 1) EXIT
1026 END DO
1027 END IF
1028*
1029* Repeat main iteration loop
1030*
1031 END DO
1032*
1033* Postprocessing: order THETA from least to greatest
1034*
1035 DO i = 1, q
1036*
1037 mini = i
1038 thetamin = theta(i)
1039 DO j = i+1, q
1040 IF( theta(j) .LT. thetamin ) THEN
1041 mini = j
1042 thetamin = theta(j)
1043 END IF
1044 END DO
1045*
1046 IF( mini .NE. i ) THEN
1047 theta(mini) = theta(i)
1048 theta(i) = thetamin
1049 IF( colmajor ) THEN
1050 IF( wantu1 )
1051 $ CALL sswap( p, u1(1,i), 1, u1(1,mini), 1 )
1052 IF( wantu2 )
1053 $ CALL sswap( m-p, u2(1,i), 1, u2(1,mini), 1 )
1054 IF( wantv1t )
1055 $ CALL sswap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t )
1056 IF( wantv2t )
1057 $ CALL sswap( m-q, v2t(i,1), ldv2t, v2t(mini,1),
1058 $ ldv2t )
1059 ELSE
1060 IF( wantu1 )
1061 $ CALL sswap( p, u1(i,1), ldu1, u1(mini,1), ldu1 )
1062 IF( wantu2 )
1063 $ CALL sswap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 )
1064 IF( wantv1t )
1065 $ CALL sswap( q, v1t(1,i), 1, v1t(1,mini), 1 )
1066 IF( wantv2t )
1067 $ CALL sswap( m-q, v2t(1,i), 1, v2t(1,mini), 1 )
1068 END IF
1069 END IF
1070*
1071 END DO
1072*
1073 RETURN
1074*
1075* End of SBBCSD
1076*
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
slasr
subroutine slasr(side, pivot, direct, m, n, c, s, a, lda)
SLASR applies a sequence of plane rotations to a general rectangular matrix.
Definition slasr.f:199
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
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79
sswap
subroutine sswap(n, sx, incx, sy, incy)
SSWAP
Definition sswap.f:82
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

◆ sgghd3()

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

SGGHD3

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

Purpose:
!>
!> SGGHD3 reduces a pair of real matrices (A,B) to generalized upper
!> Hessenberg form using orthogonal 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 orthogonal matrix Q to the left side
!> of the equation.
!>
!> This subroutine simultaneously reduces A to a Hessenberg matrix H:
!>    Q**T*A*Z = H
!> and transforms B to another upper triangular matrix T:
!>    Q**T*B*Z = T
!> in order to reduce the problem to its standard form
!>    H*y = lambda*T*y
!> where y = Z**T*x.
!>
!> The orthogonal 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**T = (Q1*Q) * H * (Z1*Z)**T
!>
!>      Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T
!>
!> If Q1 is the orthogonal matrix from the QR factorization of B in the
!> original equation A*x = lambda*B*x, then SGGHD3 reduces the original
!> problem to generalized Hessenberg form.
!>
!> This is a blocked variant of SGGHRD, 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
!>                 orthogonal matrix Q is returned;
!>          = 'V': Q must contain an orthogonal 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
!>                 orthogonal matrix Z is returned;
!>          = 'V': Z must contain an orthogonal 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 SGGBAL; 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 REAL 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 REAL array, dimension (LDB, N)
!>          On entry, the N-by-N upper triangular matrix B.
!>          On exit, the upper triangular matrix T = Q**T 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 REAL array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the orthogonal matrix Q1,
!>          typically from the QR factorization of B.
!>          On exit, if COMPQ='I', the orthogonal 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 REAL array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the orthogonal matrix Z1.
!>          On exit, if COMPZ='I', the orthogonal 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 REAL 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 228 of file sgghd3.f.

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

◆ sgghrd()

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

SGGHRD

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

Purpose:
!>
!> SGGHRD reduces a pair of real matrices (A,B) to generalized upper
!> Hessenberg form using orthogonal 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 orthogonal matrix Q to the left side
!> of the equation.
!>
!> This subroutine simultaneously reduces A to a Hessenberg matrix H:
!>    Q**T*A*Z = H
!> and transforms B to another upper triangular matrix T:
!>    Q**T*B*Z = T
!> in order to reduce the problem to its standard form
!>    H*y = lambda*T*y
!> where y = Z**T*x.
!>
!> The orthogonal 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**T = (Q1*Q) * H * (Z1*Z)**T
!>
!>      Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T
!>
!> If Q1 is the orthogonal matrix from the QR factorization of B in the
!> original equation A*x = lambda*B*x, then SGGHRD 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
!>                 orthogonal matrix Q is returned;
!>          = 'V': Q must contain an orthogonal 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
!>                 orthogonal matrix Z is returned;
!>          = 'V': Z must contain an orthogonal 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 SGGBAL; 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 REAL 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 REAL array, dimension (LDB, N)
!>          On entry, the N-by-N upper triangular matrix B.
!>          On exit, the upper triangular matrix T = Q**T 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 REAL array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the orthogonal matrix Q1,
!>          typically from the QR factorization of B.
!>          On exit, if COMPQ='I', the orthogonal 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 REAL array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the orthogonal matrix Z1.
!>          On exit, if COMPZ='I', the orthogonal 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 205 of file sgghrd.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 COMPQ, COMPZ
214 INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
215* ..
216* .. Array Arguments ..
217 REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
218 $ Z( LDZ, * )
219* ..
220*
221* =====================================================================
222*
223* .. Parameters ..
224 REAL ONE, ZERO
225 parameter( one = 1.0e+0, zero = 0.0e+0 )
226* ..
227* .. Local Scalars ..
228 LOGICAL ILQ, ILZ
229 INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
230 REAL C, S, TEMP
231* ..
232* .. External Functions ..
233 LOGICAL LSAME
234 EXTERNAL lsame
235* ..
236* .. External Subroutines ..
237 EXTERNAL slartg, slaset, srot, xerbla
238* ..
239* .. Intrinsic Functions ..
240 INTRINSIC max
241* ..
242* .. Executable Statements ..
243*
244* Decode COMPQ
245*
246 IF( lsame( compq, 'N' ) ) THEN
247 ilq = .false.
248 icompq = 1
249 ELSE IF( lsame( compq, 'V' ) ) THEN
250 ilq = .true.
251 icompq = 2
252 ELSE IF( lsame( compq, 'I' ) ) THEN
253 ilq = .true.
254 icompq = 3
255 ELSE
256 icompq = 0
257 END IF
258*
259* Decode COMPZ
260*
261 IF( lsame( compz, 'N' ) ) THEN
262 ilz = .false.
263 icompz = 1
264 ELSE IF( lsame( compz, 'V' ) ) THEN
265 ilz = .true.
266 icompz = 2
267 ELSE IF( lsame( compz, 'I' ) ) THEN
268 ilz = .true.
269 icompz = 3
270 ELSE
271 icompz = 0
272 END IF
273*
274* Test the input parameters.
275*
276 info = 0
277 IF( icompq.LE.0 ) THEN
278 info = -1
279 ELSE IF( icompz.LE.0 ) THEN
280 info = -2
281 ELSE IF( n.LT.0 ) THEN
282 info = -3
283 ELSE IF( ilo.LT.1 ) THEN
284 info = -4
285 ELSE IF( ihi.GT.n .OR. ihi.LT.ilo-1 ) THEN
286 info = -5
287 ELSE IF( lda.LT.max( 1, n ) ) THEN
288 info = -7
289 ELSE IF( ldb.LT.max( 1, n ) ) THEN
290 info = -9
291 ELSE IF( ( ilq .AND. ldq.LT.n ) .OR. ldq.LT.1 ) THEN
292 info = -11
293 ELSE IF( ( ilz .AND. ldz.LT.n ) .OR. ldz.LT.1 ) THEN
294 info = -13
295 END IF
296 IF( info.NE.0 ) THEN
297 CALL xerbla( 'SGGHRD', -info )
298 RETURN
299 END IF
300*
301* Initialize Q and Z if desired.
302*
303 IF( icompq.EQ.3 )
304 $ CALL slaset( 'Full', n, n, zero, one, q, ldq )
305 IF( icompz.EQ.3 )
306 $ CALL slaset( 'Full', n, n, zero, one, z, ldz )
307*
308* Quick return if possible
309*
310 IF( n.LE.1 )
311 $ RETURN
312*
313* Zero out lower triangle of B
314*
315 DO 20 jcol = 1, n - 1
316 DO 10 jrow = jcol + 1, n
317 b( jrow, jcol ) = zero
318 10 CONTINUE
319 20 CONTINUE
320*
321* Reduce A and B
322*
323 DO 40 jcol = ilo, ihi - 2
324*
325 DO 30 jrow = ihi, jcol + 2, -1
326*
327* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
328*
329 temp = a( jrow-1, jcol )
330 CALL slartg( temp, a( jrow, jcol ), c, s,
331 $ a( jrow-1, jcol ) )
332 a( jrow, jcol ) = zero
333 CALL srot( n-jcol, a( jrow-1, jcol+1 ), lda,
334 $ a( jrow, jcol+1 ), lda, c, s )
335 CALL srot( n+2-jrow, b( jrow-1, jrow-1 ), ldb,
336 $ b( jrow, jrow-1 ), ldb, c, s )
337 IF( ilq )
338 $ CALL srot( n, q( 1, jrow-1 ), 1, q( 1, jrow ), 1, c, s )
339*
340* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
341*
342 temp = b( jrow, jrow )
343 CALL slartg( temp, b( jrow, jrow-1 ), c, s,
344 $ b( jrow, jrow ) )
345 b( jrow, jrow-1 ) = zero
346 CALL srot( ihi, a( 1, jrow ), 1, a( 1, jrow-1 ), 1, c, s )
347 CALL srot( jrow-1, b( 1, jrow ), 1, b( 1, jrow-1 ), 1, c,
348 $ s )
349 IF( ilz )
350 $ CALL srot( 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 SGGHRD
357*

◆ sggqrf()

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

SGGQRF

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

Purpose:
!>
!> SGGQRF 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 orthogonal matrix, Z is a P-by-P orthogonal
!> 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**T*(inv(T)*R)
!>
!> where inv(B) denotes the inverse of the matrix B, and Z**T denotes the
!> transpose of the 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 REAL 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 orthogonal 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 REAL array, dimension (min(N,M))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix Q (see Further Details).
!>
[in,out]B
!>          B is REAL 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 orthogonal
!>          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 REAL array, dimension (min(N,P))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix Z (see Further Details).
!>
[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. 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 SORMQR.
!>
!>          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**T
!>
!>  where taua is a real scalar, and v is a real 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 SORGQR.
!>  To use Q to update another matrix, use LAPACK subroutine SORMQR.
!>
!>  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**T
!>
!>  where taub is a real scalar, and v is a real 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 SORGRQ.
!>  To use Z to update another matrix, use LAPACK subroutine SORMRQ.
!>

Definition at line 213 of file sggqrf.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 REAL 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 sgeqrf, sgerqf, sormqr, 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, 'SGEQRF', ' ', n, m, -1, -1 )
250 nb2 = ilaenv( 1, 'SGERQF', ' ', n, p, -1, -1 )
251 nb3 = ilaenv( 1, 'SORMQR', ' ', 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( 'SGGQRF', -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 sgeqrf( n, m, a, lda, taua, work, lwork, info )
279 lopt = work( 1 )
280*
281* Update B := Q**T*B.
282*
283 CALL sormqr( 'Left', 'Transpose', n, p, min( n, m ), a, lda, taua,
284 $ 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 sgerqf( n, p, b, ldb, taub, work, lwork, info )
290 work( 1 ) = max( lopt, int( work( 1 ) ) )
291*
292 RETURN
293*
294* End of SGGQRF
295*
sgeqrf
subroutine sgeqrf(m, n, a, lda, tau, work, lwork, info)
SGEQRF
Definition sgeqrf.f:146
sgerqf
subroutine sgerqf(m, n, a, lda, tau, work, lwork, info)
SGERQF
Definition sgerqf.f:139
sormqr
subroutine sormqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
SORMQR
Definition sormqr.f:168

◆ sggrqf()

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

SGGRQF

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

Purpose:
!>
!> SGGRQF 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 orthogonal matrix, Z is a P-by-P orthogonal
!> 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**T
!>
!> where inv(B) denotes the inverse of the matrix B, and Z**T denotes the
!> 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 REAL 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 orthogonal
!>          matrix Q as a product of elementary reflectors (see Further
!>          Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[out]TAUA
!>          TAUA is REAL array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix Q (see Further Details).
!>
[in,out]B
!>          B is REAL 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 orthogonal 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 REAL array, dimension (min(P,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix Z (see Further Details).
!>
[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. 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 SORMRQ.
!>
!>          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 INF0= -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**T
!>
!>  where taua is a real scalar, and v is a real 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 SORGRQ.
!>  To use Q to update another matrix, use LAPACK subroutine SORMRQ.
!>
!>  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**T
!>
!>  where taub is a real scalar, and v is a real 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 SORGQR.
!>  To use Z to update another matrix, use LAPACK subroutine SORMQR.
!>

Definition at line 212 of file sggrqf.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 REAL 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 sgeqrf, sgerqf, sormrq, 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, 'SGERQF', ' ', m, n, -1, -1 )
249 nb2 = ilaenv( 1, 'SGEQRF', ' ', p, n, -1, -1 )
250 nb3 = ilaenv( 1, 'SORMRQ', ' ', 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( 'SGGRQF', -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 sgerqf( m, n, a, lda, taua, work, lwork, info )
278 lopt = work( 1 )
279*
280* Update B := B*Q**T
281*
282 CALL sormrq( 'Right', '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 sgeqrf( p, n, b, ldb, taub, work, lwork, info )
290 work( 1 ) = max( lopt, int( work( 1 ) ) )
291*
292 RETURN
293*
294* End of SGGRQF
295*
sormrq
subroutine sormrq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
SORMRQ
Definition sormrq.f:168

◆ sggsvp()

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

SGGSVP

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine SGGSVP3.
!>
!> SGGSVP computes orthogonal matrices U, V and Q such that
!>
!>                    N-K-L  K    L
!>  U**T*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**T*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**T,B**T)**T.
!>
!> This decomposition is the preprocessing step for computing the
!> Generalized Singular Value Decomposition (GSVD), see subroutine
!> SGGSVD.
!>
Parameters
[in]JOBU
!>          JOBU is CHARACTER*1
!>          = 'U':  Orthogonal matrix U is computed;
!>          = 'N':  U is not computed.
!>
[in]JOBV
!>          JOBV is CHARACTER*1
!>          = 'V':  Orthogonal matrix V is computed;
!>          = 'N':  V is not computed.
!>
[in]JOBQ
!>          JOBQ is CHARACTER*1
!>          = 'Q':  Orthogonal 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 REAL 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 REAL 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**T,B**T)**T.
!>
[out]U
!>          U is REAL array, dimension (LDU,M)
!>          If JOBU = 'U', U contains the orthogonal 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 REAL array, dimension (LDV,P)
!>          If JOBV = 'V', V contains the orthogonal 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 REAL array, dimension (LDQ,N)
!>          If JOBQ = 'Q', Q contains the orthogonal 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]TAU
!>          TAU is REAL array, dimension (N)
!>
[out]WORK
!>          WORK is REAL 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 SGEQPF 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 253 of file sggsvp.f.

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

◆ sggsvp3()

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

SGGSVP3

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

Purpose:
!>
!> SGGSVP3 computes orthogonal matrices U, V and Q such that
!>
!>                    N-K-L  K    L
!>  U**T*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**T*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**T,B**T)**T.
!>
!> This decomposition is the preprocessing step for computing the
!> Generalized Singular Value Decomposition (GSVD), see subroutine
!> SGGSVD3.
!>
Parameters
[in]JOBU
!>          JOBU is CHARACTER*1
!>          = 'U':  Orthogonal matrix U is computed;
!>          = 'N':  U is not computed.
!>
[in]JOBV
!>          JOBV is CHARACTER*1
!>          = 'V':  Orthogonal matrix V is computed;
!>          = 'N':  V is not computed.
!>
[in]JOBQ
!>          JOBQ is CHARACTER*1
!>          = 'Q':  Orthogonal 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 REAL 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 REAL 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**T,B**T)**T.
!>
[out]U
!>          U is REAL array, dimension (LDU,M)
!>          If JOBU = 'U', U contains the orthogonal 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 REAL array, dimension (LDV,P)
!>          If JOBV = 'V', V contains the orthogonal 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 REAL array, dimension (LDQ,N)
!>          If JOBQ = 'Q', Q contains the orthogonal 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]TAU
!>          TAU is REAL array, dimension (N)
!>
[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 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 SGEQP3 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.
!>
!>  SGGSVP3 replaces the deprecated subroutine SGGSVP.
!>
!>

Definition at line 269 of file sggsvp3.f.

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

◆ sgsvj0()

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

SGSVJ0 pre-processor for the routine sgesvj.

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

Purpose:
!>
!> SGSVJ0 is called from SGESVJ as a pre-processor and that is its main
!> purpose. It applies Jacobi rotations in the same way as SGESVJ 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 REAL 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 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 REAL 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 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 REAL 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 REAL 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:
SGSVJ0 is used just to enable SGESVJ to call a simplified version of itself to work on a submatrix of the original matrix.
Contributors:
Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
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 sgsvj0.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 INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP
225 REAL EPS, SFMIN, TOL
226 CHARACTER*1 JOBV
227* ..
228* .. Array Arguments ..
229 REAL A( LDA, * ), SVA( N ), D( N ), V( LDV, * ),
230 $ WORK( LWORK )
231* ..
232*
233* =====================================================================
234*
235* .. Local Parameters ..
236 REAL ZERO, HALF, ONE
237 parameter( zero = 0.0e0, half = 0.5e0, one = 1.0e0)
238* ..
239* .. Local Scalars ..
240 REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
241 $ BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,
242 $ ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,
243 $ THSIGN
244 INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
245 $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,
246 $ NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND
247 LOGICAL APPLV, ROTOK, RSVEC
248* ..
249* .. Local Arrays ..
250 REAL FASTR( 5 )
251* ..
252* .. Intrinsic Functions ..
253 INTRINSIC abs, max, float, min, sign, sqrt
254* ..
255* .. External Functions ..
256 REAL SDOT, SNRM2
257 INTEGER ISAMAX
258 LOGICAL LSAME
259 EXTERNAL isamax, lsame, sdot, snrm2
260* ..
261* .. External Subroutines ..
262 EXTERNAL saxpy, scopy, slascl, slassq, srotm, sswap,
263 $ xerbla
264* ..
265* .. Executable Statements ..
266*
267* Test the input parameters.
268*
269 applv = lsame( jobv, 'A' )
270 rsvec = lsame( jobv, 'V' )
271 IF( .NOT.( rsvec .OR. applv .OR. lsame( jobv, 'N' ) ) ) THEN
272 info = -1
273 ELSE IF( m.LT.0 ) THEN
274 info = -2
275 ELSE IF( ( n.LT.0 ) .OR. ( n.GT.m ) ) THEN
276 info = -3
277 ELSE IF( lda.LT.m ) THEN
278 info = -5
279 ELSE IF( ( rsvec.OR.applv ) .AND. ( mv.LT.0 ) ) THEN
280 info = -8
281 ELSE IF( ( rsvec.AND.( ldv.LT.n ) ).OR.
282 $ ( applv.AND.( ldv.LT.mv ) ) ) THEN
283 info = -10
284 ELSE IF( tol.LE.eps ) THEN
285 info = -13
286 ELSE IF( nsweep.LT.0 ) THEN
287 info = -14
288 ELSE IF( lwork.LT.m ) THEN
289 info = -16
290 ELSE
291 info = 0
292 END IF
293*
294* #:(
295 IF( info.NE.0 ) THEN
296 CALL xerbla( 'SGSVJ0', -info )
297 RETURN
298 END IF
299*
300 IF( rsvec ) THEN
301 mvl = n
302 ELSE IF( applv ) THEN
303 mvl = mv
304 END IF
305 rsvec = rsvec .OR. applv
306
307 rooteps = sqrt( eps )
308 rootsfmin = sqrt( sfmin )
309 small = sfmin / eps
310 big = one / sfmin
311 rootbig = one / rootsfmin
312 bigtheta = one / rooteps
313 roottol = sqrt( tol )
314*
315* .. Row-cyclic Jacobi SVD algorithm with column pivoting ..
316*
317 emptsw = ( n*( n-1 ) ) / 2
318 notrot = 0
319 fastr( 1 ) = zero
320*
321* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
322*
323
324 swband = 0
325*[TP] SWBAND is a tuning parameter. It is meaningful and effective
326* if SGESVJ is used as a computational routine in the preconditioned
327* Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure
328* ......
329
330 kbl = min( 8, n )
331*[TP] KBL is a tuning parameter that defines the tile size in the
332* tiling of the p-q loops of pivot pairs. In general, an optimal
333* value of KBL depends on the matrix dimensions and on the
334* parameters of the computer's memory.
335*
336 nbl = n / kbl
337 IF( ( nbl*kbl ).NE.n )nbl = nbl + 1
338
339 blskip = ( kbl**2 ) + 1
340*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
341
342 rowskip = min( 5, kbl )
343*[TP] ROWSKIP is a tuning parameter.
344
345 lkahead = 1
346*[TP] LKAHEAD is a tuning parameter.
347 swband = 0
348 pskipped = 0
349*
350 DO 1993 i = 1, nsweep
351* .. go go go ...
352*
353 mxaapq = zero
354 mxsinj = zero
355 iswrot = 0
356*
357 notrot = 0
358 pskipped = 0
359*
360 DO 2000 ibr = 1, nbl
361
362 igl = ( ibr-1 )*kbl + 1
363*
364 DO 1002 ir1 = 0, min( lkahead, nbl-ibr )
365*
366 igl = igl + ir1*kbl
367*
368 DO 2001 p = igl, min( igl+kbl-1, n-1 )
369
370* .. de Rijk's pivoting
371 q = isamax( n-p+1, sva( p ), 1 ) + p - 1
372 IF( p.NE.q ) THEN
373 CALL sswap( m, a( 1, p ), 1, a( 1, q ), 1 )
374 IF( rsvec )CALL sswap( mvl, v( 1, p ), 1,
375 $ v( 1, q ), 1 )
376 temp1 = sva( p )
377 sva( p ) = sva( q )
378 sva( q ) = temp1
379 temp1 = d( p )
380 d( p ) = d( q )
381 d( q ) = temp1
382 END IF
383*
384 IF( ir1.EQ.0 ) THEN
385*
386* Column norms are periodically updated by explicit
387* norm computation.
388* Caveat:
389* Some BLAS implementations compute SNRM2(M,A(1,p),1)
390* as SQRT(SDOT(M,A(1,p),1,A(1,p),1)), which may result in
391* overflow for ||A(:,p)||_2 > SQRT(overflow_threshold), and
392* underflow for ||A(:,p)||_2 < SQRT(underflow_threshold).
393* Hence, SNRM2 cannot be trusted, not even in the case when
394* the true norm is far from the under(over)flow boundaries.
395* If properly implemented SNRM2 is available, the IF-THEN-ELSE
396* below should read "AAPP = SNRM2( M, A(1,p), 1 ) * D(p)".
397*
398 IF( ( sva( p ).LT.rootbig ) .AND.
399 $ ( sva( p ).GT.rootsfmin ) ) THEN
400 sva( p ) = snrm2( m, a( 1, p ), 1 )*d( p )
401 ELSE
402 temp1 = zero
403 aapp = one
404 CALL slassq( m, a( 1, p ), 1, temp1, aapp )
405 sva( p ) = temp1*sqrt( aapp )*d( p )
406 END IF
407 aapp = sva( p )
408 ELSE
409 aapp = sva( p )
410 END IF
411
412*
413 IF( aapp.GT.zero ) THEN
414*
415 pskipped = 0
416*
417 DO 2002 q = p + 1, min( igl+kbl-1, n )
418*
419 aaqq = sva( q )
420
421 IF( aaqq.GT.zero ) THEN
422*
423 aapp0 = aapp
424 IF( aaqq.GE.one ) THEN
425 rotok = ( small*aapp ).LE.aaqq
426 IF( aapp.LT.( big / aaqq ) ) THEN
427 aapq = ( sdot( m, a( 1, p ), 1, a( 1,
428 $ q ), 1 )*d( p )*d( q ) / aaqq )
429 $ / aapp
430 ELSE
431 CALL scopy( m, a( 1, p ), 1, work, 1 )
432 CALL slascl( 'G', 0, 0, aapp, d( p ),
433 $ m, 1, work, lda, ierr )
434 aapq = sdot( m, work, 1, a( 1, q ),
435 $ 1 )*d( q ) / aaqq
436 END IF
437 ELSE
438 rotok = aapp.LE.( aaqq / small )
439 IF( aapp.GT.( small / aaqq ) ) THEN
440 aapq = ( sdot( m, a( 1, p ), 1, a( 1,
441 $ q ), 1 )*d( p )*d( q ) / aaqq )
442 $ / aapp
443 ELSE
444 CALL scopy( m, a( 1, q ), 1, work, 1 )
445 CALL slascl( 'G', 0, 0, aaqq, d( q ),
446 $ m, 1, work, lda, ierr )
447 aapq = sdot( m, work, 1, a( 1, p ),
448 $ 1 )*d( p ) / aapp
449 END IF
450 END IF
451*
452 mxaapq = max( mxaapq, abs( aapq ) )
453*
454* TO rotate or NOT to rotate, THAT is the question ...
455*
456 IF( abs( aapq ).GT.tol ) THEN
457*
458* .. rotate
459* ROTATED = ROTATED + ONE
460*
461 IF( ir1.EQ.0 ) THEN
462 notrot = 0
463 pskipped = 0
464 iswrot = iswrot + 1
465 END IF
466*
467 IF( rotok ) THEN
468*
469 aqoap = aaqq / aapp
470 apoaq = aapp / aaqq
471 theta = -half*abs( aqoap-apoaq ) / aapq
472*
473 IF( abs( theta ).GT.bigtheta ) THEN
474*
475 t = half / theta
476 fastr( 3 ) = t*d( p ) / d( q )
477 fastr( 4 ) = -t*d( q ) / d( p )
478 CALL srotm( m, a( 1, p ), 1,
479 $ a( 1, q ), 1, fastr )
480 IF( rsvec )CALL srotm( mvl,
481 $ v( 1, p ), 1,
482 $ v( 1, q ), 1,
483 $ fastr )
484 sva( q ) = aaqq*sqrt( max( zero,
485 $ one+t*apoaq*aapq ) )
486 aapp = aapp*sqrt( max( zero,
487 $ one-t*aqoap*aapq ) )
488 mxsinj = max( mxsinj, abs( t ) )
489*
490 ELSE
491*
492* .. choose correct signum for THETA and rotate
493*
494 thsign = -sign( one, aapq )
495 t = one / ( theta+thsign*
496 $ sqrt( one+theta*theta ) )
497 cs = sqrt( one / ( one+t*t ) )
498 sn = t*cs
499*
500 mxsinj = max( mxsinj, abs( sn ) )
501 sva( q ) = aaqq*sqrt( max( zero,
502 $ one+t*apoaq*aapq ) )
503 aapp = aapp*sqrt( max( zero,
504 $ one-t*aqoap*aapq ) )
505*
506 apoaq = d( p ) / d( q )
507 aqoap = d( q ) / d( p )
508 IF( d( p ).GE.one ) THEN
509 IF( d( q ).GE.one ) THEN
510 fastr( 3 ) = t*apoaq
511 fastr( 4 ) = -t*aqoap
512 d( p ) = d( p )*cs
513 d( q ) = d( q )*cs
514 CALL srotm( m, a( 1, p ), 1,
515 $ a( 1, q ), 1,
516 $ fastr )
517 IF( rsvec )CALL srotm( mvl,
518 $ v( 1, p ), 1, v( 1, q ),
519 $ 1, fastr )
520 ELSE
521 CALL saxpy( m, -t*aqoap,
522 $ a( 1, q ), 1,
523 $ a( 1, p ), 1 )
524 CALL saxpy( m, cs*sn*apoaq,
525 $ a( 1, p ), 1,
526 $ a( 1, q ), 1 )
527 d( p ) = d( p )*cs
528 d( q ) = d( q ) / cs
529 IF( rsvec ) THEN
530 CALL saxpy( mvl, -t*aqoap,
531 $ v( 1, q ), 1,
532 $ v( 1, p ), 1 )
533 CALL saxpy( mvl,
534 $ cs*sn*apoaq,
535 $ v( 1, p ), 1,
536 $ v( 1, q ), 1 )
537 END IF
538 END IF
539 ELSE
540 IF( d( q ).GE.one ) THEN
541 CALL saxpy( m, t*apoaq,
542 $ a( 1, p ), 1,
543 $ a( 1, q ), 1 )
544 CALL saxpy( m, -cs*sn*aqoap,
545 $ a( 1, q ), 1,
546 $ a( 1, p ), 1 )
547 d( p ) = d( p ) / cs
548 d( q ) = d( q )*cs
549 IF( rsvec ) THEN
550 CALL saxpy( mvl, t*apoaq,
551 $ v( 1, p ), 1,
552 $ v( 1, q ), 1 )
553 CALL saxpy( mvl,
554 $ -cs*sn*aqoap,
555 $ v( 1, q ), 1,
556 $ v( 1, p ), 1 )
557 END IF
558 ELSE
559 IF( d( p ).GE.d( q ) ) THEN
560 CALL saxpy( m, -t*aqoap,
561 $ a( 1, q ), 1,
562 $ a( 1, p ), 1 )
563 CALL saxpy( m, cs*sn*apoaq,
564 $ a( 1, p ), 1,
565 $ a( 1, q ), 1 )
566 d( p ) = d( p )*cs
567 d( q ) = d( q ) / cs
568 IF( rsvec ) THEN
569 CALL saxpy( mvl,
570 $ -t*aqoap,
571 $ v( 1, q ), 1,
572 $ v( 1, p ), 1 )
573 CALL saxpy( mvl,
574 $ cs*sn*apoaq,
575 $ v( 1, p ), 1,
576 $ v( 1, q ), 1 )
577 END IF
578 ELSE
579 CALL saxpy( m, t*apoaq,
580 $ a( 1, p ), 1,
581 $ a( 1, q ), 1 )
582 CALL saxpy( m,
583 $ -cs*sn*aqoap,
584 $ a( 1, q ), 1,
585 $ a( 1, p ), 1 )
586 d( p ) = d( p ) / cs
587 d( q ) = d( q )*cs
588 IF( rsvec ) THEN
589 CALL saxpy( mvl,
590 $ t*apoaq, v( 1, p ),
591 $ 1, v( 1, q ), 1 )
592 CALL saxpy( mvl,
593 $ -cs*sn*aqoap,
594 $ v( 1, q ), 1,
595 $ v( 1, p ), 1 )
596 END IF
597 END IF
598 END IF
599 END IF
600 END IF
601*
602 ELSE
603* .. have to use modified Gram-Schmidt like transformation
604 CALL scopy( m, a( 1, p ), 1, work, 1 )
605 CALL slascl( 'G', 0, 0, aapp, one, m,
606 $ 1, work, lda, ierr )
607 CALL slascl( 'G', 0, 0, aaqq, one, m,
608 $ 1, a( 1, q ), lda, ierr )
609 temp1 = -aapq*d( p ) / d( q )
610 CALL saxpy( m, temp1, work, 1,
611 $ a( 1, q ), 1 )
612 CALL slascl( 'G', 0, 0, one, aaqq, m,
613 $ 1, a( 1, q ), lda, ierr )
614 sva( q ) = aaqq*sqrt( max( zero,
615 $ one-aapq*aapq ) )
616 mxsinj = max( mxsinj, sfmin )
617 END IF
618* END IF ROTOK THEN ... ELSE
619*
620* In the case of cancellation in updating SVA(q), SVA(p)
621* recompute SVA(q), SVA(p).
622 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
623 $ THEN
624 IF( ( aaqq.LT.rootbig ) .AND.
625 $ ( aaqq.GT.rootsfmin ) ) THEN
626 sva( q ) = snrm2( m, a( 1, q ), 1 )*
627 $ d( q )
628 ELSE
629 t = zero
630 aaqq = one
631 CALL slassq( m, a( 1, q ), 1, t,
632 $ aaqq )
633 sva( q ) = t*sqrt( aaqq )*d( q )
634 END IF
635 END IF
636 IF( ( aapp / aapp0 ).LE.rooteps ) THEN
637 IF( ( aapp.LT.rootbig ) .AND.
638 $ ( aapp.GT.rootsfmin ) ) THEN
639 aapp = snrm2( m, a( 1, p ), 1 )*
640 $ d( p )
641 ELSE
642 t = zero
643 aapp = one
644 CALL slassq( m, a( 1, p ), 1, t,
645 $ aapp )
646 aapp = t*sqrt( aapp )*d( p )
647 END IF
648 sva( p ) = aapp
649 END IF
650*
651 ELSE
652* A(:,p) and A(:,q) already numerically orthogonal
653 IF( ir1.EQ.0 )notrot = notrot + 1
654 pskipped = pskipped + 1
655 END IF
656 ELSE
657* A(:,q) is zero column
658 IF( ir1.EQ.0 )notrot = notrot + 1
659 pskipped = pskipped + 1
660 END IF
661*
662 IF( ( i.LE.swband ) .AND.
663 $ ( pskipped.GT.rowskip ) ) THEN
664 IF( ir1.EQ.0 )aapp = -aapp
665 notrot = 0
666 GO TO 2103
667 END IF
668*
669 2002 CONTINUE
670* END q-LOOP
671*
672 2103 CONTINUE
673* bailed out of q-loop
674
675 sva( p ) = aapp
676
677 ELSE
678 sva( p ) = aapp
679 IF( ( ir1.EQ.0 ) .AND. ( aapp.EQ.zero ) )
680 $ notrot = notrot + min( igl+kbl-1, n ) - p
681 END IF
682*
683 2001 CONTINUE
684* end of the p-loop
685* end of doing the block ( ibr, ibr )
686 1002 CONTINUE
687* end of ir1-loop
688*
689*........................................................
690* ... go to the off diagonal blocks
691*
692 igl = ( ibr-1 )*kbl + 1
693*
694 DO 2010 jbc = ibr + 1, nbl
695*
696 jgl = ( jbc-1 )*kbl + 1
697*
698* doing the block at ( ibr, jbc )
699*
700 ijblsk = 0
701 DO 2100 p = igl, min( igl+kbl-1, n )
702*
703 aapp = sva( p )
704*
705 IF( aapp.GT.zero ) THEN
706*
707 pskipped = 0
708*
709 DO 2200 q = jgl, min( jgl+kbl-1, n )
710*
711 aaqq = sva( q )
712*
713 IF( aaqq.GT.zero ) THEN
714 aapp0 = aapp
715*
716* .. M x 2 Jacobi SVD ..
717*
718* .. Safe Gram matrix computation ..
719*
720 IF( aaqq.GE.one ) THEN
721 IF( aapp.GE.aaqq ) THEN
722 rotok = ( small*aapp ).LE.aaqq
723 ELSE
724 rotok = ( small*aaqq ).LE.aapp
725 END IF
726 IF( aapp.LT.( big / aaqq ) ) THEN
727 aapq = ( sdot( m, a( 1, p ), 1, a( 1,
728 $ q ), 1 )*d( p )*d( q ) / aaqq )
729 $ / aapp
730 ELSE
731 CALL scopy( m, a( 1, p ), 1, work, 1 )
732 CALL slascl( 'G', 0, 0, aapp, d( p ),
733 $ m, 1, work, lda, ierr )
734 aapq = sdot( m, work, 1, a( 1, q ),
735 $ 1 )*d( q ) / aaqq
736 END IF
737 ELSE
738 IF( aapp.GE.aaqq ) THEN
739 rotok = aapp.LE.( aaqq / small )
740 ELSE
741 rotok = aaqq.LE.( aapp / small )
742 END IF
743 IF( aapp.GT.( small / aaqq ) ) THEN
744 aapq = ( sdot( m, a( 1, p ), 1, a( 1,
745 $ q ), 1 )*d( p )*d( q ) / aaqq )
746 $ / aapp
747 ELSE
748 CALL scopy( m, a( 1, q ), 1, work, 1 )
749 CALL slascl( 'G', 0, 0, aaqq, d( q ),
750 $ m, 1, work, lda, ierr )
751 aapq = sdot( m, work, 1, a( 1, p ),
752 $ 1 )*d( p ) / aapp
753 END IF
754 END IF
755*
756 mxaapq = max( mxaapq, abs( aapq ) )
757*
758* TO rotate or NOT to rotate, THAT is the question ...
759*
760 IF( abs( aapq ).GT.tol ) THEN
761 notrot = 0
762* ROTATED = ROTATED + 1
763 pskipped = 0
764 iswrot = iswrot + 1
765*
766 IF( rotok ) THEN
767*
768 aqoap = aaqq / aapp
769 apoaq = aapp / aaqq
770 theta = -half*abs( aqoap-apoaq ) / aapq
771 IF( aaqq.GT.aapp0 )theta = -theta
772*
773 IF( abs( theta ).GT.bigtheta ) THEN
774 t = half / theta
775 fastr( 3 ) = t*d( p ) / d( q )
776 fastr( 4 ) = -t*d( q ) / d( p )
777 CALL srotm( m, a( 1, p ), 1,
778 $ a( 1, q ), 1, fastr )
779 IF( rsvec )CALL srotm( mvl,
780 $ v( 1, p ), 1,
781 $ v( 1, q ), 1,
782 $ fastr )
783 sva( q ) = aaqq*sqrt( max( zero,
784 $ one+t*apoaq*aapq ) )
785 aapp = aapp*sqrt( max( zero,
786 $ one-t*aqoap*aapq ) )
787 mxsinj = max( mxsinj, abs( t ) )
788 ELSE
789*
790* .. choose correct signum for THETA and rotate
791*
792 thsign = -sign( one, aapq )
793 IF( aaqq.GT.aapp0 )thsign = -thsign
794 t = one / ( theta+thsign*
795 $ sqrt( one+theta*theta ) )
796 cs = sqrt( one / ( one+t*t ) )
797 sn = t*cs
798 mxsinj = max( mxsinj, abs( sn ) )
799 sva( q ) = aaqq*sqrt( max( zero,
800 $ one+t*apoaq*aapq ) )
801 aapp = aapp*sqrt( max( zero,
802 $ one-t*aqoap*aapq ) )
803*
804 apoaq = d( p ) / d( q )
805 aqoap = d( q ) / d( p )
806 IF( d( p ).GE.one ) THEN
807*
808 IF( d( q ).GE.one ) THEN
809 fastr( 3 ) = t*apoaq
810 fastr( 4 ) = -t*aqoap
811 d( p ) = d( p )*cs
812 d( q ) = d( q )*cs
813 CALL srotm( m, a( 1, p ), 1,
814 $ a( 1, q ), 1,
815 $ fastr )
816 IF( rsvec )CALL srotm( mvl,
817 $ v( 1, p ), 1, v( 1, q ),
818 $ 1, fastr )
819 ELSE
820 CALL saxpy( m, -t*aqoap,
821 $ a( 1, q ), 1,
822 $ a( 1, p ), 1 )
823 CALL saxpy( m, cs*sn*apoaq,
824 $ a( 1, p ), 1,
825 $ a( 1, q ), 1 )
826 IF( rsvec ) THEN
827 CALL saxpy( mvl, -t*aqoap,
828 $ v( 1, q ), 1,
829 $ v( 1, p ), 1 )
830 CALL saxpy( mvl,
831 $ cs*sn*apoaq,
832 $ v( 1, p ), 1,
833 $ v( 1, q ), 1 )
834 END IF
835 d( p ) = d( p )*cs
836 d( q ) = d( q ) / cs
837 END IF
838 ELSE
839 IF( d( q ).GE.one ) THEN
840 CALL saxpy( m, t*apoaq,
841 $ a( 1, p ), 1,
842 $ a( 1, q ), 1 )
843 CALL saxpy( m, -cs*sn*aqoap,
844 $ a( 1, q ), 1,
845 $ a( 1, p ), 1 )
846 IF( rsvec ) THEN
847 CALL saxpy( mvl, t*apoaq,
848 $ v( 1, p ), 1,
849 $ v( 1, q ), 1 )
850 CALL saxpy( mvl,
851 $ -cs*sn*aqoap,
852 $ v( 1, q ), 1,
853 $ v( 1, p ), 1 )
854 END IF
855 d( p ) = d( p ) / cs
856 d( q ) = d( q )*cs
857 ELSE
858 IF( d( p ).GE.d( q ) ) THEN
859 CALL saxpy( m, -t*aqoap,
860 $ a( 1, q ), 1,
861 $ a( 1, p ), 1 )
862 CALL saxpy( m, cs*sn*apoaq,
863 $ a( 1, p ), 1,
864 $ a( 1, q ), 1 )
865 d( p ) = d( p )*cs
866 d( q ) = d( q ) / cs
867 IF( rsvec ) THEN
868 CALL saxpy( mvl,
869 $ -t*aqoap,
870 $ v( 1, q ), 1,
871 $ v( 1, p ), 1 )
872 CALL saxpy( mvl,
873 $ cs*sn*apoaq,
874 $ v( 1, p ), 1,
875 $ v( 1, q ), 1 )
876 END IF
877 ELSE
878 CALL saxpy( m, t*apoaq,
879 $ a( 1, p ), 1,
880 $ a( 1, q ), 1 )
881 CALL saxpy( m,
882 $ -cs*sn*aqoap,
883 $ a( 1, q ), 1,
884 $ a( 1, p ), 1 )
885 d( p ) = d( p ) / cs
886 d( q ) = d( q )*cs
887 IF( rsvec ) THEN
888 CALL saxpy( mvl,
889 $ t*apoaq, v( 1, p ),
890 $ 1, v( 1, q ), 1 )
891 CALL saxpy( mvl,
892 $ -cs*sn*aqoap,
893 $ v( 1, q ), 1,
894 $ v( 1, p ), 1 )
895 END IF
896 END IF
897 END IF
898 END IF
899 END IF
900*
901 ELSE
902 IF( aapp.GT.aaqq ) THEN
903 CALL scopy( m, a( 1, p ), 1, work,
904 $ 1 )
905 CALL slascl( 'G', 0, 0, aapp, one,
906 $ m, 1, work, lda, ierr )
907 CALL slascl( 'G', 0, 0, aaqq, one,
908 $ m, 1, a( 1, q ), lda,
909 $ ierr )
910 temp1 = -aapq*d( p ) / d( q )
911 CALL saxpy( m, temp1, work, 1,
912 $ a( 1, q ), 1 )
913 CALL slascl( 'G', 0, 0, one, aaqq,
914 $ m, 1, a( 1, q ), lda,
915 $ ierr )
916 sva( q ) = aaqq*sqrt( max( zero,
917 $ one-aapq*aapq ) )
918 mxsinj = max( mxsinj, sfmin )
919 ELSE
920 CALL scopy( m, a( 1, q ), 1, work,
921 $ 1 )
922 CALL slascl( 'G', 0, 0, aaqq, one,
923 $ m, 1, work, lda, ierr )
924 CALL slascl( 'G', 0, 0, aapp, one,
925 $ m, 1, a( 1, p ), lda,
926 $ ierr )
927 temp1 = -aapq*d( q ) / d( p )
928 CALL saxpy( m, temp1, work, 1,
929 $ a( 1, p ), 1 )
930 CALL slascl( 'G', 0, 0, one, aapp,
931 $ m, 1, a( 1, p ), lda,
932 $ ierr )
933 sva( p ) = aapp*sqrt( max( zero,
934 $ one-aapq*aapq ) )
935 mxsinj = max( mxsinj, sfmin )
936 END IF
937 END IF
938* END IF ROTOK THEN ... ELSE
939*
940* In the case of cancellation in updating SVA(q)
941* .. recompute SVA(q)
942 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
943 $ THEN
944 IF( ( aaqq.LT.rootbig ) .AND.
945 $ ( aaqq.GT.rootsfmin ) ) THEN
946 sva( q ) = snrm2( m, a( 1, q ), 1 )*
947 $ d( q )
948 ELSE
949 t = zero
950 aaqq = one
951 CALL slassq( m, a( 1, q ), 1, t,
952 $ aaqq )
953 sva( q ) = t*sqrt( aaqq )*d( q )
954 END IF
955 END IF
956 IF( ( aapp / aapp0 )**2.LE.rooteps ) THEN
957 IF( ( aapp.LT.rootbig ) .AND.
958 $ ( aapp.GT.rootsfmin ) ) THEN
959 aapp = snrm2( m, a( 1, p ), 1 )*
960 $ d( p )
961 ELSE
962 t = zero
963 aapp = one
964 CALL slassq( m, a( 1, p ), 1, t,
965 $ aapp )
966 aapp = t*sqrt( aapp )*d( p )
967 END IF
968 sva( p ) = aapp
969 END IF
970* end of OK rotation
971 ELSE
972 notrot = notrot + 1
973 pskipped = pskipped + 1
974 ijblsk = ijblsk + 1
975 END IF
976 ELSE
977 notrot = notrot + 1
978 pskipped = pskipped + 1
979 ijblsk = ijblsk + 1
980 END IF
981*
982 IF( ( i.LE.swband ) .AND. ( ijblsk.GE.blskip ) )
983 $ THEN
984 sva( p ) = aapp
985 notrot = 0
986 GO TO 2011
987 END IF
988 IF( ( i.LE.swband ) .AND.
989 $ ( pskipped.GT.rowskip ) ) THEN
990 aapp = -aapp
991 notrot = 0
992 GO TO 2203
993 END IF
994*
995 2200 CONTINUE
996* end of the q-loop
997 2203 CONTINUE
998*
999 sva( p ) = aapp
1000*
1001 ELSE
1002 IF( aapp.EQ.zero )notrot = notrot +
1003 $ min( jgl+kbl-1, n ) - jgl + 1
1004 IF( aapp.LT.zero )notrot = 0
1005 END IF
1006
1007 2100 CONTINUE
1008* end of the p-loop
1009 2010 CONTINUE
1010* end of the jbc-loop
1011 2011 CONTINUE
1012*2011 bailed out of the jbc-loop
1013 DO 2012 p = igl, min( igl+kbl-1, n )
1014 sva( p ) = abs( sva( p ) )
1015 2012 CONTINUE
1016*
1017 2000 CONTINUE
1018*2000 :: end of the ibr-loop
1019*
1020* .. update SVA(N)
1021 IF( ( sva( n ).LT.rootbig ) .AND. ( sva( n ).GT.rootsfmin ) )
1022 $ THEN
1023 sva( n ) = snrm2( m, a( 1, n ), 1 )*d( n )
1024 ELSE
1025 t = zero
1026 aapp = one
1027 CALL slassq( m, a( 1, n ), 1, t, aapp )
1028 sva( n ) = t*sqrt( aapp )*d( n )
1029 END IF
1030*
1031* Additional steering devices
1032*
1033 IF( ( i.LT.swband ) .AND. ( ( mxaapq.LE.roottol ) .OR.
1034 $ ( iswrot.LE.n ) ) )swband = i
1035*
1036 IF( ( i.GT.swband+1 ) .AND. ( mxaapq.LT.float( n )*tol ) .AND.
1037 $ ( float( n )*mxaapq*mxsinj.LT.tol ) ) THEN
1038 GO TO 1994
1039 END IF
1040*
1041 IF( notrot.GE.emptsw )GO TO 1994
1042
1043 1993 CONTINUE
1044* end i=1:NSWEEP loop
1045* #:) Reaching this point means that the procedure has completed the given
1046* number of iterations.
1047 info = nsweep - 1
1048 GO TO 1995
1049 1994 CONTINUE
1050* #:) Reaching this point means that during the i-th sweep all pivots were
1051* below the given tolerance, causing early exit.
1052*
1053 info = 0
1054* #:) INFO = 0 confirms successful iterations.
1055 1995 CONTINUE
1056*
1057* Sort the vector D.
1058 DO 5991 p = 1, n - 1
1059 q = isamax( n-p+1, sva( p ), 1 ) + p - 1
1060 IF( p.NE.q ) THEN
1061 temp1 = sva( p )
1062 sva( p ) = sva( q )
1063 sva( q ) = temp1
1064 temp1 = d( p )
1065 d( p ) = d( q )
1066 d( q ) = temp1
1067 CALL sswap( m, a( 1, p ), 1, a( 1, q ), 1 )
1068 IF( rsvec )CALL sswap( mvl, v( 1, p ), 1, v( 1, q ), 1 )
1069 END IF
1070 5991 CONTINUE
1071*
1072 RETURN
1073* ..
1074* .. END OF SGSVJ0
1075* ..
slassq
subroutine slassq(n, x, incx, scl, sumsq)
SLASSQ updates a sum of squares represented in scaled form.
Definition slassq.f90:137
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
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
srotm
subroutine srotm(n, sx, incx, sy, incy, sparam)
SROTM
Definition srotm.f:97
sdot
real function sdot(n, sx, incx, sy, incy)
SDOT
Definition sdot.f:82
saxpy
subroutine saxpy(n, sa, sx, incx, sy, incy)
SAXPY
Definition saxpy.f:89
snrm2
real(wp) function snrm2(n, x, incx)
SNRM2
Definition snrm2.f90:89

◆ sgsvj1()

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

SGSVJ1 pre-processor for the routine sgesvj, applies Jacobi rotations targeting only particular pivots.

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

Purpose:
!>
!> SGSVJ1 is called from SGESVJ as a pre-processor and that is its main
!> purpose. It applies Jacobi rotations in the same way as SGESVJ 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
!> ~~~~~~~~~~~~~~~
!> SGSVJ1 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 REAL 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 REAL 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 REAL 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 REAL 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.
Contributors:
Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)

Definition at line 234 of file sgsvj1.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 REAL A( LDA, * ), D( N ), SVA( N ), V( LDV, * ),
248 $ WORK( LWORK )
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 REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
259 $ BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,
260 $ ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,
261 $ TEMP1, THETA, THSIGN
262 INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,
263 $ ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr,
264 $ p, PSKIPPED, q, ROWSKIP, SWBAND
265 LOGICAL APPLV, ROTOK, RSVEC
266* ..
267* .. Local Arrays ..
268 REAL FASTR( 5 )
269* ..
270* .. Intrinsic Functions ..
271 INTRINSIC abs, max, float, min, sign, sqrt
272* ..
273* .. External Functions ..
274 REAL SDOT, SNRM2
275 INTEGER ISAMAX
276 LOGICAL LSAME
277 EXTERNAL isamax, lsame, sdot, snrm2
278* ..
279* .. External Subroutines ..
280 EXTERNAL saxpy, scopy, slascl, slassq, srotm, sswap,
281 $ xerbla
282* ..
283* .. Executable Statements ..
284*
285* Test the input parameters.
286*
287 applv = lsame( jobv, 'A' )
288 rsvec = lsame( jobv, 'V' )
289 IF( .NOT.( rsvec .OR. applv .OR. lsame( jobv, 'N' ) ) ) THEN
290 info = -1
291 ELSE IF( m.LT.0 ) THEN
292 info = -2
293 ELSE IF( ( n.LT.0 ) .OR. ( n.GT.m ) ) THEN
294 info = -3
295 ELSE IF( n1.LT.0 ) THEN
296 info = -4
297 ELSE IF( lda.LT.m ) THEN
298 info = -6
299 ELSE IF( ( rsvec.OR.applv ) .AND. ( mv.LT.0 ) ) THEN
300 info = -9
301 ELSE IF( ( rsvec.AND.( ldv.LT.n ) ).OR.
302 $ ( applv.AND.( ldv.LT.mv ) ) ) THEN
303 info = -11
304 ELSE IF( tol.LE.eps ) THEN
305 info = -14
306 ELSE IF( nsweep.LT.0 ) THEN
307 info = -15
308 ELSE IF( lwork.LT.m ) THEN
309 info = -17
310 ELSE
311 info = 0
312 END IF
313*
314* #:(
315 IF( info.NE.0 ) THEN
316 CALL xerbla( 'SGSVJ1', -info )
317 RETURN
318 END IF
319*
320 IF( rsvec ) THEN
321 mvl = n
322 ELSE IF( applv ) THEN
323 mvl = mv
324 END IF
325 rsvec = rsvec .OR. applv
326
327 rooteps = sqrt( eps )
328 rootsfmin = sqrt( sfmin )
329 small = sfmin / eps
330 big = one / sfmin
331 rootbig = one / rootsfmin
332 large = big / sqrt( float( m*n ) )
333 bigtheta = one / rooteps
334 roottol = sqrt( tol )
335*
336* .. Initialize the right singular vector matrix ..
337*
338* RSVEC = LSAME( JOBV, 'Y' )
339*
340 emptsw = n1*( n-n1 )
341 notrot = 0
342 fastr( 1 ) = zero
343*
344* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
345*
346 kbl = min( 8, n )
347 nblr = n1 / kbl
348 IF( ( nblr*kbl ).NE.n1 )nblr = nblr + 1
349
350* .. the tiling is nblr-by-nblc [tiles]
351
352 nblc = ( n-n1 ) / kbl
353 IF( ( nblc*kbl ).NE.( n-n1 ) )nblc = nblc + 1
354 blskip = ( kbl**2 ) + 1
355*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
356
357 rowskip = min( 5, kbl )
358*[TP] ROWSKIP is a tuning parameter.
359 swband = 0
360*[TP] SWBAND is a tuning parameter. It is meaningful and effective
361* if SGESVJ is used as a computational routine in the preconditioned
362* Jacobi SVD algorithm SGESVJ.
363*
364*
365* | * * * [x] [x] [x]|
366* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks.
367* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block.
368* |[x] [x] [x] * * * |
369* |[x] [x] [x] * * * |
370* |[x] [x] [x] * * * |
371*
372*
373 DO 1993 i = 1, nsweep
374* .. go go go ...
375*
376 mxaapq = zero
377 mxsinj = zero
378 iswrot = 0
379*
380 notrot = 0
381 pskipped = 0
382*
383 DO 2000 ibr = 1, nblr
384
385 igl = ( ibr-1 )*kbl + 1
386*
387*
388*........................................................
389* ... go to the off diagonal blocks
390
391 igl = ( ibr-1 )*kbl + 1
392
393 DO 2010 jbc = 1, nblc
394
395 jgl = n1 + ( jbc-1 )*kbl + 1
396
397* doing the block at ( ibr, jbc )
398
399 ijblsk = 0
400 DO 2100 p = igl, min( igl+kbl-1, n1 )
401
402 aapp = sva( p )
403
404 IF( aapp.GT.zero ) THEN
405
406 pskipped = 0
407
408 DO 2200 q = jgl, min( jgl+kbl-1, n )
409*
410 aaqq = sva( q )
411
412 IF( aaqq.GT.zero ) THEN
413 aapp0 = aapp
414*
415* .. M x 2 Jacobi SVD ..
416*
417* .. Safe Gram matrix computation ..
418*
419 IF( aaqq.GE.one ) THEN
420 IF( aapp.GE.aaqq ) THEN
421 rotok = ( small*aapp ).LE.aaqq
422 ELSE
423 rotok = ( small*aaqq ).LE.aapp
424 END IF
425 IF( aapp.LT.( big / aaqq ) ) THEN
426 aapq = ( sdot( m, a( 1, p ), 1, a( 1,
427 $ q ), 1 )*d( p )*d( q ) / aaqq )
428 $ / aapp
429 ELSE
430 CALL scopy( m, a( 1, p ), 1, work, 1 )
431 CALL slascl( 'G', 0, 0, aapp, d( p ),
432 $ m, 1, work, lda, ierr )
433 aapq = sdot( m, work, 1, a( 1, q ),
434 $ 1 )*d( q ) / aaqq
435 END IF
436 ELSE
437 IF( aapp.GE.aaqq ) THEN
438 rotok = aapp.LE.( aaqq / small )
439 ELSE
440 rotok = aaqq.LE.( aapp / small )
441 END IF
442 IF( aapp.GT.( small / aaqq ) ) THEN
443 aapq = ( sdot( m, a( 1, p ), 1, a( 1,
444 $ q ), 1 )*d( p )*d( q ) / aaqq )
445 $ / aapp
446 ELSE
447 CALL scopy( m, a( 1, q ), 1, work, 1 )
448 CALL slascl( 'G', 0, 0, aaqq, d( q ),
449 $ m, 1, work, lda, ierr )
450 aapq = sdot( m, work, 1, a( 1, p ),
451 $ 1 )*d( p ) / aapp
452 END IF
453 END IF
454
455 mxaapq = max( mxaapq, abs( aapq ) )
456
457* TO rotate or NOT to rotate, THAT is the question ...
458*
459 IF( abs( aapq ).GT.tol ) THEN
460 notrot = 0
461* ROTATED = ROTATED + 1
462 pskipped = 0
463 iswrot = iswrot + 1
464*
465 IF( rotok ) THEN
466*
467 aqoap = aaqq / aapp
468 apoaq = aapp / aaqq
469 theta = -half*abs( aqoap-apoaq ) / aapq
470 IF( aaqq.GT.aapp0 )theta = -theta
471
472 IF( abs( theta ).GT.bigtheta ) THEN
473 t = half / theta
474 fastr( 3 ) = t*d( p ) / d( q )
475 fastr( 4 ) = -t*d( q ) / d( p )
476 CALL srotm( m, a( 1, p ), 1,
477 $ a( 1, q ), 1, fastr )
478 IF( rsvec )CALL srotm( mvl,
479 $ v( 1, p ), 1,
480 $ v( 1, q ), 1,
481 $ fastr )
482 sva( q ) = aaqq*sqrt( max( zero,
483 $ one+t*apoaq*aapq ) )
484 aapp = aapp*sqrt( max( zero,
485 $ one-t*aqoap*aapq ) )
486 mxsinj = max( mxsinj, abs( t ) )
487 ELSE
488*
489* .. choose correct signum for THETA and rotate
490*
491 thsign = -sign( one, aapq )
492 IF( aaqq.GT.aapp0 )thsign = -thsign
493 t = one / ( theta+thsign*
494 $ sqrt( one+theta*theta ) )
495 cs = sqrt( one / ( one+t*t ) )
496 sn = t*cs
497 mxsinj = max( mxsinj, abs( sn ) )
498 sva( q ) = aaqq*sqrt( max( zero,
499 $ one+t*apoaq*aapq ) )
500 aapp = aapp*sqrt( max( zero,
501 $ one-t*aqoap*aapq ) )
502
503 apoaq = d( p ) / d( q )
504 aqoap = d( q ) / d( p )
505 IF( d( p ).GE.one ) THEN
506*
507 IF( d( q ).GE.one ) THEN
508 fastr( 3 ) = t*apoaq
509 fastr( 4 ) = -t*aqoap
510 d( p ) = d( p )*cs
511 d( q ) = d( q )*cs
512 CALL srotm( m, a( 1, p ), 1,
513 $ a( 1, q ), 1,
514 $ fastr )
515 IF( rsvec )CALL srotm( mvl,
516 $ v( 1, p ), 1, v( 1, q ),
517 $ 1, fastr )
518 ELSE
519 CALL saxpy( m, -t*aqoap,
520 $ a( 1, q ), 1,
521 $ a( 1, p ), 1 )
522 CALL saxpy( m, cs*sn*apoaq,
523 $ a( 1, p ), 1,
524 $ a( 1, q ), 1 )
525 IF( rsvec ) THEN
526 CALL saxpy( mvl, -t*aqoap,
527 $ v( 1, q ), 1,
528 $ v( 1, p ), 1 )
529 CALL saxpy( mvl,
530 $ cs*sn*apoaq,
531 $ v( 1, p ), 1,
532 $ v( 1, q ), 1 )
533 END IF
534 d( p ) = d( p )*cs
535 d( q ) = d( q ) / cs
536 END IF
537 ELSE
538 IF( d( q ).GE.one ) THEN
539 CALL saxpy( m, t*apoaq,
540 $ a( 1, p ), 1,
541 $ a( 1, q ), 1 )
542 CALL saxpy( m, -cs*sn*aqoap,
543 $ a( 1, q ), 1,
544 $ a( 1, p ), 1 )
545 IF( rsvec ) THEN
546 CALL saxpy( mvl, t*apoaq,
547 $ v( 1, p ), 1,
548 $ v( 1, q ), 1 )
549 CALL saxpy( mvl,
550 $ -cs*sn*aqoap,
551 $ v( 1, q ), 1,
552 $ v( 1, p ), 1 )
553 END IF
554 d( p ) = d( p ) / cs
555 d( q ) = d( q )*cs
556 ELSE
557 IF( d( p ).GE.d( q ) ) THEN
558 CALL saxpy( m, -t*aqoap,
559 $ a( 1, q ), 1,
560 $ a( 1, p ), 1 )
561 CALL saxpy( m, cs*sn*apoaq,
562 $ a( 1, p ), 1,
563 $ a( 1, q ), 1 )
564 d( p ) = d( p )*cs
565 d( q ) = d( q ) / cs
566 IF( rsvec ) THEN
567 CALL saxpy( mvl,
568 $ -t*aqoap,
569 $ v( 1, q ), 1,
570 $ v( 1, p ), 1 )
571 CALL saxpy( mvl,
572 $ cs*sn*apoaq,
573 $ v( 1, p ), 1,
574 $ v( 1, q ), 1 )
575 END IF
576 ELSE
577 CALL saxpy( m, t*apoaq,
578 $ a( 1, p ), 1,
579 $ a( 1, q ), 1 )
580 CALL saxpy( m,
581 $ -cs*sn*aqoap,
582 $ a( 1, q ), 1,
583 $ a( 1, p ), 1 )
584 d( p ) = d( p ) / cs
585 d( q ) = d( q )*cs
586 IF( rsvec ) THEN
587 CALL saxpy( mvl,
588 $ t*apoaq, v( 1, p ),
589 $ 1, v( 1, q ), 1 )
590 CALL saxpy( mvl,
591 $ -cs*sn*aqoap,
592 $ v( 1, q ), 1,
593 $ v( 1, p ), 1 )
594 END IF
595 END IF
596 END IF
597 END IF
598 END IF
599
600 ELSE
601 IF( aapp.GT.aaqq ) THEN
602 CALL scopy( m, a( 1, p ), 1, work,
603 $ 1 )
604 CALL slascl( 'G', 0, 0, aapp, one,
605 $ m, 1, work, lda, ierr )
606 CALL slascl( 'G', 0, 0, aaqq, one,
607 $ m, 1, a( 1, q ), lda,
608 $ ierr )
609 temp1 = -aapq*d( p ) / d( q )
610 CALL saxpy( m, temp1, work, 1,
611 $ a( 1, q ), 1 )
612 CALL slascl( 'G', 0, 0, one, aaqq,
613 $ m, 1, a( 1, q ), lda,
614 $ ierr )
615 sva( q ) = aaqq*sqrt( max( zero,
616 $ one-aapq*aapq ) )
617 mxsinj = max( mxsinj, sfmin )
618 ELSE
619 CALL scopy( m, a( 1, q ), 1, work,
620 $ 1 )
621 CALL slascl( 'G', 0, 0, aaqq, one,
622 $ m, 1, work, lda, ierr )
623 CALL slascl( 'G', 0, 0, aapp, one,
624 $ m, 1, a( 1, p ), lda,
625 $ ierr )
626 temp1 = -aapq*d( q ) / d( p )
627 CALL saxpy( m, temp1, work, 1,
628 $ a( 1, p ), 1 )
629 CALL slascl( 'G', 0, 0, one, aapp,
630 $ m, 1, a( 1, p ), lda,
631 $ ierr )
632 sva( p ) = aapp*sqrt( max( zero,
633 $ one-aapq*aapq ) )
634 mxsinj = max( mxsinj, sfmin )
635 END IF
636 END IF
637* END IF ROTOK THEN ... ELSE
638*
639* In the case of cancellation in updating SVA(q)
640* .. recompute SVA(q)
641 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
642 $ THEN
643 IF( ( aaqq.LT.rootbig ) .AND.
644 $ ( aaqq.GT.rootsfmin ) ) THEN
645 sva( q ) = snrm2( m, a( 1, q ), 1 )*
646 $ d( q )
647 ELSE
648 t = zero
649 aaqq = one
650 CALL slassq( m, a( 1, q ), 1, t,
651 $ aaqq )
652 sva( q ) = t*sqrt( aaqq )*d( q )
653 END IF
654 END IF
655 IF( ( aapp / aapp0 )**2.LE.rooteps ) THEN
656 IF( ( aapp.LT.rootbig ) .AND.
657 $ ( aapp.GT.rootsfmin ) ) THEN
658 aapp = snrm2( m, a( 1, p ), 1 )*
659 $ d( p )
660 ELSE
661 t = zero
662 aapp = one
663 CALL slassq( m, a( 1, p ), 1, t,
664 $ aapp )
665 aapp = t*sqrt( aapp )*d( p )
666 END IF
667 sva( p ) = aapp
668 END IF
669* end of OK rotation
670 ELSE
671 notrot = notrot + 1
672* SKIPPED = SKIPPED + 1
673 pskipped = pskipped + 1
674 ijblsk = ijblsk + 1
675 END IF
676 ELSE
677 notrot = notrot + 1
678 pskipped = pskipped + 1
679 ijblsk = ijblsk + 1
680 END IF
681
682* IF ( NOTROT .GE. EMPTSW ) GO TO 2011
683 IF( ( i.LE.swband ) .AND. ( ijblsk.GE.blskip ) )
684 $ THEN
685 sva( p ) = aapp
686 notrot = 0
687 GO TO 2011
688 END IF
689 IF( ( i.LE.swband ) .AND.
690 $ ( pskipped.GT.rowskip ) ) THEN
691 aapp = -aapp
692 notrot = 0
693 GO TO 2203
694 END IF
695
696*
697 2200 CONTINUE
698* end of the q-loop
699 2203 CONTINUE
700
701 sva( p ) = aapp
702*
703 ELSE
704 IF( aapp.EQ.zero )notrot = notrot +
705 $ min( jgl+kbl-1, n ) - jgl + 1
706 IF( aapp.LT.zero )notrot = 0
707*** IF ( NOTROT .GE. EMPTSW ) GO TO 2011
708 END IF
709
710 2100 CONTINUE
711* end of the p-loop
712 2010 CONTINUE
713* end of the jbc-loop
714 2011 CONTINUE
715*2011 bailed out of the jbc-loop
716 DO 2012 p = igl, min( igl+kbl-1, n )
717 sva( p ) = abs( sva( p ) )
718 2012 CONTINUE
719*** IF ( NOTROT .GE. EMPTSW ) GO TO 1994
720 2000 CONTINUE
721*2000 :: end of the ibr-loop
722*
723* .. update SVA(N)
724 IF( ( sva( n ).LT.rootbig ) .AND. ( sva( n ).GT.rootsfmin ) )
725 $ THEN
726 sva( n ) = snrm2( m, a( 1, n ), 1 )*d( n )
727 ELSE
728 t = zero
729 aapp = one
730 CALL slassq( m, a( 1, n ), 1, t, aapp )
731 sva( n ) = t*sqrt( aapp )*d( n )
732 END IF
733*
734* Additional steering devices
735*
736 IF( ( i.LT.swband ) .AND. ( ( mxaapq.LE.roottol ) .OR.
737 $ ( iswrot.LE.n ) ) )swband = i
738
739 IF( ( i.GT.swband+1 ) .AND. ( mxaapq.LT.float( n )*tol ) .AND.
740 $ ( float( n )*mxaapq*mxsinj.LT.tol ) ) THEN
741 GO TO 1994
742 END IF
743
744*
745 IF( notrot.GE.emptsw )GO TO 1994
746
747 1993 CONTINUE
748* end i=1:NSWEEP loop
749* #:) Reaching this point means that the procedure has completed the given
750* number of sweeps.
751 info = nsweep - 1
752 GO TO 1995
753 1994 CONTINUE
754* #:) Reaching this point means that during the i-th sweep all pivots were
755* below the given threshold, causing early exit.
756
757 info = 0
758* #:) INFO = 0 confirms successful iterations.
759 1995 CONTINUE
760*
761* Sort the vector D
762*
763 DO 5991 p = 1, n - 1
764 q = isamax( n-p+1, sva( p ), 1 ) + p - 1
765 IF( p.NE.q ) THEN
766 temp1 = sva( p )
767 sva( p ) = sva( q )
768 sva( q ) = temp1
769 temp1 = d( p )
770 d( p ) = d( q )
771 d( q ) = temp1
772 CALL sswap( m, a( 1, p ), 1, a( 1, q ), 1 )
773 IF( rsvec )CALL sswap( mvl, v( 1, p ), 1, v( 1, q ), 1 )
774 END IF
775 5991 CONTINUE
776*
777 RETURN
778* ..
779* .. END OF SGSVJ1
780* ..

◆ shsein()

subroutine shsein ( character side,
character eigsrc,
character initv,
logical, dimension( * ) select,
integer n,
real, dimension( ldh, * ) h,
integer ldh,
real, dimension( * ) wr,
real, dimension( * ) wi,
real, dimension( ldvl, * ) vl,
integer ldvl,
real, dimension( ldvr, * ) vr,
integer ldvr,
integer mm,
integer m,
real, dimension( * ) work,
integer, dimension( * ) ifaill,
integer, dimension( * ) ifailr,
integer info )

SHSEIN

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

Purpose:
!>
!> SHSEIN uses inverse iteration to find specified right and/or left
!> eigenvectors of a real 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 (WR,WI):
!>          = 'Q': the eigenvalues were found using SHSEQR; 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 SHSEIN 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, SHSEIN 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,out]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          Specifies the eigenvectors to be computed. To select the
!>          real eigenvector corresponding to a real eigenvalue WR(j),
!>          SELECT(j) must be set to .TRUE.. To select the complex
!>          eigenvector corresponding to a complex eigenvalue
!>          (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
!>          either SELECT(j) or SELECT(j+1) or both must be set to
!>          .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
!>          .FALSE..
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix H.  N >= 0.
!>
[in]H
!>          H is REAL 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]WR
!>          WR is REAL array, dimension (N)
!>
[in]WI
!>          WI is REAL array, dimension (N)
!>
!>          On entry, the real and imaginary parts of the eigenvalues of
!>          H; a complex conjugate pair of eigenvalues must be stored in
!>          consecutive elements of WR and WI.
!>          On exit, WR may have been altered since close eigenvalues
!>          are perturbed slightly in searching for independent
!>          eigenvectors.
!>
[in,out]VL
!>          VL is REAL 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(s) 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. A
!>          complex eigenvector corresponding to a complex eigenvalue is
!>          stored in two consecutive columns, the first holding the real
!>          part and the second the imaginary part.
!>          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 REAL 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(s) 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. A
!>          complex eigenvector corresponding to a complex eigenvalue is
!>          stored in two consecutive columns, the first holding the real
!>          part and the second the imaginary part.
!>          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; each selected real eigenvector
!>          occupies one column and each selected complex eigenvector
!>          occupies two columns.
!>
[out]WORK
!>          WORK is REAL array, dimension ((N+2)*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 the i-th and (i+1)th
!>          columns of VL hold a complex eigenvector, then IFAILL(i) and
!>          IFAILL(i+1) are set to the same value.
!>          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 the i-th and (i+1)th
!>          columns of VR hold a complex eigenvector, then IFAILR(i) and
!>          IFAILR(i+1) are set to the same value.
!>          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 260 of file shsein.f.

263*
264* -- LAPACK computational routine --
265* -- LAPACK is a software package provided by Univ. of Tennessee, --
266* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
267*
268* .. Scalar Arguments ..
269 CHARACTER EIGSRC, INITV, SIDE
270 INTEGER INFO, LDH, LDVL, LDVR, M, MM, N
271* ..
272* .. Array Arguments ..
273 LOGICAL SELECT( * )
274 INTEGER IFAILL( * ), IFAILR( * )
275 REAL H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
276 $ WI( * ), WORK( * ), WR( * )
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 BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
287 INTEGER I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
288 REAL BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI,
289 $ WKR
290* ..
291* .. External Functions ..
292 LOGICAL LSAME, SISNAN
293 REAL SLAMCH, SLANHS
294 EXTERNAL lsame, slamch, slanhs, sisnan
295* ..
296* .. External Subroutines ..
297 EXTERNAL slaein, xerbla
298* ..
299* .. Intrinsic Functions ..
300 INTRINSIC abs, max
301* ..
302* .. Executable Statements ..
303*
304* Decode and test the input parameters.
305*
306 bothv = lsame( side, 'B' )
307 rightv = lsame( side, 'R' ) .OR. bothv
308 leftv = lsame( side, 'L' ) .OR. bothv
309*
310 fromqr = lsame( eigsrc, 'Q' )
311*
312 noinit = lsame( initv, 'N' )
313*
314* Set M to the number of columns required to store the selected
315* eigenvectors, and standardize the array SELECT.
316*
317 m = 0
318 pair = .false.
319 DO 10 k = 1, n
320 IF( pair ) THEN
321 pair = .false.
322 SELECT( k ) = .false.
323 ELSE
324 IF( wi( k ).EQ.zero ) THEN
325 IF( SELECT( k ) )
326 $ m = m + 1
327 ELSE
328 pair = .true.
329 IF( SELECT( k ) .OR. SELECT( k+1 ) ) THEN
330 SELECT( k ) = .true.
331 m = m + 2
332 END IF
333 END IF
334 END IF
335 10 CONTINUE
336*
337 info = 0
338 IF( .NOT.rightv .AND. .NOT.leftv ) THEN
339 info = -1
340 ELSE IF( .NOT.fromqr .AND. .NOT.lsame( eigsrc, 'N' ) ) THEN
341 info = -2
342 ELSE IF( .NOT.noinit .AND. .NOT.lsame( initv, 'U' ) ) THEN
343 info = -3
344 ELSE IF( n.LT.0 ) THEN
345 info = -5
346 ELSE IF( ldh.LT.max( 1, n ) ) THEN
347 info = -7
348 ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN
349 info = -11
350 ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN
351 info = -13
352 ELSE IF( mm.LT.m ) THEN
353 info = -14
354 END IF
355 IF( info.NE.0 ) THEN
356 CALL xerbla( 'SHSEIN', -info )
357 RETURN
358 END IF
359*
360* Quick return if possible.
361*
362 IF( n.EQ.0 )
363 $ RETURN
364*
365* Set machine-dependent constants.
366*
367 unfl = slamch( 'Safe minimum' )
368 ulp = slamch( 'Precision' )
369 smlnum = unfl*( n / ulp )
370 bignum = ( one-ulp ) / smlnum
371*
372 ldwork = n + 1
373*
374 kl = 1
375 kln = 0
376 IF( fromqr ) THEN
377 kr = 0
378 ELSE
379 kr = n
380 END IF
381 ksr = 1
382*
383 DO 120 k = 1, n
384 IF( SELECT( k ) ) THEN
385*
386* Compute eigenvector(s) corresponding to W(K).
387*
388 IF( fromqr ) THEN
389*
390* If affiliation of eigenvalues is known, check whether
391* the matrix splits.
392*
393* Determine KL and KR such that 1 <= KL <= K <= KR <= N
394* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
395* KR = N).
396*
397* Then inverse iteration can be performed with the
398* submatrix H(KL:N,KL:N) for a left eigenvector, and with
399* the submatrix H(1:KR,1:KR) for a right eigenvector.
400*
401 DO 20 i = k, kl + 1, -1
402 IF( h( i, i-1 ).EQ.zero )
403 $ GO TO 30
404 20 CONTINUE
405 30 CONTINUE
406 kl = i
407 IF( k.GT.kr ) THEN
408 DO 40 i = k, n - 1
409 IF( h( i+1, i ).EQ.zero )
410 $ GO TO 50
411 40 CONTINUE
412 50 CONTINUE
413 kr = i
414 END IF
415 END IF
416*
417 IF( kl.NE.kln ) THEN
418 kln = kl
419*
420* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
421* has not ben computed before.
422*
423 hnorm = slanhs( 'I', kr-kl+1, h( kl, kl ), ldh, work )
424 IF( sisnan( hnorm ) ) THEN
425 info = -6
426 RETURN
427 ELSE IF( hnorm.GT.zero ) THEN
428 eps3 = hnorm*ulp
429 ELSE
430 eps3 = smlnum
431 END IF
432 END IF
433*
434* Perturb eigenvalue if it is close to any previous
435* selected eigenvalues affiliated to the submatrix
436* H(KL:KR,KL:KR). Close roots are modified by EPS3.
437*
438 wkr = wr( k )
439 wki = wi( k )
440 60 CONTINUE
441 DO 70 i = k - 1, kl, -1
442 IF( SELECT( i ) .AND. abs( wr( i )-wkr )+
443 $ abs( wi( i )-wki ).LT.eps3 ) THEN
444 wkr = wkr + eps3
445 GO TO 60
446 END IF
447 70 CONTINUE
448 wr( k ) = wkr
449*
450 pair = wki.NE.zero
451 IF( pair ) THEN
452 ksi = ksr + 1
453 ELSE
454 ksi = ksr
455 END IF
456 IF( leftv ) THEN
457*
458* Compute left eigenvector.
459*
460 CALL slaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,
461 $ wkr, wki, vl( kl, ksr ), vl( kl, ksi ),
462 $ work, ldwork, work( n*n+n+1 ), eps3, smlnum,
463 $ bignum, iinfo )
464 IF( iinfo.GT.0 ) THEN
465 IF( pair ) THEN
466 info = info + 2
467 ELSE
468 info = info + 1
469 END IF
470 ifaill( ksr ) = k
471 ifaill( ksi ) = k
472 ELSE
473 ifaill( ksr ) = 0
474 ifaill( ksi ) = 0
475 END IF
476 DO 80 i = 1, kl - 1
477 vl( i, ksr ) = zero
478 80 CONTINUE
479 IF( pair ) THEN
480 DO 90 i = 1, kl - 1
481 vl( i, ksi ) = zero
482 90 CONTINUE
483 END IF
484 END IF
485 IF( rightv ) THEN
486*
487* Compute right eigenvector.
488*
489 CALL slaein( .true., noinit, kr, h, ldh, wkr, wki,
490 $ vr( 1, ksr ), vr( 1, ksi ), work, ldwork,
491 $ work( n*n+n+1 ), eps3, smlnum, bignum,
492 $ iinfo )
493 IF( iinfo.GT.0 ) THEN
494 IF( pair ) THEN
495 info = info + 2
496 ELSE
497 info = info + 1
498 END IF
499 ifailr( ksr ) = k
500 ifailr( ksi ) = k
501 ELSE
502 ifailr( ksr ) = 0
503 ifailr( ksi ) = 0
504 END IF
505 DO 100 i = kr + 1, n
506 vr( i, ksr ) = zero
507 100 CONTINUE
508 IF( pair ) THEN
509 DO 110 i = kr + 1, n
510 vr( i, ksi ) = zero
511 110 CONTINUE
512 END IF
513 END IF
514*
515 IF( pair ) THEN
516 ksr = ksr + 2
517 ELSE
518 ksr = ksr + 1
519 END IF
520 END IF
521 120 CONTINUE
522*
523 RETURN
524*
525* End of SHSEIN
526*
sisnan
logical function sisnan(sin)
SISNAN tests input for NaN.
Definition sisnan.f:59
slanhs
real function slanhs(norm, n, a, lda, work)
SLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition slanhs.f:108
slaein
subroutine slaein(rightv, noinit, n, h, ldh, wr, wi, vr, vi, b, ldb, work, eps3, smlnum, bignum, info)
SLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse iterat...
Definition slaein.f:172

◆ shseqr()

subroutine shseqr ( character job,
character compz,
integer n,
integer ilo,
integer ihi,
real, dimension( ldh, * ) h,
integer ldh,
real, dimension( * ) wr,
real, dimension( * ) wi,
real, dimension( ldz, * ) z,
integer ldz,
real, dimension( * ) work,
integer lwork,
integer info )

SHSEQR

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

Purpose:
!>
!>    SHSEQR computes the eigenvalues of a Hessenberg matrix H
!>    and, optionally, the matrices T and Z from the Schur decomposition
!>    H = Z T Z**T, where T is an upper quasi-triangular matrix (the
!>    Schur form), and Z is the orthogonal matrix of Schur vectors.
!>
!>    Optionally Z may be postmultiplied into an input orthogonal
!>    matrix Q so that this routine can give the Schur factorization
!>    of a matrix A which has been reduced to the Hessenberg form H
!>    by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.
!>
Parameters
[in]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 orthogonal 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 SGEBAL, and then passed to ZGEHRD
!>           when the matrix output by SGEBAL 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 REAL array, dimension (LDH,N)
!>           On entry, the upper Hessenberg matrix H.
!>           On exit, if INFO = 0 and JOB = 'S', then H contains the
!>           upper quasi-triangular matrix T from the Schur decomposition
!>           (the Schur form); 2-by-2 diagonal blocks (corresponding to
!>           complex conjugate pairs of eigenvalues) are returned in
!>           standard form, with H(i,i) = H(i+1,i+1) and
!>           H(i+1,i)*H(i,i+1) < 0. If INFO = 0 and 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 SHSEQR, 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]WR
!>          WR is REAL array, dimension (N)
!>
[out]WI
!>          WI is REAL array, dimension (N)
!>
!>           The real and imaginary parts, respectively, of the computed
!>           eigenvalues. If two eigenvalues are computed as a complex
!>           conjugate pair, they are stored in consecutive elements of
!>           WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and
!>           WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in
!>           the same order as on the diagonal of the Schur form returned
!>           in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
!>           diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
!>           WI(i+1) = -WI(i).
!>
[in,out]Z
!>          Z is REAL 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 orthogonal 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 orthogonal matrix generated by SORGHR
!>           after the call to SGEHRD 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 REAL 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 SHSEQR does a workspace query.
!>           In this case, SHSEQR 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, SHSEQR failed to compute all of
!>                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
!>                and WI contain those eigenvalues which have been
!>                successfully computed.  (Failures are rare.)
!>
!>                If INFO > 0 and 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 an orthogonal matrix.  The final
!>                value of H is upper Hessenberg and quasi-triangular
!>                in rows and columns INFO+1 through IHI.
!>
!>                If INFO > 0 and COMPZ = 'V', then on exit
!>
!>                  (final value of Z)  =  (initial value of Z)*U
!>
!>                where U is the orthogonal 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 orthogonal 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,'SHSEQR',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 SLAHQR vs SLAQR0 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
!>                       SLAHQR 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 314 of file shseqr.f.

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

◆ sla_lin_berr()

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

SLA_LIN_BERR computes a component-wise relative backward error.

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

Purpose:
!>
!>    SLA_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 REAL 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 sla_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 sla_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 REAL RES( N, NRHS )
112* ..
113*
114* =====================================================================
115*
116* .. Local Scalars ..
117 REAL TMP
118 INTEGER I, J
119* ..
120* .. Intrinsic Functions ..
121 INTRINSIC abs, max
122* ..
123* .. External Functions ..
124 EXTERNAL slamch
125 REAL SLAMCH
126 REAL SAFE1
127* ..
128* .. Executable Statements ..
129*
130* Adding SAFE1 to the numerator guards against spuriously zero
131* residuals. A similar safeguard is in the SLA_yyAMV routine used
132* to compute AYB.
133*
134 safe1 = slamch( 'Safe minimum' )
135 safe1 = (nz+1)*safe1
136
137 DO j = 1, nrhs
138 berr(j) = 0.0
139 DO i = 1, n
140 IF (ayb(i,j) .NE. 0.0) THEN
141 tmp = (safe1+abs(res(i,j)))/ayb(i,j)
142 berr(j) = max( berr(j), tmp )
143 END IF
144*
145* If AYB is exactly 0.0 (and if computed by SLA_yyAMV), then we know
146* the true residual also must be exactly 0.0.
147*
148 END DO
149 END DO
150*
151* End of SLA_LIN_BERR
152*

◆ sla_wwaddw()

subroutine sla_wwaddw ( integer n,
real, dimension( * ) x,
real, dimension( * ) y,
real, dimension( * ) w )

SLA_WWADDW adds a vector into a doubled-single vector.

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

Purpose:
!>
!>    SLA_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 REAL array, dimension (N)
!>            The first part of the doubled-single accumulation vector.
!>
[in,out]Y
!>          Y is REAL array, dimension (N)
!>            The second part of the doubled-single accumulation vector.
!>
[in]W
!>          W is REAL 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 sla_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 REAL X( * ), Y( * ), W( * )
91* ..
92*
93* =====================================================================
94*
95* .. Local Scalars ..
96 REAL 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 SLA_WWADDW
110*

◆ slals0()

subroutine slals0 ( integer icompq,
integer nl,
integer nr,
integer sqre,
integer nrhs,
real, dimension( ldb, * ) b,
integer ldb,
real, 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( * ) work,
integer info )

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

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

Purpose:
!>
!> SLALS0 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 REAL 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 REAL 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]WORK
!>          WORK is REAL array, dimension ( K )
!>
[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 265 of file slals0.f.

268*
269* -- LAPACK computational routine --
270* -- LAPACK is a software package provided by Univ. of Tennessee, --
271* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
272*
273* .. Scalar Arguments ..
274 INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
275 $ LDGNUM, NL, NR, NRHS, SQRE
276 REAL C, S
277* ..
278* .. Array Arguments ..
279 INTEGER GIVCOL( LDGCOL, * ), PERM( * )
280 REAL B( LDB, * ), BX( LDBX, * ), DIFL( * ),
281 $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
282 $ POLES( LDGNUM, * ), WORK( * ), Z( * )
283* ..
284*
285* =====================================================================
286*
287* .. Parameters ..
288 REAL ONE, ZERO, NEGONE
289 parameter( one = 1.0e0, zero = 0.0e0, negone = -1.0e0 )
290* ..
291* .. Local Scalars ..
292 INTEGER I, J, M, N, NLP1
293 REAL DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
294* ..
295* .. External Subroutines ..
296 EXTERNAL scopy, sgemv, slacpy, slascl, srot, sscal,
297 $ xerbla
298* ..
299* .. External Functions ..
300 REAL SLAMC3, SNRM2
301 EXTERNAL slamc3, snrm2
302* ..
303* .. Intrinsic Functions ..
304 INTRINSIC max
305* ..
306* .. Executable Statements ..
307*
308* Test the input parameters.
309*
310 info = 0
311 n = nl + nr + 1
312*
313 IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
314 info = -1
315 ELSE IF( nl.LT.1 ) THEN
316 info = -2
317 ELSE IF( nr.LT.1 ) THEN
318 info = -3
319 ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
320 info = -4
321 ELSE IF( nrhs.LT.1 ) THEN
322 info = -5
323 ELSE IF( ldb.LT.n ) THEN
324 info = -7
325 ELSE IF( ldbx.LT.n ) THEN
326 info = -9
327 ELSE IF( givptr.LT.0 ) THEN
328 info = -11
329 ELSE IF( ldgcol.LT.n ) THEN
330 info = -13
331 ELSE IF( ldgnum.LT.n ) THEN
332 info = -15
333 ELSE IF( k.LT.1 ) THEN
334 info = -20
335 END IF
336 IF( info.NE.0 ) THEN
337 CALL xerbla( 'SLALS0', -info )
338 RETURN
339 END IF
340*
341 m = n + sqre
342 nlp1 = nl + 1
343*
344 IF( icompq.EQ.0 ) THEN
345*
346* Apply back orthogonal transformations from the left.
347*
348* Step (1L): apply back the Givens rotations performed.
349*
350 DO 10 i = 1, givptr
351 CALL srot( nrhs, b( givcol( i, 2 ), 1 ), ldb,
352 $ b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
353 $ givnum( i, 1 ) )
354 10 CONTINUE
355*
356* Step (2L): permute rows of B.
357*
358 CALL scopy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx )
359 DO 20 i = 2, n
360 CALL scopy( nrhs, b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx )
361 20 CONTINUE
362*
363* Step (3L): apply the inverse of the left singular vector
364* matrix to BX.
365*
366 IF( k.EQ.1 ) THEN
367 CALL scopy( nrhs, bx, ldbx, b, ldb )
368 IF( z( 1 ).LT.zero ) THEN
369 CALL sscal( nrhs, negone, b, ldb )
370 END IF
371 ELSE
372 DO 50 j = 1, k
373 diflj = difl( j )
374 dj = poles( j, 1 )
375 dsigj = -poles( j, 2 )
376 IF( j.LT.k ) THEN
377 difrj = -difr( j, 1 )
378 dsigjp = -poles( j+1, 2 )
379 END IF
380 IF( ( z( j ).EQ.zero ) .OR. ( poles( j, 2 ).EQ.zero ) )
381 $ THEN
382 work( j ) = zero
383 ELSE
384 work( j ) = -poles( j, 2 )*z( j ) / diflj /
385 $ ( poles( j, 2 )+dj )
386 END IF
387 DO 30 i = 1, j - 1
388 IF( ( z( i ).EQ.zero ) .OR.
389 $ ( poles( i, 2 ).EQ.zero ) ) THEN
390 work( i ) = zero
391 ELSE
392 work( i ) = poles( i, 2 )*z( i ) /
393 $ ( slamc3( poles( i, 2 ), dsigj )-
394 $ diflj ) / ( poles( i, 2 )+dj )
395 END IF
396 30 CONTINUE
397 DO 40 i = j + 1, k
398 IF( ( z( i ).EQ.zero ) .OR.
399 $ ( poles( i, 2 ).EQ.zero ) ) THEN
400 work( i ) = zero
401 ELSE
402 work( i ) = poles( i, 2 )*z( i ) /
403 $ ( slamc3( poles( i, 2 ), dsigjp )+
404 $ difrj ) / ( poles( i, 2 )+dj )
405 END IF
406 40 CONTINUE
407 work( 1 ) = negone
408 temp = snrm2( k, work, 1 )
409 CALL sgemv( 'T', k, nrhs, one, bx, ldbx, work, 1, zero,
410 $ b( j, 1 ), ldb )
411 CALL slascl( 'G', 0, 0, temp, one, 1, nrhs, b( j, 1 ),
412 $ ldb, info )
413 50 CONTINUE
414 END IF
415*
416* Move the deflated rows of BX to B also.
417*
418 IF( k.LT.max( m, n ) )
419 $ CALL slacpy( 'A', n-k, nrhs, bx( k+1, 1 ), ldbx,
420 $ b( k+1, 1 ), ldb )
421 ELSE
422*
423* Apply back the right orthogonal transformations.
424*
425* Step (1R): apply back the new right singular vector matrix
426* to B.
427*
428 IF( k.EQ.1 ) THEN
429 CALL scopy( nrhs, b, ldb, bx, ldbx )
430 ELSE
431 DO 80 j = 1, k
432 dsigj = poles( j, 2 )
433 IF( z( j ).EQ.zero ) THEN
434 work( j ) = zero
435 ELSE
436 work( j ) = -z( j ) / difl( j ) /
437 $ ( dsigj+poles( j, 1 ) ) / difr( j, 2 )
438 END IF
439 DO 60 i = 1, j - 1
440 IF( z( j ).EQ.zero ) THEN
441 work( i ) = zero
442 ELSE
443 work( i ) = z( j ) / ( slamc3( dsigj, -poles( i+1,
444 $ 2 ) )-difr( i, 1 ) ) /
445 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
446 END IF
447 60 CONTINUE
448 DO 70 i = j + 1, k
449 IF( z( j ).EQ.zero ) THEN
450 work( i ) = zero
451 ELSE
452 work( i ) = z( j ) / ( slamc3( dsigj, -poles( i,
453 $ 2 ) )-difl( i ) ) /
454 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
455 END IF
456 70 CONTINUE
457 CALL sgemv( 'T', k, nrhs, one, b, ldb, work, 1, zero,
458 $ bx( j, 1 ), ldbx )
459 80 CONTINUE
460 END IF
461*
462* Step (2R): if SQRE = 1, apply back the rotation that is
463* related to the right null space of the subproblem.
464*
465 IF( sqre.EQ.1 ) THEN
466 CALL scopy( nrhs, b( m, 1 ), ldb, bx( m, 1 ), ldbx )
467 CALL srot( nrhs, bx( 1, 1 ), ldbx, bx( m, 1 ), ldbx, c, s )
468 END IF
469 IF( k.LT.max( m, n ) )
470 $ CALL slacpy( 'A', n-k, nrhs, b( k+1, 1 ), ldb, bx( k+1, 1 ),
471 $ ldbx )
472*
473* Step (3R): permute rows of B.
474*
475 CALL scopy( nrhs, bx( 1, 1 ), ldbx, b( nlp1, 1 ), ldb )
476 IF( sqre.EQ.1 ) THEN
477 CALL scopy( nrhs, bx( m, 1 ), ldbx, b( m, 1 ), ldb )
478 END IF
479 DO 90 i = 2, n
480 CALL scopy( nrhs, bx( i, 1 ), ldbx, b( perm( i ), 1 ), ldb )
481 90 CONTINUE
482*
483* Step (4R): apply back the Givens rotations performed.
484*
485 DO 100 i = givptr, 1, -1
486 CALL srot( nrhs, b( givcol( i, 2 ), 1 ), ldb,
487 $ b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ),
488 $ -givnum( i, 1 ) )
489 100 CONTINUE
490 END IF
491*
492 RETURN
493*
494* End of SLALS0
495*
slamc3
real function slamc3(a, b)
SLAMC3
Definition slamch.f:169

◆ slalsa()

subroutine slalsa ( integer icompq,
integer smlsiz,
integer n,
integer nrhs,
real, dimension( ldb, * ) b,
integer ldb,
real, 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( * ) work,
integer, dimension( * ) iwork,
integer info )

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

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

Purpose:
!>
!> SLALSA 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, SLALSA applies the inverse of the left singular vector
!> matrix of an upper bidiagonal matrix to the right hand side; and if
!> ICOMPQ = 1, SLALSA applies the right singular vector matrix to the
!> right hand side. The singular vector matrices were generated in
!> compact form by SLALSA.
!>
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 REAL 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 REAL 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**T 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]WORK
!>          WORK is REAL array, dimension (N)
!>
[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 slalsa.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 B( LDB, * ), BX( LDBX, * ), C( * ),
280 $ DIFL( LDU, * ), DIFR( LDU, * ),
281 $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ),
282 $ U( LDU, * ), VT( LDU, * ), WORK( * ),
283 $ Z( LDU, * )
284* ..
285*
286* =====================================================================
287*
288* .. Parameters ..
289 REAL ZERO, ONE
290 parameter( zero = 0.0e0, one = 1.0e0 )
291* ..
292* .. Local Scalars ..
293 INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2,
294 $ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL,
295 $ NR, NRF, NRP1, SQRE
296* ..
297* .. External Subroutines ..
298 EXTERNAL scopy, sgemm, slals0, slasdt, xerbla
299* ..
300* .. Executable Statements ..
301*
302* Test the input parameters.
303*
304 info = 0
305*
306 IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
307 info = -1
308 ELSE IF( smlsiz.LT.3 ) THEN
309 info = -2
310 ELSE IF( n.LT.smlsiz ) THEN
311 info = -3
312 ELSE IF( nrhs.LT.1 ) THEN
313 info = -4
314 ELSE IF( ldb.LT.n ) THEN
315 info = -6
316 ELSE IF( ldbx.LT.n ) THEN
317 info = -8
318 ELSE IF( ldu.LT.n ) THEN
319 info = -10
320 ELSE IF( ldgcol.LT.n ) THEN
321 info = -19
322 END IF
323 IF( info.NE.0 ) THEN
324 CALL xerbla( 'SLALSA', -info )
325 RETURN
326 END IF
327*
328* Book-keeping and setting up the computation tree.
329*
330 inode = 1
331 ndiml = inode + n
332 ndimr = ndiml + n
333*
334 CALL slasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ),
335 $ iwork( ndimr ), smlsiz )
336*
337* The following code applies back the left singular vector factors.
338* For applying back the right singular vector factors, go to 50.
339*
340 IF( icompq.EQ.1 ) THEN
341 GO TO 50
342 END IF
343*
344* The nodes on the bottom level of the tree were solved
345* by SLASDQ. The corresponding left and right singular vector
346* matrices are in explicit form. First apply back the left
347* singular vector matrices.
348*
349 ndb1 = ( nd+1 ) / 2
350 DO 10 i = ndb1, nd
351*
352* IC : center row of each node
353* NL : number of rows of left subproblem
354* NR : number of rows of right subproblem
355* NLF: starting row of the left subproblem
356* NRF: starting row of the right subproblem
357*
358 i1 = i - 1
359 ic = iwork( inode+i1 )
360 nl = iwork( ndiml+i1 )
361 nr = iwork( ndimr+i1 )
362 nlf = ic - nl
363 nrf = ic + 1
364 CALL sgemm( 'T', 'N', nl, nrhs, nl, one, u( nlf, 1 ), ldu,
365 $ b( nlf, 1 ), ldb, zero, bx( nlf, 1 ), ldbx )
366 CALL sgemm( 'T', 'N', nr, nrhs, nr, one, u( nrf, 1 ), ldu,
367 $ b( nrf, 1 ), ldb, zero, bx( nrf, 1 ), ldbx )
368 10 CONTINUE
369*
370* Next copy the rows of B that correspond to unchanged rows
371* in the bidiagonal matrix to BX.
372*
373 DO 20 i = 1, nd
374 ic = iwork( inode+i-1 )
375 CALL scopy( nrhs, b( ic, 1 ), ldb, bx( ic, 1 ), ldbx )
376 20 CONTINUE
377*
378* Finally go through the left singular vector matrices of all
379* the other subproblems bottom-up on the tree.
380*
381 j = 2**nlvl
382 sqre = 0
383*
384 DO 40 lvl = nlvl, 1, -1
385 lvl2 = 2*lvl - 1
386*
387* find the first node LF and last node LL on
388* the current level LVL
389*
390 IF( lvl.EQ.1 ) THEN
391 lf = 1
392 ll = 1
393 ELSE
394 lf = 2**( lvl-1 )
395 ll = 2*lf - 1
396 END IF
397 DO 30 i = lf, ll
398 im1 = i - 1
399 ic = iwork( inode+im1 )
400 nl = iwork( ndiml+im1 )
401 nr = iwork( ndimr+im1 )
402 nlf = ic - nl
403 nrf = ic + 1
404 j = j - 1
405 CALL slals0( icompq, nl, nr, sqre, nrhs, bx( nlf, 1 ), ldbx,
406 $ b( nlf, 1 ), ldb, perm( nlf, lvl ),
407 $ givptr( j ), givcol( nlf, lvl2 ), ldgcol,
408 $ givnum( nlf, lvl2 ), ldu, poles( nlf, lvl2 ),
409 $ difl( nlf, lvl ), difr( nlf, lvl2 ),
410 $ z( nlf, lvl ), k( j ), c( j ), s( j ), work,
411 $ info )
412 30 CONTINUE
413 40 CONTINUE
414 GO TO 90
415*
416* ICOMPQ = 1: applying back the right singular vector factors.
417*
418 50 CONTINUE
419*
420* First now go through the right singular vector matrices of all
421* the tree nodes top-down.
422*
423 j = 0
424 DO 70 lvl = 1, nlvl
425 lvl2 = 2*lvl - 1
426*
427* Find the first node LF and last node LL on
428* the current level LVL.
429*
430 IF( lvl.EQ.1 ) THEN
431 lf = 1
432 ll = 1
433 ELSE
434 lf = 2**( lvl-1 )
435 ll = 2*lf - 1
436 END IF
437 DO 60 i = ll, lf, -1
438 im1 = i - 1
439 ic = iwork( inode+im1 )
440 nl = iwork( ndiml+im1 )
441 nr = iwork( ndimr+im1 )
442 nlf = ic - nl
443 nrf = ic + 1
444 IF( i.EQ.ll ) THEN
445 sqre = 0
446 ELSE
447 sqre = 1
448 END IF
449 j = j + 1
450 CALL slals0( icompq, nl, nr, sqre, nrhs, b( nlf, 1 ), ldb,
451 $ bx( nlf, 1 ), ldbx, perm( nlf, lvl ),
452 $ givptr( j ), givcol( nlf, lvl2 ), ldgcol,
453 $ givnum( nlf, lvl2 ), ldu, poles( nlf, lvl2 ),
454 $ difl( nlf, lvl ), difr( nlf, lvl2 ),
455 $ z( nlf, lvl ), k( j ), c( j ), s( j ), work,
456 $ info )
457 60 CONTINUE
458 70 CONTINUE
459*
460* The nodes on the bottom level of the tree were solved
461* by SLASDQ. The corresponding right singular vector
462* matrices are in explicit form. Apply them back.
463*
464 ndb1 = ( nd+1 ) / 2
465 DO 80 i = ndb1, nd
466 i1 = i - 1
467 ic = iwork( inode+i1 )
468 nl = iwork( ndiml+i1 )
469 nr = iwork( ndimr+i1 )
470 nlp1 = nl + 1
471 IF( i.EQ.nd ) THEN
472 nrp1 = nr
473 ELSE
474 nrp1 = nr + 1
475 END IF
476 nlf = ic - nl
477 nrf = ic + 1
478 CALL sgemm( 'T', 'N', nlp1, nrhs, nlp1, one, vt( nlf, 1 ), ldu,
479 $ b( nlf, 1 ), ldb, zero, bx( nlf, 1 ), ldbx )
480 CALL sgemm( 'T', 'N', nrp1, nrhs, nrp1, one, vt( nrf, 1 ), ldu,
481 $ b( nrf, 1 ), ldb, zero, bx( nrf, 1 ), ldbx )
482 80 CONTINUE
483*
484 90 CONTINUE
485*
486 RETURN
487*
488* End of SLALSA
489*
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
slals0
subroutine slals0(icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx, perm, givptr, givcol, ldgcol, givnum, ldgnum, poles, difl, difr, z, k, c, s, work, info)
SLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer...
Definition slals0.f:268

◆ slalsd()

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

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

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

Purpose:
!>
!> SLALSD 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 REAL 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 REAL array, dimension at least
!>         (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
!>         where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension at least
!>         (3*N*NLVL + 11*N)
!>
[out]INFO
!>          INFO is INTEGER
!>         = 0:  successful exit.
!>         < 0:  if INFO = -i, the i-th argument had an illegal value.
!>         > 0:  The algorithm failed to compute a singular value while
!>               working on the submatrix lying in rows and columns
!>               INFO/(N+1) through MOD(INFO,N+1).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Ming Gu and Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA

Definition at line 177 of file slalsd.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 UPLO
186 INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ
187 REAL RCOND
188* ..
189* .. Array Arguments ..
190 INTEGER IWORK( * )
191 REAL B( LDB, * ), D( * ), E( * ), WORK( * )
192* ..
193*
194* =====================================================================
195*
196* .. Parameters ..
197 REAL ZERO, ONE, TWO
198 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
199* ..
200* .. Local Scalars ..
201 INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
202 $ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL,
203 $ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI,
204 $ SMLSZP, SQRE, ST, ST1, U, VT, Z
205 REAL CS, EPS, ORGNRM, R, RCND, SN, TOL
206* ..
207* .. External Functions ..
208 INTEGER ISAMAX
209 REAL SLAMCH, SLANST
210 EXTERNAL isamax, slamch, slanst
211* ..
212* .. External Subroutines ..
213 EXTERNAL scopy, sgemm, slacpy, slalsa, slartg, slascl,
214 $ slasda, slasdq, slaset, slasrt, srot, xerbla
215* ..
216* .. Intrinsic Functions ..
217 INTRINSIC abs, int, log, real, sign
218* ..
219* .. Executable Statements ..
220*
221* Test the input parameters.
222*
223 info = 0
224*
225 IF( n.LT.0 ) THEN
226 info = -3
227 ELSE IF( nrhs.LT.1 ) THEN
228 info = -4
229 ELSE IF( ( ldb.LT.1 ) .OR. ( ldb.LT.n ) ) THEN
230 info = -8
231 END IF
232 IF( info.NE.0 ) THEN
233 CALL xerbla( 'SLALSD', -info )
234 RETURN
235 END IF
236*
237 eps = slamch( 'Epsilon' )
238*
239* Set up the tolerance.
240*
241 IF( ( rcond.LE.zero ) .OR. ( rcond.GE.one ) ) THEN
242 rcnd = eps
243 ELSE
244 rcnd = rcond
245 END IF
246*
247 rank = 0
248*
249* Quick return if possible.
250*
251 IF( n.EQ.0 ) THEN
252 RETURN
253 ELSE IF( n.EQ.1 ) THEN
254 IF( d( 1 ).EQ.zero ) THEN
255 CALL slaset( 'A', 1, nrhs, zero, zero, b, ldb )
256 ELSE
257 rank = 1
258 CALL slascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info )
259 d( 1 ) = abs( d( 1 ) )
260 END IF
261 RETURN
262 END IF
263*
264* Rotate the matrix if it is lower bidiagonal.
265*
266 IF( uplo.EQ.'L' ) THEN
267 DO 10 i = 1, n - 1
268 CALL slartg( d( i ), e( i ), cs, sn, r )
269 d( i ) = r
270 e( i ) = sn*d( i+1 )
271 d( i+1 ) = cs*d( i+1 )
272 IF( nrhs.EQ.1 ) THEN
273 CALL srot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn )
274 ELSE
275 work( i*2-1 ) = cs
276 work( i*2 ) = sn
277 END IF
278 10 CONTINUE
279 IF( nrhs.GT.1 ) THEN
280 DO 30 i = 1, nrhs
281 DO 20 j = 1, n - 1
282 cs = work( j*2-1 )
283 sn = work( j*2 )
284 CALL srot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn )
285 20 CONTINUE
286 30 CONTINUE
287 END IF
288 END IF
289*
290* Scale.
291*
292 nm1 = n - 1
293 orgnrm = slanst( 'M', n, d, e )
294 IF( orgnrm.EQ.zero ) THEN
295 CALL slaset( 'A', n, nrhs, zero, zero, b, ldb )
296 RETURN
297 END IF
298*
299 CALL slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info )
300 CALL slascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info )
301*
302* If N is smaller than the minimum divide size SMLSIZ, then solve
303* the problem with another solver.
304*
305 IF( n.LE.smlsiz ) THEN
306 nwork = 1 + n*n
307 CALL slaset( 'A', n, n, zero, one, work, n )
308 CALL slasdq( 'U', 0, n, n, 0, nrhs, d, e, work, n, work, n, b,
309 $ ldb, work( nwork ), info )
310 IF( info.NE.0 ) THEN
311 RETURN
312 END IF
313 tol = rcnd*abs( d( isamax( n, d, 1 ) ) )
314 DO 40 i = 1, n
315 IF( d( i ).LE.tol ) THEN
316 CALL slaset( 'A', 1, nrhs, zero, zero, b( i, 1 ), ldb )
317 ELSE
318 CALL slascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),
319 $ ldb, info )
320 rank = rank + 1
321 END IF
322 40 CONTINUE
323 CALL sgemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero,
324 $ work( nwork ), n )
325 CALL slacpy( 'A', n, nrhs, work( nwork ), n, b, ldb )
326*
327* Unscale.
328*
329 CALL slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info )
330 CALL slasrt( 'D', n, d, info )
331 CALL slascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info )
332*
333 RETURN
334 END IF
335*
336* Book-keeping and setting up some constants.
337*
338 nlvl = int( log( real( n ) / real( smlsiz+1 ) ) / log( two ) ) + 1
339*
340 smlszp = smlsiz + 1
341*
342 u = 1
343 vt = 1 + smlsiz*n
344 difl = vt + smlszp*n
345 difr = difl + nlvl*n
346 z = difr + nlvl*n*2
347 c = z + nlvl*n
348 s = c + n
349 poles = s + n
350 givnum = poles + 2*nlvl*n
351 bx = givnum + 2*nlvl*n
352 nwork = bx + n*nrhs
353*
354 sizei = 1 + n
355 k = sizei + n
356 givptr = k + n
357 perm = givptr + n
358 givcol = perm + nlvl*n
359 iwk = givcol + nlvl*n*2
360*
361 st = 1
362 sqre = 0
363 icmpq1 = 1
364 icmpq2 = 0
365 nsub = 0
366*
367 DO 50 i = 1, n
368 IF( abs( d( i ) ).LT.eps ) THEN
369 d( i ) = sign( eps, d( i ) )
370 END IF
371 50 CONTINUE
372*
373 DO 60 i = 1, nm1
374 IF( ( abs( e( i ) ).LT.eps ) .OR. ( i.EQ.nm1 ) ) THEN
375 nsub = nsub + 1
376 iwork( nsub ) = st
377*
378* Subproblem found. First determine its size and then
379* apply divide and conquer on it.
380*
381 IF( i.LT.nm1 ) THEN
382*
383* A subproblem with E(I) small for I < NM1.
384*
385 nsize = i - st + 1
386 iwork( sizei+nsub-1 ) = nsize
387 ELSE IF( abs( e( i ) ).GE.eps ) THEN
388*
389* A subproblem with E(NM1) not too small but I = NM1.
390*
391 nsize = n - st + 1
392 iwork( sizei+nsub-1 ) = nsize
393 ELSE
394*
395* A subproblem with E(NM1) small. This implies an
396* 1-by-1 subproblem at D(N), which is not solved
397* explicitly.
398*
399 nsize = i - st + 1
400 iwork( sizei+nsub-1 ) = nsize
401 nsub = nsub + 1
402 iwork( nsub ) = n
403 iwork( sizei+nsub-1 ) = 1
404 CALL scopy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n )
405 END IF
406 st1 = st - 1
407 IF( nsize.EQ.1 ) THEN
408*
409* This is a 1-by-1 subproblem and is not solved
410* explicitly.
411*
412 CALL scopy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n )
413 ELSE IF( nsize.LE.smlsiz ) THEN
414*
415* This is a small subproblem and is solved by SLASDQ.
416*
417 CALL slaset( 'A', nsize, nsize, zero, one,
418 $ work( vt+st1 ), n )
419 CALL slasdq( 'U', 0, nsize, nsize, 0, nrhs, d( st ),
420 $ e( st ), work( vt+st1 ), n, work( nwork ),
421 $ n, b( st, 1 ), ldb, work( nwork ), info )
422 IF( info.NE.0 ) THEN
423 RETURN
424 END IF
425 CALL slacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,
426 $ work( bx+st1 ), n )
427 ELSE
428*
429* A large problem. Solve it using divide and conquer.
430*
431 CALL slasda( icmpq1, smlsiz, nsize, sqre, d( st ),
432 $ e( st ), work( u+st1 ), n, work( vt+st1 ),
433 $ iwork( k+st1 ), work( difl+st1 ),
434 $ work( difr+st1 ), work( z+st1 ),
435 $ work( poles+st1 ), iwork( givptr+st1 ),
436 $ iwork( givcol+st1 ), n, iwork( perm+st1 ),
437 $ work( givnum+st1 ), work( c+st1 ),
438 $ work( s+st1 ), work( nwork ), iwork( iwk ),
439 $ info )
440 IF( info.NE.0 ) THEN
441 RETURN
442 END IF
443 bxst = bx + st1
444 CALL slalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),
445 $ ldb, work( bxst ), n, work( u+st1 ), n,
446 $ work( vt+st1 ), iwork( k+st1 ),
447 $ work( difl+st1 ), work( difr+st1 ),
448 $ work( z+st1 ), work( poles+st1 ),
449 $ iwork( givptr+st1 ), iwork( givcol+st1 ), n,
450 $ iwork( perm+st1 ), work( givnum+st1 ),
451 $ work( c+st1 ), work( s+st1 ), work( nwork ),
452 $ iwork( iwk ), info )
453 IF( info.NE.0 ) THEN
454 RETURN
455 END IF
456 END IF
457 st = i + 1
458 END IF
459 60 CONTINUE
460*
461* Apply the singular values and treat the tiny ones as zero.
462*
463 tol = rcnd*abs( d( isamax( n, d, 1 ) ) )
464*
465 DO 70 i = 1, n
466*
467* Some of the elements in D can be negative because 1-by-1
468* subproblems were not solved explicitly.
469*
470 IF( abs( d( i ) ).LE.tol ) THEN
471 CALL slaset( 'A', 1, nrhs, zero, zero, work( bx+i-1 ), n )
472 ELSE
473 rank = rank + 1
474 CALL slascl( 'G', 0, 0, d( i ), one, 1, nrhs,
475 $ work( bx+i-1 ), n, info )
476 END IF
477 d( i ) = abs( d( i ) )
478 70 CONTINUE
479*
480* Now apply back the right singular vectors.
481*
482 icmpq2 = 1
483 DO 80 i = 1, nsub
484 st = iwork( i )
485 st1 = st - 1
486 nsize = iwork( sizei+i-1 )
487 bxst = bx + st1
488 IF( nsize.EQ.1 ) THEN
489 CALL scopy( nrhs, work( bxst ), n, b( st, 1 ), ldb )
490 ELSE IF( nsize.LE.smlsiz ) THEN
491 CALL sgemm( 'T', 'N', nsize, nrhs, nsize, one,
492 $ work( vt+st1 ), n, work( bxst ), n, zero,
493 $ b( st, 1 ), ldb )
494 ELSE
495 CALL slalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,
496 $ b( st, 1 ), ldb, work( u+st1 ), n,
497 $ work( vt+st1 ), iwork( k+st1 ),
498 $ work( difl+st1 ), work( difr+st1 ),
499 $ work( z+st1 ), work( poles+st1 ),
500 $ iwork( givptr+st1 ), iwork( givcol+st1 ), n,
501 $ iwork( perm+st1 ), work( givnum+st1 ),
502 $ work( c+st1 ), work( s+st1 ), work( nwork ),
503 $ iwork( iwk ), info )
504 IF( info.NE.0 ) THEN
505 RETURN
506 END IF
507 END IF
508 80 CONTINUE
509*
510* Unscale and sort the singular values.
511*
512 CALL slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info )
513 CALL slasrt( 'D', n, d, info )
514 CALL slascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info )
515*
516 RETURN
517*
518* End of SLALSD
519*
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
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
slalsa
subroutine slalsa(icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u, ldu, vt, k, difl, difr, z, poles, givptr, givcol, ldgcol, perm, givnum, c, s, work, iwork, info)
SLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd.
Definition slalsa.f:267

◆ slansf()

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

SLANSF

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

Purpose:
!>
!> SLANSF returns the value of the one norm, or the Frobenius norm, or
!> the infinity norm, or the element of largest absolute value of a
!> real symmetric matrix A in RFP format.
!>
Returns
SLANSF 
!>
!>    SLANSF = ( 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*1
!>          Specifies the value to be returned in SLANSF as described
!>          above.
!>
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          Specifies whether the RFP format of A is normal or
!>          transposed format.
!>          = 'N':  RFP format is Normal;
!>          = 'T':  RFP format is Transpose.
!>
[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:
!>           = 'U': RFP A came from an upper triangular matrix;
!>           = '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, SLANSF is
!>          set to zero.
!>
[in]A
!>          A is REAL array, dimension ( N*(N+1)/2 );
!>          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
!>          part of the symmetric matrix A stored in RFP format. See the
!>           below for more details.
!>          Unchanged on exit.
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!>          WORK is not referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  We first consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last three columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 then consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last two columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 208 of file slansf.f.

209*
210* -- LAPACK computational routine --
211* -- LAPACK is a software package provided by Univ. of Tennessee, --
212* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
213*
214* .. Scalar Arguments ..
215 CHARACTER NORM, TRANSR, UPLO
216 INTEGER N
217* ..
218* .. Array Arguments ..
219 REAL A( 0: * ), WORK( 0: * )
220* ..
221*
222* =====================================================================
223*
224* ..
225* .. Parameters ..
226 REAL ONE, ZERO
227 parameter( one = 1.0e+0, zero = 0.0e+0 )
228* ..
229* .. Local Scalars ..
230 INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA
231 REAL SCALE, S, VALUE, AA, TEMP
232* ..
233* .. External Functions ..
234 LOGICAL LSAME, SISNAN
235 EXTERNAL lsame, sisnan
236* ..
237* .. External Subroutines ..
238 EXTERNAL slassq
239* ..
240* .. Intrinsic Functions ..
241 INTRINSIC abs, sqrt
242* ..
243* .. Executable Statements ..
244*
245 IF( n.EQ.0 ) THEN
246 slansf = zero
247 RETURN
248 ELSE IF( n.EQ.1 ) THEN
249 slansf = abs( a(0) )
250 RETURN
251 END IF
252*
253* set noe = 1 if n is odd. if n is even set noe=0
254*
255 noe = 1
256 IF( mod( n, 2 ).EQ.0 )
257 $ noe = 0
258*
259* set ifm = 0 when form='T or 't' and 1 otherwise
260*
261 ifm = 1
262 IF( lsame( transr, 'T' ) )
263 $ ifm = 0
264*
265* set ilu = 0 when uplo='U or 'u' and 1 otherwise
266*
267 ilu = 1
268 IF( lsame( uplo, 'U' ) )
269 $ ilu = 0
270*
271* set lda = (n+1)/2 when ifm = 0
272* set lda = n when ifm = 1 and noe = 1
273* set lda = n+1 when ifm = 1 and noe = 0
274*
275 IF( ifm.EQ.1 ) THEN
276 IF( noe.EQ.1 ) THEN
277 lda = n
278 ELSE
279* noe=0
280 lda = n + 1
281 END IF
282 ELSE
283* ifm=0
284 lda = ( n+1 ) / 2
285 END IF
286*
287 IF( lsame( norm, 'M' ) ) THEN
288*
289* Find max(abs(A(i,j))).
290*
291 k = ( n+1 ) / 2
292 VALUE = zero
293 IF( noe.EQ.1 ) THEN
294* n is odd
295 IF( ifm.EQ.1 ) THEN
296* A is n by k
297 DO j = 0, k - 1
298 DO i = 0, n - 1
299 temp = abs( a( i+j*lda ) )
300 IF( VALUE .LT. temp .OR. sisnan( temp ) )
301 $ VALUE = temp
302 END DO
303 END DO
304 ELSE
305* xpose case; A is k by n
306 DO j = 0, n - 1
307 DO i = 0, k - 1
308 temp = abs( a( i+j*lda ) )
309 IF( VALUE .LT. temp .OR. sisnan( temp ) )
310 $ VALUE = temp
311 END DO
312 END DO
313 END IF
314 ELSE
315* n is even
316 IF( ifm.EQ.1 ) THEN
317* A is n+1 by k
318 DO j = 0, k - 1
319 DO i = 0, n
320 temp = abs( a( i+j*lda ) )
321 IF( VALUE .LT. temp .OR. sisnan( temp ) )
322 $ VALUE = temp
323 END DO
324 END DO
325 ELSE
326* xpose case; A is k by n+1
327 DO j = 0, n
328 DO i = 0, k - 1
329 temp = abs( a( i+j*lda ) )
330 IF( VALUE .LT. temp .OR. sisnan( temp ) )
331 $ VALUE = temp
332 END DO
333 END DO
334 END IF
335 END IF
336 ELSE IF( ( lsame( norm, 'I' ) ) .OR. ( lsame( norm, 'O' ) ) .OR.
337 $ ( norm.EQ.'1' ) ) THEN
338*
339* Find normI(A) ( = norm1(A), since A is symmetric).
340*
341 IF( ifm.EQ.1 ) THEN
342 k = n / 2
343 IF( noe.EQ.1 ) THEN
344* n is odd
345 IF( ilu.EQ.0 ) THEN
346 DO i = 0, k - 1
347 work( i ) = zero
348 END DO
349 DO j = 0, k
350 s = zero
351 DO i = 0, k + j - 1
352 aa = abs( a( i+j*lda ) )
353* -> A(i,j+k)
354 s = s + aa
355 work( i ) = work( i ) + aa
356 END DO
357 aa = abs( a( i+j*lda ) )
358* -> A(j+k,j+k)
359 work( j+k ) = s + aa
360 IF( i.EQ.k+k )
361 $ GO TO 10
362 i = i + 1
363 aa = abs( a( i+j*lda ) )
364* -> A(j,j)
365 work( j ) = work( j ) + aa
366 s = zero
367 DO l = j + 1, k - 1
368 i = i + 1
369 aa = abs( a( i+j*lda ) )
370* -> A(l,j)
371 s = s + aa
372 work( l ) = work( l ) + aa
373 END DO
374 work( j ) = work( j ) + s
375 END DO
376 10 CONTINUE
377 VALUE = work( 0 )
378 DO i = 1, n-1
379 temp = work( i )
380 IF( VALUE .LT. temp .OR. sisnan( temp ) )
381 $ VALUE = temp
382 END DO
383 ELSE
384* ilu = 1
385 k = k + 1
386* k=(n+1)/2 for n odd and ilu=1
387 DO i = k, n - 1
388 work( i ) = zero
389 END DO
390 DO j = k - 1, 0, -1
391 s = zero
392 DO i = 0, j - 2
393 aa = abs( a( i+j*lda ) )
394* -> A(j+k,i+k)
395 s = s + aa
396 work( i+k ) = work( i+k ) + aa
397 END DO
398 IF( j.GT.0 ) THEN
399 aa = abs( a( i+j*lda ) )
400* -> A(j+k,j+k)
401 s = s + aa
402 work( i+k ) = work( i+k ) + s
403* i=j
404 i = i + 1
405 END IF
406 aa = abs( a( i+j*lda ) )
407* -> A(j,j)
408 work( j ) = aa
409 s = zero
410 DO l = j + 1, n - 1
411 i = i + 1
412 aa = abs( a( i+j*lda ) )
413* -> A(l,j)
414 s = s + aa
415 work( l ) = work( l ) + aa
416 END DO
417 work( j ) = work( j ) + s
418 END DO
419 VALUE = work( 0 )
420 DO i = 1, n-1
421 temp = work( i )
422 IF( VALUE .LT. temp .OR. sisnan( temp ) )
423 $ VALUE = temp
424 END DO
425 END IF
426 ELSE
427* n is even
428 IF( ilu.EQ.0 ) THEN
429 DO i = 0, k - 1
430 work( i ) = zero
431 END DO
432 DO j = 0, k - 1
433 s = zero
434 DO i = 0, k + j - 1
435 aa = abs( a( i+j*lda ) )
436* -> A(i,j+k)
437 s = s + aa
438 work( i ) = work( i ) + aa
439 END DO
440 aa = abs( a( i+j*lda ) )
441* -> A(j+k,j+k)
442 work( j+k ) = s + aa
443 i = i + 1
444 aa = abs( a( i+j*lda ) )
445* -> A(j,j)
446 work( j ) = work( j ) + aa
447 s = zero
448 DO l = j + 1, k - 1
449 i = i + 1
450 aa = abs( a( i+j*lda ) )
451* -> A(l,j)
452 s = s + aa
453 work( l ) = work( l ) + aa
454 END DO
455 work( j ) = work( j ) + s
456 END DO
457 VALUE = work( 0 )
458 DO i = 1, n-1
459 temp = work( i )
460 IF( VALUE .LT. temp .OR. sisnan( temp ) )
461 $ VALUE = temp
462 END DO
463 ELSE
464* ilu = 1
465 DO i = k, n - 1
466 work( i ) = zero
467 END DO
468 DO j = k - 1, 0, -1
469 s = zero
470 DO i = 0, j - 1
471 aa = abs( a( i+j*lda ) )
472* -> A(j+k,i+k)
473 s = s + aa
474 work( i+k ) = work( i+k ) + aa
475 END DO
476 aa = abs( a( i+j*lda ) )
477* -> A(j+k,j+k)
478 s = s + aa
479 work( i+k ) = work( i+k ) + s
480* i=j
481 i = i + 1
482 aa = abs( a( i+j*lda ) )
483* -> A(j,j)
484 work( j ) = aa
485 s = zero
486 DO l = j + 1, n - 1
487 i = i + 1
488 aa = abs( a( i+j*lda ) )
489* -> A(l,j)
490 s = s + aa
491 work( l ) = work( l ) + aa
492 END DO
493 work( j ) = work( j ) + s
494 END DO
495 VALUE = work( 0 )
496 DO i = 1, n-1
497 temp = work( i )
498 IF( VALUE .LT. temp .OR. sisnan( temp ) )
499 $ VALUE = temp
500 END DO
501 END IF
502 END IF
503 ELSE
504* ifm=0
505 k = n / 2
506 IF( noe.EQ.1 ) THEN
507* n is odd
508 IF( ilu.EQ.0 ) THEN
509 n1 = k
510* n/2
511 k = k + 1
512* k is the row size and lda
513 DO i = n1, n - 1
514 work( i ) = zero
515 END DO
516 DO j = 0, n1 - 1
517 s = zero
518 DO i = 0, k - 1
519 aa = abs( a( i+j*lda ) )
520* A(j,n1+i)
521 work( i+n1 ) = work( i+n1 ) + aa
522 s = s + aa
523 END DO
524 work( j ) = s
525 END DO
526* j=n1=k-1 is special
527 s = abs( a( 0+j*lda ) )
528* A(k-1,k-1)
529 DO i = 1, k - 1
530 aa = abs( a( i+j*lda ) )
531* A(k-1,i+n1)
532 work( i+n1 ) = work( i+n1 ) + aa
533 s = s + aa
534 END DO
535 work( j ) = work( j ) + s
536 DO j = k, n - 1
537 s = zero
538 DO i = 0, j - k - 1
539 aa = abs( a( i+j*lda ) )
540* A(i,j-k)
541 work( i ) = work( i ) + aa
542 s = s + aa
543 END DO
544* i=j-k
545 aa = abs( a( i+j*lda ) )
546* A(j-k,j-k)
547 s = s + aa
548 work( j-k ) = work( j-k ) + s
549 i = i + 1
550 s = abs( a( i+j*lda ) )
551* A(j,j)
552 DO l = j + 1, n - 1
553 i = i + 1
554 aa = abs( a( i+j*lda ) )
555* A(j,l)
556 work( l ) = work( l ) + aa
557 s = s + aa
558 END DO
559 work( j ) = work( j ) + s
560 END DO
561 VALUE = work( 0 )
562 DO i = 1, n-1
563 temp = work( i )
564 IF( VALUE .LT. temp .OR. sisnan( temp ) )
565 $ VALUE = temp
566 END DO
567 ELSE
568* ilu=1
569 k = k + 1
570* k=(n+1)/2 for n odd and ilu=1
571 DO i = k, n - 1
572 work( i ) = zero
573 END DO
574 DO j = 0, k - 2
575* process
576 s = zero
577 DO i = 0, j - 1
578 aa = abs( a( i+j*lda ) )
579* A(j,i)
580 work( i ) = work( i ) + aa
581 s = s + aa
582 END DO
583 aa = abs( a( i+j*lda ) )
584* i=j so process of A(j,j)
585 s = s + aa
586 work( j ) = s
587* is initialised here
588 i = i + 1
589* i=j process A(j+k,j+k)
590 aa = abs( a( i+j*lda ) )
591 s = aa
592 DO l = k + j + 1, n - 1
593 i = i + 1
594 aa = abs( a( i+j*lda ) )
595* A(l,k+j)
596 s = s + aa
597 work( l ) = work( l ) + aa
598 END DO
599 work( k+j ) = work( k+j ) + s
600 END DO
601* j=k-1 is special :process col A(k-1,0:k-1)
602 s = zero
603 DO i = 0, k - 2
604 aa = abs( a( i+j*lda ) )
605* A(k,i)
606 work( i ) = work( i ) + aa
607 s = s + aa
608 END DO
609* i=k-1
610 aa = abs( a( i+j*lda ) )
611* A(k-1,k-1)
612 s = s + aa
613 work( i ) = s
614* done with col j=k+1
615 DO j = k, n - 1
616* process col j of A = A(j,0:k-1)
617 s = zero
618 DO i = 0, k - 1
619 aa = abs( a( i+j*lda ) )
620* A(j,i)
621 work( i ) = work( i ) + aa
622 s = s + aa
623 END DO
624 work( j ) = work( j ) + s
625 END DO
626 VALUE = work( 0 )
627 DO i = 1, n-1
628 temp = work( i )
629 IF( VALUE .LT. temp .OR. sisnan( temp ) )
630 $ VALUE = temp
631 END DO
632 END IF
633 ELSE
634* n is even
635 IF( ilu.EQ.0 ) THEN
636 DO i = k, n - 1
637 work( i ) = zero
638 END DO
639 DO j = 0, k - 1
640 s = zero
641 DO i = 0, k - 1
642 aa = abs( a( i+j*lda ) )
643* A(j,i+k)
644 work( i+k ) = work( i+k ) + aa
645 s = s + aa
646 END DO
647 work( j ) = s
648 END DO
649* j=k
650 aa = abs( a( 0+j*lda ) )
651* A(k,k)
652 s = aa
653 DO i = 1, k - 1
654 aa = abs( a( i+j*lda ) )
655* A(k,k+i)
656 work( i+k ) = work( i+k ) + aa
657 s = s + aa
658 END DO
659 work( j ) = work( j ) + s
660 DO j = k + 1, n - 1
661 s = zero
662 DO i = 0, j - 2 - k
663 aa = abs( a( i+j*lda ) )
664* A(i,j-k-1)
665 work( i ) = work( i ) + aa
666 s = s + aa
667 END DO
668* i=j-1-k
669 aa = abs( a( i+j*lda ) )
670* A(j-k-1,j-k-1)
671 s = s + aa
672 work( j-k-1 ) = work( j-k-1 ) + s
673 i = i + 1
674 aa = abs( a( i+j*lda ) )
675* A(j,j)
676 s = aa
677 DO l = j + 1, n - 1
678 i = i + 1
679 aa = abs( a( i+j*lda ) )
680* A(j,l)
681 work( l ) = work( l ) + aa
682 s = s + aa
683 END DO
684 work( j ) = work( j ) + s
685 END DO
686* j=n
687 s = zero
688 DO i = 0, k - 2
689 aa = abs( a( i+j*lda ) )
690* A(i,k-1)
691 work( i ) = work( i ) + aa
692 s = s + aa
693 END DO
694* i=k-1
695 aa = abs( a( i+j*lda ) )
696* A(k-1,k-1)
697 s = s + aa
698 work( i ) = work( i ) + s
699 VALUE = work( 0 )
700 DO i = 1, n-1
701 temp = work( i )
702 IF( VALUE .LT. temp .OR. sisnan( temp ) )
703 $ VALUE = temp
704 END DO
705 ELSE
706* ilu=1
707 DO i = k, n - 1
708 work( i ) = zero
709 END DO
710* j=0 is special :process col A(k:n-1,k)
711 s = abs( a( 0 ) )
712* A(k,k)
713 DO i = 1, k - 1
714 aa = abs( a( i ) )
715* A(k+i,k)
716 work( i+k ) = work( i+k ) + aa
717 s = s + aa
718 END DO
719 work( k ) = work( k ) + s
720 DO j = 1, k - 1
721* process
722 s = zero
723 DO i = 0, j - 2
724 aa = abs( a( i+j*lda ) )
725* A(j-1,i)
726 work( i ) = work( i ) + aa
727 s = s + aa
728 END DO
729 aa = abs( a( i+j*lda ) )
730* i=j-1 so process of A(j-1,j-1)
731 s = s + aa
732 work( j-1 ) = s
733* is initialised here
734 i = i + 1
735* i=j process A(j+k,j+k)
736 aa = abs( a( i+j*lda ) )
737 s = aa
738 DO l = k + j + 1, n - 1
739 i = i + 1
740 aa = abs( a( i+j*lda ) )
741* A(l,k+j)
742 s = s + aa
743 work( l ) = work( l ) + aa
744 END DO
745 work( k+j ) = work( k+j ) + s
746 END DO
747* j=k is special :process col A(k,0:k-1)
748 s = zero
749 DO i = 0, k - 2
750 aa = abs( a( i+j*lda ) )
751* A(k,i)
752 work( i ) = work( i ) + aa
753 s = s + aa
754 END DO
755* i=k-1
756 aa = abs( a( i+j*lda ) )
757* A(k-1,k-1)
758 s = s + aa
759 work( i ) = s
760* done with col j=k+1
761 DO j = k + 1, n
762* process col j-1 of A = A(j-1,0:k-1)
763 s = zero
764 DO i = 0, k - 1
765 aa = abs( a( i+j*lda ) )
766* A(j-1,i)
767 work( i ) = work( i ) + aa
768 s = s + aa
769 END DO
770 work( j-1 ) = work( j-1 ) + s
771 END DO
772 VALUE = work( 0 )
773 DO i = 1, n-1
774 temp = work( i )
775 IF( VALUE .LT. temp .OR. sisnan( temp ) )
776 $ VALUE = temp
777 END DO
778 END IF
779 END IF
780 END IF
781 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
782*
783* Find normF(A).
784*
785 k = ( n+1 ) / 2
786 scale = zero
787 s = one
788 IF( noe.EQ.1 ) THEN
789* n is odd
790 IF( ifm.EQ.1 ) THEN
791* A is normal
792 IF( ilu.EQ.0 ) THEN
793* A is upper
794 DO j = 0, k - 3
795 CALL slassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s )
796* L at A(k,0)
797 END DO
798 DO j = 0, k - 1
799 CALL slassq( k+j-1, a( 0+j*lda ), 1, scale, s )
800* trap U at A(0,0)
801 END DO
802 s = s + s
803* double s for the off diagonal elements
804 CALL slassq( k-1, a( k ), lda+1, scale, s )
805* tri L at A(k,0)
806 CALL slassq( k, a( k-1 ), lda+1, scale, s )
807* tri U at A(k-1,0)
808 ELSE
809* ilu=1 & A is lower
810 DO j = 0, k - 1
811 CALL slassq( n-j-1, a( j+1+j*lda ), 1, scale, s )
812* trap L at A(0,0)
813 END DO
814 DO j = 0, k - 2
815 CALL slassq( j, a( 0+( 1+j )*lda ), 1, scale, s )
816* U at A(0,1)
817 END DO
818 s = s + s
819* double s for the off diagonal elements
820 CALL slassq( k, a( 0 ), lda+1, scale, s )
821* tri L at A(0,0)
822 CALL slassq( k-1, a( 0+lda ), lda+1, scale, s )
823* tri U at A(0,1)
824 END IF
825 ELSE
826* A is xpose
827 IF( ilu.EQ.0 ) THEN
828* A**T is upper
829 DO j = 1, k - 2
830 CALL slassq( j, a( 0+( k+j )*lda ), 1, scale, s )
831* U at A(0,k)
832 END DO
833 DO j = 0, k - 2
834 CALL slassq( k, a( 0+j*lda ), 1, scale, s )
835* k by k-1 rect. at A(0,0)
836 END DO
837 DO j = 0, k - 2
838 CALL slassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,
839 $ scale, s )
840* L at A(0,k-1)
841 END DO
842 s = s + s
843* double s for the off diagonal elements
844 CALL slassq( k-1, a( 0+k*lda ), lda+1, scale, s )
845* tri U at A(0,k)
846 CALL slassq( k, a( 0+( k-1 )*lda ), lda+1, scale, s )
847* tri L at A(0,k-1)
848 ELSE
849* A**T is lower
850 DO j = 1, k - 1
851 CALL slassq( j, a( 0+j*lda ), 1, scale, s )
852* U at A(0,0)
853 END DO
854 DO j = k, n - 1
855 CALL slassq( k, a( 0+j*lda ), 1, scale, s )
856* k by k-1 rect. at A(0,k)
857 END DO
858 DO j = 0, k - 3
859 CALL slassq( k-j-2, a( j+2+j*lda ), 1, scale, s )
860* L at A(1,0)
861 END DO
862 s = s + s
863* double s for the off diagonal elements
864 CALL slassq( k, a( 0 ), lda+1, scale, s )
865* tri U at A(0,0)
866 CALL slassq( k-1, a( 1 ), lda+1, scale, s )
867* tri L at A(1,0)
868 END IF
869 END IF
870 ELSE
871* n is even
872 IF( ifm.EQ.1 ) THEN
873* A is normal
874 IF( ilu.EQ.0 ) THEN
875* A is upper
876 DO j = 0, k - 2
877 CALL slassq( k-j-1, a( k+j+2+j*lda ), 1, scale, s )
878* L at A(k+1,0)
879 END DO
880 DO j = 0, k - 1
881 CALL slassq( k+j, a( 0+j*lda ), 1, scale, s )
882* trap U at A(0,0)
883 END DO
884 s = s + s
885* double s for the off diagonal elements
886 CALL slassq( k, a( k+1 ), lda+1, scale, s )
887* tri L at A(k+1,0)
888 CALL slassq( k, a( k ), lda+1, scale, s )
889* tri U at A(k,0)
890 ELSE
891* ilu=1 & A is lower
892 DO j = 0, k - 1
893 CALL slassq( n-j-1, a( j+2+j*lda ), 1, scale, s )
894* trap L at A(1,0)
895 END DO
896 DO j = 1, k - 1
897 CALL slassq( j, a( 0+j*lda ), 1, scale, s )
898* U at A(0,0)
899 END DO
900 s = s + s
901* double s for the off diagonal elements
902 CALL slassq( k, a( 1 ), lda+1, scale, s )
903* tri L at A(1,0)
904 CALL slassq( k, a( 0 ), lda+1, scale, s )
905* tri U at A(0,0)
906 END IF
907 ELSE
908* A is xpose
909 IF( ilu.EQ.0 ) THEN
910* A**T is upper
911 DO j = 1, k - 1
912 CALL slassq( j, a( 0+( k+1+j )*lda ), 1, scale, s )
913* U at A(0,k+1)
914 END DO
915 DO j = 0, k - 1
916 CALL slassq( k, a( 0+j*lda ), 1, scale, s )
917* k by k rect. at A(0,0)
918 END DO
919 DO j = 0, k - 2
920 CALL slassq( k-j-1, a( j+1+( j+k )*lda ), 1, scale,
921 $ s )
922* L at A(0,k)
923 END DO
924 s = s + s
925* double s for the off diagonal elements
926 CALL slassq( k, a( 0+( k+1 )*lda ), lda+1, scale, s )
927* tri U at A(0,k+1)
928 CALL slassq( k, a( 0+k*lda ), lda+1, scale, s )
929* tri L at A(0,k)
930 ELSE
931* A**T is lower
932 DO j = 1, k - 1
933 CALL slassq( j, a( 0+( j+1 )*lda ), 1, scale, s )
934* U at A(0,1)
935 END DO
936 DO j = k + 1, n
937 CALL slassq( k, a( 0+j*lda ), 1, scale, s )
938* k by k rect. at A(0,k+1)
939 END DO
940 DO j = 0, k - 2
941 CALL slassq( k-j-1, a( j+1+j*lda ), 1, scale, s )
942* L at A(0,0)
943 END DO
944 s = s + s
945* double s for the off diagonal elements
946 CALL slassq( k, a( lda ), lda+1, scale, s )
947* tri L at A(0,1)
948 CALL slassq( k, a( 0 ), lda+1, scale, s )
949* tri U at A(0,0)
950 END IF
951 END IF
952 END IF
953 VALUE = scale*sqrt( s )
954 END IF
955*
956 slansf = VALUE
957 RETURN
958*
959* End of SLANSF
960*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
slansf
real function slansf(norm, transr, uplo, n, a, work)
SLANSF
Definition slansf.f:209

◆ slarscl2()

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

SLARSCL2 performs reciprocal diagonal scaling on a vector.

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

Purpose:
!>
!> SLARSCL2 performs a reciprocal diagonal scaling on an vector:
!>   x <-- inv(D) * x
!> where the diagonal matrix D is stored as a vector.
!>
!> Eventually to be replaced by BLAS_sge_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 REAL 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 89 of file slarscl2.f.

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

◆ slarz()

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

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

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

Purpose:
!>
!> SLARZ applies a real elementary reflector H to a real M-by-N
!> matrix C, from either the left or the right. H is represented in the
!> form
!>
!>       H = I - tau * v * v**T
!>
!> where tau is a real scalar and v is a real vector.
!>
!> If tau = 0, then H is taken to be the unit matrix.
!>
!>
!> H is a product of k elementary reflectors as returned by STZRZF.
!>
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 REAL array, dimension (1+(L-1)*abs(INCV))
!>          The vector v in the representation of H as returned by
!>          STZRZF. V is not used if TAU = 0.
!>
[in]INCV
!>          INCV is INTEGER
!>          The increment between elements of v. INCV <> 0.
!>
[in]TAU
!>          TAU is REAL
!>          The value tau in the representation of H.
!>
[in,out]C
!>          C is REAL 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 REAL 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 144 of file slarz.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 CHARACTER SIDE
152 INTEGER INCV, L, LDC, M, N
153 REAL TAU
154* ..
155* .. Array Arguments ..
156 REAL C( LDC, * ), V( * ), WORK( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 REAL ONE, ZERO
163 parameter( one = 1.0e+0, zero = 0.0e+0 )
164* ..
165* .. External Subroutines ..
166 EXTERNAL saxpy, scopy, sgemv, sger
167* ..
168* .. External Functions ..
169 LOGICAL LSAME
170 EXTERNAL lsame
171* ..
172* .. Executable Statements ..
173*
174 IF( lsame( side, 'L' ) ) THEN
175*
176* Form H * C
177*
178 IF( tau.NE.zero ) THEN
179*
180* w( 1:n ) = C( 1, 1:n )
181*
182 CALL scopy( n, c, ldc, work, 1 )
183*
184* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )**T * v( 1:l )
185*
186 CALL sgemv( 'Transpose', l, n, one, c( m-l+1, 1 ), ldc, v,
187 $ incv, one, work, 1 )
188*
189* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
190*
191 CALL saxpy( n, -tau, work, 1, c, ldc )
192*
193* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
194* tau * v( 1:l ) * w( 1:n )**T
195*
196 CALL sger( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),
197 $ ldc )
198 END IF
199*
200 ELSE
201*
202* Form C * H
203*
204 IF( tau.NE.zero ) THEN
205*
206* w( 1:m ) = C( 1:m, 1 )
207*
208 CALL scopy( m, c, 1, work, 1 )
209*
210* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
211*
212 CALL sgemv( 'No transpose', m, l, one, c( 1, n-l+1 ), ldc,
213 $ v, incv, one, work, 1 )
214*
215* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )
216*
217 CALL saxpy( m, -tau, work, 1, c, 1 )
218*
219* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
220* tau * w( 1:m ) * v( 1:l )**T
221*
222 CALL sger( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),
223 $ ldc )
224*
225 END IF
226*
227 END IF
228*
229 RETURN
230*
231* End of SLARZ
232*
sger
subroutine sger(m, n, alpha, x, incx, y, incy, a, lda)
SGER
Definition sger.f:130

◆ slarzb()

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

SLARZB applies a block reflector or its transpose to a general matrix.

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

Purpose:
!>
!> SLARZB applies a real block reflector H or its transpose H**T to
!> a real 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**T from the Left
!>          = 'R': apply H or H**T from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply H (No transpose)
!>          = 'C': apply H**T (Transpose)
!>
[in]DIRECT
!>          DIRECT is CHARACTER*1
!>          Indicates how H is formed from a product of elementary
!>          reflectors
!>          = 'F': H = H(1) H(2) . . . H(k) (Forward, 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 REAL 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 REAL 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 REAL array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is REAL 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 slarzb.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 REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
194 $ WORK( LDWORK, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 REAL ONE
201 parameter( one = 1.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 scopy, sgemm, strmm, 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( 'SLARZB', -info )
231 RETURN
232 END IF
233*
234 IF( lsame( trans, 'N' ) ) THEN
235 transt = 'T'
236 ELSE
237 transt = 'N'
238 END IF
239*
240 IF( lsame( side, 'L' ) ) THEN
241*
242* Form H * C or H**T * C
243*
244* W( 1:n, 1:k ) = C( 1:k, 1:n )**T
245*
246 DO 10 j = 1, k
247 CALL scopy( 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 )**T * V( 1:k, 1:l )**T
252*
253 IF( l.GT.0 )
254 $ CALL sgemm( 'Transpose', 'Transpose', n, k, l, one,
255 $ c( m-l+1, 1 ), ldc, v, ldv, one, work, ldwork )
256*
257* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T**T or W( 1:m, 1:k ) * T
258*
259 CALL strmm( 'Right', 'Lower', transt, 'Non-unit', n, k, one, t,
260 $ ldt, work, ldwork )
261*
262* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )**T
263*
264 DO 30 j = 1, n
265 DO 20 i = 1, k
266 c( i, j ) = c( i, j ) - work( j, i )
267 20 CONTINUE
268 30 CONTINUE
269*
270* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
271* V( 1:k, 1:l )**T * W( 1:n, 1:k )**T
272*
273 IF( l.GT.0 )
274 $ CALL sgemm( 'Transpose', 'Transpose', l, n, k, -one, v, ldv,
275 $ work, ldwork, one, c( m-l+1, 1 ), ldc )
276*
277 ELSE IF( lsame( side, 'R' ) ) THEN
278*
279* Form C * H or C * H**T
280*
281* W( 1:m, 1:k ) = C( 1:m, 1:k )
282*
283 DO 40 j = 1, k
284 CALL scopy( m, c( 1, j ), 1, work( 1, j ), 1 )
285 40 CONTINUE
286*
287* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
288* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )**T
289*
290 IF( l.GT.0 )
291 $ CALL sgemm( 'No transpose', 'Transpose', m, k, l, one,
292 $ c( 1, n-l+1 ), ldc, v, ldv, one, work, ldwork )
293*
294* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T**T
295*
296 CALL strmm( 'Right', 'Lower', trans, 'Non-unit', m, k, one, t,
297 $ ldt, work, ldwork )
298*
299* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
300*
301 DO 60 j = 1, k
302 DO 50 i = 1, m
303 c( i, j ) = c( i, j ) - work( i, j )
304 50 CONTINUE
305 60 CONTINUE
306*
307* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
308* W( 1:m, 1:k ) * V( 1:k, 1:l )
309*
310 IF( l.GT.0 )
311 $ CALL sgemm( 'No transpose', 'No transpose', m, l, k, -one,
312 $ work, ldwork, v, ldv, one, c( 1, n-l+1 ), ldc )
313*
314 END IF
315*
316 RETURN
317*
318* End of SLARZB
319*
strmm
subroutine strmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRMM
Definition strmm.f:177

◆ slarzt()

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

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

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

Purpose:
!>
!> SLARZT forms the triangular factor T of a real block reflector
!> H of order > n, which is defined as a product of k elementary
!> reflectors.
!>
!> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!>
!> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!>
!> If STOREV = 'C', the vector which defines the elementary reflector
!> H(i) is stored in the i-th column of the array V, and
!>
!>    H  =  I - V * T * V**T
!>
!> If STOREV = 'R', the vector which defines the elementary reflector
!> H(i) is stored in the i-th row of the array V, and
!>
!>    H  =  I - V**T * T * V
!>
!> 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 REAL 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i).
!>
[out]T
!>          T is REAL 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 slarzt.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 REAL T( LDT, * ), TAU( * ), V( LDV, * )
196* ..
197*
198* =====================================================================
199*
200* .. Parameters ..
201 REAL ZERO
202 parameter( zero = 0.0e+0 )
203* ..
204* .. Local Scalars ..
205 INTEGER I, INFO, J
206* ..
207* .. External Subroutines ..
208 EXTERNAL sgemv, strmv, 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( 'SLARZT', -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)**T
244*
245 CALL sgemv( 'No transpose', k-i, n, -tau( i ),
246 $ v( i+1, 1 ), ldv, v( i, 1 ), ldv, zero,
247 $ t( i+1, i ), 1 )
248*
249* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)
250*
251 CALL strmv( 'Lower', 'No transpose', 'Non-unit', k-i,
252 $ t( i+1, i+1 ), ldt, t( i+1, i ), 1 )
253 END IF
254 t( i, i ) = tau( i )
255 END IF
256 20 CONTINUE
257 RETURN
258*
259* End of SLARZT
260*

◆ slascl2()

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

SLASCL2 performs diagonal scaling on a vector.

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

Purpose:
!>
!> SLASCL2 performs a diagonal scaling on a vector:
!>   x <-- D * x
!> where the diagonal matrix D is stored as a vector.
!>
!> Eventually to be replaced by BLAS_sge_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 REAL 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 89 of file slascl2.f.

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

◆ slatrz()

subroutine slatrz ( integer m,
integer n,
integer l,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work )

SLATRZ factors an upper trapezoidal matrix by means of orthogonal transformations.

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

Purpose:
!>
!> SLATRZ factors the M-by-(M+L) real upper trapezoidal matrix
!> [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z, by means
!> of orthogonal transformations.  Z is an (M+L)-by-(M+L) orthogonal
!> 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 REAL 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
!>          orthogonal 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 REAL array, dimension (M)
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is REAL 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 )**T,   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 slatrz.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 REAL A( LDA, * ), TAU( * ), WORK( * )
150* ..
151*
152* =====================================================================
153*
154* .. Parameters ..
155 REAL ZERO
156 parameter( zero = 0.0e+0 )
157* ..
158* .. Local Scalars ..
159 INTEGER I
160* ..
161* .. External Subroutines ..
162 EXTERNAL slarfg, slarz
163* ..
164* .. Executable Statements ..
165*
166* Test the input arguments
167*
168* Quick return if possible
169*
170 IF( m.EQ.0 ) THEN
171 RETURN
172 ELSE IF( m.EQ.n ) THEN
173 DO 10 i = 1, n
174 tau( i ) = zero
175 10 CONTINUE
176 RETURN
177 END IF
178*
179 DO 20 i = m, 1, -1
180*
181* Generate elementary reflector H(i) to annihilate
182* [ A(i,i) A(i,n-l+1:n) ]
183*
184 CALL slarfg( l+1, a( i, i ), a( i, n-l+1 ), lda, tau( i ) )
185*
186* Apply H(i) to A(1:i-1,i:n) from the right
187*
188 CALL slarz( 'Right', i-1, n-i+1, l, a( i, n-l+1 ), lda,
189 $ tau( i ), a( 1, i ), lda, work )
190*
191 20 CONTINUE
192*
193 RETURN
194*
195* End of SLATRZ
196*
slarfg
subroutine slarfg(n, alpha, x, incx, tau)
SLARFG generates an elementary reflector (Householder matrix).
Definition slarfg.f:106
slarz
subroutine slarz(side, m, n, l, v, incv, tau, c, ldc, work)
SLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix.
Definition slarz.f:145

◆ slatzm()

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

SLATZM

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine SORMRZ.
!>
!> SLATZM applies a Householder matrix generated by STZRQF to a matrix.
!>
!> Let P = I - tau*u*u**T,   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 REAL 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 REAL
!>          The value tau in the representation of P.
!>
[in,out]C1
!>          C1 is REAL 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 REAL 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 >= (1,M).
!>
[out]WORK
!>          WORK is REAL 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 150 of file slatzm.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 SIDE
158 INTEGER INCV, LDC, M, N
159 REAL TAU
160* ..
161* .. Array Arguments ..
162 REAL C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 REAL ONE, ZERO
169 parameter( one = 1.0e+0, zero = 0.0e+0 )
170* ..
171* .. External Subroutines ..
172 EXTERNAL saxpy, scopy, sgemv, sger
173* ..
174* .. External Functions ..
175 LOGICAL LSAME
176 EXTERNAL lsame
177* ..
178* .. Intrinsic Functions ..
179 INTRINSIC min
180* ..
181* .. Executable Statements ..
182*
183 IF( ( min( m, n ).EQ.0 ) .OR. ( tau.EQ.zero ) )
184 $ RETURN
185*
186 IF( lsame( side, 'L' ) ) THEN
187*
188* w := (C1 + v**T * C2)**T
189*
190 CALL scopy( n, c1, ldc, work, 1 )
191 CALL sgemv( 'Transpose', m-1, n, one, c2, ldc, v, incv, one,
192 $ work, 1 )
193*
194* [ C1 ] := [ C1 ] - tau* [ 1 ] * w**T
195* [ C2 ] [ C2 ] [ v ]
196*
197 CALL saxpy( n, -tau, work, 1, c1, ldc )
198 CALL sger( m-1, n, -tau, v, incv, work, 1, c2, ldc )
199*
200 ELSE IF( lsame( side, 'R' ) ) THEN
201*
202* w := C1 + C2 * v
203*
204 CALL scopy( m, c1, 1, work, 1 )
205 CALL sgemv( 'No transpose', m, n-1, one, c2, ldc, v, incv, one,
206 $ work, 1 )
207*
208* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**T]
209*
210 CALL saxpy( m, -tau, work, 1, c1, 1 )
211 CALL sger( m, n-1, -tau, work, 1, v, incv, c2, ldc )
212 END IF
213*
214 RETURN
215*
216* End of SLATZM
217*

◆ sopgtr()

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

SOPGTR

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

Purpose:
!>
!> SOPGTR generates a real orthogonal matrix Q which is defined as the
!> product of n-1 elementary reflectors H(i) of order n, as returned by
!> SSPTRD 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 SSPTRD;
!>          = 'L': Lower triangular packed storage used in previous
!>                 call to SSPTRD.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix Q. N >= 0.
!>
[in]AP
!>          AP is REAL array, dimension (N*(N+1)/2)
!>          The vectors which define the elementary reflectors, as
!>          returned by SSPTRD.
!>
[in]TAU
!>          TAU is REAL array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SSPTRD.
!>
[out]Q
!>          Q is REAL array, dimension (LDQ,N)
!>          The N-by-N orthogonal matrix Q.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= max(1,N).
!>
[out]WORK
!>          WORK is REAL 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 sopgtr.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 REAL AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 REAL ZERO, ONE
131 parameter( zero = 0.0e+0, one = 1.0e+0 )
132* ..
133* .. Local Scalars ..
134 LOGICAL UPPER
135 INTEGER I, IINFO, IJ, J
136* ..
137* .. External Functions ..
138 LOGICAL LSAME
139 EXTERNAL lsame
140* ..
141* .. External Subroutines ..
142 EXTERNAL sorg2l, sorg2r, xerbla
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC max
146* ..
147* .. Executable Statements ..
148*
149* Test the input arguments
150*
151 info = 0
152 upper = lsame( uplo, 'U' )
153 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
154 info = -1
155 ELSE IF( n.LT.0 ) THEN
156 info = -2
157 ELSE IF( ldq.LT.max( 1, n ) ) THEN
158 info = -6
159 END IF
160 IF( info.NE.0 ) THEN
161 CALL xerbla( 'SOPGTR', -info )
162 RETURN
163 END IF
164*
165* Quick return if possible
166*
167 IF( n.EQ.0 )
168 $ RETURN
169*
170 IF( upper ) THEN
171*
172* Q was determined by a call to SSPTRD with UPLO = 'U'
173*
174* Unpack the vectors which define the elementary reflectors and
175* set the last row and column of Q equal to those of the unit
176* matrix
177*
178 ij = 2
179 DO 20 j = 1, n - 1
180 DO 10 i = 1, j - 1
181 q( i, j ) = ap( ij )
182 ij = ij + 1
183 10 CONTINUE
184 ij = ij + 2
185 q( n, j ) = zero
186 20 CONTINUE
187 DO 30 i = 1, n - 1
188 q( i, n ) = zero
189 30 CONTINUE
190 q( n, n ) = one
191*
192* Generate Q(1:n-1,1:n-1)
193*
194 CALL sorg2l( n-1, n-1, n-1, q, ldq, tau, work, iinfo )
195*
196 ELSE
197*
198* Q was determined by a call to SSPTRD with UPLO = 'L'.
199*
200* Unpack the vectors which define the elementary reflectors and
201* set the first row and column of Q equal to those of the unit
202* matrix
203*
204 q( 1, 1 ) = one
205 DO 40 i = 2, n
206 q( i, 1 ) = zero
207 40 CONTINUE
208 ij = 3
209 DO 60 j = 2, n
210 q( 1, j ) = zero
211 DO 50 i = j + 1, n
212 q( i, j ) = ap( ij )
213 ij = ij + 1
214 50 CONTINUE
215 ij = ij + 2
216 60 CONTINUE
217 IF( n.GT.1 ) THEN
218*
219* Generate Q(2:n,2:n)
220*
221 CALL sorg2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,
222 $ iinfo )
223 END IF
224 END IF
225 RETURN
226*
227* End of SOPGTR
228*
sorg2l
subroutine sorg2l(m, n, k, a, lda, tau, work, info)
SORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf ...
Definition sorg2l.f:114

◆ sopmtr()

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

SOPMTR

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

Purpose:
!>
!> SOPMTR 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'. Q is defined as the product of
!> nq-1 elementary reflectors, as returned by SSPTRD 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**T from the Left;
!>          = 'R': apply Q or Q**T from the Right.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U': Upper triangular packed storage used in previous
!>                 call to SSPTRD;
!>          = 'L': Lower triangular packed storage used in previous
!>                 call to SSPTRD.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'T':  Transpose, apply Q**T.
!>
[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 REAL 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 SSPTRD.  AP is modified by the routine but
!>          restored on exit.
!>
[in]TAU
!>          TAU is REAL 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 SSPTRD.
!>
[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
!>                                   (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 sopmtr.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 REAL AP( * ), C( LDC, * ), TAU( * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 REAL ONE
167 parameter( one = 1.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 REAL AII
173* ..
174* .. External Functions ..
175 LOGICAL LSAME
176 EXTERNAL lsame
177* ..
178* .. External Subroutines ..
179 EXTERNAL slarf, xerbla
180* ..
181* .. Intrinsic Functions ..
182 INTRINSIC 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, 'T' ) ) 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( 'SOPMTR', -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 SSPTRD 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) is applied to C(1:i,1:n)
252*
253 mi = i
254 ELSE
255*
256* H(i) is applied to C(1:m,1:i)
257*
258 ni = i
259 END IF
260*
261* Apply H(i)
262*
263 aii = ap( ii )
264 ap( ii ) = one
265 CALL slarf( side, mi, ni, ap( ii-i+1 ), 1, tau( i ), c, ldc,
266 $ work )
267 ap( ii ) = aii
268*
269 IF( forwrd ) THEN
270 ii = ii + i + 2
271 ELSE
272 ii = ii - i - 1
273 END IF
274 10 CONTINUE
275 ELSE
276*
277* Q was determined by a call to SSPTRD with UPLO = 'L'.
278*
279 forwrd = ( left .AND. .NOT.notran ) .OR.
280 $ ( .NOT.left .AND. notran )
281*
282 IF( forwrd ) THEN
283 i1 = 1
284 i2 = nq - 1
285 i3 = 1
286 ii = 2
287 ELSE
288 i1 = nq - 1
289 i2 = 1
290 i3 = -1
291 ii = nq*( nq+1 ) / 2 - 1
292 END IF
293*
294 IF( left ) THEN
295 ni = n
296 jc = 1
297 ELSE
298 mi = m
299 ic = 1
300 END IF
301*
302 DO 20 i = i1, i2, i3
303 aii = ap( ii )
304 ap( ii ) = one
305 IF( left ) THEN
306*
307* H(i) is applied to C(i+1:m,1:n)
308*
309 mi = m - i
310 ic = i + 1
311 ELSE
312*
313* H(i) is applied to C(1:m,i+1:n)
314*
315 ni = n - i
316 jc = i + 1
317 END IF
318*
319* Apply H(i)
320*
321 CALL slarf( side, mi, ni, ap( ii ), 1, tau( i ),
322 $ c( ic, jc ), ldc, work )
323 ap( ii ) = aii
324*
325 IF( forwrd ) THEN
326 ii = ii + nq - i + 1
327 ELSE
328 ii = ii - nq + i - 2
329 END IF
330 20 CONTINUE
331 END IF
332 RETURN
333*
334* End of SOPMTR
335*
slarf
subroutine slarf(side, m, n, v, incv, tau, c, ldc, work)
SLARF applies an elementary reflector to a general rectangular matrix.
Definition slarf.f:124
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ sorbdb()

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

SORBDB

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

Purpose:
!>
!> SORBDB simultaneously bidiagonalizes the blocks of an M-by-M
!> partitioned orthogonal matrix X:
!>
!>                                 [ B11 | B12 0  0 ]
!>     [ X11 | X12 ]   [ P1 |    ] [  0  |  0 -I  0 ] [ Q1 |    ]**T
!> 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 SORCSD
!> for details.)
!>
!> The orthogonal 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 REAL array, dimension (LDX11,Q)
!>          On entry, the top-left block of the orthogonal 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 REAL array, dimension (LDX12,M-Q)
!>          On entry, the top-right block of the orthogonal 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 REAL array, dimension (LDX21,Q)
!>          On entry, the bottom-left block of the orthogonal 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 REAL array, dimension (LDX22,M-Q)
!>          On entry, the bottom-right block of the orthogonal 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 REAL array, dimension (P)
!>          The scalar factors of the elementary reflectors that define
!>          P1.
!>
[out]TAUP2
!>          TAUP2 is REAL array, dimension (M-P)
!>          The scalar factors of the elementary reflectors that define
!>          P2.
!>
[out]TAUQ1
!>          TAUQ1 is REAL array, dimension (Q)
!>          The scalar factors of the elementary reflectors that define
!>          Q1.
!>
[out]TAUQ2
!>          TAUQ2 is REAL array, dimension (M-Q)
!>          The scalar factors of the elementary reflectors that define
!>          Q2.
!>
[out]WORK
!>          WORK is REAL 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 SORCSD for details.
!>
!>  P1, P2, Q1, and Q2 are represented as products of elementary
!>  reflectors. See SORCSD for details on generating P1, P2, Q1, and Q2
!>  using SORGQR and SORGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

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

◆ sorbdb1()

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

SORBDB1

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

Purpose:
!>
!> SORBDB1 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 SORBDB2, SORBDB3, and SORBDB4 handle cases in
!> which Q is not the minimum dimension.
!>
!> The orthogonal 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 REAL 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 REAL 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 REAL array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is REAL array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is REAL array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is REAL 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 SORCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
!>  and SORGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 201 of file sorbdb1.f.

203*
204* -- LAPACK computational routine --
205* -- LAPACK is a software package provided by Univ. of Tennessee, --
206* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
207*
208* .. Scalar Arguments ..
209 INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
210* ..
211* .. Array Arguments ..
212 REAL PHI(*), THETA(*)
213 REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
214 $ X11(LDX11,*), X21(LDX21,*)
215* ..
216*
217* ====================================================================
218*
219* .. Parameters ..
220 REAL ONE
221 parameter( one = 1.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 slarf, slarfgp, sorbdb5, srot, xerbla
231* ..
232* .. External Functions ..
233 REAL SNRM2
234 EXTERNAL snrm2
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( 'SORBDB1', -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 slarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
284 CALL slarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
285 theta(i) = atan2( x21(i,i), 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 slarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),
291 $ ldx11, work(ilarf) )
292 CALL slarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),
293 $ x21(i,i+1), ldx21, work(ilarf) )
294*
295 IF( i .LT. q ) THEN
296 CALL srot( q-i, x11(i,i+1), ldx11, x21(i,i+1), ldx21, c, s )
297 CALL slarfgp( q-i, x21(i,i+1), x21(i,i+2), ldx21, tauq1(i) )
298 s = x21(i,i+1)
299 x21(i,i+1) = one
300 CALL slarf( 'R', p-i, q-i, x21(i,i+1), ldx21, tauq1(i),
301 $ x11(i+1,i+1), ldx11, work(ilarf) )
302 CALL slarf( 'R', m-p-i, q-i, x21(i,i+1), ldx21, tauq1(i),
303 $ x21(i+1,i+1), ldx21, work(ilarf) )
304 c = sqrt( snrm2( p-i, x11(i+1,i+1), 1 )**2
305 $ + snrm2( m-p-i, x21(i+1,i+1), 1 )**2 )
306 phi(i) = atan2( s, c )
307 CALL sorbdb5( p-i, m-p-i, q-i-1, x11(i+1,i+1), 1,
308 $ x21(i+1,i+1), 1, x11(i+1,i+2), ldx11,
309 $ x21(i+1,i+2), ldx21, work(iorbdb5), lorbdb5,
310 $ childinfo )
311 END IF
312*
313 END DO
314*
315 RETURN
316*
317* End of SORBDB1
318*
sorbdb5
subroutine sorbdb5(m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
SORBDB5
Definition sorbdb5.f:156

◆ sorbdb2()

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

SORBDB2

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

Purpose:
!>
!> SORBDB2 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 SORBDB1, SORBDB3, and SORBDB4 handle cases in
!> which P is not the minimum dimension.
!>
!> The orthogonal 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 REAL 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 REAL 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 REAL array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is REAL array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is REAL array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is REAL 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 SORCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
!>  and SORGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 199 of file sorbdb2.f.

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

◆ sorbdb3()

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

SORBDB3

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

Purpose:
!>
!> SORBDB3 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 SORBDB1, SORBDB2, and SORBDB4 handle cases in
!> which M-P is not the minimum dimension.
!>
!> The orthogonal 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 REAL 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 REAL 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 REAL array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is REAL array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is REAL array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is REAL 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 SORCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
!>  and SORGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 200 of file sorbdb3.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 REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
213 $ X11(LDX11,*), X21(LDX21,*)
214* ..
215*
216* ====================================================================
217*
218* .. Parameters ..
219 REAL ONE
220 parameter( one = 1.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 slarf, slarfgp, sorbdb5, srot, xerbla
230* ..
231* .. External Functions ..
232 REAL SNRM2
233 EXTERNAL snrm2
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( 'SORBDB3', -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 srot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c, s )
284 END IF
285*
286 CALL slarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) )
287 s = x21(i,i)
288 x21(i,i) = one
289 CALL slarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),
290 $ x11(i,i), ldx11, work(ilarf) )
291 CALL slarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),
292 $ x21(i+1,i), ldx21, work(ilarf) )
293 c = sqrt( snrm2( p-i+1, x11(i,i), 1 )**2
294 $ + snrm2( m-p-i, x21(i+1,i), 1 )**2 )
295 theta(i) = atan2( s, c )
296*
297 CALL sorbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,
298 $ x11(i,i+1), ldx11, x21(i+1,i+1), ldx21,
299 $ work(iorbdb5), lorbdb5, childinfo )
300 CALL slarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
301 IF( i .LT. m-p ) THEN
302 CALL slarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) )
303 phi(i) = atan2( x21(i+1,i), x11(i,i) )
304 c = cos( phi(i) )
305 s = sin( phi(i) )
306 x21(i+1,i) = one
307 CALL slarf( 'L', m-p-i, q-i, x21(i+1,i), 1, taup2(i),
308 $ x21(i+1,i+1), ldx21, work(ilarf) )
309 END IF
310 x11(i,i) = one
311 CALL slarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),
312 $ ldx11, work(ilarf) )
313*
314 END DO
315*
316* Reduce the bottom-right portion of X11 to the identity matrix
317*
318 DO i = m-p + 1, q
319 CALL slarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
320 x11(i,i) = one
321 CALL slarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),
322 $ ldx11, work(ilarf) )
323 END DO
324*
325 RETURN
326*
327* End of SORBDB3
328*

◆ sorbdb4()

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

SORBDB4

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

Purpose:
!>
!> SORBDB4 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 SORBDB1, SORBDB2, and SORBDB3 handle cases in
!> which M-Q is not the minimum dimension.
!>
!> The orthogonal 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 REAL 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 REAL 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 REAL array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is REAL array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is REAL array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]PHANTOM
!>          PHANTOM is REAL 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 REAL 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 SORCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
!>  and SORGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 211 of file sorbdb4.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, LWORK, M, P, Q, LDX11, LDX21
221* ..
222* .. Array Arguments ..
223 REAL PHI(*), THETA(*)
224 REAL PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
225 $ WORK(*), X11(LDX11,*), X21(LDX21,*)
226* ..
227*
228* ====================================================================
229*
230* .. Parameters ..
231 REAL NEGONE, ONE, ZERO
232 parameter( negone = -1.0e0, one = 1.0e0, zero = 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 slarf, slarfgp, sorbdb5, srot, sscal, xerbla
242* ..
243* .. External Functions ..
244 REAL SNRM2
245 EXTERNAL snrm2
246* ..
247* .. Intrinsic Function ..
248 INTRINSIC atan2, cos, max, sin, sqrt
249* ..
250* .. Executable Statements ..
251*
252* Test input arguments
253*
254 info = 0
255 lquery = lwork .EQ. -1
256*
257 IF( m .LT. 0 ) THEN
258 info = -1
259 ELSE IF( p .LT. m-q .OR. m-p .LT. m-q ) THEN
260 info = -2
261 ELSE IF( q .LT. m-q .OR. q .GT. m ) THEN
262 info = -3
263 ELSE IF( ldx11 .LT. max( 1, p ) ) THEN
264 info = -5
265 ELSE IF( ldx21 .LT. max( 1, m-p ) ) THEN
266 info = -7
267 END IF
268*
269* Compute workspace
270*
271 IF( info .EQ. 0 ) THEN
272 ilarf = 2
273 llarf = max( q-1, p-1, m-p-1 )
274 iorbdb5 = 2
275 lorbdb5 = q
276 lworkopt = ilarf + llarf - 1
277 lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1 )
278 lworkmin = lworkopt
279 work(1) = lworkopt
280 IF( lwork .LT. lworkmin .AND. .NOT.lquery ) THEN
281 info = -14
282 END IF
283 END IF
284 IF( info .NE. 0 ) THEN
285 CALL xerbla( 'SORBDB4', -info )
286 RETURN
287 ELSE IF( lquery ) THEN
288 RETURN
289 END IF
290*
291* Reduce columns 1, ..., M-Q of X11 and X21
292*
293 DO i = 1, m-q
294*
295 IF( i .EQ. 1 ) THEN
296 DO j = 1, m
297 phantom(j) = zero
298 END DO
299 CALL sorbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,
300 $ x11, ldx11, x21, ldx21, work(iorbdb5),
301 $ lorbdb5, childinfo )
302 CALL sscal( p, negone, phantom(1), 1 )
303 CALL slarfgp( p, phantom(1), phantom(2), 1, taup1(1) )
304 CALL slarfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) )
305 theta(i) = atan2( phantom(1), phantom(p+1) )
306 c = cos( theta(i) )
307 s = sin( theta(i) )
308 phantom(1) = one
309 phantom(p+1) = one
310 CALL slarf( 'L', p, q, phantom(1), 1, taup1(1), x11, ldx11,
311 $ work(ilarf) )
312 CALL slarf( 'L', m-p, q, phantom(p+1), 1, taup2(1), x21,
313 $ ldx21, work(ilarf) )
314 ELSE
315 CALL sorbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,
316 $ x21(i,i-1), 1, x11(i,i), ldx11, x21(i,i),
317 $ ldx21, work(iorbdb5), lorbdb5, childinfo )
318 CALL sscal( p-i+1, negone, x11(i,i-1), 1 )
319 CALL slarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) )
320 CALL slarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,
321 $ taup2(i) )
322 theta(i) = atan2( x11(i,i-1), x21(i,i-1) )
323 c = cos( theta(i) )
324 s = sin( theta(i) )
325 x11(i,i-1) = one
326 x21(i,i-1) = one
327 CALL slarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1, taup1(i),
328 $ x11(i,i), ldx11, work(ilarf) )
329 CALL slarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1, taup2(i),
330 $ x21(i,i), ldx21, work(ilarf) )
331 END IF
332*
333 CALL srot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c )
334 CALL slarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) )
335 c = x21(i,i)
336 x21(i,i) = one
337 CALL slarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),
338 $ x11(i+1,i), ldx11, work(ilarf) )
339 CALL slarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),
340 $ x21(i+1,i), ldx21, work(ilarf) )
341 IF( i .LT. m-q ) THEN
342 s = sqrt( snrm2( p-i, x11(i+1,i), 1 )**2
343 $ + snrm2( m-p-i, x21(i+1,i), 1 )**2 )
344 phi(i) = atan2( s, c )
345 END IF
346*
347 END DO
348*
349* Reduce the bottom-right portion of X11 to [ I 0 ]
350*
351 DO i = m - q + 1, p
352 CALL slarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) )
353 x11(i,i) = one
354 CALL slarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),
355 $ x11(i+1,i), ldx11, work(ilarf) )
356 CALL slarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),
357 $ x21(m-q+1,i), ldx21, work(ilarf) )
358 END DO
359*
360* Reduce the bottom-right portion of X21 to [ 0 I ]
361*
362 DO i = p + 1, q
363 CALL slarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,
364 $ tauq1(i) )
365 x21(m-q+i-p,i) = one
366 CALL slarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),
367 $ x21(m-q+i-p+1,i), ldx21, work(ilarf) )
368 END DO
369*
370 RETURN
371*
372* End of SORBDB4
373*

◆ sorbdb5()

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

SORBDB5

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

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

◆ sorbdb6()

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

SORBDB6

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

Purpose:
!>
!> SORBDB6 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 sorbdb6.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 REAL 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 REAL NEGONE, ONE, ZERO
174 parameter( negone = -1.0e0, one = 1.0e0, zero = 0.0e0 )
175* ..
176* .. Local Scalars ..
177 INTEGER I
178 REAL NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
179* ..
180* .. External Subroutines ..
181 EXTERNAL sgemv, slassq, xerbla
182* ..
183* .. Intrinsic Function ..
184 INTRINSIC max
185* ..
186* .. Executable Statements ..
187*
188* Test input arguments
189*
190 info = 0
191 IF( m1 .LT. 0 ) THEN
192 info = -1
193 ELSE IF( m2 .LT. 0 ) THEN
194 info = -2
195 ELSE IF( n .LT. 0 ) THEN
196 info = -3
197 ELSE IF( incx1 .LT. 1 ) THEN
198 info = -5
199 ELSE IF( incx2 .LT. 1 ) THEN
200 info = -7
201 ELSE IF( ldq1 .LT. max( 1, m1 ) ) THEN
202 info = -9
203 ELSE IF( ldq2 .LT. max( 1, m2 ) ) THEN
204 info = -11
205 ELSE IF( lwork .LT. n ) THEN
206 info = -13
207 END IF
208*
209 IF( info .NE. 0 ) THEN
210 CALL xerbla( 'SORBDB6', -info )
211 RETURN
212 END IF
213*
214* First, project X onto the orthogonal complement of Q's column
215* space
216*
217 scl1 = realzero
218 ssq1 = realone
219 CALL slassq( m1, x1, incx1, scl1, ssq1 )
220 scl2 = realzero
221 ssq2 = realone
222 CALL slassq( m2, x2, incx2, scl2, ssq2 )
223 normsq1 = scl1**2*ssq1 + scl2**2*ssq2
224*
225 IF( m1 .EQ. 0 ) THEN
226 DO i = 1, n
227 work(i) = zero
228 END DO
229 ELSE
230 CALL sgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,
231 $ 1 )
232 END IF
233*
234 CALL sgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 )
235*
236 CALL sgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,
237 $ incx1 )
238 CALL sgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,
239 $ incx2 )
240*
241 scl1 = realzero
242 ssq1 = realone
243 CALL slassq( m1, x1, incx1, scl1, ssq1 )
244 scl2 = realzero
245 ssq2 = realone
246 CALL slassq( m2, x2, incx2, scl2, ssq2 )
247 normsq2 = scl1**2*ssq1 + scl2**2*ssq2
248*
249* If projection is sufficiently large in norm, then stop.
250* If projection is zero, then stop.
251* Otherwise, project again.
252*
253 IF( normsq2 .GE. alphasq*normsq1 ) THEN
254 RETURN
255 END IF
256*
257 IF( normsq2 .EQ. zero ) THEN
258 RETURN
259 END IF
260*
261 normsq1 = normsq2
262*
263 DO i = 1, n
264 work(i) = zero
265 END DO
266*
267 IF( m1 .EQ. 0 ) THEN
268 DO i = 1, n
269 work(i) = zero
270 END DO
271 ELSE
272 CALL sgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,
273 $ 1 )
274 END IF
275*
276 CALL sgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 )
277*
278 CALL sgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,
279 $ incx1 )
280 CALL sgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,
281 $ incx2 )
282*
283 scl1 = realzero
284 ssq1 = realone
285 CALL slassq( m1, x1, incx1, scl1, ssq1 )
286 scl2 = realzero
287 ssq2 = realone
288 CALL slassq( m1, x1, incx1, scl1, ssq1 )
289 normsq2 = scl1**2*ssq1 + scl2**2*ssq2
290*
291* If second projection is sufficiently large in norm, then do
292* nothing more. Alternatively, if it shrunk significantly, then
293* truncate it to zero.
294*
295 IF( normsq2 .LT. alphasq*normsq1 ) THEN
296 DO i = 1, m1
297 x1(i) = zero
298 END DO
299 DO i = 1, m2
300 x2(i) = zero
301 END DO
302 END IF
303*
304 RETURN
305*
306* End of SORBDB6
307*

◆ sorcsd()

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

SORCSD

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

Purpose:
!>
!> SORCSD computes the CS decomposition of an M-by-M partitioned
!> orthogonal matrix X:
!>
!>                                 [  I  0  0 |  0  0  0 ]
!>                                 [  0  C  0 |  0 -S  0 ]
!>     [ X11 | X12 ]   [ U1 |    ] [  0  0  0 |  0  0 -I ] [ V1 |    ]**T
!> 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 orthogonal 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 REAL array, dimension (LDX11,Q)
!>          On entry, part of the orthogonal matrix whose CSD is desired.
!>
[in]LDX11
!>          LDX11 is INTEGER
!>          The leading dimension of X11. LDX11 >= MAX(1,P).
!>
[in,out]X12
!>          X12 is REAL array, dimension (LDX12,M-Q)
!>          On entry, part of the orthogonal matrix whose CSD is desired.
!>
[in]LDX12
!>          LDX12 is INTEGER
!>          The leading dimension of X12. LDX12 >= MAX(1,P).
!>
[in,out]X21
!>          X21 is REAL array, dimension (LDX21,Q)
!>          On entry, part of the orthogonal 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 REAL array, dimension (LDX22,M-Q)
!>          On entry, part of the orthogonal 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 REAL array, dimension (LDU1,P)
!>          If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
!>
[in]LDU1
!>          LDU1 is INTEGER
!>          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
!>          MAX(1,P).
!>
[out]U2
!>          U2 is REAL array, dimension (LDU2,M-P)
!>          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
!>          matrix U2.
!>
[in]LDU2
!>          LDU2 is INTEGER
!>          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
!>          MAX(1,M-P).
!>
[out]V1T
!>          V1T is REAL array, dimension (LDV1T,Q)
!>          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
!>          matrix V1**T.
!>
[in]LDV1T
!>          LDV1T is INTEGER
!>          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
!>          MAX(1,Q).
!>
[out]V2T
!>          V2T is REAL array, dimension (LDV2T,M-Q)
!>          If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal
!>          matrix V2**T.
!>
[in]LDV2T
!>          LDV2T is INTEGER
!>          The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=
!>          MAX(1,M-Q).
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>          If INFO > 0 on exit, WORK(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]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]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:  SBBCSD 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 295 of file sorcsd.f.

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

◆ sorcsd2by1()

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

SORCSD2BY1

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

Purpose:
!>
!> SORCSD2BY1 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 orthogonal 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 REAL array, dimension (LDX11,Q)
!>          On entry, part of the orthogonal matrix whose CSD is desired.
!>
[in]LDX11
!>          LDX11 is INTEGER
!>          The leading dimension of X11. LDX11 >= MAX(1,P).
!>
[in,out]X21
!>          X21 is REAL array, dimension (LDX21,Q)
!>          On entry, part of the orthogonal 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 REAL array, dimension (P)
!>          If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
!>
[in]LDU1
!>          LDU1 is INTEGER
!>          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
!>          MAX(1,P).
!>
[out]U2
!>          U2 is REAL array, dimension (M-P)
!>          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
!>          matrix U2.
!>
[in]LDU2
!>          LDU2 is INTEGER
!>          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
!>          MAX(1,M-P).
!>
[out]V1T
!>          V1T is REAL array, dimension (Q)
!>          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
!>          matrix V1**T.
!>
[in]LDV1T
!>          LDV1T is INTEGER
!>          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
!>          MAX(1,Q).
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>          If INFO > 0 on exit, WORK(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]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]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:  SBBCSD 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 230 of file sorcsd2by1.f.

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

◆ sorg2l()

subroutine sorg2l ( integer m,
integer n,
integer k,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm).

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

Purpose:
!>
!> SORG2L generates an m by n real 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 SGEQLF.
!>
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 REAL 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 SGEQLF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGEQLF.
!>
[out]WORK
!>          WORK is REAL 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 sorg2l.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 REAL A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 REAL ONE, ZERO
130 parameter( one = 1.0e+0, zero = 0.0e+0 )
131* ..
132* .. Local Scalars ..
133 INTEGER I, II, J, L
134* ..
135* .. External Subroutines ..
136 EXTERNAL slarf, sscal, xerbla
137* ..
138* .. Intrinsic Functions ..
139 INTRINSIC 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.0 .OR. n.GT.m ) THEN
149 info = -2
150 ELSE IF( k.LT.0 .OR. k.GT.n ) 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( 'SORG2L', -info )
157 RETURN
158 END IF
159*
160* Quick return if possible
161*
162 IF( n.LE.0 )
163 $ RETURN
164*
165* Initialise columns 1:n-k to columns of the unit matrix
166*
167 DO 20 j = 1, n - k
168 DO 10 l = 1, m
169 a( l, j ) = zero
170 10 CONTINUE
171 a( m-n+j, j ) = one
172 20 CONTINUE
173*
174 DO 40 i = 1, k
175 ii = n - k + i
176*
177* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
178*
179 a( m-n+ii, ii ) = one
180 CALL slarf( 'Left', m-n+ii, ii-1, a( 1, ii ), 1, tau( i ), a,
181 $ lda, work )
182 CALL sscal( m-n+ii-1, -tau( i ), a( 1, ii ), 1 )
183 a( m-n+ii, ii ) = one - tau( i )
184*
185* Set A(m-k+i+1:m,n-k+i) to zero
186*
187 DO 30 l = m - n + ii + 1, m
188 a( l, ii ) = zero
189 30 CONTINUE
190 40 CONTINUE
191 RETURN
192*
193* End of SORG2L
194*

◆ sorg2r()

subroutine sorg2r ( integer m,
integer n,
integer k,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm).

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

Purpose:
!>
!> SORG2R generates an m by n real 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 SGEQRF.
!>
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 REAL 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 SGEQRF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGEQRF.
!>
[out]WORK
!>          WORK is REAL 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 sorg2r.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 REAL A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 REAL ONE, ZERO
130 parameter( one = 1.0e+0, zero = 0.0e+0 )
131* ..
132* .. Local Scalars ..
133 INTEGER I, J, L
134* ..
135* .. External Subroutines ..
136 EXTERNAL slarf, sscal, xerbla
137* ..
138* .. Intrinsic Functions ..
139 INTRINSIC 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.0 .OR. n.GT.m ) THEN
149 info = -2
150 ELSE IF( k.LT.0 .OR. k.GT.n ) 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( 'SORG2R', -info )
157 RETURN
158 END IF
159*
160* Quick return if possible
161*
162 IF( n.LE.0 )
163 $ RETURN
164*
165* Initialise columns k+1:n to columns of the unit matrix
166*
167 DO 20 j = k + 1, n
168 DO 10 l = 1, m
169 a( l, j ) = zero
170 10 CONTINUE
171 a( j, j ) = one
172 20 CONTINUE
173*
174 DO 40 i = k, 1, -1
175*
176* Apply H(i) to A(i:m,i:n) from the left
177*
178 IF( i.LT.n ) THEN
179 a( i, i ) = one
180 CALL slarf( 'Left', m-i+1, n-i, a( i, i ), 1, tau( i ),
181 $ a( i, i+1 ), lda, work )
182 END IF
183 IF( i.LT.m )
184 $ CALL sscal( m-i, -tau( i ), a( i+1, i ), 1 )
185 a( i, i ) = one - tau( i )
186*
187* Set A(1:i-1,i) to zero
188*
189 DO 30 l = 1, i - 1
190 a( l, i ) = zero
191 30 CONTINUE
192 40 CONTINUE
193 RETURN
194*
195* End of SORG2R
196*

◆ sorghr()

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

SORGHR

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

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

◆ sorgl2()

subroutine sorgl2 ( integer m,
integer n,
integer k,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SORGL2

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

Purpose:
!>
!> SORGL2 generates an m by n real 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(2) H(1)
!>
!> as returned by SGELQF.
!>
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 REAL 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 SGELQF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGELQF.
!>
[out]WORK
!>          WORK is REAL 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 sorgl2.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 REAL A( LDA, * ), TAU( * ), WORK( * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 REAL ONE, ZERO
129 parameter( one = 1.0e+0, zero = 0.0e+0 )
130* ..
131* .. Local Scalars ..
132 INTEGER I, J, L
133* ..
134* .. External Subroutines ..
135 EXTERNAL slarf, sscal, xerbla
136* ..
137* .. Intrinsic Functions ..
138 INTRINSIC max
139* ..
140* .. Executable Statements ..
141*
142* Test the input arguments
143*
144 info = 0
145 IF( m.LT.0 ) THEN
146 info = -1
147 ELSE IF( n.LT.m ) THEN
148 info = -2
149 ELSE IF( k.LT.0 .OR. k.GT.m ) THEN
150 info = -3
151 ELSE IF( lda.LT.max( 1, m ) ) THEN
152 info = -5
153 END IF
154 IF( info.NE.0 ) THEN
155 CALL xerbla( 'SORGL2', -info )
156 RETURN
157 END IF
158*
159* Quick return if possible
160*
161 IF( m.LE.0 )
162 $ RETURN
163*
164 IF( k.LT.m ) THEN
165*
166* Initialise rows k+1:m to rows of the unit matrix
167*
168 DO 20 j = 1, n
169 DO 10 l = k + 1, m
170 a( l, j ) = zero
171 10 CONTINUE
172 IF( j.GT.k .AND. j.LE.m )
173 $ a( j, j ) = one
174 20 CONTINUE
175 END IF
176*
177 DO 40 i = k, 1, -1
178*
179* Apply H(i) to A(i:m,i:n) from the right
180*
181 IF( i.LT.n ) THEN
182 IF( i.LT.m ) THEN
183 a( i, i ) = one
184 CALL slarf( 'Right', m-i, n-i+1, a( i, i ), lda,
185 $ tau( i ), a( i+1, i ), lda, work )
186 END IF
187 CALL sscal( n-i, -tau( i ), a( i, i+1 ), lda )
188 END IF
189 a( i, i ) = one - tau( i )
190*
191* Set A(i,1:i-1) to zero
192*
193 DO 30 l = 1, i - 1
194 a( i, l ) = zero
195 30 CONTINUE
196 40 CONTINUE
197 RETURN
198*
199* End of SORGL2
200*

◆ sorglq()

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

SORGLQ

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

Purpose:
!>
!> SORGLQ generates an M-by-N real 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(2) H(1)
!>
!> as returned by SGELQF.
!>
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 REAL 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 SGELQF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGELQF.
!>
[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. 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 sorglq.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 REAL A( LDA, * ), TAU( * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 REAL ZERO
143 parameter( zero = 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 slarfb, slarft, sorgl2, 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, 'SORGLQ', ' ', 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( 'SORGLQ', -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, 'SORGLQ', ' ', 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, 'SORGLQ', ' ', 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 sorgl2( 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 slarft( 'Forward', 'Rowwise', n-i+1, ib, a( i, i ),
256 $ lda, tau( i ), work, ldwork )
257*
258* Apply H**T to A(i+ib:m,i:n) from the right
259*
260 CALL slarfb( 'Right', 'Transpose', 'Forward', 'Rowwise',
261 $ m-i-ib+1, n-i+1, ib, a( i, i ), lda, work,
262 $ ldwork, a( i+ib, i ), lda, work( ib+1 ),
263 $ ldwork )
264 END IF
265*
266* Apply H**T to columns i:n of current block
267*
268 CALL sorgl2( 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 SORGLQ
285*
slarft
subroutine slarft(direct, storev, n, k, v, ldv, tau, t, ldt)
SLARFT forms the triangular factor T of a block reflector H = I - vtvH
Definition slarft.f:163
slarfb
subroutine slarfb(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
SLARFB applies a block reflector or its transpose to a general rectangular matrix.
Definition slarfb.f:197
sorgl2
subroutine sorgl2(m, n, k, a, lda, tau, work, info)
SORGL2
Definition sorgl2.f:113

◆ sorgql()

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

SORGQL

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

Purpose:
!>
!> SORGQL generates an M-by-N real 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 SGEQLF.
!>
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 REAL 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 SGEQLF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGEQLF.
!>
[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. 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 sorgql.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 REAL A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO
144 parameter( zero = 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 slarfb, slarft, sorg2l, 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, 'SORGQL', ' ', 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( 'SORGQL', -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, 'SORGQL', ' ', 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, 'SORGQL', ' ', 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 sorg2l( 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 slarft( '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 slarfb( '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 sorg2l( 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 SORGQL
292*

◆ sorgqr()

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

SORGQR

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

Purpose:
!>
!> SORGQR generates an M-by-N real 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 SGEQRF.
!>
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 REAL 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 SGEQRF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGEQRF.
!>
[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. 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 sorgqr.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 REAL A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO
144 parameter( zero = 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 slarfb, slarft, sorg2r, 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, 'SORGQR', ' ', 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( 'SORGQR', -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, 'SORGQR', ' ', 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, 'SORGQR', ' ', 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 sorg2r( 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 slarft( '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 slarfb( '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 sorg2r( 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 SORGQR
286*

◆ sorgr2()

subroutine sorgr2 ( integer m,
integer n,
integer k,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer info )

SORGR2 generates all or part of the orthogonal matrix Q from an RQ factorization determined by sgerqf (unblocked algorithm).

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

Purpose:
!>
!> SORGR2 generates an m by n real 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(2) . . . H(k)
!>
!> as returned by SGERQF.
!>
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 REAL 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 SGERQF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGERQF.
!>
[out]WORK
!>          WORK is REAL 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 sorgr2.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 REAL A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 REAL ONE, ZERO
130 parameter( one = 1.0e+0, zero = 0.0e+0 )
131* ..
132* .. Local Scalars ..
133 INTEGER I, II, J, L
134* ..
135* .. External Subroutines ..
136 EXTERNAL slarf, sscal, xerbla
137* ..
138* .. Intrinsic Functions ..
139 INTRINSIC 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( 'SORGR2', -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 1:m-k to rows of the unit matrix
168*
169 DO 20 j = 1, n
170 DO 10 l = 1, m - k
171 a( l, j ) = zero
172 10 CONTINUE
173 IF( j.GT.n-m .AND. j.LE.n-k )
174 $ a( m-n+j, j ) = one
175 20 CONTINUE
176 END IF
177*
178 DO 40 i = 1, k
179 ii = m - k + i
180*
181* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right
182*
183 a( ii, n-m+ii ) = one
184 CALL slarf( 'Right', ii-1, n-m+ii, a( ii, 1 ), lda, tau( i ),
185 $ a, lda, work )
186 CALL sscal( n-m+ii-1, -tau( i ), a( ii, 1 ), lda )
187 a( ii, n-m+ii ) = one - tau( i )
188*
189* Set A(m-k+i,n-k+i+1:n) to zero
190*
191 DO 30 l = n - m + ii + 1, n
192 a( ii, l ) = zero
193 30 CONTINUE
194 40 CONTINUE
195 RETURN
196*
197* End of SORGR2
198*

◆ sorgrq()

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

SORGRQ

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

Purpose:
!>
!> SORGRQ generates an M-by-N real 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(2) . . . H(k)
!>
!> as returned by SGERQF.
!>
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 REAL 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 SGERQF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGERQF.
!>
[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. 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 sorgrq.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 REAL A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO
144 parameter( zero = 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 slarfb, slarft, sorgr2, 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, 'SORGRQ', ' ', 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( 'SORGRQ', -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, 'SORGRQ', ' ', 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, 'SORGRQ', ' ', 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 sorgr2( 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 slarft( 'Backward', 'Rowwise', n-k+i+ib-1, ib,
264 $ a( ii, 1 ), lda, tau( i ), work, ldwork )
265*
266* Apply H**T to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
267*
268 CALL slarfb( 'Right', 'Transpose', 'Backward', 'Rowwise',
269 $ ii-1, n-k+i+ib-1, ib, a( ii, 1 ), lda, work,
270 $ ldwork, a, lda, work( ib+1 ), ldwork )
271 END IF
272*
273* Apply H**T to columns 1:n-k+i+ib-1 of current block
274*
275 CALL sorgr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),
276 $ work, iinfo )
277*
278* Set columns n-k+i+ib:n of current block to zero
279*
280 DO 40 l = n - k + i + ib, n
281 DO 30 j = ii, ii + ib - 1
282 a( j, l ) = zero
283 30 CONTINUE
284 40 CONTINUE
285 50 CONTINUE
286 END IF
287*
288 work( 1 ) = iws
289 RETURN
290*
291* End of SORGRQ
292*
sorgr2
subroutine sorgr2(m, n, k, a, lda, tau, work, info)
SORGR2 generates all or part of the orthogonal matrix Q from an RQ factorization determined by sgerqf...
Definition sorgr2.f:114

◆ sorgtr()

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

SORGTR

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

Purpose:
!>
!> SORGTR generates a real orthogonal matrix Q which is defined as the
!> product of n-1 elementary reflectors of order N, as returned by
!> SSYTRD:
!>
!> 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 SSYTRD;
!>          = 'L': Lower triangle of A contains elementary reflectors
!>                 from SSYTRD.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix Q. N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the vectors which define the elementary reflectors,
!>          as returned by SSYTRD.
!>          On exit, the N-by-N orthogonal matrix Q.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!>
[in]TAU
!>          TAU is REAL array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SSYTRD.
!>
[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. LWORK >= max(1,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 sorgtr.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 REAL A( LDA, * ), TAU( * ), WORK( * )
134* ..
135*
136* =====================================================================
137*
138* .. Parameters ..
139 REAL ZERO, ONE
140 parameter( zero = 0.0e+0, one = 1.0e+0 )
141* ..
142* .. Local Scalars ..
143 LOGICAL LQUERY, UPPER
144 INTEGER I, IINFO, J, LWKOPT, NB
145* ..
146* .. External Functions ..
147 LOGICAL LSAME
148 INTEGER ILAENV
149 EXTERNAL ilaenv, lsame
150* ..
151* .. External Subroutines ..
152 EXTERNAL sorgql, sorgqr, xerbla
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC max
156* ..
157* .. Executable Statements ..
158*
159* Test the input arguments
160*
161 info = 0
162 lquery = ( lwork.EQ.-1 )
163 upper = lsame( uplo, 'U' )
164 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
165 info = -1
166 ELSE IF( n.LT.0 ) THEN
167 info = -2
168 ELSE IF( lda.LT.max( 1, n ) ) THEN
169 info = -4
170 ELSE IF( lwork.LT.max( 1, n-1 ) .AND. .NOT.lquery ) THEN
171 info = -7
172 END IF
173*
174 IF( info.EQ.0 ) THEN
175 IF ( upper ) THEN
176 nb = ilaenv( 1, 'SORGQL', ' ', n-1, n-1, n-1, -1 )
177 ELSE
178 nb = ilaenv( 1, 'SORGQR', ' ', n-1, n-1, n-1, -1 )
179 END IF
180 lwkopt = max( 1, n-1 )*nb
181 work( 1 ) = lwkopt
182 END IF
183*
184 IF( info.NE.0 ) THEN
185 CALL xerbla( 'SORGTR', -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 IF( upper ) THEN
199*
200* Q was determined by a call to SSYTRD with UPLO = 'U'
201*
202* Shift the vectors which define the elementary reflectors one
203* column to the left, and set the last row and column of Q to
204* those of the unit matrix
205*
206 DO 20 j = 1, n - 1
207 DO 10 i = 1, j - 1
208 a( i, j ) = a( i, j+1 )
209 10 CONTINUE
210 a( n, j ) = zero
211 20 CONTINUE
212 DO 30 i = 1, n - 1
213 a( i, n ) = zero
214 30 CONTINUE
215 a( n, n ) = one
216*
217* Generate Q(1:n-1,1:n-1)
218*
219 CALL sorgql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
220*
221 ELSE
222*
223* Q was determined by a call to SSYTRD with UPLO = 'L'.
224*
225* Shift the vectors which define the elementary reflectors one
226* column to the right, and set the first row and column of Q to
227* those of the unit matrix
228*
229 DO 50 j = n, 2, -1
230 a( 1, j ) = zero
231 DO 40 i = j + 1, n
232 a( i, j ) = a( i, j-1 )
233 40 CONTINUE
234 50 CONTINUE
235 a( 1, 1 ) = one
236 DO 60 i = 2, n
237 a( i, 1 ) = zero
238 60 CONTINUE
239 IF( n.GT.1 ) THEN
240*
241* Generate Q(2:n,2:n)
242*
243 CALL sorgqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,
244 $ lwork, iinfo )
245 END IF
246 END IF
247 work( 1 ) = lwkopt
248 RETURN
249*
250* End of SORGTR
251*
sorgql
subroutine sorgql(m, n, k, a, lda, tau, work, lwork, info)
SORGQL
Definition sorgql.f:128

◆ sorm2l()

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

SORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sgeqlf (unblocked algorithm).

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

Purpose:
!>
!> SORM2L overwrites the general real m by n matrix C with
!>
!>       Q * C  if SIDE = 'L' and TRANS = 'N', or
!>
!>       Q**T * C  if SIDE = 'L' and TRANS = 'T', or
!>
!>       C * Q  if SIDE = 'R' and TRANS = 'N', or
!>
!>       C * Q**T if SIDE = 'R' and TRANS = 'T',
!>
!> where Q is a real orthogonal matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(k) . . . H(2) H(1)
!>
!> as returned by SGEQLF. 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**T from the Left
!>          = 'R': apply Q or Q**T from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'T': apply Q**T (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 REAL 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
!>          SGEQLF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGEQLF.
!>
[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
!>                                   (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 sorm2l.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 REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 REAL ONE
176 parameter( one = 1.0e+0 )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, MI, NI, NQ
181 REAL AII
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL slarf, xerbla
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC 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, 'T' ) ) 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( 'SORM2L', -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 ) )
234 $ THEN
235 i1 = 1
236 i2 = k
237 i3 = 1
238 ELSE
239 i1 = k
240 i2 = 1
241 i3 = -1
242 END IF
243*
244 IF( left ) THEN
245 ni = n
246 ELSE
247 mi = m
248 END IF
249*
250 DO 10 i = i1, i2, i3
251 IF( left ) THEN
252*
253* H(i) is applied to C(1:m-k+i,1:n)
254*
255 mi = m - k + i
256 ELSE
257*
258* H(i) is applied to C(1:m,1:n-k+i)
259*
260 ni = n - k + i
261 END IF
262*
263* Apply H(i)
264*
265 aii = a( nq-k+i, i )
266 a( nq-k+i, i ) = one
267 CALL slarf( side, mi, ni, a( 1, i ), 1, tau( i ), c, ldc,
268 $ work )
269 a( nq-k+i, i ) = aii
270 10 CONTINUE
271 RETURN
272*
273* End of SORM2L
274*

◆ sorm2r()

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

SORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm).

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

Purpose:
!>
!> SORM2R overwrites the general real m by n matrix C with
!>
!>       Q * C  if SIDE = 'L' and TRANS = 'N', or
!>
!>       Q**T* C  if SIDE = 'L' and TRANS = 'T', or
!>
!>       C * Q  if SIDE = 'R' and TRANS = 'N', or
!>
!>       C * Q**T if SIDE = 'R' and TRANS = 'T',
!>
!> where Q is a real orthogonal matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1) H(2) . . . H(k)
!>
!> as returned by SGEQRF. 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**T from the Left
!>          = 'R': apply Q or Q**T from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'T': apply Q**T (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 REAL 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
!>          SGEQRF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGEQRF.
!>
[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
!>                                   (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 sorm2r.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 REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 REAL ONE
176 parameter( one = 1.0e+0 )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
181 REAL AII
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL slarf, xerbla
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC 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, 'T' ) ) 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( 'SORM2R', -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 ) )
234 $ THEN
235 i1 = 1
236 i2 = k
237 i3 = 1
238 ELSE
239 i1 = k
240 i2 = 1
241 i3 = -1
242 END IF
243*
244 IF( left ) THEN
245 ni = n
246 jc = 1
247 ELSE
248 mi = m
249 ic = 1
250 END IF
251*
252 DO 10 i = i1, i2, i3
253 IF( left ) THEN
254*
255* H(i) is applied to C(i:m,1:n)
256*
257 mi = m - i + 1
258 ic = i
259 ELSE
260*
261* H(i) is applied to C(1:m,i:n)
262*
263 ni = n - i + 1
264 jc = i
265 END IF
266*
267* Apply H(i)
268*
269 aii = a( i, i )
270 a( i, i ) = one
271 CALL slarf( side, mi, ni, a( i, i ), 1, tau( i ), c( ic, jc ),
272 $ ldc, work )
273 a( i, i ) = aii
274 10 CONTINUE
275 RETURN
276*
277* End of SORM2R
278*

◆ sormbr()

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

SORMBR

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

Purpose:
!>
!> If VECT = 'Q', SORMBR 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
!>
!> If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C
!> with
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      P * C          C * P
!> TRANS = 'T':      P**T * C       C * P**T
!>
!> Here Q and P**T are the orthogonal matrices determined by SGEBRD when
!> reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
!> P**T 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 orthogonal matrix Q or P**T 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**T;
!>          = 'P': apply P or P**T.
!>
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q, Q**T, P or P**T from the Left;
!>          = 'R': apply Q, Q**T, P or P**T from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q  or P;
!>          = 'T':  Transpose, apply Q**T or P**T.
!>
[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 SGEBRD.
!>          If VECT = 'P', the number of rows in the original
!>          matrix reduced by SGEBRD.
!>          K >= 0.
!>
[in]A
!>          A is REAL 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 SGEBRD.
!>
[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 REAL 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 SGEBRD in the array argument TAUQ or TAUP.
!>
[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
!>          or P*C or P**T*C or C*P or C*P**T.
!>
[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 >= 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 194 of file sormbr.f.

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

◆ sormhr()

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

SORMHR

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

Purpose:
!>
!> SORMHR 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'. Q is defined as the product of
!> IHI-ILO elementary reflectors, as returned by SGEHRD:
!>
!> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
!>
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':  No transpose, apply Q;
!>          = 'T':  Transpose, apply Q**T.
!>
[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 SGEHRD. 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 REAL array, dimension
!>                               (LDA,M) if SIDE = 'L'
!>                               (LDA,N) if SIDE = 'R'
!>          The vectors which define the elementary reflectors, as
!>          returned by SGEHRD.
!>
[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 REAL 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 SGEHRD.
!>
[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 >= 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 sormhr.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 REAL 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 sormqr, 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, 'T' ) )
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, 'SORMQR', side // trans, nh, n, nh, -1 )
252 ELSE
253 nb = ilaenv( 1, 'SORMQR', 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( 'SORMHR', -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 sormqr( 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 SORMHR
292*

◆ sorml2()

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

SORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm).

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

Purpose:
!>
!> SORML2 overwrites the general real m by n matrix C with
!>
!>       Q * C  if SIDE = 'L' and TRANS = 'N', or
!>
!>       Q**T* C  if SIDE = 'L' and TRANS = 'T', or
!>
!>       C * Q  if SIDE = 'R' and TRANS = 'N', or
!>
!>       C * Q**T if SIDE = 'R' and TRANS = 'T',
!>
!> where Q is a real orthogonal matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(k) . . . H(2) H(1)
!>
!> as returned by SGELQF. 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**T from the Left
!>          = 'R': apply Q or Q**T from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'T': apply Q**T (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 REAL 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
!>          SGELQF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGELQF.
!>
[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
!>                                   (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 sorml2.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 REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 REAL ONE
176 parameter( one = 1.0e+0 )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
181 REAL AII
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL slarf, xerbla
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC 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, 'T' ) ) 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( 'SORML2', -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 ) )
234 $ THEN
235 i1 = 1
236 i2 = k
237 i3 = 1
238 ELSE
239 i1 = k
240 i2 = 1
241 i3 = -1
242 END IF
243*
244 IF( left ) THEN
245 ni = n
246 jc = 1
247 ELSE
248 mi = m
249 ic = 1
250 END IF
251*
252 DO 10 i = i1, i2, i3
253 IF( left ) THEN
254*
255* H(i) is applied to C(i:m,1:n)
256*
257 mi = m - i + 1
258 ic = i
259 ELSE
260*
261* H(i) is applied to C(1:m,i:n)
262*
263 ni = n - i + 1
264 jc = i
265 END IF
266*
267* Apply H(i)
268*
269 aii = a( i, i )
270 a( i, i ) = one
271 CALL slarf( side, mi, ni, a( i, i ), lda, tau( i ),
272 $ c( ic, jc ), ldc, work )
273 a( i, i ) = aii
274 10 CONTINUE
275 RETURN
276*
277* End of SORML2
278*

◆ sormlq()

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

SORMLQ

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

Purpose:
!>
!> SORMLQ 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 defined as the product of k
!> elementary reflectors
!>
!>       Q = H(k) . . . H(2) H(1)
!>
!> as returned by SGELQF. 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**T from the Left;
!>          = 'R': apply Q or Q**T from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'T':  Transpose, apply Q**T.
!>
[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 REAL 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
!>          SGELQF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGELQF.
!>
[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 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 sormlq.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 REAL 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 slarfb, slarft, sorml2, 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, 'T' ) ) 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 nb = min( nbmax, ilaenv( 1, 'SORMLQ', side // trans, m, n, k,
247 $ -1 ) )
248 lwkopt = nw*nb + tsize
249 work( 1 ) = lwkopt
250 END IF
251*
252 IF( info.NE.0 ) THEN
253 CALL xerbla( 'SORMLQ', -info )
254 RETURN
255 ELSE IF( lquery ) THEN
256 RETURN
257 END IF
258*
259* Quick return if possible
260*
261 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) THEN
262 work( 1 ) = 1
263 RETURN
264 END IF
265*
266 nbmin = 2
267 ldwork = nw
268 IF( nb.GT.1 .AND. nb.LT.k ) THEN
269 IF( lwork.LT.lwkopt ) THEN
270 nb = (lwork-tsize) / ldwork
271 nbmin = max( 2, ilaenv( 2, 'SORMLQ', side // trans, m, n, k,
272 $ -1 ) )
273 END IF
274 END IF
275*
276 IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
277*
278* Use unblocked code
279*
280 CALL sorml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,
281 $ iinfo )
282 ELSE
283*
284* Use blocked code
285*
286 iwt = 1 + nw*nb
287 IF( ( left .AND. notran ) .OR.
288 $ ( .NOT.left .AND. .NOT.notran ) ) THEN
289 i1 = 1
290 i2 = k
291 i3 = nb
292 ELSE
293 i1 = ( ( k-1 ) / nb )*nb + 1
294 i2 = 1
295 i3 = -nb
296 END IF
297*
298 IF( left ) THEN
299 ni = n
300 jc = 1
301 ELSE
302 mi = m
303 ic = 1
304 END IF
305*
306 IF( notran ) THEN
307 transt = 'T'
308 ELSE
309 transt = 'N'
310 END IF
311*
312 DO 10 i = i1, i2, i3
313 ib = min( nb, k-i+1 )
314*
315* Form the triangular factor of the block reflector
316* H = H(i) H(i+1) . . . H(i+ib-1)
317*
318 CALL slarft( 'Forward', 'Rowwise', nq-i+1, ib, a( i, i ),
319 $ lda, tau( i ), work( iwt ), ldt )
320 IF( left ) THEN
321*
322* H or H**T is applied to C(i:m,1:n)
323*
324 mi = m - i + 1
325 ic = i
326 ELSE
327*
328* H or H**T is applied to C(1:m,i:n)
329*
330 ni = n - i + 1
331 jc = i
332 END IF
333*
334* Apply H or H**T
335*
336 CALL slarfb( side, transt, 'Forward', 'Rowwise', mi, ni, ib,
337 $ a( i, i ), lda, work( iwt ), ldt,
338 $ c( ic, jc ), ldc, work, ldwork )
339 10 CONTINUE
340 END IF
341 work( 1 ) = lwkopt
342 RETURN
343*
344* End of SORMLQ
345*
sorml2
subroutine sorml2(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
SORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sge...
Definition sorml2.f:159

◆ sormql()

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

SORMQL

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

Purpose:
!>
!> SORMQL 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 defined as the product of k
!> elementary reflectors
!>
!>       Q = H(k) . . . H(2) H(1)
!>
!> as returned by SGEQLF. 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**T from the Left;
!>          = 'R': apply Q or Q**T from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'T':  Transpose, apply Q**T.
!>
[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 REAL 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
!>          SGEQLF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGEQLF.
!>
[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 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 sormql.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 REAL 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 slarfb, slarft, sorm2l, 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, 'T' ) ) 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, 'SORMQL', 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( 'SORMQL', -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 nbmin = 2
269 ldwork = nw
270 IF( nb.GT.1 .AND. nb.LT.k ) THEN
271 IF( lwork.LT.lwkopt ) THEN
272 nb = (lwork-tsize) / ldwork
273 nbmin = max( 2, ilaenv( 2, 'SORMQL', side // trans, m, n, k,
274 $ -1 ) )
275 END IF
276 END IF
277*
278 IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
279*
280* Use unblocked code
281*
282 CALL sorm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,
283 $ iinfo )
284 ELSE
285*
286* Use blocked code
287*
288 iwt = 1 + nw*nb
289 IF( ( left .AND. notran ) .OR.
290 $ ( .NOT.left .AND. .NOT.notran ) ) THEN
291 i1 = 1
292 i2 = k
293 i3 = nb
294 ELSE
295 i1 = ( ( k-1 ) / nb )*nb + 1
296 i2 = 1
297 i3 = -nb
298 END IF
299*
300 IF( left ) THEN
301 ni = n
302 ELSE
303 mi = m
304 END IF
305*
306 DO 10 i = i1, i2, i3
307 ib = min( nb, k-i+1 )
308*
309* Form the triangular factor of the block reflector
310* H = H(i+ib-1) . . . H(i+1) H(i)
311*
312 CALL slarft( 'Backward', 'Columnwise', nq-k+i+ib-1, ib,
313 $ a( 1, i ), lda, tau( i ), work( iwt ), ldt )
314 IF( left ) THEN
315*
316* H or H**T is applied to C(1:m-k+i+ib-1,1:n)
317*
318 mi = m - k + i + ib - 1
319 ELSE
320*
321* H or H**T is applied to C(1:m,1:n-k+i+ib-1)
322*
323 ni = n - k + i + ib - 1
324 END IF
325*
326* Apply H or H**T
327*
328 CALL slarfb( side, trans, 'Backward', 'Columnwise', mi, ni,
329 $ ib, a( 1, i ), lda, work( iwt ), ldt, c, ldc,
330 $ work, ldwork )
331 10 CONTINUE
332 END IF
333 work( 1 ) = lwkopt
334 RETURN
335*
336* End of SORMQL
337*
sorm2l
subroutine sorm2l(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
SORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sge...
Definition sorm2l.f:159

◆ sormqr()

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

SORMQR

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

Purpose:
!>
!> SORMQR 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 defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1) H(2) . . . H(k)
!>
!> as returned by SGEQRF. 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**T from the Left;
!>          = 'R': apply Q or Q**T from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'T':  Transpose, apply Q**T.
!>
[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 REAL 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
!>          SGEQRF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGEQRF.
!>
[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 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 sormqr.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 REAL 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 slarfb, slarft, sorm2r, 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, 'T' ) ) 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, 'SORMQR', 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( 'SORMQR', -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, 'SORMQR', 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 sorm2r( 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 slarft( '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**T is applied to C(i:m,1:n)
316*
317 mi = m - i + 1
318 ic = i
319 ELSE
320*
321* H or H**T 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**T
328*
329 CALL slarfb( 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 SORMQR
338*

◆ sormr2()

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

SORMR2 multiplies a general matrix by the orthogonal matrix from a RQ factorization determined by sgerqf (unblocked algorithm).

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

Purpose:
!>
!> SORMR2 overwrites the general real m by n matrix C with
!>
!>       Q * C  if SIDE = 'L' and TRANS = 'N', or
!>
!>       Q**T* C  if SIDE = 'L' and TRANS = 'T', or
!>
!>       C * Q  if SIDE = 'R' and TRANS = 'N', or
!>
!>       C * Q**T if SIDE = 'R' and TRANS = 'T',
!>
!> where Q is a real orthogonal matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1) H(2) . . . H(k)
!>
!> as returned by SGERQF. 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**T from the Left
!>          = 'R': apply Q or Q**T from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'T': apply Q' (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 REAL 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
!>          SGERQF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGERQF.
!>
[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
!>                                   (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 sormr2.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 REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 REAL ONE
176 parameter( one = 1.0e+0 )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, MI, NI, NQ
181 REAL AII
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL slarf, xerbla
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC 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, 'T' ) ) 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( 'SORMR2', -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 ) )
234 $ THEN
235 i1 = 1
236 i2 = k
237 i3 = 1
238 ELSE
239 i1 = k
240 i2 = 1
241 i3 = -1
242 END IF
243*
244 IF( left ) THEN
245 ni = n
246 ELSE
247 mi = m
248 END IF
249*
250 DO 10 i = i1, i2, i3
251 IF( left ) THEN
252*
253* H(i) is applied to C(1:m-k+i,1:n)
254*
255 mi = m - k + i
256 ELSE
257*
258* H(i) is applied to C(1:m,1:n-k+i)
259*
260 ni = n - k + i
261 END IF
262*
263* Apply H(i)
264*
265 aii = a( i, nq-k+i )
266 a( i, nq-k+i ) = one
267 CALL slarf( side, mi, ni, a( i, 1 ), lda, tau( i ), c, ldc,
268 $ work )
269 a( i, nq-k+i ) = aii
270 10 CONTINUE
271 RETURN
272*
273* End of SORMR2
274*

◆ sormr3()

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

SORMR3 multiplies a general matrix by the orthogonal matrix from a RZ factorization determined by stzrzf (unblocked algorithm).

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

Purpose:
!>
!> SORMR3 overwrites the general real m by n matrix C with
!>
!>       Q * C  if SIDE = 'L' and TRANS = 'N', or
!>
!>       Q**T* C  if SIDE = 'L' and TRANS = 'C', or
!>
!>       C * Q  if SIDE = 'R' and TRANS = 'N', or
!>
!>       C * Q**T if SIDE = 'R' and TRANS = 'C',
!>
!> where Q is a real orthogonal matrix defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1) H(2) . . . H(k)
!>
!> as returned by STZRZF. 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**T from the Left
!>          = 'R': apply Q or Q**T from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply Q  (No transpose)
!>          = 'T': apply Q**T (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 REAL 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
!>          STZRZF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by STZRZF.
!>
[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
!>                                   (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 sormr3.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 REAL 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* ..
197* .. External Functions ..
198 LOGICAL LSAME
199 EXTERNAL lsame
200* ..
201* .. External Subroutines ..
202 EXTERNAL slarz, xerbla
203* ..
204* .. Intrinsic Functions ..
205 INTRINSIC max
206* ..
207* .. Executable Statements ..
208*
209* Test the input arguments
210*
211 info = 0
212 left = lsame( side, 'L' )
213 notran = lsame( trans, 'N' )
214*
215* NQ is the order of Q
216*
217 IF( left ) THEN
218 nq = m
219 ELSE
220 nq = n
221 END IF
222 IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN
223 info = -1
224 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) ) THEN
225 info = -2
226 ELSE IF( m.LT.0 ) THEN
227 info = -3
228 ELSE IF( n.LT.0 ) THEN
229 info = -4
230 ELSE IF( k.LT.0 .OR. k.GT.nq ) THEN
231 info = -5
232 ELSE IF( l.LT.0 .OR. ( left .AND. ( l.GT.m ) ) .OR.
233 $ ( .NOT.left .AND. ( l.GT.n ) ) ) THEN
234 info = -6
235 ELSE IF( lda.LT.max( 1, k ) ) THEN
236 info = -8
237 ELSE IF( ldc.LT.max( 1, m ) ) THEN
238 info = -11
239 END IF
240 IF( info.NE.0 ) THEN
241 CALL xerbla( 'SORMR3', -info )
242 RETURN
243 END IF
244*
245* Quick return if possible
246*
247 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 )
248 $ RETURN
249*
250 IF( ( left .AND. .NOT.notran .OR. .NOT.left .AND. notran ) ) THEN
251 i1 = 1
252 i2 = k
253 i3 = 1
254 ELSE
255 i1 = k
256 i2 = 1
257 i3 = -1
258 END IF
259*
260 IF( left ) THEN
261 ni = n
262 ja = m - l + 1
263 jc = 1
264 ELSE
265 mi = m
266 ja = n - l + 1
267 ic = 1
268 END IF
269*
270 DO 10 i = i1, i2, i3
271 IF( left ) THEN
272*
273* H(i) or H(i)**T is applied to C(i:m,1:n)
274*
275 mi = m - i + 1
276 ic = i
277 ELSE
278*
279* H(i) or H(i)**T is applied to C(1:m,i:n)
280*
281 ni = n - i + 1
282 jc = i
283 END IF
284*
285* Apply H(i) or H(i)**T
286*
287 CALL slarz( side, mi, ni, l, a( i, ja ), lda, tau( i ),
288 $ c( ic, jc ), ldc, work )
289*
290 10 CONTINUE
291*
292 RETURN
293*
294* End of SORMR3
295*

◆ sormrq()

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

SORMRQ

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

Purpose:
!>
!> SORMRQ 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 defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1) H(2) . . . H(k)
!>
!> as returned by SGERQF. 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**T from the Left;
!>          = 'R': apply Q or Q**T from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'T':  Transpose, apply Q**T.
!>
[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 REAL 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
!>          SGERQF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by SGERQF.
!>
[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 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 sormrq.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 REAL 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 slarfb, slarft, sormr2, 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, 'T' ) ) 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, 'SORMRQ', 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( 'SORMRQ', -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, 'SORMRQ', 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 sormr2( 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 = 'T'
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 slarft( '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**T 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**T 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**T
334*
335 CALL slarfb( 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 SORMRQ
344*

◆ sormrz()

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

SORMRZ

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

Purpose:
!>
!> SORMRZ 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 defined as the product of k
!> elementary reflectors
!>
!>       Q = H(1) H(2) . . . H(k)
!>
!> as returned by STZRZF. 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**T from the Left;
!>          = 'R': apply Q or Q**T from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'T':  Transpose, apply Q**T.
!>
[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 REAL 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
!>          STZRZF 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 REAL array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by STZRZF.
!>
[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**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 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 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 sormrz.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 REAL 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 slarzb, slarzt, sormr3, 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, 'T' ) ) 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, 'SORMRQ', 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( 'SORMRZ', -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 nbmin = 2
291 ldwork = nw
292 IF( nb.GT.1 .AND. nb.LT.k ) THEN
293 IF( lwork.LT.lwkopt ) THEN
294 nb = (lwork-tsize) / ldwork
295 nbmin = max( 2, ilaenv( 2, 'SORMRQ', side // trans, m, n, k,
296 $ -1 ) )
297 END IF
298 END IF
299*
300 IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
301*
302* Use unblocked code
303*
304 CALL sormr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,
305 $ work, iinfo )
306 ELSE
307*
308* Use blocked code
309*
310 iwt = 1 + nw*nb
311 IF( ( left .AND. .NOT.notran ) .OR.
312 $ ( .NOT.left .AND. notran ) ) THEN
313 i1 = 1
314 i2 = k
315 i3 = nb
316 ELSE
317 i1 = ( ( k-1 ) / nb )*nb + 1
318 i2 = 1
319 i3 = -nb
320 END IF
321*
322 IF( left ) THEN
323 ni = n
324 jc = 1
325 ja = m - l + 1
326 ELSE
327 mi = m
328 ic = 1
329 ja = n - l + 1
330 END IF
331*
332 IF( notran ) THEN
333 transt = 'T'
334 ELSE
335 transt = 'N'
336 END IF
337*
338 DO 10 i = i1, i2, i3
339 ib = min( nb, k-i+1 )
340*
341* Form the triangular factor of the block reflector
342* H = H(i+ib-1) . . . H(i+1) H(i)
343*
344 CALL slarzt( 'Backward', 'Rowwise', l, ib, a( i, ja ), lda,
345 $ tau( i ), work( iwt ), ldt )
346*
347 IF( left ) THEN
348*
349* H or H**T is applied to C(i:m,1:n)
350*
351 mi = m - i + 1
352 ic = i
353 ELSE
354*
355* H or H**T is applied to C(1:m,i:n)
356*
357 ni = n - i + 1
358 jc = i
359 END IF
360*
361* Apply H or H**T
362*
363 CALL slarzb( side, transt, 'Backward', 'Rowwise', mi, ni,
364 $ ib, l, a( i, ja ), lda, work( iwt ), ldt,
365 $ c( ic, jc ), ldc, work, ldwork )
366 10 CONTINUE
367*
368 END IF
369*
370 work( 1 ) = lwkopt
371*
372 RETURN
373*
374* End of SORMRZ
375*
slarzb
subroutine slarzb(side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, c, ldc, work, ldwork)
SLARZB applies a block reflector or its transpose to a general matrix.
Definition slarzb.f:183
slarzt
subroutine slarzt(direct, storev, n, k, v, ldv, tau, t, ldt)
SLARZT forms the triangular factor T of a block reflector H = I - vtvH.
Definition slarzt.f:185
sormr3
subroutine sormr3(side, trans, m, n, k, l, a, lda, tau, c, ldc, work, info)
SORMR3 multiplies a general matrix by the orthogonal matrix from a RZ factorization determined by stz...
Definition sormr3.f:178

◆ sormtr()

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

SORMTR

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

Purpose:
!>
!> SORMTR 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'. Q is defined as the product of
!> nq-1 elementary reflectors, as returned by SSYTRD:
!>
!> 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**T from the Left;
!>          = 'R': apply Q or Q**T from the Right.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U': Upper triangle of A contains elementary reflectors
!>                 from SSYTRD;
!>          = 'L': Lower triangle of A contains elementary reflectors
!>                 from SSYTRD.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'T':  Transpose, apply Q**T.
!>
[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 REAL array, dimension
!>                               (LDA,M) if SIDE = 'L'
!>                               (LDA,N) if SIDE = 'R'
!>          The vectors which define the elementary reflectors, as
!>          returned by SSYTRD.
!>
[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 REAL 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 SSYTRD.
!>
[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 >= 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 sormtr.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 REAL 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, NI, NB, NQ, NW
191* ..
192* .. External Functions ..
193 LOGICAL LSAME
194 INTEGER ILAENV
195 EXTERNAL ilaenv, lsame
196* ..
197* .. External Subroutines ..
198 EXTERNAL sormql, sormqr, 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, 'T' ) )
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, 'SORMQL', side // trans, m-1, n, m-1,
244 $ -1 )
245 ELSE
246 nb = ilaenv( 1, 'SORMQL', side // trans, m, n-1, n-1,
247 $ -1 )
248 END IF
249 ELSE
250 IF( left ) THEN
251 nb = ilaenv( 1, 'SORMQR', side // trans, m-1, n, m-1,
252 $ -1 )
253 ELSE
254 nb = ilaenv( 1, 'SORMQR', 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( 'SORMTR', -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 SSYTRD with UPLO = 'U'
287*
288 CALL sormql( 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 SSYTRD 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 sormqr( 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 SORMTR
308*
sormql
subroutine sormql(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
SORMQL
Definition sormql.f:168

◆ spbcon()

subroutine spbcon ( character uplo,
integer n,
integer kd,
real, dimension( ldab, * ) ab,
integer ldab,
real anorm,
real rcond,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

SPBCON

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

Purpose:
!>
!> SPBCON estimates the reciprocal of the condition number (in the
!> 1-norm) of a real symmetric positive definite band matrix using the
!> Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.
!>
!> 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 subdiagonals if UPLO = 'L'.  KD >= 0.
!>
[in]AB
!>          AB is REAL array, dimension (LDAB,N)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**T*U or A = L*L**T 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 symmetric 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 REAL array, dimension (3*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 130 of file spbcon.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 UPLO
139 INTEGER INFO, KD, LDAB, N
140 REAL ANORM, RCOND
141* ..
142* .. Array Arguments ..
143 INTEGER IWORK( * )
144 REAL AB( LDAB, * ), WORK( * )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 REAL ONE, ZERO
151 parameter( one = 1.0e+0, zero = 0.0e+0 )
152* ..
153* .. Local Scalars ..
154 LOGICAL UPPER
155 CHARACTER NORMIN
156 INTEGER IX, KASE
157 REAL AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
158* ..
159* .. Local Arrays ..
160 INTEGER ISAVE( 3 )
161* ..
162* .. External Functions ..
163 LOGICAL LSAME
164 INTEGER ISAMAX
165 REAL SLAMCH
166 EXTERNAL lsame, isamax, slamch
167* ..
168* .. External Subroutines ..
169 EXTERNAL slacn2, slatbs, srscl, xerbla
170* ..
171* .. Intrinsic Functions ..
172 INTRINSIC abs
173* ..
174* .. Executable Statements ..
175*
176* Test the input parameters.
177*
178 info = 0
179 upper = lsame( uplo, 'U' )
180 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
181 info = -1
182 ELSE IF( n.LT.0 ) THEN
183 info = -2
184 ELSE IF( kd.LT.0 ) THEN
185 info = -3
186 ELSE IF( ldab.LT.kd+1 ) THEN
187 info = -5
188 ELSE IF( anorm.LT.zero ) THEN
189 info = -6
190 END IF
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'SPBCON', -info )
193 RETURN
194 END IF
195*
196* Quick return if possible
197*
198 rcond = zero
199 IF( n.EQ.0 ) THEN
200 rcond = one
201 RETURN
202 ELSE IF( anorm.EQ.zero ) THEN
203 RETURN
204 END IF
205*
206 smlnum = slamch( 'Safe minimum' )
207*
208* Estimate the 1-norm of the inverse.
209*
210 kase = 0
211 normin = 'N'
212 10 CONTINUE
213 CALL slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
214 IF( kase.NE.0 ) THEN
215 IF( upper ) THEN
216*
217* Multiply by inv(U**T).
218*
219 CALL slatbs( 'Upper', 'Transpose', 'Non-unit', normin, n,
220 $ kd, ab, ldab, work, scalel, work( 2*n+1 ),
221 $ info )
222 normin = 'Y'
223*
224* Multiply by inv(U).
225*
226 CALL slatbs( 'Upper', 'No transpose', 'Non-unit', normin, n,
227 $ kd, ab, ldab, work, scaleu, work( 2*n+1 ),
228 $ info )
229 ELSE
230*
231* Multiply by inv(L).
232*
233 CALL slatbs( 'Lower', 'No transpose', 'Non-unit', normin, n,
234 $ kd, ab, ldab, work, scalel, work( 2*n+1 ),
235 $ info )
236 normin = 'Y'
237*
238* Multiply by inv(L**T).
239*
240 CALL slatbs( 'Lower', 'Transpose', 'Non-unit', normin, n,
241 $ kd, ab, ldab, work, scaleu, work( 2*n+1 ),
242 $ info )
243 END IF
244*
245* Multiply by 1/SCALE if doing so will not cause overflow.
246*
247 scale = scalel*scaleu
248 IF( scale.NE.one ) THEN
249 ix = isamax( n, work, 1 )
250 IF( scale.LT.abs( work( ix ) )*smlnum .OR. scale.EQ.zero )
251 $ GO TO 20
252 CALL srscl( n, scale, work, 1 )
253 END IF
254 GO TO 10
255 END IF
256*
257* Compute the estimate of the reciprocal condition number.
258*
259 IF( ainvnm.NE.zero )
260 $ rcond = ( one / ainvnm ) / anorm
261*
262 20 CONTINUE
263*
264 RETURN
265*
266* End of SPBCON
267*
slatbs
subroutine slatbs(uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
SLATBS solves a triangular banded system of equations.
Definition slatbs.f:242
srscl
subroutine srscl(n, sa, sx, incx)
SRSCL multiplies a vector by the reciprocal of a real scalar.
Definition srscl.f:84
slacn2
subroutine slacn2(n, v, x, isgn, est, kase, isave)
SLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
Definition slacn2.f:136

◆ spbequ()

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

SPBEQU

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

Purpose:
!>
!> SPBEQU computes row and column scalings intended to equilibrate a
!> symmetric 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 REAL array, dimension (LDAB,N)
!>          The upper or lower triangle of the symmetric band matrix A,
!>          stored in the first KD+1 rows of the array.  The j-th column
!>          of A is stored in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
[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 128 of file spbequ.f.

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

◆ spbrfs()

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

SPBRFS

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

Purpose:
!>
!> SPBRFS improves the computed solution to a system of linear
!> equations when the coefficient matrix is symmetric 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 REAL array, dimension (LDAB,N)
!>          The upper or lower triangle of the symmetric band matrix A,
!>          stored in the first KD+1 rows of the array.  The j-th column
!>          of A is stored in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[in]AFB
!>          AFB is REAL array, dimension (LDAFB,N)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**T*U or A = L*L**T of the band matrix A as computed by
!>          SPBTRF, 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 REAL 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 REAL array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by SPBTRS.
!>          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 REAL array, dimension (3*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 spbrfs.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 INTEGER IWORK( * )
200 REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
201 $ BERR( * ), FERR( * ), 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 REAL ONE
212 parameter( one = 1.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* ..
223* .. Local Arrays ..
224 INTEGER ISAVE( 3 )
225* ..
226* .. External Subroutines ..
227 EXTERNAL saxpy, scopy, slacn2, spbtrs, ssbmv, xerbla
228* ..
229* .. Intrinsic Functions ..
230 INTRINSIC abs, max, min
231* ..
232* .. External Functions ..
233 LOGICAL LSAME
234 REAL SLAMCH
235 EXTERNAL lsame, slamch
236* ..
237* .. Executable Statements ..
238*
239* Test the input parameters.
240*
241 info = 0
242 upper = lsame( uplo, 'U' )
243 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
244 info = -1
245 ELSE IF( n.LT.0 ) THEN
246 info = -2
247 ELSE IF( kd.LT.0 ) THEN
248 info = -3
249 ELSE IF( nrhs.LT.0 ) THEN
250 info = -4
251 ELSE IF( ldab.LT.kd+1 ) THEN
252 info = -6
253 ELSE IF( ldafb.LT.kd+1 ) THEN
254 info = -8
255 ELSE IF( ldb.LT.max( 1, n ) ) THEN
256 info = -10
257 ELSE IF( ldx.LT.max( 1, n ) ) THEN
258 info = -12
259 END IF
260 IF( info.NE.0 ) THEN
261 CALL xerbla( 'SPBRFS', -info )
262 RETURN
263 END IF
264*
265* Quick return if possible
266*
267 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
268 DO 10 j = 1, nrhs
269 ferr( j ) = zero
270 berr( j ) = zero
271 10 CONTINUE
272 RETURN
273 END IF
274*
275* NZ = maximum number of nonzero elements in each row of A, plus 1
276*
277 nz = min( n+1, 2*kd+2 )
278 eps = slamch( 'Epsilon' )
279 safmin = slamch( 'Safe minimum' )
280 safe1 = nz*safmin
281 safe2 = safe1 / eps
282*
283* Do for each right hand side
284*
285 DO 140 j = 1, nrhs
286*
287 count = 1
288 lstres = three
289 20 CONTINUE
290*
291* Loop until stopping criterion is satisfied.
292*
293* Compute residual R = B - A * X
294*
295 CALL scopy( n, b( 1, j ), 1, work( n+1 ), 1 )
296 CALL ssbmv( uplo, n, kd, -one, ab, ldab, x( 1, j ), 1, one,
297 $ work( n+1 ), 1 )
298*
299* Compute componentwise relative backward error from formula
300*
301* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
302*
303* where abs(Z) is the componentwise absolute value of the matrix
304* or vector Z. If the i-th component of the denominator is less
305* than SAFE2, then SAFE1 is added to the i-th components of the
306* numerator and denominator before dividing.
307*
308 DO 30 i = 1, n
309 work( i ) = abs( b( i, j ) )
310 30 CONTINUE
311*
312* Compute abs(A)*abs(X) + abs(B).
313*
314 IF( upper ) THEN
315 DO 50 k = 1, n
316 s = zero
317 xk = abs( x( k, j ) )
318 l = kd + 1 - k
319 DO 40 i = max( 1, k-kd ), k - 1
320 work( i ) = work( i ) + abs( ab( l+i, k ) )*xk
321 s = s + abs( ab( l+i, k ) )*abs( x( i, j ) )
322 40 CONTINUE
323 work( k ) = work( k ) + abs( ab( kd+1, k ) )*xk + s
324 50 CONTINUE
325 ELSE
326 DO 70 k = 1, n
327 s = zero
328 xk = abs( x( k, j ) )
329 work( k ) = work( k ) + abs( ab( 1, k ) )*xk
330 l = 1 - k
331 DO 60 i = k + 1, min( n, k+kd )
332 work( i ) = work( i ) + abs( ab( l+i, k ) )*xk
333 s = s + abs( ab( l+i, k ) )*abs( x( i, j ) )
334 60 CONTINUE
335 work( k ) = work( k ) + s
336 70 CONTINUE
337 END IF
338 s = zero
339 DO 80 i = 1, n
340 IF( work( i ).GT.safe2 ) THEN
341 s = max( s, abs( work( n+i ) ) / work( i ) )
342 ELSE
343 s = max( s, ( abs( work( n+i ) )+safe1 ) /
344 $ ( work( i )+safe1 ) )
345 END IF
346 80 CONTINUE
347 berr( j ) = s
348*
349* Test stopping criterion. Continue iterating if
350* 1) The residual BERR(J) is larger than machine epsilon, and
351* 2) BERR(J) decreased by at least a factor of 2 during the
352* last iteration, and
353* 3) At most ITMAX iterations tried.
354*
355 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
356 $ count.LE.itmax ) THEN
357*
358* Update solution and try again.
359*
360 CALL spbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n,
361 $ info )
362 CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 )
363 lstres = berr( j )
364 count = count + 1
365 GO TO 20
366 END IF
367*
368* Bound error from formula
369*
370* norm(X - XTRUE) / norm(X) .le. FERR =
371* norm( abs(inv(A))*
372* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
373*
374* where
375* norm(Z) is the magnitude of the largest component of Z
376* inv(A) is the inverse of A
377* abs(Z) is the componentwise absolute value of the matrix or
378* vector Z
379* NZ is the maximum number of nonzeros in any row of A, plus 1
380* EPS is machine epsilon
381*
382* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
383* is incremented by SAFE1 if the i-th component of
384* abs(A)*abs(X) + abs(B) is less than SAFE2.
385*
386* Use SLACN2 to estimate the infinity-norm of the matrix
387* inv(A) * diag(W),
388* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
389*
390 DO 90 i = 1, n
391 IF( work( i ).GT.safe2 ) THEN
392 work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
393 ELSE
394 work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
395 END IF
396 90 CONTINUE
397*
398 kase = 0
399 100 CONTINUE
400 CALL slacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),
401 $ kase, isave )
402 IF( kase.NE.0 ) THEN
403 IF( kase.EQ.1 ) THEN
404*
405* Multiply by diag(W)*inv(A**T).
406*
407 CALL spbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n,
408 $ info )
409 DO 110 i = 1, n
410 work( n+i ) = work( n+i )*work( i )
411 110 CONTINUE
412 ELSE IF( kase.EQ.2 ) THEN
413*
414* Multiply by inv(A)*diag(W).
415*
416 DO 120 i = 1, n
417 work( n+i ) = work( n+i )*work( i )
418 120 CONTINUE
419 CALL spbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n,
420 $ info )
421 END IF
422 GO TO 100
423 END IF
424*
425* Normalize error.
426*
427 lstres = zero
428 DO 130 i = 1, n
429 lstres = max( lstres, abs( x( i, j ) ) )
430 130 CONTINUE
431 IF( lstres.NE.zero )
432 $ ferr( j ) = ferr( j ) / lstres
433*
434 140 CONTINUE
435*
436 RETURN
437*
438* End of SPBRFS
439*
spbtrs
subroutine spbtrs(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
SPBTRS
Definition spbtrs.f:121
ssbmv
subroutine ssbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
SSBMV
Definition ssbmv.f:184

◆ spbstf()

subroutine spbstf ( character uplo,
integer n,
integer kd,
real, dimension( ldab, * ) ab,
integer ldab,
integer info )

SPBSTF

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

Purpose:
!>
!> SPBSTF computes a split Cholesky factorization of a real
!> symmetric positive definite band matrix A.
!>
!> This routine is designed to be used in conjunction with SSBGST.
!>
!> The factorization has the form  A = S**T*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 REAL array, dimension (LDAB,N)
!>          On entry, the upper or lower triangle of the symmetric band
!>          matrix A, stored in the first kd+1 rows of the array.  The
!>          j-th column of A is stored in the j-th column of the array AB
!>          as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
!>          On exit, if INFO = 0, the factor S from the split Cholesky
!>          factorization A = S**T*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  s64  s75
!>   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54  s65  s76
!>  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  s23  s34  s54  s65  s76   *
!>  a31  a42  a53  a64  a64   *    *   s13  s24  s53  s64  s75   *    *
!>
!>  Array elements marked * are not used by the routine.
!>

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

◆ spbtf2()

subroutine spbtf2 ( character uplo,
integer n,
integer kd,
real, dimension( ldab, * ) ab,
integer ldab,
integer info )

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

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

Purpose:
!>
!> SPBTF2 computes the Cholesky factorization of a real symmetric
!> positive definite band matrix A.
!>
!> The factorization has the form
!>    A = U**T * U ,  if UPLO = 'U', or
!>    A = L  * L**T,  if UPLO = 'L',
!> where U is an upper triangular matrix, U**T is the 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
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of super-diagonals of the matrix A if UPLO = 'U',
!>          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
!>
[in,out]AB
!>          AB is REAL array, dimension (LDAB,N)
!>          On entry, the upper or lower triangle of the symmetric band
!>          matrix A, stored in the first KD+1 rows of the array.  The
!>          j-th column of A is stored in the j-th column of the array AB
!>          as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
!>          On exit, if INFO = 0, the triangular factor U or L from the
!>          Cholesky factorization A = U**T*U or A = L*L**T of the band
!>          matrix A, in the same storage format as A.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[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 spbtf2.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 REAL 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 sscal, ssyr, xerbla
172* ..
173* .. Intrinsic Functions ..
174 INTRINSIC max, min, sqrt
175* ..
176* .. Executable Statements ..
177*
178* Test the input parameters.
179*
180 info = 0
181 upper = lsame( uplo, 'U' )
182 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
183 info = -1
184 ELSE IF( n.LT.0 ) THEN
185 info = -2
186 ELSE IF( kd.LT.0 ) THEN
187 info = -3
188 ELSE IF( ldab.LT.kd+1 ) THEN
189 info = -5
190 END IF
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'SPBTF2', -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**T*U.
206*
207 DO 10 j = 1, n
208*
209* Compute U(J,J) and test for non-positive-definiteness.
210*
211 ajj = ab( kd+1, j )
212 IF( ajj.LE.zero )
213 $ GO TO 30
214 ajj = sqrt( ajj )
215 ab( kd+1, j ) = ajj
216*
217* Compute elements J+1:J+KN of row J and update the
218* trailing submatrix within the band.
219*
220 kn = min( kd, n-j )
221 IF( kn.GT.0 ) THEN
222 CALL sscal( kn, one / ajj, ab( kd, j+1 ), kld )
223 CALL ssyr( 'Upper', kn, -one, ab( kd, j+1 ), kld,
224 $ ab( kd+1, j+1 ), kld )
225 END IF
226 10 CONTINUE
227 ELSE
228*
229* Compute the Cholesky factorization A = L*L**T.
230*
231 DO 20 j = 1, n
232*
233* Compute L(J,J) and test for non-positive-definiteness.
234*
235 ajj = ab( 1, j )
236 IF( ajj.LE.zero )
237 $ GO TO 30
238 ajj = sqrt( ajj )
239 ab( 1, j ) = ajj
240*
241* Compute elements J+1:J+KN of column J and update the
242* trailing submatrix within the band.
243*
244 kn = min( kd, n-j )
245 IF( kn.GT.0 ) THEN
246 CALL sscal( kn, one / ajj, ab( 2, j ), 1 )
247 CALL ssyr( 'Lower', kn, -one, ab( 2, j ), 1,
248 $ ab( 1, j+1 ), kld )
249 END IF
250 20 CONTINUE
251 END IF
252 RETURN
253*
254 30 CONTINUE
255 info = j
256 RETURN
257*
258* End of SPBTF2
259*

◆ spbtrf()

subroutine spbtrf ( character uplo,
integer n,
integer kd,
real, dimension( ldab, * ) ab,
integer ldab,
integer info )

SPBTRF

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

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

◆ spbtrs()

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

SPBTRS

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

Purpose:
!>
!> SPBTRS solves a system of linear equations A*X = B with a symmetric
!> positive definite band matrix A using the Cholesky factorization
!> A = U**T*U or A = L*L**T computed by SPBTRF.
!>
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 REAL array, dimension (LDAB,N)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**T*U or A = L*L**T 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 REAL 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 spbtrs.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 REAL 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 stbsv, 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( 'SPBTRS', -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**T *U.
182*
183 DO 10 j = 1, nrhs
184*
185* Solve U**T *X = B, overwriting B with X.
186*
187 CALL stbsv( 'Upper', 'Transpose', 'Non-unit', n, kd, ab,
188 $ ldab, b( 1, j ), 1 )
189*
190* Solve U*X = B, overwriting B with X.
191*
192 CALL stbsv( '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**T.
198*
199 DO 20 j = 1, nrhs
200*
201* Solve L*X = B, overwriting B with X.
202*
203 CALL stbsv( 'Lower', 'No transpose', 'Non-unit', n, kd, ab,
204 $ ldab, b( 1, j ), 1 )
205*
206* Solve L**T *X = B, overwriting B with X.
207*
208 CALL stbsv( 'Lower', 'Transpose', 'Non-unit', n, kd, ab,
209 $ ldab, b( 1, j ), 1 )
210 20 CONTINUE
211 END IF
212*
213 RETURN
214*
215* End of SPBTRS
216*
stbsv
subroutine stbsv(uplo, trans, diag, n, k, a, lda, x, incx)
STBSV
Definition stbsv.f:189

◆ spftrf()

subroutine spftrf ( character transr,
character uplo,
integer n,
real, dimension( 0: * ) a,
integer info )

SPFTRF

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

Purpose:
!>
!> SPFTRF computes the Cholesky factorization of a real symmetric
!> positive definite matrix A.
!>
!> The factorization has the form
!>    A = U**T * U,  if UPLO = 'U', or
!>    A = L  * L**T,  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;
!>          = 'T':  The 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 REAL array, dimension ( N*(N+1)/2 );
!>          On entry, the symmetric 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 = 'T' then RFP is
!>          the 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 =
!>          'T'. 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**T*U or RFP A = L*L**T.
!>
[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:
!>
!>  We first consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last three columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 then consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last two columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 197 of file spftrf.f.

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

◆ spftri()

subroutine spftri ( character transr,
character uplo,
integer n,
real, dimension( 0: * ) a,
integer info )

SPFTRI

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

Purpose:
!>
!> SPFTRI computes the inverse of a real (symmetric) positive definite
!> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!> computed by SPFTRF.
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  The Normal TRANSR of RFP A is stored;
!>          = 'T':  The 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 REAL array, dimension ( N*(N+1)/2 )
!>          On entry, the symmetric 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 = 'T' then RFP is
!>          the 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 =
!>          'T'. 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 symmetric 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 Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last three columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 then consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last two columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 190 of file spftri.f.

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

◆ spftrs()

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

SPFTRS

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

Purpose:
!>
!> SPFTRS solves a system of linear equations A*X = B with a symmetric
!> positive definite matrix A using the Cholesky factorization
!> A = U**T*U or A = L*L**T computed by SPFTRF.
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  The Normal TRANSR of RFP A is stored;
!>          = 'T':  The 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 REAL 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**T, as computed by SPFTRF.
!>          See note below for more details about RFP A.
!>
[in,out]B
!>          B is REAL 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 Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last three columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 then consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last two columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 198 of file spftrs.f.

199*
200* -- LAPACK computational routine --
201* -- LAPACK is a software package provided by Univ. of Tennessee, --
202* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
203*
204* .. Scalar Arguments ..
205 CHARACTER TRANSR, UPLO
206 INTEGER INFO, LDB, N, NRHS
207* ..
208* .. Array Arguments ..
209 REAL A( 0: * ), B( LDB, * )
210* ..
211*
212* =====================================================================
213*
214* .. Parameters ..
215 REAL ONE
216 parameter( one = 1.0e+0 )
217* ..
218* .. Local Scalars ..
219 LOGICAL LOWER, NORMALTRANSR
220* ..
221* .. External Functions ..
222 LOGICAL LSAME
223 EXTERNAL lsame
224* ..
225* .. External Subroutines ..
226 EXTERNAL xerbla, stfsm
227* ..
228* .. Intrinsic Functions ..
229 INTRINSIC max
230* ..
231* .. Executable Statements ..
232*
233* Test the input parameters.
234*
235 info = 0
236 normaltransr = lsame( transr, 'N' )
237 lower = lsame( uplo, 'L' )
238 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'T' ) ) THEN
239 info = -1
240 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
241 info = -2
242 ELSE IF( n.LT.0 ) THEN
243 info = -3
244 ELSE IF( nrhs.LT.0 ) THEN
245 info = -4
246 ELSE IF( ldb.LT.max( 1, n ) ) THEN
247 info = -7
248 END IF
249 IF( info.NE.0 ) THEN
250 CALL xerbla( 'SPFTRS', -info )
251 RETURN
252 END IF
253*
254* Quick return if possible
255*
256 IF( n.EQ.0 .OR. nrhs.EQ.0 )
257 $ RETURN
258*
259* start execution: there are two triangular solves
260*
261 IF( lower ) THEN
262 CALL stfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,
263 $ ldb )
264 CALL stfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,
265 $ ldb )
266 ELSE
267 CALL stfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,
268 $ ldb )
269 CALL stfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,
270 $ ldb )
271 END IF
272*
273 RETURN
274*
275* End of SPFTRS
276*
stfsm
subroutine stfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
STFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition stfsm.f:277

◆ sppcon()

subroutine sppcon ( character uplo,
integer n,
real, dimension( * ) ap,
real anorm,
real rcond,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

SPPCON

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

Purpose:
!>
!> SPPCON estimates the reciprocal of the condition number (in the
!> 1-norm) of a real symmetric positive definite packed matrix using
!> the Cholesky factorization A = U**T*U or A = L*L**T computed by
!> SPPTRF.
!>
!> 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 REAL array, dimension (N*(N+1)/2)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**T*U or A = L*L**T, 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 symmetric 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 REAL array, dimension (3*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 sppcon.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 IWORK( * )
130 REAL 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* ..
145* .. Local Arrays ..
146 INTEGER ISAVE( 3 )
147* ..
148* .. External Functions ..
149 LOGICAL LSAME
150 INTEGER ISAMAX
151 REAL SLAMCH
152 EXTERNAL lsame, isamax, slamch
153* ..
154* .. External Subroutines ..
155 EXTERNAL slacn2, slatps, srscl, xerbla
156* ..
157* .. Intrinsic Functions ..
158 INTRINSIC abs
159* ..
160* .. Executable Statements ..
161*
162* Test the input parameters.
163*
164 info = 0
165 upper = lsame( uplo, 'U' )
166 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
167 info = -1
168 ELSE IF( n.LT.0 ) THEN
169 info = -2
170 ELSE IF( anorm.LT.zero ) THEN
171 info = -4
172 END IF
173 IF( info.NE.0 ) THEN
174 CALL xerbla( 'SPPCON', -info )
175 RETURN
176 END IF
177*
178* Quick return if possible
179*
180 rcond = zero
181 IF( n.EQ.0 ) THEN
182 rcond = one
183 RETURN
184 ELSE IF( anorm.EQ.zero ) THEN
185 RETURN
186 END IF
187*
188 smlnum = slamch( 'Safe minimum' )
189*
190* Estimate the 1-norm of the inverse.
191*
192 kase = 0
193 normin = 'N'
194 10 CONTINUE
195 CALL slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
196 IF( kase.NE.0 ) THEN
197 IF( upper ) THEN
198*
199* Multiply by inv(U**T).
200*
201 CALL slatps( 'Upper', 'Transpose', 'Non-unit', normin, n,
202 $ ap, work, scalel, work( 2*n+1 ), info )
203 normin = 'Y'
204*
205* Multiply by inv(U).
206*
207 CALL slatps( 'Upper', 'No transpose', 'Non-unit', normin, n,
208 $ ap, work, scaleu, work( 2*n+1 ), info )
209 ELSE
210*
211* Multiply by inv(L).
212*
213 CALL slatps( 'Lower', 'No transpose', 'Non-unit', normin, n,
214 $ ap, work, scalel, work( 2*n+1 ), info )
215 normin = 'Y'
216*
217* Multiply by inv(L**T).
218*
219 CALL slatps( 'Lower', 'Transpose', 'Non-unit', normin, n,
220 $ ap, work, scaleu, work( 2*n+1 ), info )
221 END IF
222*
223* Multiply by 1/SCALE if doing so will not cause overflow.
224*
225 scale = scalel*scaleu
226 IF( scale.NE.one ) THEN
227 ix = isamax( n, work, 1 )
228 IF( scale.LT.abs( work( ix ) )*smlnum .OR. scale.EQ.zero )
229 $ GO TO 20
230 CALL srscl( n, scale, work, 1 )
231 END IF
232 GO TO 10
233 END IF
234*
235* Compute the estimate of the reciprocal condition number.
236*
237 IF( ainvnm.NE.zero )
238 $ rcond = ( one / ainvnm ) / anorm
239*
240 20 CONTINUE
241 RETURN
242*
243* End of SPPCON
244*
slatps
subroutine slatps(uplo, trans, diag, normin, n, ap, x, scale, cnorm, info)
SLATPS solves a triangular system of equations with the matrix held in packed storage.
Definition slatps.f:229

◆ sppequ()

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

SPPEQU

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

Purpose:
!>
!> SPPEQU computes row and column scalings intended to equilibrate a
!> symmetric 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 REAL array, dimension (N*(N+1)/2)
!>          The upper or lower triangle of the symmetric matrix A, packed
!>          columnwise in a linear array.  The j-th column of A is stored
!>          in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>
[out]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 115 of file sppequ.f.

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

◆ spprfs()

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

SPPRFS

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

Purpose:
!>
!> SPPRFS improves the computed solution to a system of linear
!> equations when the coefficient matrix is symmetric 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 REAL array, dimension (N*(N+1)/2)
!>          The upper or lower triangle of the symmetric matrix A, packed
!>          columnwise in a linear array.  The j-th column of A is stored
!>          in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>
[in]AFP
!>          AFP is REAL array, dimension (N*(N+1)/2)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF,
!>          packed columnwise in a linear array in the same format as A
!>          (see AP).
!>
[in]B
!>          B is REAL 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 REAL array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by SPPTRS.
!>          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 REAL array, dimension (3*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 spprfs.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 INTEGER IWORK( * )
182 REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
183 $ FERR( * ), WORK( * ), 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 REAL ONE
194 parameter( one = 1.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* ..
205* .. Local Arrays ..
206 INTEGER ISAVE( 3 )
207* ..
208* .. External Subroutines ..
209 EXTERNAL saxpy, scopy, slacn2, spptrs, sspmv, xerbla
210* ..
211* .. Intrinsic Functions ..
212 INTRINSIC abs, max
213* ..
214* .. External Functions ..
215 LOGICAL LSAME
216 REAL SLAMCH
217 EXTERNAL lsame, slamch
218* ..
219* .. Executable Statements ..
220*
221* Test the input parameters.
222*
223 info = 0
224 upper = lsame( uplo, 'U' )
225 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
226 info = -1
227 ELSE IF( n.LT.0 ) THEN
228 info = -2
229 ELSE IF( nrhs.LT.0 ) THEN
230 info = -3
231 ELSE IF( ldb.LT.max( 1, n ) ) THEN
232 info = -7
233 ELSE IF( ldx.LT.max( 1, n ) ) THEN
234 info = -9
235 END IF
236 IF( info.NE.0 ) THEN
237 CALL xerbla( 'SPPRFS', -info )
238 RETURN
239 END IF
240*
241* Quick return if possible
242*
243 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
244 DO 10 j = 1, nrhs
245 ferr( j ) = zero
246 berr( j ) = zero
247 10 CONTINUE
248 RETURN
249 END IF
250*
251* NZ = maximum number of nonzero elements in each row of A, plus 1
252*
253 nz = n + 1
254 eps = slamch( 'Epsilon' )
255 safmin = slamch( 'Safe minimum' )
256 safe1 = nz*safmin
257 safe2 = safe1 / eps
258*
259* Do for each right hand side
260*
261 DO 140 j = 1, nrhs
262*
263 count = 1
264 lstres = three
265 20 CONTINUE
266*
267* Loop until stopping criterion is satisfied.
268*
269* Compute residual R = B - A * X
270*
271 CALL scopy( n, b( 1, j ), 1, work( n+1 ), 1 )
272 CALL sspmv( uplo, n, -one, ap, x( 1, j ), 1, one, work( n+1 ),
273 $ 1 )
274*
275* Compute componentwise relative backward error from formula
276*
277* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
278*
279* where abs(Z) is the componentwise absolute value of the matrix
280* or vector Z. If the i-th component of the denominator is less
281* than SAFE2, then SAFE1 is added to the i-th components of the
282* numerator and denominator before dividing.
283*
284 DO 30 i = 1, n
285 work( i ) = abs( b( i, j ) )
286 30 CONTINUE
287*
288* Compute abs(A)*abs(X) + abs(B).
289*
290 kk = 1
291 IF( upper ) THEN
292 DO 50 k = 1, n
293 s = zero
294 xk = abs( x( k, j ) )
295 ik = kk
296 DO 40 i = 1, k - 1
297 work( i ) = work( i ) + abs( ap( ik ) )*xk
298 s = s + abs( ap( ik ) )*abs( x( i, j ) )
299 ik = ik + 1
300 40 CONTINUE
301 work( k ) = work( k ) + abs( ap( kk+k-1 ) )*xk + s
302 kk = kk + k
303 50 CONTINUE
304 ELSE
305 DO 70 k = 1, n
306 s = zero
307 xk = abs( x( k, j ) )
308 work( k ) = work( k ) + abs( ap( kk ) )*xk
309 ik = kk + 1
310 DO 60 i = k + 1, n
311 work( i ) = work( i ) + abs( ap( ik ) )*xk
312 s = s + abs( ap( ik ) )*abs( x( i, j ) )
313 ik = ik + 1
314 60 CONTINUE
315 work( k ) = work( k ) + s
316 kk = kk + ( n-k+1 )
317 70 CONTINUE
318 END IF
319 s = zero
320 DO 80 i = 1, n
321 IF( work( i ).GT.safe2 ) THEN
322 s = max( s, abs( work( n+i ) ) / work( i ) )
323 ELSE
324 s = max( s, ( abs( work( n+i ) )+safe1 ) /
325 $ ( work( i )+safe1 ) )
326 END IF
327 80 CONTINUE
328 berr( j ) = s
329*
330* Test stopping criterion. Continue iterating if
331* 1) The residual BERR(J) is larger than machine epsilon, and
332* 2) BERR(J) decreased by at least a factor of 2 during the
333* last iteration, and
334* 3) At most ITMAX iterations tried.
335*
336 IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
337 $ count.LE.itmax ) THEN
338*
339* Update solution and try again.
340*
341 CALL spptrs( uplo, n, 1, afp, work( n+1 ), n, info )
342 CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 )
343 lstres = berr( j )
344 count = count + 1
345 GO TO 20
346 END IF
347*
348* Bound error from formula
349*
350* norm(X - XTRUE) / norm(X) .le. FERR =
351* norm( abs(inv(A))*
352* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
353*
354* where
355* norm(Z) is the magnitude of the largest component of Z
356* inv(A) is the inverse of A
357* abs(Z) is the componentwise absolute value of the matrix or
358* vector Z
359* NZ is the maximum number of nonzeros in any row of A, plus 1
360* EPS is machine epsilon
361*
362* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
363* is incremented by SAFE1 if the i-th component of
364* abs(A)*abs(X) + abs(B) is less than SAFE2.
365*
366* Use SLACN2 to estimate the infinity-norm of the matrix
367* inv(A) * diag(W),
368* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
369*
370 DO 90 i = 1, n
371 IF( work( i ).GT.safe2 ) THEN
372 work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
373 ELSE
374 work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
375 END IF
376 90 CONTINUE
377*
378 kase = 0
379 100 CONTINUE
380 CALL slacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),
381 $ kase, isave )
382 IF( kase.NE.0 ) THEN
383 IF( kase.EQ.1 ) THEN
384*
385* Multiply by diag(W)*inv(A**T).
386*
387 CALL spptrs( uplo, n, 1, afp, work( n+1 ), n, info )
388 DO 110 i = 1, n
389 work( n+i ) = work( i )*work( n+i )
390 110 CONTINUE
391 ELSE IF( kase.EQ.2 ) THEN
392*
393* Multiply by inv(A)*diag(W).
394*
395 DO 120 i = 1, n
396 work( n+i ) = work( i )*work( n+i )
397 120 CONTINUE
398 CALL spptrs( uplo, n, 1, afp, work( n+1 ), n, info )
399 END IF
400 GO TO 100
401 END IF
402*
403* Normalize error.
404*
405 lstres = zero
406 DO 130 i = 1, n
407 lstres = max( lstres, abs( x( i, j ) ) )
408 130 CONTINUE
409 IF( lstres.NE.zero )
410 $ ferr( j ) = ferr( j ) / lstres
411*
412 140 CONTINUE
413*
414 RETURN
415*
416* End of SPPRFS
417*
spptrs
subroutine spptrs(uplo, n, nrhs, ap, b, ldb, info)
SPPTRS
Definition spptrs.f:108
sspmv
subroutine sspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
SSPMV
Definition sspmv.f:147

◆ spptrf()

subroutine spptrf ( character uplo,
integer n,
real, dimension( * ) ap,
integer info )

SPPTRF

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

Purpose:
!>
!> SPPTRF computes the Cholesky factorization of a real symmetric
!> positive definite matrix A stored in packed format.
!>
!> The factorization has the form
!>    A = U**T * U,  if UPLO = 'U', or
!>    A = L  * L**T,  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 REAL 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.
!>          See below for further details.
!>
!>          On exit, if INFO = 0, the triangular factor U or L from the
!>          Cholesky factorization A = U**T*U or A = L*L**T, 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 symmetric matrix A:
!>
!>     a11 a12 a13 a14
!>         a22 a23 a24
!>             a33 a34     (aij = 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 spptrf.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 REAL 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 J, JC, JJ
141 REAL AJJ
142* ..
143* .. External Functions ..
144 LOGICAL LSAME
145 REAL SDOT
146 EXTERNAL lsame, sdot
147* ..
148* .. External Subroutines ..
149 EXTERNAL sscal, sspr, stpsv, xerbla
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC 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( 'SPPTRF', -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**T*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 stpsv( 'Upper', 'Transpose', 'Non-unit', j-1, ap,
188 $ ap( jc ), 1 )
189*
190* Compute U(J,J) and test for non-positive-definiteness.
191*
192 ajj = ap( jj ) - sdot( j-1, ap( jc ), 1, ap( jc ), 1 )
193 IF( ajj.LE.zero ) THEN
194 ap( jj ) = ajj
195 GO TO 30
196 END IF
197 ap( jj ) = sqrt( ajj )
198 10 CONTINUE
199 ELSE
200*
201* Compute the Cholesky factorization A = L*L**T.
202*
203 jj = 1
204 DO 20 j = 1, n
205*
206* Compute L(J,J) and test for non-positive-definiteness.
207*
208 ajj = ap( jj )
209 IF( ajj.LE.zero ) THEN
210 ap( jj ) = ajj
211 GO TO 30
212 END IF
213 ajj = sqrt( ajj )
214 ap( jj ) = ajj
215*
216* Compute elements J+1:N of column J and update the trailing
217* submatrix.
218*
219 IF( j.LT.n ) THEN
220 CALL sscal( n-j, one / ajj, ap( jj+1 ), 1 )
221 CALL sspr( 'Lower', n-j, -one, ap( jj+1 ), 1,
222 $ ap( jj+n-j+1 ) )
223 jj = jj + n - j + 1
224 END IF
225 20 CONTINUE
226 END IF
227 GO TO 40
228*
229 30 CONTINUE
230 info = j
231*
232 40 CONTINUE
233 RETURN
234*
235* End of SPPTRF
236*
sspr
subroutine sspr(uplo, n, alpha, x, incx, ap)
SSPR
Definition sspr.f:127
stpsv
subroutine stpsv(uplo, trans, diag, n, ap, x, incx)
STPSV
Definition stpsv.f:144

◆ spptri()

subroutine spptri ( character uplo,
integer n,
real, dimension( * ) ap,
integer info )

SPPTRI

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

Purpose:
!>
!> SPPTRI computes the inverse of a real symmetric positive definite
!> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!> computed by SPPTRF.
!>
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 REAL array, dimension (N*(N+1)/2)
!>          On entry, the triangular factor U or L from the Cholesky
!>          factorization A = U**T*U or A = L*L**T, 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 (symmetric)
!>          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 spptri.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 REAL 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 REAL SDOT
120 EXTERNAL lsame, sdot
121* ..
122* .. External Subroutines ..
123 EXTERNAL sscal, sspr, stpmv, stptri, xerbla
124* ..
125* .. Executable Statements ..
126*
127* Test the input parameters.
128*
129 info = 0
130 upper = lsame( uplo, 'U' )
131 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
132 info = -1
133 ELSE IF( n.LT.0 ) THEN
134 info = -2
135 END IF
136 IF( info.NE.0 ) THEN
137 CALL xerbla( 'SPPTRI', -info )
138 RETURN
139 END IF
140*
141* Quick return if possible
142*
143 IF( n.EQ.0 )
144 $ RETURN
145*
146* Invert the triangular Cholesky factor U or L.
147*
148 CALL stptri( uplo, 'Non-unit', n, ap, info )
149 IF( info.GT.0 )
150 $ RETURN
151*
152 IF( upper ) THEN
153*
154* Compute the product inv(U) * inv(U)**T.
155*
156 jj = 0
157 DO 10 j = 1, n
158 jc = jj + 1
159 jj = jj + j
160 IF( j.GT.1 )
161 $ CALL sspr( 'Upper', j-1, one, ap( jc ), 1, ap )
162 ajj = ap( jj )
163 CALL sscal( j, ajj, ap( jc ), 1 )
164 10 CONTINUE
165*
166 ELSE
167*
168* Compute the product inv(L)**T * inv(L).
169*
170 jj = 1
171 DO 20 j = 1, n
172 jjn = jj + n - j + 1
173 ap( jj ) = sdot( n-j+1, ap( jj ), 1, ap( jj ), 1 )
174 IF( j.LT.n )
175 $ CALL stpmv( 'Lower', 'Transpose', 'Non-unit', n-j,
176 $ ap( jjn ), ap( jj+1 ), 1 )
177 jj = jjn
178 20 CONTINUE
179 END IF
180*
181 RETURN
182*
183* End of SPPTRI
184*
stptri
subroutine stptri(uplo, diag, n, ap, info)
STPTRI
Definition stptri.f:117
stpmv
subroutine stpmv(uplo, trans, diag, n, ap, x, incx)
STPMV
Definition stpmv.f:142

◆ spptrs()

subroutine spptrs ( character uplo,
integer n,
integer nrhs,
real, dimension( * ) ap,
real, dimension( ldb, * ) b,
integer ldb,
integer info )

SPPTRS

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

Purpose:
!>
!> SPPTRS solves a system of linear equations A*X = B with a symmetric
!> positive definite matrix A in packed storage using the Cholesky
!> factorization A = U**T*U or A = L*L**T computed by SPPTRF.
!>
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 REAL array, dimension (N*(N+1)/2)
!>          The triangular factor U or L from the Cholesky factorization
!>          A = U**T*U or A = L*L**T, 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 REAL 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 spptrs.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 REAL 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 stpsv, 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( 'SPPTRS', -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**T * U.
165*
166 DO 10 i = 1, nrhs
167*
168* Solve U**T *X = B, overwriting B with X.
169*
170 CALL stpsv( 'Upper', 'Transpose', 'Non-unit', n, ap,
171 $ b( 1, i ), 1 )
172*
173* Solve U*X = B, overwriting B with X.
174*
175 CALL stpsv( '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**T.
181*
182 DO 20 i = 1, nrhs
183*
184* Solve L*Y = B, overwriting B with X.
185*
186 CALL stpsv( 'Lower', 'No transpose', 'Non-unit', n, ap,
187 $ b( 1, i ), 1 )
188*
189* Solve L**T *X = Y, overwriting B with X.
190*
191 CALL stpsv( 'Lower', 'Transpose', 'Non-unit', n, ap,
192 $ b( 1, i ), 1 )
193 20 CONTINUE
194 END IF
195*
196 RETURN
197*
198* End of SPPTRS
199*

◆ spstf2()

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

SPSTF2 computes the Cholesky factorization with complete pivoting of a real symmetric positive semidefinite matrix.

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

Purpose:
!>
!> SPSTF2 computes the Cholesky factorization with complete
!> pivoting of a real symmetric positive semidefinite matrix A.
!>
!> The factorization has the form
!>    P**T * A * P = U**T * U ,  if UPLO = 'U',
!>    P**T * A * P = L  * L**T,  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 REAL array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n by n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n by n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, if 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 140 of file spstf2.f.

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

◆ spstrf()

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

SPSTRF computes the Cholesky factorization with complete pivoting of a real symmetric positive semidefinite matrix.

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

Purpose:
!>
!> SPSTRF computes the Cholesky factorization with complete
!> pivoting of a real symmetric positive semidefinite matrix A.
!>
!> The factorization has the form
!>    P**T * A * P = U**T * U ,  if UPLO = 'U',
!>    P**T * A * P = L  * L**T,  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 REAL array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n by n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n by n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, if 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 140 of file spstrf.f.

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

◆ ssbgst()

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

SSBGST

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

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

◆ ssbtrd()

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

SSBTRD

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

Purpose:
!>
!> SSBTRD reduces a real symmetric band matrix A to symmetric
!> tridiagonal form T by an orthogonal similarity transformation:
!> Q**T * 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 REAL array, dimension (LDAB,N)
!>          On entry, the upper or lower triangle of the symmetric band
!>          matrix A, stored in the first KD+1 rows of the array.  The
!>          j-th column of A is stored in the j-th column of the array AB
!>          as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>          On exit, 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 REAL 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 orthogonal 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 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:
!>
!>  Modified by Linda Kaufman, Bell Labs.
!>

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

◆ ssfrk()

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

SSFRK performs a symmetric rank-k operation for matrix in RFP format.

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

Purpose:
!>
!> Level 3 BLAS like routine for C in RFP Format.
!>
!> SSFRK performs one of the symmetric rank--k operations
!>
!>    C := alpha*A*A**T + beta*C,
!>
!> or
!>
!>    C := alpha*A**T*A + beta*C,
!>
!> where alpha and beta are real scalars, C is an n--by--n symmetric
!> 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;
!>          = 'T':  The 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**T + beta*C.
!>
!>              TRANS = 'T' or 't'   C := alpha*A**T*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 = 'T'
!>           or 't', 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 REAL 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 REAL array, dimension (NT)
!>           NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP
!>           Format. RFP Format is described by TRANSR, UPLO and N.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 164 of file ssfrk.f.

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

◆ sspcon()

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

SSPCON

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

Purpose:
!>
!> SSPCON estimates the reciprocal of the condition number (in the
!> 1-norm) of a real symmetric packed matrix A using the factorization
!> A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
!>
!> 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 REAL 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 SSPTRF, 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 SSPTRF.
!>
[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 REAL array, dimension (2*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 123 of file sspcon.f.

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

◆ sspgst()

subroutine sspgst ( integer itype,
character uplo,
integer n,
real, dimension( * ) ap,
real, dimension( * ) bp,
integer info )

SSPGST

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

Purpose:
!>
!> SSPGST reduces a real symmetric-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**T)*A*inv(U) or inv(L)*A*inv(L**T)
!>
!> 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**T or L**T*A*L.
!>
!> B must have been previously factorized as U**T*U or L*L**T by SPPTRF.
!>
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
!>          = 2 or 3: compute U*A*U**T or L**T*A*L.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored and B is factored as
!>                  U**T*U;
!>          = 'L':  Lower triangle of A is stored and B is factored as
!>                  L*L**T.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!>
[in,out]AP
!>          AP is REAL 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, if INFO = 0, the transformed matrix, stored in the
!>          same format as A.
!>
[in]BP
!>          BP is REAL 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 SPPTRF.
!>
[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 sspgst.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 REAL AP( * ), BP( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 REAL ONE, HALF
130 parameter( one = 1.0, half = 0.5 )
131* ..
132* .. Local Scalars ..
133 LOGICAL UPPER
134 INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK
135 REAL AJJ, AKK, BJJ, BKK, CT
136* ..
137* .. External Subroutines ..
138 EXTERNAL saxpy, sscal, sspmv, sspr2, stpmv, stpsv,
139 $ xerbla
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 REAL SDOT
144 EXTERNAL lsame, sdot
145* ..
146* .. Executable Statements ..
147*
148* Test the input parameters.
149*
150 info = 0
151 upper = lsame( uplo, 'U' )
152 IF( itype.LT.1 .OR. itype.GT.3 ) THEN
153 info = -1
154 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
155 info = -2
156 ELSE IF( n.LT.0 ) THEN
157 info = -3
158 END IF
159 IF( info.NE.0 ) THEN
160 CALL xerbla( 'SSPGST', -info )
161 RETURN
162 END IF
163*
164 IF( itype.EQ.1 ) THEN
165 IF( upper ) THEN
166*
167* Compute inv(U**T)*A*inv(U)
168*
169* J1 and JJ are the indices of A(1,j) and A(j,j)
170*
171 jj = 0
172 DO 10 j = 1, n
173 j1 = jj + 1
174 jj = jj + j
175*
176* Compute the j-th column of the upper triangle of A
177*
178 bjj = bp( jj )
179 CALL stpsv( uplo, 'Transpose', 'Nonunit', j, bp,
180 $ ap( j1 ), 1 )
181 CALL sspmv( uplo, j-1, -one, ap, bp( j1 ), 1, one,
182 $ ap( j1 ), 1 )
183 CALL sscal( j-1, one / bjj, ap( j1 ), 1 )
184 ap( jj ) = ( ap( jj )-sdot( j-1, ap( j1 ), 1, bp( j1 ),
185 $ 1 ) ) / bjj
186 10 CONTINUE
187 ELSE
188*
189* Compute inv(L)*A*inv(L**T)
190*
191* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
192*
193 kk = 1
194 DO 20 k = 1, n
195 k1k1 = kk + n - k + 1
196*
197* Update the lower triangle of A(k:n,k:n)
198*
199 akk = ap( kk )
200 bkk = bp( kk )
201 akk = akk / bkk**2
202 ap( kk ) = akk
203 IF( k.LT.n ) THEN
204 CALL sscal( n-k, one / bkk, ap( kk+1 ), 1 )
205 ct = -half*akk
206 CALL saxpy( n-k, ct, bp( kk+1 ), 1, ap( kk+1 ), 1 )
207 CALL sspr2( uplo, n-k, -one, ap( kk+1 ), 1,
208 $ bp( kk+1 ), 1, ap( k1k1 ) )
209 CALL saxpy( n-k, ct, bp( kk+1 ), 1, ap( kk+1 ), 1 )
210 CALL stpsv( uplo, 'No transpose', 'Non-unit', n-k,
211 $ bp( k1k1 ), ap( kk+1 ), 1 )
212 END IF
213 kk = k1k1
214 20 CONTINUE
215 END IF
216 ELSE
217 IF( upper ) THEN
218*
219* Compute U*A*U**T
220*
221* K1 and KK are the indices of A(1,k) and A(k,k)
222*
223 kk = 0
224 DO 30 k = 1, n
225 k1 = kk + 1
226 kk = kk + k
227*
228* Update the upper triangle of A(1:k,1:k)
229*
230 akk = ap( kk )
231 bkk = bp( kk )
232 CALL stpmv( uplo, 'No transpose', 'Non-unit', k-1, bp,
233 $ ap( k1 ), 1 )
234 ct = half*akk
235 CALL saxpy( k-1, ct, bp( k1 ), 1, ap( k1 ), 1 )
236 CALL sspr2( uplo, k-1, one, ap( k1 ), 1, bp( k1 ), 1,
237 $ ap )
238 CALL saxpy( k-1, ct, bp( k1 ), 1, ap( k1 ), 1 )
239 CALL sscal( k-1, bkk, ap( k1 ), 1 )
240 ap( kk ) = akk*bkk**2
241 30 CONTINUE
242 ELSE
243*
244* Compute L**T *A*L
245*
246* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
247*
248 jj = 1
249 DO 40 j = 1, n
250 j1j1 = jj + n - j + 1
251*
252* Compute the j-th column of the lower triangle of A
253*
254 ajj = ap( jj )
255 bjj = bp( jj )
256 ap( jj ) = ajj*bjj + sdot( n-j, ap( jj+1 ), 1,
257 $ bp( jj+1 ), 1 )
258 CALL sscal( n-j, bjj, ap( jj+1 ), 1 )
259 CALL sspmv( uplo, n-j, one, ap( j1j1 ), bp( jj+1 ), 1,
260 $ one, ap( jj+1 ), 1 )
261 CALL stpmv( uplo, 'Transpose', 'Non-unit', n-j+1,
262 $ bp( jj ), ap( jj ), 1 )
263 jj = j1j1
264 40 CONTINUE
265 END IF
266 END IF
267 RETURN
268*
269* End of SSPGST
270*
sspr2
subroutine sspr2(uplo, n, alpha, x, incx, y, incy, ap)
SSPR2
Definition sspr2.f:142

◆ ssprfs()

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

SSPRFS

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

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

◆ ssptrd()

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

SSPTRD

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

Purpose:
!>
!> SSPTRD reduces a real symmetric matrix A stored in packed form to
!> symmetric tridiagonal form T by an orthogonal similarity
!> transformation: Q**T * 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 REAL 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)*(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 orthogonal
!>          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 orthogonal 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 REAL 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**T
!>
!>  where tau is a real scalar, and v is a real 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**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
!>  overwriting A(i+2:n,i), and tau is stored in TAU(i).
!>

Definition at line 149 of file ssptrd.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 UPLO
157 INTEGER INFO, N
158* ..
159* .. Array Arguments ..
160 REAL AP( * ), D( * ), E( * ), TAU( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 REAL ONE, ZERO, HALF
167 parameter( one = 1.0, zero = 0.0, half = 1.0 / 2.0 )
168* ..
169* .. Local Scalars ..
170 LOGICAL UPPER
171 INTEGER I, I1, I1I1, II
172 REAL ALPHA, TAUI
173* ..
174* .. External Subroutines ..
175 EXTERNAL saxpy, slarfg, sspmv, sspr2, xerbla
176* ..
177* .. External Functions ..
178 LOGICAL LSAME
179 REAL SDOT
180 EXTERNAL lsame, sdot
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 END IF
193 IF( info.NE.0 ) THEN
194 CALL xerbla( 'SSPTRD', -info )
195 RETURN
196 END IF
197*
198* Quick return if possible
199*
200 IF( n.LE.0 )
201 $ RETURN
202*
203 IF( upper ) THEN
204*
205* Reduce the upper triangle of A.
206* I1 is the index in AP of A(1,I+1).
207*
208 i1 = n*( n-1 ) / 2 + 1
209 DO 10 i = n - 1, 1, -1
210*
211* Generate elementary reflector H(i) = I - tau * v * v**T
212* to annihilate A(1:i-1,i+1)
213*
214 CALL slarfg( i, ap( i1+i-1 ), ap( i1 ), 1, taui )
215 e( i ) = ap( i1+i-1 )
216*
217 IF( taui.NE.zero ) THEN
218*
219* Apply H(i) from both sides to A(1:i,1:i)
220*
221 ap( i1+i-1 ) = one
222*
223* Compute y := tau * A * v storing y in TAU(1:i)
224*
225 CALL sspmv( uplo, i, taui, ap, ap( i1 ), 1, zero, tau,
226 $ 1 )
227*
228* Compute w := y - 1/2 * tau * (y**T *v) * v
229*
230 alpha = -half*taui*sdot( i, tau, 1, ap( i1 ), 1 )
231 CALL saxpy( i, alpha, ap( i1 ), 1, tau, 1 )
232*
233* Apply the transformation as a rank-2 update:
234* A := A - v * w**T - w * v**T
235*
236 CALL sspr2( uplo, i, -one, ap( i1 ), 1, tau, 1, ap )
237*
238 ap( i1+i-1 ) = e( i )
239 END IF
240 d( i+1 ) = ap( i1+i )
241 tau( i ) = taui
242 i1 = i1 - i
243 10 CONTINUE
244 d( 1 ) = ap( 1 )
245 ELSE
246*
247* Reduce the lower triangle of A. II is the index in AP of
248* A(i,i) and I1I1 is the index of A(i+1,i+1).
249*
250 ii = 1
251 DO 20 i = 1, n - 1
252 i1i1 = ii + n - i + 1
253*
254* Generate elementary reflector H(i) = I - tau * v * v**T
255* to annihilate A(i+2:n,i)
256*
257 CALL slarfg( n-i, ap( ii+1 ), ap( ii+2 ), 1, taui )
258 e( i ) = ap( ii+1 )
259*
260 IF( taui.NE.zero ) THEN
261*
262* Apply H(i) from both sides to A(i+1:n,i+1:n)
263*
264 ap( ii+1 ) = one
265*
266* Compute y := tau * A * v storing y in TAU(i:n-1)
267*
268 CALL sspmv( uplo, n-i, taui, ap( i1i1 ), ap( ii+1 ), 1,
269 $ zero, tau( i ), 1 )
270*
271* Compute w := y - 1/2 * tau * (y**T *v) * v
272*
273 alpha = -half*taui*sdot( n-i, tau( i ), 1, ap( ii+1 ),
274 $ 1 )
275 CALL saxpy( n-i, alpha, ap( ii+1 ), 1, tau( i ), 1 )
276*
277* Apply the transformation as a rank-2 update:
278* A := A - v * w**T - w * v**T
279*
280 CALL sspr2( uplo, n-i, -one, ap( ii+1 ), 1, tau( i ), 1,
281 $ ap( i1i1 ) )
282*
283 ap( ii+1 ) = e( i )
284 END IF
285 d( i ) = ap( ii )
286 tau( i ) = taui
287 ii = i1i1
288 20 CONTINUE
289 d( n ) = ap( ii )
290 END IF
291*
292 RETURN
293*
294* End of SSPTRD
295*

◆ ssptrf()

subroutine ssptrf ( character uplo,
integer n,
real, dimension( * ) ap,
integer, dimension( * ) ipiv,
integer info )

SSPTRF

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

Purpose:
!>
!> SSPTRF computes the factorization of a real 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 REAL 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 156 of file ssptrf.f.

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

◆ ssptri()

subroutine ssptri ( character uplo,
integer n,
real, dimension( * ) ap,
integer, dimension( * ) ipiv,
real, dimension( * ) work,
integer info )

SSPTRI

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

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

◆ ssptrs()

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

SSPTRS

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

Purpose:
!>
!> SSPTRS solves a system of linear equations A*X = B with a real
!> symmetric matrix A stored in packed format using the factorization
!> A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
!>
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 REAL 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 SSPTRF, 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 SSPTRF.
!>
[in,out]B
!>          B is REAL 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 ssptrs.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 REAL AP( * ), B( LDB, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 REAL ONE
133 parameter( one = 1.0e+0 )
134* ..
135* .. Local Scalars ..
136 LOGICAL UPPER
137 INTEGER J, K, KC, KP
138 REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
139* ..
140* .. External Functions ..
141 LOGICAL LSAME
142 EXTERNAL lsame
143* ..
144* .. External Subroutines ..
145 EXTERNAL sgemv, sger, sscal, sswap, 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( 'SSPTRS', -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 sswap( 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 sger( 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 sscal( 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 sswap( 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 sger( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,
226 $ b( 1, 1 ), ldb )
227 CALL sger( 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 sgemv( '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 sswap( 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 sgemv( 'Transpose', k-1, nrhs, -one, b, ldb, ap( kc ),
288 $ 1, one, b( k, 1 ), ldb )
289 CALL sgemv( '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 sswap( 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 sswap( 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 sger( 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 sscal( 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 sswap( 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 sger( n-k-1, nrhs, -one, ap( kc+2 ), 1, b( k, 1 ),
359 $ ldb, b( k+2, 1 ), ldb )
360 CALL sger( 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 sgemv( '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 sswap( 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 sgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ),
424 $ ldb, ap( kc+1 ), 1, one, b( k, 1 ), ldb )
425 CALL sgemv( '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 sswap( 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 SSPTRS
446*

◆ sstegr()

subroutine sstegr ( 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,
real, dimension( ldz, * ) z,
integer ldz,
integer, dimension( * ) isuppz,
real, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer liwork,
integer info )

SSTEGR

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

Purpose:
!>
!> SSTEGR 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.
!>
!> SSTEGR is a compatibility wrapper around the improved SSTEMR 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 : SSTEGR and SSTEMR 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 REAL 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 SLARRV.
!>                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
!>                the nonzero error code returned by SLARRE or
!>                SLARRV, 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 sstegr.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 REAL Z( LDZ, * )
279* ..
280*
281* =====================================================================
282*
283* .. Local Scalars ..
284 LOGICAL TRYRAC
285* ..
286* .. External Subroutines ..
287 EXTERNAL sstemr
288* ..
289* .. Executable Statements ..
290 info = 0
291 tryrac = .false.
292
293 CALL sstemr( 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 SSTEGR
298*
sstemr
subroutine sstemr(jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
SSTEMR
Definition sstemr.f:321

◆ sstein()

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

SSTEIN

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

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

◆ sstemr()

subroutine sstemr ( 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,
real, dimension( ldz, * ) z,
integer ldz,
integer nzc,
integer, dimension( * ) isuppz,
logical tryrac,
real, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer liwork,
integer info )

SSTEMR

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

Purpose:
!>
!> SSTEMR 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.SSTEMR 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.
!>
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 REAL 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 SLARRV.
!>                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
!>                the nonzero error code returned by SLARRE or
!>                SLARRV, 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 318 of file sstemr.f.

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

◆ stbcon()

subroutine stbcon ( character norm,
character uplo,
character diag,
integer n,
integer kd,
real, dimension( ldab, * ) ab,
integer ldab,
real rcond,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

STBCON

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

Purpose:
!>
!> STBCON 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 REAL 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 REAL array, dimension (3*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 stbcon.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 INTEGER IWORK( * )
155 REAL 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* ..
170* .. Local Arrays ..
171 INTEGER ISAVE( 3 )
172* ..
173* .. External Functions ..
174 LOGICAL LSAME
175 INTEGER ISAMAX
176 REAL SLAMCH, SLANTB
177 EXTERNAL lsame, isamax, slamch, slantb
178* ..
179* .. External Subroutines ..
180 EXTERNAL slacn2, slatbs, srscl, xerbla
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC abs, max, real
184* ..
185* .. Executable Statements ..
186*
187* Test the input parameters.
188*
189 info = 0
190 upper = lsame( uplo, 'U' )
191 onenrm = norm.EQ.'1' .OR. lsame( norm, 'O' )
192 nounit = lsame( diag, 'N' )
193*
194 IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN
195 info = -1
196 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
197 info = -2
198 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
199 info = -3
200 ELSE IF( n.LT.0 ) THEN
201 info = -4
202 ELSE IF( kd.LT.0 ) THEN
203 info = -5
204 ELSE IF( ldab.LT.kd+1 ) THEN
205 info = -7
206 END IF
207 IF( info.NE.0 ) THEN
208 CALL xerbla( 'STBCON', -info )
209 RETURN
210 END IF
211*
212* Quick return if possible
213*
214 IF( n.EQ.0 ) THEN
215 rcond = one
216 RETURN
217 END IF
218*
219 rcond = zero
220 smlnum = slamch( 'Safe minimum' )*real( max( 1, n ) )
221*
222* Compute the norm of the triangular matrix A.
223*
224 anorm = slantb( norm, uplo, diag, n, kd, ab, ldab, work )
225*
226* Continue only if ANORM > 0.
227*
228 IF( anorm.GT.zero ) THEN
229*
230* Estimate the norm of the inverse of A.
231*
232 ainvnm = zero
233 normin = 'N'
234 IF( onenrm ) THEN
235 kase1 = 1
236 ELSE
237 kase1 = 2
238 END IF
239 kase = 0
240 10 CONTINUE
241 CALL slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
242 IF( kase.NE.0 ) THEN
243 IF( kase.EQ.kase1 ) THEN
244*
245* Multiply by inv(A).
246*
247 CALL slatbs( uplo, 'No transpose', diag, normin, n, kd,
248 $ ab, ldab, work, scale, work( 2*n+1 ), info )
249 ELSE
250*
251* Multiply by inv(A**T).
252*
253 CALL slatbs( uplo, 'Transpose', diag, normin, n, kd, ab,
254 $ ldab, work, scale, work( 2*n+1 ), info )
255 END IF
256 normin = 'Y'
257*
258* Multiply by 1/SCALE if doing so will not cause overflow.
259*
260 IF( scale.NE.one ) THEN
261 ix = isamax( n, work, 1 )
262 xnorm = abs( work( ix ) )
263 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
264 $ GO TO 20
265 CALL srscl( n, scale, work, 1 )
266 END IF
267 GO TO 10
268 END IF
269*
270* Compute the estimate of the reciprocal condition number.
271*
272 IF( ainvnm.NE.zero )
273 $ rcond = ( one / anorm ) / ainvnm
274 END IF
275*
276 20 CONTINUE
277 RETURN
278*
279* End of STBCON
280*
slantb
real function slantb(norm, uplo, diag, n, k, ab, ldab, work)
SLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slantb.f:140

◆ stbrfs()

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

STBRFS

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

Purpose:
!>
!> STBRFS 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 STBTRS or some other
!> means before entering this routine.  STBRFS 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 = 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 REAL 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 REAL 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 REAL 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 REAL array, dimension (3*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 stbrfs.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 INTEGER IWORK( * )
199 REAL AB( LDAB, * ), B( LDB, * ), BERR( * ),
200 $ FERR( * ), WORK( * ), X( LDX, * )
201* ..
202*
203* =====================================================================
204*
205* .. Parameters ..
206 REAL ZERO
207 parameter( zero = 0.0e+0 )
208 REAL ONE
209 parameter( one = 1.0e+0 )
210* ..
211* .. Local Scalars ..
212 LOGICAL NOTRAN, NOUNIT, UPPER
213 CHARACTER TRANST
214 INTEGER I, J, K, KASE, NZ
215 REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
216* ..
217* .. Local Arrays ..
218 INTEGER ISAVE( 3 )
219* ..
220* .. External Subroutines ..
221 EXTERNAL saxpy, scopy, slacn2, stbmv, stbsv, xerbla
222* ..
223* .. Intrinsic Functions ..
224 INTRINSIC abs, max, min
225* ..
226* .. External Functions ..
227 LOGICAL LSAME
228 REAL SLAMCH
229 EXTERNAL lsame, slamch
230* ..
231* .. Executable Statements ..
232*
233* Test the input parameters.
234*
235 info = 0
236 upper = lsame( uplo, 'U' )
237 notran = lsame( trans, 'N' )
238 nounit = lsame( diag, 'N' )
239*
240 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
241 info = -1
242 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
243 $ lsame( trans, 'C' ) ) THEN
244 info = -2
245 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
246 info = -3
247 ELSE IF( n.LT.0 ) THEN
248 info = -4
249 ELSE IF( kd.LT.0 ) THEN
250 info = -5
251 ELSE IF( nrhs.LT.0 ) THEN
252 info = -6
253 ELSE IF( ldab.LT.kd+1 ) THEN
254 info = -8
255 ELSE IF( ldb.LT.max( 1, n ) ) THEN
256 info = -10
257 ELSE IF( ldx.LT.max( 1, n ) ) THEN
258 info = -12
259 END IF
260 IF( info.NE.0 ) THEN
261 CALL xerbla( 'STBRFS', -info )
262 RETURN
263 END IF
264*
265* Quick return if possible
266*
267 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
268 DO 10 j = 1, nrhs
269 ferr( j ) = zero
270 berr( j ) = zero
271 10 CONTINUE
272 RETURN
273 END IF
274*
275 IF( notran ) THEN
276 transt = 'T'
277 ELSE
278 transt = 'N'
279 END IF
280*
281* NZ = maximum number of nonzero elements in each row of A, plus 1
282*
283 nz = kd + 2
284 eps = slamch( 'Epsilon' )
285 safmin = slamch( 'Safe minimum' )
286 safe1 = nz*safmin
287 safe2 = safe1 / eps
288*
289* Do for each right hand side
290*
291 DO 250 j = 1, nrhs
292*
293* Compute residual R = B - op(A) * X,
294* where op(A) = A or A**T, depending on TRANS.
295*
296 CALL scopy( n, x( 1, j ), 1, work( n+1 ), 1 )
297 CALL stbmv( uplo, trans, diag, n, kd, ab, ldab, work( n+1 ),
298 $ 1 )
299 CALL saxpy( n, -one, b( 1, j ), 1, work( n+1 ), 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 work( i ) = abs( 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 = abs( x( k, j ) )
322 DO 30 i = max( 1, k-kd ), k
323 work( i ) = work( i ) +
324 $ abs( ab( kd+1+i-k, k ) )*xk
325 30 CONTINUE
326 40 CONTINUE
327 ELSE
328 DO 60 k = 1, n
329 xk = abs( x( k, j ) )
330 DO 50 i = max( 1, k-kd ), k - 1
331 work( i ) = work( i ) +
332 $ abs( ab( kd+1+i-k, k ) )*xk
333 50 CONTINUE
334 work( k ) = work( k ) + xk
335 60 CONTINUE
336 END IF
337 ELSE
338 IF( nounit ) THEN
339 DO 80 k = 1, n
340 xk = abs( x( k, j ) )
341 DO 70 i = k, min( n, k+kd )
342 work( i ) = work( i ) + abs( ab( 1+i-k, k ) )*xk
343 70 CONTINUE
344 80 CONTINUE
345 ELSE
346 DO 100 k = 1, n
347 xk = abs( x( k, j ) )
348 DO 90 i = k + 1, min( n, k+kd )
349 work( i ) = work( i ) + abs( ab( 1+i-k, k ) )*xk
350 90 CONTINUE
351 work( k ) = work( k ) + xk
352 100 CONTINUE
353 END IF
354 END IF
355 ELSE
356*
357* Compute abs(A**T)*abs(X) + abs(B).
358*
359 IF( upper ) THEN
360 IF( nounit ) THEN
361 DO 120 k = 1, n
362 s = zero
363 DO 110 i = max( 1, k-kd ), k
364 s = s + abs( ab( kd+1+i-k, k ) )*
365 $ abs( x( i, j ) )
366 110 CONTINUE
367 work( k ) = work( k ) + s
368 120 CONTINUE
369 ELSE
370 DO 140 k = 1, n
371 s = abs( x( k, j ) )
372 DO 130 i = max( 1, k-kd ), k - 1
373 s = s + abs( ab( kd+1+i-k, k ) )*
374 $ abs( x( i, j ) )
375 130 CONTINUE
376 work( k ) = work( k ) + s
377 140 CONTINUE
378 END IF
379 ELSE
380 IF( nounit ) THEN
381 DO 160 k = 1, n
382 s = zero
383 DO 150 i = k, min( n, k+kd )
384 s = s + abs( ab( 1+i-k, k ) )*abs( x( i, j ) )
385 150 CONTINUE
386 work( k ) = work( k ) + s
387 160 CONTINUE
388 ELSE
389 DO 180 k = 1, n
390 s = abs( x( k, j ) )
391 DO 170 i = k + 1, min( n, k+kd )
392 s = s + abs( ab( 1+i-k, k ) )*abs( x( i, j ) )
393 170 CONTINUE
394 work( k ) = work( k ) + s
395 180 CONTINUE
396 END IF
397 END IF
398 END IF
399 s = zero
400 DO 190 i = 1, n
401 IF( work( i ).GT.safe2 ) THEN
402 s = max( s, abs( work( n+i ) ) / work( i ) )
403 ELSE
404 s = max( s, ( abs( work( n+i ) )+safe1 ) /
405 $ ( work( i )+safe1 ) )
406 END IF
407 190 CONTINUE
408 berr( j ) = s
409*
410* Bound error from formula
411*
412* norm(X - XTRUE) / norm(X) .le. FERR =
413* norm( abs(inv(op(A)))*
414* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
415*
416* where
417* norm(Z) is the magnitude of the largest component of Z
418* inv(op(A)) is the inverse of op(A)
419* abs(Z) is the componentwise absolute value of the matrix or
420* vector Z
421* NZ is the maximum number of nonzeros in any row of A, plus 1
422* EPS is machine epsilon
423*
424* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
425* is incremented by SAFE1 if the i-th component of
426* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
427*
428* Use SLACN2 to estimate the infinity-norm of the matrix
429* inv(op(A)) * diag(W),
430* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
431*
432 DO 200 i = 1, n
433 IF( work( i ).GT.safe2 ) THEN
434 work( i ) = abs( work( n+i ) ) + nz*eps*work( i )
435 ELSE
436 work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1
437 END IF
438 200 CONTINUE
439*
440 kase = 0
441 210 CONTINUE
442 CALL slacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),
443 $ kase, isave )
444 IF( kase.NE.0 ) THEN
445 IF( kase.EQ.1 ) THEN
446*
447* Multiply by diag(W)*inv(op(A)**T).
448*
449 CALL stbsv( uplo, transt, diag, n, kd, ab, ldab,
450 $ work( n+1 ), 1 )
451 DO 220 i = 1, n
452 work( n+i ) = work( i )*work( n+i )
453 220 CONTINUE
454 ELSE
455*
456* Multiply by inv(op(A))*diag(W).
457*
458 DO 230 i = 1, n
459 work( n+i ) = work( i )*work( n+i )
460 230 CONTINUE
461 CALL stbsv( uplo, trans, diag, n, kd, ab, ldab,
462 $ work( n+1 ), 1 )
463 END IF
464 GO TO 210
465 END IF
466*
467* Normalize error.
468*
469 lstres = zero
470 DO 240 i = 1, n
471 lstres = max( lstres, abs( x( i, j ) ) )
472 240 CONTINUE
473 IF( lstres.NE.zero )
474 $ ferr( j ) = ferr( j ) / lstres
475*
476 250 CONTINUE
477*
478 RETURN
479*
480* End of STBRFS
481*
stbmv
subroutine stbmv(uplo, trans, diag, n, k, a, lda, x, incx)
STBMV
Definition stbmv.f:186

◆ stbtrs()

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

STBTRS

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

Purpose:
!>
!> STBTRS solves a triangular system of the form
!>
!>    A * X = B  or  A**T * 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 the system of equations:
!>          = 'N':  A * X = B  (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose = 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 REAL 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 REAL 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 stbtrs.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 REAL AB( LDAB, * ), B( LDB, * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 REAL ZERO
163 parameter( zero = 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 stbsv, 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( 'STBTRS', -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 or A**T * X = B.
232*
233 DO 30 j = 1, nrhs
234 CALL stbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1, j ), 1 )
235 30 CONTINUE
236*
237 RETURN
238*
239* End of STBTRS
240*

◆ stfsm()

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

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

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

Purpose:
!>
!> Level 3 BLAS like routine for A in RFP Format.
!>
!> STFSM  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**T.
!>
!> 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;
!>          = 'T':  The 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  = 'T' or 't'   op( A ) = 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 REAL
!>           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 REAL array, dimension (NT)
!>           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 = 'T' then RFP is the 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
!>           transpose Format. If UPLO = 'L' the RFP A contains
!>           the NT elements of lower packed A either in normal or
!>           transpose Format. The LDA of RFP A is (N+1)/2 when
!>           TRANSR = 'T'. 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 REAL 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 Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last three columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 then consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last two columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 275 of file stfsm.f.

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

◆ stftri()

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

STFTRI

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

Purpose:
!>
!> STFTRI 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;
!>          = 'T':  The 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 REAL array, dimension (NT);
!>          NT=N*(N+1)/2. On entry, the triangular factor of a Hermitian
!>          Positive Definite 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 = 'T' then RFP is
!>          the 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 = 'T'. 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 Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last three columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 then consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last two columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 200 of file stftri.f.

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

◆ stfttp()

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

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

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

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

◆ stfttr()

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

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

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

Purpose:
!>
!> STFTTR 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;
!>          = 'T':  ARF is in 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 matrices ARF and A. N >= 0.
!>
[in]ARF
!>          ARF is REAL array, dimension (N*(N+1)/2).
!>          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
!>          matrix A in RFP format. See the  below for more
!>          details.
!>
[out]A
!>          A is REAL 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 Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last three columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 then consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last two columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 195 of file stfttr.f.

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

◆ stgsen()

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

STGSEN

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

Purpose:
!>
!> STGSEN reorders the generalized real Schur decomposition of a real
!> matrix pair (A, B) (in terms of an orthonormal equivalence trans-
!> formation Q**T * (A, B) * Z), so that a selected cluster of eigenvalues
!> appears in the leading diagonal blocks of the upper quasi-triangular
!> matrix A and the upper triangular B. The leading columns of Q and
!> Z form orthonormal bases of the corresponding left and right eigen-
!> spaces (deflating subspaces). (A, B) must be in generalized real
!> Schur canonical form (as returned by SGGES), i.e. A is block upper
!> triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
!> triangular.
!>
!> STGSEN also computes the generalized eigenvalues
!>
!>             w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
!>
!> of the reordered matrix pair (A, B).
!>
!> Optionally, STGSEN computes the 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 a real eigenvalue w(j), SELECT(j) must be set to
!>          .TRUE.. To select a complex conjugate pair of eigenvalues
!>          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
!>          either SELECT(j) or SELECT(j+1) or both must be set to
!>          .TRUE.; a complex conjugate pair of eigenvalues must be
!>          either both included in the cluster or both excluded.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A and B. N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension(LDA,N)
!>          On entry, the upper quasi-triangular matrix A, with (A, B) in
!>          generalized real 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 REAL array, dimension(LDB,N)
!>          On entry, the upper triangular matrix B, with (A, B) in
!>          generalized real 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]ALPHAR
!>          ALPHAR is REAL array, dimension (N)
!>
[out]ALPHAI
!>          ALPHAI is REAL array, dimension (N)
!>
[out]BETA
!>          BETA is REAL array, dimension (N)
!>
!>          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
!>          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i
!>          and BETA(j),j=1,...,N  are the diagonals of the complex Schur
!>          form (S,T) that would result if the 2-by-2 diagonal blocks of
!>          the real generalized Schur form of (A,B) were further reduced
!>          to triangular form using complex unitary transformations.
!>          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
!>          positive, then the j-th and (j+1)-st eigenvalues are a
!>          complex conjugate pair, with ALPHAI(j+1) negative.
!>
[in,out]Q
!>          Q is REAL 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 orthogonal
!>          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;
!>          and if WANTQ = .TRUE., LDQ >= N.
!>
[in,out]Z
!>          Z is REAL 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 orthogonal
!>          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 eigen-
!>          spaces (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
!>          eigenspaces 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 and 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.
!>          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 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. LWORK >=  4*N+16.
!>          If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
!>          If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 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+6.
!>          If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
!>
!>          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:
!>
!>  STGSEN first collects the selected eigenvalues by computing
!>  orthogonal 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**T*(A, B)*W = (A11 A12) (B11 B12) n1
!>                              ( 0  A22),( 0  B22) n2
!>                                n1  n2    n1  n2
!>
!>  where N = n1+n2 and U**T means the 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**T, then the
!>  reordered generalized real Schur form of (C, D) is given by
!>
!>           (C, D) = (Q*U)*(U**T*(A, B)*W)*(Z*W)**T,
!>
!>  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**T, In1) ]
!>            [ kron(In2, B11)  -kron(B22**T, In1) ].
!>
!>  Here, Inx is the identity matrix of size nx and A22**T is the
!>  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 SLATDF), then the parameter
!>  IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF
!>  (IJOB = 2 will be used)). See STGSYL 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 448 of file stgsen.f.

451*
452* -- LAPACK computational routine --
453* -- LAPACK is a software package provided by Univ. of Tennessee, --
454* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
455*
456* .. Scalar Arguments ..
457 LOGICAL WANTQ, WANTZ
458 INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
459 $ M, N
460 REAL PL, PR
461* ..
462* .. Array Arguments ..
463 LOGICAL SELECT( * )
464 INTEGER IWORK( * )
465 REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
466 $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ),
467 $ WORK( * ), Z( LDZ, * )
468* ..
469*
470* =====================================================================
471*
472* .. Parameters ..
473 INTEGER IDIFJB
474 parameter( idifjb = 3 )
475 REAL ZERO, ONE
476 parameter( zero = 0.0e+0, one = 1.0e+0 )
477* ..
478* .. Local Scalars ..
479 LOGICAL LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2,
480 $ WANTP
481 INTEGER I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN,
482 $ MN2, N1, N2
483 REAL DSCALE, DSUM, EPS, RDSCAL, SMLNUM
484* ..
485* .. Local Arrays ..
486 INTEGER ISAVE( 3 )
487* ..
488* .. External Subroutines ..
489 EXTERNAL slacn2, slacpy, slag2, slassq, stgexc, stgsyl,
490 $ xerbla
491* ..
492* .. External Functions ..
493 REAL SLAMCH
494 EXTERNAL slamch
495* ..
496* .. Intrinsic Functions ..
497 INTRINSIC max, sign, sqrt
498* ..
499* .. Executable Statements ..
500*
501* Decode and test the input parameters
502*
503 info = 0
504 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 )
505*
506 IF( ijob.LT.0 .OR. ijob.GT.5 ) THEN
507 info = -1
508 ELSE IF( n.LT.0 ) THEN
509 info = -5
510 ELSE IF( lda.LT.max( 1, n ) ) THEN
511 info = -7
512 ELSE IF( ldb.LT.max( 1, n ) ) THEN
513 info = -9
514 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) ) THEN
515 info = -14
516 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) ) THEN
517 info = -16
518 END IF
519*
520 IF( info.NE.0 ) THEN
521 CALL xerbla( 'STGSEN', -info )
522 RETURN
523 END IF
524*
525* Get machine constants
526*
527 eps = slamch( 'P' )
528 smlnum = slamch( 'S' ) / eps
529 ierr = 0
530*
531 wantp = ijob.EQ.1 .OR. ijob.GE.4
532 wantd1 = ijob.EQ.2 .OR. ijob.EQ.4
533 wantd2 = ijob.EQ.3 .OR. ijob.EQ.5
534 wantd = wantd1 .OR. wantd2
535*
536* Set M to the dimension of the specified pair of deflating
537* subspaces.
538*
539 m = 0
540 pair = .false.
541 IF( .NOT.lquery .OR. ijob.NE.0 ) THEN
542 DO 10 k = 1, n
543 IF( pair ) THEN
544 pair = .false.
545 ELSE
546 IF( k.LT.n ) THEN
547 IF( a( k+1, k ).EQ.zero ) THEN
548 IF( SELECT( k ) )
549 $ m = m + 1
550 ELSE
551 pair = .true.
552 IF( SELECT( k ) .OR. SELECT( k+1 ) )
553 $ m = m + 2
554 END IF
555 ELSE
556 IF( SELECT( n ) )
557 $ m = m + 1
558 END IF
559 END IF
560 10 CONTINUE
561 END IF
562*
563 IF( ijob.EQ.1 .OR. ijob.EQ.2 .OR. ijob.EQ.4 ) THEN
564 lwmin = max( 1, 4*n+16, 2*m*(n-m) )
565 liwmin = max( 1, n+6 )
566 ELSE IF( ijob.EQ.3 .OR. ijob.EQ.5 ) THEN
567 lwmin = max( 1, 4*n+16, 4*m*(n-m) )
568 liwmin = max( 1, 2*m*(n-m), n+6 )
569 ELSE
570 lwmin = max( 1, 4*n+16 )
571 liwmin = 1
572 END IF
573*
574 work( 1 ) = lwmin
575 iwork( 1 ) = liwmin
576*
577 IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
578 info = -22
579 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery ) THEN
580 info = -24
581 END IF
582*
583 IF( info.NE.0 ) THEN
584 CALL xerbla( 'STGSEN', -info )
585 RETURN
586 ELSE IF( lquery ) THEN
587 RETURN
588 END IF
589*
590* Quick return if possible.
591*
592 IF( m.EQ.n .OR. m.EQ.0 ) THEN
593 IF( wantp ) THEN
594 pl = one
595 pr = one
596 END IF
597 IF( wantd ) THEN
598 dscale = zero
599 dsum = one
600 DO 20 i = 1, n
601 CALL slassq( n, a( 1, i ), 1, dscale, dsum )
602 CALL slassq( n, b( 1, i ), 1, dscale, dsum )
603 20 CONTINUE
604 dif( 1 ) = dscale*sqrt( dsum )
605 dif( 2 ) = dif( 1 )
606 END IF
607 GO TO 60
608 END IF
609*
610* Collect the selected blocks at the top-left corner of (A, B).
611*
612 ks = 0
613 pair = .false.
614 DO 30 k = 1, n
615 IF( pair ) THEN
616 pair = .false.
617 ELSE
618*
619 swap = SELECT( k )
620 IF( k.LT.n ) THEN
621 IF( a( k+1, k ).NE.zero ) THEN
622 pair = .true.
623 swap = swap .OR. SELECT( k+1 )
624 END IF
625 END IF
626*
627 IF( swap ) THEN
628 ks = ks + 1
629*
630* Swap the K-th block to position KS.
631* Perform the reordering of diagonal blocks in (A, B)
632* by orthogonal transformation matrices and update
633* Q and Z accordingly (if requested):
634*
635 kk = k
636 IF( k.NE.ks )
637 $ CALL stgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq,
638 $ z, ldz, kk, ks, work, lwork, ierr )
639*
640 IF( ierr.GT.0 ) THEN
641*
642* Swap is rejected: exit.
643*
644 info = 1
645 IF( wantp ) THEN
646 pl = zero
647 pr = zero
648 END IF
649 IF( wantd ) THEN
650 dif( 1 ) = zero
651 dif( 2 ) = zero
652 END IF
653 GO TO 60
654 END IF
655*
656 IF( pair )
657 $ ks = ks + 1
658 END IF
659 END IF
660 30 CONTINUE
661 IF( wantp ) THEN
662*
663* Solve generalized Sylvester equation for R and L
664* and compute PL and PR.
665*
666 n1 = m
667 n2 = n - m
668 i = n1 + 1
669 ijb = 0
670 CALL slacpy( 'Full', n1, n2, a( 1, i ), lda, work, n1 )
671 CALL slacpy( 'Full', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),
672 $ n1 )
673 CALL stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,
674 $ n1, b, ldb, b( i, i ), ldb, work( n1*n2+1 ), n1,
675 $ dscale, dif( 1 ), work( n1*n2*2+1 ),
676 $ lwork-2*n1*n2, iwork, ierr )
677*
678* Estimate the reciprocal of norms of "projections" onto left
679* and right eigenspaces.
680*
681 rdscal = zero
682 dsum = one
683 CALL slassq( n1*n2, work, 1, rdscal, dsum )
684 pl = rdscal*sqrt( dsum )
685 IF( pl.EQ.zero ) THEN
686 pl = one
687 ELSE
688 pl = dscale / ( sqrt( dscale*dscale / pl+pl )*sqrt( pl ) )
689 END IF
690 rdscal = zero
691 dsum = one
692 CALL slassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum )
693 pr = rdscal*sqrt( dsum )
694 IF( pr.EQ.zero ) THEN
695 pr = one
696 ELSE
697 pr = dscale / ( sqrt( dscale*dscale / pr+pr )*sqrt( pr ) )
698 END IF
699 END IF
700*
701 IF( wantd ) THEN
702*
703* Compute estimates of Difu and Difl.
704*
705 IF( wantd1 ) THEN
706 n1 = m
707 n2 = n - m
708 i = n1 + 1
709 ijb = idifjb
710*
711* Frobenius norm-based Difu-estimate.
712*
713 CALL stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,
714 $ n1, b, ldb, b( i, i ), ldb, work( n1*n2+1 ),
715 $ n1, dscale, dif( 1 ), work( 2*n1*n2+1 ),
716 $ lwork-2*n1*n2, iwork, ierr )
717*
718* Frobenius norm-based Difl-estimate.
719*
720 CALL stgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,
721 $ n2, b( i, i ), ldb, b, ldb, work( n1*n2+1 ),
722 $ n2, dscale, dif( 2 ), work( 2*n1*n2+1 ),
723 $ lwork-2*n1*n2, iwork, ierr )
724 ELSE
725*
726*
727* Compute 1-norm-based estimates of Difu and Difl using
728* reversed communication with SLACN2. In each step a
729* generalized Sylvester equation or a transposed variant
730* is solved.
731*
732 kase = 0
733 n1 = m
734 n2 = n - m
735 i = n1 + 1
736 ijb = 0
737 mn2 = 2*n1*n2
738*
739* 1-norm-based estimate of Difu.
740*
741 40 CONTINUE
742 CALL slacn2( mn2, work( mn2+1 ), work, iwork, dif( 1 ),
743 $ kase, isave )
744 IF( kase.NE.0 ) THEN
745 IF( kase.EQ.1 ) THEN
746*
747* Solve generalized Sylvester equation.
748*
749 CALL stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,
750 $ work, n1, b, ldb, b( i, i ), ldb,
751 $ work( n1*n2+1 ), n1, dscale, dif( 1 ),
752 $ work( 2*n1*n2+1 ), lwork-2*n1*n2, iwork,
753 $ ierr )
754 ELSE
755*
756* Solve the transposed variant.
757*
758 CALL stgsyl( 'T', ijb, n1, n2, a, lda, a( i, i ), lda,
759 $ work, n1, b, ldb, b( i, i ), ldb,
760 $ work( n1*n2+1 ), n1, dscale, dif( 1 ),
761 $ work( 2*n1*n2+1 ), lwork-2*n1*n2, iwork,
762 $ ierr )
763 END IF
764 GO TO 40
765 END IF
766 dif( 1 ) = dscale / dif( 1 )
767*
768* 1-norm-based estimate of Difl.
769*
770 50 CONTINUE
771 CALL slacn2( mn2, work( mn2+1 ), work, iwork, dif( 2 ),
772 $ kase, isave )
773 IF( kase.NE.0 ) THEN
774 IF( kase.EQ.1 ) THEN
775*
776* Solve generalized Sylvester equation.
777*
778 CALL stgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,
779 $ work, n2, b( i, i ), ldb, b, ldb,
780 $ work( n1*n2+1 ), n2, dscale, dif( 2 ),
781 $ work( 2*n1*n2+1 ), lwork-2*n1*n2, iwork,
782 $ ierr )
783 ELSE
784*
785* Solve the transposed variant.
786*
787 CALL stgsyl( 'T', ijb, n2, n1, a( i, i ), lda, a, lda,
788 $ work, n2, b( i, i ), ldb, b, ldb,
789 $ work( n1*n2+1 ), n2, dscale, dif( 2 ),
790 $ work( 2*n1*n2+1 ), lwork-2*n1*n2, iwork,
791 $ ierr )
792 END IF
793 GO TO 50
794 END IF
795 dif( 2 ) = dscale / dif( 2 )
796*
797 END IF
798 END IF
799*
800 60 CONTINUE
801*
802* Compute generalized eigenvalues of reordered pair (A, B) and
803* normalize the generalized Schur form.
804*
805 pair = .false.
806 DO 70 k = 1, n
807 IF( pair ) THEN
808 pair = .false.
809 ELSE
810*
811 IF( k.LT.n ) THEN
812 IF( a( k+1, k ).NE.zero ) THEN
813 pair = .true.
814 END IF
815 END IF
816*
817 IF( pair ) THEN
818*
819* Compute the eigenvalue(s) at position K.
820*
821 work( 1 ) = a( k, k )
822 work( 2 ) = a( k+1, k )
823 work( 3 ) = a( k, k+1 )
824 work( 4 ) = a( k+1, k+1 )
825 work( 5 ) = b( k, k )
826 work( 6 ) = b( k+1, k )
827 work( 7 ) = b( k, k+1 )
828 work( 8 ) = b( k+1, k+1 )
829 CALL slag2( work, 2, work( 5 ), 2, smlnum*eps, beta( k ),
830 $ beta( k+1 ), alphar( k ), alphar( k+1 ),
831 $ alphai( k ) )
832 alphai( k+1 ) = -alphai( k )
833*
834 ELSE
835*
836 IF( sign( one, b( k, k ) ).LT.zero ) THEN
837*
838* If B(K,K) is negative, make it positive
839*
840 DO 80 i = 1, n
841 a( k, i ) = -a( k, i )
842 b( k, i ) = -b( k, i )
843 IF( wantq ) q( i, k ) = -q( i, k )
844 80 CONTINUE
845 END IF
846*
847 alphar( k ) = a( k, k )
848 alphai( k ) = zero
849 beta( k ) = b( k, k )
850*
851 END IF
852 END IF
853 70 CONTINUE
854*
855 work( 1 ) = lwmin
856 iwork( 1 ) = liwmin
857*
858 RETURN
859*
860* End of STGSEN
861*
stgexc
subroutine stgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, work, lwork, info)
STGEXC
Definition stgexc.f:220
slag2
subroutine slag2(a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2, wi)
SLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary ...
Definition slag2.f:156
stgsyl
subroutine stgsyl(trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, dif, work, lwork, iwork, info)
STGSYL
Definition stgsyl.f:299
swap
#define swap(a, b, tmp)
Definition macros.h:40

◆ stgsja()

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

STGSJA

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

Purpose:
!>
!> STGSJA computes the generalized singular value decomposition (GSVD)
!> of two real 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 SGGSVP
!> 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**T *A*Q = D1*( 0 R ),    V**T *B*Q = D2*( 0 R ),
!>
!> where U, V and Q are orthogonal 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 orthogonal 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 an orthogonal matrix U1 on entry, and
!>                  the product U1*U is returned;
!>          = 'I':  U is initialized to the unit matrix, and the
!>                  orthogonal matrix U is returned;
!>          = 'N':  U is not computed.
!>
[in]JOBV
!>          JOBV is CHARACTER*1
!>          = 'V':  V must contain an orthogonal matrix V1 on entry, and
!>                  the product V1*V is returned;
!>          = 'I':  V is initialized to the unit matrix, and the
!>                  orthogonal matrix V is returned;
!>          = 'N':  V is not computed.
!>
[in]JOBQ
!>          JOBQ is CHARACTER*1
!>          = 'Q':  Q must contain an orthogonal matrix Q1 on entry, and
!>                  the product Q1*Q is returned;
!>          = 'I':  Q is initialized to the unit matrix, and the
!>                  orthogonal 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 STGSJA.
!>          See Further Details.
!>
[in,out]A
!>          A is REAL 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 REAL 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 and
!>            BETA(K+L+1:N)  = 0.
!>
[in,out]U
!>          U is REAL array, dimension (LDU,M)
!>          On entry, if JOBU = 'U', U must contain a matrix U1 (usually
!>          the orthogonal matrix returned by SGGSVP).
!>          On exit,
!>          if JOBU = 'I', U contains the orthogonal 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 REAL array, dimension (LDV,P)
!>          On entry, if JOBV = 'V', V must contain a matrix V1 (usually
!>          the orthogonal matrix returned by SGGSVP).
!>          On exit,
!>          if JOBV = 'I', V contains the orthogonal 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 REAL array, dimension (LDQ,N)
!>          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
!>          the orthogonal matrix returned by SGGSVP).
!>          On exit,
!>          if JOBQ = 'I', Q contains the orthogonal 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 REAL 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:
!>
!>  STGSJA 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**T *A13*Q1 = C1*R1; V1**T *B13*Q1 = S1*R1,
!>
!>  where U1, V1 and Q1 are orthogonal matrix, and Z**T is the transpose
!>  of Z.  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 375 of file stgsja.f.

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

◆ stgsna()

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

STGSNA

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

Purpose:
!>
!> STGSNA estimates reciprocal condition numbers for specified
!> eigenvalues and/or eigenvectors of a matrix pair (A, B) in
!> generalized real Schur canonical form (or of any matrix pair
!> (Q*A*Z**T, Q*B*Z**T) with orthogonal matrices Q and Z, where
!> Z**T denotes the transpose of Z.
!>
!> (A, B) must be in generalized real Schur form (as returned by SGGES),
!> i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
!> blocks. B is 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 eigenpair corresponding to a real eigenvalue w(j),
!>          SELECT(j) must be set to .TRUE.. To select condition numbers
!>          corresponding to a complex conjugate pair of eigenvalues w(j)
!>          and w(j+1), either SELECT(j) or SELECT(j+1) or both, 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 REAL array, dimension (LDA,N)
!>          The upper quasi-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 REAL 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 REAL 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 STGEVC.
!>          If JOB = 'V', VL is not referenced.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          The leading dimension of the array VL. LDVL >= 1.
!>          If JOB = 'E' or 'B', LDVL >= N.
!>
[in]VR
!>          VR is REAL 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 ov VR, as returned by STGEVC.
!>          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. For a complex conjugate pair of eigenvalues two
!>          consecutive elements of S are set to the same value. Thus
!>          S(j), DIF(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]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. For a complex eigenvector two
!>          consecutive elements of DIF are set to the same value. 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.
!>          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 real
!>          eigenvalue one element is used, and for each selected complex
!>          conjugate pair of eigenvalues, two elements are used.
!>          If HOWMNY = 'A', M is set to N.
!>
[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. LWORK >= max(1,N).
!>          If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
!>
!>          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 (N + 6)
!>          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 a generalized eigenvalue
!>  w = (a, b) is defined as
!>
!>       S(w) = (|u**TAv|**2 + |u**TBv|**2)**(1/2) / (norm(u)*norm(v))
!>
!>  where u and v are the left and right 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 (= u**TAv/u**TBv)
!>  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 DIF(i) of right eigenvector u
!>  and left eigenvector v corresponding to the generalized eigenvalue w
!>  is defined as follows:
!>
!>  a) If the i-th eigenvalue w = (a,b) is real
!>
!>     Suppose U and V are orthogonal transformations such that
!>
!>              U**T*(A, B)*V  = (S, T) = ( a   *  ) ( b  *  )  1
!>                                        ( 0  S22 ),( 0 T22 )  n-1
!>                                          1  n-1     1 n-1
!>
!>     Then the reciprocal condition number DIF(i) is
!>
!>                Difl((a, b), (S22, T22)) = sigma-min( Zl ),
!>
!>     where sigma-min(Zl) denotes the smallest singular value of the
!>     2(n-1)-by-2(n-1) matrix
!>
!>         Zl = [ kron(a, In-1)  -kron(1, S22) ]
!>              [ kron(b, In-1)  -kron(1, T22) ] .
!>
!>     Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
!>     Kronecker product between the matrices X and Y.
!>
!>     Note that if the default method for computing DIF(i) is wanted
!>     (see SLATDF), then the parameter DIFDRI (see below) should be
!>     changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)).
!>     See STGSYL for more details.
!>
!>  b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
!>
!>     Suppose U and V are orthogonal transformations such that
!>
!>              U**T*(A, B)*V = (S, T) = ( S11  *   ) ( T11  *  )  2
!>                                       ( 0    S22 ),( 0    T22) n-2
!>                                         2    n-2     2    n-2
!>
!>     and (S11, T11) corresponds to the complex conjugate eigenvalue
!>     pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
!>     that
!>
!>       U1**T*S11*V1 = ( s11 s12 ) and U1**T*T11*V1 = ( t11 t12 )
!>                      (  0  s22 )                    (  0  t22 )
!>
!>     where the generalized eigenvalues w = s11/t11 and
!>     conjg(w) = s22/t22.
!>
!>     Then the reciprocal condition number DIF(i) is bounded by
!>
!>         min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
!>
!>     where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
!>     Z1 is the complex 2-by-2 matrix
!>
!>              Z1 =  [ s11  -s22 ]
!>                    [ t11  -t22 ],
!>
!>     This is done by computing (using real arithmetic) the
!>     roots of the characteristical polynomial det(Z1**T * Z1 - lambda I),
!>     where Z1**T denotes the transpose of Z1 and det(X) denotes
!>     the determinant of X.
!>
!>     and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
!>     upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
!>
!>              Z2 = [ kron(S11**T, In-2)  -kron(I2, S22) ]
!>                   [ kron(T11**T, In-2)  -kron(I2, T22) ]
!>
!>     Note that if the default method for computing DIF is wanted (see
!>     SLATDF), then the parameter DIFDRI (see below) should be changed
!>     from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL
!>     for more details.
!>
!>  For each eigenvalue/vector specified by SELECT, DIF stores a
!>  Frobenius norm-based estimate of Difl.
!>
!>  An approximate error bound for the i-th 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 378 of file stgsna.f.

381*
382* -- LAPACK computational routine --
383* -- LAPACK is a software package provided by Univ. of Tennessee, --
384* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
385*
386* .. Scalar Arguments ..
387 CHARACTER HOWMNY, JOB
388 INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
389* ..
390* .. Array Arguments ..
391 LOGICAL SELECT( * )
392 INTEGER IWORK( * )
393 REAL A( LDA, * ), B( LDB, * ), DIF( * ), S( * ),
394 $ VL( LDVL, * ), VR( LDVR, * ), WORK( * )
395* ..
396*
397* =====================================================================
398*
399* .. Parameters ..
400 INTEGER DIFDRI
401 parameter( difdri = 3 )
402 REAL ZERO, ONE, TWO, FOUR
403 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
404 $ four = 4.0e+0 )
405* ..
406* .. Local Scalars ..
407 LOGICAL LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS
408 INTEGER I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2
409 REAL ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND,
410 $ EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM,
411 $ TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV,
412 $ UHBVI
413* ..
414* .. Local Arrays ..
415 REAL DUMMY( 1 ), DUMMY1( 1 )
416* ..
417* .. External Functions ..
418 LOGICAL LSAME
419 REAL SDOT, SLAMCH, SLAPY2, SNRM2
420 EXTERNAL lsame, sdot, slamch, slapy2, snrm2
421* ..
422* .. External Subroutines ..
423 EXTERNAL sgemv, slacpy, slag2, stgexc, stgsyl, xerbla
424* ..
425* .. Intrinsic Functions ..
426 INTRINSIC max, min, sqrt
427* ..
428* .. Executable Statements ..
429*
430* Decode and test the input parameters
431*
432 wantbh = lsame( job, 'B' )
433 wants = lsame( job, 'E' ) .OR. wantbh
434 wantdf = lsame( job, 'V' ) .OR. wantbh
435*
436 somcon = lsame( howmny, 'S' )
437*
438 info = 0
439 lquery = ( lwork.EQ.-1 )
440*
441 IF( .NOT.wants .AND. .NOT.wantdf ) THEN
442 info = -1
443 ELSE IF( .NOT.lsame( howmny, 'A' ) .AND. .NOT.somcon ) THEN
444 info = -2
445 ELSE IF( n.LT.0 ) THEN
446 info = -4
447 ELSE IF( lda.LT.max( 1, n ) ) THEN
448 info = -6
449 ELSE IF( ldb.LT.max( 1, n ) ) THEN
450 info = -8
451 ELSE IF( wants .AND. ldvl.LT.n ) THEN
452 info = -10
453 ELSE IF( wants .AND. ldvr.LT.n ) THEN
454 info = -12
455 ELSE
456*
457* Set M to the number of eigenpairs for which condition numbers
458* are required, and test MM.
459*
460 IF( somcon ) THEN
461 m = 0
462 pair = .false.
463 DO 10 k = 1, n
464 IF( pair ) THEN
465 pair = .false.
466 ELSE
467 IF( k.LT.n ) THEN
468 IF( a( k+1, k ).EQ.zero ) THEN
469 IF( SELECT( k ) )
470 $ m = m + 1
471 ELSE
472 pair = .true.
473 IF( SELECT( k ) .OR. SELECT( k+1 ) )
474 $ m = m + 2
475 END IF
476 ELSE
477 IF( SELECT( n ) )
478 $ m = m + 1
479 END IF
480 END IF
481 10 CONTINUE
482 ELSE
483 m = n
484 END IF
485*
486 IF( n.EQ.0 ) THEN
487 lwmin = 1
488 ELSE IF( lsame( job, 'V' ) .OR. lsame( job, 'B' ) ) THEN
489 lwmin = 2*n*( n + 2 ) + 16
490 ELSE
491 lwmin = n
492 END IF
493 work( 1 ) = lwmin
494*
495 IF( mm.LT.m ) THEN
496 info = -15
497 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
498 info = -18
499 END IF
500 END IF
501*
502 IF( info.NE.0 ) THEN
503 CALL xerbla( 'STGSNA', -info )
504 RETURN
505 ELSE IF( lquery ) THEN
506 RETURN
507 END IF
508*
509* Quick return if possible
510*
511 IF( n.EQ.0 )
512 $ RETURN
513*
514* Get machine constants
515*
516 eps = slamch( 'P' )
517 smlnum = slamch( 'S' ) / eps
518 ks = 0
519 pair = .false.
520*
521 DO 20 k = 1, n
522*
523* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block.
524*
525 IF( pair ) THEN
526 pair = .false.
527 GO TO 20
528 ELSE
529 IF( k.LT.n )
530 $ pair = a( k+1, k ).NE.zero
531 END IF
532*
533* Determine whether condition numbers are required for the k-th
534* eigenpair.
535*
536 IF( somcon ) THEN
537 IF( pair ) THEN
538 IF( .NOT.SELECT( k ) .AND. .NOT.SELECT( k+1 ) )
539 $ GO TO 20
540 ELSE
541 IF( .NOT.SELECT( k ) )
542 $ GO TO 20
543 END IF
544 END IF
545*
546 ks = ks + 1
547*
548 IF( wants ) THEN
549*
550* Compute the reciprocal condition number of the k-th
551* eigenvalue.
552*
553 IF( pair ) THEN
554*
555* Complex eigenvalue pair.
556*
557 rnrm = slapy2( snrm2( n, vr( 1, ks ), 1 ),
558 $ snrm2( n, vr( 1, ks+1 ), 1 ) )
559 lnrm = slapy2( snrm2( n, vl( 1, ks ), 1 ),
560 $ snrm2( n, vl( 1, ks+1 ), 1 ) )
561 CALL sgemv( 'N', n, n, one, a, lda, vr( 1, ks ), 1, zero,
562 $ work, 1 )
563 tmprr = sdot( n, work, 1, vl( 1, ks ), 1 )
564 tmpri = sdot( n, work, 1, vl( 1, ks+1 ), 1 )
565 CALL sgemv( 'N', n, n, one, a, lda, vr( 1, ks+1 ), 1,
566 $ zero, work, 1 )
567 tmpii = sdot( n, work, 1, vl( 1, ks+1 ), 1 )
568 tmpir = sdot( n, work, 1, vl( 1, ks ), 1 )
569 uhav = tmprr + tmpii
570 uhavi = tmpir - tmpri
571 CALL sgemv( 'N', n, n, one, b, ldb, vr( 1, ks ), 1, zero,
572 $ work, 1 )
573 tmprr = sdot( n, work, 1, vl( 1, ks ), 1 )
574 tmpri = sdot( n, work, 1, vl( 1, ks+1 ), 1 )
575 CALL sgemv( 'N', n, n, one, b, ldb, vr( 1, ks+1 ), 1,
576 $ zero, work, 1 )
577 tmpii = sdot( n, work, 1, vl( 1, ks+1 ), 1 )
578 tmpir = sdot( n, work, 1, vl( 1, ks ), 1 )
579 uhbv = tmprr + tmpii
580 uhbvi = tmpir - tmpri
581 uhav = slapy2( uhav, uhavi )
582 uhbv = slapy2( uhbv, uhbvi )
583 cond = slapy2( uhav, uhbv )
584 s( ks ) = cond / ( rnrm*lnrm )
585 s( ks+1 ) = s( ks )
586*
587 ELSE
588*
589* Real eigenvalue.
590*
591 rnrm = snrm2( n, vr( 1, ks ), 1 )
592 lnrm = snrm2( n, vl( 1, ks ), 1 )
593 CALL sgemv( 'N', n, n, one, a, lda, vr( 1, ks ), 1, zero,
594 $ work, 1 )
595 uhav = sdot( n, work, 1, vl( 1, ks ), 1 )
596 CALL sgemv( 'N', n, n, one, b, ldb, vr( 1, ks ), 1, zero,
597 $ work, 1 )
598 uhbv = sdot( n, work, 1, vl( 1, ks ), 1 )
599 cond = slapy2( uhav, uhbv )
600 IF( cond.EQ.zero ) THEN
601 s( ks ) = -one
602 ELSE
603 s( ks ) = cond / ( rnrm*lnrm )
604 END IF
605 END IF
606 END IF
607*
608 IF( wantdf ) THEN
609 IF( n.EQ.1 ) THEN
610 dif( ks ) = slapy2( a( 1, 1 ), b( 1, 1 ) )
611 GO TO 20
612 END IF
613*
614* Estimate the reciprocal condition number of the k-th
615* eigenvectors.
616 IF( pair ) THEN
617*
618* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)).
619* Compute the eigenvalue(s) at position K.
620*
621 work( 1 ) = a( k, k )
622 work( 2 ) = a( k+1, k )
623 work( 3 ) = a( k, k+1 )
624 work( 4 ) = a( k+1, k+1 )
625 work( 5 ) = b( k, k )
626 work( 6 ) = b( k+1, k )
627 work( 7 ) = b( k, k+1 )
628 work( 8 ) = b( k+1, k+1 )
629 CALL slag2( work, 2, work( 5 ), 2, smlnum*eps, beta,
630 $ dummy1( 1 ), alphar, dummy( 1 ), alphai )
631 alprqt = one
632 c1 = two*( alphar*alphar+alphai*alphai+beta*beta )
633 c2 = four*beta*beta*alphai*alphai
634 root1 = c1 + sqrt( c1*c1-4.0*c2 )
635 root2 = c2 / root1
636 root1 = root1 / two
637 cond = min( sqrt( root1 ), sqrt( root2 ) )
638 END IF
639*
640* Copy the matrix (A, B) to the array WORK and swap the
641* diagonal block beginning at A(k,k) to the (1,1) position.
642*
643 CALL slacpy( 'Full', n, n, a, lda, work, n )
644 CALL slacpy( 'Full', n, n, b, ldb, work( n*n+1 ), n )
645 ifst = k
646 ilst = 1
647*
648 CALL stgexc( .false., .false., n, work, n, work( n*n+1 ), n,
649 $ dummy, 1, dummy1, 1, ifst, ilst,
650 $ work( n*n*2+1 ), lwork-2*n*n, ierr )
651*
652 IF( ierr.GT.0 ) THEN
653*
654* Ill-conditioned problem - swap rejected.
655*
656 dif( ks ) = zero
657 ELSE
658*
659* Reordering successful, solve generalized Sylvester
660* equation for R and L,
661* A22 * R - L * A11 = A12
662* B22 * R - L * B11 = B12,
663* and compute estimate of Difl((A11,B11), (A22, B22)).
664*
665 n1 = 1
666 IF( work( 2 ).NE.zero )
667 $ n1 = 2
668 n2 = n - n1
669 IF( n2.EQ.0 ) THEN
670 dif( ks ) = cond
671 ELSE
672 i = n*n + 1
673 iz = 2*n*n + 1
674 CALL stgsyl( 'N', difdri, n2, n1, work( n*n1+n1+1 ),
675 $ n, work, n, work( n1+1 ), n,
676 $ work( n*n1+n1+i ), n, work( i ), n,
677 $ work( n1+i ), n, scale, dif( ks ),
678 $ work( iz+1 ), lwork-2*n*n, iwork, ierr )
679*
680 IF( pair )
681 $ dif( ks ) = min( max( one, alprqt )*dif( ks ),
682 $ cond )
683 END IF
684 END IF
685 IF( pair )
686 $ dif( ks+1 ) = dif( ks )
687 END IF
688 IF( pair )
689 $ ks = ks + 1
690*
691 20 CONTINUE
692 work( 1 ) = lwmin
693 RETURN
694*
695* End of STGSNA
696*
slapy2
real function slapy2(x, y)
SLAPY2 returns sqrt(x2+y2).
Definition slapy2.f:63

◆ stpcon()

subroutine stpcon ( character norm,
character uplo,
character diag,
integer n,
real, dimension( * ) ap,
real rcond,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

STPCON

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

Purpose:
!>
!> STPCON 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 REAL 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 REAL array, dimension (3*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 stpcon.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 INTEGER IWORK( * )
142 REAL 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* ..
157* .. Local Arrays ..
158 INTEGER ISAVE( 3 )
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 INTEGER ISAMAX
163 REAL SLAMCH, SLANTP
164 EXTERNAL lsame, isamax, slamch, slantp
165* ..
166* .. External Subroutines ..
167 EXTERNAL slacn2, slatps, srscl, xerbla
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, max, real
171* ..
172* .. Executable Statements ..
173*
174* Test the input parameters.
175*
176 info = 0
177 upper = lsame( uplo, 'U' )
178 onenrm = norm.EQ.'1' .OR. lsame( norm, 'O' )
179 nounit = lsame( diag, 'N' )
180*
181 IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN
182 info = -1
183 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
184 info = -2
185 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
186 info = -3
187 ELSE IF( n.LT.0 ) THEN
188 info = -4
189 END IF
190 IF( info.NE.0 ) THEN
191 CALL xerbla( 'STPCON', -info )
192 RETURN
193 END IF
194*
195* Quick return if possible
196*
197 IF( n.EQ.0 ) THEN
198 rcond = one
199 RETURN
200 END IF
201*
202 rcond = zero
203 smlnum = slamch( 'Safe minimum' )*real( max( 1, n ) )
204*
205* Compute the norm of the triangular matrix A.
206*
207 anorm = slantp( norm, uplo, diag, n, ap, work )
208*
209* Continue only if ANORM > 0.
210*
211 IF( anorm.GT.zero ) THEN
212*
213* Estimate the norm of the inverse of A.
214*
215 ainvnm = zero
216 normin = 'N'
217 IF( onenrm ) THEN
218 kase1 = 1
219 ELSE
220 kase1 = 2
221 END IF
222 kase = 0
223 10 CONTINUE
224 CALL slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
225 IF( kase.NE.0 ) THEN
226 IF( kase.EQ.kase1 ) THEN
227*
228* Multiply by inv(A).
229*
230 CALL slatps( uplo, 'No transpose', diag, normin, n, ap,
231 $ work, scale, work( 2*n+1 ), info )
232 ELSE
233*
234* Multiply by inv(A**T).
235*
236 CALL slatps( uplo, 'Transpose', diag, normin, n, ap,
237 $ work, scale, work( 2*n+1 ), info )
238 END IF
239 normin = 'Y'
240*
241* Multiply by 1/SCALE if doing so will not cause overflow.
242*
243 IF( scale.NE.one ) THEN
244 ix = isamax( n, work, 1 )
245 xnorm = abs( work( ix ) )
246 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
247 $ GO TO 20
248 CALL srscl( n, scale, work, 1 )
249 END IF
250 GO TO 10
251 END IF
252*
253* Compute the estimate of the reciprocal condition number.
254*
255 IF( ainvnm.NE.zero )
256 $ rcond = ( one / anorm ) / ainvnm
257 END IF
258*
259 20 CONTINUE
260 RETURN
261*
262* End of STPCON
263*
slantp
real function slantp(norm, uplo, diag, n, ap, work)
SLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slantp.f:124

◆ stpmqrt()

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

STPMQRT

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

Purpose:
!>
!> STPMQRT applies a real orthogonal matrix Q obtained from a
!>  real block reflector H to a general
!> real matrix C, which consists of two blocks A and B.
!>
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':  No transpose, apply Q;
!>          = 'T':  Transpose, apply Q^T.
!>
[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 REAL 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 REAL 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 REAL 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^T*C or C*Q or C*Q^T.  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 REAL 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^T*C or C*Q or C*Q^T.  See Further Details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.
!>          LDB >= max(1,M).
!>
[out]WORK
!>          WORK is REAL 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 real 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='T' and SIDE='L', C is on exit replaced with Q^T * C.
!>
!>  If TRANS='N' and SIDE='R', C is on exit replaced with C * Q.
!>
!>  If TRANS='T' and SIDE='R', C is on exit replaced with C * Q^T.
!>

Definition at line 214 of file stpmqrt.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 REAL 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 stprfb, 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, 'T' )
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( 'STPMQRT', -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 stprfb( 'L', 'T', '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 stprfb( '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 stprfb( '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 stprfb( 'R', 'T', '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 STPMQRT
364*
stprfb
subroutine stprfb(side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, a, lda, b, ldb, work, ldwork)
STPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matri...
Definition stprfb.f:251

◆ stpqrt()

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

STPQRT

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

Purpose:
!>
!> STPQRT computes a blocked QR factorization of a real
!>  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 REAL 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 REAL 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 REAL 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 REAL 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 stpqrt.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 REAL 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 stpqrt2, stprfb, 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( 'STPQRT', -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 stpqrt2( 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 stprfb( 'L', 'T', '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 STPQRT
266*
stpqrt2
subroutine stpqrt2(m, n, l, a, lda, b, ldb, t, ldt, info)
STPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix,...
Definition stpqrt2.f:173

◆ stpqrt2()

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

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

Purpose:
!>
!> STPQRT2 computes a QR factorization of a real 
!> 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 REAL 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 REAL 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 REAL 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 stpqrt2.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 REAL A( LDA, * ), B( LDB, * ), T( LDT, * )
183* ..
184*
185* =====================================================================
186*
187* .. Parameters ..
188 REAL ONE, ZERO
189 parameter( one = 1.0, zero = 0.0 )
190* ..
191* .. Local Scalars ..
192 INTEGER I, J, P, MP, NP
193 REAL ALPHA
194* ..
195* .. External Subroutines ..
196 EXTERNAL slarfg, sgemv, sger, strmv, 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( 'STPQRT2', -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 slarfg( 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 ) = (a( i, i+j ))
240 END DO
241 CALL sgemv( 'T', 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 = -(t( i, 1 ))
247 DO j = 1, n-i
248 a( i, i+j ) = a( i, i+j ) + alpha*(t( j, n ))
249 END DO
250 CALL sger( 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 strmv( 'U', 'T', 'N', p, b( mp, 1 ), ldb,
274 $ t( 1, i ), 1 )
275*
276* Rectangular part of B2
277*
278 CALL sgemv( 'T', 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 sgemv( 'T', 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 strmv( '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 STPQRT2
298*

◆ stprfs()

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

STPRFS

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

Purpose:
!>
!> STPRFS 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 STPTRS or some other
!> means before entering this routine.  STPRFS 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 = 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 REAL 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.
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!>
[in]B
!>          B is REAL 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 REAL 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 REAL array, dimension (3*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 173 of file stprfs.f.

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

◆ stptri()

subroutine stptri ( character uplo,
character diag,
integer n,
real, dimension( * ) ap,
integer info )

STPTRI

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

Purpose:
!>
!> STPTRI computes the inverse of a real 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 REAL 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 stptri.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 REAL AP( * )
128* ..
129*
130* =====================================================================
131*
132* .. Parameters ..
133 REAL ONE, ZERO
134 parameter( one = 1.0e+0, zero = 0.0e+0 )
135* ..
136* .. Local Scalars ..
137 LOGICAL NOUNIT, UPPER
138 INTEGER J, JC, JCLAST, JJ
139 REAL AJJ
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 EXTERNAL lsame
144* ..
145* .. External Subroutines ..
146 EXTERNAL sscal, stpmv, xerbla
147* ..
148* .. Executable Statements ..
149*
150* Test the input parameters.
151*
152 info = 0
153 upper = lsame( uplo, 'U' )
154 nounit = lsame( diag, 'N' )
155 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
156 info = -1
157 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
158 info = -2
159 ELSE IF( n.LT.0 ) THEN
160 info = -3
161 END IF
162 IF( info.NE.0 ) THEN
163 CALL xerbla( 'STPTRI', -info )
164 RETURN
165 END IF
166*
167* Check for singularity if non-unit.
168*
169 IF( nounit ) THEN
170 IF( upper ) THEN
171 jj = 0
172 DO 10 info = 1, n
173 jj = jj + info
174 IF( ap( jj ).EQ.zero )
175 $ RETURN
176 10 CONTINUE
177 ELSE
178 jj = 1
179 DO 20 info = 1, n
180 IF( ap( jj ).EQ.zero )
181 $ RETURN
182 jj = jj + n - info + 1
183 20 CONTINUE
184 END IF
185 info = 0
186 END IF
187*
188 IF( upper ) THEN
189*
190* Compute inverse of upper triangular matrix.
191*
192 jc = 1
193 DO 30 j = 1, n
194 IF( nounit ) THEN
195 ap( jc+j-1 ) = one / ap( jc+j-1 )
196 ajj = -ap( jc+j-1 )
197 ELSE
198 ajj = -one
199 END IF
200*
201* Compute elements 1:j-1 of j-th column.
202*
203 CALL stpmv( 'Upper', 'No transpose', diag, j-1, ap,
204 $ ap( jc ), 1 )
205 CALL sscal( j-1, ajj, ap( jc ), 1 )
206 jc = jc + j
207 30 CONTINUE
208*
209 ELSE
210*
211* Compute inverse of lower triangular matrix.
212*
213 jc = n*( n+1 ) / 2
214 DO 40 j = n, 1, -1
215 IF( nounit ) THEN
216 ap( jc ) = one / ap( jc )
217 ajj = -ap( jc )
218 ELSE
219 ajj = -one
220 END IF
221 IF( j.LT.n ) THEN
222*
223* Compute elements j+1:n of j-th column.
224*
225 CALL stpmv( 'Lower', 'No transpose', diag, n-j,
226 $ ap( jclast ), ap( jc+1 ), 1 )
227 CALL sscal( n-j, ajj, ap( jc+1 ), 1 )
228 END IF
229 jclast = jc
230 jc = jc - n + j - 2
231 40 CONTINUE
232 END IF
233*
234 RETURN
235*
236* End of STPTRI
237*

◆ stptrs()

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

STPTRS

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

Purpose:
!>
!> STPTRS solves a triangular system of the form
!>
!>    A * X = B  or  A**T * 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 = 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 REAL 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 REAL 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 stptrs.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 REAL AP( * ), B( LDB, * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 REAL ZERO
147 parameter( zero = 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 stpsv, 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( 'STPTRS', -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 or A**T * x = b.
216*
217 DO 30 j = 1, nrhs
218 CALL stpsv( uplo, trans, diag, n, ap, b( 1, j ), 1 )
219 30 CONTINUE
220*
221 RETURN
222*
223* End of STPTRS
224*

◆ stpttf()

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

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

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

Purpose:
!>
!> STPTTF 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;
!>          = 'T':  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 REAL 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 REAL 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 Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last three columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 then consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last two columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 185 of file stpttf.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 TRANSR, UPLO
193 INTEGER INFO, N
194* ..
195* .. Array Arguments ..
196 REAL AP( 0: * ), ARF( 0: * )
197*
198* =====================================================================
199*
200* .. Parameters ..
201* ..
202* .. Local Scalars ..
203 LOGICAL LOWER, NISODD, NORMALTRANSR
204 INTEGER N1, N2, K, NT
205 INTEGER I, J, IJ
206 INTEGER IJP, JP, LDA, JS
207* ..
208* .. External Functions ..
209 LOGICAL LSAME
210 EXTERNAL lsame
211* ..
212* .. External Subroutines ..
213 EXTERNAL xerbla
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC mod
217* ..
218* .. Executable Statements ..
219*
220* Test the input parameters.
221*
222 info = 0
223 normaltransr = lsame( transr, 'N' )
224 lower = lsame( uplo, 'L' )
225 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'T' ) ) THEN
226 info = -1
227 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
228 info = -2
229 ELSE IF( n.LT.0 ) THEN
230 info = -3
231 END IF
232 IF( info.NE.0 ) THEN
233 CALL xerbla( 'STPTTF', -info )
234 RETURN
235 END IF
236*
237* Quick return if possible
238*
239 IF( n.EQ.0 )
240 $ RETURN
241*
242 IF( n.EQ.1 ) THEN
243 IF( normaltransr ) THEN
244 arf( 0 ) = ap( 0 )
245 ELSE
246 arf( 0 ) = ap( 0 )
247 END IF
248 RETURN
249 END IF
250*
251* Size of array ARF(0:NT-1)
252*
253 nt = n*( n+1 ) / 2
254*
255* Set N1 and N2 depending on LOWER
256*
257 IF( lower ) THEN
258 n2 = n / 2
259 n1 = n - n2
260 ELSE
261 n1 = n / 2
262 n2 = n - n1
263 END IF
264*
265* If N is odd, set NISODD = .TRUE.
266* If N is even, set K = N/2 and NISODD = .FALSE.
267*
268* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe)
269* where noe = 0 if n is even, noe = 1 if n is odd
270*
271 IF( mod( n, 2 ).EQ.0 ) THEN
272 k = n / 2
273 nisodd = .false.
274 lda = n + 1
275 ELSE
276 nisodd = .true.
277 lda = n
278 END IF
279*
280* ARF^C has lda rows and n+1-noe cols
281*
282 IF( .NOT.normaltransr )
283 $ lda = ( n+1 ) / 2
284*
285* start execution: there are eight cases
286*
287 IF( nisodd ) THEN
288*
289* N is odd
290*
291 IF( normaltransr ) THEN
292*
293* N is odd and TRANSR = 'N'
294*
295 IF( lower ) THEN
296*
297* N is odd, TRANSR = 'N', and UPLO = 'L'
298*
299 ijp = 0
300 jp = 0
301 DO j = 0, n2
302 DO i = j, n - 1
303 ij = i + jp
304 arf( ij ) = ap( ijp )
305 ijp = ijp + 1
306 END DO
307 jp = jp + lda
308 END DO
309 DO i = 0, n2 - 1
310 DO j = 1 + i, n2
311 ij = i + j*lda
312 arf( ij ) = ap( ijp )
313 ijp = ijp + 1
314 END DO
315 END DO
316*
317 ELSE
318*
319* N is odd, TRANSR = 'N', and UPLO = 'U'
320*
321 ijp = 0
322 DO j = 0, n1 - 1
323 ij = n2 + j
324 DO i = 0, j
325 arf( ij ) = ap( ijp )
326 ijp = ijp + 1
327 ij = ij + lda
328 END DO
329 END DO
330 js = 0
331 DO j = n1, n - 1
332 ij = js
333 DO ij = js, js + j
334 arf( ij ) = ap( ijp )
335 ijp = ijp + 1
336 END DO
337 js = js + lda
338 END DO
339*
340 END IF
341*
342 ELSE
343*
344* N is odd and TRANSR = 'T'
345*
346 IF( lower ) THEN
347*
348* N is odd, TRANSR = 'T', and UPLO = 'L'
349*
350 ijp = 0
351 DO i = 0, n2
352 DO ij = i*( lda+1 ), n*lda - 1, lda
353 arf( ij ) = ap( ijp )
354 ijp = ijp + 1
355 END DO
356 END DO
357 js = 1
358 DO j = 0, n2 - 1
359 DO ij = js, js + n2 - j - 1
360 arf( ij ) = ap( ijp )
361 ijp = ijp + 1
362 END DO
363 js = js + lda + 1
364 END DO
365*
366 ELSE
367*
368* N is odd, TRANSR = 'T', and UPLO = 'U'
369*
370 ijp = 0
371 js = n2*lda
372 DO j = 0, n1 - 1
373 DO ij = js, js + j
374 arf( ij ) = ap( ijp )
375 ijp = ijp + 1
376 END DO
377 js = js + lda
378 END DO
379 DO i = 0, n1
380 DO ij = i, i + ( n1+i )*lda, lda
381 arf( ij ) = ap( ijp )
382 ijp = ijp + 1
383 END DO
384 END DO
385*
386 END IF
387*
388 END IF
389*
390 ELSE
391*
392* N is even
393*
394 IF( normaltransr ) THEN
395*
396* N is even and TRANSR = 'N'
397*
398 IF( lower ) THEN
399*
400* N is even, TRANSR = 'N', and UPLO = 'L'
401*
402 ijp = 0
403 jp = 0
404 DO j = 0, k - 1
405 DO i = j, n - 1
406 ij = 1 + i + jp
407 arf( ij ) = ap( ijp )
408 ijp = ijp + 1
409 END DO
410 jp = jp + lda
411 END DO
412 DO i = 0, k - 1
413 DO j = i, k - 1
414 ij = i + j*lda
415 arf( ij ) = ap( ijp )
416 ijp = ijp + 1
417 END DO
418 END DO
419*
420 ELSE
421*
422* N is even, TRANSR = 'N', and UPLO = 'U'
423*
424 ijp = 0
425 DO j = 0, k - 1
426 ij = k + 1 + j
427 DO i = 0, j
428 arf( ij ) = ap( ijp )
429 ijp = ijp + 1
430 ij = ij + lda
431 END DO
432 END DO
433 js = 0
434 DO j = k, n - 1
435 ij = js
436 DO ij = js, js + j
437 arf( ij ) = ap( ijp )
438 ijp = ijp + 1
439 END DO
440 js = js + lda
441 END DO
442*
443 END IF
444*
445 ELSE
446*
447* N is even and TRANSR = 'T'
448*
449 IF( lower ) THEN
450*
451* N is even, TRANSR = 'T', and UPLO = 'L'
452*
453 ijp = 0
454 DO i = 0, k - 1
455 DO ij = i + ( i+1 )*lda, ( n+1 )*lda - 1, lda
456 arf( ij ) = ap( ijp )
457 ijp = ijp + 1
458 END DO
459 END DO
460 js = 0
461 DO j = 0, k - 1
462 DO ij = js, js + k - j - 1
463 arf( ij ) = ap( ijp )
464 ijp = ijp + 1
465 END DO
466 js = js + lda + 1
467 END DO
468*
469 ELSE
470*
471* N is even, TRANSR = 'T', and UPLO = 'U'
472*
473 ijp = 0
474 js = ( k+1 )*lda
475 DO j = 0, k - 1
476 DO ij = js, js + j
477 arf( ij ) = ap( ijp )
478 ijp = ijp + 1
479 END DO
480 js = js + lda
481 END DO
482 DO i = 0, k - 1
483 DO ij = i, i + ( k+i )*lda, lda
484 arf( ij ) = ap( ijp )
485 ijp = ijp + 1
486 END DO
487 END DO
488*
489 END IF
490*
491 END IF
492*
493 END IF
494*
495 RETURN
496*
497* End of STPTTF
498*

◆ stpttr()

subroutine stpttr ( character uplo,
integer n,
real, dimension( * ) ap,
real, dimension( lda, * ) a,
integer lda,
integer info )

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

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

Purpose:
!>
!> STPTTR 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 REAL 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 REAL 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 stpttr.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 REAL 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( 'STPTTR', -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 STPTTR
172*

◆ strcon()

subroutine strcon ( character norm,
character uplo,
character diag,
integer n,
real, dimension( lda, * ) a,
integer lda,
real rcond,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

STRCON

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

Purpose:
!>
!> STRCON 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 REAL 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 REAL array, dimension (3*N)
!>
[out]IWORK
!>          IWORK is INTEGER 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 strcon.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 INTEGER IWORK( * )
149 REAL 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* ..
164* .. Local Arrays ..
165 INTEGER ISAVE( 3 )
166* ..
167* .. External Functions ..
168 LOGICAL LSAME
169 INTEGER ISAMAX
170 REAL SLAMCH, SLANTR
171 EXTERNAL lsame, isamax, slamch, slantr
172* ..
173* .. External Subroutines ..
174 EXTERNAL slacn2, slatrs, srscl, xerbla
175* ..
176* .. Intrinsic Functions ..
177 INTRINSIC abs, max, real
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 ELSE IF( lda.LT.max( 1, n ) ) THEN
197 info = -6
198 END IF
199 IF( info.NE.0 ) THEN
200 CALL xerbla( 'STRCON', -info )
201 RETURN
202 END IF
203*
204* Quick return if possible
205*
206 IF( n.EQ.0 ) THEN
207 rcond = one
208 RETURN
209 END IF
210*
211 rcond = zero
212 smlnum = slamch( 'Safe minimum' )*real( max( 1, n ) )
213*
214* Compute the norm of the triangular matrix A.
215*
216 anorm = slantr( norm, uplo, diag, n, n, a, lda, work )
217*
218* Continue only if ANORM > 0.
219*
220 IF( anorm.GT.zero ) THEN
221*
222* Estimate the norm of the inverse of A.
223*
224 ainvnm = zero
225 normin = 'N'
226 IF( onenrm ) THEN
227 kase1 = 1
228 ELSE
229 kase1 = 2
230 END IF
231 kase = 0
232 10 CONTINUE
233 CALL slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
234 IF( kase.NE.0 ) THEN
235 IF( kase.EQ.kase1 ) THEN
236*
237* Multiply by inv(A).
238*
239 CALL slatrs( uplo, 'No transpose', diag, normin, n, a,
240 $ lda, work, scale, work( 2*n+1 ), info )
241 ELSE
242*
243* Multiply by inv(A**T).
244*
245 CALL slatrs( uplo, 'Transpose', diag, normin, n, a, lda,
246 $ work, scale, work( 2*n+1 ), info )
247 END IF
248 normin = 'Y'
249*
250* Multiply by 1/SCALE if doing so will not cause overflow.
251*
252 IF( scale.NE.one ) THEN
253 ix = isamax( n, work, 1 )
254 xnorm = abs( work( ix ) )
255 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
256 $ GO TO 20
257 CALL srscl( n, scale, work, 1 )
258 END IF
259 GO TO 10
260 END IF
261*
262* Compute the estimate of the reciprocal condition number.
263*
264 IF( ainvnm.NE.zero )
265 $ rcond = ( one / anorm ) / ainvnm
266 END IF
267*
268 20 CONTINUE
269 RETURN
270*
271* End of STRCON
272*
slantr
real function slantr(norm, uplo, diag, m, n, a, lda, work)
SLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slantr.f:141
slatrs
subroutine slatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
SLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition slatrs.f:238

◆ strevc()

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

STREVC

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

Purpose:
!>
!> STREVC computes some or all of the right and/or left eigenvectors of
!> a real upper quasi-triangular matrix T.
!> Matrices of this type are produced by the Schur factorization of
!> a real general matrix:  A = Q*T*Q**T, as computed by SHSEQR.
!>
!> 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 y.
!> The eigenvalues are not input to this routine, but are read directly
!> from the diagonal blocks 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 orthogonal 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 by the matrices in VR and/or VL;
!>          = 'S':  compute selected right and/or left eigenvectors,
!>                  as indicated by the logical array SELECT.
!>
[in,out]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
!>          computed.
!>          If w(j) is a real eigenvalue, the corresponding real
!>          eigenvector is computed if SELECT(j) is .TRUE..
!>          If w(j) and w(j+1) are the real and imaginary parts of a
!>          complex eigenvalue, the corresponding complex eigenvector is
!>          computed if either SELECT(j) or SELECT(j+1) is .TRUE., and
!>          on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to
!>          .FALSE..
!>          Not referenced if HOWMNY = 'A' or 'B'.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!>
[in]T
!>          T is REAL array, dimension (LDT,N)
!>          The upper quasi-triangular matrix T in Schur canonical form.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in,out]VL
!>          VL is REAL 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 orthogonal matrix Q
!>          of Schur vectors returned by SHSEQR).
!>          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.
!>          A complex eigenvector corresponding to a complex eigenvalue
!>          is stored in two consecutive columns, the first holding the
!>          real part, and the second the imaginary part.
!>          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 REAL 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 orthogonal matrix Q
!>          of Schur vectors returned by SHSEQR).
!>          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.
!>          A complex eigenvector corresponding to a complex eigenvalue
!>          is stored in two consecutive columns, the first holding the
!>          real part and the second the imaginary part.
!>          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 real eigenvector occupies one column and each
!>          selected complex eigenvector occupies two columns.
!>
[out]WORK
!>          WORK is REAL 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.
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 220 of file strevc.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 HOWMNY, SIDE
229 INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
230* ..
231* .. Array Arguments ..
232 LOGICAL SELECT( * )
233 REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
234 $ WORK( * )
235* ..
236*
237* =====================================================================
238*
239* .. Parameters ..
240 REAL ZERO, ONE
241 parameter( zero = 0.0e+0, one = 1.0e+0 )
242* ..
243* .. Local Scalars ..
244 LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
245 INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
246 REAL BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE,
247 $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR,
248 $ XNORM
249* ..
250* .. External Functions ..
251 LOGICAL LSAME
252 INTEGER ISAMAX
253 REAL SDOT, SLAMCH
254 EXTERNAL lsame, isamax, sdot, slamch
255* ..
256* .. External Subroutines ..
257 EXTERNAL saxpy, scopy, sgemv, slabad, slaln2, sscal,
258 $ xerbla
259* ..
260* .. Intrinsic Functions ..
261 INTRINSIC abs, max, sqrt
262* ..
263* .. Local Arrays ..
264 REAL X( 2, 2 )
265* ..
266* .. Executable Statements ..
267*
268* Decode and test the input parameters
269*
270 bothv = lsame( side, 'B' )
271 rightv = lsame( side, 'R' ) .OR. bothv
272 leftv = lsame( side, 'L' ) .OR. bothv
273*
274 allv = lsame( howmny, 'A' )
275 over = lsame( howmny, 'B' )
276 somev = lsame( howmny, 'S' )
277*
278 info = 0
279 IF( .NOT.rightv .AND. .NOT.leftv ) THEN
280 info = -1
281 ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN
282 info = -2
283 ELSE IF( n.LT.0 ) THEN
284 info = -4
285 ELSE IF( ldt.LT.max( 1, n ) ) THEN
286 info = -6
287 ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN
288 info = -8
289 ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN
290 info = -10
291 ELSE
292*
293* Set M to the number of columns required to store the selected
294* eigenvectors, standardize the array SELECT if necessary, and
295* test MM.
296*
297 IF( somev ) THEN
298 m = 0
299 pair = .false.
300 DO 10 j = 1, n
301 IF( pair ) THEN
302 pair = .false.
303 SELECT( j ) = .false.
304 ELSE
305 IF( j.LT.n ) THEN
306 IF( t( j+1, j ).EQ.zero ) THEN
307 IF( SELECT( j ) )
308 $ m = m + 1
309 ELSE
310 pair = .true.
311 IF( SELECT( j ) .OR. SELECT( j+1 ) ) THEN
312 SELECT( j ) = .true.
313 m = m + 2
314 END IF
315 END IF
316 ELSE
317 IF( SELECT( n ) )
318 $ m = m + 1
319 END IF
320 END IF
321 10 CONTINUE
322 ELSE
323 m = n
324 END IF
325*
326 IF( mm.LT.m ) THEN
327 info = -11
328 END IF
329 END IF
330 IF( info.NE.0 ) THEN
331 CALL xerbla( 'STREVC', -info )
332 RETURN
333 END IF
334*
335* Quick return if possible.
336*
337 IF( n.EQ.0 )
338 $ RETURN
339*
340* Set the constants to control overflow.
341*
342 unfl = slamch( 'Safe minimum' )
343 ovfl = one / unfl
344 CALL slabad( unfl, ovfl )
345 ulp = slamch( 'Precision' )
346 smlnum = unfl*( n / ulp )
347 bignum = ( one-ulp ) / smlnum
348*
349* Compute 1-norm of each column of strictly upper triangular
350* part of T to control overflow in triangular solver.
351*
352 work( 1 ) = zero
353 DO 30 j = 2, n
354 work( j ) = zero
355 DO 20 i = 1, j - 1
356 work( j ) = work( j ) + abs( t( i, j ) )
357 20 CONTINUE
358 30 CONTINUE
359*
360* Index IP is used to specify the real or complex eigenvalue:
361* IP = 0, real eigenvalue,
362* 1, first of conjugate complex pair: (wr,wi)
363* -1, second of conjugate complex pair: (wr,wi)
364*
365 n2 = 2*n
366*
367 IF( rightv ) THEN
368*
369* Compute right eigenvectors.
370*
371 ip = 0
372 is = m
373 DO 140 ki = n, 1, -1
374*
375 IF( ip.EQ.1 )
376 $ GO TO 130
377 IF( ki.EQ.1 )
378 $ GO TO 40
379 IF( t( ki, ki-1 ).EQ.zero )
380 $ GO TO 40
381 ip = -1
382*
383 40 CONTINUE
384 IF( somev ) THEN
385 IF( ip.EQ.0 ) THEN
386 IF( .NOT.SELECT( ki ) )
387 $ GO TO 130
388 ELSE
389 IF( .NOT.SELECT( ki-1 ) )
390 $ GO TO 130
391 END IF
392 END IF
393*
394* Compute the KI-th eigenvalue (WR,WI).
395*
396 wr = t( ki, ki )
397 wi = zero
398 IF( ip.NE.0 )
399 $ wi = sqrt( abs( t( ki, ki-1 ) ) )*
400 $ sqrt( abs( t( ki-1, ki ) ) )
401 smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
402*
403 IF( ip.EQ.0 ) THEN
404*
405* Real right eigenvector
406*
407 work( ki+n ) = one
408*
409* Form right-hand side
410*
411 DO 50 k = 1, ki - 1
412 work( k+n ) = -t( k, ki )
413 50 CONTINUE
414*
415* Solve the upper quasi-triangular system:
416* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
417*
418 jnxt = ki - 1
419 DO 60 j = ki - 1, 1, -1
420 IF( j.GT.jnxt )
421 $ GO TO 60
422 j1 = j
423 j2 = j
424 jnxt = j - 1
425 IF( j.GT.1 ) THEN
426 IF( t( j, j-1 ).NE.zero ) THEN
427 j1 = j - 1
428 jnxt = j - 2
429 END IF
430 END IF
431*
432 IF( j1.EQ.j2 ) THEN
433*
434* 1-by-1 diagonal block
435*
436 CALL slaln2( .false., 1, 1, smin, one, t( j, j ),
437 $ ldt, one, one, work( j+n ), n, wr,
438 $ zero, x, 2, scale, xnorm, ierr )
439*
440* Scale X(1,1) to avoid overflow when updating
441* the right-hand side.
442*
443 IF( xnorm.GT.one ) THEN
444 IF( work( j ).GT.bignum / xnorm ) THEN
445 x( 1, 1 ) = x( 1, 1 ) / xnorm
446 scale = scale / xnorm
447 END IF
448 END IF
449*
450* Scale if necessary
451*
452 IF( scale.NE.one )
453 $ CALL sscal( ki, scale, work( 1+n ), 1 )
454 work( j+n ) = x( 1, 1 )
455*
456* Update right-hand side
457*
458 CALL saxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,
459 $ work( 1+n ), 1 )
460*
461 ELSE
462*
463* 2-by-2 diagonal block
464*
465 CALL slaln2( .false., 2, 1, smin, one,
466 $ t( j-1, j-1 ), ldt, one, one,
467 $ work( j-1+n ), n, wr, zero, x, 2,
468 $ scale, xnorm, ierr )
469*
470* Scale X(1,1) and X(2,1) to avoid overflow when
471* updating the right-hand side.
472*
473 IF( xnorm.GT.one ) THEN
474 beta = max( work( j-1 ), work( j ) )
475 IF( beta.GT.bignum / xnorm ) THEN
476 x( 1, 1 ) = x( 1, 1 ) / xnorm
477 x( 2, 1 ) = x( 2, 1 ) / xnorm
478 scale = scale / xnorm
479 END IF
480 END IF
481*
482* Scale if necessary
483*
484 IF( scale.NE.one )
485 $ CALL sscal( ki, scale, work( 1+n ), 1 )
486 work( j-1+n ) = x( 1, 1 )
487 work( j+n ) = x( 2, 1 )
488*
489* Update right-hand side
490*
491 CALL saxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,
492 $ work( 1+n ), 1 )
493 CALL saxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,
494 $ work( 1+n ), 1 )
495 END IF
496 60 CONTINUE
497*
498* Copy the vector x or Q*x to VR and normalize.
499*
500 IF( .NOT.over ) THEN
501 CALL scopy( ki, work( 1+n ), 1, vr( 1, is ), 1 )
502*
503 ii = isamax( ki, vr( 1, is ), 1 )
504 remax = one / abs( vr( ii, is ) )
505 CALL sscal( ki, remax, vr( 1, is ), 1 )
506*
507 DO 70 k = ki + 1, n
508 vr( k, is ) = zero
509 70 CONTINUE
510 ELSE
511 IF( ki.GT.1 )
512 $ CALL sgemv( 'N', n, ki-1, one, vr, ldvr,
513 $ work( 1+n ), 1, work( ki+n ),
514 $ vr( 1, ki ), 1 )
515*
516 ii = isamax( n, vr( 1, ki ), 1 )
517 remax = one / abs( vr( ii, ki ) )
518 CALL sscal( n, remax, vr( 1, ki ), 1 )
519 END IF
520*
521 ELSE
522*
523* Complex right eigenvector.
524*
525* Initial solve
526* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
527* [ (T(KI,KI-1) T(KI,KI) ) ]
528*
529 IF( abs( t( ki-1, ki ) ).GE.abs( t( ki, ki-1 ) ) ) THEN
530 work( ki-1+n ) = one
531 work( ki+n2 ) = wi / t( ki-1, ki )
532 ELSE
533 work( ki-1+n ) = -wi / t( ki, ki-1 )
534 work( ki+n2 ) = one
535 END IF
536 work( ki+n ) = zero
537 work( ki-1+n2 ) = zero
538*
539* Form right-hand side
540*
541 DO 80 k = 1, ki - 2
542 work( k+n ) = -work( ki-1+n )*t( k, ki-1 )
543 work( k+n2 ) = -work( ki+n2 )*t( k, ki )
544 80 CONTINUE
545*
546* Solve upper quasi-triangular system:
547* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
548*
549 jnxt = ki - 2
550 DO 90 j = ki - 2, 1, -1
551 IF( j.GT.jnxt )
552 $ GO TO 90
553 j1 = j
554 j2 = j
555 jnxt = j - 1
556 IF( j.GT.1 ) THEN
557 IF( t( j, j-1 ).NE.zero ) THEN
558 j1 = j - 1
559 jnxt = j - 2
560 END IF
561 END IF
562*
563 IF( j1.EQ.j2 ) THEN
564*
565* 1-by-1 diagonal block
566*
567 CALL slaln2( .false., 1, 2, smin, one, t( j, j ),
568 $ ldt, one, one, work( j+n ), n, wr, wi,
569 $ x, 2, scale, xnorm, ierr )
570*
571* Scale X(1,1) and X(1,2) to avoid overflow when
572* updating the right-hand side.
573*
574 IF( xnorm.GT.one ) THEN
575 IF( work( j ).GT.bignum / xnorm ) THEN
576 x( 1, 1 ) = x( 1, 1 ) / xnorm
577 x( 1, 2 ) = x( 1, 2 ) / xnorm
578 scale = scale / xnorm
579 END IF
580 END IF
581*
582* Scale if necessary
583*
584 IF( scale.NE.one ) THEN
585 CALL sscal( ki, scale, work( 1+n ), 1 )
586 CALL sscal( ki, scale, work( 1+n2 ), 1 )
587 END IF
588 work( j+n ) = x( 1, 1 )
589 work( j+n2 ) = x( 1, 2 )
590*
591* Update the right-hand side
592*
593 CALL saxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,
594 $ work( 1+n ), 1 )
595 CALL saxpy( j-1, -x( 1, 2 ), t( 1, j ), 1,
596 $ work( 1+n2 ), 1 )
597*
598 ELSE
599*
600* 2-by-2 diagonal block
601*
602 CALL slaln2( .false., 2, 2, smin, one,
603 $ t( j-1, j-1 ), ldt, one, one,
604 $ work( j-1+n ), n, wr, wi, x, 2, scale,
605 $ xnorm, ierr )
606*
607* Scale X to avoid overflow when updating
608* the right-hand side.
609*
610 IF( xnorm.GT.one ) THEN
611 beta = max( work( j-1 ), work( j ) )
612 IF( beta.GT.bignum / xnorm ) THEN
613 rec = one / xnorm
614 x( 1, 1 ) = x( 1, 1 )*rec
615 x( 1, 2 ) = x( 1, 2 )*rec
616 x( 2, 1 ) = x( 2, 1 )*rec
617 x( 2, 2 ) = x( 2, 2 )*rec
618 scale = scale*rec
619 END IF
620 END IF
621*
622* Scale if necessary
623*
624 IF( scale.NE.one ) THEN
625 CALL sscal( ki, scale, work( 1+n ), 1 )
626 CALL sscal( ki, scale, work( 1+n2 ), 1 )
627 END IF
628 work( j-1+n ) = x( 1, 1 )
629 work( j+n ) = x( 2, 1 )
630 work( j-1+n2 ) = x( 1, 2 )
631 work( j+n2 ) = x( 2, 2 )
632*
633* Update the right-hand side
634*
635 CALL saxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,
636 $ work( 1+n ), 1 )
637 CALL saxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,
638 $ work( 1+n ), 1 )
639 CALL saxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,
640 $ work( 1+n2 ), 1 )
641 CALL saxpy( j-2, -x( 2, 2 ), t( 1, j ), 1,
642 $ work( 1+n2 ), 1 )
643 END IF
644 90 CONTINUE
645*
646* Copy the vector x or Q*x to VR and normalize.
647*
648 IF( .NOT.over ) THEN
649 CALL scopy( ki, work( 1+n ), 1, vr( 1, is-1 ), 1 )
650 CALL scopy( ki, work( 1+n2 ), 1, vr( 1, is ), 1 )
651*
652 emax = zero
653 DO 100 k = 1, ki
654 emax = max( emax, abs( vr( k, is-1 ) )+
655 $ abs( vr( k, is ) ) )
656 100 CONTINUE
657*
658 remax = one / emax
659 CALL sscal( ki, remax, vr( 1, is-1 ), 1 )
660 CALL sscal( ki, remax, vr( 1, is ), 1 )
661*
662 DO 110 k = ki + 1, n
663 vr( k, is-1 ) = zero
664 vr( k, is ) = zero
665 110 CONTINUE
666*
667 ELSE
668*
669 IF( ki.GT.2 ) THEN
670 CALL sgemv( 'N', n, ki-2, one, vr, ldvr,
671 $ work( 1+n ), 1, work( ki-1+n ),
672 $ vr( 1, ki-1 ), 1 )
673 CALL sgemv( 'N', n, ki-2, one, vr, ldvr,
674 $ work( 1+n2 ), 1, work( ki+n2 ),
675 $ vr( 1, ki ), 1 )
676 ELSE
677 CALL sscal( n, work( ki-1+n ), vr( 1, ki-1 ), 1 )
678 CALL sscal( n, work( ki+n2 ), vr( 1, ki ), 1 )
679 END IF
680*
681 emax = zero
682 DO 120 k = 1, n
683 emax = max( emax, abs( vr( k, ki-1 ) )+
684 $ abs( vr( k, ki ) ) )
685 120 CONTINUE
686 remax = one / emax
687 CALL sscal( n, remax, vr( 1, ki-1 ), 1 )
688 CALL sscal( n, remax, vr( 1, ki ), 1 )
689 END IF
690 END IF
691*
692 is = is - 1
693 IF( ip.NE.0 )
694 $ is = is - 1
695 130 CONTINUE
696 IF( ip.EQ.1 )
697 $ ip = 0
698 IF( ip.EQ.-1 )
699 $ ip = 1
700 140 CONTINUE
701 END IF
702*
703 IF( leftv ) THEN
704*
705* Compute left eigenvectors.
706*
707 ip = 0
708 is = 1
709 DO 260 ki = 1, n
710*
711 IF( ip.EQ.-1 )
712 $ GO TO 250
713 IF( ki.EQ.n )
714 $ GO TO 150
715 IF( t( ki+1, ki ).EQ.zero )
716 $ GO TO 150
717 ip = 1
718*
719 150 CONTINUE
720 IF( somev ) THEN
721 IF( .NOT.SELECT( ki ) )
722 $ GO TO 250
723 END IF
724*
725* Compute the KI-th eigenvalue (WR,WI).
726*
727 wr = t( ki, ki )
728 wi = zero
729 IF( ip.NE.0 )
730 $ wi = sqrt( abs( t( ki, ki+1 ) ) )*
731 $ sqrt( abs( t( ki+1, ki ) ) )
732 smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
733*
734 IF( ip.EQ.0 ) THEN
735*
736* Real left eigenvector.
737*
738 work( ki+n ) = one
739*
740* Form right-hand side
741*
742 DO 160 k = ki + 1, n
743 work( k+n ) = -t( ki, k )
744 160 CONTINUE
745*
746* Solve the quasi-triangular system:
747* (T(KI+1:N,KI+1:N) - WR)**T*X = SCALE*WORK
748*
749 vmax = one
750 vcrit = bignum
751*
752 jnxt = ki + 1
753 DO 170 j = ki + 1, n
754 IF( j.LT.jnxt )
755 $ GO TO 170
756 j1 = j
757 j2 = j
758 jnxt = j + 1
759 IF( j.LT.n ) THEN
760 IF( t( j+1, j ).NE.zero ) THEN
761 j2 = j + 1
762 jnxt = j + 2
763 END IF
764 END IF
765*
766 IF( j1.EQ.j2 ) THEN
767*
768* 1-by-1 diagonal block
769*
770* Scale if necessary to avoid overflow when forming
771* the right-hand side.
772*
773 IF( work( j ).GT.vcrit ) THEN
774 rec = one / vmax
775 CALL sscal( n-ki+1, rec, work( ki+n ), 1 )
776 vmax = one
777 vcrit = bignum
778 END IF
779*
780 work( j+n ) = work( j+n ) -
781 $ sdot( j-ki-1, t( ki+1, j ), 1,
782 $ work( ki+1+n ), 1 )
783*
784* Solve (T(J,J)-WR)**T*X = WORK
785*
786 CALL slaln2( .false., 1, 1, smin, one, t( j, j ),
787 $ ldt, one, one, work( j+n ), n, wr,
788 $ zero, x, 2, scale, xnorm, ierr )
789*
790* Scale if necessary
791*
792 IF( scale.NE.one )
793 $ CALL sscal( n-ki+1, scale, work( ki+n ), 1 )
794 work( j+n ) = x( 1, 1 )
795 vmax = max( abs( work( j+n ) ), vmax )
796 vcrit = bignum / vmax
797*
798 ELSE
799*
800* 2-by-2 diagonal block
801*
802* Scale if necessary to avoid overflow when forming
803* the right-hand side.
804*
805 beta = max( work( j ), work( j+1 ) )
806 IF( beta.GT.vcrit ) THEN
807 rec = one / vmax
808 CALL sscal( n-ki+1, rec, work( ki+n ), 1 )
809 vmax = one
810 vcrit = bignum
811 END IF
812*
813 work( j+n ) = work( j+n ) -
814 $ sdot( j-ki-1, t( ki+1, j ), 1,
815 $ work( ki+1+n ), 1 )
816*
817 work( j+1+n ) = work( j+1+n ) -
818 $ sdot( j-ki-1, t( ki+1, j+1 ), 1,
819 $ work( ki+1+n ), 1 )
820*
821* Solve
822* [T(J,J)-WR T(J,J+1) ]**T* X = SCALE*( WORK1 )
823* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 )
824*
825 CALL slaln2( .true., 2, 1, smin, one, t( j, j ),
826 $ ldt, one, one, work( j+n ), n, wr,
827 $ zero, x, 2, scale, xnorm, ierr )
828*
829* Scale if necessary
830*
831 IF( scale.NE.one )
832 $ CALL sscal( n-ki+1, scale, work( ki+n ), 1 )
833 work( j+n ) = x( 1, 1 )
834 work( j+1+n ) = x( 2, 1 )
835*
836 vmax = max( abs( work( j+n ) ),
837 $ abs( work( j+1+n ) ), vmax )
838 vcrit = bignum / vmax
839*
840 END IF
841 170 CONTINUE
842*
843* Copy the vector x or Q*x to VL and normalize.
844*
845 IF( .NOT.over ) THEN
846 CALL scopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 )
847*
848 ii = isamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
849 remax = one / abs( vl( ii, is ) )
850 CALL sscal( n-ki+1, remax, vl( ki, is ), 1 )
851*
852 DO 180 k = 1, ki - 1
853 vl( k, is ) = zero
854 180 CONTINUE
855*
856 ELSE
857*
858 IF( ki.LT.n )
859 $ CALL sgemv( 'N', n, n-ki, one, vl( 1, ki+1 ), ldvl,
860 $ work( ki+1+n ), 1, work( ki+n ),
861 $ vl( 1, ki ), 1 )
862*
863 ii = isamax( n, vl( 1, ki ), 1 )
864 remax = one / abs( vl( ii, ki ) )
865 CALL sscal( n, remax, vl( 1, ki ), 1 )
866*
867 END IF
868*
869 ELSE
870*
871* Complex left eigenvector.
872*
873* Initial solve:
874* ((T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI))*X = 0.
875* ((T(KI+1,KI) T(KI+1,KI+1)) )
876*
877 IF( abs( t( ki, ki+1 ) ).GE.abs( t( ki+1, ki ) ) ) THEN
878 work( ki+n ) = wi / t( ki, ki+1 )
879 work( ki+1+n2 ) = one
880 ELSE
881 work( ki+n ) = one
882 work( ki+1+n2 ) = -wi / t( ki+1, ki )
883 END IF
884 work( ki+1+n ) = zero
885 work( ki+n2 ) = zero
886*
887* Form right-hand side
888*
889 DO 190 k = ki + 2, n
890 work( k+n ) = -work( ki+n )*t( ki, k )
891 work( k+n2 ) = -work( ki+1+n2 )*t( ki+1, k )
892 190 CONTINUE
893*
894* Solve complex quasi-triangular system:
895* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
896*
897 vmax = one
898 vcrit = bignum
899*
900 jnxt = ki + 2
901 DO 200 j = ki + 2, n
902 IF( j.LT.jnxt )
903 $ GO TO 200
904 j1 = j
905 j2 = j
906 jnxt = j + 1
907 IF( j.LT.n ) THEN
908 IF( t( j+1, j ).NE.zero ) THEN
909 j2 = j + 1
910 jnxt = j + 2
911 END IF
912 END IF
913*
914 IF( j1.EQ.j2 ) THEN
915*
916* 1-by-1 diagonal block
917*
918* Scale if necessary to avoid overflow when
919* forming the right-hand side elements.
920*
921 IF( work( j ).GT.vcrit ) THEN
922 rec = one / vmax
923 CALL sscal( n-ki+1, rec, work( ki+n ), 1 )
924 CALL sscal( n-ki+1, rec, work( ki+n2 ), 1 )
925 vmax = one
926 vcrit = bignum
927 END IF
928*
929 work( j+n ) = work( j+n ) -
930 $ sdot( j-ki-2, t( ki+2, j ), 1,
931 $ work( ki+2+n ), 1 )
932 work( j+n2 ) = work( j+n2 ) -
933 $ sdot( j-ki-2, t( ki+2, j ), 1,
934 $ work( ki+2+n2 ), 1 )
935*
936* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
937*
938 CALL slaln2( .false., 1, 2, smin, one, t( j, j ),
939 $ ldt, one, one, work( j+n ), n, wr,
940 $ -wi, x, 2, scale, xnorm, ierr )
941*
942* Scale if necessary
943*
944 IF( scale.NE.one ) THEN
945 CALL sscal( n-ki+1, scale, work( ki+n ), 1 )
946 CALL sscal( n-ki+1, scale, work( ki+n2 ), 1 )
947 END IF
948 work( j+n ) = x( 1, 1 )
949 work( j+n2 ) = x( 1, 2 )
950 vmax = max( abs( work( j+n ) ),
951 $ abs( work( j+n2 ) ), vmax )
952 vcrit = bignum / vmax
953*
954 ELSE
955*
956* 2-by-2 diagonal block
957*
958* Scale if necessary to avoid overflow when forming
959* the right-hand side elements.
960*
961 beta = max( work( j ), work( j+1 ) )
962 IF( beta.GT.vcrit ) THEN
963 rec = one / vmax
964 CALL sscal( n-ki+1, rec, work( ki+n ), 1 )
965 CALL sscal( n-ki+1, rec, work( ki+n2 ), 1 )
966 vmax = one
967 vcrit = bignum
968 END IF
969*
970 work( j+n ) = work( j+n ) -
971 $ sdot( j-ki-2, t( ki+2, j ), 1,
972 $ work( ki+2+n ), 1 )
973*
974 work( j+n2 ) = work( j+n2 ) -
975 $ sdot( j-ki-2, t( ki+2, j ), 1,
976 $ work( ki+2+n2 ), 1 )
977*
978 work( j+1+n ) = work( j+1+n ) -
979 $ sdot( j-ki-2, t( ki+2, j+1 ), 1,
980 $ work( ki+2+n ), 1 )
981*
982 work( j+1+n2 ) = work( j+1+n2 ) -
983 $ sdot( j-ki-2, t( ki+2, j+1 ), 1,
984 $ work( ki+2+n2 ), 1 )
985*
986* Solve 2-by-2 complex linear equation
987* ([T(j,j) T(j,j+1) ]**T-(wr-i*wi)*I)*X = SCALE*B
988* ([T(j+1,j) T(j+1,j+1)] )
989*
990 CALL slaln2( .true., 2, 2, smin, one, t( j, j ),
991 $ ldt, one, one, work( j+n ), n, wr,
992 $ -wi, x, 2, scale, xnorm, ierr )
993*
994* Scale if necessary
995*
996 IF( scale.NE.one ) THEN
997 CALL sscal( n-ki+1, scale, work( ki+n ), 1 )
998 CALL sscal( n-ki+1, scale, work( ki+n2 ), 1 )
999 END IF
1000 work( j+n ) = x( 1, 1 )
1001 work( j+n2 ) = x( 1, 2 )
1002 work( j+1+n ) = x( 2, 1 )
1003 work( j+1+n2 ) = x( 2, 2 )
1004 vmax = max( abs( x( 1, 1 ) ), abs( x( 1, 2 ) ),
1005 $ abs( x( 2, 1 ) ), abs( x( 2, 2 ) ), vmax )
1006 vcrit = bignum / vmax
1007*
1008 END IF
1009 200 CONTINUE
1010*
1011* Copy the vector x or Q*x to VL and normalize.
1012*
1013 IF( .NOT.over ) THEN
1014 CALL scopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 )
1015 CALL scopy( n-ki+1, work( ki+n2 ), 1, vl( ki, is+1 ),
1016 $ 1 )
1017*
1018 emax = zero
1019 DO 220 k = ki, n
1020 emax = max( emax, abs( vl( k, is ) )+
1021 $ abs( vl( k, is+1 ) ) )
1022 220 CONTINUE
1023 remax = one / emax
1024 CALL sscal( n-ki+1, remax, vl( ki, is ), 1 )
1025 CALL sscal( n-ki+1, remax, vl( ki, is+1 ), 1 )
1026*
1027 DO 230 k = 1, ki - 1
1028 vl( k, is ) = zero
1029 vl( k, is+1 ) = zero
1030 230 CONTINUE
1031 ELSE
1032 IF( ki.LT.n-1 ) THEN
1033 CALL sgemv( 'N', n, n-ki-1, one, vl( 1, ki+2 ),
1034 $ ldvl, work( ki+2+n ), 1, work( ki+n ),
1035 $ vl( 1, ki ), 1 )
1036 CALL sgemv( 'N', n, n-ki-1, one, vl( 1, ki+2 ),
1037 $ ldvl, work( ki+2+n2 ), 1,
1038 $ work( ki+1+n2 ), vl( 1, ki+1 ), 1 )
1039 ELSE
1040 CALL sscal( n, work( ki+n ), vl( 1, ki ), 1 )
1041 CALL sscal( n, work( ki+1+n2 ), vl( 1, ki+1 ), 1 )
1042 END IF
1043*
1044 emax = zero
1045 DO 240 k = 1, n
1046 emax = max( emax, abs( vl( k, ki ) )+
1047 $ abs( vl( k, ki+1 ) ) )
1048 240 CONTINUE
1049 remax = one / emax
1050 CALL sscal( n, remax, vl( 1, ki ), 1 )
1051 CALL sscal( n, remax, vl( 1, ki+1 ), 1 )
1052*
1053 END IF
1054*
1055 END IF
1056*
1057 is = is + 1
1058 IF( ip.NE.0 )
1059 $ is = is + 1
1060 250 CONTINUE
1061 IF( ip.EQ.-1 )
1062 $ ip = 0
1063 IF( ip.EQ.1 )
1064 $ ip = -1
1065*
1066 260 CONTINUE
1067*
1068 END IF
1069*
1070 RETURN
1071*
1072* End of STREVC
1073*
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74
slaln2
subroutine slaln2(ltrans, na, nw, smin, ca, a, lda, d1, d2, b, ldb, wr, wi, x, ldx, scale, xnorm, info)
SLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.
Definition slaln2.f:218

◆ strevc3()

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

STREVC3

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

Purpose:
!>
!> STREVC3 computes some or all of the right and/or left eigenvectors of
!> a real upper quasi-triangular matrix T.
!> Matrices of this type are produced by the Schur factorization of
!> a real general matrix:  A = Q*T*Q**T, as computed by SHSEQR.
!>
!> The right eigenvector x and the left eigenvector y of T corresponding
!> to an eigenvalue w are defined by:
!>
!>    T*x = w*x,     (y**T)*T = w*(y**T)
!>
!> where y**T denotes the transpose of the vector y.
!> The eigenvalues are not input to this routine, but are read directly
!> from the diagonal blocks 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 orthogonal 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 by the matrices in VR and/or VL;
!>          = 'S':  compute selected right and/or left eigenvectors,
!>                  as indicated by the logical array SELECT.
!>
[in,out]SELECT
!>          SELECT is LOGICAL array, dimension (N)
!>          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
!>          computed.
!>          If w(j) is a real eigenvalue, the corresponding real
!>          eigenvector is computed if SELECT(j) is .TRUE..
!>          If w(j) and w(j+1) are the real and imaginary parts of a
!>          complex eigenvalue, the corresponding complex eigenvector is
!>          computed if either SELECT(j) or SELECT(j+1) is .TRUE., and
!>          on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to
!>          .FALSE..
!>          Not referenced if HOWMNY = 'A' or 'B'.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!>
[in]T
!>          T is REAL array, dimension (LDT,N)
!>          The upper quasi-triangular matrix T in Schur canonical form.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in,out]VL
!>          VL is REAL 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 orthogonal matrix Q
!>          of Schur vectors returned by SHSEQR).
!>          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.
!>          A complex eigenvector corresponding to a complex eigenvalue
!>          is stored in two consecutive columns, the first holding the
!>          real part, and the second the imaginary part.
!>          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 REAL 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 orthogonal matrix Q
!>          of Schur vectors returned by SHSEQR).
!>          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.
!>          A complex eigenvector corresponding to a complex eigenvalue
!>          is stored in two consecutive columns, the first holding the
!>          real part and the second the imaginary part.
!>          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 real eigenvector occupies one column and each
!>          selected complex eigenvector occupies two columns.
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of array WORK. LWORK >= max(1,3*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]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 235 of file strevc3.f.

237 IMPLICIT NONE
238*
239* -- LAPACK computational routine --
240* -- LAPACK is a software package provided by Univ. of Tennessee, --
241* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
242*
243* .. Scalar Arguments ..
244 CHARACTER HOWMNY, SIDE
245 INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N
246* ..
247* .. Array Arguments ..
248 LOGICAL SELECT( * )
249 REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
250 $ WORK( * )
251* ..
252*
253* =====================================================================
254*
255* .. Parameters ..
256 REAL ZERO, ONE
257 parameter( zero = 0.0e+0, one = 1.0e+0 )
258 INTEGER NBMIN, NBMAX
259 parameter( nbmin = 8, nbmax = 128 )
260* ..
261* .. Local Scalars ..
262 LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, PAIR,
263 $ RIGHTV, SOMEV
264 INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI,
265 $ IV, MAXWRK, NB, KI2
266 REAL BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE,
267 $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR,
268 $ XNORM
269* ..
270* .. External Functions ..
271 LOGICAL LSAME
272 INTEGER ISAMAX, ILAENV
273 REAL SDOT, SLAMCH
274 EXTERNAL lsame, isamax, ilaenv, sdot, slamch
275* ..
276* .. External Subroutines ..
277 EXTERNAL saxpy, scopy, sgemv, slaln2, sscal, xerbla,
278 $ slacpy, sgemm, slabad, slaset
279* ..
280* .. Intrinsic Functions ..
281 INTRINSIC abs, max, sqrt
282* ..
283* .. Local Arrays ..
284 REAL X( 2, 2 )
285 INTEGER ISCOMPLEX( NBMAX )
286* ..
287* .. Executable Statements ..
288*
289* Decode and test the input parameters
290*
291 bothv = lsame( side, 'B' )
292 rightv = lsame( side, 'R' ) .OR. bothv
293 leftv = lsame( side, 'L' ) .OR. bothv
294*
295 allv = lsame( howmny, 'A' )
296 over = lsame( howmny, 'B' )
297 somev = lsame( howmny, 'S' )
298*
299 info = 0
300 nb = ilaenv( 1, 'STREVC', side // howmny, n, -1, -1, -1 )
301 maxwrk = n + 2*n*nb
302 work(1) = maxwrk
303 lquery = ( lwork.EQ.-1 )
304 IF( .NOT.rightv .AND. .NOT.leftv ) THEN
305 info = -1
306 ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN
307 info = -2
308 ELSE IF( n.LT.0 ) THEN
309 info = -4
310 ELSE IF( ldt.LT.max( 1, n ) ) THEN
311 info = -6
312 ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) ) THEN
313 info = -8
314 ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) ) THEN
315 info = -10
316 ELSE IF( lwork.LT.max( 1, 3*n ) .AND. .NOT.lquery ) THEN
317 info = -14
318 ELSE
319*
320* Set M to the number of columns required to store the selected
321* eigenvectors, standardize the array SELECT if necessary, and
322* test MM.
323*
324 IF( somev ) THEN
325 m = 0
326 pair = .false.
327 DO 10 j = 1, n
328 IF( pair ) THEN
329 pair = .false.
330 SELECT( j ) = .false.
331 ELSE
332 IF( j.LT.n ) THEN
333 IF( t( j+1, j ).EQ.zero ) THEN
334 IF( SELECT( j ) )
335 $ m = m + 1
336 ELSE
337 pair = .true.
338 IF( SELECT( j ) .OR. SELECT( j+1 ) ) THEN
339 SELECT( j ) = .true.
340 m = m + 2
341 END IF
342 END IF
343 ELSE
344 IF( SELECT( n ) )
345 $ m = m + 1
346 END IF
347 END IF
348 10 CONTINUE
349 ELSE
350 m = n
351 END IF
352*
353 IF( mm.LT.m ) THEN
354 info = -11
355 END IF
356 END IF
357 IF( info.NE.0 ) THEN
358 CALL xerbla( 'STREVC3', -info )
359 RETURN
360 ELSE IF( lquery ) THEN
361 RETURN
362 END IF
363*
364* Quick return if possible.
365*
366 IF( n.EQ.0 )
367 $ RETURN
368*
369* Use blocked version of back-transformation if sufficient workspace.
370* Zero-out the workspace to avoid potential NaN propagation.
371*
372 IF( over .AND. lwork .GE. n + 2*n*nbmin ) THEN
373 nb = (lwork - n) / (2*n)
374 nb = min( nb, nbmax )
375 CALL slaset( 'F', n, 1+2*nb, zero, zero, work, n )
376 ELSE
377 nb = 1
378 END IF
379*
380* Set the constants to control overflow.
381*
382 unfl = slamch( 'Safe minimum' )
383 ovfl = one / unfl
384 CALL slabad( unfl, ovfl )
385 ulp = slamch( 'Precision' )
386 smlnum = unfl*( n / ulp )
387 bignum = ( one-ulp ) / smlnum
388*
389* Compute 1-norm of each column of strictly upper triangular
390* part of T to control overflow in triangular solver.
391*
392 work( 1 ) = zero
393 DO 30 j = 2, n
394 work( j ) = zero
395 DO 20 i = 1, j - 1
396 work( j ) = work( j ) + abs( t( i, j ) )
397 20 CONTINUE
398 30 CONTINUE
399*
400* Index IP is used to specify the real or complex eigenvalue:
401* IP = 0, real eigenvalue,
402* 1, first of conjugate complex pair: (wr,wi)
403* -1, second of conjugate complex pair: (wr,wi)
404* ISCOMPLEX array stores IP for each column in current block.
405*
406 IF( rightv ) THEN
407*
408* ============================================================
409* Compute right eigenvectors.
410*
411* IV is index of column in current block.
412* For complex right vector, uses IV-1 for real part and IV for complex part.
413* Non-blocked version always uses IV=2;
414* blocked version starts with IV=NB, goes down to 1 or 2.
415* (Note the "0-th" column is used for 1-norms computed above.)
416 iv = 2
417 IF( nb.GT.2 ) THEN
418 iv = nb
419 END IF
420
421 ip = 0
422 is = m
423 DO 140 ki = n, 1, -1
424 IF( ip.EQ.-1 ) THEN
425* previous iteration (ki+1) was second of conjugate pair,
426* so this ki is first of conjugate pair; skip to end of loop
427 ip = 1
428 GO TO 140
429 ELSE IF( ki.EQ.1 ) THEN
430* last column, so this ki must be real eigenvalue
431 ip = 0
432 ELSE IF( t( ki, ki-1 ).EQ.zero ) THEN
433* zero on sub-diagonal, so this ki is real eigenvalue
434 ip = 0
435 ELSE
436* non-zero on sub-diagonal, so this ki is second of conjugate pair
437 ip = -1
438 END IF
439
440 IF( somev ) THEN
441 IF( ip.EQ.0 ) THEN
442 IF( .NOT.SELECT( ki ) )
443 $ GO TO 140
444 ELSE
445 IF( .NOT.SELECT( ki-1 ) )
446 $ GO TO 140
447 END IF
448 END IF
449*
450* Compute the KI-th eigenvalue (WR,WI).
451*
452 wr = t( ki, ki )
453 wi = zero
454 IF( ip.NE.0 )
455 $ wi = sqrt( abs( t( ki, ki-1 ) ) )*
456 $ sqrt( abs( t( ki-1, ki ) ) )
457 smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
458*
459 IF( ip.EQ.0 ) THEN
460*
461* --------------------------------------------------------
462* Real right eigenvector
463*
464 work( ki + iv*n ) = one
465*
466* Form right-hand side.
467*
468 DO 50 k = 1, ki - 1
469 work( k + iv*n ) = -t( k, ki )
470 50 CONTINUE
471*
472* Solve upper quasi-triangular system:
473* [ T(1:KI-1,1:KI-1) - WR ]*X = SCALE*WORK.
474*
475 jnxt = ki - 1
476 DO 60 j = ki - 1, 1, -1
477 IF( j.GT.jnxt )
478 $ GO TO 60
479 j1 = j
480 j2 = j
481 jnxt = j - 1
482 IF( j.GT.1 ) THEN
483 IF( t( j, j-1 ).NE.zero ) THEN
484 j1 = j - 1
485 jnxt = j - 2
486 END IF
487 END IF
488*
489 IF( j1.EQ.j2 ) THEN
490*
491* 1-by-1 diagonal block
492*
493 CALL slaln2( .false., 1, 1, smin, one, t( j, j ),
494 $ ldt, one, one, work( j+iv*n ), n, wr,
495 $ zero, x, 2, scale, xnorm, ierr )
496*
497* Scale X(1,1) to avoid overflow when updating
498* the right-hand side.
499*
500 IF( xnorm.GT.one ) THEN
501 IF( work( j ).GT.bignum / xnorm ) THEN
502 x( 1, 1 ) = x( 1, 1 ) / xnorm
503 scale = scale / xnorm
504 END IF
505 END IF
506*
507* Scale if necessary
508*
509 IF( scale.NE.one )
510 $ CALL sscal( ki, scale, work( 1+iv*n ), 1 )
511 work( j+iv*n ) = x( 1, 1 )
512*
513* Update right-hand side
514*
515 CALL saxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,
516 $ work( 1+iv*n ), 1 )
517*
518 ELSE
519*
520* 2-by-2 diagonal block
521*
522 CALL slaln2( .false., 2, 1, smin, one,
523 $ t( j-1, j-1 ), ldt, one, one,
524 $ work( j-1+iv*n ), n, wr, zero, x, 2,
525 $ scale, xnorm, ierr )
526*
527* Scale X(1,1) and X(2,1) to avoid overflow when
528* updating the right-hand side.
529*
530 IF( xnorm.GT.one ) THEN
531 beta = max( work( j-1 ), work( j ) )
532 IF( beta.GT.bignum / xnorm ) THEN
533 x( 1, 1 ) = x( 1, 1 ) / xnorm
534 x( 2, 1 ) = x( 2, 1 ) / xnorm
535 scale = scale / xnorm
536 END IF
537 END IF
538*
539* Scale if necessary
540*
541 IF( scale.NE.one )
542 $ CALL sscal( ki, scale, work( 1+iv*n ), 1 )
543 work( j-1+iv*n ) = x( 1, 1 )
544 work( j +iv*n ) = x( 2, 1 )
545*
546* Update right-hand side
547*
548 CALL saxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,
549 $ work( 1+iv*n ), 1 )
550 CALL saxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,
551 $ work( 1+iv*n ), 1 )
552 END IF
553 60 CONTINUE
554*
555* Copy the vector x or Q*x to VR and normalize.
556*
557 IF( .NOT.over ) THEN
558* ------------------------------
559* no back-transform: copy x to VR and normalize.
560 CALL scopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 )
561*
562 ii = isamax( ki, vr( 1, is ), 1 )
563 remax = one / abs( vr( ii, is ) )
564 CALL sscal( ki, remax, vr( 1, is ), 1 )
565*
566 DO 70 k = ki + 1, n
567 vr( k, is ) = zero
568 70 CONTINUE
569*
570 ELSE IF( nb.EQ.1 ) THEN
571* ------------------------------
572* version 1: back-transform each vector with GEMV, Q*x.
573 IF( ki.GT.1 )
574 $ CALL sgemv( 'N', n, ki-1, one, vr, ldvr,
575 $ work( 1 + iv*n ), 1, work( ki + iv*n ),
576 $ vr( 1, ki ), 1 )
577*
578 ii = isamax( n, vr( 1, ki ), 1 )
579 remax = one / abs( vr( ii, ki ) )
580 CALL sscal( n, remax, vr( 1, ki ), 1 )
581*
582 ELSE
583* ------------------------------
584* version 2: back-transform block of vectors with GEMM
585* zero out below vector
586 DO k = ki + 1, n
587 work( k + iv*n ) = zero
588 END DO
589 iscomplex( iv ) = ip
590* back-transform and normalization is done below
591 END IF
592 ELSE
593*
594* --------------------------------------------------------
595* Complex right eigenvector.
596*
597* Initial solve
598* [ ( T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I*WI) ]*X = 0.
599* [ ( T(KI, KI-1) T(KI, KI) ) ]
600*
601 IF( abs( t( ki-1, ki ) ).GE.abs( t( ki, ki-1 ) ) ) THEN
602 work( ki-1 + (iv-1)*n ) = one
603 work( ki + (iv )*n ) = wi / t( ki-1, ki )
604 ELSE
605 work( ki-1 + (iv-1)*n ) = -wi / t( ki, ki-1 )
606 work( ki + (iv )*n ) = one
607 END IF
608 work( ki + (iv-1)*n ) = zero
609 work( ki-1 + (iv )*n ) = zero
610*
611* Form right-hand side.
612*
613 DO 80 k = 1, ki - 2
614 work( k+(iv-1)*n ) = -work( ki-1+(iv-1)*n )*t(k,ki-1)
615 work( k+(iv )*n ) = -work( ki +(iv )*n )*t(k,ki )
616 80 CONTINUE
617*
618* Solve upper quasi-triangular system:
619* [ T(1:KI-2,1:KI-2) - (WR+i*WI) ]*X = SCALE*(WORK+i*WORK2)
620*
621 jnxt = ki - 2
622 DO 90 j = ki - 2, 1, -1
623 IF( j.GT.jnxt )
624 $ GO TO 90
625 j1 = j
626 j2 = j
627 jnxt = j - 1
628 IF( j.GT.1 ) THEN
629 IF( t( j, j-1 ).NE.zero ) THEN
630 j1 = j - 1
631 jnxt = j - 2
632 END IF
633 END IF
634*
635 IF( j1.EQ.j2 ) THEN
636*
637* 1-by-1 diagonal block
638*
639 CALL slaln2( .false., 1, 2, smin, one, t( j, j ),
640 $ ldt, one, one, work( j+(iv-1)*n ), n,
641 $ wr, wi, x, 2, scale, xnorm, ierr )
642*
643* Scale X(1,1) and X(1,2) to avoid overflow when
644* updating the right-hand side.
645*
646 IF( xnorm.GT.one ) THEN
647 IF( work( j ).GT.bignum / xnorm ) THEN
648 x( 1, 1 ) = x( 1, 1 ) / xnorm
649 x( 1, 2 ) = x( 1, 2 ) / xnorm
650 scale = scale / xnorm
651 END IF
652 END IF
653*
654* Scale if necessary
655*
656 IF( scale.NE.one ) THEN
657 CALL sscal( ki, scale, work( 1+(iv-1)*n ), 1 )
658 CALL sscal( ki, scale, work( 1+(iv )*n ), 1 )
659 END IF
660 work( j+(iv-1)*n ) = x( 1, 1 )
661 work( j+(iv )*n ) = x( 1, 2 )
662*
663* Update the right-hand side
664*
665 CALL saxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,
666 $ work( 1+(iv-1)*n ), 1 )
667 CALL saxpy( j-1, -x( 1, 2 ), t( 1, j ), 1,
668 $ work( 1+(iv )*n ), 1 )
669*
670 ELSE
671*
672* 2-by-2 diagonal block
673*
674 CALL slaln2( .false., 2, 2, smin, one,
675 $ t( j-1, j-1 ), ldt, one, one,
676 $ work( j-1+(iv-1)*n ), n, wr, wi, x, 2,
677 $ scale, xnorm, ierr )
678*
679* Scale X to avoid overflow when updating
680* the right-hand side.
681*
682 IF( xnorm.GT.one ) THEN
683 beta = max( work( j-1 ), work( j ) )
684 IF( beta.GT.bignum / xnorm ) THEN
685 rec = one / xnorm
686 x( 1, 1 ) = x( 1, 1 )*rec
687 x( 1, 2 ) = x( 1, 2 )*rec
688 x( 2, 1 ) = x( 2, 1 )*rec
689 x( 2, 2 ) = x( 2, 2 )*rec
690 scale = scale*rec
691 END IF
692 END IF
693*
694* Scale if necessary
695*
696 IF( scale.NE.one ) THEN
697 CALL sscal( ki, scale, work( 1+(iv-1)*n ), 1 )
698 CALL sscal( ki, scale, work( 1+(iv )*n ), 1 )
699 END IF
700 work( j-1+(iv-1)*n ) = x( 1, 1 )
701 work( j +(iv-1)*n ) = x( 2, 1 )
702 work( j-1+(iv )*n ) = x( 1, 2 )
703 work( j +(iv )*n ) = x( 2, 2 )
704*
705* Update the right-hand side
706*
707 CALL saxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,
708 $ work( 1+(iv-1)*n ), 1 )
709 CALL saxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,
710 $ work( 1+(iv-1)*n ), 1 )
711 CALL saxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,
712 $ work( 1+(iv )*n ), 1 )
713 CALL saxpy( j-2, -x( 2, 2 ), t( 1, j ), 1,
714 $ work( 1+(iv )*n ), 1 )
715 END IF
716 90 CONTINUE
717*
718* Copy the vector x or Q*x to VR and normalize.
719*
720 IF( .NOT.over ) THEN
721* ------------------------------
722* no back-transform: copy x to VR and normalize.
723 CALL scopy( ki, work( 1+(iv-1)*n ), 1, vr(1,is-1), 1 )
724 CALL scopy( ki, work( 1+(iv )*n ), 1, vr(1,is ), 1 )
725*
726 emax = zero
727 DO 100 k = 1, ki
728 emax = max( emax, abs( vr( k, is-1 ) )+
729 $ abs( vr( k, is ) ) )
730 100 CONTINUE
731 remax = one / emax
732 CALL sscal( ki, remax, vr( 1, is-1 ), 1 )
733 CALL sscal( ki, remax, vr( 1, is ), 1 )
734*
735 DO 110 k = ki + 1, n
736 vr( k, is-1 ) = zero
737 vr( k, is ) = zero
738 110 CONTINUE
739*
740 ELSE IF( nb.EQ.1 ) THEN
741* ------------------------------
742* version 1: back-transform each vector with GEMV, Q*x.
743 IF( ki.GT.2 ) THEN
744 CALL sgemv( 'N', n, ki-2, one, vr, ldvr,
745 $ work( 1 + (iv-1)*n ), 1,
746 $ work( ki-1 + (iv-1)*n ), vr(1,ki-1), 1)
747 CALL sgemv( 'N', n, ki-2, one, vr, ldvr,
748 $ work( 1 + (iv)*n ), 1,
749 $ work( ki + (iv)*n ), vr( 1, ki ), 1 )
750 ELSE
751 CALL sscal( n, work(ki-1+(iv-1)*n), vr(1,ki-1), 1)
752 CALL sscal( n, work(ki +(iv )*n), vr(1,ki ), 1)
753 END IF
754*
755 emax = zero
756 DO 120 k = 1, n
757 emax = max( emax, abs( vr( k, ki-1 ) )+
758 $ abs( vr( k, ki ) ) )
759 120 CONTINUE
760 remax = one / emax
761 CALL sscal( n, remax, vr( 1, ki-1 ), 1 )
762 CALL sscal( n, remax, vr( 1, ki ), 1 )
763*
764 ELSE
765* ------------------------------
766* version 2: back-transform block of vectors with GEMM
767* zero out below vector
768 DO k = ki + 1, n
769 work( k + (iv-1)*n ) = zero
770 work( k + (iv )*n ) = zero
771 END DO
772 iscomplex( iv-1 ) = -ip
773 iscomplex( iv ) = ip
774 iv = iv - 1
775* back-transform and normalization is done below
776 END IF
777 END IF
778
779 IF( nb.GT.1 ) THEN
780* --------------------------------------------------------
781* Blocked version of back-transform
782* For complex case, KI2 includes both vectors (KI-1 and KI)
783 IF( ip.EQ.0 ) THEN
784 ki2 = ki
785 ELSE
786 ki2 = ki - 1
787 END IF
788
789* Columns IV:NB of work are valid vectors.
790* When the number of vectors stored reaches NB-1 or NB,
791* or if this was last vector, do the GEMM
792 IF( (iv.LE.2) .OR. (ki2.EQ.1) ) THEN
793 CALL sgemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,
794 $ vr, ldvr,
795 $ work( 1 + (iv)*n ), n,
796 $ zero,
797 $ work( 1 + (nb+iv)*n ), n )
798* normalize vectors
799 DO k = iv, nb
800 IF( iscomplex(k).EQ.0 ) THEN
801* real eigenvector
802 ii = isamax( n, work( 1 + (nb+k)*n ), 1 )
803 remax = one / abs( work( ii + (nb+k)*n ) )
804 ELSE IF( iscomplex(k).EQ.1 ) THEN
805* first eigenvector of conjugate pair
806 emax = zero
807 DO ii = 1, n
808 emax = max( emax,
809 $ abs( work( ii + (nb+k )*n ) )+
810 $ abs( work( ii + (nb+k+1)*n ) ) )
811 END DO
812 remax = one / emax
813* else if ISCOMPLEX(K).EQ.-1
814* second eigenvector of conjugate pair
815* reuse same REMAX as previous K
816 END IF
817 CALL sscal( n, remax, work( 1 + (nb+k)*n ), 1 )
818 END DO
819 CALL slacpy( 'F', n, nb-iv+1,
820 $ work( 1 + (nb+iv)*n ), n,
821 $ vr( 1, ki2 ), ldvr )
822 iv = nb
823 ELSE
824 iv = iv - 1
825 END IF
826 END IF ! blocked back-transform
827*
828 is = is - 1
829 IF( ip.NE.0 )
830 $ is = is - 1
831 140 CONTINUE
832 END IF
833
834 IF( leftv ) THEN
835*
836* ============================================================
837* Compute left eigenvectors.
838*
839* IV is index of column in current block.
840* For complex left vector, uses IV for real part and IV+1 for complex part.
841* Non-blocked version always uses IV=1;
842* blocked version starts with IV=1, goes up to NB-1 or NB.
843* (Note the "0-th" column is used for 1-norms computed above.)
844 iv = 1
845 ip = 0
846 is = 1
847 DO 260 ki = 1, n
848 IF( ip.EQ.1 ) THEN
849* previous iteration (ki-1) was first of conjugate pair,
850* so this ki is second of conjugate pair; skip to end of loop
851 ip = -1
852 GO TO 260
853 ELSE IF( ki.EQ.n ) THEN
854* last column, so this ki must be real eigenvalue
855 ip = 0
856 ELSE IF( t( ki+1, ki ).EQ.zero ) THEN
857* zero on sub-diagonal, so this ki is real eigenvalue
858 ip = 0
859 ELSE
860* non-zero on sub-diagonal, so this ki is first of conjugate pair
861 ip = 1
862 END IF
863*
864 IF( somev ) THEN
865 IF( .NOT.SELECT( ki ) )
866 $ GO TO 260
867 END IF
868*
869* Compute the KI-th eigenvalue (WR,WI).
870*
871 wr = t( ki, ki )
872 wi = zero
873 IF( ip.NE.0 )
874 $ wi = sqrt( abs( t( ki, ki+1 ) ) )*
875 $ sqrt( abs( t( ki+1, ki ) ) )
876 smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum )
877*
878 IF( ip.EQ.0 ) THEN
879*
880* --------------------------------------------------------
881* Real left eigenvector
882*
883 work( ki + iv*n ) = one
884*
885* Form right-hand side.
886*
887 DO 160 k = ki + 1, n
888 work( k + iv*n ) = -t( ki, k )
889 160 CONTINUE
890*
891* Solve transposed quasi-triangular system:
892* [ T(KI+1:N,KI+1:N) - WR ]**T * X = SCALE*WORK
893*
894 vmax = one
895 vcrit = bignum
896*
897 jnxt = ki + 1
898 DO 170 j = ki + 1, n
899 IF( j.LT.jnxt )
900 $ GO TO 170
901 j1 = j
902 j2 = j
903 jnxt = j + 1
904 IF( j.LT.n ) THEN
905 IF( t( j+1, j ).NE.zero ) THEN
906 j2 = j + 1
907 jnxt = j + 2
908 END IF
909 END IF
910*
911 IF( j1.EQ.j2 ) THEN
912*
913* 1-by-1 diagonal block
914*
915* Scale if necessary to avoid overflow when forming
916* the right-hand side.
917*
918 IF( work( j ).GT.vcrit ) THEN
919 rec = one / vmax
920 CALL sscal( n-ki+1, rec, work( ki+iv*n ), 1 )
921 vmax = one
922 vcrit = bignum
923 END IF
924*
925 work( j+iv*n ) = work( j+iv*n ) -
926 $ sdot( j-ki-1, t( ki+1, j ), 1,
927 $ work( ki+1+iv*n ), 1 )
928*
929* Solve [ T(J,J) - WR ]**T * X = WORK
930*
931 CALL slaln2( .false., 1, 1, smin, one, t( j, j ),
932 $ ldt, one, one, work( j+iv*n ), n, wr,
933 $ zero, x, 2, scale, xnorm, ierr )
934*
935* Scale if necessary
936*
937 IF( scale.NE.one )
938 $ CALL sscal( n-ki+1, scale, work( ki+iv*n ), 1 )
939 work( j+iv*n ) = x( 1, 1 )
940 vmax = max( abs( work( j+iv*n ) ), vmax )
941 vcrit = bignum / vmax
942*
943 ELSE
944*
945* 2-by-2 diagonal block
946*
947* Scale if necessary to avoid overflow when forming
948* the right-hand side.
949*
950 beta = max( work( j ), work( j+1 ) )
951 IF( beta.GT.vcrit ) THEN
952 rec = one / vmax
953 CALL sscal( n-ki+1, rec, work( ki+iv*n ), 1 )
954 vmax = one
955 vcrit = bignum
956 END IF
957*
958 work( j+iv*n ) = work( j+iv*n ) -
959 $ sdot( j-ki-1, t( ki+1, j ), 1,
960 $ work( ki+1+iv*n ), 1 )
961*
962 work( j+1+iv*n ) = work( j+1+iv*n ) -
963 $ sdot( j-ki-1, t( ki+1, j+1 ), 1,
964 $ work( ki+1+iv*n ), 1 )
965*
966* Solve
967* [ T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 )
968* [ T(J+1,J) T(J+1,J+1)-WR ] ( WORK2 )
969*
970 CALL slaln2( .true., 2, 1, smin, one, t( j, j ),
971 $ ldt, one, one, work( j+iv*n ), n, wr,
972 $ zero, x, 2, scale, xnorm, ierr )
973*
974* Scale if necessary
975*
976 IF( scale.NE.one )
977 $ CALL sscal( n-ki+1, scale, work( ki+iv*n ), 1 )
978 work( j +iv*n ) = x( 1, 1 )
979 work( j+1+iv*n ) = x( 2, 1 )
980*
981 vmax = max( abs( work( j +iv*n ) ),
982 $ abs( work( j+1+iv*n ) ), vmax )
983 vcrit = bignum / vmax
984*
985 END IF
986 170 CONTINUE
987*
988* Copy the vector x or Q*x to VL and normalize.
989*
990 IF( .NOT.over ) THEN
991* ------------------------------
992* no back-transform: copy x to VL and normalize.
993 CALL scopy( n-ki+1, work( ki + iv*n ), 1,
994 $ vl( ki, is ), 1 )
995*
996 ii = isamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
997 remax = one / abs( vl( ii, is ) )
998 CALL sscal( n-ki+1, remax, vl( ki, is ), 1 )
999*
1000 DO 180 k = 1, ki - 1
1001 vl( k, is ) = zero
1002 180 CONTINUE
1003*
1004 ELSE IF( nb.EQ.1 ) THEN
1005* ------------------------------
1006* version 1: back-transform each vector with GEMV, Q*x.
1007 IF( ki.LT.n )
1008 $ CALL sgemv( 'N', n, n-ki, one,
1009 $ vl( 1, ki+1 ), ldvl,
1010 $ work( ki+1 + iv*n ), 1,
1011 $ work( ki + iv*n ), vl( 1, ki ), 1 )
1012*
1013 ii = isamax( n, vl( 1, ki ), 1 )
1014 remax = one / abs( vl( ii, ki ) )
1015 CALL sscal( n, remax, vl( 1, ki ), 1 )
1016*
1017 ELSE
1018* ------------------------------
1019* version 2: back-transform block of vectors with GEMM
1020* zero out above vector
1021* could go from KI-NV+1 to KI-1
1022 DO k = 1, ki - 1
1023 work( k + iv*n ) = zero
1024 END DO
1025 iscomplex( iv ) = ip
1026* back-transform and normalization is done below
1027 END IF
1028 ELSE
1029*
1030* --------------------------------------------------------
1031* Complex left eigenvector.
1032*
1033* Initial solve:
1034* [ ( T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI) ]*X = 0.
1035* [ ( T(KI+1,KI) T(KI+1,KI+1) ) ]
1036*
1037 IF( abs( t( ki, ki+1 ) ).GE.abs( t( ki+1, ki ) ) ) THEN
1038 work( ki + (iv )*n ) = wi / t( ki, ki+1 )
1039 work( ki+1 + (iv+1)*n ) = one
1040 ELSE
1041 work( ki + (iv )*n ) = one
1042 work( ki+1 + (iv+1)*n ) = -wi / t( ki+1, ki )
1043 END IF
1044 work( ki+1 + (iv )*n ) = zero
1045 work( ki + (iv+1)*n ) = zero
1046*
1047* Form right-hand side.
1048*
1049 DO 190 k = ki + 2, n
1050 work( k+(iv )*n ) = -work( ki +(iv )*n )*t(ki, k)
1051 work( k+(iv+1)*n ) = -work( ki+1+(iv+1)*n )*t(ki+1,k)
1052 190 CONTINUE
1053*
1054* Solve transposed quasi-triangular system:
1055* [ T(KI+2:N,KI+2:N)**T - (WR-i*WI) ]*X = WORK1+i*WORK2
1056*
1057 vmax = one
1058 vcrit = bignum
1059*
1060 jnxt = ki + 2
1061 DO 200 j = ki + 2, n
1062 IF( j.LT.jnxt )
1063 $ GO TO 200
1064 j1 = j
1065 j2 = j
1066 jnxt = j + 1
1067 IF( j.LT.n ) THEN
1068 IF( t( j+1, j ).NE.zero ) THEN
1069 j2 = j + 1
1070 jnxt = j + 2
1071 END IF
1072 END IF
1073*
1074 IF( j1.EQ.j2 ) THEN
1075*
1076* 1-by-1 diagonal block
1077*
1078* Scale if necessary to avoid overflow when
1079* forming the right-hand side elements.
1080*
1081 IF( work( j ).GT.vcrit ) THEN
1082 rec = one / vmax
1083 CALL sscal( n-ki+1, rec, work(ki+(iv )*n), 1 )
1084 CALL sscal( n-ki+1, rec, work(ki+(iv+1)*n), 1 )
1085 vmax = one
1086 vcrit = bignum
1087 END IF
1088*
1089 work( j+(iv )*n ) = work( j+(iv)*n ) -
1090 $ sdot( j-ki-2, t( ki+2, j ), 1,
1091 $ work( ki+2+(iv)*n ), 1 )
1092 work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -
1093 $ sdot( j-ki-2, t( ki+2, j ), 1,
1094 $ work( ki+2+(iv+1)*n ), 1 )
1095*
1096* Solve [ T(J,J)-(WR-i*WI) ]*(X11+i*X12)= WK+I*WK2
1097*
1098 CALL slaln2( .false., 1, 2, smin, one, t( j, j ),
1099 $ ldt, one, one, work( j+iv*n ), n, wr,
1100 $ -wi, x, 2, scale, xnorm, ierr )
1101*
1102* Scale if necessary
1103*
1104 IF( scale.NE.one ) THEN
1105 CALL sscal( n-ki+1, scale, work(ki+(iv )*n), 1)
1106 CALL sscal( n-ki+1, scale, work(ki+(iv+1)*n), 1)
1107 END IF
1108 work( j+(iv )*n ) = x( 1, 1 )
1109 work( j+(iv+1)*n ) = x( 1, 2 )
1110 vmax = max( abs( work( j+(iv )*n ) ),
1111 $ abs( work( j+(iv+1)*n ) ), vmax )
1112 vcrit = bignum / vmax
1113*
1114 ELSE
1115*
1116* 2-by-2 diagonal block
1117*
1118* Scale if necessary to avoid overflow when forming
1119* the right-hand side elements.
1120*
1121 beta = max( work( j ), work( j+1 ) )
1122 IF( beta.GT.vcrit ) THEN
1123 rec = one / vmax
1124 CALL sscal( n-ki+1, rec, work(ki+(iv )*n), 1 )
1125 CALL sscal( n-ki+1, rec, work(ki+(iv+1)*n), 1 )
1126 vmax = one
1127 vcrit = bignum
1128 END IF
1129*
1130 work( j +(iv )*n ) = work( j+(iv)*n ) -
1131 $ sdot( j-ki-2, t( ki+2, j ), 1,
1132 $ work( ki+2+(iv)*n ), 1 )
1133*
1134 work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -
1135 $ sdot( j-ki-2, t( ki+2, j ), 1,
1136 $ work( ki+2+(iv+1)*n ), 1 )
1137*
1138 work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -
1139 $ sdot( j-ki-2, t( ki+2, j+1 ), 1,
1140 $ work( ki+2+(iv)*n ), 1 )
1141*
1142 work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -
1143 $ sdot( j-ki-2, t( ki+2, j+1 ), 1,
1144 $ work( ki+2+(iv+1)*n ), 1 )
1145*
1146* Solve 2-by-2 complex linear equation
1147* [ (T(j,j) T(j,j+1) )**T - (wr-i*wi)*I ]*X = SCALE*B
1148* [ (T(j+1,j) T(j+1,j+1)) ]
1149*
1150 CALL slaln2( .true., 2, 2, smin, one, t( j, j ),
1151 $ ldt, one, one, work( j+iv*n ), n, wr,
1152 $ -wi, x, 2, scale, xnorm, ierr )
1153*
1154* Scale if necessary
1155*
1156 IF( scale.NE.one ) THEN
1157 CALL sscal( n-ki+1, scale, work(ki+(iv )*n), 1)
1158 CALL sscal( n-ki+1, scale, work(ki+(iv+1)*n), 1)
1159 END IF
1160 work( j +(iv )*n ) = x( 1, 1 )
1161 work( j +(iv+1)*n ) = x( 1, 2 )
1162 work( j+1+(iv )*n ) = x( 2, 1 )
1163 work( j+1+(iv+1)*n ) = x( 2, 2 )
1164 vmax = max( abs( x( 1, 1 ) ), abs( x( 1, 2 ) ),
1165 $ abs( x( 2, 1 ) ), abs( x( 2, 2 ) ),
1166 $ vmax )
1167 vcrit = bignum / vmax
1168*
1169 END IF
1170 200 CONTINUE
1171*
1172* Copy the vector x or Q*x to VL and normalize.
1173*
1174 IF( .NOT.over ) THEN
1175* ------------------------------
1176* no back-transform: copy x to VL and normalize.
1177 CALL scopy( n-ki+1, work( ki + (iv )*n ), 1,
1178 $ vl( ki, is ), 1 )
1179 CALL scopy( n-ki+1, work( ki + (iv+1)*n ), 1,
1180 $ vl( ki, is+1 ), 1 )
1181*
1182 emax = zero
1183 DO 220 k = ki, n
1184 emax = max( emax, abs( vl( k, is ) )+
1185 $ abs( vl( k, is+1 ) ) )
1186 220 CONTINUE
1187 remax = one / emax
1188 CALL sscal( n-ki+1, remax, vl( ki, is ), 1 )
1189 CALL sscal( n-ki+1, remax, vl( ki, is+1 ), 1 )
1190*
1191 DO 230 k = 1, ki - 1
1192 vl( k, is ) = zero
1193 vl( k, is+1 ) = zero
1194 230 CONTINUE
1195*
1196 ELSE IF( nb.EQ.1 ) THEN
1197* ------------------------------
1198* version 1: back-transform each vector with GEMV, Q*x.
1199 IF( ki.LT.n-1 ) THEN
1200 CALL sgemv( 'N', n, n-ki-1, one,
1201 $ vl( 1, ki+2 ), ldvl,
1202 $ work( ki+2 + (iv)*n ), 1,
1203 $ work( ki + (iv)*n ),
1204 $ vl( 1, ki ), 1 )
1205 CALL sgemv( 'N', n, n-ki-1, one,
1206 $ vl( 1, ki+2 ), ldvl,
1207 $ work( ki+2 + (iv+1)*n ), 1,
1208 $ work( ki+1 + (iv+1)*n ),
1209 $ vl( 1, ki+1 ), 1 )
1210 ELSE
1211 CALL sscal( n, work(ki+ (iv )*n), vl(1, ki ), 1)
1212 CALL sscal( n, work(ki+1+(iv+1)*n), vl(1, ki+1), 1)
1213 END IF
1214*
1215 emax = zero
1216 DO 240 k = 1, n
1217 emax = max( emax, abs( vl( k, ki ) )+
1218 $ abs( vl( k, ki+1 ) ) )
1219 240 CONTINUE
1220 remax = one / emax
1221 CALL sscal( n, remax, vl( 1, ki ), 1 )
1222 CALL sscal( n, remax, vl( 1, ki+1 ), 1 )
1223*
1224 ELSE
1225* ------------------------------
1226* version 2: back-transform block of vectors with GEMM
1227* zero out above vector
1228* could go from KI-NV+1 to KI-1
1229 DO k = 1, ki - 1
1230 work( k + (iv )*n ) = zero
1231 work( k + (iv+1)*n ) = zero
1232 END DO
1233 iscomplex( iv ) = ip
1234 iscomplex( iv+1 ) = -ip
1235 iv = iv + 1
1236* back-transform and normalization is done below
1237 END IF
1238 END IF
1239
1240 IF( nb.GT.1 ) THEN
1241* --------------------------------------------------------
1242* Blocked version of back-transform
1243* For complex case, KI2 includes both vectors (KI and KI+1)
1244 IF( ip.EQ.0 ) THEN
1245 ki2 = ki
1246 ELSE
1247 ki2 = ki + 1
1248 END IF
1249
1250* Columns 1:IV of work are valid vectors.
1251* When the number of vectors stored reaches NB-1 or NB,
1252* or if this was last vector, do the GEMM
1253 IF( (iv.GE.nb-1) .OR. (ki2.EQ.n) ) THEN
1254 CALL sgemm( 'N', 'N', n, iv, n-ki2+iv, one,
1255 $ vl( 1, ki2-iv+1 ), ldvl,
1256 $ work( ki2-iv+1 + (1)*n ), n,
1257 $ zero,
1258 $ work( 1 + (nb+1)*n ), n )
1259* normalize vectors
1260 DO k = 1, iv
1261 IF( iscomplex(k).EQ.0) THEN
1262* real eigenvector
1263 ii = isamax( n, work( 1 + (nb+k)*n ), 1 )
1264 remax = one / abs( work( ii + (nb+k)*n ) )
1265 ELSE IF( iscomplex(k).EQ.1) THEN
1266* first eigenvector of conjugate pair
1267 emax = zero
1268 DO ii = 1, n
1269 emax = max( emax,
1270 $ abs( work( ii + (nb+k )*n ) )+
1271 $ abs( work( ii + (nb+k+1)*n ) ) )
1272 END DO
1273 remax = one / emax
1274* else if ISCOMPLEX(K).EQ.-1
1275* second eigenvector of conjugate pair
1276* reuse same REMAX as previous K
1277 END IF
1278 CALL sscal( n, remax, work( 1 + (nb+k)*n ), 1 )
1279 END DO
1280 CALL slacpy( 'F', n, iv,
1281 $ work( 1 + (nb+1)*n ), n,
1282 $ vl( 1, ki2-iv+1 ), ldvl )
1283 iv = 1
1284 ELSE
1285 iv = iv + 1
1286 END IF
1287 END IF ! blocked back-transform
1288*
1289 is = is + 1
1290 IF( ip.NE.0 )
1291 $ is = is + 1
1292 260 CONTINUE
1293 END IF
1294*
1295 RETURN
1296*
1297* End of STREVC3
1298*

◆ strexc()

subroutine strexc ( character compq,
integer n,
real, dimension( ldt, * ) t,
integer ldt,
real, dimension( ldq, * ) q,
integer ldq,
integer ifst,
integer ilst,
real, dimension( * ) work,
integer info )

STREXC

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

Purpose:
!>
!> STREXC reorders the real Schur factorization of a real matrix
!> A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
!> moved to row ILST.
!>
!> The real Schur form T is reordered by an orthogonal similarity
!> transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
!> is updated by postmultiplying it with Z.
!>
!> T must be in Schur canonical form (as returned by SHSEQR), that is,
!> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!> 2-by-2 diagonal block has its diagonal elements equal and its
!> off-diagonal elements of opposite sign.
!>
Parameters
[in]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 REAL array, dimension (LDT,N)
!>          On entry, the upper quasi-triangular matrix T, in Schur
!>          Schur canonical form.
!>          On exit, the reordered upper quasi-triangular matrix, again
!>          in Schur canonical form.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in,out]Q
!>          Q is REAL 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
!>          orthogonal 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,out]IFST
!>          IFST is INTEGER
!>
[in,out]ILST
!>          ILST is INTEGER
!>
!>          Specify the reordering of the diagonal blocks of T.
!>          The block with row index IFST is moved to row ILST, by a
!>          sequence of transpositions between adjacent blocks.
!>          On exit, if IFST pointed on entry to the second row of a
!>          2-by-2 block, it is changed to point to the first row; ILST
!>          always points to the first row of the block in its final
!>          position (which may differ from its input value by +1 or -1).
!>          1 <= IFST <= N; 1 <= ILST <= N.
!>
[out]WORK
!>          WORK 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
!>          = 1:  two adjacent blocks were too close to swap (the problem
!>                is very ill-conditioned); T may have been partially
!>                reordered, and ILST points to the first row of the
!>                current position of the block being moved.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 146 of file strexc.f.

148*
149* -- LAPACK computational routine --
150* -- LAPACK is a software package provided by Univ. of Tennessee, --
151* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
152*
153* .. Scalar Arguments ..
154 CHARACTER COMPQ
155 INTEGER IFST, ILST, INFO, LDQ, LDT, N
156* ..
157* .. Array Arguments ..
158 REAL Q( LDQ, * ), T( LDT, * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 REAL ZERO
165 parameter( zero = 0.0e+0 )
166* ..
167* .. Local Scalars ..
168 LOGICAL WANTQ
169 INTEGER HERE, NBF, NBL, NBNEXT
170* ..
171* .. External Functions ..
172 LOGICAL LSAME
173 EXTERNAL lsame
174* ..
175* .. External Subroutines ..
176 EXTERNAL slaexc, xerbla
177* ..
178* .. Intrinsic Functions ..
179 INTRINSIC max
180* ..
181* .. Executable Statements ..
182*
183* Decode and test the input arguments.
184*
185 info = 0
186 wantq = lsame( compq, 'V' )
187 IF( .NOT.wantq .AND. .NOT.lsame( compq, 'N' ) ) THEN
188 info = -1
189 ELSE IF( n.LT.0 ) THEN
190 info = -2
191 ELSE IF( ldt.LT.max( 1, n ) ) THEN
192 info = -4
193 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.max( 1, n ) ) ) THEN
194 info = -6
195 ELSE IF(( ifst.LT.1 .OR. ifst.GT.n ).AND.( n.GT.0 )) THEN
196 info = -7
197 ELSE IF(( ilst.LT.1 .OR. ilst.GT.n ).AND.( n.GT.0 )) THEN
198 info = -8
199 END IF
200 IF( info.NE.0 ) THEN
201 CALL xerbla( 'STREXC', -info )
202 RETURN
203 END IF
204*
205* Quick return if possible
206*
207 IF( n.LE.1 )
208 $ RETURN
209*
210* Determine the first row of specified block
211* and find out it is 1 by 1 or 2 by 2.
212*
213 IF( ifst.GT.1 ) THEN
214 IF( t( ifst, ifst-1 ).NE.zero )
215 $ ifst = ifst - 1
216 END IF
217 nbf = 1
218 IF( ifst.LT.n ) THEN
219 IF( t( ifst+1, ifst ).NE.zero )
220 $ nbf = 2
221 END IF
222*
223* Determine the first row of the final block
224* and find out it is 1 by 1 or 2 by 2.
225*
226 IF( ilst.GT.1 ) THEN
227 IF( t( ilst, ilst-1 ).NE.zero )
228 $ ilst = ilst - 1
229 END IF
230 nbl = 1
231 IF( ilst.LT.n ) THEN
232 IF( t( ilst+1, ilst ).NE.zero )
233 $ nbl = 2
234 END IF
235*
236 IF( ifst.EQ.ilst )
237 $ RETURN
238*
239 IF( ifst.LT.ilst ) THEN
240*
241* Update ILST
242*
243 IF( nbf.EQ.2 .AND. nbl.EQ.1 )
244 $ ilst = ilst - 1
245 IF( nbf.EQ.1 .AND. nbl.EQ.2 )
246 $ ilst = ilst + 1
247*
248 here = ifst
249*
250 10 CONTINUE
251*
252* Swap block with next one below
253*
254 IF( nbf.EQ.1 .OR. nbf.EQ.2 ) THEN
255*
256* Current block either 1 by 1 or 2 by 2
257*
258 nbnext = 1
259 IF( here+nbf+1.LE.n ) THEN
260 IF( t( here+nbf+1, here+nbf ).NE.zero )
261 $ nbnext = 2
262 END IF
263 CALL slaexc( wantq, n, t, ldt, q, ldq, here, nbf, nbnext,
264 $ work, info )
265 IF( info.NE.0 ) THEN
266 ilst = here
267 RETURN
268 END IF
269 here = here + nbnext
270*
271* Test if 2 by 2 block breaks into two 1 by 1 blocks
272*
273 IF( nbf.EQ.2 ) THEN
274 IF( t( here+1, here ).EQ.zero )
275 $ nbf = 3
276 END IF
277*
278 ELSE
279*
280* Current block consists of two 1 by 1 blocks each of which
281* must be swapped individually
282*
283 nbnext = 1
284 IF( here+3.LE.n ) THEN
285 IF( t( here+3, here+2 ).NE.zero )
286 $ nbnext = 2
287 END IF
288 CALL slaexc( wantq, n, t, ldt, q, ldq, here+1, 1, nbnext,
289 $ work, info )
290 IF( info.NE.0 ) THEN
291 ilst = here
292 RETURN
293 END IF
294 IF( nbnext.EQ.1 ) THEN
295*
296* Swap two 1 by 1 blocks, no problems possible
297*
298 CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1, nbnext,
299 $ work, info )
300 here = here + 1
301 ELSE
302*
303* Recompute NBNEXT in case 2 by 2 split
304*
305 IF( t( here+2, here+1 ).EQ.zero )
306 $ nbnext = 1
307 IF( nbnext.EQ.2 ) THEN
308*
309* 2 by 2 Block did not split
310*
311 CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1,
312 $ nbnext, work, info )
313 IF( info.NE.0 ) THEN
314 ilst = here
315 RETURN
316 END IF
317 here = here + 2
318 ELSE
319*
320* 2 by 2 Block did split
321*
322 CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1, 1,
323 $ work, info )
324 CALL slaexc( wantq, n, t, ldt, q, ldq, here+1, 1, 1,
325 $ work, info )
326 here = here + 2
327 END IF
328 END IF
329 END IF
330 IF( here.LT.ilst )
331 $ GO TO 10
332*
333 ELSE
334*
335 here = ifst
336 20 CONTINUE
337*
338* Swap block with next one above
339*
340 IF( nbf.EQ.1 .OR. nbf.EQ.2 ) THEN
341*
342* Current block either 1 by 1 or 2 by 2
343*
344 nbnext = 1
345 IF( here.GE.3 ) THEN
346 IF( t( here-1, here-2 ).NE.zero )
347 $ nbnext = 2
348 END IF
349 CALL slaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,
350 $ nbf, work, info )
351 IF( info.NE.0 ) THEN
352 ilst = here
353 RETURN
354 END IF
355 here = here - nbnext
356*
357* Test if 2 by 2 block breaks into two 1 by 1 blocks
358*
359 IF( nbf.EQ.2 ) THEN
360 IF( t( here+1, here ).EQ.zero )
361 $ nbf = 3
362 END IF
363*
364 ELSE
365*
366* Current block consists of two 1 by 1 blocks each of which
367* must be swapped individually
368*
369 nbnext = 1
370 IF( here.GE.3 ) THEN
371 IF( t( here-1, here-2 ).NE.zero )
372 $ nbnext = 2
373 END IF
374 CALL slaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,
375 $ 1, work, info )
376 IF( info.NE.0 ) THEN
377 ilst = here
378 RETURN
379 END IF
380 IF( nbnext.EQ.1 ) THEN
381*
382* Swap two 1 by 1 blocks, no problems possible
383*
384 CALL slaexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1,
385 $ work, info )
386 here = here - 1
387 ELSE
388*
389* Recompute NBNEXT in case 2 by 2 split
390*
391 IF( t( here, here-1 ).EQ.zero )
392 $ nbnext = 1
393 IF( nbnext.EQ.2 ) THEN
394*
395* 2 by 2 Block did not split
396*
397 CALL slaexc( wantq, n, t, ldt, q, ldq, here-1, 2, 1,
398 $ work, info )
399 IF( info.NE.0 ) THEN
400 ilst = here
401 RETURN
402 END IF
403 here = here - 2
404 ELSE
405*
406* 2 by 2 Block did split
407*
408 CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1, 1,
409 $ work, info )
410 CALL slaexc( wantq, n, t, ldt, q, ldq, here-1, 1, 1,
411 $ work, info )
412 here = here - 2
413 END IF
414 END IF
415 END IF
416 IF( here.GT.ilst )
417 $ GO TO 20
418 END IF
419 ilst = here
420*
421 RETURN
422*
423* End of STREXC
424*
slaexc
subroutine slaexc(wantq, n, t, ldt, q, ldq, j1, n1, n2, work, info)
SLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form...
Definition slaexc.f:138

◆ strrfs()

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

STRRFS

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

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

◆ strsen()

subroutine strsen ( character job,
character compq,
logical, dimension( * ) select,
integer n,
real, dimension( ldt, * ) t,
integer ldt,
real, dimension( ldq, * ) q,
integer ldq,
real, dimension( * ) wr,
real, dimension( * ) wi,
integer m,
real s,
real sep,
real, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer liwork,
integer info )

STRSEN

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

Purpose:
!>
!> STRSEN reorders the real Schur factorization of a real matrix
!> A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
!> the leading diagonal blocks of the upper quasi-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.
!>
!> T must be in Schur canonical form (as returned by SHSEQR), that is,
!> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!> 2-by-2 diagonal block has its diagonal elements equal and its
!> off-diagonal elements of opposite sign.
!>
Parameters
[in]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 a real eigenvalue w(j), SELECT(j) must be set to
!>          .TRUE.. To select a complex conjugate pair of eigenvalues
!>          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
!>          either SELECT(j) or SELECT(j+1) or both must be set to
!>          .TRUE.; a complex conjugate pair of eigenvalues must be
!>          either both included in the cluster or both excluded.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!>
[in,out]T
!>          T is REAL array, dimension (LDT,N)
!>          On entry, the upper quasi-triangular matrix T, in Schur
!>          canonical form.
!>          On exit, T is overwritten by the reordered matrix T, again in
!>          Schur canonical form, with the selected eigenvalues in the
!>          leading diagonal blocks.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in,out]Q
!>          Q is REAL 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
!>          orthogonal 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]WR
!>          WR is REAL array, dimension (N)
!>
[out]WI
!>          WI is REAL array, dimension (N)
!>
!>          The real and imaginary parts, respectively, of the reordered
!>          eigenvalues of T. The eigenvalues are stored in the same
!>          order as on the diagonal of T, with WR(i) = T(i,i) and, if
!>          T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
!>          WI(i+1) = -WI(i). Note that if a complex eigenvalue is
!>          sufficiently ill-conditioned, then its value may differ
!>          significantly from its value before reordering.
!>
[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 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 JOB = 'N', LWORK >= max(1,N);
!>          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]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 JOB = 'N' or 'E', LIWORK >= 1;
!>          if JOB = 'V' or 'B', LIWORK >= max(1,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 T failed because some eigenvalues are too
!>               close to separate (the problem is very ill-conditioned);
!>               T may have been partially reordered, and WR and WI
!>               contain the eigenvalues in the same order as in T; S and
!>               SEP (if requested) are set to zero.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  STRSEN first collects the selected eigenvalues by computing an
!>  orthogonal 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**T * T * Z = ( T11 T12 ) n1
!>                         (  0  T22 ) n2
!>                            n1  n2
!>
!>  where N = n1+n2 and Z**T means the transpose of Z. The first n1 columns
!>  of Z span the specified invariant subspace of T.
!>
!>  If T has been obtained from the real Schur factorization of a matrix
!>  A = Q*T*Q**T, then the reordered real Schur factorization of A is given
!>  by A = (Q*Z)*(Z**T*T*Z)*(Q*Z)**T, 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 312 of file strsen.f.

314*
315* -- LAPACK computational routine --
316* -- LAPACK is a software package provided by Univ. of Tennessee, --
317* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
318*
319* .. Scalar Arguments ..
320 CHARACTER COMPQ, JOB
321 INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N
322 REAL S, SEP
323* ..
324* .. Array Arguments ..
325 LOGICAL SELECT( * )
326 INTEGER IWORK( * )
327 REAL Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ),
328 $ WR( * )
329* ..
330*
331* =====================================================================
332*
333* .. Parameters ..
334 REAL ZERO, ONE
335 parameter( zero = 0.0e+0, one = 1.0e+0 )
336* ..
337* .. Local Scalars ..
338 LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS,
339 $ WANTSP
340 INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2,
341 $ NN
342 REAL EST, RNORM, SCALE
343* ..
344* .. Local Arrays ..
345 INTEGER ISAVE( 3 )
346* ..
347* .. External Functions ..
348 LOGICAL LSAME
349 REAL SLANGE
350 EXTERNAL lsame, slange
351* ..
352* .. External Subroutines ..
353 EXTERNAL slacn2, slacpy, strexc, strsyl, xerbla
354* ..
355* .. Intrinsic Functions ..
356 INTRINSIC abs, max, sqrt
357* ..
358* .. Executable Statements ..
359*
360* Decode and test the input parameters
361*
362 wantbh = lsame( job, 'B' )
363 wants = lsame( job, 'E' ) .OR. wantbh
364 wantsp = lsame( job, 'V' ) .OR. wantbh
365 wantq = lsame( compq, 'V' )
366*
367 info = 0
368 lquery = ( lwork.EQ.-1 )
369 IF( .NOT.lsame( job, 'N' ) .AND. .NOT.wants .AND. .NOT.wantsp )
370 $ THEN
371 info = -1
372 ELSE IF( .NOT.lsame( compq, 'N' ) .AND. .NOT.wantq ) THEN
373 info = -2
374 ELSE IF( n.LT.0 ) THEN
375 info = -4
376 ELSE IF( ldt.LT.max( 1, n ) ) THEN
377 info = -6
378 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) ) THEN
379 info = -8
380 ELSE
381*
382* Set M to the dimension of the specified invariant subspace,
383* and test LWORK and LIWORK.
384*
385 m = 0
386 pair = .false.
387 DO 10 k = 1, n
388 IF( pair ) THEN
389 pair = .false.
390 ELSE
391 IF( k.LT.n ) THEN
392 IF( t( k+1, k ).EQ.zero ) THEN
393 IF( SELECT( k ) )
394 $ m = m + 1
395 ELSE
396 pair = .true.
397 IF( SELECT( k ) .OR. SELECT( k+1 ) )
398 $ m = m + 2
399 END IF
400 ELSE
401 IF( SELECT( n ) )
402 $ m = m + 1
403 END IF
404 END IF
405 10 CONTINUE
406*
407 n1 = m
408 n2 = n - m
409 nn = n1*n2
410*
411 IF( wantsp ) THEN
412 lwmin = max( 1, 2*nn )
413 liwmin = max( 1, nn )
414 ELSE IF( lsame( job, 'N' ) ) THEN
415 lwmin = max( 1, n )
416 liwmin = 1
417 ELSE IF( lsame( job, 'E' ) ) THEN
418 lwmin = max( 1, nn )
419 liwmin = 1
420 END IF
421*
422 IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
423 info = -15
424 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery ) THEN
425 info = -17
426 END IF
427 END IF
428*
429 IF( info.EQ.0 ) THEN
430 work( 1 ) = lwmin
431 iwork( 1 ) = liwmin
432 END IF
433*
434 IF( info.NE.0 ) THEN
435 CALL xerbla( 'STRSEN', -info )
436 RETURN
437 ELSE IF( lquery ) THEN
438 RETURN
439 END IF
440*
441* Quick return if possible.
442*
443 IF( m.EQ.n .OR. m.EQ.0 ) THEN
444 IF( wants )
445 $ s = one
446 IF( wantsp )
447 $ sep = slange( '1', n, n, t, ldt, work )
448 GO TO 40
449 END IF
450*
451* Collect the selected blocks at the top-left corner of T.
452*
453 ks = 0
454 pair = .false.
455 DO 20 k = 1, n
456 IF( pair ) THEN
457 pair = .false.
458 ELSE
459 swap = SELECT( k )
460 IF( k.LT.n ) THEN
461 IF( t( k+1, k ).NE.zero ) THEN
462 pair = .true.
463 swap = swap .OR. SELECT( k+1 )
464 END IF
465 END IF
466 IF( swap ) THEN
467 ks = ks + 1
468*
469* Swap the K-th block to position KS.
470*
471 ierr = 0
472 kk = k
473 IF( k.NE.ks )
474 $ CALL strexc( compq, n, t, ldt, q, ldq, kk, ks, work,
475 $ ierr )
476 IF( ierr.EQ.1 .OR. ierr.EQ.2 ) THEN
477*
478* Blocks too close to swap: exit.
479*
480 info = 1
481 IF( wants )
482 $ s = zero
483 IF( wantsp )
484 $ sep = zero
485 GO TO 40
486 END IF
487 IF( pair )
488 $ ks = ks + 1
489 END IF
490 END IF
491 20 CONTINUE
492*
493 IF( wants ) THEN
494*
495* Solve Sylvester equation for R:
496*
497* T11*R - R*T22 = scale*T12
498*
499 CALL slacpy( 'F', n1, n2, t( 1, n1+1 ), ldt, work, n1 )
500 CALL strsyl( 'N', 'N', -1, n1, n2, t, ldt, t( n1+1, n1+1 ),
501 $ ldt, work, n1, scale, ierr )
502*
503* Estimate the reciprocal of the condition number of the cluster
504* of eigenvalues.
505*
506 rnorm = slange( 'F', n1, n2, work, n1, work )
507 IF( rnorm.EQ.zero ) THEN
508 s = one
509 ELSE
510 s = scale / ( sqrt( scale*scale / rnorm+rnorm )*
511 $ sqrt( rnorm ) )
512 END IF
513 END IF
514*
515 IF( wantsp ) THEN
516*
517* Estimate sep(T11,T22).
518*
519 est = zero
520 kase = 0
521 30 CONTINUE
522 CALL slacn2( nn, work( nn+1 ), work, iwork, est, kase, isave )
523 IF( kase.NE.0 ) THEN
524 IF( kase.EQ.1 ) THEN
525*
526* Solve T11*R - R*T22 = scale*X.
527*
528 CALL strsyl( 'N', 'N', -1, n1, n2, t, ldt,
529 $ t( n1+1, n1+1 ), ldt, work, n1, scale,
530 $ ierr )
531 ELSE
532*
533* Solve T11**T*R - R*T22**T = scale*X.
534*
535 CALL strsyl( 'T', 'T', -1, n1, n2, t, ldt,
536 $ t( n1+1, n1+1 ), ldt, work, n1, scale,
537 $ ierr )
538 END IF
539 GO TO 30
540 END IF
541*
542 sep = scale / est
543 END IF
544*
545 40 CONTINUE
546*
547* Store the output eigenvalues in WR and WI.
548*
549 DO 50 k = 1, n
550 wr( k ) = t( k, k )
551 wi( k ) = zero
552 50 CONTINUE
553 DO 60 k = 1, n - 1
554 IF( t( k+1, k ).NE.zero ) THEN
555 wi( k ) = sqrt( abs( t( k, k+1 ) ) )*
556 $ sqrt( abs( t( k+1, k ) ) )
557 wi( k+1 ) = -wi( k )
558 END IF
559 60 CONTINUE
560*
561 work( 1 ) = lwmin
562 iwork( 1 ) = liwmin
563*
564 RETURN
565*
566* End of STRSEN
567*
slange
real function slange(norm, m, n, a, lda, work)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition slange.f:114
strexc
subroutine strexc(compq, n, t, ldt, q, ldq, ifst, ilst, work, info)
STREXC
Definition strexc.f:148
strsyl
subroutine strsyl(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
STRSYL
Definition strsyl.f:164

◆ strsna()

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

STRSNA

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

Purpose:
!>
!> STRSNA estimates reciprocal condition numbers for specified
!> eigenvalues and/or right eigenvectors of a real upper
!> quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
!> orthogonal).
!>
!> T must be in Schur canonical form (as returned by SHSEQR), that is,
!> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!> 2-by-2 diagonal block has its diagonal elements equal and its
!> off-diagonal elements of opposite sign.
!>
Parameters
[in]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 eigenpair corresponding to a real eigenvalue w(j),
!>          SELECT(j) must be set to .TRUE.. To select condition numbers
!>          corresponding to a complex conjugate pair of eigenvalues w(j)
!>          and w(j+1), either SELECT(j) or SELECT(j+1) or both, 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 REAL array, dimension (LDT,N)
!>          The upper quasi-triangular matrix T, in Schur canonical form.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in]VL
!>          VL is REAL array, dimension (LDVL,M)
!>          If JOB = 'E' or 'B', VL must contain left eigenvectors of T
!>          (or of any Q*T*Q**T with Q orthogonal), corresponding to the
!>          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
!>          must be stored in consecutive columns of VL, as returned by
!>          SHSEIN or STREVC.
!>          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 REAL array, dimension (LDVR,M)
!>          If JOB = 'E' or 'B', VR must contain right eigenvectors of T
!>          (or of any Q*T*Q**T with Q orthogonal), corresponding to the
!>          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
!>          must be stored in consecutive columns of VR, as returned by
!>          SHSEIN or STREVC.
!>          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. For a complex conjugate pair of eigenvalues two
!>          consecutive elements of S are set to the same value. 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. For a complex eigenvector two
!>          consecutive elements of SEP are set to the same value. If
!>          the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
!>          is set to 0; this can only occur when the true value would be
!>          very small anyway.
!>          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 REAL 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]IWORK
!>          IWORK is INTEGER array, dimension (2*(N-1))
!>          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 an eigenvalue lambda is
!>  defined as
!>
!>          S(lambda) = |v**T*u| / (norm(u)*norm(v))
!>
!>  where u and v are the right and left eigenvectors of T corresponding
!>  to lambda; v**T denotes the 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 262 of file strsna.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 HOWMNY, JOB
272 INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
273* ..
274* .. Array Arguments ..
275 LOGICAL SELECT( * )
276 INTEGER IWORK( * )
277 REAL S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
278 $ VR( LDVR, * ), WORK( LDWORK, * )
279* ..
280*
281* =====================================================================
282*
283* .. Parameters ..
284 REAL ZERO, ONE, TWO
285 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0 )
286* ..
287* .. Local Scalars ..
288 LOGICAL PAIR, SOMCON, WANTBH, WANTS, WANTSP
289 INTEGER I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
290 REAL BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM,
291 $ MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN
292* ..
293* .. Local Arrays ..
294 INTEGER ISAVE( 3 )
295 REAL DUMMY( 1 )
296* ..
297* .. External Functions ..
298 LOGICAL LSAME
299 REAL SDOT, SLAMCH, SLAPY2, SNRM2
300 EXTERNAL lsame, sdot, slamch, slapy2, snrm2
301* ..
302* .. External Subroutines ..
303 EXTERNAL slabad, slacn2, slacpy, slaqtr, strexc, xerbla
304* ..
305* .. Intrinsic Functions ..
306 INTRINSIC abs, max, sqrt
307* ..
308* .. Executable Statements ..
309*
310* Decode and test the input parameters
311*
312 wantbh = lsame( job, 'B' )
313 wants = lsame( job, 'E' ) .OR. wantbh
314 wantsp = lsame( job, 'V' ) .OR. wantbh
315*
316 somcon = lsame( howmny, 'S' )
317*
318 info = 0
319 IF( .NOT.wants .AND. .NOT.wantsp ) THEN
320 info = -1
321 ELSE IF( .NOT.lsame( howmny, 'A' ) .AND. .NOT.somcon ) THEN
322 info = -2
323 ELSE IF( n.LT.0 ) THEN
324 info = -4
325 ELSE IF( ldt.LT.max( 1, n ) ) THEN
326 info = -6
327 ELSE IF( ldvl.LT.1 .OR. ( wants .AND. ldvl.LT.n ) ) THEN
328 info = -8
329 ELSE IF( ldvr.LT.1 .OR. ( wants .AND. ldvr.LT.n ) ) THEN
330 info = -10
331 ELSE
332*
333* Set M to the number of eigenpairs for which condition numbers
334* are required, and test MM.
335*
336 IF( somcon ) THEN
337 m = 0
338 pair = .false.
339 DO 10 k = 1, n
340 IF( pair ) THEN
341 pair = .false.
342 ELSE
343 IF( k.LT.n ) THEN
344 IF( t( k+1, k ).EQ.zero ) THEN
345 IF( SELECT( k ) )
346 $ m = m + 1
347 ELSE
348 pair = .true.
349 IF( SELECT( k ) .OR. SELECT( k+1 ) )
350 $ m = m + 2
351 END IF
352 ELSE
353 IF( SELECT( n ) )
354 $ m = m + 1
355 END IF
356 END IF
357 10 CONTINUE
358 ELSE
359 m = n
360 END IF
361*
362 IF( mm.LT.m ) THEN
363 info = -13
364 ELSE IF( ldwork.LT.1 .OR. ( wantsp .AND. ldwork.LT.n ) ) THEN
365 info = -16
366 END IF
367 END IF
368 IF( info.NE.0 ) THEN
369 CALL xerbla( 'STRSNA', -info )
370 RETURN
371 END IF
372*
373* Quick return if possible
374*
375 IF( n.EQ.0 )
376 $ RETURN
377*
378 IF( n.EQ.1 ) THEN
379 IF( somcon ) THEN
380 IF( .NOT.SELECT( 1 ) )
381 $ RETURN
382 END IF
383 IF( wants )
384 $ s( 1 ) = one
385 IF( wantsp )
386 $ sep( 1 ) = abs( t( 1, 1 ) )
387 RETURN
388 END IF
389*
390* Get machine constants
391*
392 eps = slamch( 'P' )
393 smlnum = slamch( 'S' ) / eps
394 bignum = one / smlnum
395 CALL slabad( smlnum, bignum )
396*
397 ks = 0
398 pair = .false.
399 DO 60 k = 1, n
400*
401* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block.
402*
403 IF( pair ) THEN
404 pair = .false.
405 GO TO 60
406 ELSE
407 IF( k.LT.n )
408 $ pair = t( k+1, k ).NE.zero
409 END IF
410*
411* Determine whether condition numbers are required for the k-th
412* eigenpair.
413*
414 IF( somcon ) THEN
415 IF( pair ) THEN
416 IF( .NOT.SELECT( k ) .AND. .NOT.SELECT( k+1 ) )
417 $ GO TO 60
418 ELSE
419 IF( .NOT.SELECT( k ) )
420 $ GO TO 60
421 END IF
422 END IF
423*
424 ks = ks + 1
425*
426 IF( wants ) THEN
427*
428* Compute the reciprocal condition number of the k-th
429* eigenvalue.
430*
431 IF( .NOT.pair ) THEN
432*
433* Real eigenvalue.
434*
435 prod = sdot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
436 rnrm = snrm2( n, vr( 1, ks ), 1 )
437 lnrm = snrm2( n, vl( 1, ks ), 1 )
438 s( ks ) = abs( prod ) / ( rnrm*lnrm )
439 ELSE
440*
441* Complex eigenvalue.
442*
443 prod1 = sdot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
444 prod1 = prod1 + sdot( n, vr( 1, ks+1 ), 1, vl( 1, ks+1 ),
445 $ 1 )
446 prod2 = sdot( n, vl( 1, ks ), 1, vr( 1, ks+1 ), 1 )
447 prod2 = prod2 - sdot( n, vl( 1, ks+1 ), 1, vr( 1, ks ),
448 $ 1 )
449 rnrm = slapy2( snrm2( n, vr( 1, ks ), 1 ),
450 $ snrm2( n, vr( 1, ks+1 ), 1 ) )
451 lnrm = slapy2( snrm2( n, vl( 1, ks ), 1 ),
452 $ snrm2( n, vl( 1, ks+1 ), 1 ) )
453 cond = slapy2( prod1, prod2 ) / ( rnrm*lnrm )
454 s( ks ) = cond
455 s( ks+1 ) = cond
456 END IF
457 END IF
458*
459 IF( wantsp ) THEN
460*
461* Estimate the reciprocal condition number of the k-th
462* eigenvector.
463*
464* Copy the matrix T to the array WORK and swap the diagonal
465* block beginning at T(k,k) to the (1,1) position.
466*
467 CALL slacpy( 'Full', n, n, t, ldt, work, ldwork )
468 ifst = k
469 ilst = 1
470 CALL strexc( 'No Q', n, work, ldwork, dummy, 1, ifst, ilst,
471 $ work( 1, n+1 ), ierr )
472*
473 IF( ierr.EQ.1 .OR. ierr.EQ.2 ) THEN
474*
475* Could not swap because blocks not well separated
476*
477 scale = one
478 est = bignum
479 ELSE
480*
481* Reordering successful
482*
483 IF( work( 2, 1 ).EQ.zero ) THEN
484*
485* Form C = T22 - lambda*I in WORK(2:N,2:N).
486*
487 DO 20 i = 2, n
488 work( i, i ) = work( i, i ) - work( 1, 1 )
489 20 CONTINUE
490 n2 = 1
491 nn = n - 1
492 ELSE
493*
494* Triangularize the 2 by 2 block by unitary
495* transformation U = [ cs i*ss ]
496* [ i*ss cs ].
497* such that the (1,1) position of WORK is complex
498* eigenvalue lambda with positive imaginary part. (2,2)
499* position of WORK is the complex eigenvalue lambda
500* with negative imaginary part.
501*
502 mu = sqrt( abs( work( 1, 2 ) ) )*
503 $ sqrt( abs( work( 2, 1 ) ) )
504 delta = slapy2( mu, work( 2, 1 ) )
505 cs = mu / delta
506 sn = -work( 2, 1 ) / delta
507*
508* Form
509*
510* C**T = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ]
511* [ mu ]
512* [ .. ]
513* [ .. ]
514* [ mu ]
515* where C**T is transpose of matrix C,
516* and RWORK is stored starting in the N+1-st column of
517* WORK.
518*
519 DO 30 j = 3, n
520 work( 2, j ) = cs*work( 2, j )
521 work( j, j ) = work( j, j ) - work( 1, 1 )
522 30 CONTINUE
523 work( 2, 2 ) = zero
524*
525 work( 1, n+1 ) = two*mu
526 DO 40 i = 2, n - 1
527 work( i, n+1 ) = sn*work( 1, i+1 )
528 40 CONTINUE
529 n2 = 2
530 nn = 2*( n-1 )
531 END IF
532*
533* Estimate norm(inv(C**T))
534*
535 est = zero
536 kase = 0
537 50 CONTINUE
538 CALL slacn2( nn, work( 1, n+2 ), work( 1, n+4 ), iwork,
539 $ est, kase, isave )
540 IF( kase.NE.0 ) THEN
541 IF( kase.EQ.1 ) THEN
542 IF( n2.EQ.1 ) THEN
543*
544* Real eigenvalue: solve C**T*x = scale*c.
545*
546 CALL slaqtr( .true., .true., n-1, work( 2, 2 ),
547 $ ldwork, dummy, dumm, scale,
548 $ work( 1, n+4 ), work( 1, n+6 ),
549 $ ierr )
550 ELSE
551*
552* Complex eigenvalue: solve
553* C**T*(p+iq) = scale*(c+id) in real arithmetic.
554*
555 CALL slaqtr( .true., .false., n-1, work( 2, 2 ),
556 $ ldwork, work( 1, n+1 ), mu, scale,
557 $ work( 1, n+4 ), work( 1, n+6 ),
558 $ ierr )
559 END IF
560 ELSE
561 IF( n2.EQ.1 ) THEN
562*
563* Real eigenvalue: solve C*x = scale*c.
564*
565 CALL slaqtr( .false., .true., n-1, work( 2, 2 ),
566 $ ldwork, dummy, dumm, scale,
567 $ work( 1, n+4 ), work( 1, n+6 ),
568 $ ierr )
569 ELSE
570*
571* Complex eigenvalue: solve
572* C*(p+iq) = scale*(c+id) in real arithmetic.
573*
574 CALL slaqtr( .false., .false., n-1,
575 $ work( 2, 2 ), ldwork,
576 $ work( 1, n+1 ), mu, scale,
577 $ work( 1, n+4 ), work( 1, n+6 ),
578 $ ierr )
579*
580 END IF
581 END IF
582*
583 GO TO 50
584 END IF
585 END IF
586*
587 sep( ks ) = scale / max( est, smlnum )
588 IF( pair )
589 $ sep( ks+1 ) = sep( ks )
590 END IF
591*
592 IF( pair )
593 $ ks = ks + 1
594*
595 60 CONTINUE
596 RETURN
597*
598* End of STRSNA
599*
slaqtr
subroutine slaqtr(ltran, lreal, n, t, ldt, b, w, scale, x, work, info)
SLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of sp...
Definition slaqtr.f:165

◆ strti2()

subroutine strti2 ( character uplo,
character diag,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer info )

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

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

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

◆ strtri()

subroutine strtri ( character uplo,
character diag,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer info )

STRTRI

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

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

◆ strtrs()

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

STRTRS

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

Purpose:
!>
!> STRTRS solves a triangular system of the form
!>
!>    A * X = B  or  A**T * 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 = 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 REAL 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 REAL 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 strtrs.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 REAL A( LDA, * ), B( LDB, * )
151* ..
152*
153* =====================================================================
154*
155* .. Parameters ..
156 REAL ZERO, ONE
157 parameter( zero = 0.0e+0, one = 1.0e+0 )
158* ..
159* .. Local Scalars ..
160 LOGICAL NOUNIT
161* ..
162* .. External Functions ..
163 LOGICAL LSAME
164 EXTERNAL lsame
165* ..
166* .. External Subroutines ..
167 EXTERNAL strsm, xerbla
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC max
171* ..
172* .. Executable Statements ..
173*
174* Test the input parameters.
175*
176 info = 0
177 nounit = lsame( diag, 'N' )
178 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
179 info = -1
180 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.
181 $ lsame( trans, 'T' ) .AND. .NOT.lsame( trans, 'C' ) ) THEN
182 info = -2
183 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
184 info = -3
185 ELSE IF( n.LT.0 ) THEN
186 info = -4
187 ELSE IF( nrhs.LT.0 ) THEN
188 info = -5
189 ELSE IF( lda.LT.max( 1, n ) ) THEN
190 info = -7
191 ELSE IF( ldb.LT.max( 1, n ) ) THEN
192 info = -9
193 END IF
194 IF( info.NE.0 ) THEN
195 CALL xerbla( 'STRTRS', -info )
196 RETURN
197 END IF
198*
199* Quick return if possible
200*
201 IF( n.EQ.0 )
202 $ RETURN
203*
204* Check for singularity.
205*
206 IF( nounit ) THEN
207 DO 10 info = 1, n
208 IF( a( info, info ).EQ.zero )
209 $ RETURN
210 10 CONTINUE
211 END IF
212 info = 0
213*
214* Solve A * x = b or A**T * x = b.
215*
216 CALL strsm( 'Left', uplo, trans, diag, n, nrhs, one, a, lda, b,
217 $ ldb )
218*
219 RETURN
220*
221* End of STRTRS
222*

◆ strttf()

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

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

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

Purpose:
!>
!> STRTTF 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 form is wanted;
!>          = 'T':  ARF in Transpose form is wanted.
!>
[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]A
!>          A is REAL 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 REAL array, dimension (NT).
!>          NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.
!>
[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 Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last three columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 then consider Rectangular Full Packed (RFP) 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
!>  the 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
!>  the transpose of the last two columns of AP lower.
!>  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 = 'T'. RFP A in both UPLO cases is just the
!>  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 193 of file strttf.f.

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

◆ strttp()

subroutine strttp ( character uplo,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) ap,
integer info )

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

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

Purpose:
!>
!> STRTTP 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 REAL 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]AP
!>          AP is REAL 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 strttp.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 REAL 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( 'STRTTP', -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 RETURN
169*
170* End of STRTTP
171*

◆ stzrqf()

subroutine stzrqf ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
integer info )

STZRQF

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine STZRZF.
!>
!> STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
!> to upper triangular form by means of orthogonal transformations.
!>
!> The upper trapezoidal matrix A is factored as
!>
!>    A = ( R  0 ) * Z,
!>
!> where Z is an N-by-N orthogonal 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 REAL 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
!>          orthogonal 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 REAL 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 ), 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 )**T,   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 stzrqf.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 REAL A( LDA, * ), TAU( * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ONE, ZERO
154 parameter( one = 1.0e+0, zero = 0.0e+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER I, K, M1
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC max, min
161* ..
162* .. External Subroutines ..
163 EXTERNAL saxpy, scopy, sgemv, sger, slarfg, xerbla
164* ..
165* .. Executable Statements ..
166*
167* Test the input parameters.
168*
169 info = 0
170 IF( m.LT.0 ) THEN
171 info = -1
172 ELSE IF( n.LT.m ) THEN
173 info = -2
174 ELSE IF( lda.LT.max( 1, m ) ) THEN
175 info = -4
176 END IF
177 IF( info.NE.0 ) THEN
178 CALL xerbla( 'STZRQF', -info )
179 RETURN
180 END IF
181*
182* Perform the factorization.
183*
184 IF( m.EQ.0 )
185 $ RETURN
186 IF( m.EQ.n ) THEN
187 DO 10 i = 1, n
188 tau( i ) = zero
189 10 CONTINUE
190 ELSE
191 m1 = min( m+1, n )
192 DO 20 k = m, 1, -1
193*
194* Use a Householder reflection to zero the kth row of A.
195* First set up the reflection.
196*
197 CALL slarfg( n-m+1, a( k, k ), a( k, m1 ), lda, tau( k ) )
198*
199 IF( ( tau( k ).NE.zero ) .AND. ( k.GT.1 ) ) THEN
200*
201* We now perform the operation A := A*P( k ).
202*
203* Use the first ( k - 1 ) elements of TAU to store a( k ),
204* where a( k ) consists of the first ( k - 1 ) elements of
205* the kth column of A. Also let B denote the first
206* ( k - 1 ) rows of the last ( n - m ) columns of A.
207*
208 CALL scopy( k-1, a( 1, k ), 1, tau, 1 )
209*
210* Form w = a( k ) + B*z( k ) in TAU.
211*
212 CALL sgemv( 'No transpose', k-1, n-m, one, a( 1, m1 ),
213 $ lda, a( k, m1 ), lda, one, tau, 1 )
214*
215* Now form a( k ) := a( k ) - tau*w
216* and B := B - tau*w*z( k )**T.
217*
218 CALL saxpy( k-1, -tau( k ), tau, 1, a( 1, k ), 1 )
219 CALL sger( k-1, n-m, -tau( k ), tau, 1, a( k, m1 ), lda,
220 $ a( 1, m1 ), lda )
221 END IF
222 20 CONTINUE
223 END IF
224*
225 RETURN
226*
227* End of STZRQF
228*

◆ stzrzf()

subroutine stzrzf ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) tau,
real, dimension( * ) work,
integer lwork,
integer info )

STZRZF

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

Purpose:
!>
!> STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
!> to upper triangular form by means of orthogonal transformations.
!>
!> The upper trapezoidal matrix A is factored as
!>
!>    A = ( R  0 ) * Z,
!>
!> where Z is an N-by-N orthogonal 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 REAL 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
!>          orthogonal 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 REAL array, dimension (M)
!>          The scalar factors of the elementary reflectors.
!>
[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.  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)**T
!>
!>  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 STZRZF,
!>  and tau(k) is the kth element of the array TAU.
!>
!>

Definition at line 150 of file stzrzf.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 REAL A( LDA, * ), TAU( * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 REAL ZERO
167 parameter( zero = 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, slarzb, slarzt, slatrz
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, 'SGERQF', ' ', 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( 'STZRZF', -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, 'SGERQF', ' ', 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, 'SGERQF', ' ', 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 slatrz( 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 slarzt( '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 slarzb( '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 slatrz( mu, n, n-m, a, lda, tau, work )
303*
304 work( 1 ) = lwkopt
305*
306 RETURN
307*
308* End of STZRZF
309*
slatrz
subroutine slatrz(m, n, l, a, lda, tau, work)
SLATRZ factors an upper trapezoidal matrix by means of orthogonal transformations.
Definition slatrz.f:140