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

Functions

subroutine ctplqt (m, n, l, mb, a, lda, b, ldb, t, ldt, work, info)
 CTPLQT
subroutine ctplqt2 (m, n, l, a, lda, b, ldb, t, ldt, info)
 CTPLQT2
subroutine ctpmlqt (side, trans, m, n, k, l, mb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
 CTPMLQT
subroutine dbbcsd (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)
 DBBCSD
subroutine dggsvp (jobu, jobv, jobq, m, p, n, a, lda, b, ldb, tola, tolb, k, l, u, ldu, v, ldv, q, ldq, iwork, tau, work, info)
 DGGSVP
subroutine dlatzm (side, m, n, v, incv, tau, c1, c2, ldc, work)
 DLATZM
subroutine dtzrqf (m, n, a, lda, tau, info)
 DTZRQF
subroutine dgetsqrhrt (m, n, mb1, nb1, nb2, a, lda, t, ldt, work, lwork, info)
 DGETSQRHRT
subroutine dgghd3 (compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, work, lwork, info)
 DGGHD3
subroutine dgghrd (compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, info)
 DGGHRD
subroutine dggqrf (n, m, p, a, lda, taua, b, ldb, taub, work, lwork, info)
 DGGQRF
subroutine dggrqf (m, p, n, a, lda, taua, b, ldb, taub, work, lwork, info)
 DGGRQF
subroutine dggsvp3 (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)
 DGGSVP3
subroutine dgsvj0 (jobv, m, n, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
 DGSVJ0 pre-processor for the routine dgesvj.
subroutine dgsvj1 (jobv, m, n, n1, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
 DGSVJ1 pre-processor for the routine dgesvj, applies Jacobi rotations targeting only particular pivots.
subroutine dhsein (side, eigsrc, initv, select, n, h, ldh, wr, wi, vl, ldvl, vr, ldvr, mm, m, work, ifaill, ifailr, info)
 DHSEIN
subroutine dhseqr (job, compz, n, ilo, ihi, h, ldh, wr, wi, z, ldz, work, lwork, info)
 DHSEQR
subroutine dla_lin_berr (n, nz, nrhs, res, ayb, berr)
 DLA_LIN_BERR computes a component-wise relative backward error.
subroutine dla_wwaddw (n, x, y, w)
 DLA_WWADDW adds a vector into a doubled-single vector.
subroutine dlals0 (icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx, perm, givptr, givcol, ldgcol, givnum, ldgnum, poles, difl, difr, z, k, c, s, work, info)
 DLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd.
subroutine dlalsa (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)
 DLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd.
subroutine dlalsd (uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond, rank, work, iwork, info)
 DLALSD uses the singular value decomposition of A to solve the least squares problem.
double precision function dlansf (norm, transr, uplo, n, a, work)
 DLANSF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix in RFP format.
subroutine dlarscl2 (m, n, d, x, ldx)
 DLARSCL2 performs reciprocal diagonal scaling on a vector.
subroutine dlarz (side, m, n, l, v, incv, tau, c, ldc, work)
 DLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix.
subroutine dlarzb (side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, c, ldc, work, ldwork)
 DLARZB applies a block reflector or its transpose to a general matrix.
subroutine dlarzt (direct, storev, n, k, v, ldv, tau, t, ldt)
 DLARZT forms the triangular factor T of a block reflector H = I - vtvH.
subroutine dlascl2 (m, n, d, x, ldx)
 DLASCL2 performs diagonal scaling on a vector.
subroutine dlatrz (m, n, l, a, lda, tau, work)
 DLATRZ factors an upper trapezoidal matrix by means of orthogonal transformations.
subroutine dopgtr (uplo, n, ap, tau, q, ldq, work, info)
 DOPGTR
subroutine dopmtr (side, uplo, trans, m, n, ap, tau, c, ldc, work, info)
 DOPMTR
subroutine dorbdb (trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, lwork, info)
 DORBDB
subroutine dorbdb1 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 DORBDB1
subroutine dorbdb2 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 DORBDB2
subroutine dorbdb3 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
 DORBDB3
subroutine dorbdb4 (m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, phantom, work, lwork, info)
 DORBDB4
subroutine dorbdb5 (m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
 DORBDB5
subroutine dorbdb6 (m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
 DORBDB6
recursive subroutine dorcsd (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)
 DORCSD
subroutine dorcsd2by1 (jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, iwork, info)
 DORCSD2BY1
subroutine dorg2l (m, n, k, a, lda, tau, work, info)
 DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm).
subroutine dorg2r (m, n, k, a, lda, tau, work, info)
 DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm).
subroutine dorghr (n, ilo, ihi, a, lda, tau, work, lwork, info)
 DORGHR
subroutine dorgl2 (m, n, k, a, lda, tau, work, info)
 DORGL2
subroutine dorglq (m, n, k, a, lda, tau, work, lwork, info)
 DORGLQ
subroutine dorgql (m, n, k, a, lda, tau, work, lwork, info)
 DORGQL
subroutine dorgqr (m, n, k, a, lda, tau, work, lwork, info)
 DORGQR
subroutine dorgr2 (m, n, k, a, lda, tau, work, info)
 DORGR2 generates all or part of the orthogonal matrix Q from an RQ factorization determined by sgerqf (unblocked algorithm).
subroutine dorgrq (m, n, k, a, lda, tau, work, lwork, info)
 DORGRQ
subroutine dorgtr (uplo, n, a, lda, tau, work, lwork, info)
 DORGTR
subroutine dorgtsqr (m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
 DORGTSQR
subroutine dorgtsqr_row (m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
 DORGTSQR_ROW
subroutine dorhr_col (m, n, nb, a, lda, t, ldt, d, info)
 DORHR_COL
subroutine dorm2l (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sgeqlf (unblocked algorithm).
subroutine dorm2r (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm).
subroutine dormbr (vect, side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 DORMBR
subroutine dormhr (side, trans, m, n, ilo, ihi, a, lda, tau, c, ldc, work, lwork, info)
 DORMHR
subroutine dorml2 (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm).
subroutine dormlq (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 DORMLQ
subroutine dormql (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 DORMQL
subroutine dormqr (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 DORMQR
subroutine dormr2 (side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
 DORMR2 multiplies a general matrix by the orthogonal matrix from a RQ factorization determined by sgerqf (unblocked algorithm).
subroutine dormr3 (side, trans, m, n, k, l, a, lda, tau, c, ldc, work, info)
 DORMR3 multiplies a general matrix by the orthogonal matrix from a RZ factorization determined by stzrzf (unblocked algorithm).
subroutine dormrq (side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
 DORMRQ
subroutine dormrz (side, trans, m, n, k, l, a, lda, tau, c, ldc, work, lwork, info)
 DORMRZ
subroutine dormtr (side, uplo, trans, m, n, a, lda, tau, c, ldc, work, lwork, info)
 DORMTR
subroutine dpbcon (uplo, n, kd, ab, ldab, anorm, rcond, work, iwork, info)
 DPBCON
subroutine dpbequ (uplo, n, kd, ab, ldab, s, scond, amax, info)
 DPBEQU
subroutine dpbrfs (uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 DPBRFS
subroutine dpbstf (uplo, n, kd, ab, ldab, info)
 DPBSTF
subroutine dpbtf2 (uplo, n, kd, ab, ldab, info)
 DPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (unblocked algorithm).
subroutine dpbtrf (uplo, n, kd, ab, ldab, info)
 DPBTRF
subroutine dpbtrs (uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
 DPBTRS
subroutine dpftrf (transr, uplo, n, a, info)
 DPFTRF
subroutine dpftri (transr, uplo, n, a, info)
 DPFTRI
subroutine dpftrs (transr, uplo, n, nrhs, a, b, ldb, info)
 DPFTRS
subroutine dppcon (uplo, n, ap, anorm, rcond, work, iwork, info)
 DPPCON
subroutine dppequ (uplo, n, ap, s, scond, amax, info)
 DPPEQU
subroutine dpprfs (uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 DPPRFS
subroutine dpptrf (uplo, n, ap, info)
 DPPTRF
subroutine dpptri (uplo, n, ap, info)
 DPPTRI
subroutine dpptrs (uplo, n, nrhs, ap, b, ldb, info)
 DPPTRS
subroutine dpstf2 (uplo, n, a, lda, piv, rank, tol, work, info)
 DPSTF2 computes the Cholesky factorization with complete pivoting of a real symmetric positive semidefinite matrix.
subroutine dpstrf (uplo, n, a, lda, piv, rank, tol, work, info)
 DPSTRF computes the Cholesky factorization with complete pivoting of a real symmetric positive semidefinite matrix.
subroutine dsbgst (vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x, ldx, work, info)
 DSBGST
subroutine dsbtrd (vect, uplo, n, kd, ab, ldab, d, e, q, ldq, work, info)
 DSBTRD
subroutine dsfrk (transr, uplo, trans, n, k, alpha, a, lda, beta, c)
 DSFRK performs a symmetric rank-k operation for matrix in RFP format.
subroutine dspcon (uplo, n, ap, ipiv, anorm, rcond, work, iwork, info)
 DSPCON
subroutine dspgst (itype, uplo, n, ap, bp, info)
 DSPGST
subroutine dsprfs (uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 DSPRFS
subroutine dsptrd (uplo, n, ap, d, e, tau, info)
 DSPTRD
subroutine dsptrf (uplo, n, ap, ipiv, info)
 DSPTRF
subroutine dsptri (uplo, n, ap, ipiv, work, info)
 DSPTRI
subroutine dsptrs (uplo, n, nrhs, ap, ipiv, b, ldb, info)
 DSPTRS
subroutine dstegr (jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
 DSTEGR
subroutine dstein (n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
 DSTEIN
subroutine dstemr (jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
 DSTEMR
subroutine dtbcon (norm, uplo, diag, n, kd, ab, ldab, rcond, work, iwork, info)
 DTBCON
subroutine dtbrfs (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 DTBRFS
subroutine dtbtrs (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, info)
 DTBTRS
subroutine dtfsm (transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
 DTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
subroutine dtftri (transr, uplo, diag, n, a, info)
 DTFTRI
subroutine dtfttp (transr, uplo, n, arf, ap, info)
 DTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed format (TP).
subroutine dtfttr (transr, uplo, n, arf, a, lda, info)
 DTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full format (TR).
subroutine dtgsen (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)
 DTGSEN
subroutine dtgsja (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)
 DTGSJA
subroutine dtgsna (job, howmny, select, n, a, lda, b, ldb, vl, ldvl, vr, ldvr, s, dif, mm, m, work, lwork, iwork, info)
 DTGSNA
subroutine dtpcon (norm, uplo, diag, n, ap, rcond, work, iwork, info)
 DTPCON
subroutine dtplqt (m, n, l, mb, a, lda, b, ldb, t, ldt, work, info)
 DTPLQT
subroutine dtplqt2 (m, n, l, a, lda, b, ldb, t, ldt, info)
 DTPLQT2 computes a LQ 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 dtpmlqt (side, trans, m, n, k, l, mb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
 DTPMLQT
subroutine dtpmqrt (side, trans, m, n, k, l, nb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
 DTPMQRT
subroutine dtpqrt (m, n, l, nb, a, lda, b, ldb, t, ldt, work, info)
 DTPQRT
subroutine dtpqrt2 (m, n, l, a, lda, b, ldb, t, ldt, info)
 DTPQRT2 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 dtprfs (uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 DTPRFS
subroutine dtptri (uplo, diag, n, ap, info)
 DTPTRI
subroutine dtptrs (uplo, trans, diag, n, nrhs, ap, b, ldb, info)
 DTPTRS
subroutine dtpttf (transr, uplo, n, ap, arf, info)
 DTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed format (TF).
subroutine dtpttr (uplo, n, ap, a, lda, info)
 DTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (TR).
subroutine dtrcon (norm, uplo, diag, n, a, lda, rcond, work, iwork, info)
 DTRCON
subroutine dtrevc (side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, info)
 DTREVC
subroutine dtrevc3 (side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, lwork, info)
 DTREVC3
subroutine dtrexc (compq, n, t, ldt, q, ldq, ifst, ilst, work, info)
 DTREXC
subroutine dtrrfs (uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 DTRRFS
subroutine dtrsen (job, compq, select, n, t, ldt, q, ldq, wr, wi, m, s, sep, work, lwork, iwork, liwork, info)
 DTRSEN
subroutine dtrsna (job, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, s, sep, mm, m, work, ldwork, iwork, info)
 DTRSNA
subroutine dtrti2 (uplo, diag, n, a, lda, info)
 DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
subroutine dtrtri (uplo, diag, n, a, lda, info)
 DTRTRI
subroutine dtrtrs (uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
 DTRTRS
subroutine dtrttf (transr, uplo, n, a, lda, arf, info)
 DTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed format (TF).
subroutine dtrttp (uplo, n, a, lda, ap, info)
 DTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (TP).
subroutine dtzrzf (m, n, a, lda, tau, work, lwork, info)
 DTZRZF
subroutine stplqt (m, n, l, mb, a, lda, b, ldb, t, ldt, work, info)
 STPLQT
subroutine stplqt2 (m, n, l, a, lda, b, ldb, t, ldt, info)
 STPLQT2 computes a LQ 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 stpmlqt (side, trans, m, n, k, l, mb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
 STPMLQT
subroutine ztplqt (m, n, l, mb, a, lda, b, ldb, t, ldt, work, info)
 ZTPLQT
subroutine ztplqt2 (m, n, l, a, lda, b, ldb, t, ldt, info)
 ZTPLQT2 computes a LQ 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 ztpmlqt (side, trans, m, n, k, l, mb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
 ZTPMLQT

Detailed Description

This is the group of double other Computational routines

Function Documentation

◆ ctplqt()

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

CTPLQT

Purpose:
!>
!> CTPLQT computes a blocked LQ factorization of a complex
!>  matrix C, which is composed of a
!> triangular block A and pentagonal block B, using the compact
!> WY representation for Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix B, and the order of the
!>          triangular matrix A.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix B.
!>          N >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in]MB
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.  M >= MB >= 1.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,M)
!>          On entry, the lower triangular M-by-M matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,N)
!>          On entry, the pentagonal M-by-N matrix B.  The first N-L columns
!>          are rectangular, and the last L columns are lower trapezoidal.
!>          On exit, B contains the pentagonal matrix V.  See Further Details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!>
[out]T
!>          T is COMPLEX array, dimension (LDT,N)
!>          The lower 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 >= MB.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MB*M)
!>
[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 M-by-(M+N) matrix
!>
!>               C = [ A ] [ B ]
!>
!>
!>  where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
!>  upper trapezoidal matrix B2:
!>          [ B ] = [ B1 ] [ B2 ]
!>                   [ B1 ]  <- M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L lower trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  M-by-M lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>            [ C ] = [ A ] [ B ]
!>                   [ A ]  <- lower triangular M-by-M
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>            [ W ] = [ I ] [ V ]
!>                   [ I ]  <- identity, M-by-M
!>                   [ 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 ] [ V2 ]
!>                   [ V1 ] <- M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows of V represent the vectors which define the H(i)'s.
!>
!>  The number of blocks is B = ceiling(M/MB), where each
!>  block is of order MB except for the last block, which is of order
!>  IB = M - (M-1)*MB.  For each of the B blocks, a upper triangular block
!>  reflector factor is computed: T1, T2, ..., TB.  The MB-by-MB (and IB-by-IB
!>  for the last block) T's are stored in the MB-by-N matrix T as
!>
!>               T = [T1 T2 ... TB].
!>

Definition at line 172 of file ctplqt.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, LDA, LDB, LDT, N, M, L, MB
181* ..
182* .. Array Arguments ..
183 COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
184* ..
185*
186* =====================================================================
187*
188* ..
189* .. Local Scalars ..
190 INTEGER I, IB, LB, NB, IINFO
191* ..
192* .. External Subroutines ..
193 EXTERNAL ctplqt2, ctprfb, xerbla
194* ..
195* .. Executable Statements ..
196*
197* Test the input arguments
198*
199 info = 0
200 IF( m.LT.0 ) THEN
201 info = -1
202 ELSE IF( n.LT.0 ) THEN
203 info = -2
204 ELSE IF( l.LT.0 .OR. (l.GT.min(m,n) .AND. min(m,n).GE.0)) THEN
205 info = -3
206 ELSE IF( mb.LT.1 .OR. (mb.GT.m .AND. m.GT.0)) THEN
207 info = -4
208 ELSE IF( lda.LT.max( 1, m ) ) THEN
209 info = -6
210 ELSE IF( ldb.LT.max( 1, m ) ) THEN
211 info = -8
212 ELSE IF( ldt.LT.mb ) THEN
213 info = -10
214 END IF
215 IF( info.NE.0 ) THEN
216 CALL xerbla( 'CTPLQT', -info )
217 RETURN
218 END IF
219*
220* Quick return if possible
221*
222 IF( m.EQ.0 .OR. n.EQ.0 ) RETURN
223*
224 DO i = 1, m, mb
225*
226* Compute the QR factorization of the current block
227*
228 ib = min( m-i+1, mb )
229 nb = min( n-l+i+ib-1, n )
230 IF( i.GE.l ) THEN
231 lb = 0
232 ELSE
233 lb = nb-n+l-i+1
234 END IF
235*
236 CALL ctplqt2( ib, nb, lb, a(i,i), lda, b( i, 1 ), ldb,
237 $ t(1, i ), ldt, iinfo )
238*
239* Update by applying H**T to B(I+IB:M,:) from the right
240*
241 IF( i+ib.LE.m ) THEN
242 CALL ctprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,
243 $ b( i, 1 ), ldb, t( 1, i ), ldt,
244 $ a( i+ib, i ), lda, b( i+ib, 1 ), ldb,
245 $ work, m-i-ib+1)
246 END IF
247 END DO
248 RETURN
249*
250* End of CTPLQT
251*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
ctprfb
subroutine ctprfb(side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, a, lda, b, ldb, work, ldwork)
CTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matri...
Definition ctprfb.f:251
ctplqt2
subroutine ctplqt2(m, n, l, a, lda, b, ldb, t, ldt, info)
CTPLQT2
Definition ctplqt2.f:162
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ ctplqt2()

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

CTPLQT2

Purpose:
!>
!> CTPLQT2 computes a LQ a factorization of a complex 
!> matrix C, which is composed of a triangular block A and pentagonal block B,
!> using the compact WY representation for Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The total number of rows of the matrix B.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix B, and the order of
!>          the triangular matrix A.
!>          N >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,M)
!>          On entry, the lower triangular M-by-M matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,N)
!>          On entry, the pentagonal M-by-N matrix B.  The first N-L columns
!>          are rectangular, and the last L columns are lower trapezoidal.
!>          On exit, B contains the pentagonal matrix V.  See Further Details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!>
[out]T
!>          T is COMPLEX array, dimension (LDT,M)
!>          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,M)
!>
[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 M-by-(M+N) matrix
!>
!>               C = [ A ][ B ]
!>
!>
!>  where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L
!>  upper trapezoidal matrix B2:
!>
!>               B = [ B1 ][ B2 ]
!>                   [ B1 ]  <-     M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L lower trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>
!>               C = [ A ][ B ]
!>                   [ A ]  <- lower triangular M-by-M
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>
!>               W = [ I ][ V ]
!>                   [ I ]  <- identity, M-by-M
!>                   [ 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,
!>
!>               W = [ V1 ][ V2 ]
!>                   [ V1 ] <-     M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows 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 * T * W
!>
!>  where W^H is the conjugate transpose of W and T is the upper triangular
!>  factor of the block reflector.
!>

Definition at line 161 of file ctplqt2.f.

162*
163* -- LAPACK computational routine --
164* -- LAPACK is a software package provided by Univ. of Tennessee, --
165* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
166*
167* .. Scalar Arguments ..
168 INTEGER INFO, LDA, LDB, LDT, N, M, L
169* ..
170* .. Array Arguments ..
171 COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * )
172* ..
173*
174* =====================================================================
175*
176* .. Parameters ..
177 COMPLEX ONE, ZERO
178 parameter( zero = ( 0.0e+0, 0.0e+0 ),one = ( 1.0e+0, 0.0e+0 ) )
179* ..
180* .. Local Scalars ..
181 INTEGER I, J, P, MP, NP
182 COMPLEX ALPHA
183* ..
184* .. External Subroutines ..
185 EXTERNAL clarfg, cgemv, cgerc, ctrmv, xerbla
186* ..
187* .. Intrinsic Functions ..
188 INTRINSIC max, min
189* ..
190* .. Executable Statements ..
191*
192* Test the input arguments
193*
194 info = 0
195 IF( m.LT.0 ) THEN
196 info = -1
197 ELSE IF( n.LT.0 ) THEN
198 info = -2
199 ELSE IF( l.LT.0 .OR. l.GT.min(m,n) ) THEN
200 info = -3
201 ELSE IF( lda.LT.max( 1, m ) ) THEN
202 info = -5
203 ELSE IF( ldb.LT.max( 1, m ) ) THEN
204 info = -7
205 ELSE IF( ldt.LT.max( 1, m ) ) THEN
206 info = -9
207 END IF
208 IF( info.NE.0 ) THEN
209 CALL xerbla( 'CTPLQT2', -info )
210 RETURN
211 END IF
212*
213* Quick return if possible
214*
215 IF( n.EQ.0 .OR. m.EQ.0 ) RETURN
216*
217 DO i = 1, m
218*
219* Generate elementary reflector H(I) to annihilate B(I,:)
220*
221 p = n-l+min( l, i )
222 CALL clarfg( p+1, a( i, i ), b( i, 1 ), ldb, t( 1, i ) )
223 t(1,i)=conjg(t(1,i))
224 IF( i.LT.m ) THEN
225 DO j = 1, p
226 b( i, j ) = conjg(b(i,j))
227 END DO
228*
229* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)]
230*
231 DO j = 1, m-i
232 t( m, j ) = (a( i+j, i ))
233 END DO
234 CALL cgemv( 'N', m-i, p, one, b( i+1, 1 ), ldb,
235 $ b( i, 1 ), ldb, one, t( m, 1 ), ldt )
236*
237* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H
238*
239 alpha = -(t( 1, i ))
240 DO j = 1, m-i
241 a( i+j, i ) = a( i+j, i ) + alpha*(t( m, j ))
242 END DO
243 CALL cgerc( m-i, p, (alpha), t( m, 1 ), ldt,
244 $ b( i, 1 ), ldb, b( i+1, 1 ), ldb )
245 DO j = 1, p
246 b( i, j ) = conjg(b(i,j))
247 END DO
248 END IF
249 END DO
250*
251 DO i = 2, m
252*
253* T(I,1:I-1) := C(I:I-1,1:N)**H * (alpha * C(I,I:N))
254*
255 alpha = -(t( 1, i ))
256 DO j = 1, i-1
257 t( i, j ) = zero
258 END DO
259 p = min( i-1, l )
260 np = min( n-l+1, n )
261 mp = min( p+1, m )
262 DO j = 1, n-l+p
263 b(i,j)=conjg(b(i,j))
264 END DO
265*
266* Triangular part of B2
267*
268 DO j = 1, p
269 t( i, j ) = (alpha*b( i, n-l+j ))
270 END DO
271 CALL ctrmv( 'L', 'N', 'N', p, b( 1, np ), ldb,
272 $ t( i, 1 ), ldt )
273*
274* Rectangular part of B2
275*
276 CALL cgemv( 'N', i-1-p, l, alpha, b( mp, np ), ldb,
277 $ b( i, np ), ldb, zero, t( i,mp ), ldt )
278*
279* B1
280
281*
282 CALL cgemv( 'N', i-1, n-l, alpha, b, ldb, b( i, 1 ), ldb,
283 $ one, t( i, 1 ), ldt )
284*
285
286*
287* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1)
288*
289 DO j = 1, i-1
290 t(i,j)=conjg(t(i,j))
291 END DO
292 CALL ctrmv( 'L', 'C', 'N', i-1, t, ldt, t( i, 1 ), ldt )
293 DO j = 1, i-1
294 t(i,j)=conjg(t(i,j))
295 END DO
296 DO j = 1, n-l+p
297 b(i,j)=conjg(b(i,j))
298 END DO
299*
300* T(I,I) = tau(I)
301*
302 t( i, i ) = t( 1, i )
303 t( 1, i ) = zero
304 END DO
305 DO i=1,m
306 DO j= i+1,m
307 t(i,j)=(t(j,i))
308 t(j,i)=zero
309 END DO
310 END DO
311
312*
313* End of CTPLQT2
314*
alpha
#define alpha
Definition eval.h:35
clarfg
subroutine clarfg(n, alpha, x, incx, tau)
CLARFG generates an elementary reflector (Householder matrix).
Definition clarfg.f:106
ctrmv
subroutine ctrmv(uplo, trans, diag, n, a, lda, x, incx)
CTRMV
Definition ctrmv.f:147
cgemv
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
Definition cgemv.f:158
cgerc
subroutine cgerc(m, n, alpha, x, incx, y, incy, a, lda)
CGERC
Definition cgerc.f:130

◆ ctpmlqt()

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

CTPMLQT

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

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

◆ dbbcsd()

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

DBBCSD

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

Purpose:
!>
!> DBBCSD 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 DORCSD 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 DOUBLE PRECISION array, dimension (Q)
!>          On entry, the angles THETA(1),...,THETA(Q) that, along with
!>          PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block
!>          form. On exit, the angles whose cosines and sines define the
!>          diagonal blocks in the CS decomposition.
!>
[in,out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>          The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,
!>          THETA(Q), define the matrix in bidiagonal-block form.
!>
[in,out]U1
!>          U1 is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (Q)
!>          When DBBCSD converges, B11D contains the cosines of THETA(1),
!>          ..., THETA(Q). If DBBCSD fails to converge, then B11D
!>          contains the diagonal of the partially reduced top-left
!>          block.
!>
[out]B11E
!>          B11E is DOUBLE PRECISION array, dimension (Q-1)
!>          When DBBCSD converges, B11E contains zeros. If DBBCSD fails
!>          to converge, then B11E contains the superdiagonal of the
!>          partially reduced top-left block.
!>
[out]B12D
!>          B12D is DOUBLE PRECISION array, dimension (Q)
!>          When DBBCSD converges, B12D contains the negative sines of
!>          THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then
!>          B12D contains the diagonal of the partially reduced top-right
!>          block.
!>
[out]B12E
!>          B12E is DOUBLE PRECISION array, dimension (Q-1)
!>          When DBBCSD converges, B12E contains zeros. If DBBCSD fails
!>          to converge, then B12E contains the subdiagonal of the
!>          partially reduced top-right block.
!>
[out]B21D
!>          B21D is DOUBLE PRECISION  array, dimension (Q)
!>          When DBBCSD converges, B21D contains the negative sines of
!>          THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then
!>          B21D contains the diagonal of the partially reduced bottom-left
!>          block.
!>
[out]B21E
!>          B21E is DOUBLE PRECISION  array, dimension (Q-1)
!>          When DBBCSD converges, B21E contains zeros. If DBBCSD fails
!>          to converge, then B21E contains the subdiagonal of the
!>          partially reduced bottom-left block.
!>
[out]B22D
!>          B22D is DOUBLE PRECISION  array, dimension (Q)
!>          When DBBCSD converges, B22D contains the negative sines of
!>          THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then
!>          B22D contains the diagonal of the partially reduced bottom-right
!>          block.
!>
[out]B22E
!>          B22E is DOUBLE PRECISION  array, dimension (Q-1)
!>          When DBBCSD converges, B22E contains zeros. If DBBCSD fails
!>          to converge, then B22E contains the subdiagonal of the
!>          partially reduced bottom-right block.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 DBBCSD did not converge, INFO specifies the number
!>                of nonzero entries in PHI, and B11D, B11E, etc.,
!>                contain the partially reduced matrix.
!>
Internal Parameters:
!>  TOLMUL  DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8)))
!>          TOLMUL controls the convergence criterion of the QR loop.
!>          Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they
!>          are within TOLMUL*EPS of either bound.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 328 of file dbbcsd.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 DOUBLE PRECISION B11D( * ), B11E( * ), B12D( * ), B12E( * ),
343 $ B21D( * ), B21E( * ), B22D( * ), B22E( * ),
344 $ PHI( * ), THETA( * ), WORK( * )
345 DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
346 $ V2T( LDV2T, * )
347* ..
348*
349* ===================================================================
350*
351* .. Parameters ..
352 INTEGER MAXITR
353 parameter( maxitr = 6 )
354 DOUBLE PRECISION HUNDRED, MEIGHTH, ONE, TEN, ZERO
355 parameter( hundred = 100.0d0, meighth = -0.125d0,
356 $ one = 1.0d0, ten = 10.0d0, zero = 0.0d0 )
357 DOUBLE PRECISION NEGONE
358 parameter( negone = -1.0d0 )
359 DOUBLE PRECISION PIOVER2
360 parameter( piover2 = 1.57079632679489661923132169163975144210d0 )
361* ..
362* .. Local Scalars ..
363 LOGICAL COLMAJOR, LQUERY, RESTART11, RESTART12,
364 $ RESTART21, RESTART22, WANTU1, WANTU2, WANTV1T,
365 $ WANTV2T
366 INTEGER I, IMIN, IMAX, ITER, IU1CS, IU1SN, IU2CS,
367 $ IU2SN, IV1TCS, IV1TSN, IV2TCS, IV2TSN, J,
368 $ LWORKMIN, LWORKOPT, MAXIT, MINI
369 DOUBLE PRECISION B11BULGE, B12BULGE, B21BULGE, B22BULGE, DUMMY,
370 $ EPS, MU, NU, R, SIGMA11, SIGMA21,
371 $ TEMP, THETAMAX, THETAMIN, THRESH, TOL, TOLMUL,
372 $ UNFL, X1, X2, Y1, Y2
373*
374* .. External Subroutines ..
375 EXTERNAL dlasr, dscal, dswap, dlartgp, dlartgs, dlas2,
376 $ xerbla
377* ..
378* .. External Functions ..
379 DOUBLE PRECISION DLAMCH
380 LOGICAL LSAME
381 EXTERNAL lsame, dlamch
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( 'DBBCSD', -info )
445 RETURN
446 ELSE IF( lquery ) THEN
447 RETURN
448 END IF
449*
450* Get machine constants
451*
452 eps = dlamch( 'Epsilon' )
453 unfl = dlamch( '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 dlas2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,
563 $ dummy )
564 CALL dlas2( 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 dlartgs( b11d(imin), b11e(imin), mu,
588 $ work(iv1tcs+imin-1), work(iv1tsn+imin-1) )
589 ELSE
590 CALL dlartgs( 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 dlartgp( b11bulge, b11d(imin), work(iu1sn+imin-1),
618 $ work(iu1cs+imin-1), r )
619 ELSE IF( mu .LE. nu ) THEN
620 CALL dlartgs( b11e( imin ), b11d( imin + 1 ), mu,
621 $ work(iu1cs+imin-1), work(iu1sn+imin-1) )
622 ELSE
623 CALL dlartgs( 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 dlartgp( b21bulge, b21d(imin), work(iu2sn+imin-1),
628 $ work(iu2cs+imin-1), r )
629 ELSE IF( nu .LT. mu ) THEN
630 CALL dlartgs( b21e( imin ), b21d( imin + 1 ), nu,
631 $ work(iu2cs+imin-1), work(iu2sn+imin-1) )
632 ELSE
633 CALL dlartgs( 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 dlartgp( x2, x1, work(iv1tsn+i-1), work(iv1tcs+i-1),
701 $ r )
702 ELSE IF( .NOT. restart11 .AND. restart21 ) THEN
703 CALL dlartgp( b11bulge, b11e(i-1), work(iv1tsn+i-1),
704 $ work(iv1tcs+i-1), r )
705 ELSE IF( restart11 .AND. .NOT. restart21 ) THEN
706 CALL dlartgp( b21bulge, b21e(i-1), work(iv1tsn+i-1),
707 $ work(iv1tcs+i-1), r )
708 ELSE IF( mu .LE. nu ) THEN
709 CALL dlartgs( b11d(i), b11e(i), mu, work(iv1tcs+i-1),
710 $ work(iv1tsn+i-1) )
711 ELSE
712 CALL dlartgs( 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 dlartgp( y2, y1, work(iv2tsn+i-1-1),
719 $ work(iv2tcs+i-1-1), r )
720 ELSE IF( .NOT. restart12 .AND. restart22 ) THEN
721 CALL dlartgp( 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 dlartgp( 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 dlartgs( b12e(i-1), b12d(i), nu, work(iv2tcs+i-1-1),
728 $ work(iv2tsn+i-1-1) )
729 ELSE
730 CALL dlartgs( 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 dlartgp( x2, x1, work(iu1sn+i-1), work(iu1cs+i-1),
784 $ r )
785 ELSE IF( .NOT. restart11 .AND. restart12 ) THEN
786 CALL dlartgp( b11bulge, b11d(i), work(iu1sn+i-1),
787 $ work(iu1cs+i-1), r )
788 ELSE IF( restart11 .AND. .NOT. restart12 ) THEN
789 CALL dlartgp( b12bulge, b12e(i-1), work(iu1sn+i-1),
790 $ work(iu1cs+i-1), r )
791 ELSE IF( mu .LE. nu ) THEN
792 CALL dlartgs( b11e(i), b11d(i+1), mu, work(iu1cs+i-1),
793 $ work(iu1sn+i-1) )
794 ELSE
795 CALL dlartgs( 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 dlartgp( y2, y1, work(iu2sn+i-1), work(iu2cs+i-1),
800 $ r )
801 ELSE IF( .NOT. restart21 .AND. restart22 ) THEN
802 CALL dlartgp( b21bulge, b21d(i), work(iu2sn+i-1),
803 $ work(iu2cs+i-1), r )
804 ELSE IF( restart21 .AND. .NOT. restart22 ) THEN
805 CALL dlartgp( b22bulge, b22e(i-1), work(iu2sn+i-1),
806 $ work(iu2cs+i-1), r )
807 ELSE IF( nu .LT. mu ) THEN
808 CALL dlartgs( b21e(i), b21e(i+1), nu, work(iu2cs+i-1),
809 $ work(iu2sn+i-1) )
810 ELSE
811 CALL dlartgs( 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 dlartgp( y2, y1, work(iv2tsn+imax-1-1),
863 $ work(iv2tcs+imax-1-1), r )
864 ELSE IF( .NOT. restart12 .AND. restart22 ) THEN
865 CALL dlartgp( 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 dlartgp( 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 dlartgs( b12e(imax-1), b12d(imax), nu,
872 $ work(iv2tcs+imax-1-1), work(iv2tsn+imax-1-1) )
873 ELSE
874 CALL dlartgs( 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 dlasr( '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 dlasr( '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 dlasr( '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 dlasr( '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 dlasr( '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 dlasr( '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 dlasr( '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 dlasr( '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 dscal( q, negone, v1t(imax,1), ldv1t )
944 ELSE
945 CALL dscal( 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 dscal( p, negone, u1(1,imax), 1 )
967 ELSE
968 CALL dscal( 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 dscal( m-p, negone, u2(1,imax), 1 )
977 ELSE
978 CALL dscal( 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 dscal( m-q, negone, v2t(imax,1), ldv2t )
989 ELSE
990 CALL dscal( 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 dswap( p, u1(1,i), 1, u1(1,mini), 1 )
1052 IF( wantu2 )
1053 $ CALL dswap( m-p, u2(1,i), 1, u2(1,mini), 1 )
1054 IF( wantv1t )
1055 $ CALL dswap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t )
1056 IF( wantv2t )
1057 $ CALL dswap( m-q, v2t(i,1), ldv2t, v2t(mini,1),
1058 $ ldv2t )
1059 ELSE
1060 IF( wantu1 )
1061 $ CALL dswap( p, u1(i,1), ldu1, u1(mini,1), ldu1 )
1062 IF( wantu2 )
1063 $ CALL dswap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 )
1064 IF( wantv1t )
1065 $ CALL dswap( q, v1t(1,i), 1, v1t(1,mini), 1 )
1066 IF( wantv2t )
1067 $ CALL dswap( 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 DBBCSD
1076*
dlas2
subroutine dlas2(f, g, h, ssmin, ssmax)
DLAS2 computes singular values of a 2-by-2 triangular matrix.
Definition dlas2.f:107
dlasr
subroutine dlasr(side, pivot, direct, m, n, c, s, a, lda)
DLASR applies a sequence of plane rotations to a general rectangular matrix.
Definition dlasr.f:199
dlartgp
subroutine dlartgp(f, g, cs, sn, r)
DLARTGP generates a plane rotation so that the diagonal is nonnegative.
Definition dlartgp.f:95
dlartgs
subroutine dlartgs(x, y, sigma, cs, sn)
DLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bid...
Definition dlartgs.f:90
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79
dswap
subroutine dswap(n, dx, incx, dy, incy)
DSWAP
Definition dswap.f:82
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69

◆ dgetsqrhrt()

subroutine dgetsqrhrt ( integer m,
integer n,
integer mb1,
integer nb1,
integer nb2,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( * ) work,
integer lwork,
integer info )

DGETSQRHRT

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

Purpose:
!>
!> DGETSQRHRT computes a NB2-sized column blocked QR-factorization
!> of a real M-by-N matrix A with M >= N,
!>
!>    A = Q * R.
!>
!> The routine uses internally a NB1-sized column blocked and MB1-sized
!> row blocked TSQR-factorization and perfors the reconstruction
!> of the Householder vectors from the TSQR output. The routine also
!> converts the R_tsqr factor from the TSQR-factorization output into
!> the R factor that corresponds to the Householder QR-factorization,
!>
!>    A = Q_tsqr * R_tsqr = Q * R.
!>
!> The output Q and R factors are stored in the same format as in DGEQRT
!> (Q is in blocked compact WY-representation). See the documentation
!> of DGEQRT for more details on the format.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A. M >= N >= 0.
!>
[in]MB1
!>          MB1 is INTEGER
!>          The row block size to be used in the blocked TSQR.
!>          MB1 > N.
!>
[in]NB1
!>          NB1 is INTEGER
!>          The column block size to be used in the blocked TSQR.
!>          N >= NB1 >= 1.
!>
[in]NB2
!>          NB2 is INTEGER
!>          The block size to be used in the blocked QR that is
!>          output. NB2 >= 1.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>
!>          On entry: an M-by-N matrix A.
!>
!>          On exit:
!>           a) the elements on and above the diagonal
!>              of the array contain the N-by-N upper-triangular
!>              matrix R corresponding to the Householder QR;
!>           b) the elements below the diagonal represent Q by
!>              the columns of blocked V (compact WY-representation).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is DOUBLE PRECISION array, dimension (LDT,N))
!>          The upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB2.
!>
[out]WORK
!>          (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          The dimension of the array WORK.
!>          LWORK >= MAX( LWT + LW1, MAX( LWT+N*N+LW2, LWT+N*N+N ) ),
!>          where
!>             NUM_ALL_ROW_BLOCKS = CEIL((M-N)/(MB1-N)),
!>             NB1LOCAL = MIN(NB1,N).
!>             LWT = NUM_ALL_ROW_BLOCKS * N * NB1LOCAL,
!>             LW1 = NB1LOCAL * N,
!>             LW2 = NB1LOCAL * MAX( NB1LOCAL, ( N - NB1LOCAL ) ),
!>          If LWORK = -1, then a workspace query is assumed.
!>          The routine only calculates the optimal size of the WORK
!>          array, returns this value as the first entry of the WORK
!>          array, and no error message related to LWORK is issued
!>          by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!> November 2020, Igor Kozachenko,
!>                Computer Science Division,
!>                University of California, Berkeley
!>
!>

Definition at line 177 of file dgetsqrhrt.f.

179 IMPLICIT NONE
180*
181* -- LAPACK computational routine --
182* -- LAPACK is a software package provided by Univ. of Tennessee, --
183* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
184*
185* .. Scalar Arguments ..
186 INTEGER INFO, LDA, LDT, LWORK, M, N, NB1, NB2, MB1
187* ..
188* .. Array Arguments ..
189 DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * )
190* ..
191*
192* =====================================================================
193*
194* .. Parameters ..
195 DOUBLE PRECISION ONE
196 parameter( one = 1.0d+0 )
197* ..
198* .. Local Scalars ..
199 LOGICAL LQUERY
200 INTEGER I, IINFO, J, LW1, LW2, LWT, LDWT, LWORKOPT,
201 $ NB1LOCAL, NB2LOCAL, NUM_ALL_ROW_BLOCKS
202* ..
203* .. External Subroutines ..
204 EXTERNAL dcopy, dlatsqr, dorgtsqr_row, dorhr_col,
205 $ xerbla
206* ..
207* .. Intrinsic Functions ..
208 INTRINSIC ceiling, dble, max, min
209* ..
210* .. Executable Statements ..
211*
212* Test the input arguments
213*
214 info = 0
215 lquery = lwork.EQ.-1
216 IF( m.LT.0 ) THEN
217 info = -1
218 ELSE IF( n.LT.0 .OR. m.LT.n ) THEN
219 info = -2
220 ELSE IF( mb1.LE.n ) THEN
221 info = -3
222 ELSE IF( nb1.LT.1 ) THEN
223 info = -4
224 ELSE IF( nb2.LT.1 ) THEN
225 info = -5
226 ELSE IF( lda.LT.max( 1, m ) ) THEN
227 info = -7
228 ELSE IF( ldt.LT.max( 1, min( nb2, n ) ) ) THEN
229 info = -9
230 ELSE
231*
232* Test the input LWORK for the dimension of the array WORK.
233* This workspace is used to store array:
234* a) Matrix T and WORK for DLATSQR;
235* b) N-by-N upper-triangular factor R_tsqr;
236* c) Matrix T and array WORK for DORGTSQR_ROW;
237* d) Diagonal D for DORHR_COL.
238*
239 IF( lwork.LT.n*n+1 .AND. .NOT.lquery ) THEN
240 info = -11
241 ELSE
242*
243* Set block size for column blocks
244*
245 nb1local = min( nb1, n )
246*
247 num_all_row_blocks = max( 1,
248 $ ceiling( dble( m - n ) / dble( mb1 - n ) ) )
249*
250* Length and leading dimension of WORK array to place
251* T array in TSQR.
252*
253 lwt = num_all_row_blocks * n * nb1local
254
255 ldwt = nb1local
256*
257* Length of TSQR work array
258*
259 lw1 = nb1local * n
260*
261* Length of DORGTSQR_ROW work array.
262*
263 lw2 = nb1local * max( nb1local, ( n - nb1local ) )
264*
265 lworkopt = max( lwt + lw1, max( lwt+n*n+lw2, lwt+n*n+n ) )
266*
267 IF( ( lwork.LT.max( 1, lworkopt ) ).AND.(.NOT.lquery) ) THEN
268 info = -11
269 END IF
270*
271 END IF
272 END IF
273*
274* Handle error in the input parameters and return workspace query.
275*
276 IF( info.NE.0 ) THEN
277 CALL xerbla( 'DGETSQRHRT', -info )
278 RETURN
279 ELSE IF ( lquery ) THEN
280 work( 1 ) = dble( lworkopt )
281 RETURN
282 END IF
283*
284* Quick return if possible
285*
286 IF( min( m, n ).EQ.0 ) THEN
287 work( 1 ) = dble( lworkopt )
288 RETURN
289 END IF
290*
291 nb2local = min( nb2, n )
292*
293*
294* (1) Perform TSQR-factorization of the M-by-N matrix A.
295*
296 CALL dlatsqr( m, n, mb1, nb1local, a, lda, work, ldwt,
297 $ work(lwt+1), lw1, iinfo )
298*
299* (2) Copy the factor R_tsqr stored in the upper-triangular part
300* of A into the square matrix in the work array
301* WORK(LWT+1:LWT+N*N) column-by-column.
302*
303 DO j = 1, n
304 CALL dcopy( j, a( 1, j ), 1, work( lwt + n*(j-1)+1 ), 1 )
305 END DO
306*
307* (3) Generate a M-by-N matrix Q with orthonormal columns from
308* the result stored below the diagonal in the array A in place.
309*
310
311 CALL dorgtsqr_row( m, n, mb1, nb1local, a, lda, work, ldwt,
312 $ work( lwt+n*n+1 ), lw2, iinfo )
313*
314* (4) Perform the reconstruction of Householder vectors from
315* the matrix Q (stored in A) in place.
316*
317 CALL dorhr_col( m, n, nb2local, a, lda, t, ldt,
318 $ work( lwt+n*n+1 ), iinfo )
319*
320* (5) Copy the factor R_tsqr stored in the square matrix in the
321* work array WORK(LWT+1:LWT+N*N) into the upper-triangular
322* part of A.
323*
324* (6) Compute from R_tsqr the factor R_hr corresponding to
325* the reconstructed Householder vectors, i.e. R_hr = S * R_tsqr.
326* This multiplication by the sign matrix S on the left means
327* changing the sign of I-th row of the matrix R_tsqr according
328* to sign of the I-th diagonal element DIAG(I) of the matrix S.
329* DIAG is stored in WORK( LWT+N*N+1 ) from the DORHR_COL output.
330*
331* (5) and (6) can be combined in a single loop, so the rows in A
332* are accessed only once.
333*
334 DO i = 1, n
335 IF( work( lwt+n*n+i ).EQ.-one ) THEN
336 DO j = i, n
337 a( i, j ) = -one * work( lwt+n*(j-1)+i )
338 END DO
339 ELSE
340 CALL dcopy( n-i+1, work(lwt+n*(i-1)+i), n, a( i, i ), lda )
341 END IF
342 END DO
343*
344 work( 1 ) = dble( lworkopt )
345 RETURN
346*
347* End of DGETSQRHRT
348*
dlatsqr
subroutine dlatsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
DLATSQR
Definition dlatsqr.f:166
dorhr_col
subroutine dorhr_col(m, n, nb, a, lda, t, ldt, d, info)
DORHR_COL
Definition dorhr_col.f:259
dorgtsqr_row
subroutine dorgtsqr_row(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
DORGTSQR_ROW
Definition dorgtsqr_row.f:188
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82

◆ dgghd3()

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

DGGHD3

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

Purpose:
!>
!> DGGHD3 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 DGGHD3 reduces the original
!> problem to generalized Hessenberg form.
!>
!> This is a blocked variant of DGGHRD, 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 DGGBAL; 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dgghd3.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 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
243 $ Z( LDZ, * ), WORK( * )
244* ..
245*
246* =====================================================================
247*
248* .. Parameters ..
249 DOUBLE PRECISION ZERO, ONE
250 parameter( zero = 0.0d+0, one = 1.0d+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 DOUBLE PRECISION 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 dgghrd, dlartg, dlaset, dorm22, drot, dgemm,
267 $ dgemv, dtrmv, dlacpy, xerbla
268* ..
269* .. Intrinsic Functions ..
270 INTRINSIC dble, max
271* ..
272* .. Executable Statements ..
273*
274* Decode and test the input parameters.
275*
276 info = 0
277 nb = ilaenv( 1, 'DGGHD3', ' ', n, ilo, ihi, -1 )
278 lwkopt = max( 6*n*nb, 1 )
279 work( 1 ) = dble( 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( 'DGGHD3', -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 dlaset( 'All', n, n, zero, one, q, ldq )
318 IF( initz )
319 $ CALL dlaset( 'All', n, n, zero, one, z, ldz )
320*
321* Zero out lower triangle of B.
322*
323 IF( n.GT.1 )
324 $ CALL dlaset( '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, 'DGGHD3', ' ', 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, 'DGGHD3', ' ', 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, 'DGGHD3', ' ', 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, 'DGGHD3', ' ', 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 dlaset( 'All', nblst, nblst, zero, one, work, nblst )
387 pw = nblst * nblst + 1
388 DO i = 1, n2nb
389 CALL dlaset( '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 dlartg( 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 dlartg( temp, b( jj+1, jj ), c, s,
473 $ b( jj+1, jj+1 ) )
474 b( jj+1, jj ) = zero
475 CALL drot( 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 DLASR.
485* CALL DLASR( '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 drot( 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 dgemv( '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 dtrmv( 'Lower', 'Transpose', 'Non-unit',
545 $ nblst-len, work( len*nblst + 1 ), nblst,
546 $ work( pw+len ), 1 )
547 CALL dgemv( '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 dtrmv( 'Upper', 'Transpose', 'Non-unit', len,
584 $ work( ppwo + nnb ), 2*nnb, work( pw ),
585 $ 1 )
586 CALL dtrmv( 'Lower', 'Transpose', 'Non-unit', nnb,
587 $ work( ppwo + 2*len*nnb ),
588 $ 2*nnb, work( pw + len ), 1 )
589 CALL dgemv( 'Transpose', nnb, len, one,
590 $ work( ppwo ), 2*nnb, a( jrow, j+1 ), 1,
591 $ one, work( pw ), 1 )
592 CALL dgemv( '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 dgemm( 'Transpose', 'No Transpose', nblst,
611 $ cola, nblst, one, work, nblst,
612 $ a( j, jcol+nnb ), lda, zero, work( pw ),
613 $ nblst )
614 CALL dlacpy( '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 dorm22( '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 dgemm( '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 dlacpy( '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 dgemm( 'No Transpose', 'No Transpose', nh,
660 $ nblst, nblst, one, q( topq, j ), ldq,
661 $ work, nblst, zero, work( pw ), nh )
662 CALL dlacpy( '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 dorm22( '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 dgemm( '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 dlacpy( '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 dlaset( 'All', nblst, nblst, zero, one, work,
702 $ nblst )
703 pw = nblst * nblst + 1
704 DO i = 1, n2nb
705 CALL dlaset( '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 dlaset( 'Lower', ihi - jcol - 1, nnb, zero, zero,
754 $ a( jcol + 2, jcol ), lda )
755 CALL dlaset( '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 dgemm( 'No Transpose', 'No Transpose', top,
764 $ nblst, nblst, one, a( 1, j ), lda,
765 $ work, nblst, zero, work( pw ), top )
766 CALL dlacpy( '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 dorm22( '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 dgemm( '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 dlacpy( '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 dgemm( 'No Transpose', 'No Transpose', top,
795 $ nblst, nblst, one, b( 1, j ), ldb,
796 $ work, nblst, zero, work( pw ), top )
797 CALL dlacpy( '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 dorm22( '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 dgemm( '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 dlacpy( '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 dgemm( 'No Transpose', 'No Transpose', nh,
837 $ nblst, nblst, one, z( topq, j ), ldz,
838 $ work, nblst, zero, work( pw ), nh )
839 CALL dlacpy( '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 dorm22( '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 dgemm( '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 dlacpy( '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 dgghrd( compq2, compz2, n, jcol, ihi, a, lda, b, ldb, q,
887 $ ldq, z, ldz, ierr )
888 work( 1 ) = dble( lwkopt )
889*
890 RETURN
891*
892* End of DGGHD3
893*
dlartg
subroutine dlartg(f, g, c, s, r)
DLARTG generates a plane rotation with real cosine and real sine.
Definition dlartg.f90:113
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
dlacpy
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
Definition dlacpy.f:103
dlaset
subroutine dlaset(uplo, m, n, alpha, beta, a, lda)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition dlaset.f:110
dorm22
subroutine dorm22(side, trans, m, n, n1, n2, q, ldq, c, ldc, work, lwork, info)
DORM22 multiplies a general matrix by a banded orthogonal matrix.
Definition dorm22.f:163
dgghrd
subroutine dgghrd(compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, info)
DGGHRD
Definition dgghrd.f:207
drot
subroutine drot(n, dx, incx, dy, incy, c, s)
DROT
Definition drot.f:92
dgemv
subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
DGEMV
Definition dgemv.f:156
dtrmv
subroutine dtrmv(uplo, trans, diag, n, a, lda, x, incx)
DTRMV
Definition dtrmv.f:147
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187

◆ dgghrd()

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

DGGHRD

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

Purpose:
!>
!> DGGHRD 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 DGGHRD 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 DGGBAL; 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dgghrd.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 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
218 $ Z( LDZ, * )
219* ..
220*
221* =====================================================================
222*
223* .. Parameters ..
224 DOUBLE PRECISION ONE, ZERO
225 parameter( one = 1.0d+0, zero = 0.0d+0 )
226* ..
227* .. Local Scalars ..
228 LOGICAL ILQ, ILZ
229 INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
230 DOUBLE PRECISION C, S, TEMP
231* ..
232* .. External Functions ..
233 LOGICAL LSAME
234 EXTERNAL lsame
235* ..
236* .. External Subroutines ..
237 EXTERNAL dlartg, dlaset, drot, 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( 'DGGHRD', -info )
298 RETURN
299 END IF
300*
301* Initialize Q and Z if desired.
302*
303 IF( icompq.EQ.3 )
304 $ CALL dlaset( 'Full', n, n, zero, one, q, ldq )
305 IF( icompz.EQ.3 )
306 $ CALL dlaset( '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 dlartg( temp, a( jrow, jcol ), c, s,
331 $ a( jrow-1, jcol ) )
332 a( jrow, jcol ) = zero
333 CALL drot( n-jcol, a( jrow-1, jcol+1 ), lda,
334 $ a( jrow, jcol+1 ), lda, c, s )
335 CALL drot( n+2-jrow, b( jrow-1, jrow-1 ), ldb,
336 $ b( jrow, jrow-1 ), ldb, c, s )
337 IF( ilq )
338 $ CALL drot( 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 dlartg( temp, b( jrow, jrow-1 ), c, s,
344 $ b( jrow, jrow ) )
345 b( jrow, jrow-1 ) = zero
346 CALL drot( ihi, a( 1, jrow ), 1, a( 1, jrow-1 ), 1, c, s )
347 CALL drot( jrow-1, b( 1, jrow ), 1, b( 1, jrow-1 ), 1, c,
348 $ s )
349 IF( ilz )
350 $ CALL drot( 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 DGGHRD
357*

◆ dggqrf()

subroutine dggqrf ( integer n,
integer m,
integer p,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) taua,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) taub,
double precision, dimension( * ) work,
integer lwork,
integer info )

DGGQRF

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

Purpose:
!>
!> DGGQRF 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 DORMQR.
!>
!>          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 DORGQR.
!>  To use Q to update another matrix, use LAPACK subroutine DORMQR.
!>
!>  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 DORGRQ.
!>  To use Z to update another matrix, use LAPACK subroutine DORMRQ.
!>

Definition at line 213 of file dggqrf.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 DOUBLE PRECISION 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 dgeqrf, dgerqf, dormqr, 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, 'DGEQRF', ' ', n, m, -1, -1 )
250 nb2 = ilaenv( 1, 'DGERQF', ' ', n, p, -1, -1 )
251 nb3 = ilaenv( 1, 'DORMQR', ' ', 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( 'DGGQRF', -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 dgeqrf( n, m, a, lda, taua, work, lwork, info )
279 lopt = work( 1 )
280*
281* Update B := Q**T*B.
282*
283 CALL dormqr( '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 dgerqf( n, p, b, ldb, taub, work, lwork, info )
290 work( 1 ) = max( lopt, int( work( 1 ) ) )
291*
292 RETURN
293*
294* End of DGGQRF
295*
dgerqf
subroutine dgerqf(m, n, a, lda, tau, work, lwork, info)
DGERQF
Definition dgerqf.f:139
dgeqrf
subroutine dgeqrf(m, n, a, lda, tau, work, lwork, info)
DGEQRF
Definition dgeqrf.f:146
dormqr
subroutine dormqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
DORMQR
Definition dormqr.f:167

◆ dggrqf()

subroutine dggrqf ( integer m,
integer p,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) taua,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) taub,
double precision, dimension( * ) work,
integer lwork,
integer info )

DGGRQF

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

Purpose:
!>
!> DGGRQF 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 DORMRQ.
!>
!>          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 DORGRQ.
!>  To use Q to update another matrix, use LAPACK subroutine DORMRQ.
!>
!>  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 DORGQR.
!>  To use Z to update another matrix, use LAPACK subroutine DORMQR.
!>

Definition at line 212 of file dggrqf.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 DOUBLE PRECISION 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 dgeqrf, dgerqf, dormrq, 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, 'DGERQF', ' ', m, n, -1, -1 )
249 nb2 = ilaenv( 1, 'DGEQRF', ' ', p, n, -1, -1 )
250 nb3 = ilaenv( 1, 'DORMRQ', ' ', 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( 'DGGRQF', -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 dgerqf( m, n, a, lda, taua, work, lwork, info )
278 lopt = work( 1 )
279*
280* Update B := B*Q**T
281*
282 CALL dormrq( '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 dgeqrf( p, n, b, ldb, taub, work, lwork, info )
290 work( 1 ) = max( lopt, int( work( 1 ) ) )
291*
292 RETURN
293*
294* End of DGGRQF
295*
dormrq
subroutine dormrq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
DORMRQ
Definition dormrq.f:167

◆ dggsvp()

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

DGGSVP

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine DGGSVP3.
!>
!> DGGSVP 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
!> DGGSVD.
!>
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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,N)
!>          On entry, the P-by-N matrix B.
!>          On exit, B contains the triangular matrix described in
!>          the Purpose section.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,P).
!>
[in]TOLA
!>          TOLA is DOUBLE PRECISION
!>
[in]TOLB
!>          TOLB is DOUBLE PRECISION
!>
!>          TOLA and TOLB are the thresholds to determine the effective
!>          numerical rank of matrix B and a subblock of A. Generally,
!>          they are set to
!>             TOLA = MAX(M,N)*norm(A)*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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 DGEQPF 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 dggsvp.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 DOUBLE PRECISION TOLA, TOLB
265* ..
266* .. Array Arguments ..
267 INTEGER IWORK( * )
268 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
269 $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
270* ..
271*
272* =====================================================================
273*
274* .. Parameters ..
275 DOUBLE PRECISION ZERO, ONE
276 parameter( zero = 0.0d+0, one = 1.0d+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 dgeqpf, dgeqr2, dgerq2, dlacpy, dlapmt, dlaset,
288 $ dorg2r, dorm2r, dormr2, 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( 'DGGSVP', -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 dgeqpf( p, n, b, ldb, iwork, tau, work, info )
338*
339* Update A := A*P
340*
341 CALL dlapmt( 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 dlaset( 'Full', p, p, zero, zero, v, ldv )
356 IF( p.GT.1 )
357 $ CALL dlacpy( 'Lower', p-1, n, b( 2, 1 ), ldb, v( 2, 1 ),
358 $ ldv )
359 CALL dorg2r( 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 dlaset( '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 dlaset( 'Full', n, n, zero, one, q, ldq )
377 CALL dlapmt( 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 dgerq2( l, n, b, ldb, tau, work, info )
385*
386* Update A := A*Z**T
387*
388 CALL dormr2( '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 dormr2( 'Right', 'Transpose', n, n, l, b, ldb, tau, q,
396 $ ldq, work, info )
397 END IF
398*
399* Clean up B
400*
401 CALL dlaset( '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 dgeqpf( 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 dorm2r( '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 dlaset( 'Full', m, m, zero, zero, u, ldu )
441 IF( m.GT.1 )
442 $ CALL dlacpy( 'Lower', m-1, n-l, a( 2, 1 ), lda, u( 2, 1 ),
443 $ ldu )
444 CALL dorg2r( 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 dlapmt( 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 dlaset( '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 dgerq2( 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 dormr2( '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 dlaset( '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 dgeqr2( 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 dorm2r( '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 DGGSVP
518*
dgeqr2
subroutine dgeqr2(m, n, a, lda, tau, work, info)
DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition dgeqr2.f:130
dgeqpf
subroutine dgeqpf(m, n, a, lda, jpvt, tau, work, info)
DGEQPF
Definition dgeqpf.f:142
dgerq2
subroutine dgerq2(m, n, a, lda, tau, work, info)
DGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition dgerq2.f:123
dlapmt
subroutine dlapmt(forwrd, m, n, x, ldx, k)
DLAPMT performs a forward or backward permutation of the columns of a matrix.
Definition dlapmt.f:104
dorm2r
subroutine dorm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sge...
Definition dorm2r.f:159
dorg2r
subroutine dorg2r(m, n, k, a, lda, tau, work, info)
DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf ...
Definition dorg2r.f:114
dormr2
subroutine dormr2(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
DORMR2 multiplies a general matrix by the orthogonal matrix from a RQ factorization determined by sge...
Definition dormr2.f:159

◆ dggsvp3()

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

DGGSVP3

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

Purpose:
!>
!> DGGSVP3 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
!> DGGSVD3.
!>
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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,N)
!>          On entry, the P-by-N matrix B.
!>          On exit, B contains the triangular matrix described in
!>          the Purpose section.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,P).
!>
[in]TOLA
!>          TOLA is DOUBLE PRECISION
!>
[in]TOLB
!>          TOLB is DOUBLE PRECISION
!>
!>          TOLA and TOLB are the thresholds to determine the effective
!>          numerical rank of matrix B and a subblock of A. Generally,
!>          they are set to
!>             TOLA = MAX(M,N)*norm(A)*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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
!>          If 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 DGEQP3 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.
!>
!>  DGGSVP3 replaces the deprecated subroutine DGGSVP.
!>
!>

Definition at line 269 of file dggsvp3.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 DOUBLE PRECISION TOLA, TOLB
284* ..
285* .. Array Arguments ..
286 INTEGER IWORK( * )
287 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
288 $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
289* ..
290*
291* =====================================================================
292*
293* .. Parameters ..
294 DOUBLE PRECISION ZERO, ONE
295 parameter( zero = 0.0d+0, one = 1.0d+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 dgeqp3, dgeqr2, dgerq2, dlacpy, dlapmt,
307 $ dlaset, dorg2r, dorm2r, dormr2, 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 dgeqp3( 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 dgeqp3( m, n, a, lda, iwork, tau, work, -1, info )
366 lwkopt = max( lwkopt, int( work( 1 ) ) )
367 lwkopt = max( 1, lwkopt )
368 work( 1 ) = dble( lwkopt )
369 END IF
370*
371 IF( info.NE.0 ) THEN
372 CALL xerbla( 'DGGSVP3', -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 dgeqp3( p, n, b, ldb, iwork, tau, work, lwork, info )
386*
387* Update A := A*P
388*
389 CALL dlapmt( 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 dlaset( 'Full', p, p, zero, zero, v, ldv )
404 IF( p.GT.1 )
405 $ CALL dlacpy( 'Lower', p-1, n, b( 2, 1 ), ldb, v( 2, 1 ),
406 $ ldv )
407 CALL dorg2r( 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 dlaset( '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 dlaset( 'Full', n, n, zero, one, q, ldq )
425 CALL dlapmt( 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 dgerq2( l, n, b, ldb, tau, work, info )
433*
434* Update A := A*Z**T
435*
436 CALL dormr2( '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 dormr2( 'Right', 'Transpose', n, n, l, b, ldb, tau, q,
444 $ ldq, work, info )
445 END IF
446*
447* Clean up B
448*
449 CALL dlaset( '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 dgeqp3( 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 dorm2r( '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 dlaset( 'Full', m, m, zero, zero, u, ldu )
489 IF( m.GT.1 )
490 $ CALL dlacpy( 'Lower', m-1, n-l, a( 2, 1 ), lda, u( 2, 1 ),
491 $ ldu )
492 CALL dorg2r( 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 dlapmt( 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 dlaset( '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 dgerq2( 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 dormr2( '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 dlaset( '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 dgeqr2( 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 dorm2r( '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 ) = dble( lwkopt )
564 RETURN
565*
566* End of DGGSVP3
567*
dgeqp3
subroutine dgeqp3(m, n, a, lda, jpvt, tau, work, lwork, info)
DGEQP3
Definition dgeqp3.f:151

◆ dgsvj0()

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

DGSVJ0 pre-processor for the routine dgesvj.

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

Purpose:
!>
!> DGSVJ0 is called from DGESVJ as a pre-processor and that is its main
!> purpose. It applies Jacobi rotations in the same way as DGESVJ 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>          On entry, SVA contains the Euclidean norms of the columns of
!>          the matrix A*diag(D).
!>          On exit, SVA contains the Euclidean norms of the columns of
!>          the matrix onexit*diag(D_onexit).
!>
[in]MV
!>          MV is INTEGER
!>          If JOBV = 'A', then MV rows of V are post-multipled by a
!>                           sequence of Jacobi rotations.
!>          If JOBV = 'N',   then MV is not referenced.
!>
[in,out]V
!>          V is DOUBLE PRECISION array, dimension (LDV,N)
!>          If JOBV = 'V' then N rows of V are post-multipled by a
!>                           sequence of Jacobi rotations.
!>          If JOBV = 'A' then MV rows of V are post-multipled by a
!>                           sequence of Jacobi rotations.
!>          If JOBV = 'N',   then V is not referenced.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V,  LDV >= 1.
!>          If JOBV = 'V', LDV >= N.
!>          If JOBV = 'A', LDV >= MV.
!>
[in]EPS
!>          EPS is DOUBLE PRECISION
!>          EPS = DLAMCH('Epsilon')
!>
[in]SFMIN
!>          SFMIN is DOUBLE PRECISION
!>          SFMIN = DLAMCH('Safe Minimum')
!>
[in]TOL
!>          TOL is DOUBLE PRECISION
!>          TOL is the threshold for Jacobi rotations. For a pair
!>          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is
!>          applied only if DABS(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 DOUBLE PRECISION 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:
DGSVJ0 is used just to enable DGESVJ 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 dgsvj0.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 DOUBLE PRECISION EPS, SFMIN, TOL
226 CHARACTER*1 JOBV
227* ..
228* .. Array Arguments ..
229 DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ),
230 $ WORK( LWORK )
231* ..
232*
233* =====================================================================
234*
235* .. Local Parameters ..
236 DOUBLE PRECISION ZERO, HALF, ONE
237 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0)
238* ..
239* .. Local Scalars ..
240 DOUBLE PRECISION 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 DOUBLE PRECISION FASTR( 5 )
251* ..
252* .. Intrinsic Functions ..
253 INTRINSIC dabs, max, dble, min, dsign, dsqrt
254* ..
255* .. External Functions ..
256 DOUBLE PRECISION DDOT, DNRM2
257 INTEGER IDAMAX
258 LOGICAL LSAME
259 EXTERNAL idamax, lsame, ddot, dnrm2
260* ..
261* .. External Subroutines ..
262 EXTERNAL daxpy, dcopy, dlascl, dlassq, drotm, dswap,
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( 'DGSVJ0', -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 = dsqrt( eps )
308 rootsfmin = dsqrt( sfmin )
309 small = sfmin / eps
310 big = one / sfmin
311 rootbig = one / rootsfmin
312 bigtheta = one / rooteps
313 roottol = dsqrt( 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 = idamax( n-p+1, sva( p ), 1 ) + p - 1
372 IF( p.NE.q ) THEN
373 CALL dswap( m, a( 1, p ), 1, a( 1, q ), 1 )
374 IF( rsvec )CALL dswap( 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 DNRM2(M,A(1,p),1)
390* as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may result in
391* overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and
392* underflow for ||A(:,p)||_2 < DSQRT(underflow_threshold).
393* Hence, DNRM2 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 DNRM2 is available, the IF-THEN-ELSE
396* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * D(p)".
397*
398 IF( ( sva( p ).LT.rootbig ) .AND.
399 $ ( sva( p ).GT.rootsfmin ) ) THEN
400 sva( p ) = dnrm2( m, a( 1, p ), 1 )*d( p )
401 ELSE
402 temp1 = zero
403 aapp = one
404 CALL dlassq( m, a( 1, p ), 1, temp1, aapp )
405 sva( p ) = temp1*dsqrt( 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 = ( ddot( m, a( 1, p ), 1, a( 1,
428 $ q ), 1 )*d( p )*d( q ) / aaqq )
429 $ / aapp
430 ELSE
431 CALL dcopy( m, a( 1, p ), 1, work, 1 )
432 CALL dlascl( 'G', 0, 0, aapp, d( p ),
433 $ m, 1, work, lda, ierr )
434 aapq = ddot( 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 = ( ddot( m, a( 1, p ), 1, a( 1,
441 $ q ), 1 )*d( p )*d( q ) / aaqq )
442 $ / aapp
443 ELSE
444 CALL dcopy( m, a( 1, q ), 1, work, 1 )
445 CALL dlascl( 'G', 0, 0, aaqq, d( q ),
446 $ m, 1, work, lda, ierr )
447 aapq = ddot( m, work, 1, a( 1, p ),
448 $ 1 )*d( p ) / aapp
449 END IF
450 END IF
451*
452 mxaapq = max( mxaapq, dabs( aapq ) )
453*
454* TO rotate or NOT to rotate, THAT is the question ...
455*
456 IF( dabs( 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*dabs( aqoap-apoaq )/aapq
472*
473 IF( dabs( 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 drotm( m, a( 1, p ), 1,
479 $ a( 1, q ), 1, fastr )
480 IF( rsvec )CALL drotm( mvl,
481 $ v( 1, p ), 1,
482 $ v( 1, q ), 1,
483 $ fastr )
484 sva( q ) = aaqq*dsqrt( max( zero,
485 $ one+t*apoaq*aapq ) )
486 aapp = aapp*dsqrt( max( zero,
487 $ one-t*aqoap*aapq ) )
488 mxsinj = max( mxsinj, dabs( t ) )
489*
490 ELSE
491*
492* .. choose correct signum for THETA and rotate
493*
494 thsign = -dsign( one, aapq )
495 t = one / ( theta+thsign*
496 $ dsqrt( one+theta*theta ) )
497 cs = dsqrt( one / ( one+t*t ) )
498 sn = t*cs
499*
500 mxsinj = max( mxsinj, dabs( sn ) )
501 sva( q ) = aaqq*dsqrt( max( zero,
502 $ one+t*apoaq*aapq ) )
503 aapp = aapp*dsqrt( 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 drotm( m, a( 1, p ), 1,
515 $ a( 1, q ), 1,
516 $ fastr )
517 IF( rsvec )CALL drotm( mvl,
518 $ v( 1, p ), 1, v( 1, q ),
519 $ 1, fastr )
520 ELSE
521 CALL daxpy( m, -t*aqoap,
522 $ a( 1, q ), 1,
523 $ a( 1, p ), 1 )
524 CALL daxpy( 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 daxpy( mvl, -t*aqoap,
531 $ v( 1, q ), 1,
532 $ v( 1, p ), 1 )
533 CALL daxpy( 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 daxpy( m, t*apoaq,
542 $ a( 1, p ), 1,
543 $ a( 1, q ), 1 )
544 CALL daxpy( 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 daxpy( mvl, t*apoaq,
551 $ v( 1, p ), 1,
552 $ v( 1, q ), 1 )
553 CALL daxpy( 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 daxpy( m, -t*aqoap,
561 $ a( 1, q ), 1,
562 $ a( 1, p ), 1 )
563 CALL daxpy( 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 daxpy( mvl,
570 $ -t*aqoap,
571 $ v( 1, q ), 1,
572 $ v( 1, p ), 1 )
573 CALL daxpy( mvl,
574 $ cs*sn*apoaq,
575 $ v( 1, p ), 1,
576 $ v( 1, q ), 1 )
577 END IF
578 ELSE
579 CALL daxpy( m, t*apoaq,
580 $ a( 1, p ), 1,
581 $ a( 1, q ), 1 )
582 CALL daxpy( 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 daxpy( mvl,
590 $ t*apoaq, v( 1, p ),
591 $ 1, v( 1, q ), 1 )
592 CALL daxpy( 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 dcopy( m, a( 1, p ), 1, work, 1 )
605 CALL dlascl( 'G', 0, 0, aapp, one, m,
606 $ 1, work, lda, ierr )
607 CALL dlascl( 'G', 0, 0, aaqq, one, m,
608 $ 1, a( 1, q ), lda, ierr )
609 temp1 = -aapq*d( p ) / d( q )
610 CALL daxpy( m, temp1, work, 1,
611 $ a( 1, q ), 1 )
612 CALL dlascl( 'G', 0, 0, one, aaqq, m,
613 $ 1, a( 1, q ), lda, ierr )
614 sva( q ) = aaqq*dsqrt( 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 ) = dnrm2( m, a( 1, q ), 1 )*
627 $ d( q )
628 ELSE
629 t = zero
630 aaqq = one
631 CALL dlassq( m, a( 1, q ), 1, t,
632 $ aaqq )
633 sva( q ) = t*dsqrt( 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 = dnrm2( m, a( 1, p ), 1 )*
640 $ d( p )
641 ELSE
642 t = zero
643 aapp = one
644 CALL dlassq( m, a( 1, p ), 1, t,
645 $ aapp )
646 aapp = t*dsqrt( 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 = ( ddot( m, a( 1, p ), 1, a( 1,
728 $ q ), 1 )*d( p )*d( q ) / aaqq )
729 $ / aapp
730 ELSE
731 CALL dcopy( m, a( 1, p ), 1, work, 1 )
732 CALL dlascl( 'G', 0, 0, aapp, d( p ),
733 $ m, 1, work, lda, ierr )
734 aapq = ddot( 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 = ( ddot( m, a( 1, p ), 1, a( 1,
745 $ q ), 1 )*d( p )*d( q ) / aaqq )
746 $ / aapp
747 ELSE
748 CALL dcopy( m, a( 1, q ), 1, work, 1 )
749 CALL dlascl( 'G', 0, 0, aaqq, d( q ),
750 $ m, 1, work, lda, ierr )
751 aapq = ddot( m, work, 1, a( 1, p ),
752 $ 1 )*d( p ) / aapp
753 END IF
754 END IF
755*
756 mxaapq = max( mxaapq, dabs( aapq ) )
757*
758* TO rotate or NOT to rotate, THAT is the question ...
759*
760 IF( dabs( 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*dabs( aqoap-apoaq )/aapq
771 IF( aaqq.GT.aapp0 )theta = -theta
772*
773 IF( dabs( 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 drotm( m, a( 1, p ), 1,
778 $ a( 1, q ), 1, fastr )
779 IF( rsvec )CALL drotm( mvl,
780 $ v( 1, p ), 1,
781 $ v( 1, q ), 1,
782 $ fastr )
783 sva( q ) = aaqq*dsqrt( max( zero,
784 $ one+t*apoaq*aapq ) )
785 aapp = aapp*dsqrt( max( zero,
786 $ one-t*aqoap*aapq ) )
787 mxsinj = max( mxsinj, dabs( t ) )
788 ELSE
789*
790* .. choose correct signum for THETA and rotate
791*
792 thsign = -dsign( one, aapq )
793 IF( aaqq.GT.aapp0 )thsign = -thsign
794 t = one / ( theta+thsign*
795 $ dsqrt( one+theta*theta ) )
796 cs = dsqrt( one / ( one+t*t ) )
797 sn = t*cs
798 mxsinj = max( mxsinj, dabs( sn ) )
799 sva( q ) = aaqq*dsqrt( max( zero,
800 $ one+t*apoaq*aapq ) )
801 aapp = aapp*dsqrt( 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 drotm( m, a( 1, p ), 1,
814 $ a( 1, q ), 1,
815 $ fastr )
816 IF( rsvec )CALL drotm( mvl,
817 $ v( 1, p ), 1, v( 1, q ),
818 $ 1, fastr )
819 ELSE
820 CALL daxpy( m, -t*aqoap,
821 $ a( 1, q ), 1,
822 $ a( 1, p ), 1 )
823 CALL daxpy( m, cs*sn*apoaq,
824 $ a( 1, p ), 1,
825 $ a( 1, q ), 1 )
826 IF( rsvec ) THEN
827 CALL daxpy( mvl, -t*aqoap,
828 $ v( 1, q ), 1,
829 $ v( 1, p ), 1 )
830 CALL daxpy( 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 daxpy( m, t*apoaq,
841 $ a( 1, p ), 1,
842 $ a( 1, q ), 1 )
843 CALL daxpy( m, -cs*sn*aqoap,
844 $ a( 1, q ), 1,
845 $ a( 1, p ), 1 )
846 IF( rsvec ) THEN
847 CALL daxpy( mvl, t*apoaq,
848 $ v( 1, p ), 1,
849 $ v( 1, q ), 1 )
850 CALL daxpy( 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 daxpy( m, -t*aqoap,
860 $ a( 1, q ), 1,
861 $ a( 1, p ), 1 )
862 CALL daxpy( 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 daxpy( mvl,
869 $ -t*aqoap,
870 $ v( 1, q ), 1,
871 $ v( 1, p ), 1 )
872 CALL daxpy( mvl,
873 $ cs*sn*apoaq,
874 $ v( 1, p ), 1,
875 $ v( 1, q ), 1 )
876 END IF
877 ELSE
878 CALL daxpy( m, t*apoaq,
879 $ a( 1, p ), 1,
880 $ a( 1, q ), 1 )
881 CALL daxpy( 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 daxpy( mvl,
889 $ t*apoaq, v( 1, p ),
890 $ 1, v( 1, q ), 1 )
891 CALL daxpy( 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 dcopy( m, a( 1, p ), 1, work,
904 $ 1 )
905 CALL dlascl( 'G', 0, 0, aapp, one,
906 $ m, 1, work, lda, ierr )
907 CALL dlascl( 'G', 0, 0, aaqq, one,
908 $ m, 1, a( 1, q ), lda,
909 $ ierr )
910 temp1 = -aapq*d( p ) / d( q )
911 CALL daxpy( m, temp1, work, 1,
912 $ a( 1, q ), 1 )
913 CALL dlascl( 'G', 0, 0, one, aaqq,
914 $ m, 1, a( 1, q ), lda,
915 $ ierr )
916 sva( q ) = aaqq*dsqrt( max( zero,
917 $ one-aapq*aapq ) )
918 mxsinj = max( mxsinj, sfmin )
919 ELSE
920 CALL dcopy( m, a( 1, q ), 1, work,
921 $ 1 )
922 CALL dlascl( 'G', 0, 0, aaqq, one,
923 $ m, 1, work, lda, ierr )
924 CALL dlascl( 'G', 0, 0, aapp, one,
925 $ m, 1, a( 1, p ), lda,
926 $ ierr )
927 temp1 = -aapq*d( q ) / d( p )
928 CALL daxpy( m, temp1, work, 1,
929 $ a( 1, p ), 1 )
930 CALL dlascl( 'G', 0, 0, one, aapp,
931 $ m, 1, a( 1, p ), lda,
932 $ ierr )
933 sva( p ) = aapp*dsqrt( 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 ) = dnrm2( m, a( 1, q ), 1 )*
947 $ d( q )
948 ELSE
949 t = zero
950 aaqq = one
951 CALL dlassq( m, a( 1, q ), 1, t,
952 $ aaqq )
953 sva( q ) = t*dsqrt( 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 = dnrm2( m, a( 1, p ), 1 )*
960 $ d( p )
961 ELSE
962 t = zero
963 aapp = one
964 CALL dlassq( m, a( 1, p ), 1, t,
965 $ aapp )
966 aapp = t*dsqrt( 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 ) = dabs( 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 ) = dnrm2( m, a( 1, n ), 1 )*d( n )
1024 ELSE
1025 t = zero
1026 aapp = one
1027 CALL dlassq( m, a( 1, n ), 1, t, aapp )
1028 sva( n ) = t*dsqrt( 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.dble( n )*tol ) .AND.
1037 $ ( dble( 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 = idamax( 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 dswap( m, a( 1, p ), 1, a( 1, q ), 1 )
1068 IF( rsvec )CALL dswap( mvl, v( 1, p ), 1, v( 1, q ), 1 )
1069 END IF
1070 5991 CONTINUE
1071*
1072 RETURN
1073* ..
1074* .. END OF DGSVJ0
1075* ..
dlassq
subroutine dlassq(n, x, incx, scl, sumsq)
DLASSQ updates a sum of squares represented in scaled form.
Definition dlassq.f90:137
dlascl
subroutine dlascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition dlascl.f:143
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71
ddot
double precision function ddot(n, dx, incx, dy, incy)
DDOT
Definition ddot.f:82
drotm
subroutine drotm(n, dx, incx, dy, incy, dparam)
DROTM
Definition drotm.f:96
daxpy
subroutine daxpy(n, da, dx, incx, dy, incy)
DAXPY
Definition daxpy.f:89
dnrm2
real(wp) function dnrm2(n, x, incx)
DNRM2
Definition dnrm2.f90:89

◆ dgsvj1()

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

DGSVJ1 pre-processor for the routine dgesvj, applies Jacobi rotations targeting only particular pivots.

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

Purpose:
!>
!> DGSVJ1 is called from DGESVJ as a pre-processor and that is its main
!> purpose. It applies Jacobi rotations in the same way as DGESVJ 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
!> ~~~~~~~~~~~~~~~
!> DGSVJ1 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>          The array D accumulates the scaling factors from the fast scaled
!>          Jacobi rotations.
!>          On entry, A*diag(D) represents the input matrix.
!>          On exit, A_onexit*diag(D_onexit) represents the input matrix
!>          post-multiplied by a sequence of Jacobi rotations, where the
!>          rotation threshold and the total number of sweeps are given in
!>          TOL and NSWEEP, respectively.
!>          (See the descriptions of N1, A, TOL and NSWEEP.)
!>
[in,out]SVA
!>          SVA is DOUBLE PRECISION array, dimension (N)
!>          On entry, SVA contains the Euclidean norms of the columns of
!>          the matrix A*diag(D).
!>          On exit, SVA contains the Euclidean norms of the columns of
!>          the matrix onexit*diag(D_onexit).
!>
[in]MV
!>          MV is INTEGER
!>          If JOBV = 'A', then MV rows of V are post-multipled by a
!>                         sequence of Jacobi rotations.
!>          If JOBV = 'N', then MV is not referenced.
!>
[in,out]V
!>          V is DOUBLE PRECISION array, dimension (LDV,N)
!>          If JOBV = 'V', then N rows of V are post-multipled by a
!>                         sequence of Jacobi rotations.
!>          If JOBV = 'A', then MV rows of V are post-multipled by a
!>                         sequence of Jacobi rotations.
!>          If JOBV = 'N', then V is not referenced.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V,  LDV >= 1.
!>          If JOBV = 'V', LDV >= N.
!>          If JOBV = 'A', LDV >= MV.
!>
[in]EPS
!>          EPS is DOUBLE PRECISION
!>          EPS = DLAMCH('Epsilon')
!>
[in]SFMIN
!>          SFMIN is DOUBLE PRECISION
!>          SFMIN = DLAMCH('Safe Minimum')
!>
[in]TOL
!>          TOL is DOUBLE PRECISION
!>          TOL is the threshold for Jacobi rotations. For a pair
!>          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is
!>          applied only if DABS(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 DOUBLE PRECISION 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 dgsvj1.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 DOUBLE PRECISION EPS, SFMIN, TOL
243 INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP
244 CHARACTER*1 JOBV
245* ..
246* .. Array Arguments ..
247 DOUBLE PRECISION A( LDA, * ), D( N ), SVA( N ), V( LDV, * ),
248 $ WORK( LWORK )
249* ..
250*
251* =====================================================================
252*
253* .. Local Parameters ..
254 DOUBLE PRECISION ZERO, HALF, ONE
255 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
256* ..
257* .. Local Scalars ..
258 DOUBLE PRECISION 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 DOUBLE PRECISION FASTR( 5 )
269* ..
270* .. Intrinsic Functions ..
271 INTRINSIC dabs, max, dble, min, dsign, dsqrt
272* ..
273* .. External Functions ..
274 DOUBLE PRECISION DDOT, DNRM2
275 INTEGER IDAMAX
276 LOGICAL LSAME
277 EXTERNAL idamax, lsame, ddot, dnrm2
278* ..
279* .. External Subroutines ..
280 EXTERNAL daxpy, dcopy, dlascl, dlassq, drotm, dswap,
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( 'DGSVJ1', -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 = dsqrt( eps )
328 rootsfmin = dsqrt( sfmin )
329 small = sfmin / eps
330 big = one / sfmin
331 rootbig = one / rootsfmin
332 large = big / dsqrt( dble( m*n ) )
333 bigtheta = one / rooteps
334 roottol = dsqrt( 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 = ( ddot( m, a( 1, p ), 1, a( 1,
427 $ q ), 1 )*d( p )*d( q ) / aaqq )
428 $ / aapp
429 ELSE
430 CALL dcopy( m, a( 1, p ), 1, work, 1 )
431 CALL dlascl( 'G', 0, 0, aapp, d( p ),
432 $ m, 1, work, lda, ierr )
433 aapq = ddot( 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 = ( ddot( m, a( 1, p ), 1, a( 1,
444 $ q ), 1 )*d( p )*d( q ) / aaqq )
445 $ / aapp
446 ELSE
447 CALL dcopy( m, a( 1, q ), 1, work, 1 )
448 CALL dlascl( 'G', 0, 0, aaqq, d( q ),
449 $ m, 1, work, lda, ierr )
450 aapq = ddot( m, work, 1, a( 1, p ),
451 $ 1 )*d( p ) / aapp
452 END IF
453 END IF
454
455 mxaapq = max( mxaapq, dabs( aapq ) )
456
457* TO rotate or NOT to rotate, THAT is the question ...
458*
459 IF( dabs( 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*dabs(aqoap-apoaq) / aapq
470 IF( aaqq.GT.aapp0 )theta = -theta
471
472 IF( dabs( 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 drotm( m, a( 1, p ), 1,
477 $ a( 1, q ), 1, fastr )
478 IF( rsvec )CALL drotm( mvl,
479 $ v( 1, p ), 1,
480 $ v( 1, q ), 1,
481 $ fastr )
482 sva( q ) = aaqq*dsqrt( max( zero,
483 $ one+t*apoaq*aapq ) )
484 aapp = aapp*dsqrt( max( zero,
485 $ one-t*aqoap*aapq ) )
486 mxsinj = max( mxsinj, dabs( t ) )
487 ELSE
488*
489* .. choose correct signum for THETA and rotate
490*
491 thsign = -dsign( one, aapq )
492 IF( aaqq.GT.aapp0 )thsign = -thsign
493 t = one / ( theta+thsign*
494 $ dsqrt( one+theta*theta ) )
495 cs = dsqrt( one / ( one+t*t ) )
496 sn = t*cs
497 mxsinj = max( mxsinj, dabs( sn ) )
498 sva( q ) = aaqq*dsqrt( max( zero,
499 $ one+t*apoaq*aapq ) )
500 aapp = aapp*dsqrt( 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 drotm( m, a( 1, p ), 1,
513 $ a( 1, q ), 1,
514 $ fastr )
515 IF( rsvec )CALL drotm( mvl,
516 $ v( 1, p ), 1, v( 1, q ),
517 $ 1, fastr )
518 ELSE
519 CALL daxpy( m, -t*aqoap,
520 $ a( 1, q ), 1,
521 $ a( 1, p ), 1 )
522 CALL daxpy( m, cs*sn*apoaq,
523 $ a( 1, p ), 1,
524 $ a( 1, q ), 1 )
525 IF( rsvec ) THEN
526 CALL daxpy( mvl, -t*aqoap,
527 $ v( 1, q ), 1,
528 $ v( 1, p ), 1 )
529 CALL daxpy( 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 daxpy( m, t*apoaq,
540 $ a( 1, p ), 1,
541 $ a( 1, q ), 1 )
542 CALL daxpy( m, -cs*sn*aqoap,
543 $ a( 1, q ), 1,
544 $ a( 1, p ), 1 )
545 IF( rsvec ) THEN
546 CALL daxpy( mvl, t*apoaq,
547 $ v( 1, p ), 1,
548 $ v( 1, q ), 1 )
549 CALL daxpy( 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 daxpy( m, -t*aqoap,
559 $ a( 1, q ), 1,
560 $ a( 1, p ), 1 )
561 CALL daxpy( 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 daxpy( mvl,
568 $ -t*aqoap,
569 $ v( 1, q ), 1,
570 $ v( 1, p ), 1 )
571 CALL daxpy( mvl,
572 $ cs*sn*apoaq,
573 $ v( 1, p ), 1,
574 $ v( 1, q ), 1 )
575 END IF
576 ELSE
577 CALL daxpy( m, t*apoaq,
578 $ a( 1, p ), 1,
579 $ a( 1, q ), 1 )
580 CALL daxpy( 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 daxpy( mvl,
588 $ t*apoaq, v( 1, p ),
589 $ 1, v( 1, q ), 1 )
590 CALL daxpy( 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 dcopy( m, a( 1, p ), 1, work,
603 $ 1 )
604 CALL dlascl( 'G', 0, 0, aapp, one,
605 $ m, 1, work, lda, ierr )
606 CALL dlascl( 'G', 0, 0, aaqq, one,
607 $ m, 1, a( 1, q ), lda,
608 $ ierr )
609 temp1 = -aapq*d( p ) / d( q )
610 CALL daxpy( m, temp1, work, 1,
611 $ a( 1, q ), 1 )
612 CALL dlascl( 'G', 0, 0, one, aaqq,
613 $ m, 1, a( 1, q ), lda,
614 $ ierr )
615 sva( q ) = aaqq*dsqrt( max( zero,
616 $ one-aapq*aapq ) )
617 mxsinj = max( mxsinj, sfmin )
618 ELSE
619 CALL dcopy( m, a( 1, q ), 1, work,
620 $ 1 )
621 CALL dlascl( 'G', 0, 0, aaqq, one,
622 $ m, 1, work, lda, ierr )
623 CALL dlascl( 'G', 0, 0, aapp, one,
624 $ m, 1, a( 1, p ), lda,
625 $ ierr )
626 temp1 = -aapq*d( q ) / d( p )
627 CALL daxpy( m, temp1, work, 1,
628 $ a( 1, p ), 1 )
629 CALL dlascl( 'G', 0, 0, one, aapp,
630 $ m, 1, a( 1, p ), lda,
631 $ ierr )
632 sva( p ) = aapp*dsqrt( 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 ) = dnrm2( m, a( 1, q ), 1 )*
646 $ d( q )
647 ELSE
648 t = zero
649 aaqq = one
650 CALL dlassq( m, a( 1, q ), 1, t,
651 $ aaqq )
652 sva( q ) = t*dsqrt( 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 = dnrm2( m, a( 1, p ), 1 )*
659 $ d( p )
660 ELSE
661 t = zero
662 aapp = one
663 CALL dlassq( m, a( 1, p ), 1, t,
664 $ aapp )
665 aapp = t*dsqrt( 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 ) = dabs( 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 ) = dnrm2( m, a( 1, n ), 1 )*d( n )
727 ELSE
728 t = zero
729 aapp = one
730 CALL dlassq( m, a( 1, n ), 1, t, aapp )
731 sva( n ) = t*dsqrt( 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.dble( n )*tol ) .AND.
740 $ ( dble( 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 = idamax( 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 dswap( m, a( 1, p ), 1, a( 1, q ), 1 )
773 IF( rsvec )CALL dswap( mvl, v( 1, p ), 1, v( 1, q ), 1 )
774 END IF
775 5991 CONTINUE
776*
777 RETURN
778* ..
779* .. END OF DGSVJ1
780* ..

◆ dhsein()

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

DHSEIN

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

Purpose:
!>
!> DHSEIN 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 DHSEQR; 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 DHSEIN 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, DHSEIN 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[in]WI
!>          WI is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dhsein.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 DOUBLE PRECISION H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
276 $ WI( * ), WORK( * ), WR( * )
277* ..
278*
279* =====================================================================
280*
281* .. Parameters ..
282 DOUBLE PRECISION ZERO, ONE
283 parameter( zero = 0.0d+0, one = 1.0d+0 )
284* ..
285* .. Local Scalars ..
286 LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
287 INTEGER I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
288 DOUBLE PRECISION BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI,
289 $ WKR
290* ..
291* .. External Functions ..
292 LOGICAL LSAME, DISNAN
293 DOUBLE PRECISION DLAMCH, DLANHS
294 EXTERNAL lsame, dlamch, dlanhs, disnan
295* ..
296* .. External Subroutines ..
297 EXTERNAL dlaein, 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( 'DHSEIN', -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 = dlamch( 'Safe minimum' )
368 ulp = dlamch( '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 = dlanhs( 'I', kr-kl+1, h( kl, kl ), ldh, work )
424 IF( disnan( 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 dlaein( .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 dlaein( .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 DHSEIN
526*
disnan
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:59
dlanhs
double precision function dlanhs(norm, n, a, lda, work)
DLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition dlanhs.f:108
dlaein
subroutine dlaein(rightv, noinit, n, h, ldh, wr, wi, vr, vi, b, ldb, work, eps3, smlnum, bignum, info)
DLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse iterat...
Definition dlaein.f:172

◆ dhseqr()

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

DHSEQR

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

Purpose:
!>
!>    DHSEQR 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 DGEBAL, and then passed to ZGEHRD
!>           when the matrix output by DGEBAL 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 DOUBLE PRECISION 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 DHSEQR, 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 DOUBLE PRECISION array, dimension (N)
!>
[out]WI
!>          WI is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DORGHR
!>           after the call to DGEHRD 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 DOUBLE PRECISION 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 DHSEQR does a workspace query.
!>           In this case, DHSEQR 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, DHSEQR 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,'DHSEQR',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 DLAHQR vs DLAQR0 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
!>                       DLAHQR 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 dhseqr.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 DOUBLE PRECISION 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* . DLAHQR 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 DLAHQR 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 DOUBLE PRECISION ZERO, ONE
349 parameter( zero = 0.0d0, one = 1.0d0 )
350* ..
351* .. Local Arrays ..
352 DOUBLE PRECISION 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 dlacpy, dlahqr, dlaqr0, dlaset, xerbla
365* ..
366* .. Intrinsic Functions ..
367 INTRINSIC dble, max, min
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 ) = dble( 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( 'DHSEQR', -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 dlaqr0( 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( dble( max( 1, n ) ), work( 1 ) )
420 RETURN
421*
422 ELSE
423*
424* ==== copy eigenvalues isolated by DGEBAL ====
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 dlaset( '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* ==== DLAHQR/DLAQR0 crossover point ====
449*
450 nmin = ilaenv( 12, 'DHSEQR', job( : 1 ) // compz( : 1 ), n,
451 $ ilo, ihi, lwork )
452 nmin = max( ntiny, nmin )
453*
454* ==== DLAQR0 for big matrices; DLAHQR for small ones ====
455*
456 IF( n.GT.nmin ) THEN
457 CALL dlaqr0( 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 dlahqr( 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 DLAHQR failure! DLAQR0 sometimes succeeds
469* . when DLAHQR fails. ====
470*
471 kbot = info
472*
473 IF( n.GE.nl ) THEN
474*
475* ==== Larger matrices have enough subdiagonal scratch
476* . space to call DLAQR0 directly. ====
477*
478 CALL dlaqr0( 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 DLAQR0. Hence,
485* . tiny matrices must be copied into a larger
486* . array before calling DLAQR0. ====
487*
488 CALL dlacpy( 'A', n, n, h, ldh, hl, nl )
489 hl( n+1, n ) = zero
490 CALL dlaset( 'A', nl, nl-n, zero, zero, hl( 1, n+1 ),
491 $ nl )
492 CALL dlaqr0( 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 dlacpy( '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 dlaset( '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( dble( max( 1, n ) ), work( 1 ) )
509 END IF
510*
511* ==== End of DHSEQR ====
512*
dlahqr
subroutine dlahqr(wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, iloz, ihiz, z, ldz, info)
DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix,...
Definition dlahqr.f:207
dlaqr0
subroutine dlaqr0(wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, iloz, ihiz, z, ldz, work, lwork, info)
DLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur de...
Definition dlaqr0.f:256
nl
character *2 function nl()
Definition message.F:2354

◆ dla_lin_berr()

subroutine dla_lin_berr ( integer n,
integer nz,
integer nrhs,
double precision, dimension( n, nrhs ) res,
double precision, dimension( n, nrhs ) ayb,
double precision, dimension( nrhs ) berr )

DLA_LIN_BERR computes a component-wise relative backward error.

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

Purpose:
!>
!>    DLA_LIN_BERR computes component-wise 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 component-wise 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 DOUBLE PRECISION array, dimension (N,NRHS)
!>     The residual matrix, i.e., the matrix R in the relative backward
!>     error formula above.
!>
[in]AYB
!>          AYB is DOUBLE PRECISION array, dimension (N, NRHS)
!>     The denominator in the relative backward error formula above, i.e.,
!>     the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B
!>     are from iterative refinement (see dla_gerfsx_extended.f).
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>     The component-wise 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 dla_lin_berr.f.

101*
102* -- LAPACK computational routine --
103* -- LAPACK is a software package provided by Univ. of Tennessee, --
104* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
105*
106* .. Scalar Arguments ..
107 INTEGER N, NZ, NRHS
108* ..
109* .. Array Arguments ..
110 DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS )
111 DOUBLE PRECISION RES( N, NRHS )
112* ..
113*
114* =====================================================================
115*
116* .. Local Scalars ..
117 DOUBLE PRECISION TMP
118 INTEGER I, J
119* ..
120* .. Intrinsic Functions ..
121 INTRINSIC abs, max
122* ..
123* .. External Functions ..
124 EXTERNAL dlamch
125 DOUBLE PRECISION DLAMCH
126 DOUBLE PRECISION 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 = dlamch( 'Safe minimum' )
135 safe1 = (nz+1)*safe1
136
137 DO j = 1, nrhs
138 berr(j) = 0.0d+0
139 DO i = 1, n
140 IF (ayb(i,j) .NE. 0.0d+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 DLA_LIN_BERR
152*

◆ dla_wwaddw()

subroutine dla_wwaddw ( integer n,
double precision, dimension( * ) x,
double precision, dimension( * ) y,
double precision, dimension( * ) w )

DLA_WWADDW adds a vector into a doubled-single vector.

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

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

◆ dlals0()

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

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

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

Purpose:
!>
!> DLALS0 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension ( LDBX, NRHS )
!>
[in]LDBX
!>          LDBX is INTEGER
!>         The leading dimension of BX.
!>
[in]PERM
!>          PERM is INTEGER array, dimension ( N )
!>         The permutations (from deflation and sorting) applied
!>         to the two blocks.
!>
[in]GIVPTR
!>          GIVPTR is INTEGER
!>         The number of Givens rotations which took place in this
!>         subproblem.
!>
[in]GIVCOL
!>          GIVCOL is INTEGER array, dimension ( LDGCOL, 2 )
!>         Each pair of numbers indicates a pair of rows/columns
!>         involved in a Givens rotation.
!>
[in]LDGCOL
!>          LDGCOL is INTEGER
!>         The leading dimension of GIVCOL, must be at least N.
!>
[in]GIVNUM
!>          GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
!>         Each number indicates the C or S value used in the
!>         corresponding Givens rotation.
!>
[in]LDGNUM
!>          LDGNUM is INTEGER
!>         The leading dimension of arrays DIFR, POLES and
!>         GIVNUM, must be at least K.
!>
[in]POLES
!>          POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
!>         On entry, POLES(1:K, 1) contains the new singular
!>         values obtained from solving the secular equation, and
!>         POLES(1:K, 2) is an array containing the poles in the secular
!>         equation.
!>
[in]DIFL
!>          DIFL is DOUBLE PRECISION array, dimension ( K ).
!>         On entry, DIFL(I) is the distance between I-th updated
!>         (undeflated) singular value and the I-th (undeflated) old
!>         singular value.
!>
[in]DIFR
!>          DIFR is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
!>         On entry, DIFR(I, 1) contains the distances between I-th
!>         updated (undeflated) singular value and the I+1-th
!>         (undeflated) old singular value. And DIFR(I, 2) is the
!>         normalizing factor for the I-th right singular vector.
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension ( K )
!>         Contain the components of the deflation-adjusted updating row
!>         vector.
!>
[in]K
!>          K is INTEGER
!>         Contains the dimension of the non-deflated matrix,
!>         This is the order of the related secular equation. 1 <= K <=N.
!>
[in]C
!>          C is DOUBLE PRECISION
!>         C contains garbage if SQRE =0 and the C-value of a Givens
!>         rotation related to the right null space if SQRE = 1.
!>
[in]S
!>          S is DOUBLE PRECISION
!>         S contains garbage if SQRE =0 and the S-value of a Givens
!>         rotation related to the right null space if SQRE = 1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dlals0.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 DOUBLE PRECISION C, S
277* ..
278* .. Array Arguments ..
279 INTEGER GIVCOL( LDGCOL, * ), PERM( * )
280 DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ),
281 $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
282 $ POLES( LDGNUM, * ), WORK( * ), Z( * )
283* ..
284*
285* =====================================================================
286*
287* .. Parameters ..
288 DOUBLE PRECISION ONE, ZERO, NEGONE
289 parameter( one = 1.0d0, zero = 0.0d0, negone = -1.0d0 )
290* ..
291* .. Local Scalars ..
292 INTEGER I, J, M, N, NLP1
293 DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
294* ..
295* .. External Subroutines ..
296 EXTERNAL dcopy, dgemv, dlacpy, dlascl, drot, dscal,
297 $ xerbla
298* ..
299* .. External Functions ..
300 DOUBLE PRECISION DLAMC3, DNRM2
301 EXTERNAL dlamc3, dnrm2
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( 'DLALS0', -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 drot( 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 dcopy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx )
359 DO 20 i = 2, n
360 CALL dcopy( 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 dcopy( nrhs, bx, ldbx, b, ldb )
368 IF( z( 1 ).LT.zero ) THEN
369 CALL dscal( 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 $ ( dlamc3( 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 $ ( dlamc3( poles( i, 2 ), dsigjp )+
404 $ difrj ) / ( poles( i, 2 )+dj )
405 END IF
406 40 CONTINUE
407 work( 1 ) = negone
408 temp = dnrm2( k, work, 1 )
409 CALL dgemv( 'T', k, nrhs, one, bx, ldbx, work, 1, zero,
410 $ b( j, 1 ), ldb )
411 CALL dlascl( '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 dlacpy( '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 dcopy( 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 ) / ( dlamc3( 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 ) / ( dlamc3( dsigj, -poles( i,
453 $ 2 ) )-difl( i ) ) /
454 $ ( dsigj+poles( i, 1 ) ) / difr( i, 2 )
455 END IF
456 70 CONTINUE
457 CALL dgemv( '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 dcopy( nrhs, b( m, 1 ), ldb, bx( m, 1 ), ldbx )
467 CALL drot( nrhs, bx( 1, 1 ), ldbx, bx( m, 1 ), ldbx, c, s )
468 END IF
469 IF( k.LT.max( m, n ) )
470 $ CALL dlacpy( '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 dcopy( nrhs, bx( 1, 1 ), ldbx, b( nlp1, 1 ), ldb )
476 IF( sqre.EQ.1 ) THEN
477 CALL dcopy( nrhs, bx( m, 1 ), ldbx, b( m, 1 ), ldb )
478 END IF
479 DO 90 i = 2, n
480 CALL dcopy( 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 drot( 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 DLALS0
495*
dlamc3
double precision function dlamc3(a, b)
DLAMC3
Definition dlamch.f:169

◆ dlalsa()

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

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

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

Purpose:
!>
!> DLALSA 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, DLALSA applies the inverse of the left singular vector
!> matrix of an upper bidiagonal matrix to the right hand side; and if
!> ICOMPQ = 1, DLALSA applies the right singular vector matrix to the
!> right hand side. The singular vector matrices were generated in
!> compact form by DLALSA.
!>
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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension ( LDBX, NRHS )
!>         On exit, the result of applying the left or right singular
!>         vector matrix to B.
!>
[in]LDBX
!>          LDBX is INTEGER
!>         The leading dimension of BX.
!>
[in]U
!>          U is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
!>         On entry, U contains the left singular vector matrices of all
!>         subproblems at the bottom level.
!>
[in]LDU
!>          LDU is INTEGER, LDU = > N.
!>         The leading dimension of arrays U, VT, DIFL, DIFR,
!>         POLES, GIVNUM, and Z.
!>
[in]VT
!>          VT is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
!>         On entry, VT**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 DOUBLE PRECISION array, dimension ( LDU, NLVL ).
!>         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
!>
[in]DIFR
!>          DIFR is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
!>         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
!>         distances between singular values on the I-th level and
!>         singular values on the (I -1)-th level, and DIFR(*, 2 * I)
!>         record the normalizing factors of the right singular vectors
!>         matrices of subproblems on I-th level.
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension ( LDU, NLVL ).
!>         On entry, Z(1, I) contains the components of the deflation-
!>         adjusted updating row vector for subproblems on the I-th
!>         level.
!>
[in]POLES
!>          POLES is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
!>         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
!>         singular values involved in the secular equations on the I-th
!>         level.
!>
[in]GIVPTR
!>          GIVPTR is INTEGER array, dimension ( N ).
!>         On entry, GIVPTR( I ) records the number of Givens
!>         rotations performed on the I-th problem on the computation
!>         tree.
!>
[in]GIVCOL
!>          GIVCOL is INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
!>         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
!>         locations of Givens rotations performed on the I-th level on
!>         the computation tree.
!>
[in]LDGCOL
!>          LDGCOL is INTEGER, LDGCOL = > N.
!>         The leading dimension of arrays GIVCOL and PERM.
!>
[in]PERM
!>          PERM is INTEGER array, dimension ( LDGCOL, NLVL ).
!>         On entry, PERM(*, I) records permutations done on the I-th
!>         level of the computation tree.
!>
[in]GIVNUM
!>          GIVNUM is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
!>         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
!>         values of Givens rotations performed on the I-th level on the
!>         computation tree.
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension ( N ).
!>         On entry, if the I-th subproblem is not square,
!>         C( I ) contains the C-value of a Givens rotation related to
!>         the right null space of the I-th subproblem.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension ( N ).
!>         On entry, if the I-th subproblem is not square,
!>         S( I ) contains the S-value of a Givens rotation related to
!>         the right null space of the I-th subproblem.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dlalsa.f.

267*
268* -- LAPACK computational routine --
269* -- LAPACK is a software package provided by Univ. of Tennessee, --
270* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
271*
272* .. Scalar Arguments ..
273 INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
274 $ SMLSIZ
275* ..
276* .. Array Arguments ..
277 INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
278 $ K( * ), PERM( LDGCOL, * )
279 DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, ONE
290 parameter( zero = 0.0d0, one = 1.0d0 )
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 dcopy, dgemm, dlals0, dlasdt, 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( 'DLALSA', -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 dlasdt( 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 DLASDQ. 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 dgemm( 'T', 'N', nl, nrhs, nl, one, u( nlf, 1 ), ldu,
365 $ b( nlf, 1 ), ldb, zero, bx( nlf, 1 ), ldbx )
366 CALL dgemm( '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 dcopy( 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 dlals0( 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 dlals0( 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 DLASDQ. 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 dgemm( 'T', 'N', nlp1, nrhs, nlp1, one, vt( nlf, 1 ), ldu,
479 $ b( nlf, 1 ), ldb, zero, bx( nlf, 1 ), ldbx )
480 CALL dgemm( '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 DLALSA
489*
dlasdt
subroutine dlasdt(n, lvl, nd, inode, ndiml, ndimr, msub)
DLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc.
Definition dlasdt.f:105
dlals0
subroutine dlals0(icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx, perm, givptr, givcol, ldgcol, givnum, ldgnum, poles, difl, difr, z, k, c, s, work, info)
DLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer...
Definition dlals0.f:268

◆ dlalsd()

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

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

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

Purpose:
!>
!> DLALSD uses the singular value decomposition of A to solve the least
!> squares problem of finding X to minimize the Euclidean norm of each
!> column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
!> are N-by-NRHS. The solution X overwrites B.
!>
!> The singular values of A smaller than RCOND times the largest
!> singular value are treated as zero in solving the least squares
!> problem; in this case a minimum norm solution is returned.
!> The actual singular values are returned in D in ascending order.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>         = 'U': D and E define an upper bidiagonal matrix.
!>         = 'L': D and E define a  lower bidiagonal matrix.
!>
[in]SMLSIZ
!>          SMLSIZ is INTEGER
!>         The maximum size of the subproblems at the bottom of the
!>         computation tree.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the  bidiagonal matrix.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>         The number of columns of B. NRHS must be at least 1.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>         On entry D contains the main diagonal of the bidiagonal
!>         matrix. On exit, if INFO = 0, D contains its singular values.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>         Contains the super-diagonal entries of the bidiagonal matrix.
!>         On exit, E has been destroyed.
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>         On input, B contains the right hand sides of the least
!>         squares problem. On output, B contains the solution X.
!>
[in]LDB
!>          LDB is INTEGER
!>         The leading dimension of B in the calling subprogram.
!>         LDB must be at least max(1,N).
!>
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>         The singular values of A less than or equal to RCOND times
!>         the largest singular value are treated as zero in solving
!>         the least squares problem. If RCOND is negative,
!>         machine precision is used instead.
!>         For example, if diag(S)*X=B were the least squares problem,
!>         where diag(S) is a diagonal matrix of singular values, the
!>         solution would be X(i) = B(i) / S(i) if S(i) is greater than
!>         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
!>         RCOND*max(S).
!>
[out]RANK
!>          RANK is INTEGER
!>         The number of singular values of A greater than RCOND times
!>         the largest singular value.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dlalsd.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 DOUBLE PRECISION RCOND
188* ..
189* .. Array Arguments ..
190 INTEGER IWORK( * )
191 DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * )
192* ..
193*
194* =====================================================================
195*
196* .. Parameters ..
197 DOUBLE PRECISION ZERO, ONE, TWO
198 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
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 DOUBLE PRECISION CS, EPS, ORGNRM, R, RCND, SN, TOL
206* ..
207* .. External Functions ..
208 INTEGER IDAMAX
209 DOUBLE PRECISION DLAMCH, DLANST
210 EXTERNAL idamax, dlamch, dlanst
211* ..
212* .. External Subroutines ..
213 EXTERNAL dcopy, dgemm, dlacpy, dlalsa, dlartg, dlascl,
214 $ dlasda, dlasdq, dlaset, dlasrt, drot, xerbla
215* ..
216* .. Intrinsic Functions ..
217 INTRINSIC abs, dble, int, log, 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( 'DLALSD', -info )
234 RETURN
235 END IF
236*
237 eps = dlamch( '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 dlaset( 'A', 1, nrhs, zero, zero, b, ldb )
256 ELSE
257 rank = 1
258 CALL dlascl( '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 dlartg( 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 drot( 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 drot( 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 = dlanst( 'M', n, d, e )
294 IF( orgnrm.EQ.zero ) THEN
295 CALL dlaset( 'A', n, nrhs, zero, zero, b, ldb )
296 RETURN
297 END IF
298*
299 CALL dlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info )
300 CALL dlascl( '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 dlaset( 'A', n, n, zero, one, work, n )
308 CALL dlasdq( '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( idamax( n, d, 1 ) ) )
314 DO 40 i = 1, n
315 IF( d( i ).LE.tol ) THEN
316 CALL dlaset( 'A', 1, nrhs, zero, zero, b( i, 1 ), ldb )
317 ELSE
318 CALL dlascl( '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 dgemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero,
324 $ work( nwork ), n )
325 CALL dlacpy( 'A', n, nrhs, work( nwork ), n, b, ldb )
326*
327* Unscale.
328*
329 CALL dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info )
330 CALL dlasrt( 'D', n, d, info )
331 CALL dlascl( '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( dble( n ) / dble( 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 dcopy( 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 dcopy( 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 DLASDQ.
416*
417 CALL dlaset( 'A', nsize, nsize, zero, one,
418 $ work( vt+st1 ), n )
419 CALL dlasdq( '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 dlacpy( '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 dlasda( 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 dlalsa( 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( idamax( 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 dlaset( 'A', 1, nrhs, zero, zero, work( bx+i-1 ), n )
472 ELSE
473 rank = rank + 1
474 CALL dlascl( '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 dcopy( nrhs, work( bxst ), n, b( st, 1 ), ldb )
490 ELSE IF( nsize.LE.smlsiz ) THEN
491 CALL dgemm( 'T', 'N', nsize, nrhs, nsize, one,
492 $ work( vt+st1 ), n, work( bxst ), n, zero,
493 $ b( st, 1 ), ldb )
494 ELSE
495 CALL dlalsa( 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 dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info )
513 CALL dlasrt( 'D', n, d, info )
514 CALL dlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info )
515*
516 RETURN
517*
518* End of DLALSD
519*
dlasdq
subroutine dlasdq(uplo, sqre, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e....
Definition dlasdq.f:211
dlanst
double precision function dlanst(norm, n, d, e)
DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlanst.f:100
dlasda
subroutine dlasda(icompq, smlsiz, n, sqre, d, e, u, ldu, vt, k, difl, difr, z, poles, givptr, givcol, ldgcol, perm, givnum, c, s, work, iwork, info)
DLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagona...
Definition dlasda.f:273
dlasrt
subroutine dlasrt(id, n, d, info)
DLASRT sorts numbers in increasing or decreasing order.
Definition dlasrt.f:88
dlalsa
subroutine dlalsa(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)
DLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd.
Definition dlalsa.f:267

◆ dlansf()

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

DLANSF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix in RFP format.

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

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

◆ dlarscl2()

subroutine dlarscl2 ( integer m,
integer n,
double precision, dimension( * ) d,
double precision, dimension( ldx, * ) x,
integer ldx )

DLARSCL2 performs reciprocal diagonal scaling on a vector.

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

Purpose:
!>
!> DLARSCL2 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_dge_diag_scale in the new BLAS
!> standard.
!>
Parameters
[in]M
!>          M is INTEGER
!>     The number of rows of D and X. M >= 0.
!>
[in]N
!>          N is INTEGER
!>     The number of columns of X. N >= 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (M)
!>     Diagonal matrix D, stored as a vector of length M.
!>
[in,out]X
!>          X is DOUBLE PRECISION 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 dlarscl2.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 DOUBLE PRECISION 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

◆ dlarz()

subroutine dlarz ( character side,
integer m,
integer n,
integer l,
double precision, dimension( * ) v,
integer incv,
double precision tau,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) work )

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

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

Purpose:
!>
!> DLARZ 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 DTZRZF.
!>
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 DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))
!>          The vector v in the representation of H as returned by
!>          DTZRZF. V is not used if TAU = 0.
!>
[in]INCV
!>          INCV is INTEGER
!>          The increment between elements of v. INCV <> 0.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION
!>          The value tau in the representation of H.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by 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 DOUBLE PRECISION 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 dlarz.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 DOUBLE PRECISION TAU
154* ..
155* .. Array Arguments ..
156 DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 DOUBLE PRECISION ONE, ZERO
163 parameter( one = 1.0d+0, zero = 0.0d+0 )
164* ..
165* .. External Subroutines ..
166 EXTERNAL daxpy, dcopy, dgemv, dger
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 dcopy( 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 dgemv( '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 daxpy( 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 dger( 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 dcopy( 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 dgemv( '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 daxpy( 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 dger( 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 DLARZ
232*
dger
subroutine dger(m, n, alpha, x, incx, y, incy, a, lda)
DGER
Definition dger.f:130

◆ dlarzb()

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

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

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

Purpose:
!>
!> DLARZB 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dlarzb.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 DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
194 $ WORK( LDWORK, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 DOUBLE PRECISION ONE
201 parameter( one = 1.0d+0 )
202* ..
203* .. Local Scalars ..
204 CHARACTER TRANST
205 INTEGER I, INFO, J
206* ..
207* .. External Functions ..
208 LOGICAL LSAME
209 EXTERNAL lsame
210* ..
211* .. External Subroutines ..
212 EXTERNAL dcopy, dgemm, dtrmm, 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( 'DLARZB', -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 dcopy( 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 dgemm( '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 dtrmm( '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 dgemm( '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 dcopy( 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 dgemm( '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 dtrmm( '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 dgemm( '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 DLARZB
319*
dtrmm
subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRMM
Definition dtrmm.f:177

◆ dlarzt()

subroutine dlarzt ( character direct,
character storev,
integer n,
integer k,
double precision, dimension( ldv, * ) v,
integer ldv,
double precision, dimension( * ) tau,
double precision, dimension( ldt, * ) t,
integer ldt )

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

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

Purpose:
!>
!> DLARZT 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i).
!>
[out]T
!>          T is DOUBLE PRECISION 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 dlarzt.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 DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
196* ..
197*
198* =====================================================================
199*
200* .. Parameters ..
201 DOUBLE PRECISION ZERO
202 parameter( zero = 0.0d+0 )
203* ..
204* .. Local Scalars ..
205 INTEGER I, INFO, J
206* ..
207* .. External Subroutines ..
208 EXTERNAL dgemv, dtrmv, 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( 'DLARZT', -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 dgemv( '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 dtrmv( '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 DLARZT
260*

◆ dlascl2()

subroutine dlascl2 ( integer m,
integer n,
double precision, dimension( * ) d,
double precision, dimension( ldx, * ) x,
integer ldx )

DLASCL2 performs diagonal scaling on a vector.

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

Purpose:
!>
!> DLASCL2 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_dge_diag_scale in the new BLAS
!> standard.
!>
Parameters
[in]M
!>          M is INTEGER
!>     The number of rows of D and X. M >= 0.
!>
[in]N
!>          N is INTEGER
!>     The number of columns of X. N >= 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, length M
!>     Diagonal matrix D, stored as a vector of length M.
!>
[in,out]X
!>          X is DOUBLE PRECISION 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 dlascl2.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 DOUBLE PRECISION 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

◆ dlatrz()

subroutine dlatrz ( integer m,
integer n,
integer l,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work )

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

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

Purpose:
!>
!> DLATRZ 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (M)
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dlatrz.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
150* ..
151*
152* =====================================================================
153*
154* .. Parameters ..
155 DOUBLE PRECISION ZERO
156 parameter( zero = 0.0d+0 )
157* ..
158* .. Local Scalars ..
159 INTEGER I
160* ..
161* .. External Subroutines ..
162 EXTERNAL dlarfg, dlarz
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 dlarfg( 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 dlarz( '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 DLATRZ
196*
dlarfg
subroutine dlarfg(n, alpha, x, incx, tau)
DLARFG generates an elementary reflector (Householder matrix).
Definition dlarfg.f:106
dlarz
subroutine dlarz(side, m, n, l, v, incv, tau, c, ldc, work)
DLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix.
Definition dlarz.f:145

◆ dlatzm()

subroutine dlatzm ( character side,
integer m,
integer n,
double precision, dimension( * ) v,
integer incv,
double precision tau,
double precision, dimension( ldc, * ) c1,
double precision, dimension( ldc, * ) c2,
integer ldc,
double precision, dimension( * ) work )

DLATZM

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine DORMRZ.
!>
!> DLATZM applies a Householder matrix generated by DTZRQF 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 DOUBLE PRECISION 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 DOUBLE PRECISION
!>          The value tau in the representation of P.
!>
[in,out]C1
!>          C1 is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dlatzm.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 DOUBLE PRECISION TAU
160* ..
161* .. Array Arguments ..
162 DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 DOUBLE PRECISION ONE, ZERO
169 parameter( one = 1.0d+0, zero = 0.0d+0 )
170* ..
171* .. External Subroutines ..
172 EXTERNAL daxpy, dcopy, dgemv, dger
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 dcopy( n, c1, ldc, work, 1 )
191 CALL dgemv( '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 daxpy( n, -tau, work, 1, c1, ldc )
198 CALL dger( 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 dcopy( m, c1, 1, work, 1 )
205 CALL dgemv( '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 daxpy( m, -tau, work, 1, c1, 1 )
211 CALL dger( m, n-1, -tau, work, 1, v, incv, c2, ldc )
212 END IF
213*
214 RETURN
215*
216* End of DLATZM
217*

◆ dopgtr()

subroutine dopgtr ( character uplo,
integer n,
double precision, dimension( * ) ap,
double precision, dimension( * ) tau,
double precision, dimension( ldq, * ) q,
integer ldq,
double precision, dimension( * ) work,
integer info )

DOPGTR

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

Purpose:
!>
!> DOPGTR 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
!> DSPTRD 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 DSPTRD;
!>          = 'L': Lower triangular packed storage used in previous
!>                 call to DSPTRD.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix Q. N >= 0.
!>
[in]AP
!>          AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The vectors which define the elementary reflectors, as
!>          returned by DSPTRD.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DSPTRD.
!>
[out]Q
!>          Q is DOUBLE PRECISION 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 DOUBLE PRECISION 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 dopgtr.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 DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 DOUBLE PRECISION ZERO, ONE
131 parameter( zero = 0.0d+0, one = 1.0d+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 dorg2l, dorg2r, 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( 'DOPGTR', -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 DSPTRD 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 dorg2l( n-1, n-1, n-1, q, ldq, tau, work, iinfo )
195*
196 ELSE
197*
198* Q was determined by a call to DSPTRD 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 dorg2r( 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 DOPGTR
228*
dorg2l
subroutine dorg2l(m, n, k, a, lda, tau, work, info)
DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf ...
Definition dorg2l.f:114

◆ dopmtr()

subroutine dopmtr ( character side,
character uplo,
character trans,
integer m,
integer n,
double precision, dimension( * ) ap,
double precision, dimension( * ) tau,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) work,
integer info )

DOPMTR

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

Purpose:
!>
!> DOPMTR 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 DSPTRD 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 DSPTRD;
!>          = 'L': Lower triangular packed storage used in previous
!>                 call to DSPTRD.
!>
[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 DOUBLE PRECISION 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 DSPTRD.  AP is modified by the routine but
!>          restored on exit.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION 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 DSPTRD.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                                   (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 dopmtr.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 DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 DOUBLE PRECISION ONE
167 parameter( one = 1.0d+0 )
168* ..
169* .. Local Scalars ..
170 LOGICAL FORWRD, LEFT, NOTRAN, UPPER
171 INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ
172 DOUBLE PRECISION AII
173* ..
174* .. External Functions ..
175 LOGICAL LSAME
176 EXTERNAL lsame
177* ..
178* .. External Subroutines ..
179 EXTERNAL dlarf, 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( 'DOPMTR', -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 DSPTRD 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 dlarf( 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 DSPTRD 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 dlarf( 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 DOPMTR
335*
dlarf
subroutine dlarf(side, m, n, v, incv, tau, c, ldc, work)
DLARF applies an elementary reflector to a general rectangular matrix.
Definition dlarf.f:124
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ dorbdb()

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

DORBDB

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

Purpose:
!>
!> DORBDB 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 DORCSD
!> 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (Q)
!>          The entries of the bidiagonal blocks B11, B12, B21, B22 can
!>          be computed from the angles THETA and PHI. See Further
!>          Details.
!>
[out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>          The entries of the bidiagonal blocks B11, B12, B21, B22 can
!>          be computed from the angles THETA and PHI. See Further
!>          Details.
!>
[out]TAUP1
!>          TAUP1 is DOUBLE PRECISION array, dimension (P)
!>          The scalar factors of the elementary reflectors that define
!>          P1.
!>
[out]TAUP2
!>          TAUP2 is DOUBLE PRECISION array, dimension (M-P)
!>          The scalar factors of the elementary reflectors that define
!>          P2.
!>
[out]TAUQ1
!>          TAUQ1 is DOUBLE PRECISION array, dimension (Q)
!>          The scalar factors of the elementary reflectors that define
!>          Q1.
!>
[out]TAUQ2
!>          TAUQ2 is DOUBLE PRECISION array, dimension (M-Q)
!>          The scalar factors of the elementary reflectors that define
!>          Q2.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 DORCSD for details.
!>
!>  P1, P2, Q1, and Q2 are represented as products of elementary
!>  reflectors. See DORCSD for details on generating P1, P2, Q1, and Q2
!>  using DORGQR and DORGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 284 of file dorbdb.f.

287*
288* -- LAPACK computational routine --
289* -- LAPACK is a software package provided by Univ. of Tennessee, --
290* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
291*
292* .. Scalar Arguments ..
293 CHARACTER SIGNS, TRANS
294 INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P,
295 $ Q
296* ..
297* .. Array Arguments ..
298 DOUBLE PRECISION PHI( * ), THETA( * )
299 DOUBLE PRECISION TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ),
300 $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ),
301 $ X21( LDX21, * ), X22( LDX22, * )
302* ..
303*
304* ====================================================================
305*
306* .. Parameters ..
307 DOUBLE PRECISION REALONE
308 parameter( realone = 1.0d0 )
309 DOUBLE PRECISION ONE
310 parameter( one = 1.0d0 )
311* ..
312* .. Local Scalars ..
313 LOGICAL COLMAJOR, LQUERY
314 INTEGER I, LWORKMIN, LWORKOPT
315 DOUBLE PRECISION Z1, Z2, Z3, Z4
316* ..
317* .. External Subroutines ..
318 EXTERNAL daxpy, dlarf, dlarfgp, dscal, xerbla
319* ..
320* .. External Functions ..
321 DOUBLE PRECISION DNRM2
322 LOGICAL LSAME
323 EXTERNAL dnrm2, 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 dscal( p-i+1, z1, x11(i,i), 1 )
399 ELSE
400 CALL dscal( p-i+1, z1*cos(phi(i-1)), x11(i,i), 1 )
401 CALL daxpy( 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 dscal( m-p-i+1, z2, x21(i,i), 1 )
406 ELSE
407 CALL dscal( m-p-i+1, z2*cos(phi(i-1)), x21(i,i), 1 )
408 CALL daxpy( 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( dnrm2( m-p-i+1, x21(i,i), 1 ),
413 $ dnrm2( p-i+1, x11(i,i), 1 ) )
414*
415 IF( p .GT. i ) THEN
416 CALL dlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
417 ELSE IF( p .EQ. i ) THEN
418 CALL dlarfgp( 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 dlarfgp( 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 dlarfgp( 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 dlarf( '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 dlarf( '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 dlarf( '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 dlarf( '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 dscal( q-i, -z1*z3*sin(theta(i)), x11(i,i+1),
448 $ ldx11 )
449 CALL daxpy( q-i, z2*z3*cos(theta(i)), x21(i,i+1), ldx21,
450 $ x11(i,i+1), ldx11 )
451 END IF
452 CALL dscal( m-q-i+1, -z1*z4*sin(theta(i)), x12(i,i), ldx12 )
453 CALL daxpy( 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( dnrm2( q-i, x11(i,i+1), ldx11 ),
458 $ dnrm2( m-q-i+1, x12(i,i), ldx12 ) )
459*
460 IF( i .LT. q ) THEN
461 IF ( q-i .EQ. 1 ) THEN
462 CALL dlarfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,
463 $ tauq1(i) )
464 ELSE
465 CALL dlarfgp( 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 dlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,
473 $ tauq2(i) )
474 ELSE
475 CALL dlarfgp( 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 dlarf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),
483 $ x11(i+1,i+1), ldx11, work )
484 CALL dlarf( '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 dlarf( '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 dlarf( '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 dscal( m-q-i+1, -z1*z4, x12(i,i), ldx12 )
503 IF ( i .GE. m-q ) THEN
504 CALL dlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,
505 $ tauq2(i) )
506 ELSE
507 CALL dlarfgp( 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 dlarf( '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 dlarf( '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 dscal( m-p-q-i+1, z2*z4, x22(q+i,p+i), ldx22 )
527 IF ( i .EQ. m-p-q ) THEN
528 CALL dlarfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i),
529 $ ldx22, tauq2(p+i) )
530 ELSE
531 CALL dlarfgp( 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 dlarf( '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 dscal( p-i+1, z1, x11(i,i), ldx11 )
550 ELSE
551 CALL dscal( p-i+1, z1*cos(phi(i-1)), x11(i,i), ldx11 )
552 CALL daxpy( 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 dscal( m-p-i+1, z2, x21(i,i), ldx21 )
557 ELSE
558 CALL dscal( m-p-i+1, z2*cos(phi(i-1)), x21(i,i), ldx21 )
559 CALL daxpy( 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( dnrm2( m-p-i+1, x21(i,i), ldx21 ),
564 $ dnrm2( p-i+1, x11(i,i), ldx11 ) )
565*
566 CALL dlarfgp( 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 dlarfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,
570 $ taup2(i) )
571 ELSE
572 CALL dlarfgp( 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 dlarf( '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 dlarf( '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 dlarf( '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 dlarf( '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 dscal( q-i, -z1*z3*sin(theta(i)), x11(i+1,i), 1 )
596 CALL daxpy( q-i, z2*z3*cos(theta(i)), x21(i+1,i), 1,
597 $ x11(i+1,i), 1 )
598 END IF
599 CALL dscal( m-q-i+1, -z1*z4*sin(theta(i)), x12(i,i), 1 )
600 CALL daxpy( 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( dnrm2( q-i, x11(i+1,i), 1 ),
605 $ dnrm2( m-q-i+1, x12(i,i), 1 ) )
606*
607 IF( i .LT. q ) THEN
608 IF ( q-i .EQ. 1) THEN
609 CALL dlarfgp( q-i, x11(i+1,i), x11(i+1,i), 1,
610 $ tauq1(i) )
611 ELSE
612 CALL dlarfgp( 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 dlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1,
619 $ tauq2(i) )
620 ELSE
621 CALL dlarfgp( 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 dlarf( 'L', q-i, p-i, x11(i+1,i), 1, tauq1(i),
628 $ x11(i+1,i+1), ldx11, work )
629 CALL dlarf( '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 dlarf( '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 dlarf( '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 dscal( m-q-i+1, -z1*z4, x12(i,i), 1 )
646 CALL dlarfgp( 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 dlarf( '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 dlarf( '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 dscal( m-p-q-i+1, z2*z4, x22(p+i,q+i), 1 )
664 IF ( m-p-q .EQ. i ) THEN
665 CALL dlarfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i,q+i), 1,
666 $ tauq2(p+i) )
667 ELSE
668 CALL dlarfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1,
669 $ tauq2(p+i) )
670 CALL dlarf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1,
671 $ tauq2(p+i), x22(p+i,q+i+1), ldx22, work )
672 END IF
673 x22(p+i,q+i) = one
674*
675 END DO
676*
677 END IF
678*
679 RETURN
680*
681* End of DORBDB
682*
dlarfgp
subroutine dlarfgp(n, alpha, x, incx, tau)
DLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.
Definition dlarfgp.f:104

◆ dorbdb1()

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

DORBDB1

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

Purpose:
!>
!> DORBDB1 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 DORBDB2, DORBDB3, and DORBDB4 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX21,Q)
!>           On entry, the bottom block of the matrix X to be reduced. On
!>           exit, the columns of tril(X21) specify reflectors for P2.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>           The leading dimension of X21. LDX21 >= M-P.
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]TAUP1
!>          TAUP1 is DOUBLE PRECISION array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is DOUBLE PRECISION array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is DOUBLE PRECISION array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 DORCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
!>  and DORGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 201 of file dorbdb1.f.

203*
204* -- LAPACK computational routine --
205* -- LAPACK is a software package provided by Univ. of Tennessee, --
206* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
207*
208* .. Scalar Arguments ..
209 INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
210* ..
211* .. Array Arguments ..
212 DOUBLE PRECISION PHI(*), THETA(*)
213 DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
214 $ X11(LDX11,*), X21(LDX21,*)
215* ..
216*
217* ====================================================================
218*
219* .. Parameters ..
220 DOUBLE PRECISION ONE
221 parameter( one = 1.0d0 )
222* ..
223* .. Local Scalars ..
224 DOUBLE PRECISION C, S
225 INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
226 $ LWORKMIN, LWORKOPT
227 LOGICAL LQUERY
228* ..
229* .. External Subroutines ..
230 EXTERNAL dlarf, dlarfgp, dorbdb5, drot, xerbla
231* ..
232* .. External Functions ..
233 DOUBLE PRECISION DNRM2
234 EXTERNAL dnrm2
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( 'DORBDB1', -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 dlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) )
284 CALL dlarfgp( 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 dlarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),
291 $ ldx11, work(ilarf) )
292 CALL dlarf( '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 drot( q-i, x11(i,i+1), ldx11, x21(i,i+1), ldx21, c, s )
297 CALL dlarfgp( 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 dlarf( 'R', p-i, q-i, x21(i,i+1), ldx21, tauq1(i),
301 $ x11(i+1,i+1), ldx11, work(ilarf) )
302 CALL dlarf( '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( dnrm2( p-i, x11(i+1,i+1), 1 )**2
305 $ + dnrm2( m-p-i, x21(i+1,i+1), 1 )**2 )
306 phi(i) = atan2( s, c )
307 CALL dorbdb5( 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 DORBDB1
318*
dorbdb5
subroutine dorbdb5(m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2, work, lwork, info)
DORBDB5
Definition dorbdb5.f:156

◆ dorbdb2()

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

DORBDB2

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

Purpose:
!>
!> DORBDB2 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 DORBDB1, DORBDB3, and DORBDB4 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX21,Q)
!>           On entry, the bottom block of the matrix X to be reduced. On
!>           exit, the columns of tril(X21) specify reflectors for P2.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>           The leading dimension of X21. LDX21 >= M-P.
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]TAUP1
!>          TAUP1 is DOUBLE PRECISION array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is DOUBLE PRECISION array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is DOUBLE PRECISION array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 DORCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
!>  and DORGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 200 of file dorbdb2.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 DOUBLE PRECISION PHI(*), THETA(*)
212 DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
213 $ X11(LDX11,*), X21(LDX21,*)
214* ..
215*
216* ====================================================================
217*
218* .. Parameters ..
219 DOUBLE PRECISION NEGONE, ONE
220 parameter( negone = -1.0d0, one = 1.0d0 )
221* ..
222* .. Local Scalars ..
223 DOUBLE PRECISION C, S
224 INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
225 $ LWORKMIN, LWORKOPT
226 LOGICAL LQUERY
227* ..
228* .. External Subroutines ..
229 EXTERNAL dlarf, dlarfgp, dorbdb5, drot, dscal, xerbla
230* ..
231* .. External Functions ..
232 DOUBLE PRECISION DNRM2
233 EXTERNAL dnrm2
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( p .LT. 0 .OR. p .GT. m-p ) THEN
248 info = -2
249 ELSE IF( q .LT. 0 .OR. q .LT. p .OR. m-q .LT. 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-1, m-p, 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( 'DORBDB2', -info )
273 RETURN
274 ELSE IF( lquery ) THEN
275 RETURN
276 END IF
277*
278* Reduce rows 1, ..., P of X11 and X21
279*
280 DO i = 1, p
281*
282 IF( i .GT. 1 ) THEN
283 CALL drot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c, s )
284 END IF
285 CALL dlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) )
286 c = x11(i,i)
287 x11(i,i) = one
288 CALL dlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),
289 $ x11(i+1,i), ldx11, work(ilarf) )
290 CALL dlarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),
291 $ x21(i,i), ldx21, work(ilarf) )
292 s = sqrt( dnrm2( p-i, x11(i+1,i), 1 )**2
293 $ + dnrm2( m-p-i+1, x21(i,i), 1 )**2 )
294 theta(i) = atan2( s, c )
295*
296 CALL dorbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,
297 $ x11(i+1,i+1), ldx11, x21(i,i+1), ldx21,
298 $ work(iorbdb5), lorbdb5, childinfo )
299 CALL dscal( p-i, negone, x11(i+1,i), 1 )
300 CALL dlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
301 IF( i .LT. p ) THEN
302 CALL dlarfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) )
303 phi(i) = atan2( x11(i+1,i), x21(i,i) )
304 c = cos( phi(i) )
305 s = sin( phi(i) )
306 x11(i+1,i) = one
307 CALL dlarf( 'L', p-i, q-i, x11(i+1,i), 1, taup1(i),
308 $ x11(i+1,i+1), ldx11, work(ilarf) )
309 END IF
310 x21(i,i) = one
311 CALL dlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),
312 $ x21(i,i+1), ldx21, work(ilarf) )
313*
314 END DO
315*
316* Reduce the bottom-right portion of X21 to the identity matrix
317*
318 DO i = p + 1, q
319 CALL dlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) )
320 x21(i,i) = one
321 CALL dlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),
322 $ x21(i,i+1), ldx21, work(ilarf) )
323 END DO
324*
325 RETURN
326*
327* End of DORBDB2
328*

◆ dorbdb3()

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

DORBDB3

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

Purpose:
!>
!> DORBDB3 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 DORBDB1, DORBDB2, and DORBDB4 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX21,Q)
!>           On entry, the bottom block of the matrix X to be reduced. On
!>           exit, the columns of tril(X21) specify reflectors for P2.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>           The leading dimension of X21. LDX21 >= M-P.
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]TAUP1
!>          TAUP1 is DOUBLE PRECISION array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is DOUBLE PRECISION array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is DOUBLE PRECISION array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 DORCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
!>  and DORGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 199 of file dorbdb3.f.

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

◆ dorbdb4()

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

DORBDB4

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

Purpose:
!>
!> DORBDB4 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 DORBDB1, DORBDB2, and DORBDB3 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX21,Q)
!>           On entry, the bottom block of the matrix X to be reduced. On
!>           exit, the columns of tril(X21) specify reflectors for P2.
!>
[in]LDX21
!>          LDX21 is INTEGER
!>           The leading dimension of X21. LDX21 >= M-P.
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (Q)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]PHI
!>          PHI is DOUBLE PRECISION array, dimension (Q-1)
!>           The entries of the bidiagonal blocks B11, B21 are defined by
!>           THETA and PHI. See Further Details.
!>
[out]TAUP1
!>          TAUP1 is DOUBLE PRECISION array, dimension (P)
!>           The scalar factors of the elementary reflectors that define
!>           P1.
!>
[out]TAUP2
!>          TAUP2 is DOUBLE PRECISION array, dimension (M-P)
!>           The scalar factors of the elementary reflectors that define
!>           P2.
!>
[out]TAUQ1
!>          TAUQ1 is DOUBLE PRECISION array, dimension (Q)
!>           The scalar factors of the elementary reflectors that define
!>           Q1.
!>
[out]PHANTOM
!>          PHANTOM is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DORCSD for details.
!>
!>  P1, P2, and Q1 are represented as products of elementary reflectors.
!>  See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
!>  and DORGLQ.
!>
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.

Definition at line 210 of file dorbdb4.f.

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

◆ dorbdb5()

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

DORBDB5

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

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

◆ dorbdb6()

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

DORBDB6

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

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

◆ dorcsd()

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

DORCSD

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

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

◆ dorcsd2by1()

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

DORCSD2BY1

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

Purpose:
!>
!> DORCSD2BY1 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (R), in which R =
!>          MIN(P,M-P,Q,M-Q).
!>          C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
!>          S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
!>
[out]U1
!>          U1 is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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:  DBBCSD 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 dorcsd2by1.f.

233*
234* -- LAPACK computational routine (3.5.0) --
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 DOUBLE PRECISION THETA(*)
245 DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
246 $ X11(LDX11,*), X21(LDX21,*)
247 INTEGER IWORK(*)
248* ..
249*
250* =====================================================================
251*
252* .. Parameters ..
253 DOUBLE PRECISION ONE, ZERO
254 parameter( one = 1.0d0, zero = 0.0d0 )
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 DOUBLE PRECISION DUM1(1), DUM2(1,1)
267* ..
268* .. External Subroutines ..
269 EXTERNAL dbbcsd, dcopy, dlacpy, dlapmr, dlapmt, dorbdb1,
270 $ dorbdb2, dorbdb3, dorbdb4, dorglq, dorgqr,
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* | DORBDB WORK | DORGQR WORK | DORGLQ WORK | B21D (R) |
323* | | | | B21E (R-1) |
324* | | | | B22D (R) |
325* | | | | B22E (R-1) |
326* | | | | DBBCSD 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 dorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,
352 $ dum1, dum1, dum1, dum1, work,
353 $ -1, childinfo )
354 lorbdb = int( work(1) )
355 IF( wantu1 .AND. p .GT. 0 ) THEN
356 CALL dorgqr( 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 dorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1),
363 $ -1, 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 dorglq( 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 dbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,
374 $ dum1, u1, ldu1, u2, ldu2, v1t, ldv1t,
375 $ dum2, 1, dum1, dum1, dum1,
376 $ dum1, dum1, dum1, dum1,
377 $ dum1, work(1), -1, childinfo )
378 lbbcsd = int( work(1) )
379 ELSE IF( r .EQ. p ) THEN
380 CALL dorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,
381 $ dum1, dum1, dum1, dum1,
382 $ work(1), -1, childinfo )
383 lorbdb = int( work(1) )
384 IF( wantu1 .AND. p .GT. 0 ) THEN
385 CALL dorgqr( 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 dorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1),
392 $ -1, 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 dorglq( 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 dbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,
403 $ dum1, v1t, ldv1t, dum2, 1, u1, ldu1,
404 $ u2, ldu2, dum1, dum1, dum1,
405 $ dum1, dum1, dum1, dum1,
406 $ dum1, work(1), -1, childinfo )
407 lbbcsd = int( work(1) )
408 ELSE IF( r .EQ. m-p ) THEN
409 CALL dorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,
410 $ dum1, dum1, dum1, dum1,
411 $ work(1), -1, childinfo )
412 lorbdb = int( work(1) )
413 IF( wantu1 .AND. p .GT. 0 ) THEN
414 CALL dorgqr( 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 dorgqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,
421 $ dum1, 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 dorglq( 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 dbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,
432 $ theta, dum1, dum2, 1, v1t, ldv1t, u2,
433 $ ldu2, u1, ldu1, dum1, dum1, dum1,
434 $ dum1, dum1, dum1, dum1,
435 $ dum1, work(1), -1, childinfo )
436 lbbcsd = int( work(1) )
437 ELSE
438 CALL dorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,
439 $ dum1, dum1, dum1, dum1,
440 $ dum1, work(1), -1, childinfo )
441 lorbdb = m + int( work(1) )
442 IF( wantu1 .AND. p .GT. 0 ) THEN
443 CALL dorgqr( 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 dorgqr( 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 dorglq( 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 dbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,
461 $ theta, dum1, u2, ldu2, u1, ldu1, dum2,
462 $ 1, v1t, ldv1t, dum1, dum1, dum1,
463 $ dum1, dum1, dum1, dum1,
464 $ dum1, work(1), -1, 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( 'DORCSD2BY1', -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 dorbdb1( 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 dlacpy( 'L', p, q, x11, ldx11, u1, ldu1 )
506 CALL dorgqr( 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 dlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 )
511 CALL dorgqr( 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 dlacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),
521 $ ldv1t )
522 CALL dorglq( 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 dbbcsd( 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),
531 $ work(ib12d), work(ib12e), work(ib21d),
532 $ work(ib21e), work(ib22d), work(ib22e),
533 $ work(ibbcsd), lbbcsd, 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 dlapmt( .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 dorbdb2( 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 dlacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 )
566 CALL dorgqr( 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 dlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 )
571 CALL dorgqr( 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 dlacpy( 'U', p, q, x11, ldx11, v1t, ldv1t )
576 CALL dorglq( 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 dbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,
583 $ work(iphi), v1t, ldv1t, dum2, 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 dlapmt( .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 dorbdb3( 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 dlacpy( 'L', p, q, x11, ldx11, u1, ldu1 )
615 CALL dorgqr( 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 dlacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),
625 $ ldu2 )
626 CALL dorgqr( 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 dlacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t )
631 CALL dorglq( 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 dbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,
638 $ theta, work(iphi), dum2, 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 dlapmt( .false., p, q, u1, ldu1, iwork )
656 END IF
657 IF( wantv1t ) THEN
658 CALL dlapmr( .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 dorbdb4( 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 dcopy( m-p, work(iorbdb+p), 1, u2, 1 )
676 END IF
677 IF( wantu1 .AND. p .GT. 0 ) THEN
678 CALL dcopy( p, work(iorbdb), 1, u1, 1 )
679 DO j = 2, p
680 u1(1,j) = zero
681 END DO
682 CALL dlacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),
683 $ ldu1 )
684 CALL dorgqr( 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 dlacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),
692 $ ldu2 )
693 CALL dorgqr( 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 dlacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t )
698 CALL dlacpy( '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 dlacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,
701 $ v1t(p+1,p+1), ldv1t )
702 CALL dorglq( 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 dbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,
709 $ theta, work(iphi), u2, ldu2, u1, ldu1, dum2,
710 $ 1, v1t, ldv1t, work(ib11d), work(ib11e),
711 $ work(ib12d), work(ib12e), work(ib21d),
712 $ work(ib21e), work(ib22d), work(ib22e),
713 $ work(ibbcsd), lbbcsd, 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 dlapmt( .false., p, p, u1, ldu1, iwork )
727 END IF
728 IF( wantv1t ) THEN
729 CALL dlapmr( .false., p, q, v1t, ldv1t, iwork )
730 END IF
731 END IF
732 END IF
733*
734 RETURN
735*
736* End of DORCSD2BY1
737*
dorbdb3
subroutine dorbdb3(m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
DORBDB3
Definition dorbdb3.f:201
dorbdb2
subroutine dorbdb2(m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
DORBDB2
Definition dorbdb2.f:202
dorbdb1
subroutine dorbdb1(m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, work, lwork, info)
DORBDB1
Definition dorbdb1.f:203
dorbdb4
subroutine dorbdb4(m, p, q, x11, ldx11, x21, ldx21, theta, phi, taup1, taup2, tauq1, phantom, work, lwork, info)
DORBDB4
Definition dorbdb4.f:213

◆ dorg2l()

subroutine dorg2l ( integer m,
integer n,
integer k,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer info )

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

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

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

◆ dorg2r()

subroutine dorg2r ( integer m,
integer n,
integer k,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer info )

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

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

Purpose:
!>
!> DORG2R 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 DGEQRF.
!>
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 DOUBLE PRECISION 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 DGEQRF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGEQRF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dorg2r.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 DOUBLE PRECISION ONE, ZERO
130 parameter( one = 1.0d+0, zero = 0.0d+0 )
131* ..
132* .. Local Scalars ..
133 INTEGER I, J, L
134* ..
135* .. External Subroutines ..
136 EXTERNAL dlarf, dscal, 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( 'DORG2R', -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 dlarf( '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 dscal( 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 DORG2R
196*

◆ dorghr()

subroutine dorghr ( integer n,
integer ilo,
integer ihi,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer lwork,
integer info )

DORGHR

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

Purpose:
!>
!> DORGHR generates a real orthogonal matrix Q which is defined as the
!> product of IHI-ILO elementary reflectors of order N, as returned by
!> DGEHRD:
!>
!> 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 DGEHRD. 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the vectors which define the elementary reflectors,
!>          as returned by DGEHRD.
!>          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 DOUBLE PRECISION array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGEHRD.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 dorghr.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
136* ..
137*
138* =====================================================================
139*
140* .. Parameters ..
141 DOUBLE PRECISION ZERO, ONE
142 parameter( zero = 0.0d+0, one = 1.0d+0 )
143* ..
144* .. Local Scalars ..
145 LOGICAL LQUERY
146 INTEGER I, IINFO, J, LWKOPT, NB, NH
147* ..
148* .. External Subroutines ..
149 EXTERNAL dorgqr, 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, 'DORGQR', ' ', 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( 'DORGHR', -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 dorgqr( 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 DORGHR
236*

◆ dorgl2()

subroutine dorgl2 ( integer m,
integer n,
integer k,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer info )

DORGL2

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

Purpose:
!>
!> DORGL2 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 DGELQF.
!>
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 DOUBLE PRECISION 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 DGELQF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGELQF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dorgl2.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 DOUBLE PRECISION ONE, ZERO
129 parameter( one = 1.0d+0, zero = 0.0d+0 )
130* ..
131* .. Local Scalars ..
132 INTEGER I, J, L
133* ..
134* .. External Subroutines ..
135 EXTERNAL dlarf, dscal, 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( 'DORGL2', -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 dlarf( 'Right', m-i, n-i+1, a( i, i ), lda,
185 $ tau( i ), a( i+1, i ), lda, work )
186 END IF
187 CALL dscal( 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 DORGL2
200*

◆ dorglq()

subroutine dorglq ( integer m,
integer n,
integer k,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer lwork,
integer info )

DORGLQ

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

Purpose:
!>
!> DORGLQ 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 DGELQF.
!>
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 DOUBLE PRECISION 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 DGELQF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGELQF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 dorglq.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 DOUBLE PRECISION ZERO
143 parameter( zero = 0.0d+0 )
144* ..
145* .. Local Scalars ..
146 LOGICAL LQUERY
147 INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
148 $ LWKOPT, NB, NBMIN, NX
149* ..
150* .. External Subroutines ..
151 EXTERNAL dlarfb, dlarft, dorgl2, 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, 'DORGLQ', ' ', 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( 'DORGLQ', -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, 'DORGLQ', ' ', 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, 'DORGLQ', ' ', 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 dorgl2( 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 dlarft( '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 dlarfb( '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 dorgl2( 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 DORGLQ
285*
dlarft
subroutine dlarft(direct, storev, n, k, v, ldv, tau, t, ldt)
DLARFT forms the triangular factor T of a block reflector H = I - vtvH
Definition dlarft.f:163
dlarfb
subroutine dlarfb(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
DLARFB applies a block reflector or its transpose to a general rectangular matrix.
Definition dlarfb.f:197
dorgl2
subroutine dorgl2(m, n, k, a, lda, tau, work, info)
DORGL2
Definition dorgl2.f:113

◆ dorgql()

subroutine dorgql ( integer m,
integer n,
integer k,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer lwork,
integer info )

DORGQL

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

Purpose:
!>
!> DORGQL 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 DGEQLF.
!>
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 DOUBLE PRECISION 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 DGEQLF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGEQLF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 dorgql.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO
144 parameter( zero = 0.0d+0 )
145* ..
146* .. Local Scalars ..
147 LOGICAL LQUERY
148 INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
149 $ NB, NBMIN, NX
150* ..
151* .. External Subroutines ..
152 EXTERNAL dlarfb, dlarft, dorg2l, 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, 'DORGQL', ' ', 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( 'DORGQL', -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, 'DORGQL', ' ', 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, 'DORGQL', ' ', 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 dorg2l( 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 dlarft( '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 dlarfb( '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 dorg2l( 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 DORGQL
292*

◆ dorgqr()

subroutine dorgqr ( integer m,
integer n,
integer k,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer lwork,
integer info )

DORGQR

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

Purpose:
!>
!> DORGQR 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 DGEQRF.
!>
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 DOUBLE PRECISION 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 DGEQRF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGEQRF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 dorgqr.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO
144 parameter( zero = 0.0d+0 )
145* ..
146* .. Local Scalars ..
147 LOGICAL LQUERY
148 INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
149 $ LWKOPT, NB, NBMIN, NX
150* ..
151* .. External Subroutines ..
152 EXTERNAL dlarfb, dlarft, dorg2r, 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, 'DORGQR', ' ', 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( 'DORGQR', -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, 'DORGQR', ' ', 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, 'DORGQR', ' ', 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 dorg2r( 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 dlarft( '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 dlarfb( '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 dorg2r( 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 DORGQR
286*

◆ dorgr2()

subroutine dorgr2 ( integer m,
integer n,
integer k,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer info )

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

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

Purpose:
!>
!> DORGR2 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 DGERQF.
!>
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 DOUBLE PRECISION 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 DGERQF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGERQF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dorgr2.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 DOUBLE PRECISION ONE, ZERO
130 parameter( one = 1.0d+0, zero = 0.0d+0 )
131* ..
132* .. Local Scalars ..
133 INTEGER I, II, J, L
134* ..
135* .. External Subroutines ..
136 EXTERNAL dlarf, dscal, 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( 'DORGR2', -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 dlarf( 'Right', ii-1, n-m+ii, a( ii, 1 ), lda, tau( i ),
185 $ a, lda, work )
186 CALL dscal( 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 DORGR2
198*

◆ dorgrq()

subroutine dorgrq ( integer m,
integer n,
integer k,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer lwork,
integer info )

DORGRQ

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

Purpose:
!>
!> DORGRQ 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 DGERQF.
!>
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 DOUBLE PRECISION 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 DGERQF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGERQF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 dorgrq.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO
144 parameter( zero = 0.0d+0 )
145* ..
146* .. Local Scalars ..
147 LOGICAL LQUERY
148 INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
149 $ LWKOPT, NB, NBMIN, NX
150* ..
151* .. External Subroutines ..
152 EXTERNAL dlarfb, dlarft, dorgr2, 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, 'DORGRQ', ' ', 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( 'DORGRQ', -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, 'DORGRQ', ' ', 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, 'DORGRQ', ' ', 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 dorgr2( 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 dlarft( '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 dlarfb( '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 dorgr2( 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 DORGRQ
292*
dorgr2
subroutine dorgr2(m, n, k, a, lda, tau, work, info)
DORGR2 generates all or part of the orthogonal matrix Q from an RQ factorization determined by sgerqf...
Definition dorgr2.f:114

◆ dorgtr()

subroutine dorgtr ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer lwork,
integer info )

DORGTR

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

Purpose:
!>
!> DORGTR generates a real orthogonal matrix Q which is defined as the
!> product of n-1 elementary reflectors of order N, as returned by
!> DSYTRD:
!>
!> 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 DSYTRD;
!>          = 'L': Lower triangle of A contains elementary reflectors
!>                 from DSYTRD.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix Q. N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the vectors which define the elementary reflectors,
!>          as returned by DSYTRD.
!>          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 DOUBLE PRECISION array, dimension (N-1)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DSYTRD.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 dorgtr.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
134* ..
135*
136* =====================================================================
137*
138* .. Parameters ..
139 DOUBLE PRECISION ZERO, ONE
140 parameter( zero = 0.0d+0, one = 1.0d+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 lsame, ilaenv
150* ..
151* .. External Subroutines ..
152 EXTERNAL dorgql, dorgqr, 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, 'DORGQL', ' ', n-1, n-1, n-1, -1 )
177 ELSE
178 nb = ilaenv( 1, 'DORGQR', ' ', 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( 'DORGTR', -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 DSYTRD 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 dorgql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
220*
221 ELSE
222*
223* Q was determined by a call to DSYTRD 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 dorgqr( 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 DORGTR
251*
dorgql
subroutine dorgql(m, n, k, a, lda, tau, work, lwork, info)
DORGQL
Definition dorgql.f:128

◆ dorgtsqr()

subroutine dorgtsqr ( integer m,
integer n,
integer mb,
integer nb,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( * ) work,
integer lwork,
integer info )

DORGTSQR

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

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

Definition at line 173 of file dorgtsqr.f.

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

◆ dorgtsqr_row()

subroutine dorgtsqr_row ( integer m,
integer n,
integer mb,
integer nb,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( * ) work,
integer lwork,
integer info )

DORGTSQR_ROW

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

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

Definition at line 186 of file dorgtsqr_row.f.

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

◆ dorhr_col()

subroutine dorhr_col ( integer m,
integer n,
integer nb,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( * ) d,
integer info )

DORHR_COL

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

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

Definition at line 258 of file dorhr_col.f.

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

◆ dorm2l()

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

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

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

Purpose:
!>
!> DORM2L 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 DGEQLF. 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 DOUBLE PRECISION 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
!>          DGEQLF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGEQLF.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the m by n matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                                   (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 dorm2l.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 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 DOUBLE PRECISION ONE
176 parameter( one = 1.0d+0 )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, MI, NI, NQ
181 DOUBLE PRECISION AII
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL dlarf, 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( 'DORM2L', -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 dlarf( 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 DORM2L
274*

◆ dorm2r()

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

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

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

Purpose:
!>
!> DORM2R 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 DGEQRF. 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 DOUBLE PRECISION 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
!>          DGEQRF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGEQRF.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the m by n matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                                   (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 dorm2r.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 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 DOUBLE PRECISION ONE
176 parameter( one = 1.0d+0 )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
181 DOUBLE PRECISION AII
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL dlarf, 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( 'DORM2R', -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 dlarf( 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 DORM2R
278*

◆ dormbr()

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

DORMBR

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

Purpose:
!>
!> If VECT = 'Q', DORMBR 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', DORMBR 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 DGEBRD 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 DGEBRD.
!>          If VECT = 'P', the number of rows in the original
!>          matrix reduced by DGEBRD.
!>          K >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION 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 DGEBRD.
!>
[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 DOUBLE PRECISION 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 DGEBRD in the array argument TAUQ or TAUP.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
!>          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 DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For optimum performance LWORK >= 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 193 of file dormbr.f.

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

◆ dormhr()

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

DORMHR

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

Purpose:
!>
!> DORMHR 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 DGEHRD:
!>
!> 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 DGEHRD. 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 DOUBLE PRECISION array, dimension
!>                               (LDA,M) if SIDE = 'L'
!>                               (LDA,N) if SIDE = 'R'
!>          The vectors which define the elementary reflectors, as
!>          returned by DGEHRD.
!>
[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 DOUBLE PRECISION 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 DGEHRD.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!>          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!>          blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 176 of file dormhr.f.

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

◆ dorml2()

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

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

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

Purpose:
!>
!> DORML2 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 DGELQF. 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 DOUBLE PRECISION 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
!>          DGELQF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGELQF.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the m by n matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                                   (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 dorml2.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 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 DOUBLE PRECISION ONE
176 parameter( one = 1.0d+0 )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
181 DOUBLE PRECISION AII
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL dlarf, 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( 'DORML2', -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 dlarf( 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 DORML2
278*

◆ dormlq()

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

DORMLQ

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

Purpose:
!>
!> DORMLQ 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 DGELQF. 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 DOUBLE PRECISION 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
!>          DGELQF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGELQF.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 165 of file dormlq.f.

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

◆ dormql()

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

DORMQL

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

Purpose:
!>
!> DORMQL 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 DGEQLF. 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 DOUBLE PRECISION 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
!>          DGEQLF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGEQLF.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 165 of file dormql.f.

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

◆ dormqr()

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

DORMQR

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

Purpose:
!>
!> DORMQR 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 DGEQRF. 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 DOUBLE PRECISION 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
!>          DGEQRF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGEQRF.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 165 of file dormqr.f.

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

◆ dormr2()

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

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

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

Purpose:
!>
!> DORMR2 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 DGERQF. 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 DOUBLE PRECISION 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
!>          DGERQF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGERQF.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the m by n matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                                   (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 dormr2.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 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 DOUBLE PRECISION ONE
176 parameter( one = 1.0d+0 )
177* ..
178* .. Local Scalars ..
179 LOGICAL LEFT, NOTRAN
180 INTEGER I, I1, I2, I3, MI, NI, NQ
181 DOUBLE PRECISION AII
182* ..
183* .. External Functions ..
184 LOGICAL LSAME
185 EXTERNAL lsame
186* ..
187* .. External Subroutines ..
188 EXTERNAL dlarf, 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( 'DORMR2', -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 dlarf( 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 DORMR2
274*

◆ dormr3()

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

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

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

Purpose:
!>
!> DORMR3 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 DTZRZF. 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 DOUBLE PRECISION 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
!>          DTZRZF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DTZRZF.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the m-by-n matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                                   (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 dormr3.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 DOUBLE PRECISION 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 dlarz, 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( 'DORMR3', -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 dlarz( 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 DORMR3
295*

◆ dormrq()

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

DORMRQ

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

Purpose:
!>
!> DORMRQ 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 DGERQF. 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 DOUBLE PRECISION 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
!>          DGERQF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DGERQF.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 165 of file dormrq.f.

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

◆ dormrz()

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

DORMRZ

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

Purpose:
!>
!> DORMRZ 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 DTZRZF. 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 DOUBLE PRECISION 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
!>          DTZRZF 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 DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i), as returned by DTZRZF.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**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 DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For 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 dormrz.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 DOUBLE PRECISION 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 dlarzb, dlarzt, dormr3, 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, 'DORMRQ', 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( 'DORMRZ', -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 work( 1 ) = 1
288 RETURN
289 END IF
290*
291 nbmin = 2
292 ldwork = nw
293 IF( nb.GT.1 .AND. nb.LT.k ) THEN
294 IF( lwork.LT.lwkopt ) THEN
295 nb = (lwork-tsize) / ldwork
296 nbmin = max( 2, ilaenv( 2, 'DORMRQ', side // trans, m, n, k,
297 $ -1 ) )
298 END IF
299 END IF
300*
301 IF( nb.LT.nbmin .OR. nb.GE.k ) THEN
302*
303* Use unblocked code
304*
305 CALL dormr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,
306 $ work, iinfo )
307 ELSE
308*
309* Use blocked code
310*
311 iwt = 1 + nw*nb
312 IF( ( left .AND. .NOT.notran ) .OR.
313 $ ( .NOT.left .AND. notran ) ) THEN
314 i1 = 1
315 i2 = k
316 i3 = nb
317 ELSE
318 i1 = ( ( k-1 ) / nb )*nb + 1
319 i2 = 1
320 i3 = -nb
321 END IF
322*
323 IF( left ) THEN
324 ni = n
325 jc = 1
326 ja = m - l + 1
327 ELSE
328 mi = m
329 ic = 1
330 ja = n - l + 1
331 END IF
332*
333 IF( notran ) THEN
334 transt = 'T'
335 ELSE
336 transt = 'N'
337 END IF
338*
339 DO 10 i = i1, i2, i3
340 ib = min( nb, k-i+1 )
341*
342* Form the triangular factor of the block reflector
343* H = H(i+ib-1) . . . H(i+1) H(i)
344*
345 CALL dlarzt( 'Backward', 'Rowwise', l, ib, a( i, ja ), lda,
346 $ tau( i ), work( iwt ), ldt )
347*
348 IF( left ) THEN
349*
350* H or H**T is applied to C(i:m,1:n)
351*
352 mi = m - i + 1
353 ic = i
354 ELSE
355*
356* H or H**T is applied to C(1:m,i:n)
357*
358 ni = n - i + 1
359 jc = i
360 END IF
361*
362* Apply H or H**T
363*
364 CALL dlarzb( side, transt, 'Backward', 'Rowwise', mi, ni,
365 $ ib, l, a( i, ja ), lda, work( iwt ), ldt,
366 $ c( ic, jc ), ldc, work, ldwork )
367 10 CONTINUE
368*
369 END IF
370*
371 work( 1 ) = lwkopt
372*
373 RETURN
374*
375* End of DORMRZ
376*
dlarzt
subroutine dlarzt(direct, storev, n, k, v, ldv, tau, t, ldt)
DLARZT forms the triangular factor T of a block reflector H = I - vtvH.
Definition dlarzt.f:185
dormr3
subroutine dormr3(side, trans, m, n, k, l, a, lda, tau, c, ldc, work, info)
DORMR3 multiplies a general matrix by the orthogonal matrix from a RZ factorization determined by stz...
Definition dormr3.f:178
dlarzb
subroutine dlarzb(side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, c, ldc, work, ldwork)
DLARZB applies a block reflector or its transpose to a general matrix.
Definition dlarzb.f:183

◆ dormtr()

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

DORMTR

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

Purpose:
!>
!> DORMTR 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 DSYTRD:
!>
!> 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 DSYTRD;
!>          = 'L': Lower triangle of A contains elementary reflectors
!>                 from DSYTRD.
!>
[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 DOUBLE PRECISION array, dimension
!>                               (LDA,M) if SIDE = 'L'
!>                               (LDA,N) if SIDE = 'R'
!>          The vectors which define the elementary reflectors, as
!>          returned by DSYTRD.
!>
[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 DOUBLE PRECISION 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 DSYTRD.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If SIDE = 'L', LWORK >= max(1,N);
!>          if SIDE = 'R', LWORK >= max(1,M).
!>          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!>          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!>          blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file dormtr.f.

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

◆ dpbcon()

subroutine dpbcon ( character uplo,
integer n,
integer kd,
double precision, dimension( ldab, * ) ab,
integer ldab,
double precision anorm,
double precision rcond,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DPBCON

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

Purpose:
!>
!> DPBCON 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 DPBTRF.
!>
!> 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 DOUBLE PRECISION 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 DOUBLE PRECISION
!>          The 1-norm (or infinity-norm) of the symmetric band matrix A.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dpbcon.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 DOUBLE PRECISION ANORM, RCOND
141* ..
142* .. Array Arguments ..
143 INTEGER IWORK( * )
144 DOUBLE PRECISION AB( LDAB, * ), WORK( * )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 DOUBLE PRECISION ONE, ZERO
151 parameter( one = 1.0d+0, zero = 0.0d+0 )
152* ..
153* .. Local Scalars ..
154 LOGICAL UPPER
155 CHARACTER NORMIN
156 INTEGER IX, KASE
157 DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
158* ..
159* .. Local Arrays ..
160 INTEGER ISAVE( 3 )
161* ..
162* .. External Functions ..
163 LOGICAL LSAME
164 INTEGER IDAMAX
165 DOUBLE PRECISION DLAMCH
166 EXTERNAL lsame, idamax, dlamch
167* ..
168* .. External Subroutines ..
169 EXTERNAL dlacn2, dlatbs, drscl, 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( 'DPBCON', -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 = dlamch( 'Safe minimum' )
207*
208* Estimate the 1-norm of the inverse.
209*
210 kase = 0
211 normin = 'N'
212 10 CONTINUE
213 CALL dlacn2( 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 dlatbs( '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 dlatbs( '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 dlatbs( '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 dlatbs( '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 = idamax( n, work, 1 )
250 IF( scale.LT.abs( work( ix ) )*smlnum .OR. scale.EQ.zero )
251 $ GO TO 20
252 CALL drscl( 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 DPBCON
267*
drscl
subroutine drscl(n, sa, sx, incx)
DRSCL multiplies a vector by the reciprocal of a real scalar.
Definition drscl.f:84
dlatbs
subroutine dlatbs(uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
DLATBS solves a triangular banded system of equations.
Definition dlatbs.f:242
dlacn2
subroutine dlacn2(n, v, x, isgn, est, kase, isave)
DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
Definition dlacn2.f:136

◆ dpbequ()

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

DPBEQU

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

Purpose:
!>
!> DPBEQU 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>          If INFO = 0, S contains the scale factors for A.
!>
[out]SCOND
!>          SCOND is DOUBLE PRECISION
!>          If INFO = 0, S contains the ratio of the smallest S(i) to
!>          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
!>          large nor too small, it is not worth scaling by S.
!>
[out]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix element.  If AMAX is very
!>          close to overflow or very close to underflow, the matrix
!>          should be scaled.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 128 of file dpbequ.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 DOUBLE PRECISION AMAX, SCOND
138* ..
139* .. Array Arguments ..
140 DOUBLE PRECISION AB( LDAB, * ), S( * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 DOUBLE PRECISION ZERO, ONE
147 parameter( zero = 0.0d+0, one = 1.0d+0 )
148* ..
149* .. Local Scalars ..
150 LOGICAL UPPER
151 INTEGER I, J
152 DOUBLE PRECISION 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( 'DPBEQU', -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 DPBEQU
238*

◆ dpbrfs()

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

DPBRFS

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

Purpose:
!>
!> DPBRFS 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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
!>          DPBTRF, 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by DPBTRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dpbrfs.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 DOUBLE PRECISION 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 DOUBLE PRECISION ZERO
210 parameter( zero = 0.0d+0 )
211 DOUBLE PRECISION ONE
212 parameter( one = 1.0d+0 )
213 DOUBLE PRECISION TWO
214 parameter( two = 2.0d+0 )
215 DOUBLE PRECISION THREE
216 parameter( three = 3.0d+0 )
217* ..
218* .. Local Scalars ..
219 LOGICAL UPPER
220 INTEGER COUNT, I, J, K, KASE, L, NZ
221 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
222* ..
223* .. Local Arrays ..
224 INTEGER ISAVE( 3 )
225* ..
226* .. External Subroutines ..
227 EXTERNAL daxpy, dcopy, dlacn2, dpbtrs, dsbmv, xerbla
228* ..
229* .. Intrinsic Functions ..
230 INTRINSIC abs, max, min
231* ..
232* .. External Functions ..
233 LOGICAL LSAME
234 DOUBLE PRECISION DLAMCH
235 EXTERNAL lsame, dlamch
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( 'DPBRFS', -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 = dlamch( 'Epsilon' )
279 safmin = dlamch( '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 dcopy( n, b( 1, j ), 1, work( n+1 ), 1 )
296 CALL dsbmv( 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 dpbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n,
361 $ info )
362 CALL daxpy( 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 DLACN2 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 dlacn2( 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 dpbtrs( 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 dpbtrs( 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 DPBRFS
439*
dpbtrs
subroutine dpbtrs(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
DPBTRS
Definition dpbtrs.f:121
dsbmv
subroutine dsbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
DSBMV
Definition dsbmv.f:184

◆ dpbstf()

subroutine dpbstf ( character uplo,
integer n,
integer kd,
double precision, dimension( ldab, * ) ab,
integer ldab,
integer info )

DPBSTF

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

Purpose:
!>
!> DPBSTF computes a split Cholesky factorization of a real
!> symmetric positive definite band matrix A.
!>
!> This routine is designed to be used in conjunction with DSBGST.
!>
!> 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 DOUBLE PRECISION 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 dpbstf.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 DOUBLE PRECISION AB( LDAB, * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 DOUBLE PRECISION ONE, ZERO
169 parameter( one = 1.0d+0, zero = 0.0d+0 )
170* ..
171* .. Local Scalars ..
172 LOGICAL UPPER
173 INTEGER J, KLD, KM, M
174 DOUBLE PRECISION AJJ
175* ..
176* .. External Functions ..
177 LOGICAL LSAME
178 EXTERNAL lsame
179* ..
180* .. External Subroutines ..
181 EXTERNAL dscal, dsyr, 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( 'DPBSTF', -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 dscal( km, one / ajj, ab( kd+1-km, j ), 1 )
236 CALL dsyr( '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 dscal( km, one / ajj, ab( kd, j+1 ), kld )
258 CALL dsyr( '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 dscal( km, one / ajj, ab( km+1, j-km ), kld )
281 CALL dsyr( '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 dscal( km, one / ajj, ab( 2, j ), 1 )
303 CALL dsyr( '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 DPBSTF
315*
dsyr
subroutine dsyr(uplo, n, alpha, x, incx, a, lda)
DSYR
Definition dsyr.f:132

◆ dpbtf2()

subroutine dpbtf2 ( character uplo,
integer n,
integer kd,
double precision, dimension( ldab, * ) ab,
integer ldab,
integer info )

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

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

Purpose:
!>
!> DPBTF2 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 DOUBLE PRECISION 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 dpbtf2.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 DOUBLE PRECISION AB( LDAB, * )
153* ..
154*
155* =====================================================================
156*
157* .. Parameters ..
158 DOUBLE PRECISION ONE, ZERO
159 parameter( one = 1.0d+0, zero = 0.0d+0 )
160* ..
161* .. Local Scalars ..
162 LOGICAL UPPER
163 INTEGER J, KLD, KN
164 DOUBLE PRECISION AJJ
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 EXTERNAL lsame
169* ..
170* .. External Subroutines ..
171 EXTERNAL dscal, dsyr, 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( 'DPBTF2', -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 dscal( kn, one / ajj, ab( kd, j+1 ), kld )
223 CALL dsyr( '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 dscal( kn, one / ajj, ab( 2, j ), 1 )
247 CALL dsyr( '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 DPBTF2
259*

◆ dpbtrf()

subroutine dpbtrf ( character uplo,
integer n,
integer kd,
double precision, dimension( ldab, * ) ab,
integer ldab,
integer info )

DPBTRF

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

Purpose:
!>
!> DPBTRF 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 DOUBLE PRECISION 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 dpbtrf.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 DOUBLE PRECISION AB( LDAB, * )
153* ..
154*
155* =====================================================================
156*
157* .. Parameters ..
158 DOUBLE PRECISION ONE, ZERO
159 parameter( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION WORK( LDWORK, NBMAX )
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 INTEGER ILAENV
172 EXTERNAL lsame, ilaenv
173* ..
174* .. External Subroutines ..
175 EXTERNAL dgemm, dpbtf2, dpotf2, dsyrk, dtrsm, 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( 'DPBTRF', -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, 'DPBTRF', 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 dpbtf2( 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 dpotf2( 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 dtrsm( '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 dsyrk( '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 dtrsm( '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 dgemm( '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 dsyrk( '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 dpotf2( 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 dtrsm( '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 dsyrk( '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 dtrsm( '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 dgemm( '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 dsyrk( '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 DPBTRF
431*
dpbtf2
subroutine dpbtf2(uplo, n, kd, ab, ldab, info)
DPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (un...
Definition dpbtf2.f:142
dpotf2
subroutine dpotf2(uplo, n, a, lda, info)
DPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblock...
Definition dpotf2.f:109
dsyrk
subroutine dsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
DSYRK
Definition dsyrk.f:169

◆ dpbtrs()

subroutine dpbtrs ( character uplo,
integer n,
integer kd,
integer nrhs,
double precision, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DPBTRS

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

Purpose:
!>
!> DPBTRS 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 DPBTRF.
!>
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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dpbtrs.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 DOUBLE PRECISION 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 dtbsv, 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( 'DPBTRS', -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 dtbsv( '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 dtbsv( '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 dtbsv( '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 dtbsv( '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 DPBTRS
216*
dtbsv
subroutine dtbsv(uplo, trans, diag, n, k, a, lda, x, incx)
DTBSV
Definition dtbsv.f:189

◆ dpftrf()

subroutine dpftrf ( character transr,
character uplo,
integer n,
double precision, dimension( 0: * ) a,
integer info )

DPFTRF

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

Purpose:
!>
!> DPFTRF 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 DOUBLE PRECISION 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 dpftrf.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 DOUBLE PRECISION A( 0: * )
209*
210* =====================================================================
211*
212* .. Parameters ..
213 DOUBLE PRECISION ONE
214 parameter( one = 1.0d+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, dsyrk, dpotrf, dtrsm
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( 'DPFTRF', -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 dpotrf( 'L', n1, a( 0 ), n, info )
291 IF( info.GT.0 )
292 $ RETURN
293 CALL dtrsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0 ), n,
294 $ a( n1 ), n )
295 CALL dsyrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,
296 $ a( n ), n )
297 CALL dpotrf( '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 dpotrf( 'L', n1, a( n2 ), n, info )
308 IF( info.GT.0 )
309 $ RETURN
310 CALL dtrsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,
311 $ a( 0 ), n )
312 CALL dsyrk( 'U', 'T', n2, n1, -one, a( 0 ), n, one,
313 $ a( n1 ), n )
314 CALL dpotrf( '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 dpotrf( 'U', n1, a( 0 ), n1, info )
331 IF( info.GT.0 )
332 $ RETURN
333 CALL dtrsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0 ), n1,
334 $ a( n1*n1 ), n1 )
335 CALL dsyrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,
336 $ a( 1 ), n1 )
337 CALL dpotrf( '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 dpotrf( 'U', n1, a( n2*n2 ), n2, info )
348 IF( info.GT.0 )
349 $ RETURN
350 CALL dtrsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),
351 $ n2, a( 0 ), n2 )
352 CALL dsyrk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,
353 $ a( n1*n2 ), n2 )
354 CALL dpotrf( '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 dpotrf( 'L', k, a( 1 ), n+1, info )
377 IF( info.GT.0 )
378 $ RETURN
379 CALL dtrsm( 'R', 'L', 'T', 'N', k, k, one, a( 1 ), n+1,
380 $ a( k+1 ), n+1 )
381 CALL dsyrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,
382 $ a( 0 ), n+1 )
383 CALL dpotrf( '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 dpotrf( 'L', k, a( k+1 ), n+1, info )
394 IF( info.GT.0 )
395 $ RETURN
396 CALL dtrsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),
397 $ n+1, a( 0 ), n+1 )
398 CALL dsyrk( 'U', 'T', k, k, -one, a( 0 ), n+1, one,
399 $ a( k ), n+1 )
400 CALL dpotrf( '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 dpotrf( 'U', k, a( 0+k ), k, info )
417 IF( info.GT.0 )
418 $ RETURN
419 CALL dtrsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,
420 $ a( k*( k+1 ) ), k )
421 CALL dsyrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,
422 $ a( 0 ), k )
423 CALL dpotrf( '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 dpotrf( 'U', k, a( k*( k+1 ) ), k, info )
434 IF( info.GT.0 )
435 $ RETURN
436 CALL dtrsm( 'R', 'U', 'N', 'N', k, k, one,
437 $ a( k*( k+1 ) ), k, a( 0 ), k )
438 CALL dsyrk( 'L', 'N', k, k, -one, a( 0 ), k, one,
439 $ a( k*k ), k )
440 CALL dpotrf( '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 DPFTRF
453*
dpotrf
subroutine dpotrf(uplo, n, a, lda, info)
DPOTRF
Definition dpotrf.f:107

◆ dpftri()

subroutine dpftri ( character transr,
character uplo,
integer n,
double precision, dimension( 0: * ) a,
integer info )

DPFTRI

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

Purpose:
!>
!> DPFTRI 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 DPFTRF.
!>
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 DOUBLE PRECISION 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 dpftri.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 DOUBLE PRECISION A( 0: * )
201* ..
202*
203* =====================================================================
204*
205* .. Parameters ..
206 DOUBLE PRECISION ONE
207 parameter( one = 1.0d+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, dtftri, dlauum, dtrmm, dsyrk
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( 'DPFTRI', -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 dtftri( 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 dlauum( 'L', n1, a( 0 ), n, info )
291 CALL dsyrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,
292 $ a( 0 ), n )
293 CALL dtrmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,
294 $ a( n1 ), n )
295 CALL dlauum( '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 dlauum( 'L', n1, a( n2 ), n, info )
304 CALL dsyrk( 'L', 'N', n1, n2, one, a( 0 ), n, one,
305 $ a( n2 ), n )
306 CALL dtrmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,
307 $ a( 0 ), n )
308 CALL dlauum( '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 dlauum( 'U', n1, a( 0 ), n1, info )
322 CALL dsyrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,
323 $ a( 0 ), n1 )
324 CALL dtrmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1 ), n1,
325 $ a( n1*n1 ), n1 )
326 CALL dlauum( '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 dlauum( 'U', n1, a( n2*n2 ), n2, info )
334 CALL dsyrk( 'U', 'T', n1, n2, one, a( 0 ), n2, one,
335 $ a( n2*n2 ), n2 )
336 CALL dtrmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),
337 $ n2, a( 0 ), n2 )
338 CALL dlauum( '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 dlauum( 'L', k, a( 1 ), n+1, info )
359 CALL dsyrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,
360 $ a( 1 ), n+1 )
361 CALL dtrmm( 'L', 'U', 'N', 'N', k, k, one, a( 0 ), n+1,
362 $ a( k+1 ), n+1 )
363 CALL dlauum( '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 dlauum( 'L', k, a( k+1 ), n+1, info )
372 CALL dsyrk( 'L', 'N', k, k, one, a( 0 ), n+1, one,
373 $ a( k+1 ), n+1 )
374 CALL dtrmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,
375 $ a( 0 ), n+1 )
376 CALL dlauum( '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 dlauum( 'U', k, a( k ), k, info )
391 CALL dsyrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,
392 $ a( k ), k )
393 CALL dtrmm( 'R', 'L', 'N', 'N', k, k, one, a( 0 ), k,
394 $ a( k*( k+1 ) ), k )
395 CALL dlauum( '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 dlauum( 'U', k, a( k*( k+1 ) ), k, info )
404 CALL dsyrk( 'U', 'T', k, k, one, a( 0 ), k, one,
405 $ a( k*( k+1 ) ), k )
406 CALL dtrmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,
407 $ a( 0 ), k )
408 CALL dlauum( '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 DPFTRI
419*
dlauum
subroutine dlauum(uplo, n, a, lda, info)
DLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked...
Definition dlauum.f:102
dtftri
subroutine dtftri(transr, uplo, diag, n, a, info)
DTFTRI
Definition dtftri.f:201

◆ dpftrs()

subroutine dpftrs ( character transr,
character uplo,
integer n,
integer nrhs,
double precision, dimension( 0: * ) a,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DPFTRS

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

Purpose:
!>
!> DPFTRS 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 DPFTRF.
!>
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 DOUBLE PRECISION array, dimension ( N*(N+1)/2 ).
!>          The triangular factor U or L from the Cholesky factorization
!>          of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF.
!>          See note below for more details about RFP A.
!>
[in,out]B
!>          B is DOUBLE PRECISION 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 dpftrs.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 DOUBLE PRECISION A( 0: * ), B( LDB, * )
210* ..
211*
212* =====================================================================
213*
214* .. Parameters ..
215 DOUBLE PRECISION ONE
216 parameter( one = 1.0d+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, dtfsm
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( 'DPFTRS', -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 dtfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,
263 $ ldb )
264 CALL dtfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,
265 $ ldb )
266 ELSE
267 CALL dtfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,
268 $ ldb )
269 CALL dtfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,
270 $ ldb )
271 END IF
272*
273 RETURN
274*
275* End of DPFTRS
276*
dtfsm
subroutine dtfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
DTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition dtfsm.f:277

◆ dppcon()

subroutine dppcon ( character uplo,
integer n,
double precision, dimension( * ) ap,
double precision anorm,
double precision rcond,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DPPCON

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

Purpose:
!>
!> DPPCON 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
!> DPPTRF.
!>
!> 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 DOUBLE PRECISION 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 DOUBLE PRECISION
!>          The 1-norm (or infinity-norm) of the symmetric matrix A.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dppcon.f.

118*
119* -- LAPACK computational routine --
120* -- LAPACK is a software package provided by Univ. of Tennessee, --
121* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
122*
123* .. Scalar Arguments ..
124 CHARACTER UPLO
125 INTEGER INFO, N
126 DOUBLE PRECISION ANORM, RCOND
127* ..
128* .. Array Arguments ..
129 INTEGER IWORK( * )
130 DOUBLE PRECISION AP( * ), WORK( * )
131* ..
132*
133* =====================================================================
134*
135* .. Parameters ..
136 DOUBLE PRECISION ONE, ZERO
137 parameter( one = 1.0d+0, zero = 0.0d+0 )
138* ..
139* .. Local Scalars ..
140 LOGICAL UPPER
141 CHARACTER NORMIN
142 INTEGER IX, KASE
143 DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
144* ..
145* .. Local Arrays ..
146 INTEGER ISAVE( 3 )
147* ..
148* .. External Functions ..
149 LOGICAL LSAME
150 INTEGER IDAMAX
151 DOUBLE PRECISION DLAMCH
152 EXTERNAL lsame, idamax, dlamch
153* ..
154* .. External Subroutines ..
155 EXTERNAL dlacn2, dlatps, drscl, 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( 'DPPCON', -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 = dlamch( 'Safe minimum' )
189*
190* Estimate the 1-norm of the inverse.
191*
192 kase = 0
193 normin = 'N'
194 10 CONTINUE
195 CALL dlacn2( 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 dlatps( '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 dlatps( '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 dlatps( '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 dlatps( '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 = idamax( n, work, 1 )
228 IF( scale.LT.abs( work( ix ) )*smlnum .OR. scale.EQ.zero )
229 $ GO TO 20
230 CALL drscl( 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 DPPCON
244*
dlatps
subroutine dlatps(uplo, trans, diag, normin, n, ap, x, scale, cnorm, info)
DLATPS solves a triangular system of equations with the matrix held in packed storage.
Definition dlatps.f:229

◆ dppequ()

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

DPPEQU

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

Purpose:
!>
!> DPPEQU 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>          If INFO = 0, S contains the scale factors for A.
!>
[out]SCOND
!>          SCOND is DOUBLE PRECISION
!>          If INFO = 0, S contains the ratio of the smallest S(i) to
!>          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
!>          large nor too small, it is not worth scaling by S.
!>
[out]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix element.  If AMAX is very
!>          close to overflow or very close to underflow, the matrix
!>          should be scaled.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 115 of file dppequ.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 DOUBLE PRECISION AMAX, SCOND
125* ..
126* .. Array Arguments ..
127 DOUBLE PRECISION AP( * ), S( * )
128* ..
129*
130* =====================================================================
131*
132* .. Parameters ..
133 DOUBLE PRECISION ONE, ZERO
134 parameter( one = 1.0d+0, zero = 0.0d+0 )
135* ..
136* .. Local Scalars ..
137 LOGICAL UPPER
138 INTEGER I, JJ
139 DOUBLE PRECISION 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( 'DPPEQU', -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 DPPEQU
234*

◆ dpprfs()

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

DPPRFS

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

Purpose:
!>
!> DPPRFS 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DPPTRF/ZPPTRF,
!>          packed columnwise in a linear array in the same format as A
!>          (see AP).
!>
[in]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by DPPTRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dpprfs.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 DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
183 $ FERR( * ), WORK( * ), X( LDX, * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 INTEGER ITMAX
190 parameter( itmax = 5 )
191 DOUBLE PRECISION ZERO
192 parameter( zero = 0.0d+0 )
193 DOUBLE PRECISION ONE
194 parameter( one = 1.0d+0 )
195 DOUBLE PRECISION TWO
196 parameter( two = 2.0d+0 )
197 DOUBLE PRECISION THREE
198 parameter( three = 3.0d+0 )
199* ..
200* .. Local Scalars ..
201 LOGICAL UPPER
202 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
203 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
204* ..
205* .. Local Arrays ..
206 INTEGER ISAVE( 3 )
207* ..
208* .. External Subroutines ..
209 EXTERNAL daxpy, dcopy, dlacn2, dpptrs, dspmv, xerbla
210* ..
211* .. Intrinsic Functions ..
212 INTRINSIC abs, max
213* ..
214* .. External Functions ..
215 LOGICAL LSAME
216 DOUBLE PRECISION DLAMCH
217 EXTERNAL lsame, dlamch
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( 'DPPRFS', -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 = dlamch( 'Epsilon' )
255 safmin = dlamch( '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 dcopy( n, b( 1, j ), 1, work( n+1 ), 1 )
272 CALL dspmv( 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 dpptrs( uplo, n, 1, afp, work( n+1 ), n, info )
342 CALL daxpy( 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 DLACN2 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 dlacn2( 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 dpptrs( 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 dpptrs( 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 DPPRFS
417*
dpptrs
subroutine dpptrs(uplo, n, nrhs, ap, b, ldb, info)
DPPTRS
Definition dpptrs.f:108
dspmv
subroutine dspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
DSPMV
Definition dspmv.f:147

◆ dpptrf()

subroutine dpptrf ( character uplo,
integer n,
double precision, dimension( * ) ap,
integer info )

DPPTRF

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

Purpose:
!>
!> DPPTRF 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 DOUBLE PRECISION 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 dpptrf.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 DOUBLE PRECISION AP( * )
130* ..
131*
132* =====================================================================
133*
134* .. Parameters ..
135 DOUBLE PRECISION ONE, ZERO
136 parameter( one = 1.0d+0, zero = 0.0d+0 )
137* ..
138* .. Local Scalars ..
139 LOGICAL UPPER
140 INTEGER J, JC, JJ
141 DOUBLE PRECISION AJJ
142* ..
143* .. External Functions ..
144 LOGICAL LSAME
145 DOUBLE PRECISION DDOT
146 EXTERNAL lsame, ddot
147* ..
148* .. External Subroutines ..
149 EXTERNAL dscal, dspr, dtpsv, 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( 'DPPTRF', -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 dtpsv( '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 ) - ddot( 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 dscal( n-j, one / ajj, ap( jj+1 ), 1 )
221 CALL dspr( '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 DPPTRF
236*
dspr
subroutine dspr(uplo, n, alpha, x, incx, ap)
DSPR
Definition dspr.f:127
dtpsv
subroutine dtpsv(uplo, trans, diag, n, ap, x, incx)
DTPSV
Definition dtpsv.f:144

◆ dpptri()

subroutine dpptri ( character uplo,
integer n,
double precision, dimension( * ) ap,
integer info )

DPPTRI

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

Purpose:
!>
!> DPPTRI 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 DPPTRF.
!>
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 DOUBLE PRECISION 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 dpptri.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 DOUBLE PRECISION AP( * )
104* ..
105*
106* =====================================================================
107*
108* .. Parameters ..
109 DOUBLE PRECISION ONE
110 parameter( one = 1.0d+0 )
111* ..
112* .. Local Scalars ..
113 LOGICAL UPPER
114 INTEGER J, JC, JJ, JJN
115 DOUBLE PRECISION AJJ
116* ..
117* .. External Functions ..
118 LOGICAL LSAME
119 DOUBLE PRECISION DDOT
120 EXTERNAL lsame, ddot
121* ..
122* .. External Subroutines ..
123 EXTERNAL dscal, dspr, dtpmv, dtptri, 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( 'DPPTRI', -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 dtptri( 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 dspr( 'Upper', j-1, one, ap( jc ), 1, ap )
162 ajj = ap( jj )
163 CALL dscal( 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 ) = ddot( n-j+1, ap( jj ), 1, ap( jj ), 1 )
174 IF( j.LT.n )
175 $ CALL dtpmv( '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 DPPTRI
184*
dtptri
subroutine dtptri(uplo, diag, n, ap, info)
DTPTRI
Definition dtptri.f:117
dtpmv
subroutine dtpmv(uplo, trans, diag, n, ap, x, incx)
DTPMV
Definition dtpmv.f:142

◆ dpptrs()

subroutine dpptrs ( character uplo,
integer n,
integer nrhs,
double precision, dimension( * ) ap,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DPPTRS

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

Purpose:
!>
!> DPPTRS 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 DPPTRF.
!>
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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dpptrs.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 DOUBLE PRECISION 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 dtpsv, 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( 'DPPTRS', -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 dtpsv( 'Upper', 'Transpose', 'Non-unit', n, ap,
171 $ b( 1, i ), 1 )
172*
173* Solve U*X = B, overwriting B with X.
174*
175 CALL dtpsv( '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 dtpsv( '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 dtpsv( 'Lower', 'Transpose', 'Non-unit', n, ap,
192 $ b( 1, i ), 1 )
193 20 CONTINUE
194 END IF
195*
196 RETURN
197*
198* End of DPPTRS
199*

◆ dpstf2()

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

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

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

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

Definition at line 140 of file dpstf2.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 DOUBLE PRECISION TOL
148 INTEGER INFO, LDA, N, RANK
149 CHARACTER UPLO
150* ..
151* .. Array Arguments ..
152 DOUBLE PRECISION A( LDA, * ), WORK( 2*N )
153 INTEGER PIV( N )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 DOUBLE PRECISION ONE, ZERO
160 parameter( one = 1.0d+0, zero = 0.0d+0 )
161* ..
162* .. Local Scalars ..
163 DOUBLE PRECISION AJJ, DSTOP, DTEMP
164 INTEGER I, ITEMP, J, PVT
165 LOGICAL UPPER
166* ..
167* .. External Functions ..
168 DOUBLE PRECISION DLAMCH
169 LOGICAL LSAME, DISNAN
170 EXTERNAL dlamch, lsame, disnan
171* ..
172* .. External Subroutines ..
173 EXTERNAL dgemv, dscal, dswap, 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( 'DPSTF2', -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.disnan( 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 dstop = n * dlamch( 'Epsilon' ) * ajj
227 ELSE
228 dstop = 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.dstop.OR.disnan( 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 dswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 )
272 IF( pvt.LT.n )
273 $ CALL dswap( n-pvt, a( j, pvt+1 ), lda,
274 $ a( pvt, pvt+1 ), lda )
275 CALL dswap( pvt-j-1, a( j, j+1 ), lda, a( j+1, pvt ), 1 )
276*
277* Swap dot products and PIV
278*
279 dtemp = work( j )
280 work( j ) = work( pvt )
281 work( pvt ) = dtemp
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 dgemv( 'Trans', j-1, n-j, -one, a( 1, j+1 ), lda,
294 $ a( 1, j ), 1, one, a( j, j+1 ), lda )
295 CALL dscal( 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.dstop.OR.disnan( 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 dswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda )
335 IF( pvt.LT.n )
336 $ CALL dswap( n-pvt, a( pvt+1, j ), 1, a( pvt+1, pvt ),
337 $ 1 )
338 CALL dswap( pvt-j-1, a( j+1, j ), 1, a( pvt, j+1 ), lda )
339*
340* Swap dot products and PIV
341*
342 dtemp = work( j )
343 work( j ) = work( pvt )
344 work( pvt ) = dtemp
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 dgemv( '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 dscal( 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 DPSTF2
382*

◆ dpstrf()

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

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

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

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

Definition at line 141 of file dpstrf.f.

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

◆ dsbgst()

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

DSBGST

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

Purpose:
!>
!> DSBGST 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 DPBSTF, 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDBB,N)
!>          The banded factor S from the split Cholesky factorization of
!>          B, as returned by DPBSTF, 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dsbgst.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 DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
170 $ X( LDX, * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 DOUBLE PRECISION ZERO, ONE
177 parameter( zero = 0.0d+0, one = 1.0d+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 DOUBLE PRECISION BII, RA, RA1, T
184* ..
185* .. External Functions ..
186 LOGICAL LSAME
187 EXTERNAL lsame
188* ..
189* .. External Subroutines ..
190 EXTERNAL dger, dlar2v, dlargv, dlartg, dlartv, dlaset,
191 $ drot, dscal, 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( 'DSBGST', -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 dlaset( '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 DPBSTF. 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 dscal( n-m, one / bii, x( m+1, i ), 1 )
369 IF( kbt.GT.0 )
370 $ CALL dger( 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 dlartg( 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 dlargv( 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 dlartv( 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 dlar2v( 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 dlartv( 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 drot( 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 dlartv( 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 dlargv( 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 dlartv( 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 dlar2v( 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 dlartv( 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 drot( 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 dlartv( 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 dscal( n-m, one / bii, x( m+1, i ), 1 )
629 IF( kbt.GT.0 )
630 $ CALL dger( 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 dlartg( 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 dlargv( 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 dlartv( 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 dlar2v( 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 dlartv( 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 drot( 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 dlartv( 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 dlargv( 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 dlartv( 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 dlar2v( 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 dlartv( 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 drot( 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 dlartv( 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 dscal( nx, one / bii, x( 1, i ), 1 )
938 IF( kbt.GT.0 )
939 $ CALL dger( 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 dlartg( 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 dlargv( 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 dlartv( 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 dlar2v( 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 dlartv( 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 drot( 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 dlartv( 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 dlargv( 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 dlartv( 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 dlar2v( 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 dlartv( 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 drot( 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 dlartv( 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 dscal( nx, one / bii, x( 1, i ), 1 )
1202 IF( kbt.GT.0 )
1203 $ CALL dger( 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 dlartg( 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 dlargv( 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 dlartv( 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 dlar2v( 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 dlartv( 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 drot( 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 dlartv( 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 dlargv( 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 dlartv( 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 dlar2v( 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 dlartv( 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 drot( 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 dlartv( 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 DSBGST
1430*
dlar2v
subroutine dlar2v(n, x, y, z, incx, c, s, incc)
DLAR2V applies a vector of plane rotations with real cosines and real sines from both sides to a sequ...
Definition dlar2v.f:110
dlartv
subroutine dlartv(n, x, incx, y, incy, c, s, incc)
DLARTV applies a vector of plane rotations with real cosines and real sines to the elements of a pair...
Definition dlartv.f:108
dlargv
subroutine dlargv(n, x, incx, y, incy, c, incc)
DLARGV generates a vector of plane rotations with real cosines and real sines.
Definition dlargv.f:104

◆ dsbtrd()

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

DSBTRD

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

Purpose:
!>
!> DSBTRD 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T.
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
!>
[in,out]Q
!>          Q is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Modified by Linda Kaufman, Bell Labs.
!>

Definition at line 161 of file dsbtrd.f.

163*
164* -- LAPACK computational routine --
165* -- LAPACK is a software package provided by Univ. of Tennessee, --
166* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
167*
168* .. Scalar Arguments ..
169 CHARACTER UPLO, VECT
170 INTEGER INFO, KD, LDAB, LDQ, N
171* ..
172* .. Array Arguments ..
173 DOUBLE PRECISION AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ),
174 $ WORK( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 DOUBLE PRECISION ZERO, ONE
181 parameter( zero = 0.0d+0, one = 1.0d+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 DOUBLE PRECISION TEMP
189* ..
190* .. External Subroutines ..
191 EXTERNAL dlar2v, dlargv, dlartg, dlartv, dlaset, drot,
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( 'DSBTRD', -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 dlaset( '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 dlargv( 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* DLARTV or DROT is used
281*
282 IF( nr.GE.2*kd-1 ) THEN
283 DO 10 l = 1, kd - 1
284 CALL dlartv( 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 drot( 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 dlartg( 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 drot( 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 dlar2v( 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* DLARTV or DROT 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 dlartv( 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 drot( 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 drot( 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 drot( 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 drot( 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 dlargv( 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* DLARTV or DROT is used
473*
474 IF( nr.GT.2*kd-1 ) THEN
475 DO 130 l = 1, kd - 1
476 CALL dlartv( 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 drot( 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 dlartg( 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 drot( 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 dlar2v( 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* DLARTV or DROT 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 dlartv( 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 drot( 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 drot( 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 drot( 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 drot( 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 DSBTRD
637*

◆ dsfrk()

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

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

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

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

◆ dspcon()

subroutine dspcon ( character uplo,
integer n,
double precision, dimension( * ) ap,
integer, dimension( * ) ipiv,
double precision anorm,
double precision rcond,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DSPCON

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

Purpose:
!>
!> DSPCON 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 DSPTRF.
!>
!> 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 DOUBLE PRECISION 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 DSPTRF, 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 DSPTRF.
!>
[in]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The 1-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!>          estimate of the 1-norm of inv(A) computed in this routine.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dspcon.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 DOUBLE PRECISION ANORM, RCOND
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * ), IWORK( * )
137 DOUBLE PRECISION AP( * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ONE, ZERO
144 parameter( one = 1.0d+0, zero = 0.0d+0 )
145* ..
146* .. Local Scalars ..
147 LOGICAL UPPER
148 INTEGER I, IP, KASE
149 DOUBLE PRECISION 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 dlacn2, dsptrs, 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( 'DSPCON', -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 dlacn2( 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 dsptrs( 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 DSPCON
234*
dsptrs
subroutine dsptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
DSPTRS
Definition dsptrs.f:115

◆ dspgst()

subroutine dspgst ( integer itype,
character uplo,
integer n,
double precision, dimension( * ) ap,
double precision, dimension( * ) bp,
integer info )

DSPGST

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

Purpose:
!>
!> DSPGST 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 DPPTRF.
!>
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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DPPTRF.
!>
[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 dspgst.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 DOUBLE PRECISION AP( * ), BP( * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 DOUBLE PRECISION ONE, HALF
130 parameter( one = 1.0d0, half = 0.5d0 )
131* ..
132* .. Local Scalars ..
133 LOGICAL UPPER
134 INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK
135 DOUBLE PRECISION AJJ, AKK, BJJ, BKK, CT
136* ..
137* .. External Subroutines ..
138 EXTERNAL daxpy, dscal, dspmv, dspr2, dtpmv, dtpsv,
139 $ xerbla
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 DOUBLE PRECISION DDOT
144 EXTERNAL lsame, ddot
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( 'DSPGST', -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 dtpsv( uplo, 'Transpose', 'Nonunit', j, bp,
180 $ ap( j1 ), 1 )
181 CALL dspmv( uplo, j-1, -one, ap, bp( j1 ), 1, one,
182 $ ap( j1 ), 1 )
183 CALL dscal( j-1, one / bjj, ap( j1 ), 1 )
184 ap( jj ) = ( ap( jj )-ddot( 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 dscal( n-k, one / bkk, ap( kk+1 ), 1 )
205 ct = -half*akk
206 CALL daxpy( n-k, ct, bp( kk+1 ), 1, ap( kk+1 ), 1 )
207 CALL dspr2( uplo, n-k, -one, ap( kk+1 ), 1,
208 $ bp( kk+1 ), 1, ap( k1k1 ) )
209 CALL daxpy( n-k, ct, bp( kk+1 ), 1, ap( kk+1 ), 1 )
210 CALL dtpsv( 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 dtpmv( uplo, 'No transpose', 'Non-unit', k-1, bp,
233 $ ap( k1 ), 1 )
234 ct = half*akk
235 CALL daxpy( k-1, ct, bp( k1 ), 1, ap( k1 ), 1 )
236 CALL dspr2( uplo, k-1, one, ap( k1 ), 1, bp( k1 ), 1,
237 $ ap )
238 CALL daxpy( k-1, ct, bp( k1 ), 1, ap( k1 ), 1 )
239 CALL dscal( 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 + ddot( n-j, ap( jj+1 ), 1,
257 $ bp( jj+1 ), 1 )
258 CALL dscal( n-j, bjj, ap( jj+1 ), 1 )
259 CALL dspmv( uplo, n-j, one, ap( j1j1 ), bp( jj+1 ), 1,
260 $ one, ap( jj+1 ), 1 )
261 CALL dtpmv( 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 DSPGST
270*
dspr2
subroutine dspr2(uplo, n, alpha, x, incx, y, incy, ap)
DSPR2
Definition dspr2.f:142

◆ dsprfs()

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

DSPRFS

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

Purpose:
!>
!> DSPRFS 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DSPTRF, 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 DSPTRF.
!>
[in]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by DSPTRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dsprfs.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 DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
191 $ FERR( * ), WORK( * ), X( LDX, * )
192* ..
193*
194* =====================================================================
195*
196* .. Parameters ..
197 INTEGER ITMAX
198 parameter( itmax = 5 )
199 DOUBLE PRECISION ZERO
200 parameter( zero = 0.0d+0 )
201 DOUBLE PRECISION ONE
202 parameter( one = 1.0d+0 )
203 DOUBLE PRECISION TWO
204 parameter( two = 2.0d+0 )
205 DOUBLE PRECISION THREE
206 parameter( three = 3.0d+0 )
207* ..
208* .. Local Scalars ..
209 LOGICAL UPPER
210 INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
211 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
212* ..
213* .. Local Arrays ..
214 INTEGER ISAVE( 3 )
215* ..
216* .. External Subroutines ..
217 EXTERNAL daxpy, dcopy, dlacn2, dspmv, dsptrs, xerbla
218* ..
219* .. Intrinsic Functions ..
220 INTRINSIC abs, max
221* ..
222* .. External Functions ..
223 LOGICAL LSAME
224 DOUBLE PRECISION DLAMCH
225 EXTERNAL lsame, dlamch
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( 'DSPRFS', -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 = dlamch( 'Epsilon' )
263 safmin = dlamch( '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 dcopy( n, b( 1, j ), 1, work( n+1 ), 1 )
280 CALL dspmv( 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 dsptrs( uplo, n, 1, afp, ipiv, work( n+1 ), n, info )
350 CALL daxpy( 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 DLACN2 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 dlacn2( 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 dsptrs( 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 dsptrs( 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 DSPRFS
427*

◆ dsptrd()

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

DSPTRD

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

Purpose:
!>
!> DSPTRD 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
!>
[out]TAU
!>          TAU is DOUBLE PRECISION 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 dsptrd.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 DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 DOUBLE PRECISION ONE, ZERO, HALF
167 parameter( one = 1.0d0, zero = 0.0d0,
168 $ half = 1.0d0 / 2.0d0 )
169* ..
170* .. Local Scalars ..
171 LOGICAL UPPER
172 INTEGER I, I1, I1I1, II
173 DOUBLE PRECISION ALPHA, TAUI
174* ..
175* .. External Subroutines ..
176 EXTERNAL daxpy, dlarfg, dspmv, dspr2, xerbla
177* ..
178* .. External Functions ..
179 LOGICAL LSAME
180 DOUBLE PRECISION DDOT
181 EXTERNAL lsame, ddot
182* ..
183* .. Executable Statements ..
184*
185* Test the input parameters
186*
187 info = 0
188 upper = lsame( uplo, 'U' )
189 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
190 info = -1
191 ELSE IF( n.LT.0 ) THEN
192 info = -2
193 END IF
194 IF( info.NE.0 ) THEN
195 CALL xerbla( 'DSPTRD', -info )
196 RETURN
197 END IF
198*
199* Quick return if possible
200*
201 IF( n.LE.0 )
202 $ RETURN
203*
204 IF( upper ) THEN
205*
206* Reduce the upper triangle of A.
207* I1 is the index in AP of A(1,I+1).
208*
209 i1 = n*( n-1 ) / 2 + 1
210 DO 10 i = n - 1, 1, -1
211*
212* Generate elementary reflector H(i) = I - tau * v * v**T
213* to annihilate A(1:i-1,i+1)
214*
215 CALL dlarfg( i, ap( i1+i-1 ), ap( i1 ), 1, taui )
216 e( i ) = ap( i1+i-1 )
217*
218 IF( taui.NE.zero ) THEN
219*
220* Apply H(i) from both sides to A(1:i,1:i)
221*
222 ap( i1+i-1 ) = one
223*
224* Compute y := tau * A * v storing y in TAU(1:i)
225*
226 CALL dspmv( uplo, i, taui, ap, ap( i1 ), 1, zero, tau,
227 $ 1 )
228*
229* Compute w := y - 1/2 * tau * (y**T *v) * v
230*
231 alpha = -half*taui*ddot( i, tau, 1, ap( i1 ), 1 )
232 CALL daxpy( i, alpha, ap( i1 ), 1, tau, 1 )
233*
234* Apply the transformation as a rank-2 update:
235* A := A - v * w**T - w * v**T
236*
237 CALL dspr2( uplo, i, -one, ap( i1 ), 1, tau, 1, ap )
238*
239 ap( i1+i-1 ) = e( i )
240 END IF
241 d( i+1 ) = ap( i1+i )
242 tau( i ) = taui
243 i1 = i1 - i
244 10 CONTINUE
245 d( 1 ) = ap( 1 )
246 ELSE
247*
248* Reduce the lower triangle of A. II is the index in AP of
249* A(i,i) and I1I1 is the index of A(i+1,i+1).
250*
251 ii = 1
252 DO 20 i = 1, n - 1
253 i1i1 = ii + n - i + 1
254*
255* Generate elementary reflector H(i) = I - tau * v * v**T
256* to annihilate A(i+2:n,i)
257*
258 CALL dlarfg( n-i, ap( ii+1 ), ap( ii+2 ), 1, taui )
259 e( i ) = ap( ii+1 )
260*
261 IF( taui.NE.zero ) THEN
262*
263* Apply H(i) from both sides to A(i+1:n,i+1:n)
264*
265 ap( ii+1 ) = one
266*
267* Compute y := tau * A * v storing y in TAU(i:n-1)
268*
269 CALL dspmv( uplo, n-i, taui, ap( i1i1 ), ap( ii+1 ), 1,
270 $ zero, tau( i ), 1 )
271*
272* Compute w := y - 1/2 * tau * (y**T *v) * v
273*
274 alpha = -half*taui*ddot( n-i, tau( i ), 1, ap( ii+1 ),
275 $ 1 )
276 CALL daxpy( n-i, alpha, ap( ii+1 ), 1, tau( i ), 1 )
277*
278* Apply the transformation as a rank-2 update:
279* A := A - v * w**T - w * v**T
280*
281 CALL dspr2( uplo, n-i, -one, ap( ii+1 ), 1, tau( i ), 1,
282 $ ap( i1i1 ) )
283*
284 ap( ii+1 ) = e( i )
285 END IF
286 d( i ) = ap( ii )
287 tau( i ) = taui
288 ii = i1i1
289 20 CONTINUE
290 d( n ) = ap( ii )
291 END IF
292*
293 RETURN
294*
295* End of DSPTRD
296*

◆ dsptrf()

subroutine dsptrf ( character uplo,
integer n,
double precision, dimension( * ) ap,
integer, dimension( * ) ipiv,
integer info )

DSPTRF

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

Purpose:
!>
!> DSPTRF 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 DOUBLE PRECISION 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:
!>
!>  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).
!>
Contributors:
J. Lewis, Boeing Computer Services Company

Definition at line 158 of file dsptrf.f.

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

◆ dsptri()

subroutine dsptri ( character uplo,
integer n,
double precision, dimension( * ) ap,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work,
integer info )

DSPTRI

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

Purpose:
!>
!> DSPTRI 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 DSPTRF.
!>
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 DOUBLE PRECISION 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 DSPTRF,
!>          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 DSPTRF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 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 dsptri.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 DOUBLE PRECISION AP( * ), WORK( * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 DOUBLE PRECISION ONE, ZERO
127 parameter( one = 1.0d+0, zero = 0.0d+0 )
128* ..
129* .. Local Scalars ..
130 LOGICAL UPPER
131 INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
132 DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP
133* ..
134* .. External Functions ..
135 LOGICAL LSAME
136 DOUBLE PRECISION DDOT
137 EXTERNAL lsame, ddot
138* ..
139* .. External Subroutines ..
140 EXTERNAL dcopy, dspmv, dswap, 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( 'DSPTRI', -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 dcopy( k-1, ap( kc ), 1, work, 1 )
220 CALL dspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
221 $ 1 )
222 ap( kc+k-1 ) = ap( kc+k-1 ) -
223 $ ddot( 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 dcopy( k-1, ap( kc ), 1, work, 1 )
245 CALL dspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),
246 $ 1 )
247 ap( kc+k-1 ) = ap( kc+k-1 ) -
248 $ ddot( k-1, work, 1, ap( kc ), 1 )
249 ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -
250 $ ddot( k-1, ap( kc ), 1, ap( kcnext ),
251 $ 1 )
252 CALL dcopy( k-1, ap( kcnext ), 1, work, 1 )
253 CALL dspmv( uplo, k-1, -one, ap, work, 1, zero,
254 $ ap( kcnext ), 1 )
255 ap( kcnext+k ) = ap( kcnext+k ) -
256 $ ddot( 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 dswap( 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 dcopy( n-k, ap( kc+1 ), 1, work, 1 )
322 CALL dspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1,
323 $ zero, ap( kc+1 ), 1 )
324 ap( kc ) = ap( kc ) - ddot( 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 dcopy( n-k, ap( kc+1 ), 1, work, 1 )
346 CALL dspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
347 $ zero, ap( kc+1 ), 1 )
348 ap( kc ) = ap( kc ) - ddot( n-k, work, 1, ap( kc+1 ), 1 )
349 ap( kcnext+1 ) = ap( kcnext+1 ) -
350 $ ddot( n-k, ap( kc+1 ), 1,
351 $ ap( kcnext+2 ), 1 )
352 CALL dcopy( n-k, ap( kcnext+2 ), 1, work, 1 )
353 CALL dspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1,
354 $ zero, ap( kcnext+2 ), 1 )
355 ap( kcnext ) = ap( kcnext ) -
356 $ ddot( 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 dswap( 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 DSPTRI
397*

◆ dsptrs()

subroutine dsptrs ( character uplo,
integer n,
integer nrhs,
double precision, dimension( * ) ap,
integer, dimension( * ) ipiv,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DSPTRS

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

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

◆ dstegr()

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

DSTEGR

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

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

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

◆ dstein()

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

DSTEIN

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

Purpose:
!>
!> DSTEIN 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 DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix T.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) subdiagonal elements of the tridiagonal matrix
!>          T, in elements 1 to N-1.
!>
[in]M
!>          M is INTEGER
!>          The number of eigenvectors to be found.  0 <= M <= N.
!>
[in]W
!>          W is DOUBLE PRECISION array, dimension (N)
!>          The first M elements of W contain the eigenvalues for
!>          which eigenvectors are to be computed.  The eigenvalues
!>          should be grouped by split-off block and ordered from
!>          smallest to largest within the block.  ( The output array
!>          W from DSTEBZ with ORDER = 'B' is expected here. )
!>
[in]IBLOCK
!>          IBLOCK is INTEGER array, dimension (N)
!>          The submatrix indices associated with the corresponding
!>          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
!>          the first submatrix from the top, =2 if W(i) belongs to
!>          the second submatrix, etc.  ( The output array IBLOCK
!>          from DSTEBZ is expected here. )
!>
[in]ISPLIT
!>          ISPLIT is INTEGER array, dimension (N)
!>          The splitting points, at which T breaks up into submatrices.
!>          The first submatrix consists of rows/columns 1 to
!>          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
!>          through ISPLIT( 2 ), etc.
!>          ( The output array ISPLIT from DSTEBZ is expected here. )
!>
[out]Z
!>          Z is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (5*N)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N)
!>
[out]IFAIL
!>          IFAIL is INTEGER array, dimension (M)
!>          On normal exit, all elements of IFAIL are zero.
!>          If one or more eigenvectors fail to converge after
!>          MAXITS iterations, then their indices are stored in
!>          array IFAIL.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit.
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, then i eigenvectors failed to converge
!>               in MAXITS iterations.  Their indices are stored in
!>               array IFAIL.
!>
Internal Parameters:
!>  MAXITS  INTEGER, default = 5
!>          The maximum number of iterations performed.
!>
!>  EXTRA   INTEGER, default = 2
!>          The number of iterations performed after norm growth
!>          criterion is satisfied, should be at least 1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 172 of file dstein.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 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
186* ..
187*
188* =====================================================================
189*
190* .. Parameters ..
191 DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1
192 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 1.0d+1,
193 $ odm3 = 1.0d-3, odm1 = 1.0d-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 DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
202 $ SCL, SEP, TOL, XJ, XJM, ZTR
203* ..
204* .. Local Arrays ..
205 INTEGER ISEED( 4 )
206* ..
207* .. External Functions ..
208 INTEGER IDAMAX
209 DOUBLE PRECISION DDOT, DLAMCH, DNRM2
210 EXTERNAL idamax, ddot, dlamch, dnrm2
211* ..
212* .. External Subroutines ..
213 EXTERNAL daxpy, dcopy, dlagtf, dlagts, dlarnv, dscal,
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( 'DSTEIN', -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 = dlamch( 'Precision' )
266*
267* Initialize seed for random number generator DLARNV.
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 dtpcrt = 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 dlarnv( 2, iseed, blksiz, work( indrv1+1 ) )
347*
348* Copy the matrix T so it won't be destroyed in factorization.
349*
350 CALL dcopy( blksiz, d( b1 ), 1, work( indrv4+1 ), 1 )
351 CALL dcopy( blksiz-1, e( b1 ), 1, work( indrv2+2 ), 1 )
352 CALL dcopy( 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 dlagtf( 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 = idamax( blksiz, work( indrv1+1 ), 1 )
371 scl = blksiz*onenrm*max( eps,
372 $ abs( work( indrv4+blksiz ) ) ) /
373 $ abs( work( indrv1+jmax ) )
374 CALL dscal( blksiz, scl, work( indrv1+1 ), 1 )
375*
376* Solve the system LU = Pb.
377*
378 CALL dlagts( -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 ztr = -ddot( blksiz, work( indrv1+1 ), 1, z( b1, i ),
392 $ 1 )
393 CALL daxpy( blksiz, ztr, 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 = idamax( 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.dtpcrt )
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 / dnrm2( blksiz, work( indrv1+1 ), 1 )
426 jmax = idamax( blksiz, work( indrv1+1 ), 1 )
427 IF( work( indrv1+jmax ).LT.zero )
428 $ scl = -scl
429 CALL dscal( 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 DSTEIN
449*
dlarnv
subroutine dlarnv(idist, iseed, n, x)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition dlarnv.f:97
dlagts
subroutine dlagts(job, n, a, b, c, d, in, y, tol, info)
DLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal ma...
Definition dlagts.f:161
dlagtf
subroutine dlagtf(n, a, lambda, b, c, tol, d, in, info)
DLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix,...
Definition dlagtf.f:156

◆ dstemr()

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

DSTEMR

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

Purpose:
!>
!> DSTEMR 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.DSTEMR 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 DOUBLE PRECISION array, dimension (N)
!>          On entry, the N diagonal elements of the tridiagonal matrix
!>          T. On exit, D is overwritten.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N)
!>          On entry, the (N-1) subdiagonal elements of the tridiagonal
!>          matrix T in elements 1 to N-1 of E. E(N) need not be set on
!>          input, but is used internally as workspace.
!>          On exit, E is overwritten.
!>
[in]VL
!>          VL is DOUBLE PRECISION
!>
!>          If RANGE='V', the lower bound of the interval to
!>          be searched for eigenvalues. VL < VU.
!>          Not referenced if RANGE = 'A' or 'I'.
!>
[in]VU
!>          VU is DOUBLE PRECISION
!>
!>          If RANGE='V', the upper bound of the interval to
!>          be searched for eigenvalues. VL < VU.
!>          Not referenced if RANGE = 'A' or 'I'.
!>
[in]IL
!>          IL is INTEGER
!>
!>          If RANGE='I', the index of the
!>          smallest eigenvalue to be returned.
!>          1 <= IL <= IU <= N, if N > 0.
!>          Not referenced if RANGE = 'A' or 'V'.
!>
[in]IU
!>          IU is INTEGER
!>
!>          If RANGE='I', the index of the
!>          largest eigenvalue to be returned.
!>          1 <= IL <= IU <= N, if N > 0.
!>          Not referenced if RANGE = 'A' or 'V'.
!>
[out]M
!>          M is INTEGER
!>          The total number of eigenvalues found.  0 <= M <= N.
!>          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!>
[out]W
!>          W is DOUBLE PRECISION array, dimension (N)
!>          The first M elements contain the selected eigenvalues in
!>          ascending order.
!>
[out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
!>          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
!>          contain the orthonormal eigenvectors of the matrix T
!>          corresponding to the selected eigenvalues, with the i-th
!>          column of Z holding the eigenvector associated with W(i).
!>          If JOBZ = 'N', then Z is not referenced.
!>          Note: the user must ensure that at least max(1,M) columns are
!>          supplied in the array Z; if RANGE = 'V', the exact value of M
!>          is not known in advance and can be computed with a workspace
!>          query by setting NZC = -1, see below.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1, and if
!>          JOBZ = 'V', then LDZ >= max(1,N).
!>
[in]NZC
!>          NZC is INTEGER
!>          The number of eigenvectors to be held in the array Z.
!>          If RANGE = 'A', then NZC >= max(1,N).
!>          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
!>          If RANGE = 'I', then NZC >= IU-IL+1.
!>          If NZC = -1, then a workspace query is assumed; the
!>          routine calculates the number of columns of the array Z that
!>          are needed to hold the eigenvectors.
!>          This value is returned as the first entry of the Z array, and
!>          no error message related to NZC is issued by XERBLA.
!>
[out]ISUPPZ
!>          ISUPPZ is INTEGER array, dimension ( 2*max(1,M) )
!>          The support of the eigenvectors in Z, i.e., the indices
!>          indicating the nonzero elements in Z. The i-th computed eigenvector
!>          is nonzero only in elements ISUPPZ( 2*i-1 ) through
!>          ISUPPZ( 2*i ). This is relevant in the case when the matrix
!>          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
!>
[in,out]TRYRAC
!>          TRYRAC is LOGICAL
!>          If TRYRAC = .TRUE., indicates that the code should check whether
!>          the tridiagonal matrix defines its eigenvalues to high relative
!>          accuracy.  If so, the code uses relative-accuracy preserving
!>          algorithms that might be (a bit) slower depending on the matrix.
!>          If the matrix does not define its eigenvalues to high relative
!>          accuracy, the code can uses possibly faster algorithms.
!>          If TRYRAC = .FALSE., the code is not required to guarantee
!>          relatively accurate eigenvalues and can use the fastest possible
!>          techniques.
!>          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
!>          does not define its eigenvalues to high relative accuracy.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>          On exit, if INFO = 0, WORK(1) returns the optimal
!>          (and minimal) LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= max(1,18*N)
!>          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (LIWORK)
!>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!>
[in]LIWORK
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
!>          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
!>          if only the eigenvalues are to be computed.
!>          If LIWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the IWORK array,
!>          returns this value as the first entry of the IWORK array, and
!>          no error message related to LIWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          On exit, INFO
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = 1X, internal error in DLARRE,
!>                if INFO = 2X, internal error in DLARRV.
!>                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
!>                the nonzero error code returned by DLARRE or
!>                DLARRV, 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 dstemr.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 DOUBLE PRECISION VL, VU
331* ..
332* .. Array Arguments ..
333 INTEGER ISUPPZ( * ), IWORK( * )
334 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
335 DOUBLE PRECISION Z( LDZ, * )
336* ..
337*
338* =====================================================================
339*
340* .. Parameters ..
341 DOUBLE PRECISION ZERO, ONE, FOUR, MINRGP
342 parameter( zero = 0.0d0, one = 1.0d0,
343 $ four = 4.0d0,
344 $ minrgp = 1.0d-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 DOUBLE PRECISION 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 DOUBLE PRECISION DLAMCH, DLANST
361 EXTERNAL lsame, dlamch, dlanst
362* ..
363* .. External Subroutines ..
364 EXTERNAL dcopy, dlae2, dlaev2, dlarrc, dlarre, dlarrj,
365 $ dlarrr, dlarrv, dlasrt, dscal, dswap, xerbla
366* ..
367* .. Intrinsic Functions ..
368 INTRINSIC max, min, sqrt
369
370
371* ..
372* .. Executable Statements ..
373*
374* Test the input parameters.
375*
376 wantz = lsame( jobz, 'V' )
377 alleig = lsame( range, 'A' )
378 valeig = lsame( range, 'V' )
379 indeig = lsame( range, 'I' )
380*
381 lquery = ( ( lwork.EQ.-1 ).OR.( liwork.EQ.-1 ) )
382 zquery = ( nzc.EQ.-1 )
383
384* DSTEMR needs WORK of size 6*N, IWORK of size 3*N.
385* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N.
386* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N.
387 IF( wantz ) THEN
388 lwmin = 18*n
389 liwmin = 10*n
390 ELSE
391* need less workspace if only the eigenvalues are wanted
392 lwmin = 12*n
393 liwmin = 8*n
394 ENDIF
395
396 wl = zero
397 wu = zero
398 iil = 0
399 iiu = 0
400 nsplit = 0
401
402 IF( valeig ) THEN
403* We do not reference VL, VU in the cases RANGE = 'I','A'
404* The interval (WL, WU] contains all the wanted eigenvalues.
405* It is either given by the user or computed in DLARRE.
406 wl = vl
407 wu = vu
408 ELSEIF( indeig ) THEN
409* We do not reference IL, IU in the cases RANGE = 'V','A'
410 iil = il
411 iiu = iu
412 ENDIF
413*
414 info = 0
415 IF( .NOT.( wantz .OR. lsame( jobz, 'N' ) ) ) THEN
416 info = -1
417 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) ) THEN
418 info = -2
419 ELSE IF( n.LT.0 ) THEN
420 info = -3
421 ELSE IF( valeig .AND. n.GT.0 .AND. wu.LE.wl ) THEN
422 info = -7
423 ELSE IF( indeig .AND. ( iil.LT.1 .OR. iil.GT.n ) ) THEN
424 info = -8
425 ELSE IF( indeig .AND. ( iiu.LT.iil .OR. iiu.GT.n ) ) THEN
426 info = -9
427 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) ) THEN
428 info = -13
429 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
430 info = -17
431 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery ) THEN
432 info = -19
433 END IF
434*
435* Get machine constants.
436*
437 safmin = dlamch( 'Safe minimum' )
438 eps = dlamch( 'Precision' )
439 smlnum = safmin / eps
440 bignum = one / smlnum
441 rmin = sqrt( smlnum )
442 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
443*
444 IF( info.EQ.0 ) THEN
445 work( 1 ) = lwmin
446 iwork( 1 ) = liwmin
447*
448 IF( wantz .AND. alleig ) THEN
449 nzcmin = n
450 ELSE IF( wantz .AND. valeig ) THEN
451 CALL dlarrc( 'T', n, vl, vu, d, e, safmin,
452 $ nzcmin, itmp, itmp2, info )
453 ELSE IF( wantz .AND. indeig ) THEN
454 nzcmin = iiu-iil+1
455 ELSE
456* WANTZ .EQ. FALSE.
457 nzcmin = 0
458 ENDIF
459 IF( zquery .AND. info.EQ.0 ) THEN
460 z( 1,1 ) = nzcmin
461 ELSE IF( nzc.LT.nzcmin .AND. .NOT.zquery ) THEN
462 info = -14
463 END IF
464 END IF
465
466 IF( info.NE.0 ) THEN
467*
468 CALL xerbla( 'DSTEMR', -info )
469*
470 RETURN
471 ELSE IF( lquery .OR. zquery ) THEN
472 RETURN
473 END IF
474*
475* Handle N = 0, 1, and 2 cases immediately
476*
477 m = 0
478 IF( n.EQ.0 )
479 $ RETURN
480*
481 IF( n.EQ.1 ) THEN
482 IF( alleig .OR. indeig ) THEN
483 m = 1
484 w( 1 ) = d( 1 )
485 ELSE
486 IF( wl.LT.d( 1 ) .AND. wu.GE.d( 1 ) ) THEN
487 m = 1
488 w( 1 ) = d( 1 )
489 END IF
490 END IF
491 IF( wantz.AND.(.NOT.zquery) ) THEN
492 z( 1, 1 ) = one
493 isuppz(1) = 1
494 isuppz(2) = 1
495 END IF
496 RETURN
497 END IF
498*
499 IF( n.EQ.2 ) THEN
500 IF( .NOT.wantz ) THEN
501 CALL dlae2( d(1), e(1), d(2), r1, r2 )
502 ELSE IF( wantz.AND.(.NOT.zquery) ) THEN
503 CALL dlaev2( d(1), e(1), d(2), r1, r2, cs, sn )
504 END IF
505 IF( alleig.OR.
506 $ (valeig.AND.(r2.GT.wl).AND.
507 $ (r2.LE.wu)).OR.
508 $ (indeig.AND.(iil.EQ.1)) ) THEN
509 m = m+1
510 w( m ) = r2
511 IF( wantz.AND.(.NOT.zquery) ) THEN
512 z( 1, m ) = -sn
513 z( 2, m ) = cs
514* Note: At most one of SN and CS can be zero.
515 IF (sn.NE.zero) THEN
516 IF (cs.NE.zero) THEN
517 isuppz(2*m-1) = 1
518 isuppz(2*m) = 2
519 ELSE
520 isuppz(2*m-1) = 1
521 isuppz(2*m) = 1
522 END IF
523 ELSE
524 isuppz(2*m-1) = 2
525 isuppz(2*m) = 2
526 END IF
527 ENDIF
528 ENDIF
529 IF( alleig.OR.
530 $ (valeig.AND.(r1.GT.wl).AND.
531 $ (r1.LE.wu)).OR.
532 $ (indeig.AND.(iiu.EQ.2)) ) THEN
533 m = m+1
534 w( m ) = r1
535 IF( wantz.AND.(.NOT.zquery) ) THEN
536 z( 1, m ) = cs
537 z( 2, m ) = sn
538* Note: At most one of SN and CS can be zero.
539 IF (sn.NE.zero) THEN
540 IF (cs.NE.zero) THEN
541 isuppz(2*m-1) = 1
542 isuppz(2*m) = 2
543 ELSE
544 isuppz(2*m-1) = 1
545 isuppz(2*m) = 1
546 END IF
547 ELSE
548 isuppz(2*m-1) = 2
549 isuppz(2*m) = 2
550 END IF
551 ENDIF
552 ENDIF
553
554 ELSE
555
556* Continue with general N
557
558 indgrs = 1
559 inderr = 2*n + 1
560 indgp = 3*n + 1
561 indd = 4*n + 1
562 inde2 = 5*n + 1
563 indwrk = 6*n + 1
564*
565 iinspl = 1
566 iindbl = n + 1
567 iindw = 2*n + 1
568 iindwk = 3*n + 1
569*
570* Scale matrix to allowable range, if necessary.
571* The allowable range is related to the PIVMIN parameter; see the
572* comments in DLARRD. The preference for scaling small values
573* up is heuristic; we expect users' matrices not to be close to the
574* RMAX threshold.
575*
576 scale = one
577 tnrm = dlanst( 'M', n, d, e )
578 IF( tnrm.GT.zero .AND. tnrm.LT.rmin ) THEN
579 scale = rmin / tnrm
580 ELSE IF( tnrm.GT.rmax ) THEN
581 scale = rmax / tnrm
582 END IF
583 IF( scale.NE.one ) THEN
584 CALL dscal( n, scale, d, 1 )
585 CALL dscal( n-1, scale, e, 1 )
586 tnrm = tnrm*scale
587 IF( valeig ) THEN
588* If eigenvalues in interval have to be found,
589* scale (WL, WU] accordingly
590 wl = wl*scale
591 wu = wu*scale
592 ENDIF
593 END IF
594*
595* Compute the desired eigenvalues of the tridiagonal after splitting
596* into smaller subblocks if the corresponding off-diagonal elements
597* are small
598* THRESH is the splitting parameter for DLARRE
599* A negative THRESH forces the old splitting criterion based on the
600* size of the off-diagonal. A positive THRESH switches to splitting
601* which preserves relative accuracy.
602*
603 IF( tryrac ) THEN
604* Test whether the matrix warrants the more expensive relative approach.
605 CALL dlarrr( n, d, e, iinfo )
606 ELSE
607* The user does not care about relative accurately eigenvalues
608 iinfo = -1
609 ENDIF
610* Set the splitting criterion
611 IF (iinfo.EQ.0) THEN
612 thresh = eps
613 ELSE
614 thresh = -eps
615* relative accuracy is desired but T does not guarantee it
616 tryrac = .false.
617 ENDIF
618*
619 IF( tryrac ) THEN
620* Copy original diagonal, needed to guarantee relative accuracy
621 CALL dcopy(n,d,1,work(indd),1)
622 ENDIF
623* Store the squares of the offdiagonal values of T
624 DO 5 j = 1, n-1
625 work( inde2+j-1 ) = e(j)**2
626 5 CONTINUE
627
628* Set the tolerance parameters for bisection
629 IF( .NOT.wantz ) THEN
630* DLARRE computes the eigenvalues to full precision.
631 rtol1 = four * eps
632 rtol2 = four * eps
633 ELSE
634* DLARRE computes the eigenvalues to less than full precision.
635* DLARRV will refine the eigenvalue approximations, and we can
636* need less accurate initial bisection in DLARRE.
637* Note: these settings do only affect the subset case and DLARRE
638 rtol1 = sqrt(eps)
639 rtol2 = max( sqrt(eps)*5.0d-3, four * eps )
640 ENDIF
641 CALL dlarre( range, n, wl, wu, iil, iiu, d, e,
642 $ work(inde2), rtol1, rtol2, thresh, nsplit,
643 $ iwork( iinspl ), m, w, work( inderr ),
644 $ work( indgp ), iwork( iindbl ),
645 $ iwork( iindw ), work( indgrs ), pivmin,
646 $ work( indwrk ), iwork( iindwk ), iinfo )
647 IF( iinfo.NE.0 ) THEN
648 info = 10 + abs( iinfo )
649 RETURN
650 END IF
651* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired
652* part of the spectrum. All desired eigenvalues are contained in
653* (WL,WU]
654
655
656 IF( wantz ) THEN
657*
658* Compute the desired eigenvectors corresponding to the computed
659* eigenvalues
660*
661 CALL dlarrv( n, wl, wu, d, e,
662 $ pivmin, iwork( iinspl ), m,
663 $ 1, m, minrgp, rtol1, rtol2,
664 $ w, work( inderr ), work( indgp ), iwork( iindbl ),
665 $ iwork( iindw ), work( indgrs ), z, ldz,
666 $ isuppz, work( indwrk ), iwork( iindwk ), iinfo )
667 IF( iinfo.NE.0 ) THEN
668 info = 20 + abs( iinfo )
669 RETURN
670 END IF
671 ELSE
672* DLARRE computes eigenvalues of the (shifted) root representation
673* DLARRV returns the eigenvalues of the unshifted matrix.
674* However, if the eigenvectors are not desired by the user, we need
675* to apply the corresponding shifts from DLARRE to obtain the
676* eigenvalues of the original matrix.
677 DO 20 j = 1, m
678 itmp = iwork( iindbl+j-1 )
679 w( j ) = w( j ) + e( iwork( iinspl+itmp-1 ) )
680 20 CONTINUE
681 END IF
682*
683
684 IF ( tryrac ) THEN
685* Refine computed eigenvalues so that they are relatively accurate
686* with respect to the original matrix T.
687 ibegin = 1
688 wbegin = 1
689 DO 39 jblk = 1, iwork( iindbl+m-1 )
690 iend = iwork( iinspl+jblk-1 )
691 in = iend - ibegin + 1
692 wend = wbegin - 1
693* check if any eigenvalues have to be refined in this block
694 36 CONTINUE
695 IF( wend.LT.m ) THEN
696 IF( iwork( iindbl+wend ).EQ.jblk ) THEN
697 wend = wend + 1
698 GO TO 36
699 END IF
700 END IF
701 IF( wend.LT.wbegin ) THEN
702 ibegin = iend + 1
703 GO TO 39
704 END IF
705
706 offset = iwork(iindw+wbegin-1)-1
707 ifirst = iwork(iindw+wbegin-1)
708 ilast = iwork(iindw+wend-1)
709 rtol2 = four * eps
710 CALL dlarrj( in,
711 $ work(indd+ibegin-1), work(inde2+ibegin-1),
712 $ ifirst, ilast, rtol2, offset, w(wbegin),
713 $ work( inderr+wbegin-1 ),
714 $ work( indwrk ), iwork( iindwk ), pivmin,
715 $ tnrm, iinfo )
716 ibegin = iend + 1
717 wbegin = wend + 1
718 39 CONTINUE
719 ENDIF
720*
721* If matrix was scaled, then rescale eigenvalues appropriately.
722*
723 IF( scale.NE.one ) THEN
724 CALL dscal( m, one / scale, w, 1 )
725 END IF
726
727 END IF
728
729*
730* If eigenvalues are not in increasing order, then sort them,
731* possibly along with eigenvectors.
732*
733 IF( nsplit.GT.1 .OR. n.EQ.2 ) THEN
734 IF( .NOT. wantz ) THEN
735 CALL dlasrt( 'I', m, w, iinfo )
736 IF( iinfo.NE.0 ) THEN
737 info = 3
738 RETURN
739 END IF
740 ELSE
741 DO 60 j = 1, m - 1
742 i = 0
743 tmp = w( j )
744 DO 50 jj = j + 1, m
745 IF( w( jj ).LT.tmp ) THEN
746 i = jj
747 tmp = w( jj )
748 END IF
749 50 CONTINUE
750 IF( i.NE.0 ) THEN
751 w( i ) = w( j )
752 w( j ) = tmp
753 IF( wantz ) THEN
754 CALL dswap( n, z( 1, i ), 1, z( 1, j ), 1 )
755 itmp = isuppz( 2*i-1 )
756 isuppz( 2*i-1 ) = isuppz( 2*j-1 )
757 isuppz( 2*j-1 ) = itmp
758 itmp = isuppz( 2*i )
759 isuppz( 2*i ) = isuppz( 2*j )
760 isuppz( 2*j ) = itmp
761 END IF
762 END IF
763 60 CONTINUE
764 END IF
765 ENDIF
766*
767*
768 work( 1 ) = lwmin
769 iwork( 1 ) = liwmin
770 RETURN
771*
772* End of DSTEMR
773*
dlarrr
subroutine dlarrr(n, d, e, info)
DLARRR performs tests to decide whether the symmetric tridiagonal matrix T warrants expensive computa...
Definition dlarrr.f:94
dlarrj
subroutine dlarrj(n, d, e2, ifirst, ilast, rtol, offset, w, werr, work, iwork, pivmin, spdiam, info)
DLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T.
Definition dlarrj.f:168
dlarrc
subroutine dlarrc(jobt, n, vl, vu, d, e, pivmin, eigcnt, lcnt, rcnt, info)
DLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix.
Definition dlarrc.f:137
dlae2
subroutine dlae2(a, b, c, rt1, rt2)
DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.
Definition dlae2.f:102
dlarre
subroutine dlarre(range, n, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, work, iwork, info)
DLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduce...
Definition dlarre.f:305
dlaev2
subroutine dlaev2(a, b, c, rt1, rt2, cs1, sn1)
DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
Definition dlaev2.f:120
dlarrv
subroutine dlarrv(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)
DLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues ...
Definition dlarrv.f:292

◆ dtbcon()

subroutine dtbcon ( character norm,
character uplo,
character diag,
integer n,
integer kd,
double precision, dimension( ldab, * ) ab,
integer ldab,
double precision rcond,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DTBCON

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

Purpose:
!>
!> DTBCON 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 DOUBLE PRECISION array, dimension (LDAB,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first kd+1 rows of the array. The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dtbcon.f.

143*
144* -- LAPACK computational routine --
145* -- LAPACK is a software package provided by Univ. of Tennessee, --
146* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
147*
148* .. Scalar Arguments ..
149 CHARACTER DIAG, NORM, UPLO
150 INTEGER INFO, KD, LDAB, N
151 DOUBLE PRECISION RCOND
152* ..
153* .. Array Arguments ..
154 INTEGER IWORK( * )
155 DOUBLE PRECISION AB( LDAB, * ), WORK( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 DOUBLE PRECISION ONE, ZERO
162 parameter( one = 1.0d+0, zero = 0.0d+0 )
163* ..
164* .. Local Scalars ..
165 LOGICAL NOUNIT, ONENRM, UPPER
166 CHARACTER NORMIN
167 INTEGER IX, KASE, KASE1
168 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
169* ..
170* .. Local Arrays ..
171 INTEGER ISAVE( 3 )
172* ..
173* .. External Functions ..
174 LOGICAL LSAME
175 INTEGER IDAMAX
176 DOUBLE PRECISION DLAMCH, DLANTB
177 EXTERNAL lsame, idamax, dlamch, dlantb
178* ..
179* .. External Subroutines ..
180 EXTERNAL dlacn2, dlatbs, drscl, xerbla
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC abs, dble, max
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( 'DTBCON', -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 = dlamch( 'Safe minimum' )*dble( max( 1, n ) )
221*
222* Compute the norm of the triangular matrix A.
223*
224 anorm = dlantb( 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 dlacn2( 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 dlatbs( 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 dlatbs( 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 = idamax( n, work, 1 )
262 xnorm = abs( work( ix ) )
263 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
264 $ GO TO 20
265 CALL drscl( 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 DTBCON
280*
dlantb
double precision function dlantb(norm, uplo, diag, n, k, ab, ldab, work)
DLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlantb.f:140

◆ dtbrfs()

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

DTBRFS

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

Purpose:
!>
!> DTBRFS 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 DTBTRS or some other
!> means before entering this routine.  DTBRFS 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dtbrfs.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 DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ),
200 $ FERR( * ), WORK( * ), X( LDX, * )
201* ..
202*
203* =====================================================================
204*
205* .. Parameters ..
206 DOUBLE PRECISION ZERO
207 parameter( zero = 0.0d+0 )
208 DOUBLE PRECISION ONE
209 parameter( one = 1.0d+0 )
210* ..
211* .. Local Scalars ..
212 LOGICAL NOTRAN, NOUNIT, UPPER
213 CHARACTER TRANST
214 INTEGER I, J, K, KASE, NZ
215 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
216* ..
217* .. Local Arrays ..
218 INTEGER ISAVE( 3 )
219* ..
220* .. External Subroutines ..
221 EXTERNAL daxpy, dcopy, dlacn2, dtbmv, dtbsv, xerbla
222* ..
223* .. Intrinsic Functions ..
224 INTRINSIC abs, max, min
225* ..
226* .. External Functions ..
227 LOGICAL LSAME
228 DOUBLE PRECISION DLAMCH
229 EXTERNAL lsame, dlamch
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( 'DTBRFS', -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 = dlamch( 'Epsilon' )
285 safmin = dlamch( '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 dcopy( n, x( 1, j ), 1, work( n+1 ), 1 )
297 CALL dtbmv( uplo, trans, diag, n, kd, ab, ldab, work( n+1 ),
298 $ 1 )
299 CALL daxpy( 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 DLACN2 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 dlacn2( 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 dtbsv( 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 dtbsv( 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 DTBRFS
481*
dtbmv
subroutine dtbmv(uplo, trans, diag, n, k, a, lda, x, incx)
DTBMV
Definition dtbmv.f:186

◆ dtbtrs()

subroutine dtbtrs ( character uplo,
character trans,
character diag,
integer n,
integer kd,
integer nrhs,
double precision, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DTBTRS

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

Purpose:
!>
!> DTBTRS 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtbtrs.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 DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 DOUBLE PRECISION ZERO
163 parameter( zero = 0.0d+0 )
164* ..
165* .. Local Scalars ..
166 LOGICAL NOUNIT, UPPER
167 INTEGER J
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 EXTERNAL lsame
172* ..
173* .. External Subroutines ..
174 EXTERNAL dtbsv, 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( 'DTBTRS', -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 dtbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1, j ), 1 )
235 30 CONTINUE
236*
237 RETURN
238*
239* End of DTBTRS
240*

◆ dtfsm()

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

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

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

Purpose:
!>
!> Level 3 BLAS like routine for A in RFP Format.
!>
!> DTFSM  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 DOUBLE PRECISION
!>           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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtfsm.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 DOUBLE PRECISION ALPHA
286* ..
287* .. Array Arguments ..
288 DOUBLE PRECISION A( 0: * ), B( 0: LDB-1, 0: * )
289* ..
290*
291* =====================================================================
292*
293* ..
294* .. Parameters ..
295 DOUBLE PRECISION ONE, ZERO
296 parameter( one = 1.0d+0, zero = 0.0d+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 xerbla, dgemm, dtrsm
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( 'DTFSM ', -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*
384 IF( misodd ) THEN
385*
386* SIDE = 'L' and N is odd
387*
388 IF( normaltransr ) THEN
389*
390* SIDE = 'L', N is odd, and TRANSR = 'N'
391*
392 IF( lower ) THEN
393*
394* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L'
395*
396 IF( notrans ) THEN
397*
398* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and
399* TRANS = 'N'
400*
401 IF( m.EQ.1 ) THEN
402 CALL dtrsm( 'L', 'L', 'N', diag, m1, n, alpha,
403 $ a, m, b, ldb )
404 ELSE
405 CALL dtrsm( 'L', 'L', 'N', diag, m1, n, alpha,
406 $ a( 0 ), m, b, ldb )
407 CALL dgemm( 'N', 'N', m2, n, m1, -one, a( m1 ),
408 $ m, b, ldb, alpha, b( m1, 0 ), ldb )
409 CALL dtrsm( 'L', 'U', 'T', diag, m2, n, one,
410 $ a( m ), m, b( m1, 0 ), ldb )
411 END IF
412*
413 ELSE
414*
415* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and
416* TRANS = 'T'
417*
418 IF( m.EQ.1 ) THEN
419 CALL dtrsm( 'L', 'L', 'T', diag, m1, n, alpha,
420 $ a( 0 ), m, b, ldb )
421 ELSE
422 CALL dtrsm( 'L', 'U', 'N', diag, m2, n, alpha,
423 $ a( m ), m, b( m1, 0 ), ldb )
424 CALL dgemm( 'T', 'N', m1, n, m2, -one, a( m1 ),
425 $ m, b( m1, 0 ), ldb, alpha, b, ldb )
426 CALL dtrsm( 'L', 'L', 'T', diag, m1, n, one,
427 $ a( 0 ), m, b, ldb )
428 END IF
429*
430 END IF
431*
432 ELSE
433*
434* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U'
435*
436 IF( .NOT.notrans ) THEN
437*
438* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and
439* TRANS = 'N'
440*
441 CALL dtrsm( 'L', 'L', 'N', diag, m1, n, alpha,
442 $ a( m2 ), m, b, ldb )
443 CALL dgemm( 'T', 'N', m2, n, m1, -one, a( 0 ), m,
444 $ b, ldb, alpha, b( m1, 0 ), ldb )
445 CALL dtrsm( 'L', 'U', 'T', diag, m2, n, one,
446 $ a( m1 ), m, b( m1, 0 ), ldb )
447*
448 ELSE
449*
450* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and
451* TRANS = 'T'
452*
453 CALL dtrsm( 'L', 'U', 'N', diag, m2, n, alpha,
454 $ a( m1 ), m, b( m1, 0 ), ldb )
455 CALL dgemm( 'N', 'N', m1, n, m2, -one, a( 0 ), m,
456 $ b( m1, 0 ), ldb, alpha, b, ldb )
457 CALL dtrsm( 'L', 'L', 'T', diag, m1, n, one,
458 $ a( m2 ), m, b, ldb )
459*
460 END IF
461*
462 END IF
463*
464 ELSE
465*
466* SIDE = 'L', N is odd, and TRANSR = 'T'
467*
468 IF( lower ) THEN
469*
470* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L'
471*
472 IF( notrans ) THEN
473*
474* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and
475* TRANS = 'N'
476*
477 IF( m.EQ.1 ) THEN
478 CALL dtrsm( 'L', 'U', 'T', diag, m1, n, alpha,
479 $ a( 0 ), m1, b, ldb )
480 ELSE
481 CALL dtrsm( 'L', 'U', 'T', diag, m1, n, alpha,
482 $ a( 0 ), m1, b, ldb )
483 CALL dgemm( 'T', 'N', m2, n, m1, -one,
484 $ a( m1*m1 ), m1, b, ldb, alpha,
485 $ b( m1, 0 ), ldb )
486 CALL dtrsm( 'L', 'L', 'N', diag, m2, n, one,
487 $ a( 1 ), m1, b( m1, 0 ), ldb )
488 END IF
489*
490 ELSE
491*
492* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and
493* TRANS = 'T'
494*
495 IF( m.EQ.1 ) THEN
496 CALL dtrsm( 'L', 'U', 'N', diag, m1, n, alpha,
497 $ a( 0 ), m1, b, ldb )
498 ELSE
499 CALL dtrsm( 'L', 'L', 'T', diag, m2, n, alpha,
500 $ a( 1 ), m1, b( m1, 0 ), ldb )
501 CALL dgemm( 'N', 'N', m1, n, m2, -one,
502 $ a( m1*m1 ), m1, b( m1, 0 ), ldb,
503 $ alpha, b, ldb )
504 CALL dtrsm( 'L', 'U', 'N', diag, m1, n, one,
505 $ a( 0 ), m1, b, ldb )
506 END IF
507*
508 END IF
509*
510 ELSE
511*
512* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U'
513*
514 IF( .NOT.notrans ) THEN
515*
516* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and
517* TRANS = 'N'
518*
519 CALL dtrsm( 'L', 'U', 'T', diag, m1, n, alpha,
520 $ a( m2*m2 ), m2, b, ldb )
521 CALL dgemm( 'N', 'N', m2, n, m1, -one, a( 0 ), m2,
522 $ b, ldb, alpha, b( m1, 0 ), ldb )
523 CALL dtrsm( 'L', 'L', 'N', diag, m2, n, one,
524 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
525*
526 ELSE
527*
528* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and
529* TRANS = 'T'
530*
531 CALL dtrsm( 'L', 'L', 'T', diag, m2, n, alpha,
532 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
533 CALL dgemm( 'T', 'N', m1, n, m2, -one, a( 0 ), m2,
534 $ b( m1, 0 ), ldb, alpha, b, ldb )
535 CALL dtrsm( 'L', 'U', 'N', diag, m1, n, one,
536 $ a( m2*m2 ), m2, b, ldb )
537*
538 END IF
539*
540 END IF
541*
542 END IF
543*
544 ELSE
545*
546* SIDE = 'L' and N is even
547*
548 IF( normaltransr ) THEN
549*
550* SIDE = 'L', N is even, and TRANSR = 'N'
551*
552 IF( lower ) THEN
553*
554* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L'
555*
556 IF( notrans ) THEN
557*
558* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L',
559* and TRANS = 'N'
560*
561 CALL dtrsm( 'L', 'L', 'N', diag, k, n, alpha,
562 $ a( 1 ), m+1, b, ldb )
563 CALL dgemm( 'N', 'N', k, n, k, -one, a( k+1 ),
564 $ m+1, b, ldb, alpha, b( k, 0 ), ldb )
565 CALL dtrsm( 'L', 'U', 'T', diag, k, n, one,
566 $ a( 0 ), m+1, b( k, 0 ), ldb )
567*
568 ELSE
569*
570* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L',
571* and TRANS = 'T'
572*
573 CALL dtrsm( 'L', 'U', 'N', diag, k, n, alpha,
574 $ a( 0 ), m+1, b( k, 0 ), ldb )
575 CALL dgemm( 'T', 'N', k, n, k, -one, a( k+1 ),
576 $ m+1, b( k, 0 ), ldb, alpha, b, ldb )
577 CALL dtrsm( 'L', 'L', 'T', diag, k, n, one,
578 $ a( 1 ), m+1, b, ldb )
579*
580 END IF
581*
582 ELSE
583*
584* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U'
585*
586 IF( .NOT.notrans ) THEN
587*
588* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U',
589* and TRANS = 'N'
590*
591 CALL dtrsm( 'L', 'L', 'N', diag, k, n, alpha,
592 $ a( k+1 ), m+1, b, ldb )
593 CALL dgemm( 'T', 'N', k, n, k, -one, a( 0 ), m+1,
594 $ b, ldb, alpha, b( k, 0 ), ldb )
595 CALL dtrsm( 'L', 'U', 'T', diag, k, n, one,
596 $ a( k ), m+1, b( k, 0 ), ldb )
597*
598 ELSE
599*
600* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U',
601* and TRANS = 'T'
602 CALL dtrsm( 'L', 'U', 'N', diag, k, n, alpha,
603 $ a( k ), m+1, b( k, 0 ), ldb )
604 CALL dgemm( 'N', 'N', k, n, k, -one, a( 0 ), m+1,
605 $ b( k, 0 ), ldb, alpha, b, ldb )
606 CALL dtrsm( 'L', 'L', 'T', diag, k, n, one,
607 $ a( k+1 ), m+1, b, ldb )
608*
609 END IF
610*
611 END IF
612*
613 ELSE
614*
615* SIDE = 'L', N is even, and TRANSR = 'T'
616*
617 IF( lower ) THEN
618*
619* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L'
620*
621 IF( notrans ) THEN
622*
623* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L',
624* and TRANS = 'N'
625*
626 CALL dtrsm( 'L', 'U', 'T', diag, k, n, alpha,
627 $ a( k ), k, b, ldb )
628 CALL dgemm( 'T', 'N', k, n, k, -one,
629 $ a( k*( k+1 ) ), k, b, ldb, alpha,
630 $ b( k, 0 ), ldb )
631 CALL dtrsm( 'L', 'L', 'N', diag, k, n, one,
632 $ a( 0 ), k, b( k, 0 ), ldb )
633*
634 ELSE
635*
636* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L',
637* and TRANS = 'T'
638*
639 CALL dtrsm( 'L', 'L', 'T', diag, k, n, alpha,
640 $ a( 0 ), k, b( k, 0 ), ldb )
641 CALL dgemm( 'N', 'N', k, n, k, -one,
642 $ a( k*( k+1 ) ), k, b( k, 0 ), ldb,
643 $ alpha, b, ldb )
644 CALL dtrsm( 'L', 'U', 'N', diag, k, n, one,
645 $ a( k ), k, b, ldb )
646*
647 END IF
648*
649 ELSE
650*
651* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U'
652*
653 IF( .NOT.notrans ) THEN
654*
655* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U',
656* and TRANS = 'N'
657*
658 CALL dtrsm( 'L', 'U', 'T', diag, k, n, alpha,
659 $ a( k*( k+1 ) ), k, b, ldb )
660 CALL dgemm( 'N', 'N', k, n, k, -one, a( 0 ), k, b,
661 $ ldb, alpha, b( k, 0 ), ldb )
662 CALL dtrsm( 'L', 'L', 'N', diag, k, n, one,
663 $ a( k*k ), k, b( k, 0 ), ldb )
664*
665 ELSE
666*
667* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U',
668* and TRANS = 'T'
669*
670 CALL dtrsm( 'L', 'L', 'T', diag, k, n, alpha,
671 $ a( k*k ), k, b( k, 0 ), ldb )
672 CALL dgemm( 'T', 'N', k, n, k, -one, a( 0 ), k,
673 $ b( k, 0 ), ldb, alpha, b, ldb )
674 CALL dtrsm( 'L', 'U', 'N', diag, k, n, one,
675 $ a( k*( k+1 ) ), k, b, ldb )
676*
677 END IF
678*
679 END IF
680*
681 END IF
682*
683 END IF
684*
685 ELSE
686*
687* SIDE = 'R'
688*
689* A is N-by-N.
690* If N is odd, set NISODD = .TRUE., and N1 and N2.
691* If N is even, NISODD = .FALSE., and K.
692*
693 IF( mod( n, 2 ).EQ.0 ) THEN
694 nisodd = .false.
695 k = n / 2
696 ELSE
697 nisodd = .true.
698 IF( lower ) THEN
699 n2 = n / 2
700 n1 = n - n2
701 ELSE
702 n1 = n / 2
703 n2 = n - n1
704 END IF
705 END IF
706*
707 IF( nisodd ) THEN
708*
709* SIDE = 'R' and N is odd
710*
711 IF( normaltransr ) THEN
712*
713* SIDE = 'R', N is odd, and TRANSR = 'N'
714*
715 IF( lower ) THEN
716*
717* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L'
718*
719 IF( notrans ) THEN
720*
721* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and
722* TRANS = 'N'
723*
724 CALL dtrsm( 'R', 'U', 'T', diag, m, n2, alpha,
725 $ a( n ), n, b( 0, n1 ), ldb )
726 CALL dgemm( 'N', 'N', m, n1, n2, -one, b( 0, n1 ),
727 $ ldb, a( n1 ), n, alpha, b( 0, 0 ),
728 $ ldb )
729 CALL dtrsm( 'R', 'L', 'N', diag, m, n1, one,
730 $ a( 0 ), n, b( 0, 0 ), ldb )
731*
732 ELSE
733*
734* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and
735* TRANS = 'T'
736*
737 CALL dtrsm( 'R', 'L', 'T', diag, m, n1, alpha,
738 $ a( 0 ), n, b( 0, 0 ), ldb )
739 CALL dgemm( 'N', 'T', m, n2, n1, -one, b( 0, 0 ),
740 $ ldb, a( n1 ), n, alpha, b( 0, n1 ),
741 $ ldb )
742 CALL dtrsm( 'R', 'U', 'N', diag, m, n2, one,
743 $ a( n ), n, b( 0, n1 ), ldb )
744*
745 END IF
746*
747 ELSE
748*
749* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U'
750*
751 IF( notrans ) THEN
752*
753* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and
754* TRANS = 'N'
755*
756 CALL dtrsm( 'R', 'L', 'T', diag, m, n1, alpha,
757 $ a( n2 ), n, b( 0, 0 ), ldb )
758 CALL dgemm( 'N', 'N', m, n2, n1, -one, b( 0, 0 ),
759 $ ldb, a( 0 ), n, alpha, b( 0, n1 ),
760 $ ldb )
761 CALL dtrsm( 'R', 'U', 'N', diag, m, n2, one,
762 $ a( n1 ), n, b( 0, n1 ), ldb )
763*
764 ELSE
765*
766* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and
767* TRANS = 'T'
768*
769 CALL dtrsm( 'R', 'U', 'T', diag, m, n2, alpha,
770 $ a( n1 ), n, b( 0, n1 ), ldb )
771 CALL dgemm( 'N', 'T', m, n1, n2, -one, b( 0, n1 ),
772 $ ldb, a( 0 ), n, alpha, b( 0, 0 ), ldb )
773 CALL dtrsm( 'R', 'L', 'N', diag, m, n1, one,
774 $ a( n2 ), n, b( 0, 0 ), ldb )
775*
776 END IF
777*
778 END IF
779*
780 ELSE
781*
782* SIDE = 'R', N is odd, and TRANSR = 'T'
783*
784 IF( lower ) THEN
785*
786* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L'
787*
788 IF( notrans ) THEN
789*
790* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and
791* TRANS = 'N'
792*
793 CALL dtrsm( 'R', 'L', 'N', diag, m, n2, alpha,
794 $ a( 1 ), n1, b( 0, n1 ), ldb )
795 CALL dgemm( 'N', 'T', m, n1, n2, -one, b( 0, n1 ),
796 $ ldb, a( n1*n1 ), n1, alpha, b( 0, 0 ),
797 $ ldb )
798 CALL dtrsm( 'R', 'U', 'T', diag, m, n1, one,
799 $ a( 0 ), n1, b( 0, 0 ), ldb )
800*
801 ELSE
802*
803* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and
804* TRANS = 'T'
805*
806 CALL dtrsm( 'R', 'U', 'N', diag, m, n1, alpha,
807 $ a( 0 ), n1, b( 0, 0 ), ldb )
808 CALL dgemm( 'N', 'N', m, n2, n1, -one, b( 0, 0 ),
809 $ ldb, a( n1*n1 ), n1, alpha, b( 0, n1 ),
810 $ ldb )
811 CALL dtrsm( 'R', 'L', 'T', diag, m, n2, one,
812 $ a( 1 ), n1, b( 0, n1 ), ldb )
813*
814 END IF
815*
816 ELSE
817*
818* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U'
819*
820 IF( notrans ) THEN
821*
822* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and
823* TRANS = 'N'
824*
825 CALL dtrsm( 'R', 'U', 'N', diag, m, n1, alpha,
826 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
827 CALL dgemm( 'N', 'T', m, n2, n1, -one, b( 0, 0 ),
828 $ ldb, a( 0 ), n2, alpha, b( 0, n1 ),
829 $ ldb )
830 CALL dtrsm( 'R', 'L', 'T', diag, m, n2, one,
831 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
832*
833 ELSE
834*
835* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and
836* TRANS = 'T'
837*
838 CALL dtrsm( 'R', 'L', 'N', diag, m, n2, alpha,
839 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
840 CALL dgemm( 'N', 'N', m, n1, n2, -one, b( 0, n1 ),
841 $ ldb, a( 0 ), n2, alpha, b( 0, 0 ),
842 $ ldb )
843 CALL dtrsm( 'R', 'U', 'T', diag, m, n1, one,
844 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
845*
846 END IF
847*
848 END IF
849*
850 END IF
851*
852 ELSE
853*
854* SIDE = 'R' and N is even
855*
856 IF( normaltransr ) THEN
857*
858* SIDE = 'R', N is even, and TRANSR = 'N'
859*
860 IF( lower ) THEN
861*
862* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L'
863*
864 IF( notrans ) THEN
865*
866* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L',
867* and TRANS = 'N'
868*
869 CALL dtrsm( 'R', 'U', 'T', diag, m, k, alpha,
870 $ a( 0 ), n+1, b( 0, k ), ldb )
871 CALL dgemm( 'N', 'N', m, k, k, -one, b( 0, k ),
872 $ ldb, a( k+1 ), n+1, alpha, b( 0, 0 ),
873 $ ldb )
874 CALL dtrsm( 'R', 'L', 'N', diag, m, k, one,
875 $ a( 1 ), n+1, b( 0, 0 ), ldb )
876*
877 ELSE
878*
879* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L',
880* and TRANS = 'T'
881*
882 CALL dtrsm( 'R', 'L', 'T', diag, m, k, alpha,
883 $ a( 1 ), n+1, b( 0, 0 ), ldb )
884 CALL dgemm( 'N', 'T', m, k, k, -one, b( 0, 0 ),
885 $ ldb, a( k+1 ), n+1, alpha, b( 0, k ),
886 $ ldb )
887 CALL dtrsm( 'R', 'U', 'N', diag, m, k, one,
888 $ a( 0 ), n+1, b( 0, k ), ldb )
889*
890 END IF
891*
892 ELSE
893*
894* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U'
895*
896 IF( notrans ) THEN
897*
898* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U',
899* and TRANS = 'N'
900*
901 CALL dtrsm( 'R', 'L', 'T', diag, m, k, alpha,
902 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
903 CALL dgemm( 'N', 'N', m, k, k, -one, b( 0, 0 ),
904 $ ldb, a( 0 ), n+1, alpha, b( 0, k ),
905 $ ldb )
906 CALL dtrsm( 'R', 'U', 'N', diag, m, k, one,
907 $ a( k ), n+1, b( 0, k ), ldb )
908*
909 ELSE
910*
911* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U',
912* and TRANS = 'T'
913*
914 CALL dtrsm( 'R', 'U', 'T', diag, m, k, alpha,
915 $ a( k ), n+1, b( 0, k ), ldb )
916 CALL dgemm( 'N', 'T', m, k, k, -one, b( 0, k ),
917 $ ldb, a( 0 ), n+1, alpha, b( 0, 0 ),
918 $ ldb )
919 CALL dtrsm( 'R', 'L', 'N', diag, m, k, one,
920 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
921*
922 END IF
923*
924 END IF
925*
926 ELSE
927*
928* SIDE = 'R', N is even, and TRANSR = 'T'
929*
930 IF( lower ) THEN
931*
932* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L'
933*
934 IF( notrans ) THEN
935*
936* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L',
937* and TRANS = 'N'
938*
939 CALL dtrsm( 'R', 'L', 'N', diag, m, k, alpha,
940 $ a( 0 ), k, b( 0, k ), ldb )
941 CALL dgemm( 'N', 'T', m, k, k, -one, b( 0, k ),
942 $ ldb, a( ( k+1 )*k ), k, alpha,
943 $ b( 0, 0 ), ldb )
944 CALL dtrsm( 'R', 'U', 'T', diag, m, k, one,
945 $ a( k ), k, b( 0, 0 ), ldb )
946*
947 ELSE
948*
949* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L',
950* and TRANS = 'T'
951*
952 CALL dtrsm( 'R', 'U', 'N', diag, m, k, alpha,
953 $ a( k ), k, b( 0, 0 ), ldb )
954 CALL dgemm( 'N', 'N', m, k, k, -one, b( 0, 0 ),
955 $ ldb, a( ( k+1 )*k ), k, alpha,
956 $ b( 0, k ), ldb )
957 CALL dtrsm( 'R', 'L', 'T', diag, m, k, one,
958 $ a( 0 ), k, b( 0, k ), ldb )
959*
960 END IF
961*
962 ELSE
963*
964* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U'
965*
966 IF( notrans ) THEN
967*
968* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U',
969* and TRANS = 'N'
970*
971 CALL dtrsm( 'R', 'U', 'N', diag, m, k, alpha,
972 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
973 CALL dgemm( 'N', 'T', m, k, k, -one, b( 0, 0 ),
974 $ ldb, a( 0 ), k, alpha, b( 0, k ), ldb )
975 CALL dtrsm( 'R', 'L', 'T', diag, m, k, one,
976 $ a( k*k ), k, b( 0, k ), ldb )
977*
978 ELSE
979*
980* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U',
981* and TRANS = 'T'
982*
983 CALL dtrsm( 'R', 'L', 'N', diag, m, k, alpha,
984 $ a( k*k ), k, b( 0, k ), ldb )
985 CALL dgemm( 'N', 'N', m, k, k, -one, b( 0, k ),
986 $ ldb, a( 0 ), k, alpha, b( 0, 0 ), ldb )
987 CALL dtrsm( 'R', 'U', 'T', diag, m, k, one,
988 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
989*
990 END IF
991*
992 END IF
993*
994 END IF
995*
996 END IF
997 END IF
998*
999 RETURN
1000*
1001* End of DTFSM
1002*

◆ dtftri()

subroutine dtftri ( character transr,
character uplo,
character diag,
integer n,
double precision, dimension( 0: * ) a,
integer info )

DTFTRI

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

Purpose:
!>
!> DTFTRI 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 DOUBLE PRECISION array, dimension (0:nt-1);
!>          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 dtftri.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 DOUBLE PRECISION A( 0: * )
212* ..
213*
214* =====================================================================
215*
216* .. Parameters ..
217 DOUBLE PRECISION ONE
218 parameter( one = 1.0d+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, dtrmm, dtrtri
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( 'DTFTRI', -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 dtrtri( 'L', diag, n1, a( 0 ), n, info )
299 IF( info.GT.0 )
300 $ RETURN
301 CALL dtrmm( 'R', 'L', 'N', diag, n2, n1, -one, a( 0 ),
302 $ n, a( n1 ), n )
303 CALL dtrtri( '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 dtrmm( '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 dtrtri( 'L', diag, n1, a( n2 ), n, info )
318 IF( info.GT.0 )
319 $ RETURN
320 CALL dtrmm( 'L', 'L', 'T', diag, n1, n2, -one, a( n2 ),
321 $ n, a( 0 ), n )
322 CALL dtrtri( '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 dtrmm( '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 dtrtri( 'U', diag, n1, a( 0 ), n1, info )
342 IF( info.GT.0 )
343 $ RETURN
344 CALL dtrmm( 'L', 'U', 'N', diag, n1, n2, -one, a( 0 ),
345 $ n1, a( n1*n1 ), n1 )
346 CALL dtrtri( '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 dtrmm( '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 dtrtri( 'U', diag, n1, a( n2*n2 ), n2, info )
360 IF( info.GT.0 )
361 $ RETURN
362 CALL dtrmm( 'R', 'U', 'T', diag, n2, n1, -one,
363 $ a( n2*n2 ), n2, a( 0 ), n2 )
364 CALL dtrtri( '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 dtrmm( '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 dtrtri( 'L', diag, k, a( 1 ), n+1, info )
390 IF( info.GT.0 )
391 $ RETURN
392 CALL dtrmm( 'R', 'L', 'N', diag, k, k, -one, a( 1 ),
393 $ n+1, a( k+1 ), n+1 )
394 CALL dtrtri( '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 dtrmm( '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 dtrtri( 'L', diag, k, a( k+1 ), n+1, info )
409 IF( info.GT.0 )
410 $ RETURN
411 CALL dtrmm( 'L', 'L', 'T', diag, k, k, -one, a( k+1 ),
412 $ n+1, a( 0 ), n+1 )
413 CALL dtrtri( '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 dtrmm( '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 dtrtri( 'U', diag, k, a( k ), k, info )
432 IF( info.GT.0 )
433 $ RETURN
434 CALL dtrmm( 'L', 'U', 'N', diag, k, k, -one, a( k ), k,
435 $ a( k*( k+1 ) ), k )
436 CALL dtrtri( '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 dtrmm( '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 dtrtri( 'U', diag, k, a( k*( k+1 ) ), k, info )
450 IF( info.GT.0 )
451 $ RETURN
452 CALL dtrmm( 'R', 'U', 'T', diag, k, k, -one,
453 $ a( k*( k+1 ) ), k, a( 0 ), k )
454 CALL dtrtri( '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 dtrmm( '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 DTFTRI
468*
dtrtri
subroutine dtrtri(uplo, diag, n, a, lda, info)
DTRTRI
Definition dtrtri.f:109

◆ dtfttp()

subroutine dtfttp ( character transr,
character uplo,
integer n,
double precision, dimension( 0: * ) arf,
double precision, dimension( 0: * ) ap,
integer info )

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

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

Purpose:
!>
!> DTFTTP 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtfttp.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 DOUBLE PRECISION 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( 'DTFTTP', -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 DTFTTP
513*

◆ dtfttr()

subroutine dtfttr ( character transr,
character uplo,
integer n,
double precision, dimension( 0: * ) arf,
double precision, dimension( 0: lda-1, 0: * ) a,
integer lda,
integer info )

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

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

Purpose:
!>
!> DTFTTR 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtfttr.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 DOUBLE PRECISION 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( 'DTFTTR', -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 DTFTTR
491*

◆ dtgsen()

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

DTGSEN

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

Purpose:
!>
!> DTGSEN 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 DGGES), i.e. A is block upper
!> triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
!> triangular.
!>
!> DTGSEN also computes the generalized eigenvalues
!>
!>             w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
!>
!> of the reordered matrix pair (A, B).
!>
!> Optionally, DTGSEN 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]ALPHAI
!>          ALPHAI is DOUBLE PRECISION array, dimension (N)
!>
[out]BETA
!>          BETA is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION
!>
[out]PR
!>          PR is DOUBLE PRECISION
!>
!>          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
!>          reciprocal of the norm of  onto left and right
!>          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 DOUBLE PRECISION array, dimension (2).
!>          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
!>          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
!>          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
!>          estimates of Difu and Difl.
!>          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 DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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:
!>
!>  DTGSEN 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 DLATDF), then the parameter
!>  IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF
!>  (IJOB = 2 will be used)). See DTGSYL 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 dtgsen.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 DOUBLE PRECISION PL, PR
461* ..
462* .. Array Arguments ..
463 LOGICAL SELECT( * )
464 INTEGER IWORK( * )
465 DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, ONE
476 parameter( zero = 0.0d+0, one = 1.0d+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 DOUBLE PRECISION DSCALE, DSUM, EPS, RDSCAL, SMLNUM
484* ..
485* .. Local Arrays ..
486 INTEGER ISAVE( 3 )
487* ..
488* .. External Subroutines ..
489 EXTERNAL dlacn2, dlacpy, dlag2, dlassq, dtgexc, dtgsyl,
490 $ xerbla
491* ..
492* .. External Functions ..
493 DOUBLE PRECISION DLAMCH
494 EXTERNAL dlamch
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( 'DTGSEN', -info )
522 RETURN
523 END IF
524*
525* Get machine constants
526*
527 eps = dlamch( 'P' )
528 smlnum = dlamch( '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( 'DTGSEN', -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 dlassq( n, a( 1, i ), 1, dscale, dsum )
602 CALL dlassq( 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 dtgexc( 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 dlacpy( 'Full', n1, n2, a( 1, i ), lda, work, n1 )
671 CALL dlacpy( 'Full', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),
672 $ n1 )
673 CALL dtgsyl( '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 dlassq( 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 dlassq( 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 dtgsyl( '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 dtgsyl( '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 DLACN2. 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 dlacn2( 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 dtgsyl( '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 dtgsyl( '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 dlacn2( 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 dtgsyl( '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 dtgsyl( '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 80 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 dlag2( 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 70 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 70 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 80 CONTINUE
854*
855 work( 1 ) = lwmin
856 iwork( 1 ) = liwmin
857*
858 RETURN
859*
860* End of DTGSEN
861*
dtgexc
subroutine dtgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, work, lwork, info)
DTGEXC
Definition dtgexc.f:220
dlag2
subroutine dlag2(a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2, wi)
DLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary ...
Definition dlag2.f:156
dtgsyl
subroutine dtgsyl(trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, dif, work, lwork, iwork, info)
DTGSYL
Definition dtgsyl.f:299
swap
#define swap(a, b, tmp)
Definition macros.h:40

◆ dtgsja()

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

DTGSJA

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

Purpose:
!>
!> DTGSJA 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 DGGSVP
!> 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 DTGSJA.
!>          See Further Details.
!>
[in,out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,N)
!>          On entry, the P-by-N matrix B.
!>          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
!>          a part of R.  See Purpose for details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,P).
!>
[in]TOLA
!>          TOLA is DOUBLE PRECISION
!>
[in]TOLB
!>          TOLB is DOUBLE PRECISION
!>
!>          TOLA and TOLB are the convergence criteria for the Jacobi-
!>          Kogbetliantz iteration procedure. Generally, they are the
!>          same as used in the preprocessing step, say
!>              TOLA = max(M,N)*norm(A)*MAZHEPS,
!>              TOLB = max(P,N)*norm(B)*MAZHEPS.
!>
[out]ALPHA
!>          ALPHA is DOUBLE PRECISION array, dimension (N)
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>
!>          On exit, ALPHA and BETA contain the generalized singular
!>          value pairs of A and B;
!>            ALPHA(1:K) = 1,
!>            BETA(1:K)  = 0,
!>          and if M-K-L >= 0,
!>            ALPHA(K+1:K+L) = diag(C),
!>            BETA(K+1:K+L)  = diag(S),
!>          or if M-K-L < 0,
!>            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
!>            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
!>          Furthermore, if K+L < N,
!>            ALPHA(K+L+1:N) = 0 and
!>            BETA(K+L+1:N)  = 0.
!>
[in,out]U
!>          U is DOUBLE PRECISION array, dimension (LDU,M)
!>          On entry, if JOBU = 'U', U must contain a matrix U1 (usually
!>          the orthogonal matrix returned by DGGSVP).
!>          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 DOUBLE PRECISION array, dimension (LDV,P)
!>          On entry, if JOBV = 'V', V must contain a matrix V1 (usually
!>          the orthogonal matrix returned by DGGSVP).
!>          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 DOUBLE PRECISION array, dimension (LDQ,N)
!>          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
!>          the orthogonal matrix returned by DGGSVP).
!>          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 DOUBLE PRECISION 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:
!>
!>  DTGSJA 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 dtgsja.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 DOUBLE PRECISION TOLA, TOLB
388* ..
389* .. Array Arguments ..
390 DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, ONE, HUGENUM
401 parameter( zero = 0.0d+0, one = 1.0d+0 )
402* ..
403* .. Local Scalars ..
404*
405 LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
406 INTEGER I, J, KCYCLE
407 DOUBLE PRECISION 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 dcopy, dlags2, dlapll, dlartg, dlaset, drot,
416 $ dscal, 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( 'DTGSJA', -info )
461 RETURN
462 END IF
463*
464* Initialize U, V and Q, if necessary
465*
466 IF( initu )
467 $ CALL dlaset( 'Full', m, m, zero, one, u, ldu )
468 IF( initv )
469 $ CALL dlaset( 'Full', p, p, zero, one, v, ldv )
470 IF( initq )
471 $ CALL dlaset( '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 dlags2( 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 drot( 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 drot( 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 drot( min( k+l, m ), a( 1, n-l+j ), 1,
522 $ a( 1, n-l+i ), 1, csq, snq )
523*
524 CALL drot( 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 drot( m, u( 1, k+j ), 1, u( 1, k+i ), 1, csu,
541 $ snu )
542*
543 IF( wantv )
544 $ CALL drot( p, v( 1, j ), 1, v( 1, i ), 1, csv, snv )
545*
546 IF( wantq )
547 $ CALL drot( 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 dcopy( l-i+1, a( k+i, n-l+i ), lda, work, 1 )
564 CALL dcopy( l-i+1, b( i, n-l+i ), ldb, work( l+1 ), 1 )
565 CALL dlapll( 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 dscal( l-i+1, -one, b( i, n-l+i ), ldb )
605 IF( wantv )
606 $ CALL dscal( p, -one, v( 1, i ), 1 )
607 END IF
608*
609 CALL dlartg( abs( gamma ), one, beta( k+i ), alpha( k+i ),
610 $ rwk )
611*
612 IF( alpha( k+i ).GE.beta( k+i ) ) THEN
613 CALL dscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),
614 $ lda )
615 ELSE
616 CALL dscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),
617 $ ldb )
618 CALL dcopy( 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 dcopy( 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 DTGSJA
652*
dlags2
subroutine dlags2(upper, a1, a2, a3, b1, b2, b3, csu, snu, csv, snv, csq, snq)
DLAGS2 computes 2-by-2 orthogonal matrices U, V, and Q, and applies them to matrices A and B such tha...
Definition dlags2.f:152
dlapll
subroutine dlapll(n, x, incx, y, incy, ssmin)
DLAPLL measures the linear dependence of two vectors.
Definition dlapll.f:102

◆ dtgsna()

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

DTGSNA

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

Purpose:
!>
!> DTGSNA 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 DGGES),
!> 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DTGEVC.
!>          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 DOUBLE PRECISION 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 DTGEVC.
!>          If JOB = 'V', VR is not referenced.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          The leading dimension of the array VR. LDVR >= 1.
!>          If JOB = 'E' or 'B', LDVR >= N.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (MM)
!>          If JOB = 'E' or 'B', the reciprocal condition numbers of the
!>          selected eigenvalues, stored in consecutive elements of the
!>          array. 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 DOUBLE PRECISION array, dimension (MM)
!>          If JOB = 'V' or 'B', the estimated reciprocal condition
!>          numbers of the selected eigenvectors, stored in consecutive
!>          elements of the array. 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 DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 DLATDF), then the parameter DIFDRI (see below) should be
!>     changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)).
!>     See DTGSYL 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
!>     DLATDF), then the parameter DIFDRI (see below) should be changed
!>     from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL
!>     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 dtgsna.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 DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, ONE, TWO, FOUR
403 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
404 $ four = 4.0d+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 DOUBLE PRECISION 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 DOUBLE PRECISION DUMMY( 1 ), DUMMY1( 1 )
416* ..
417* .. External Functions ..
418 LOGICAL LSAME
419 DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2
420 EXTERNAL lsame, ddot, dlamch, dlapy2, dnrm2
421* ..
422* .. External Subroutines ..
423 EXTERNAL dgemv, dlacpy, dlag2, dtgexc, dtgsyl, 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( 'DTGSNA', -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 = dlamch( 'P' )
517 smlnum = dlamch( '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 = dlapy2( dnrm2( n, vr( 1, ks ), 1 ),
558 $ dnrm2( n, vr( 1, ks+1 ), 1 ) )
559 lnrm = dlapy2( dnrm2( n, vl( 1, ks ), 1 ),
560 $ dnrm2( n, vl( 1, ks+1 ), 1 ) )
561 CALL dgemv( 'N', n, n, one, a, lda, vr( 1, ks ), 1, zero,
562 $ work, 1 )
563 tmprr = ddot( n, work, 1, vl( 1, ks ), 1 )
564 tmpri = ddot( n, work, 1, vl( 1, ks+1 ), 1 )
565 CALL dgemv( 'N', n, n, one, a, lda, vr( 1, ks+1 ), 1,
566 $ zero, work, 1 )
567 tmpii = ddot( n, work, 1, vl( 1, ks+1 ), 1 )
568 tmpir = ddot( n, work, 1, vl( 1, ks ), 1 )
569 uhav = tmprr + tmpii
570 uhavi = tmpir - tmpri
571 CALL dgemv( 'N', n, n, one, b, ldb, vr( 1, ks ), 1, zero,
572 $ work, 1 )
573 tmprr = ddot( n, work, 1, vl( 1, ks ), 1 )
574 tmpri = ddot( n, work, 1, vl( 1, ks+1 ), 1 )
575 CALL dgemv( 'N', n, n, one, b, ldb, vr( 1, ks+1 ), 1,
576 $ zero, work, 1 )
577 tmpii = ddot( n, work, 1, vl( 1, ks+1 ), 1 )
578 tmpir = ddot( n, work, 1, vl( 1, ks ), 1 )
579 uhbv = tmprr + tmpii
580 uhbvi = tmpir - tmpri
581 uhav = dlapy2( uhav, uhavi )
582 uhbv = dlapy2( uhbv, uhbvi )
583 cond = dlapy2( uhav, uhbv )
584 s( ks ) = cond / ( rnrm*lnrm )
585 s( ks+1 ) = s( ks )
586*
587 ELSE
588*
589* Real eigenvalue.
590*
591 rnrm = dnrm2( n, vr( 1, ks ), 1 )
592 lnrm = dnrm2( n, vl( 1, ks ), 1 )
593 CALL dgemv( 'N', n, n, one, a, lda, vr( 1, ks ), 1, zero,
594 $ work, 1 )
595 uhav = ddot( n, work, 1, vl( 1, ks ), 1 )
596 CALL dgemv( 'N', n, n, one, b, ldb, vr( 1, ks ), 1, zero,
597 $ work, 1 )
598 uhbv = ddot( n, work, 1, vl( 1, ks ), 1 )
599 cond = dlapy2( 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 ) = dlapy2( 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 dlag2( 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.0d0*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 dlacpy( 'Full', n, n, a, lda, work, n )
644 CALL dlacpy( 'Full', n, n, b, ldb, work( n*n+1 ), n )
645 ifst = k
646 ilst = 1
647*
648 CALL dtgexc( .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 dtgsyl( '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 DTGSNA
696*
dlapy2
double precision function dlapy2(x, y)
DLAPY2 returns sqrt(x2+y2).
Definition dlapy2.f:63

◆ dtpcon()

subroutine dtpcon ( character norm,
character uplo,
character diag,
integer n,
double precision, dimension( * ) ap,
double precision rcond,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DTPCON

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

Purpose:
!>
!> DTPCON 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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dtpcon.f.

130*
131* -- LAPACK computational routine --
132* -- LAPACK is a software package provided by Univ. of Tennessee, --
133* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
134*
135* .. Scalar Arguments ..
136 CHARACTER DIAG, NORM, UPLO
137 INTEGER INFO, N
138 DOUBLE PRECISION RCOND
139* ..
140* .. Array Arguments ..
141 INTEGER IWORK( * )
142 DOUBLE PRECISION AP( * ), WORK( * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 DOUBLE PRECISION ONE, ZERO
149 parameter( one = 1.0d+0, zero = 0.0d+0 )
150* ..
151* .. Local Scalars ..
152 LOGICAL NOUNIT, ONENRM, UPPER
153 CHARACTER NORMIN
154 INTEGER IX, KASE, KASE1
155 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
156* ..
157* .. Local Arrays ..
158 INTEGER ISAVE( 3 )
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 INTEGER IDAMAX
163 DOUBLE PRECISION DLAMCH, DLANTP
164 EXTERNAL lsame, idamax, dlamch, dlantp
165* ..
166* .. External Subroutines ..
167 EXTERNAL dlacn2, dlatps, drscl, xerbla
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, dble, max
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( 'DTPCON', -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 = dlamch( 'Safe minimum' )*dble( max( 1, n ) )
204*
205* Compute the norm of the triangular matrix A.
206*
207 anorm = dlantp( 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 dlacn2( 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 dlatps( 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 dlatps( 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 = idamax( n, work, 1 )
245 xnorm = abs( work( ix ) )
246 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
247 $ GO TO 20
248 CALL drscl( 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 DTPCON
263*
dlantp
double precision function dlantp(norm, uplo, diag, n, ap, work)
DLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlantp.f:124

◆ dtplqt()

subroutine dtplqt ( integer m,
integer n,
integer l,
integer mb,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( * ) work,
integer info )

DTPLQT

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

Purpose:
!>
!> DTPLQT computes a blocked LQ 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, and the order of the
!>          triangular matrix A.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix B.
!>          N >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in]MB
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.  M >= MB >= 1.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,M)
!>          On entry, the lower triangular M-by-M matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>          On entry, the pentagonal M-by-N matrix B.  The first N-L columns
!>          are rectangular, and the last L columns are lower 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 DOUBLE PRECISION array, dimension (LDT,N)
!>          The lower 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 >= MB.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MB*M)
!>
[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 M-by-(M+N) matrix
!>
!>               C = [ A ] [ B ]
!>
!>
!>  where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
!>  upper trapezoidal matrix B2:
!>          [ B ] = [ B1 ] [ B2 ]
!>                   [ B1 ]  <- M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L lower trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  M-by-M lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>            [ C ] = [ A ] [ B ]
!>                   [ A ]  <- lower triangular M-by-M
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>            [ W ] = [ I ] [ V ]
!>                   [ I ]  <- identity, M-by-M
!>                   [ 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 ] [ V2 ]
!>                   [ V1 ] <- M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows of V represent the vectors which define the H(i)'s.
!>
!>  The number of blocks is B = ceiling(M/MB), where each
!>  block is of order MB except for the last block, which is of order
!>  IB = M - (M-1)*MB.  For each of the B blocks, a upper triangular block
!>  reflector factor is computed: T1, T2, ..., TB.  The MB-by-MB (and IB-by-IB
!>  for the last block) T's are stored in the MB-by-N matrix T as
!>
!>               T = [T1 T2 ... TB].
!>

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

Purpose:
!>
!> DTPLQT computes a blocked LQ 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, and the order of the
!>          triangular matrix A.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix B.
!>          N >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in]MB
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.  M >= MB >= 1.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the lower triangular N-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>          On entry, the pentagonal M-by-N matrix B.  The first N-L columns
!>          are rectangular, and the last L columns are lower 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 DOUBLE PRECISION array, dimension (LDT,N)
!>          The lower 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 >= MB.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MB*M)
!>
[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 M-by-(M+N) matrix
!>
!>               C = [ A ] [ B ]
!>
!>
!>  where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
!>  upper trapezoidal matrix B2:
!>          [ B ] = [ B1 ] [ B2 ]
!>                   [ B1 ]  <- M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L upper trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>            [ C ] = [ A ] [ B ]
!>                   [ A ]  <- lower triangular N-by-N
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>            [ W ] = [ I ] [ V ]
!>                   [ 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 ] [ V2 ]
!>                   [ V1 ] <- M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows of V represent the vectors which define the H(i)'s.
!>
!>  The number of blocks is B = ceiling(M/MB), where each
!>  block is of order MB except for the last block, which is of order
!>  IB = M - (M-1)*MB.  For each of the B blocks, a upper triangular block
!>  reflector factor is computed: T1, T2, ..., TB.  The MB-by-MB (and IB-by-IB
!>  for the last block) T's are stored in the MB-by-N matrix T as
!>
!>               T = [T1 T2 ... TB].
!>

Definition at line 187 of file dtplqt.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, MB
196* ..
197* .. Array Arguments ..
198 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
199* ..
200*
201* =====================================================================
202*
203* ..
204* .. Local Scalars ..
205 INTEGER I, IB, LB, NB, IINFO
206* ..
207* .. External Subroutines ..
208 EXTERNAL dtplqt2, dtprfb, 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( mb.LT.1 .OR. (mb.GT.m .AND. m.GT.0)) THEN
222 info = -4
223 ELSE IF( lda.LT.max( 1, m ) ) THEN
224 info = -6
225 ELSE IF( ldb.LT.max( 1, m ) ) THEN
226 info = -8
227 ELSE IF( ldt.LT.mb ) THEN
228 info = -10
229 END IF
230 IF( info.NE.0 ) THEN
231 CALL xerbla( 'DTPLQT', -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, m, mb
240*
241* Compute the QR factorization of the current block
242*
243 ib = min( m-i+1, mb )
244 nb = min( n-l+i+ib-1, n )
245 IF( i.GE.l ) THEN
246 lb = 0
247 ELSE
248 lb = nb-n+l-i+1
249 END IF
250*
251 CALL dtplqt2( ib, nb, lb, a(i,i), lda, b( i, 1 ), ldb,
252 $ t(1, i ), ldt, iinfo )
253*
254* Update by applying H**T to B(I+IB:M,:) from the right
255*
256 IF( i+ib.LE.m ) THEN
257 CALL dtprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,
258 $ b( i, 1 ), ldb, t( 1, i ), ldt,
259 $ a( i+ib, i ), lda, b( i+ib, 1 ), ldb,
260 $ work, m-i-ib+1)
261 END IF
262 END DO
263 RETURN
264*
265* End of DTPLQT
266*
dtprfb
subroutine dtprfb(side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, a, lda, b, ldb, work, ldwork)
DTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matri...
Definition dtprfb.f:251
dtplqt2
subroutine dtplqt2(m, n, l, a, lda, b, ldb, t, ldt, info)
DTPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix,...
Definition dtplqt2.f:177

◆ dtplqt2()

subroutine dtplqt2 ( integer m,
integer n,
integer l,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( ldt, * ) t,
integer ldt,
integer info )

DTPLQT2 computes a LQ 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 DTPLQT2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> DTPLQT2 computes a LQ a 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 lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,M)
!>          On entry, the lower triangular M-by-M matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>          On entry, the pentagonal M-by-N matrix B.  The first N-L columns
!>          are rectangular, and the last L columns are lower 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 DOUBLE PRECISION array, dimension (LDT,M)
!>          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,M)
!>
[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 M-by-(M+N) matrix
!>
!>               C = [ A ][ B ]
!>
!>
!>  where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L
!>  upper trapezoidal matrix B2:
!>
!>               B = [ B1 ][ B2 ]
!>                   [ B1 ]  <-     M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L lower trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>
!>               C = [ A ][ B ]
!>                   [ A ]  <- lower triangular M-by-M
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>
!>               W = [ I ][ V ]
!>                   [ I ]  <- identity, M-by-M
!>                   [ 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,
!>
!>               W = [ V1 ][ V2 ]
!>                   [ V1 ] <-     M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows 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 * T * W
!>
!>  where W^H is the conjugate transpose of W and T is the upper triangular
!>  factor of the block reflector.
!>

Definition at line 176 of file dtplqt2.f.

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

◆ dtpmlqt()

subroutine dtpmlqt ( character side,
character trans,
integer m,
integer n,
integer k,
integer l,
integer mb,
double precision, dimension( ldv, * ) v,
integer ldv,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) work,
integer info )

DTPMLQT

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

Purpose:
!>
!> DTPMQRT 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]MB
!>          MB is INTEGER
!>          The block size used for the storage of T.  K >= MB >= 1.
!>          This must be the same value of MB used to generate T
!>          in DTPLQT.
!>
[in]V
!>          V is DOUBLE PRECISION array, dimension (LDV,K)
!>          The i-th row must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          DTPLQT in B.  See Further Details.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= K.
!>
[in]T
!>          T is DOUBLE PRECISION array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by DTPLQT, stored as a MB-by-K matrix.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= MB.
!>
[in,out]A
!>          A is DOUBLE PRECISION 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', LDA >= max(1,K);
!>          If SIDE = 'R', LDA >= max(1,M).
!>
[in,out]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION array. The dimension of WORK is
!>           N*MB if SIDE = 'L', or  M*MB 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 lower trapezoidal, consisting of the first L
!>  rows of a K-by-K upper triangular matrix.  If L=K, V2 is lower 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 K-by-M.
!>                      [B]
!>
!>  If SIDE = 'R':  C = [A B]  where A is M-by-K, B is M-by-N and V is K-by-N.
!>
!>  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 212 of file dtpmlqt.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 CHARACTER SIDE, TRANS
221 INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
222* ..
223* .. Array Arguments ..
224 DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ),
225 $ T( LDT, * ), WORK( * )
226* ..
227*
228* =====================================================================
229*
230* ..
231* .. Local Scalars ..
232 LOGICAL LEFT, RIGHT, TRAN, NOTRAN
233 INTEGER I, IB, NB, LB, KF, LDAQ
234* ..
235* .. External Functions ..
236 LOGICAL LSAME
237 EXTERNAL lsame
238* ..
239* .. External Subroutines ..
240 EXTERNAL xerbla, dtprfb
241* ..
242* .. Intrinsic Functions ..
243 INTRINSIC max, min
244* ..
245* .. Executable Statements ..
246*
247* .. Test the input arguments ..
248*
249 info = 0
250 left = lsame( side, 'L' )
251 right = lsame( side, 'R' )
252 tran = lsame( trans, 'T' )
253 notran = lsame( trans, 'N' )
254*
255 IF ( left ) THEN
256 ldaq = max( 1, k )
257 ELSE IF ( right ) THEN
258 ldaq = max( 1, m )
259 END IF
260 IF( .NOT.left .AND. .NOT.right ) THEN
261 info = -1
262 ELSE IF( .NOT.tran .AND. .NOT.notran ) THEN
263 info = -2
264 ELSE IF( m.LT.0 ) THEN
265 info = -3
266 ELSE IF( n.LT.0 ) THEN
267 info = -4
268 ELSE IF( k.LT.0 ) THEN
269 info = -5
270 ELSE IF( l.LT.0 .OR. l.GT.k ) THEN
271 info = -6
272 ELSE IF( mb.LT.1 .OR. (mb.GT.k .AND. k.GT.0) ) THEN
273 info = -7
274 ELSE IF( ldv.LT.k ) THEN
275 info = -9
276 ELSE IF( ldt.LT.mb ) THEN
277 info = -11
278 ELSE IF( lda.LT.ldaq ) THEN
279 info = -13
280 ELSE IF( ldb.LT.max( 1, m ) ) THEN
281 info = -15
282 END IF
283*
284 IF( info.NE.0 ) THEN
285 CALL xerbla( 'DTPMLQT', -info )
286 RETURN
287 END IF
288*
289* .. Quick return if possible ..
290*
291 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) RETURN
292*
293 IF( left .AND. notran ) THEN
294*
295 DO i = 1, k, mb
296 ib = min( mb, k-i+1 )
297 nb = min( m-l+i+ib-1, m )
298 IF( i.GE.l ) THEN
299 lb = 0
300 ELSE
301 lb = 0
302 END IF
303 CALL dtprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,
304 $ v( i, 1 ), ldv, t( 1, i ), ldt,
305 $ a( i, 1 ), lda, b, ldb, work, ib )
306 END DO
307*
308 ELSE IF( right .AND. tran ) THEN
309*
310 DO i = 1, k, mb
311 ib = min( mb, k-i+1 )
312 nb = min( n-l+i+ib-1, n )
313 IF( i.GE.l ) THEN
314 lb = 0
315 ELSE
316 lb = nb-n+l-i+1
317 END IF
318 CALL dtprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,
319 $ v( i, 1 ), ldv, t( 1, i ), ldt,
320 $ a( 1, i ), lda, b, ldb, work, m )
321 END DO
322*
323 ELSE IF( left .AND. tran ) THEN
324*
325 kf = ((k-1)/mb)*mb+1
326 DO i = kf, 1, -mb
327 ib = min( mb, k-i+1 )
328 nb = min( m-l+i+ib-1, m )
329 IF( i.GE.l ) THEN
330 lb = 0
331 ELSE
332 lb = 0
333 END IF
334 CALL dtprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,
335 $ v( i, 1 ), ldv, t( 1, i ), ldt,
336 $ a( i, 1 ), lda, b, ldb, work, ib )
337 END DO
338*
339 ELSE IF( right .AND. notran ) THEN
340*
341 kf = ((k-1)/mb)*mb+1
342 DO i = kf, 1, -mb
343 ib = min( mb, k-i+1 )
344 nb = min( n-l+i+ib-1, n )
345 IF( i.GE.l ) THEN
346 lb = 0
347 ELSE
348 lb = nb-n+l-i+1
349 END IF
350 CALL dtprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,
351 $ v( i, 1 ), ldv, t( 1, i ), ldt,
352 $ a( 1, i ), lda, b, ldb, work, m )
353 END DO
354*
355 END IF
356*
357 RETURN
358*
359* End of DTPMLQT
360*

◆ dtpmqrt()

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

DTPMQRT

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

Purpose:
!>
!> DTPMQRT 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtpmqrt.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 DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ),
227 $ T( LDT, * ), 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 dtprfb, 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( 'DTPMQRT', -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 dtprfb( '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 dtprfb( '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 dtprfb( '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 dtprfb( '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 DTPMQRT
364*

◆ dtpqrt()

subroutine dtpqrt ( integer m,
integer n,
integer l,
integer nb,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( * ) work,
integer info )

DTPQRT

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

Purpose:
!>
!> DTPQRT 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtpqrt.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 DOUBLE PRECISION 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 dtpqrt2, dtprfb, 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( 'DTPQRT', -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 dtpqrt2( mb, ib, lb, a(i,i), lda, b( 1, i ), ldb,
252 $ t(1, i ), ldt, iinfo )
253*
254* Update by applying H**T to B(:,I+IB:N) from the left
255*
256 IF( i+ib.LE.n ) THEN
257 CALL dtprfb( '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 DTPQRT
266*
dtpqrt2
subroutine dtpqrt2(m, n, l, a, lda, b, ldb, t, ldt, info)
DTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix,...
Definition dtpqrt2.f:173

◆ dtpqrt2()

subroutine dtpqrt2 ( integer m,
integer n,
integer l,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( ldt, * ) t,
integer ldt,
integer info )

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

Purpose:
!>
!> DTPQRT2 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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**T
!>
!>  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 dtpqrt2.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 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * )
183* ..
184*
185* =====================================================================
186*
187* .. Parameters ..
188 DOUBLE PRECISION ONE, ZERO
189 parameter( one = 1.0, zero = 0.0 )
190* ..
191* .. Local Scalars ..
192 INTEGER I, J, P, MP, NP
193 DOUBLE PRECISION ALPHA
194* ..
195* .. External Subroutines ..
196 EXTERNAL dlarfg, dgemv, dger, dtrmv, 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( 'DTPQRT2', -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 dlarfg( 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 dgemv( '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 dger( 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 dtrmv( 'U', 'T', 'N', p, b( mp, 1 ), ldb,
274 $ t( 1, i ), 1 )
275*
276* Rectangular part of B2
277*
278 CALL dgemv( '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 dgemv( '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 dtrmv( '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 DTPQRT2
298*

◆ dtprfs()

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

DTPRFS

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

Purpose:
!>
!> DTPRFS 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 DTPTRS or some other
!> means before entering this routine.  DTPRFS 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dtprfs.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 DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
187 $ WORK( * ), X( LDX, * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 DOUBLE PRECISION ZERO
194 parameter( zero = 0.0d+0 )
195 DOUBLE PRECISION ONE
196 parameter( one = 1.0d+0 )
197* ..
198* .. Local Scalars ..
199 LOGICAL NOTRAN, NOUNIT, UPPER
200 CHARACTER TRANST
201 INTEGER I, J, K, KASE, KC, NZ
202 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
203* ..
204* .. Local Arrays ..
205 INTEGER ISAVE( 3 )
206* ..
207* .. External Subroutines ..
208 EXTERNAL daxpy, dcopy, dlacn2, dtpmv, dtpsv, xerbla
209* ..
210* .. Intrinsic Functions ..
211 INTRINSIC abs, max
212* ..
213* .. External Functions ..
214 LOGICAL LSAME
215 DOUBLE PRECISION DLAMCH
216 EXTERNAL lsame, dlamch
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( 'DTPRFS', -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 = dlamch( 'Epsilon' )
268 safmin = dlamch( '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 dcopy( n, x( 1, j ), 1, work( n+1 ), 1 )
280 CALL dtpmv( uplo, trans, diag, n, ap, work( n+1 ), 1 )
281 CALL daxpy( 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 DLACN2 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 dlacn2( 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 dtpsv( 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 dtpsv( 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 DTPRFS
469*

◆ dtptri()

subroutine dtptri ( character uplo,
character diag,
integer n,
double precision, dimension( * ) ap,
integer info )

DTPTRI

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

Purpose:
!>
!> DTPTRI 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 DOUBLE PRECISION 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 dtptri.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 DOUBLE PRECISION AP( * )
128* ..
129*
130* =====================================================================
131*
132* .. Parameters ..
133 DOUBLE PRECISION ONE, ZERO
134 parameter( one = 1.0d+0, zero = 0.0d+0 )
135* ..
136* .. Local Scalars ..
137 LOGICAL NOUNIT, UPPER
138 INTEGER J, JC, JCLAST, JJ
139 DOUBLE PRECISION AJJ
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 EXTERNAL lsame
144* ..
145* .. External Subroutines ..
146 EXTERNAL dscal, dtpmv, 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( 'DTPTRI', -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 dtpmv( 'Upper', 'No transpose', diag, j-1, ap,
204 $ ap( jc ), 1 )
205 CALL dscal( 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 dtpmv( 'Lower', 'No transpose', diag, n-j,
226 $ ap( jclast ), ap( jc+1 ), 1 )
227 CALL dscal( 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 DTPTRI
237*

◆ dtptrs()

subroutine dtptrs ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
double precision, dimension( * ) ap,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DTPTRS

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

Purpose:
!>
!> DTPTRS 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtptrs.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 DOUBLE PRECISION AP( * ), B( LDB, * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 DOUBLE PRECISION ZERO
147 parameter( zero = 0.0d+0 )
148* ..
149* .. Local Scalars ..
150 LOGICAL NOUNIT, UPPER
151 INTEGER J, JC
152* ..
153* .. External Functions ..
154 LOGICAL LSAME
155 EXTERNAL lsame
156* ..
157* .. External Subroutines ..
158 EXTERNAL dtpsv, 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( 'DTPTRS', -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 dtpsv( uplo, trans, diag, n, ap, b( 1, j ), 1 )
219 30 CONTINUE
220*
221 RETURN
222*
223* End of DTPTRS
224*

◆ dtpttf()

subroutine dtpttf ( character transr,
character uplo,
integer n,
double precision, dimension( 0: * ) ap,
double precision, dimension( 0: * ) arf,
integer info )

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

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

Purpose:
!>
!> DTPTTF 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtpttf.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 DOUBLE PRECISION 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( 'DTPTTF', -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 DTPTTF
498*

◆ dtpttr()

subroutine dtpttr ( character uplo,
integer n,
double precision, dimension( * ) ap,
double precision, dimension( lda, * ) a,
integer lda,
integer info )

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

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

Purpose:
!>
!> DTPTTR 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtpttr.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 DOUBLE PRECISION 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( 'DTPTTR', -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 DTPTTR
172*

◆ dtrcon()

subroutine dtrcon ( character norm,
character uplo,
character diag,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision rcond,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DTRCON

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

Purpose:
!>
!> DTRCON 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The triangular matrix A.  If UPLO = 'U', the leading N-by-N
!>          upper triangular part of the array A contains the upper
!>          triangular matrix, and the strictly lower triangular part of
!>          A is not referenced.  If UPLO = 'L', the leading N-by-N lower
!>          triangular part of the array A contains the lower triangular
!>          matrix, and the strictly upper triangular part of A is not
!>          referenced.  If DIAG = 'U', the diagonal elements of A are
!>          also not referenced and are assumed to be 1.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dtrcon.f.

137*
138* -- LAPACK computational routine --
139* -- LAPACK is a software package provided by Univ. of Tennessee, --
140* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
141*
142* .. Scalar Arguments ..
143 CHARACTER DIAG, NORM, UPLO
144 INTEGER INFO, LDA, N
145 DOUBLE PRECISION RCOND
146* ..
147* .. Array Arguments ..
148 INTEGER IWORK( * )
149 DOUBLE PRECISION A( LDA, * ), WORK( * )
150* ..
151*
152* =====================================================================
153*
154* .. Parameters ..
155 DOUBLE PRECISION ONE, ZERO
156 parameter( one = 1.0d+0, zero = 0.0d+0 )
157* ..
158* .. Local Scalars ..
159 LOGICAL NOUNIT, ONENRM, UPPER
160 CHARACTER NORMIN
161 INTEGER IX, KASE, KASE1
162 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
163* ..
164* .. Local Arrays ..
165 INTEGER ISAVE( 3 )
166* ..
167* .. External Functions ..
168 LOGICAL LSAME
169 INTEGER IDAMAX
170 DOUBLE PRECISION DLAMCH, DLANTR
171 EXTERNAL lsame, idamax, dlamch, dlantr
172* ..
173* .. External Subroutines ..
174 EXTERNAL dlacn2, dlatrs, drscl, xerbla
175* ..
176* .. Intrinsic Functions ..
177 INTRINSIC abs, dble, max
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( 'DTRCON', -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 = dlamch( 'Safe minimum' )*dble( max( 1, n ) )
213*
214* Compute the norm of the triangular matrix A.
215*
216 anorm = dlantr( 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 dlacn2( 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 dlatrs( 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 dlatrs( 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 = idamax( n, work, 1 )
254 xnorm = abs( work( ix ) )
255 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
256 $ GO TO 20
257 CALL drscl( 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 DTRCON
272*
dlantr
double precision function dlantr(norm, uplo, diag, m, n, a, lda, work)
DLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlantr.f:141
dlatrs
subroutine dlatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
DLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition dlatrs.f:238

◆ dtrevc()

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

DTREVC

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

Purpose:
!>
!> DTREVC 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 DHSEQR.
!>
!> 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DHSEQR).
!>          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 DOUBLE PRECISION 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 DHSEQR).
!>          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 DOUBLE PRECISION 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 dtrevc.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 DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
234 $ WORK( * )
235* ..
236*
237* =====================================================================
238*
239* .. Parameters ..
240 DOUBLE PRECISION ZERO, ONE
241 parameter( zero = 0.0d+0, one = 1.0d+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 DOUBLE PRECISION 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 IDAMAX
253 DOUBLE PRECISION DDOT, DLAMCH
254 EXTERNAL lsame, idamax, ddot, dlamch
255* ..
256* .. External Subroutines ..
257 EXTERNAL dlabad, daxpy, dcopy, dgemv, dlaln2, dscal,
258 $ xerbla
259* ..
260* .. Intrinsic Functions ..
261 INTRINSIC abs, max, sqrt
262* ..
263* .. Local Arrays ..
264 DOUBLE PRECISION 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( 'DTREVC', -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 = dlamch( 'Safe minimum' )
343 ovfl = one / unfl
344 CALL dlabad( unfl, ovfl )
345 ulp = dlamch( '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 dlaln2( .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 dscal( ki, scale, work( 1+n ), 1 )
454 work( j+n ) = x( 1, 1 )
455*
456* Update right-hand side
457*
458 CALL daxpy( 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 dlaln2( .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 dscal( 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 daxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,
492 $ work( 1+n ), 1 )
493 CALL daxpy( 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 dcopy( ki, work( 1+n ), 1, vr( 1, is ), 1 )
502*
503 ii = idamax( ki, vr( 1, is ), 1 )
504 remax = one / abs( vr( ii, is ) )
505 CALL dscal( 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 dgemv( 'N', n, ki-1, one, vr, ldvr,
513 $ work( 1+n ), 1, work( ki+n ),
514 $ vr( 1, ki ), 1 )
515*
516 ii = idamax( n, vr( 1, ki ), 1 )
517 remax = one / abs( vr( ii, ki ) )
518 CALL dscal( 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 dlaln2( .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 dscal( ki, scale, work( 1+n ), 1 )
586 CALL dscal( 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 daxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,
594 $ work( 1+n ), 1 )
595 CALL daxpy( 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 dlaln2( .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 dscal( ki, scale, work( 1+n ), 1 )
626 CALL dscal( 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 daxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,
636 $ work( 1+n ), 1 )
637 CALL daxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,
638 $ work( 1+n ), 1 )
639 CALL daxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,
640 $ work( 1+n2 ), 1 )
641 CALL daxpy( 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 dcopy( ki, work( 1+n ), 1, vr( 1, is-1 ), 1 )
650 CALL dcopy( 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 dscal( ki, remax, vr( 1, is-1 ), 1 )
660 CALL dscal( 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 dgemv( 'N', n, ki-2, one, vr, ldvr,
671 $ work( 1+n ), 1, work( ki-1+n ),
672 $ vr( 1, ki-1 ), 1 )
673 CALL dgemv( 'N', n, ki-2, one, vr, ldvr,
674 $ work( 1+n2 ), 1, work( ki+n2 ),
675 $ vr( 1, ki ), 1 )
676 ELSE
677 CALL dscal( n, work( ki-1+n ), vr( 1, ki-1 ), 1 )
678 CALL dscal( 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 dscal( n, remax, vr( 1, ki-1 ), 1 )
688 CALL dscal( 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 dscal( 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 $ ddot( 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 dlaln2( .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 dscal( 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 dscal( 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 $ ddot( 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 $ ddot( 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 dlaln2( .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 dscal( 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 dcopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 )
847*
848 ii = idamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
849 remax = one / abs( vl( ii, is ) )
850 CALL dscal( 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 dgemv( '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 = idamax( n, vl( 1, ki ), 1 )
864 remax = one / abs( vl( ii, ki ) )
865 CALL dscal( 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 dscal( n-ki+1, rec, work( ki+n ), 1 )
924 CALL dscal( 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 $ ddot( j-ki-2, t( ki+2, j ), 1,
931 $ work( ki+2+n ), 1 )
932 work( j+n2 ) = work( j+n2 ) -
933 $ ddot( 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 dlaln2( .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 dscal( n-ki+1, scale, work( ki+n ), 1 )
946 CALL dscal( 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 dscal( n-ki+1, rec, work( ki+n ), 1 )
965 CALL dscal( 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 $ ddot( j-ki-2, t( ki+2, j ), 1,
972 $ work( ki+2+n ), 1 )
973*
974 work( j+n2 ) = work( j+n2 ) -
975 $ ddot( 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 $ ddot( 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 $ ddot( 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 dlaln2( .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 dscal( n-ki+1, scale, work( ki+n ), 1 )
998 CALL dscal( 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 dcopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 )
1015 CALL dcopy( 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 dscal( n-ki+1, remax, vl( ki, is ), 1 )
1025 CALL dscal( 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 dgemv( '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 dgemv( '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 dscal( n, work( ki+n ), vl( 1, ki ), 1 )
1041 CALL dscal( 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 dscal( n, remax, vl( 1, ki ), 1 )
1051 CALL dscal( 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 DTREVC
1073*
dlabad
subroutine dlabad(small, large)
DLABAD
Definition dlabad.f:74
dlaln2
subroutine dlaln2(ltrans, na, nw, smin, ca, a, lda, d1, d2, b, ldb, wr, wi, x, ldx, scale, xnorm, info)
DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.
Definition dlaln2.f:218

◆ dtrevc3()

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

DTREVC3

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

Purpose:
!>
!> DTREVC3 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 DHSEQR.
!>
!> 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DHSEQR).
!>          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 DOUBLE PRECISION 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 DHSEQR).
!>          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 DOUBLE PRECISION 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 dtrevc3.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 DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
250 $ WORK( * )
251* ..
252*
253* =====================================================================
254*
255* .. Parameters ..
256 DOUBLE PRECISION ZERO, ONE
257 parameter( zero = 0.0d+0, one = 1.0d+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 DOUBLE PRECISION 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 IDAMAX, ILAENV
273 DOUBLE PRECISION DDOT, DLAMCH
274 EXTERNAL lsame, idamax, ilaenv, ddot, dlamch
275* ..
276* .. External Subroutines ..
277 EXTERNAL daxpy, dcopy, dgemv, dlaln2, dscal, xerbla,
278 $ dgemm, dlaset, dlabad, dlacpy
279* ..
280* .. Intrinsic Functions ..
281 INTRINSIC abs, max, sqrt
282* ..
283* .. Local Arrays ..
284 DOUBLE PRECISION 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, 'DTREVC', 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( 'DTREVC3', -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 dlaset( '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 = dlamch( 'Safe minimum' )
383 ovfl = one / unfl
384 CALL dlabad( unfl, ovfl )
385 ulp = dlamch( '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 dlaln2( .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 dscal( ki, scale, work( 1+iv*n ), 1 )
511 work( j+iv*n ) = x( 1, 1 )
512*
513* Update right-hand side
514*
515 CALL daxpy( 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 dlaln2( .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 dscal( 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 daxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,
549 $ work( 1+iv*n ), 1 )
550 CALL daxpy( 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 dcopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 )
561*
562 ii = idamax( ki, vr( 1, is ), 1 )
563 remax = one / abs( vr( ii, is ) )
564 CALL dscal( 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 dgemv( '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 = idamax( n, vr( 1, ki ), 1 )
579 remax = one / abs( vr( ii, ki ) )
580 CALL dscal( 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 dlaln2( .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 dscal( ki, scale, work( 1+(iv-1)*n ), 1 )
658 CALL dscal( 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 daxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,
666 $ work( 1+(iv-1)*n ), 1 )
667 CALL daxpy( 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 dlaln2( .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 dscal( ki, scale, work( 1+(iv-1)*n ), 1 )
698 CALL dscal( 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 daxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,
708 $ work( 1+(iv-1)*n ), 1 )
709 CALL daxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,
710 $ work( 1+(iv-1)*n ), 1 )
711 CALL daxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,
712 $ work( 1+(iv )*n ), 1 )
713 CALL daxpy( 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 dcopy( ki, work( 1+(iv-1)*n ), 1, vr(1,is-1), 1 )
724 CALL dcopy( 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 dscal( ki, remax, vr( 1, is-1 ), 1 )
733 CALL dscal( 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 dgemv( '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 dgemv( '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 dscal( n, work(ki-1+(iv-1)*n), vr(1,ki-1), 1)
752 CALL dscal( 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 dscal( n, remax, vr( 1, ki-1 ), 1 )
762 CALL dscal( 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 dgemm( '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 = idamax( 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 dscal( n, remax, work( 1 + (nb+k)*n ), 1 )
818 END DO
819 CALL dlacpy( '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 dscal( 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 $ ddot( 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 dlaln2( .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 dscal( 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 dscal( 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 $ ddot( 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 $ ddot( 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 dlaln2( .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 dscal( 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 dcopy( n-ki+1, work( ki + iv*n ), 1,
994 $ vl( ki, is ), 1 )
995*
996 ii = idamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
997 remax = one / abs( vl( ii, is ) )
998 CALL dscal( 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 dgemv( '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 = idamax( n, vl( 1, ki ), 1 )
1014 remax = one / abs( vl( ii, ki ) )
1015 CALL dscal( 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 dscal( n-ki+1, rec, work(ki+(iv )*n), 1 )
1084 CALL dscal( 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 $ ddot( 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 $ ddot( 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 dlaln2( .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 dscal( n-ki+1, scale, work(ki+(iv )*n), 1)
1106 CALL dscal( 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 dscal( n-ki+1, rec, work(ki+(iv )*n), 1 )
1125 CALL dscal( 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 $ ddot( 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 $ ddot( 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 $ ddot( 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 $ ddot( 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 dlaln2( .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 dscal( n-ki+1, scale, work(ki+(iv )*n), 1)
1158 CALL dscal( 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 dcopy( n-ki+1, work( ki + (iv )*n ), 1,
1178 $ vl( ki, is ), 1 )
1179 CALL dcopy( 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 dscal( n-ki+1, remax, vl( ki, is ), 1 )
1189 CALL dscal( 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 dgemv( '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 dgemv( '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 dscal( n, work(ki+ (iv )*n), vl(1, ki ), 1)
1212 CALL dscal( 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 dscal( n, remax, vl( 1, ki ), 1 )
1222 CALL dscal( 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 dgemm( '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 = idamax( 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 dscal( n, remax, work( 1 + (nb+k)*n ), 1 )
1279 END DO
1280 CALL dlacpy( '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 DTREVC3
1298*

◆ dtrexc()

subroutine dtrexc ( character compq,
integer n,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( ldq, * ) q,
integer ldq,
integer ifst,
integer ilst,
double precision, dimension( * ) work,
integer info )

DTREXC

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

Purpose:
!>
!> DTREXC 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 DHSEQR), 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          = 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 dtrexc.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 DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 DOUBLE PRECISION ZERO
165 parameter( zero = 0.0d+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 dlaexc, 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( 'DTREXC', -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 dlaexc( 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 dlaexc( 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 dlaexc( 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 dlaexc( 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 dlaexc( wantq, n, t, ldt, q, ldq, here, 1, 1,
323 $ work, info )
324 CALL dlaexc( 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 dlaexc( 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 dlaexc( 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 dlaexc( 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 dlaexc( 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 dlaexc( wantq, n, t, ldt, q, ldq, here, 1, 1,
409 $ work, info )
410 CALL dlaexc( 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 DTREXC
424*
dlaexc
subroutine dlaexc(wantq, n, t, ldt, q, ldq, j1, n1, n2, work, info)
DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form...
Definition dlaexc.f:138

◆ dtrrfs()

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

DTRRFS

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

Purpose:
!>
!> DTRRFS 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 DTRTRS or some other
!> means before entering this routine.  DTRRFS 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dtrrfs.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 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
194 $ WORK( * ), X( LDX, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 DOUBLE PRECISION ZERO
201 parameter( zero = 0.0d+0 )
202 DOUBLE PRECISION ONE
203 parameter( one = 1.0d+0 )
204* ..
205* .. Local Scalars ..
206 LOGICAL NOTRAN, NOUNIT, UPPER
207 CHARACTER TRANST
208 INTEGER I, J, K, KASE, NZ
209 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
210* ..
211* .. Local Arrays ..
212 INTEGER ISAVE( 3 )
213* ..
214* .. External Subroutines ..
215 EXTERNAL daxpy, dcopy, dlacn2, dtrmv, dtrsv, xerbla
216* ..
217* .. Intrinsic Functions ..
218 INTRINSIC abs, max
219* ..
220* .. External Functions ..
221 LOGICAL LSAME
222 DOUBLE PRECISION DLAMCH
223 EXTERNAL lsame, dlamch
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( 'DTRRFS', -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 = dlamch( 'Epsilon' )
277 safmin = dlamch( '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 dcopy( n, x( 1, j ), 1, work( n+1 ), 1 )
289 CALL dtrmv( uplo, trans, diag, n, a, lda, work( n+1 ), 1 )
290 CALL daxpy( 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 DLACN2 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 dlacn2( 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 dtrsv( 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 dtrsv( 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 DTRRFS
468*
dtrsv
subroutine dtrsv(uplo, trans, diag, n, a, lda, x, incx)
DTRSV
Definition dtrsv.f:143

◆ dtrsen()

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

DTRSEN

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

Purpose:
!>
!> DTRSEN 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 DHSEQR), 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]WI
!>          WI is DOUBLE PRECISION 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 DOUBLE PRECISION
!>          If JOB = 'E' or 'B', S is a lower bound on the reciprocal
!>          condition number for the selected cluster of eigenvalues.
!>          S cannot underestimate the true reciprocal condition number
!>          by more than a factor of sqrt(N). If M = 0 or N, S = 1.
!>          If JOB = 'N' or 'V', S is not referenced.
!>
[out]SEP
!>          SEP is DOUBLE PRECISION
!>          If JOB = 'V' or 'B', SEP is the estimated reciprocal
!>          condition number of the specified invariant subspace. If
!>          M = 0 or N, SEP = norm(T).
!>          If JOB = 'N' or 'E', SEP is not referenced.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If 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:
!>
!>  DTRSEN 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 311 of file dtrsen.f.

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

◆ dtrsna()

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

DTRSNA

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

Purpose:
!>
!> DTRSNA 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 DHSEQR), 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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
!>          DHSEIN or DTREVC.
!>          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 DOUBLE PRECISION 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
!>          DHSEIN or DTREVC.
!>          If JOB = 'V', VR is not referenced.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.
!>          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (MM)
!>          If JOB = 'E' or 'B', the reciprocal condition numbers of the
!>          selected eigenvalues, stored in consecutive elements of the
!>          array. 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 DOUBLE PRECISION array, dimension (MM)
!>          If JOB = 'V' or 'B', the estimated reciprocal condition
!>          numbers of the selected eigenvectors, stored in consecutive
!>          elements of the array. 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 DOUBLE PRECISION 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 dtrsna.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 DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
278 $ VR( LDVR, * ), WORK( LDWORK, * )
279* ..
280*
281* =====================================================================
282*
283* .. Parameters ..
284 DOUBLE PRECISION ZERO, ONE, TWO
285 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+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 DOUBLE PRECISION 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 DOUBLE PRECISION DUMMY( 1 )
296* ..
297* .. External Functions ..
298 LOGICAL LSAME
299 DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2
300 EXTERNAL lsame, ddot, dlamch, dlapy2, dnrm2
301* ..
302* .. External Subroutines ..
303 EXTERNAL dlabad, dlacn2, dlacpy, dlaqtr, dtrexc, 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( 'DTRSNA', -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 = dlamch( 'P' )
393 smlnum = dlamch( 'S' ) / eps
394 bignum = one / smlnum
395 CALL dlabad( 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 = ddot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
436 rnrm = dnrm2( n, vr( 1, ks ), 1 )
437 lnrm = dnrm2( n, vl( 1, ks ), 1 )
438 s( ks ) = abs( prod ) / ( rnrm*lnrm )
439 ELSE
440*
441* Complex eigenvalue.
442*
443 prod1 = ddot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
444 prod1 = prod1 + ddot( n, vr( 1, ks+1 ), 1, vl( 1, ks+1 ),
445 $ 1 )
446 prod2 = ddot( n, vl( 1, ks ), 1, vr( 1, ks+1 ), 1 )
447 prod2 = prod2 - ddot( n, vl( 1, ks+1 ), 1, vr( 1, ks ),
448 $ 1 )
449 rnrm = dlapy2( dnrm2( n, vr( 1, ks ), 1 ),
450 $ dnrm2( n, vr( 1, ks+1 ), 1 ) )
451 lnrm = dlapy2( dnrm2( n, vl( 1, ks ), 1 ),
452 $ dnrm2( n, vl( 1, ks+1 ), 1 ) )
453 cond = dlapy2( 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 dlacpy( 'Full', n, n, t, ldt, work, ldwork )
468 ifst = k
469 ilst = 1
470 CALL dtrexc( '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 = dlapy2( 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 dlacn2( 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 dlaqtr( .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 dlaqtr( .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 dlaqtr( .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 dlaqtr( .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 DTRSNA
599*
dlaqtr
subroutine dlaqtr(ltran, lreal, n, t, ldt, b, w, scale, x, work, info)
DLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of sp...
Definition dlaqtr.f:165

◆ dtrti2()

subroutine dtrti2 ( character uplo,
character diag,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer info )

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

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

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

◆ dtrtri()

subroutine dtrtri ( character uplo,
character diag,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer info )

DTRTRI

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

Purpose:
!>
!> DTRTRI 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 DOUBLE PRECISION 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 dtrtri.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 DOUBLE PRECISION A( LDA, * )
120* ..
121*
122* =====================================================================
123*
124* .. Parameters ..
125 DOUBLE PRECISION ONE, ZERO
126 parameter( one = 1.0d+0, zero = 0.0d+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 dtrmm, dtrsm, dtrti2, 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( 'DTRTRI', -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, 'DTRTRI', uplo // diag, n, -1, -1, -1 )
182 IF( nb.LE.1 .OR. nb.GE.n ) THEN
183*
184* Use unblocked code
185*
186 CALL dtrti2( 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 dtrmm( 'Left', 'Upper', 'No transpose', diag, j-1,
201 $ jb, one, a, lda, a( 1, j ), lda )
202 CALL dtrsm( '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 dtrti2( '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 dtrmm( '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 dtrsm( '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 dtrti2( 'Lower', diag, jb, a( j, j ), lda, info )
231 30 CONTINUE
232 END IF
233 END IF
234*
235 RETURN
236*
237* End of DTRTRI
238*
dtrti2
subroutine dtrti2(uplo, diag, n, a, lda, info)
DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
Definition dtrti2.f:110

◆ dtrtrs()

subroutine dtrtrs ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DTRTRS

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

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

◆ dtrttf()

subroutine dtrttf ( character transr,
character uplo,
integer n,
double precision, dimension( 0: lda-1, 0: * ) a,
integer lda,
double precision, dimension( 0: * ) arf,
integer info )

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

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

Purpose:
!>
!> DTRTTF 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtrttf.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 DOUBLE PRECISION 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( 'DTRTTF', -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 DTRTTF
488*

◆ dtrttp()

subroutine dtrttp ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) ap,
integer info )

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

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

Purpose:
!>
!> DTRTTP 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtrttp.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 DOUBLE PRECISION 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( 'DTRTTP', -info )
147 RETURN
148 END IF
149*
150 IF( lower ) THEN
151 k = 0
152 DO j = 1, n
153 DO i = j, n
154 k = k + 1
155 ap( k ) = a( i, j )
156 END DO
157 END DO
158 ELSE
159 k = 0
160 DO j = 1, n
161 DO i = 1, j
162 k = k + 1
163 ap( k ) = a( i, j )
164 END DO
165 END DO
166 END IF
167*
168*
169 RETURN
170*
171* End of DTRTTP
172*

◆ dtzrqf()

subroutine dtzrqf ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
integer info )

DTZRQF

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine DTZRZF.
!>
!> DTZRQF 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 dtzrqf.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 DOUBLE PRECISION A( LDA, * ), TAU( * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ONE, ZERO
154 parameter( one = 1.0d+0, zero = 0.0d+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER I, K, M1
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC max, min
161* ..
162* .. External Subroutines ..
163 EXTERNAL daxpy, dcopy, dgemv, dger, dlarfg, 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( 'DTZRQF', -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 dlarfg( 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 dcopy( k-1, a( 1, k ), 1, tau, 1 )
209*
210* Form w = a( k ) + B*z( k ) in TAU.
211*
212 CALL dgemv( '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 daxpy( k-1, -tau( k ), tau, 1, a( 1, k ), 1 )
219 CALL dger( 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 DTZRQF
228*

◆ dtzrzf()

subroutine dtzrzf ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer lwork,
integer info )

DTZRZF

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

Purpose:
!>
!> DTZRZF 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (M)
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  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 DTZRZF,
!>  and tau(k) is the kth element of the array TAU.
!>
!>

Definition at line 150 of file dtzrzf.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 DOUBLE PRECISION ZERO
167 parameter( zero = 0.0d+0 )
168* ..
169* .. Local Scalars ..
170 LOGICAL LQUERY
171 INTEGER I, IB, IWS, KI, KK, LDWORK, LWKMIN, LWKOPT,
172 $ M1, MU, NB, NBMIN, NX
173* ..
174* .. External Subroutines ..
175 EXTERNAL xerbla, dlarzb, dlarzt, dlatrz
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, 'DGERQF', ' ', 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( 'DTZRZF', -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, 'DGERQF', ' ', 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, 'DGERQF', ' ', 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 dlatrz( 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 dlarzt( '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 dlarzb( '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 dlatrz( mu, n, n-m, a, lda, tau, work )
303*
304 work( 1 ) = lwkopt
305*
306 RETURN
307*
308* End of DTZRZF
309*
dlatrz
subroutine dlatrz(m, n, l, a, lda, tau, work)
DLATRZ factors an upper trapezoidal matrix by means of orthogonal transformations.
Definition dlatrz.f:140

◆ stplqt()

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

STPLQT

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

Purpose:
!>
!> STPLQT computes a blocked LQ 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, and the order of the
!>          triangular matrix A.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix B.
!>          N >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in]MB
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.  M >= MB >= 1.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,M)
!>          On entry, the lower triangular M-by-M matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!>
[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 pentagonal M-by-N matrix B.  The first N-L columns
!>          are rectangular, and the last L columns are lower 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 lower 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 >= MB.
!>
[out]WORK
!>          WORK is REAL array, dimension (MB*M)
!>
[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 M-by-(M+N) matrix
!>
!>               C = [ A ] [ B ]
!>
!>
!>  where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
!>  upper trapezoidal matrix B2:
!>          [ B ] = [ B1 ] [ B2 ]
!>                   [ B1 ]  <- M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L lower trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  M-by-M lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>            [ C ] = [ A ] [ B ]
!>                   [ A ]  <- lower triangular M-by-M
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>            [ W ] = [ I ] [ V ]
!>                   [ I ]  <- identity, M-by-M
!>                   [ 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 ] [ V2 ]
!>                   [ V1 ] <- M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows of V represent the vectors which define the H(i)'s.
!>
!>  The number of blocks is B = ceiling(M/MB), where each
!>  block is of order MB except for the last block, which is of order
!>  IB = M - (M-1)*MB.  For each of the B blocks, a upper triangular block
!>  reflector factor is computed: T1, T2, ..., TB.  The MB-by-MB (and IB-by-IB
!>  for the last block) T's are stored in the MB-by-N matrix T as
!>
!>               T = [T1 T2 ... TB].
!>

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

Purpose:
!>
!> STPLQT computes a blocked LQ 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, and the order of the
!>          triangular matrix A.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix B.
!>          N >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in]MB
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.  M >= MB >= 1.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the lower triangular N-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!>
[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 N-L columns
!>          are rectangular, and the last L columns are lower 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 lower 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 >= MB.
!>
[out]WORK
!>          WORK is REAL array, dimension (MB*M)
!>
[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 M-by-(M+N) matrix
!>
!>               C = [ A ] [ B ]
!>
!>
!>  where A is an lower triangular N-by-N matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
!>  upper trapezoidal matrix B2:
!>          [ B ] = [ B1 ] [ B2 ]
!>                   [ B1 ]  <- M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L upper trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>            [ C ] = [ A ] [ B ]
!>                   [ A ]  <- lower triangular N-by-N
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>            [ W ] = [ I ] [ V ]
!>                   [ 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 ] [ V2 ]
!>                   [ V1 ] <- M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows of V represent the vectors which define the H(i)'s.
!>
!>  The number of blocks is B = ceiling(M/MB), where each
!>  block is of order MB except for the last block, which is of order
!>  IB = M - (M-1)*MB.  For each of the B blocks, a upper triangular block
!>  reflector factor is computed: T1, T2, ..., TB.  The MB-by-MB (and IB-by-IB
!>  for the last block) T's are stored in the MB-by-N matrix T as
!>
!>               T = [T1 T2 ... TB].
!>

Definition at line 187 of file stplqt.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, MB
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, NB, IINFO
206* ..
207* .. External Subroutines ..
208 EXTERNAL stplqt2, 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( mb.LT.1 .OR. (mb.GT.m .AND. m.GT.0)) THEN
222 info = -4
223 ELSE IF( lda.LT.max( 1, m ) ) THEN
224 info = -6
225 ELSE IF( ldb.LT.max( 1, m ) ) THEN
226 info = -8
227 ELSE IF( ldt.LT.mb ) THEN
228 info = -10
229 END IF
230 IF( info.NE.0 ) THEN
231 CALL xerbla( 'STPLQT', -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, m, mb
240*
241* Compute the QR factorization of the current block
242*
243 ib = min( m-i+1, mb )
244 nb = min( n-l+i+ib-1, n )
245 IF( i.GE.l ) THEN
246 lb = 0
247 ELSE
248 lb = nb-n+l-i+1
249 END IF
250*
251 CALL stplqt2( ib, nb, lb, a(i,i), lda, b( i, 1 ), ldb,
252 $ t(1, i ), ldt, iinfo )
253*
254* Update by applying H**T to B(I+IB:M,:) from the right
255*
256 IF( i+ib.LE.m ) THEN
257 CALL stprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,
258 $ b( i, 1 ), ldb, t( 1, i ), ldt,
259 $ a( i+ib, i ), lda, b( i+ib, 1 ), ldb,
260 $ work, m-i-ib+1)
261 END IF
262 END DO
263 RETURN
264*
265* End of STPLQT
266*
stplqt2
subroutine stplqt2(m, n, l, a, lda, b, ldb, t, ldt, info)
STPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix,...
Definition stplqt2.f:177
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

◆ stplqt2()

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

STPLQT2 computes a LQ 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 STPLQT2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> STPLQT2 computes a LQ a 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 lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,M)
!>          On entry, the lower triangular M-by-M matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!>
[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 pentagonal M-by-N matrix B.  The first N-L columns
!>          are rectangular, and the last L columns are lower 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,M)
!>          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,M)
!>
[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 M-by-(M+N) matrix
!>
!>               C = [ A ][ B ]
!>
!>
!>  where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L
!>  upper trapezoidal matrix B2:
!>
!>               B = [ B1 ][ B2 ]
!>                   [ B1 ]  <-     M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L lower trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>
!>               C = [ A ][ B ]
!>                   [ A ]  <- lower triangular M-by-M
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>
!>               W = [ I ][ V ]
!>                   [ I ]  <- identity, M-by-M
!>                   [ 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,
!>
!>               W = [ V1 ][ V2 ]
!>                   [ V1 ] <-     M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows 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 * T * W
!>
!>  where W^H is the conjugate transpose of W and T is the upper triangular
!>  factor of the block reflector.
!>

Definition at line 176 of file stplqt2.f.

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

◆ stpmlqt()

subroutine stpmlqt ( character side,
character trans,
integer m,
integer n,
integer k,
integer l,
integer mb,
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 )

STPMLQT

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

Purpose:
!>
!> STPMLQT 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]MB
!>          MB is INTEGER
!>          The block size used for the storage of T.  K >= MB >= 1.
!>          This must be the same value of MB used to generate T
!>          in STPLQT.
!>
[in]V
!>          V is REAL array, dimension (LDV,K)
!>          The i-th row must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          STPLQT in B.  See Further Details.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= K.
!>
[in]T
!>          T is REAL array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by STPLQT, stored as a MB-by-K matrix.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= MB.
!>
[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', LDA >= max(1,K);
!>          If SIDE = 'R', LDA >= 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*MB if SIDE = 'L', or  M*MB 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 lower trapezoidal, consisting of the first L
!>  rows of a K-by-K upper triangular matrix.  If L=K, V2 is lower 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 K-by-M.
!>                      [B]
!>
!>  If SIDE = 'R':  C = [A B]  where A is M-by-K, B is M-by-N and V is K-by-N.
!>
!>  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 212 of file stpmlqt.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 CHARACTER SIDE, TRANS
221 INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT
222* ..
223* .. Array Arguments ..
224 REAL V( LDV, * ), A( LDA, * ), B( LDB, * ),
225 $ T( LDT, * ), WORK( * )
226* ..
227*
228* =====================================================================
229*
230* ..
231* .. Local Scalars ..
232 LOGICAL LEFT, RIGHT, TRAN, NOTRAN
233 INTEGER I, IB, NB, LB, KF, LDAQ
234* ..
235* .. External Functions ..
236 LOGICAL LSAME
237 EXTERNAL lsame
238* ..
239* .. External Subroutines ..
240 EXTERNAL xerbla, stprfb
241* ..
242* .. Intrinsic Functions ..
243 INTRINSIC max, min
244* ..
245* .. Executable Statements ..
246*
247* .. Test the input arguments ..
248*
249 info = 0
250 left = lsame( side, 'L' )
251 right = lsame( side, 'R' )
252 tran = lsame( trans, 'T' )
253 notran = lsame( trans, 'N' )
254*
255 IF ( left ) THEN
256 ldaq = max( 1, k )
257 ELSE IF ( right ) THEN
258 ldaq = max( 1, m )
259 END IF
260 IF( .NOT.left .AND. .NOT.right ) THEN
261 info = -1
262 ELSE IF( .NOT.tran .AND. .NOT.notran ) THEN
263 info = -2
264 ELSE IF( m.LT.0 ) THEN
265 info = -3
266 ELSE IF( n.LT.0 ) THEN
267 info = -4
268 ELSE IF( k.LT.0 ) THEN
269 info = -5
270 ELSE IF( l.LT.0 .OR. l.GT.k ) THEN
271 info = -6
272 ELSE IF( mb.LT.1 .OR. (mb.GT.k .AND. k.GT.0) ) THEN
273 info = -7
274 ELSE IF( ldv.LT.k ) THEN
275 info = -9
276 ELSE IF( ldt.LT.mb ) THEN
277 info = -11
278 ELSE IF( lda.LT.ldaq ) THEN
279 info = -13
280 ELSE IF( ldb.LT.max( 1, m ) ) THEN
281 info = -15
282 END IF
283*
284 IF( info.NE.0 ) THEN
285 CALL xerbla( 'STPMLQT', -info )
286 RETURN
287 END IF
288*
289* .. Quick return if possible ..
290*
291 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) RETURN
292*
293 IF( left .AND. notran ) THEN
294*
295 DO i = 1, k, mb
296 ib = min( mb, k-i+1 )
297 nb = min( m-l+i+ib-1, m )
298 IF( i.GE.l ) THEN
299 lb = 0
300 ELSE
301 lb = 0
302 END IF
303 CALL stprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,
304 $ v( i, 1 ), ldv, t( 1, i ), ldt,
305 $ a( i, 1 ), lda, b, ldb, work, ib )
306 END DO
307*
308 ELSE IF( right .AND. tran ) THEN
309*
310 DO i = 1, k, mb
311 ib = min( mb, k-i+1 )
312 nb = min( n-l+i+ib-1, n )
313 IF( i.GE.l ) THEN
314 lb = 0
315 ELSE
316 lb = nb-n+l-i+1
317 END IF
318 CALL stprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,
319 $ v( i, 1 ), ldv, t( 1, i ), ldt,
320 $ a( 1, i ), lda, b, ldb, work, m )
321 END DO
322*
323 ELSE IF( left .AND. tran ) THEN
324*
325 kf = ((k-1)/mb)*mb+1
326 DO i = kf, 1, -mb
327 ib = min( mb, k-i+1 )
328 nb = min( m-l+i+ib-1, m )
329 IF( i.GE.l ) THEN
330 lb = 0
331 ELSE
332 lb = 0
333 END IF
334 CALL stprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,
335 $ v( i, 1 ), ldv, t( 1, i ), ldt,
336 $ a( i, 1 ), lda, b, ldb, work, ib )
337 END DO
338*
339 ELSE IF( right .AND. notran ) THEN
340*
341 kf = ((k-1)/mb)*mb+1
342 DO i = kf, 1, -mb
343 ib = min( mb, k-i+1 )
344 nb = min( n-l+i+ib-1, n )
345 IF( i.GE.l ) THEN
346 lb = 0
347 ELSE
348 lb = nb-n+l-i+1
349 END IF
350 CALL stprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,
351 $ v( i, 1 ), ldv, t( 1, i ), ldt,
352 $ a( 1, i ), lda, b, ldb, work, m )
353 END DO
354*
355 END IF
356*
357 RETURN
358*
359* End of STPMLQT
360*

◆ ztplqt()

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

ZTPLQT

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

Purpose:
!>
!> ZTPLQT computes a blocked LQ factorization of a complex
!>  matrix C, which is composed of a
!> triangular block A and pentagonal block B, using the compact
!> WY representation for Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix B, and the order of the
!>          triangular matrix A.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix B.
!>          N >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in]MB
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.  M >= MB >= 1.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,M)
!>          On entry, the lower triangular M-by-M matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          On entry, the pentagonal M-by-N matrix B.  The first N-L columns
!>          are rectangular, and the last L columns are lower trapezoidal.
!>          On exit, B contains the pentagonal matrix V.  See Further Details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDT,N)
!>          The lower 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 >= MB.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MB*M)
!>
[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 M-by-(M+N) matrix
!>
!>               C = [ A ] [ B ]
!>
!>
!>  where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L
!>  upper trapezoidal matrix B2:
!>          [ B ] = [ B1 ] [ B2 ]
!>                   [ B1 ]  <- M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L lower trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  M-by-M lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>            [ C ] = [ A ] [ B ]
!>                   [ A ]  <- lower triangular M-by-M
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>            [ W ] = [ I ] [ V ]
!>                   [ I ]  <- identity, M-by-M
!>                   [ 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 ] [ V2 ]
!>                   [ V1 ] <- M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows of V represent the vectors which define the H(i)'s.
!>
!>  The number of blocks is B = ceiling(M/MB), where each
!>  block is of order MB except for the last block, which is of order
!>  IB = M - (M-1)*MB.  For each of the B blocks, a upper triangular block
!>  reflector factor is computed: T1, T2, ..., TB.  The MB-by-MB (and IB-by-IB
!>  for the last block) T's are stored in the MB-by-N matrix T as
!>
!>               T = [T1 T2 ... TB].
!>

Definition at line 187 of file ztplqt.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, MB
196* ..
197* .. Array Arguments ..
198 COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * )
199* ..
200*
201* =====================================================================
202*
203* ..
204* .. Local Scalars ..
205 INTEGER I, IB, LB, NB, IINFO
206* ..
207* .. External Subroutines ..
208 EXTERNAL ztplqt2, ztprfb, xerbla
209* ..
210* .. Executable Statements ..
211*
212* Test the input arguments
213*
214 info = 0
215 IF( m.LT.0 ) THEN
216 info = -1
217 ELSE IF( n.LT.0 ) THEN
218 info = -2
219 ELSE IF( l.LT.0 .OR. (l.GT.min(m,n) .AND. min(m,n).GE.0)) THEN
220 info = -3
221 ELSE IF( mb.LT.1 .OR. (mb.GT.m .AND. m.GT.0)) THEN
222 info = -4
223 ELSE IF( lda.LT.max( 1, m ) ) THEN
224 info = -6
225 ELSE IF( ldb.LT.max( 1, m ) ) THEN
226 info = -8
227 ELSE IF( ldt.LT.mb ) THEN
228 info = -10
229 END IF
230 IF( info.NE.0 ) THEN
231 CALL xerbla( 'ZTPLQT', -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, m, mb
240*
241* Compute the QR factorization of the current block
242*
243 ib = min( m-i+1, mb )
244 nb = min( n-l+i+ib-1, n )
245 IF( i.GE.l ) THEN
246 lb = 0
247 ELSE
248 lb = nb-n+l-i+1
249 END IF
250*
251 CALL ztplqt2( ib, nb, lb, a(i,i), lda, b( i, 1 ), ldb,
252 $ t(1, i ), ldt, iinfo )
253*
254* Update by applying H**T to B(I+IB:M,:) from the right
255*
256 IF( i+ib.LE.m ) THEN
257 CALL ztprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,
258 $ b( i, 1 ), ldb, t( 1, i ), ldt,
259 $ a( i+ib, i ), lda, b( i+ib, 1 ), ldb,
260 $ work, m-i-ib+1)
261 END IF
262 END DO
263 RETURN
264*
265* End of ZTPLQT
266*
ztprfb
subroutine ztprfb(side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, a, lda, b, ldb, work, ldwork)
ZTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matri...
Definition ztprfb.f:251
ztplqt2
subroutine ztplqt2(m, n, l, a, lda, b, ldb, t, ldt, info)
ZTPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix,...
Definition ztplqt2.f:177

◆ ztplqt2()

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

ZTPLQT2 computes a LQ 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 ZTPLQT2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> ZTPLQT2 computes a LQ a factorization of a complex 
!> matrix C, which is composed of a triangular block A and pentagonal block B,
!> using the compact WY representation for Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The total number of rows of the matrix B.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix B, and the order of
!>          the triangular matrix A.
!>          N >= 0.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the lower trapezoidal part of B.
!>          MIN(M,N) >= L >= 0.  See Further Details.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,M)
!>          On entry, the lower triangular M-by-M matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the lower triangular matrix L.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          On entry, the pentagonal M-by-N matrix B.  The first N-L columns
!>          are rectangular, and the last L columns are lower trapezoidal.
!>          On exit, B contains the pentagonal matrix V.  See Further Details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDT,M)
!>          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,M)
!>
[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 M-by-(M+N) matrix
!>
!>               C = [ A ][ B ]
!>
!>
!>  where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal
!>  matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L
!>  upper trapezoidal matrix B2:
!>
!>               B = [ B1 ][ B2 ]
!>                   [ B1 ]  <-     M-by-(N-L) rectangular
!>                   [ B2 ]  <-     M-by-L lower trapezoidal.
!>
!>  The lower trapezoidal matrix B2 consists of the first L columns of a
!>  N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
!>  B is rectangular M-by-N; if M=L=N, B is lower triangular.
!>
!>  The matrix W stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal (of A) in the M-by-(M+N) input matrix C
!>
!>               C = [ A ][ B ]
!>                   [ A ]  <- lower triangular M-by-M
!>                   [ B ]  <- M-by-N pentagonal
!>
!>  so that W can be represented as
!>
!>               W = [ I ][ V ]
!>                   [ I ]  <- identity, M-by-M
!>                   [ 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,
!>
!>               W = [ V1 ][ V2 ]
!>                   [ V1 ] <-     M-by-(N-L) rectangular
!>                   [ V2 ] <-     M-by-L lower trapezoidal.
!>
!>  The rows 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 * T * W
!>
!>  where W^H is the conjugate transpose of W and T is the upper triangular
!>  factor of the block reflector.
!>

Definition at line 176 of file ztplqt2.f.

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

◆ ztpmlqt()

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

ZTPMLQT

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

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

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