OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
double
LAPACK » General Matrices » Computational routines

Functions

subroutine cgelqt (m, n, mb, a, lda, t, ldt, work, info)
 CGELQT
recursive subroutine cgelqt3 (m, n, a, lda, t, ldt, info)
 CGELQT3
subroutine cgemlqt (side, trans, m, n, k, mb, v, ldv, t, ldt, c, ldc, work, info)
 CGEMLQT
subroutine dgeqpf (m, n, a, lda, jpvt, tau, work, info)
 DGEQPF
subroutine dgebak (job, side, n, ilo, ihi, scale, m, v, ldv, info)
 DGEBAK
subroutine dgebal (job, n, a, lda, ilo, ihi, scale, info)
 DGEBAL
subroutine dgebd2 (m, n, a, lda, d, e, tauq, taup, work, info)
 DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
subroutine dgebrd (m, n, a, lda, d, e, tauq, taup, work, lwork, info)
 DGEBRD
subroutine dgecon (norm, n, a, lda, anorm, rcond, work, iwork, info)
 DGECON
subroutine dgeequ (m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
 DGEEQU
subroutine dgeequb (m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
 DGEEQUB
subroutine dgehd2 (n, ilo, ihi, a, lda, tau, work, info)
 DGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
subroutine dgehrd (n, ilo, ihi, a, lda, tau, work, lwork, info)
 DGEHRD
subroutine dgelq2 (m, n, a, lda, tau, work, info)
 DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
subroutine dgelqf (m, n, a, lda, tau, work, lwork, info)
 DGELQF
subroutine dgelqt (m, n, mb, a, lda, t, ldt, work, info)
 DGELQT
recursive subroutine dgelqt3 (m, n, a, lda, t, ldt, info)
 DGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact WY representation of Q.
subroutine dgemlqt (side, trans, m, n, k, mb, v, ldv, t, ldt, c, ldc, work, info)
 DGEMLQT
subroutine dgemqrt (side, trans, m, n, k, nb, v, ldv, t, ldt, c, ldc, work, info)
 DGEMQRT
subroutine dgeql2 (m, n, a, lda, tau, work, info)
 DGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.
subroutine dgeqlf (m, n, a, lda, tau, work, lwork, info)
 DGEQLF
subroutine dgeqp3 (m, n, a, lda, jpvt, tau, work, lwork, info)
 DGEQP3
subroutine dgeqr2 (m, n, a, lda, tau, work, info)
 DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
subroutine dgeqr2p (m, n, a, lda, tau, work, info)
 DGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elements using an unblocked algorithm.
subroutine dgeqrf (m, n, a, lda, tau, work, lwork, info)
 DGEQRF
subroutine dgeqrfp (m, n, a, lda, tau, work, lwork, info)
 DGEQRFP
subroutine dgeqrt (m, n, nb, a, lda, t, ldt, work, info)
 DGEQRT
subroutine dgeqrt2 (m, n, a, lda, t, ldt, info)
 DGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.
recursive subroutine dgeqrt3 (m, n, a, lda, t, ldt, info)
 DGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.
subroutine dgerfs (trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
 DGERFS
subroutine dgerfsx (trans, equed, n, nrhs, a, lda, af, ldaf, ipiv, r, c, b, ldb, x, ldx, rcond, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, iwork, info)
 DGERFSX
subroutine dgerq2 (m, n, a, lda, tau, work, info)
 DGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
subroutine dgerqf (m, n, a, lda, tau, work, lwork, info)
 DGERQF
subroutine dgesvj (joba, jobu, jobv, m, n, a, lda, sva, mv, v, ldv, work, lwork, info)
 DGESVJ
subroutine dgetf2 (m, n, a, lda, ipiv, info)
 DGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm).
subroutine dgetrf (m, n, a, lda, ipiv, info)
 DGETRF
recursive subroutine dgetrf2 (m, n, a, lda, ipiv, info)
 DGETRF2
subroutine dgetri (n, a, lda, ipiv, work, lwork, info)
 DGETRI
subroutine dgetrs (trans, n, nrhs, a, lda, ipiv, b, ldb, info)
 DGETRS
subroutine dhgeqz (job, compq, compz, n, ilo, ihi, h, ldh, t, ldt, alphar, alphai, beta, q, ldq, z, ldz, work, lwork, info)
 DHGEQZ
subroutine dla_geamv (trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
 DLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds.
double precision function dla_gercond (trans, n, a, lda, af, ldaf, ipiv, cmode, c, info, work, iwork)
 DLA_GERCOND estimates the Skeel condition number for a general matrix.
subroutine dla_gerfsx_extended (prec_type, trans_type, n, nrhs, a, lda, af, ldaf, ipiv, colequ, c, b, ldb, y, ldy, berr_out, n_norms, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, info)
 DLA_GERFSX_EXTENDED improves the computed solution to a system of linear equations for general matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution.
double precision function dla_gerpvgrw (n, ncols, a, lda, af, ldaf)
 DLA_GERPVGRW
subroutine dlaorhr_col_getrfnp (m, n, a, lda, d, info)
 DLAORHR_COL_GETRFNP
recursive subroutine dlaorhr_col_getrfnp2 (m, n, a, lda, d, info)
 DLAORHR_COL_GETRFNP2
recursive subroutine dlaqz0 (wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb, alphar, alphai, beta, q, ldq, z, ldz, work, lwork, rec, info)
 DLAQZ0
subroutine dlaqz1 (a, lda, b, ldb, sr1, sr2, si, beta1, beta2, v)
 DLAQZ1
subroutine dlaqz2 (ilq, ilz, k, istartm, istopm, ihi, a, lda, b, ldb, nq, qstart, q, ldq, nz, zstart, z, ldz)
 DLAQZ2
recursive subroutine dlaqz3 (ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb, q, ldq, z, ldz, ns, nd, alphar, alphai, beta, qc, ldqc, zc, ldzc, work, lwork, rec, info)
 DLAQZ3
subroutine dlaqz4 (ilschur, ilq, ilz, n, ilo, ihi, nshifts, nblock_desired, sr, si, ss, a, lda, b, ldb, q, ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork, info)
 DLAQZ4
subroutine dtgevc (side, howmny, select, n, s, lds, p, ldp, vl, ldvl, vr, ldvr, mm, m, work, info)
 DTGEVC
subroutine dtgexc (wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, work, lwork, info)
 DTGEXC
subroutine sgelqt (m, n, mb, a, lda, t, ldt, work, info)
 SGELQT
recursive subroutine sgelqt3 (m, n, a, lda, t, ldt, info)
 SGELQT3
subroutine sgemlqt (side, trans, m, n, k, mb, v, ldv, t, ldt, c, ldc, work, info)
 SGEMLQT
recursive subroutine slaqz0 (wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb, alphar, alphai, beta, q, ldq, z, ldz, work, lwork, rec, info)
 SLAQZ0
subroutine slaqz1 (a, lda, b, ldb, sr1, sr2, si, beta1, beta2, v)
 SLAQZ1
subroutine slaqz2 (ilq, ilz, k, istartm, istopm, ihi, a, lda, b, ldb, nq, qstart, q, ldq, nz, zstart, z, ldz)
 SLAQZ2
recursive subroutine slaqz3 (ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb, q, ldq, z, ldz, ns, nd, alphar, alphai, beta, qc, ldqc, zc, ldzc, work, lwork, rec, info)
 SLAQZ3
subroutine slaqz4 (ilschur, ilq, ilz, n, ilo, ihi, nshifts, nblock_desired, sr, si, ss, a, lda, b, ldb, q, ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork, info)
 SLAQZ4
subroutine zgelqt (m, n, mb, a, lda, t, ldt, work, info)
 ZGELQT
recursive subroutine zgelqt3 (m, n, a, lda, t, ldt, info)
 ZGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact WY representation of Q.
subroutine zgemlqt (side, trans, m, n, k, mb, v, ldv, t, ldt, c, ldc, work, info)
 ZGEMLQT

Detailed Description

This is the group of double computational functions for GE matrices

Function Documentation

◆ cgelqt()

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

CGELQT

Purpose:
!>
!> CGELQT computes a blocked LQ factorization of a complex M-by-N matrix A
!> using the compact WY representation of Q.
!>
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]MB
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.  MIN(M,N) >= MB >= 1.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the M-by-MIN(M,N) lower trapezoidal matrix L (L is
!>          lower triangular if M <= N); the elements above the diagonal
!>          are the rows of V.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is COMPLEX array, dimension (LDT,MIN(M,N))
!>          The upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.  See below
!>          for further details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= MB.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MB*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 matrix V stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1  v1 v1 v1 v1 )
!>                   (     1  v2 v2 v2 )
!>                   (         1 v3 v3 )
!>
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.
!>  Let K=MIN(M,N).  The number of blocks is B = ceiling(K/MB), where each
!>  block is of order MB except for the last block, which is of order
!>  IB = K - (B-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-K matrix T as
!>
!>               T = (T1 T2 ... TB).
!>

Definition at line 123 of file cgelqt.f.

124*
125* -- LAPACK computational routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 INTEGER INFO, LDA, LDT, M, N, MB
131* ..
132* .. Array Arguments ..
133 COMPLEX A( LDA, * ), T( LDT, * ), WORK( * )
134* ..
135*
136* =====================================================================
137*
138* ..
139* .. Local Scalars ..
140 INTEGER I, IB, IINFO, K
141* ..
142* .. External Subroutines ..
143 EXTERNAL cgelqt3, clarfb, xerbla
144* ..
145* .. Executable Statements ..
146*
147* Test the input arguments
148*
149 info = 0
150 IF( m.LT.0 ) THEN
151 info = -1
152 ELSE IF( n.LT.0 ) THEN
153 info = -2
154 ELSE IF( mb.LT.1 .OR. (mb.GT.min(m,n) .AND. min(m,n).GT.0 ))THEN
155 info = -3
156 ELSE IF( lda.LT.max( 1, m ) ) THEN
157 info = -5
158 ELSE IF( ldt.LT.mb ) THEN
159 info = -7
160 END IF
161 IF( info.NE.0 ) THEN
162 CALL xerbla( 'CGELQT', -info )
163 RETURN
164 END IF
165*
166* Quick return if possible
167*
168 k = min( m, n )
169 IF( k.EQ.0 ) RETURN
170*
171* Blocked loop of length K
172*
173 DO i = 1, k, mb
174 ib = min( k-i+1, mb )
175*
176* Compute the LQ factorization of the current block A(I:M,I:I+IB-1)
177*
178 CALL cgelqt3( ib, n-i+1, a(i,i), lda, t(1,i), ldt, iinfo )
179 IF( i+ib.LE.m ) THEN
180*
181* Update by applying H**T to A(I:M,I+IB:N) from the right
182*
183 CALL clarfb( 'R', 'N', 'F', 'R', m-i-ib+1, n-i+1, ib,
184 $ a( i, i ), lda, t( 1, i ), ldt,
185 $ a( i+ib, i ), lda, work , m-i-ib+1 )
186 END IF
187 END DO
188 RETURN
189*
190* End of CGELQT
191*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
clarfb
subroutine clarfb(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
CLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
Definition clarfb.f:197
cgelqt3
recursive subroutine cgelqt3(m, n, a, lda, t, ldt, info)
CGELQT3
Definition cgelqt3.f:116
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ cgelqt3()

recursive subroutine cgelqt3 ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldt, * ) t,
integer ldt,
integer info )

CGELQT3

Purpose:
!>
!> CGELQT3 recursively computes a LQ factorization of a complex M-by-N
!> matrix A, using the compact WY representation of Q.
!>
!> Based on the algorithm of Elmroth and Gustavson,
!> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M =< N.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the complex M-by-N matrix A.  On exit, the elements on and
!>          below the diagonal contain the N-by-N lower triangular matrix L; the
!>          elements above the diagonal are the rows of V.  See below for
!>          further details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is COMPLEX array, dimension (LDT,N)
!>          The N-by-N upper triangular factor of the block reflector.
!>          The elements on and above the diagonal contain the block
!>          reflector T; the elements below the diagonal are not used.
!>          See below for 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 matrix V stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1  v1 v1 v1 v1 )
!>                   (     1  v2 v2 v2 )
!>                   (     1  v3 v3 v3 )
!>
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.  The
!>  block reflector H is then given by
!>
!>               H = I - V * T * V**T
!>
!>  where V**T is the transpose of V.
!>
!>  For details of the algorithm, see Elmroth and Gustavson (cited above).
!>

Definition at line 115 of file cgelqt3.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 INTEGER INFO, LDA, M, N, LDT
123* ..
124* .. Array Arguments ..
125 COMPLEX A( LDA, * ), T( LDT, * )
126* ..
127*
128* =====================================================================
129*
130* .. Parameters ..
131 COMPLEX ONE, ZERO
132 parameter( one = (1.0e+00,0.0e+00) )
133 parameter( zero = (0.0e+00,0.0e+00))
134* ..
135* .. Local Scalars ..
136 INTEGER I, I1, J, J1, M1, M2, IINFO
137* ..
138* .. External Subroutines ..
139 EXTERNAL clarfg, ctrmm, cgemm, xerbla
140* ..
141* .. Executable Statements ..
142*
143 info = 0
144 IF( m .LT. 0 ) THEN
145 info = -1
146 ELSE IF( n .LT. m ) THEN
147 info = -2
148 ELSE IF( lda .LT. max( 1, m ) ) THEN
149 info = -4
150 ELSE IF( ldt .LT. max( 1, m ) ) THEN
151 info = -6
152 END IF
153 IF( info.NE.0 ) THEN
154 CALL xerbla( 'CGELQT3', -info )
155 RETURN
156 END IF
157*
158 IF( m.EQ.1 ) THEN
159*
160* Compute Householder transform when M=1
161*
162 CALL clarfg( n, a, a( 1, min( 2, n ) ), lda, t )
163 t(1,1)=conjg(t(1,1))
164*
165 ELSE
166*
167* Otherwise, split A into blocks...
168*
169 m1 = m/2
170 m2 = m-m1
171 i1 = min( m1+1, m )
172 j1 = min( m+1, n )
173*
174* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
175*
176 CALL cgelqt3( m1, n, a, lda, t, ldt, iinfo )
177*
178* Compute A(J1:M,1:N) = A(J1:M,1:N) Q1^H [workspace: T(1:N1,J1:N)]
179*
180 DO i=1,m2
181 DO j=1,m1
182 t( i+m1, j ) = a( i+m1, j )
183 END DO
184 END DO
185 CALL ctrmm( 'R', 'U', 'C', 'U', m2, m1, one,
186 & a, lda, t( i1, 1 ), ldt )
187*
188 CALL cgemm( 'N', 'C', m2, m1, n-m1, one, a( i1, i1 ), lda,
189 & a( 1, i1 ), lda, one, t( i1, 1 ), ldt)
190*
191 CALL ctrmm( 'R', 'U', 'N', 'N', m2, m1, one,
192 & t, ldt, t( i1, 1 ), ldt )
193*
194 CALL cgemm( 'N', 'N', m2, n-m1, m1, -one, t( i1, 1 ), ldt,
195 & a( 1, i1 ), lda, one, a( i1, i1 ), lda )
196*
197 CALL ctrmm( 'R', 'U', 'N', 'U', m2, m1 , one,
198 & a, lda, t( i1, 1 ), ldt )
199*
200 DO i=1,m2
201 DO j=1,m1
202 a( i+m1, j ) = a( i+m1, j ) - t( i+m1, j )
203 t( i+m1, j )= zero
204 END DO
205 END DO
206*
207* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
208*
209 CALL cgelqt3( m2, n-m1, a( i1, i1 ), lda,
210 & t( i1, i1 ), ldt, iinfo )
211*
212* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2
213*
214 DO i=1,m2
215 DO j=1,m1
216 t( j, i+m1 ) = (a( j, i+m1 ))
217 END DO
218 END DO
219*
220 CALL ctrmm( 'R', 'U', 'C', 'U', m1, m2, one,
221 & a( i1, i1 ), lda, t( 1, i1 ), ldt )
222*
223 CALL cgemm( 'N', 'C', m1, m2, n-m, one, a( 1, j1 ), lda,
224 & a( i1, j1 ), lda, one, t( 1, i1 ), ldt )
225*
226 CALL ctrmm( 'L', 'U', 'N', 'N', m1, m2, -one, t, ldt,
227 & t( 1, i1 ), ldt )
228*
229 CALL ctrmm( 'R', 'U', 'N', 'N', m1, m2, one,
230 & t( i1, i1 ), ldt, t( 1, i1 ), ldt )
231*
232*
233*
234* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3]
235* [ A(1:N1,J1:N) L2 ] [ 0 T2]
236*
237 END IF
238*
239 RETURN
240*
241* End of CGELQT3
242*
clarfg
subroutine clarfg(n, alpha, x, incx, tau)
CLARFG generates an elementary reflector (Householder matrix).
Definition clarfg.f:106
ctrmm
subroutine ctrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRMM
Definition ctrmm.f:177
cgemm
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:187

◆ cgemlqt()

subroutine cgemlqt ( character side,
character trans,
integer m,
integer n,
integer k,
integer mb,
complex, dimension( ldv, * ) v,
integer ldv,
complex, dimension( ldt, * ) t,
integer ldt,
complex, dimension( ldc, * ) c,
integer ldc,
complex, dimension( * ) work,
integer info )

CGEMLQT

Purpose:
!>
!> CGEMLQT overwrites the general complex M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q C            C Q
!> TRANS = 'C':   Q**H C            C Q**H
!>
!> where Q is a complex unitary matrix defined as the product of K
!> elementary reflectors:
!>
!>       Q = H(1) H(2) . . . H(K) = I - V T V**H
!>
!> generated using the compact WY representation as returned by CGELQT.
!>
!> Q is of order M if SIDE = 'L' and of order N  if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate transpose, apply Q**H.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]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 CGELQT.
!>
[in]V
!>          V is COMPLEX array, dimension
!>                               (LDV,M) if SIDE = 'L',
!>                               (LDV,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
!>          CGELQT in the first K rows of its array argument A.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= max(1,K).
!>
[in]T
!>          T is COMPLEX array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by CGELQT, stored as a MB-by-K matrix.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= MB.
!>
[in,out]C
!>          C is COMPLEX array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q C, Q**H C, C Q**H or C Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX array. 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.

Definition at line 151 of file cgemlqt.f.

153*
154* -- LAPACK computational routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
161* ..
162* .. Array Arguments ..
163 COMPLEX V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
164* ..
165*
166* =====================================================================
167*
168* ..
169* .. Local Scalars ..
170 LOGICAL LEFT, RIGHT, TRAN, NOTRAN
171 INTEGER I, IB, LDWORK, KF, Q
172* ..
173* .. External Functions ..
174 LOGICAL LSAME
175 EXTERNAL lsame
176* ..
177* .. External Subroutines ..
178 EXTERNAL xerbla, clarfb
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC max, min
182* ..
183* .. Executable Statements ..
184*
185* .. Test the input arguments ..
186*
187 info = 0
188 left = lsame( side, 'L' )
189 right = lsame( side, 'R' )
190 tran = lsame( trans, 'C' )
191 notran = lsame( trans, 'N' )
192*
193 IF( left ) THEN
194 ldwork = max( 1, n )
195 q = m
196 ELSE IF ( right ) THEN
197 ldwork = max( 1, m )
198 q = n
199 END IF
200 IF( .NOT.left .AND. .NOT.right ) THEN
201 info = -1
202 ELSE IF( .NOT.tran .AND. .NOT.notran ) THEN
203 info = -2
204 ELSE IF( m.LT.0 ) THEN
205 info = -3
206 ELSE IF( n.LT.0 ) THEN
207 info = -4
208 ELSE IF( k.LT.0 .OR. k.GT.q ) THEN
209 info = -5
210 ELSE IF( mb.LT.1 .OR. (mb.GT.k .AND. k.GT.0)) THEN
211 info = -6
212 ELSE IF( ldv.LT.max( 1, k ) ) THEN
213 info = -8
214 ELSE IF( ldt.LT.mb ) THEN
215 info = -10
216 ELSE IF( ldc.LT.max( 1, m ) ) THEN
217 info = -12
218 END IF
219*
220 IF( info.NE.0 ) THEN
221 CALL xerbla( 'CGEMLQT', -info )
222 RETURN
223 END IF
224*
225* .. Quick return if possible ..
226*
227 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) RETURN
228*
229 IF( left .AND. notran ) THEN
230*
231 DO i = 1, k, mb
232 ib = min( mb, k-i+1 )
233 CALL clarfb( 'L', 'C', 'F', 'R', m-i+1, n, ib,
234 $ v( i, i ), ldv, t( 1, i ), ldt,
235 $ c( i, 1 ), ldc, work, ldwork )
236 END DO
237*
238 ELSE IF( right .AND. tran ) THEN
239*
240 DO i = 1, k, mb
241 ib = min( mb, k-i+1 )
242 CALL clarfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,
243 $ v( i, i ), ldv, t( 1, i ), ldt,
244 $ c( 1, i ), ldc, work, ldwork )
245 END DO
246*
247 ELSE IF( left .AND. tran ) THEN
248*
249 kf = ((k-1)/mb)*mb+1
250 DO i = kf, 1, -mb
251 ib = min( mb, k-i+1 )
252 CALL clarfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,
253 $ v( i, i ), ldv, t( 1, i ), ldt,
254 $ c( i, 1 ), ldc, work, ldwork )
255 END DO
256*
257 ELSE IF( right .AND. notran ) THEN
258*
259 kf = ((k-1)/mb)*mb+1
260 DO i = kf, 1, -mb
261 ib = min( mb, k-i+1 )
262 CALL clarfb( 'R', 'C', 'F', 'R', m, n-i+1, ib,
263 $ v( i, i ), ldv, t( 1, i ), ldt,
264 $ c( 1, i ), ldc, work, ldwork )
265 END DO
266*
267 END IF
268*
269 RETURN
270*
271* End of CGEMLQT
272*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53

◆ dgebak()

subroutine dgebak ( character job,
character side,
integer n,
integer ilo,
integer ihi,
double precision, dimension( * ) scale,
integer m,
double precision, dimension( ldv, * ) v,
integer ldv,
integer info )

DGEBAK

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

Purpose:
!>
!> DGEBAK forms the right or left eigenvectors of a real general matrix
!> by backward transformation on the computed eigenvectors of the
!> balanced matrix output by DGEBAL.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          Specifies the type of backward transformation required:
!>          = 'N': do nothing, return immediately;
!>          = 'P': do backward transformation for permutation only;
!>          = 'S': do backward transformation for scaling only;
!>          = 'B': do backward transformations for both permutation and
!>                 scaling.
!>          JOB must be the same as the argument JOB supplied to DGEBAL.
!>
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'R':  V contains right eigenvectors;
!>          = 'L':  V contains left eigenvectors.
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrix V.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>          The integers ILO and IHI determined by DGEBAL.
!>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!>
[in]SCALE
!>          SCALE is DOUBLE PRECISION array, dimension (N)
!>          Details of the permutation and scaling factors, as returned
!>          by DGEBAL.
!>
[in]M
!>          M is INTEGER
!>          The number of columns of the matrix V.  M >= 0.
!>
[in,out]V
!>          V is DOUBLE PRECISION array, dimension (LDV,M)
!>          On entry, the matrix of right or left eigenvectors to be
!>          transformed, as returned by DHSEIN or DTREVC.
!>          On exit, V is overwritten by the transformed eigenvectors.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= 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 128 of file dgebak.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 JOB, SIDE
137 INTEGER IHI, ILO, INFO, LDV, M, N
138* ..
139* .. Array Arguments ..
140 DOUBLE PRECISION SCALE( * ), V( LDV, * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 DOUBLE PRECISION ONE
147 parameter( one = 1.0d+0 )
148* ..
149* .. Local Scalars ..
150 LOGICAL LEFTV, RIGHTV
151 INTEGER I, II, K
152 DOUBLE PRECISION S
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 EXTERNAL lsame
157* ..
158* .. External Subroutines ..
159 EXTERNAL dscal, dswap, xerbla
160* ..
161* .. Intrinsic Functions ..
162 INTRINSIC max, min
163* ..
164* .. Executable Statements ..
165*
166* Decode and Test the input parameters
167*
168 rightv = lsame( side, 'R' )
169 leftv = lsame( side, 'L' )
170*
171 info = 0
172 IF( .NOT.lsame( job, 'N' ) .AND. .NOT.lsame( job, 'P' ) .AND.
173 $ .NOT.lsame( job, 'S' ) .AND. .NOT.lsame( job, 'B' ) ) THEN
174 info = -1
175 ELSE IF( .NOT.rightv .AND. .NOT.leftv ) THEN
176 info = -2
177 ELSE IF( n.LT.0 ) THEN
178 info = -3
179 ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
180 info = -4
181 ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
182 info = -5
183 ELSE IF( m.LT.0 ) THEN
184 info = -7
185 ELSE IF( ldv.LT.max( 1, n ) ) THEN
186 info = -9
187 END IF
188 IF( info.NE.0 ) THEN
189 CALL xerbla( 'DGEBAK', -info )
190 RETURN
191 END IF
192*
193* Quick return if possible
194*
195 IF( n.EQ.0 )
196 $ RETURN
197 IF( m.EQ.0 )
198 $ RETURN
199 IF( lsame( job, 'N' ) )
200 $ RETURN
201*
202 IF( ilo.EQ.ihi )
203 $ GO TO 30
204*
205* Backward balance
206*
207 IF( lsame( job, 'S' ) .OR. lsame( job, 'B' ) ) THEN
208*
209 IF( rightv ) THEN
210 DO 10 i = ilo, ihi
211 s = scale( i )
212 CALL dscal( m, s, v( i, 1 ), ldv )
213 10 CONTINUE
214 END IF
215*
216 IF( leftv ) THEN
217 DO 20 i = ilo, ihi
218 s = one / scale( i )
219 CALL dscal( m, s, v( i, 1 ), ldv )
220 20 CONTINUE
221 END IF
222*
223 END IF
224*
225* Backward permutation
226*
227* For I = ILO-1 step -1 until 1,
228* IHI+1 step 1 until N do --
229*
230 30 CONTINUE
231 IF( lsame( job, 'P' ) .OR. lsame( job, 'B' ) ) THEN
232 IF( rightv ) THEN
233 DO 40 ii = 1, n
234 i = ii
235 IF( i.GE.ilo .AND. i.LE.ihi )
236 $ GO TO 40
237 IF( i.LT.ilo )
238 $ i = ilo - ii
239 k = scale( i )
240 IF( k.EQ.i )
241 $ GO TO 40
242 CALL dswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv )
243 40 CONTINUE
244 END IF
245*
246 IF( leftv ) THEN
247 DO 50 ii = 1, n
248 i = ii
249 IF( i.GE.ilo .AND. i.LE.ihi )
250 $ GO TO 50
251 IF( i.LT.ilo )
252 $ i = ilo - ii
253 k = scale( i )
254 IF( k.EQ.i )
255 $ GO TO 50
256 CALL dswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv )
257 50 CONTINUE
258 END IF
259 END IF
260*
261 RETURN
262*
263* End of DGEBAK
264*
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

◆ dgebal()

subroutine dgebal ( character job,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer ilo,
integer ihi,
double precision, dimension( * ) scale,
integer info )

DGEBAL

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

Purpose:
!>
!> DGEBAL balances a general real matrix A.  This involves, first,
!> permuting A by a similarity transformation to isolate eigenvalues
!> in the first 1 to ILO-1 and last IHI+1 to N elements on the
!> diagonal; and second, applying a diagonal similarity transformation
!> to rows and columns ILO to IHI to make the rows and columns as
!> close in norm as possible.  Both steps are optional.
!>
!> Balancing may reduce the 1-norm of the matrix, and improve the
!> accuracy of the computed eigenvalues and/or eigenvectors.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          Specifies the operations to be performed on A:
!>          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0
!>                  for i = 1,...,N;
!>          = 'P':  permute only;
!>          = 'S':  scale only;
!>          = 'B':  both permute and scale.
!>
[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 input matrix A.
!>          On exit,  A is overwritten by the balanced matrix.
!>          If JOB = 'N', A is not referenced.
!>          See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]ILO
!>          ILO is INTEGER
!>
[out]IHI
!>          IHI is INTEGER
!>          ILO and IHI are set to integers such that on exit
!>          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
!>          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION array, dimension (N)
!>          Details of the permutations and scaling factors applied to
!>          A.  If P(j) is the index of the row and column interchanged
!>          with row and column j and D(j) is the scaling factor
!>          applied to row and column j, then
!>          SCALE(j) = P(j)    for j = 1,...,ILO-1
!>                   = D(j)    for j = ILO,...,IHI
!>                   = P(j)    for j = IHI+1,...,N.
!>          The order in which the interchanges are made is N to IHI+1,
!>          then 1 to ILO-1.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The permutations consist of row and column interchanges which put
!>  the matrix in the form
!>
!>             ( T1   X   Y  )
!>     P A P = (  0   B   Z  )
!>             (  0   0   T2 )
!>
!>  where T1 and T2 are upper triangular matrices whose eigenvalues lie
!>  along the diagonal.  The column indices ILO and IHI mark the starting
!>  and ending columns of the submatrix B. Balancing consists of applying
!>  a diagonal similarity transformation inv(D) * B * D to make the
!>  1-norms of each row of B and its corresponding column nearly equal.
!>  The output matrix is
!>
!>     ( T1     X*D          Y    )
!>     (  0  inv(D)*B*D  inv(D)*Z ).
!>     (  0      0           T2   )
!>
!>  Information about the permutations P and the diagonal matrix D is
!>  returned in the vector SCALE.
!>
!>  This subroutine is based on the EISPACK routine BALANC.
!>
!>  Modified by Tzu-Yi Chen, Computer Science Division, University of
!>    California at Berkeley, USA
!>

Definition at line 159 of file dgebal.f.

160*
161* -- LAPACK computational routine --
162* -- LAPACK is a software package provided by Univ. of Tennessee, --
163* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
164*
165* .. Scalar Arguments ..
166 CHARACTER JOB
167 INTEGER IHI, ILO, INFO, LDA, N
168* ..
169* .. Array Arguments ..
170 DOUBLE PRECISION A( LDA, * ), SCALE( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 DOUBLE PRECISION ZERO, ONE
177 parameter( zero = 0.0d+0, one = 1.0d+0 )
178 DOUBLE PRECISION SCLFAC
179 parameter( sclfac = 2.0d+0 )
180 DOUBLE PRECISION FACTOR
181 parameter( factor = 0.95d+0 )
182* ..
183* .. Local Scalars ..
184 LOGICAL NOCONV
185 INTEGER I, ICA, IEXC, IRA, J, K, L, M
186 DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
187 $ SFMIN2
188* ..
189* .. External Functions ..
190 LOGICAL DISNAN, LSAME
191 INTEGER IDAMAX
192 DOUBLE PRECISION DLAMCH, DNRM2
193 EXTERNAL disnan, lsame, idamax, dlamch, dnrm2
194* ..
195* .. External Subroutines ..
196 EXTERNAL dscal, dswap, xerbla
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, max, min
200* ..
201* Test the input parameters
202*
203 info = 0
204 IF( .NOT.lsame( job, 'N' ) .AND. .NOT.lsame( job, 'P' ) .AND.
205 $ .NOT.lsame( job, 'S' ) .AND. .NOT.lsame( job, 'B' ) ) THEN
206 info = -1
207 ELSE IF( n.LT.0 ) THEN
208 info = -2
209 ELSE IF( lda.LT.max( 1, n ) ) THEN
210 info = -4
211 END IF
212 IF( info.NE.0 ) THEN
213 CALL xerbla( 'DGEBAL', -info )
214 RETURN
215 END IF
216*
217 k = 1
218 l = n
219*
220 IF( n.EQ.0 )
221 $ GO TO 210
222*
223 IF( lsame( job, 'N' ) ) THEN
224 DO 10 i = 1, n
225 scale( i ) = one
226 10 CONTINUE
227 GO TO 210
228 END IF
229*
230 IF( lsame( job, 'S' ) )
231 $ GO TO 120
232*
233* Permutation to isolate eigenvalues if possible
234*
235 GO TO 50
236*
237* Row and column exchange.
238*
239 20 CONTINUE
240 scale( m ) = j
241 IF( j.EQ.m )
242 $ GO TO 30
243*
244 CALL dswap( l, a( 1, j ), 1, a( 1, m ), 1 )
245 CALL dswap( n-k+1, a( j, k ), lda, a( m, k ), lda )
246*
247 30 CONTINUE
248 GO TO ( 40, 80 )iexc
249*
250* Search for rows isolating an eigenvalue and push them down.
251*
252 40 CONTINUE
253 IF( l.EQ.1 )
254 $ GO TO 210
255 l = l - 1
256*
257 50 CONTINUE
258 DO 70 j = l, 1, -1
259*
260 DO 60 i = 1, l
261 IF( i.EQ.j )
262 $ GO TO 60
263 IF( a( j, i ).NE.zero )
264 $ GO TO 70
265 60 CONTINUE
266*
267 m = l
268 iexc = 1
269 GO TO 20
270 70 CONTINUE
271*
272 GO TO 90
273*
274* Search for columns isolating an eigenvalue and push them left.
275*
276 80 CONTINUE
277 k = k + 1
278*
279 90 CONTINUE
280 DO 110 j = k, l
281*
282 DO 100 i = k, l
283 IF( i.EQ.j )
284 $ GO TO 100
285 IF( a( i, j ).NE.zero )
286 $ GO TO 110
287 100 CONTINUE
288*
289 m = k
290 iexc = 2
291 GO TO 20
292 110 CONTINUE
293*
294 120 CONTINUE
295 DO 130 i = k, l
296 scale( i ) = one
297 130 CONTINUE
298*
299 IF( lsame( job, 'P' ) )
300 $ GO TO 210
301*
302* Balance the submatrix in rows K to L.
303*
304* Iterative loop for norm reduction
305*
306 sfmin1 = dlamch( 'S' ) / dlamch( 'P' )
307 sfmax1 = one / sfmin1
308 sfmin2 = sfmin1*sclfac
309 sfmax2 = one / sfmin2
310*
311 140 CONTINUE
312 noconv = .false.
313*
314 DO 200 i = k, l
315*
316 c = dnrm2( l-k+1, a( k, i ), 1 )
317 r = dnrm2( l-k+1, a( i, k ), lda )
318 ica = idamax( l, a( 1, i ), 1 )
319 ca = abs( a( ica, i ) )
320 ira = idamax( n-k+1, a( i, k ), lda )
321 ra = abs( a( i, ira+k-1 ) )
322*
323* Guard against zero C or R due to underflow.
324*
325 IF( c.EQ.zero .OR. r.EQ.zero )
326 $ GO TO 200
327 g = r / sclfac
328 f = one
329 s = c + r
330 160 CONTINUE
331 IF( c.GE.g .OR. max( f, c, ca ).GE.sfmax2 .OR.
332 $ min( r, g, ra ).LE.sfmin2 )GO TO 170
333 IF( disnan( c+f+ca+r+g+ra ) ) THEN
334*
335* Exit if NaN to avoid infinite loop
336*
337 info = -3
338 CALL xerbla( 'DGEBAL', -info )
339 RETURN
340 END IF
341 f = f*sclfac
342 c = c*sclfac
343 ca = ca*sclfac
344 r = r / sclfac
345 g = g / sclfac
346 ra = ra / sclfac
347 GO TO 160
348*
349 170 CONTINUE
350 g = c / sclfac
351 180 CONTINUE
352 IF( g.LT.r .OR. max( r, ra ).GE.sfmax2 .OR.
353 $ min( f, c, g, ca ).LE.sfmin2 )GO TO 190
354 f = f / sclfac
355 c = c / sclfac
356 g = g / sclfac
357 ca = ca / sclfac
358 r = r*sclfac
359 ra = ra*sclfac
360 GO TO 180
361*
362* Now balance.
363*
364 190 CONTINUE
365 IF( ( c+r ).GE.factor*s )
366 $ GO TO 200
367 IF( f.LT.one .AND. scale( i ).LT.one ) THEN
368 IF( f*scale( i ).LE.sfmin1 )
369 $ GO TO 200
370 END IF
371 IF( f.GT.one .AND. scale( i ).GT.one ) THEN
372 IF( scale( i ).GE.sfmax1 / f )
373 $ GO TO 200
374 END IF
375 g = one / f
376 scale( i ) = scale( i )*f
377 noconv = .true.
378*
379 CALL dscal( n-k+1, g, a( i, k ), lda )
380 CALL dscal( l, f, a( 1, i ), 1 )
381*
382 200 CONTINUE
383*
384 IF( noconv )
385 $ GO TO 140
386*
387 210 CONTINUE
388 ilo = k
389 ihi = l
390*
391 RETURN
392*
393* End of DGEBAL
394*
disnan
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:59
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71
dnrm2
real(wp) function dnrm2(n, x, incx)
DNRM2
Definition dnrm2.f90:89
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69

◆ dgebd2()

subroutine dgebd2 ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision, dimension( * ) tauq,
double precision, dimension( * ) taup,
double precision, dimension( * ) work,
integer info )

DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.

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

Purpose:
!>
!> DGEBD2 reduces a real general m by n matrix A to upper or lower
!> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
!>
!> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows in the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns in the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the m by n general matrix to be reduced.
!>          On exit,
!>          if m >= n, the diagonal and the first superdiagonal are
!>            overwritten with the upper bidiagonal matrix B; the
!>            elements below the diagonal, with the array TAUQ, represent
!>            the orthogonal matrix Q as a product of elementary
!>            reflectors, and the elements above the first superdiagonal,
!>            with the array TAUP, represent the orthogonal matrix P as
!>            a product of elementary reflectors;
!>          if m < n, the diagonal and the first subdiagonal are
!>            overwritten with the lower bidiagonal matrix B; the
!>            elements below the first subdiagonal, with the array TAUQ,
!>            represent the orthogonal matrix Q as a product of
!>            elementary reflectors, and the elements above the diagonal,
!>            with the array TAUP, represent the orthogonal matrix P as
!>            a product of elementary reflectors.
!>          See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (min(M,N)-1)
!>          The off-diagonal elements of the bidiagonal matrix B:
!>          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
!>          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
!>
[out]TAUQ
!>          TAUQ is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix Q. See Further Details.
!>
[out]TAUP
!>          TAUP is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix P. See Further Details.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (max(M,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 matrices Q and P are represented as products of elementary
!>  reflectors:
!>
!>  If m >= n,
!>
!>     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
!>
!>  Each H(i) and G(i) has the form:
!>
!>     H(i) = I - tauq * v * v**T  and G(i) = I - taup * u * u**T
!>
!>  where tauq and taup are real scalars, and v and u are real vectors;
!>  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
!>  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
!>  tauq is stored in TAUQ(i) and taup in TAUP(i).
!>
!>  If m < n,
!>
!>     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
!>
!>  Each H(i) and G(i) has the form:
!>
!>     H(i) = I - tauq * v * v**T  and G(i) = I - taup * u * u**T
!>
!>  where tauq and taup are real scalars, and v and u are real vectors;
!>  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
!>  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
!>  tauq is stored in TAUQ(i) and taup in TAUP(i).
!>
!>  The contents of A on exit are illustrated by the following examples:
!>
!>  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
!>
!>    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
!>    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
!>    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
!>    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
!>    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
!>    (  v1  v2  v3  v4  v5 )
!>
!>  where d and e denote diagonal and off-diagonal elements of B, vi
!>  denotes an element of the vector defining H(i), and ui an element of
!>  the vector defining G(i).
!>

Definition at line 188 of file dgebd2.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, M, N
196* ..
197* .. Array Arguments ..
198 DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
199 $ TAUQ( * ), WORK( * )
200* ..
201*
202* =====================================================================
203*
204* .. Parameters ..
205 DOUBLE PRECISION ZERO, ONE
206 parameter( zero = 0.0d+0, one = 1.0d+0 )
207* ..
208* .. Local Scalars ..
209 INTEGER I
210* ..
211* .. External Subroutines ..
212 EXTERNAL dlarf, dlarfg, xerbla
213* ..
214* .. Intrinsic Functions ..
215 INTRINSIC max, min
216* ..
217* .. Executable Statements ..
218*
219* Test the input parameters
220*
221 info = 0
222 IF( m.LT.0 ) THEN
223 info = -1
224 ELSE IF( n.LT.0 ) THEN
225 info = -2
226 ELSE IF( lda.LT.max( 1, m ) ) THEN
227 info = -4
228 END IF
229 IF( info.LT.0 ) THEN
230 CALL xerbla( 'DGEBD2', -info )
231 RETURN
232 END IF
233*
234 IF( m.GE.n ) THEN
235*
236* Reduce to upper bidiagonal form
237*
238 DO 10 i = 1, n
239*
240* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
241*
242 CALL dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,
243 $ tauq( i ) )
244 d( i ) = a( i, i )
245 a( i, i ) = one
246*
247* Apply H(i) to A(i:m,i+1:n) from the left
248*
249 IF( i.LT.n )
250 $ CALL dlarf( 'Left', m-i+1, n-i, a( i, i ), 1, tauq( i ),
251 $ a( i, i+1 ), lda, work )
252 a( i, i ) = d( i )
253*
254 IF( i.LT.n ) THEN
255*
256* Generate elementary reflector G(i) to annihilate
257* A(i,i+2:n)
258*
259 CALL dlarfg( n-i, a( i, i+1 ), a( i, min( i+2, n ) ),
260 $ lda, taup( i ) )
261 e( i ) = a( i, i+1 )
262 a( i, i+1 ) = one
263*
264* Apply G(i) to A(i+1:m,i+1:n) from the right
265*
266 CALL dlarf( 'Right', m-i, n-i, a( i, i+1 ), lda,
267 $ taup( i ), a( i+1, i+1 ), lda, work )
268 a( i, i+1 ) = e( i )
269 ELSE
270 taup( i ) = zero
271 END IF
272 10 CONTINUE
273 ELSE
274*
275* Reduce to lower bidiagonal form
276*
277 DO 20 i = 1, m
278*
279* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
280*
281 CALL dlarfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,
282 $ taup( i ) )
283 d( i ) = a( i, i )
284 a( i, i ) = one
285*
286* Apply G(i) to A(i+1:m,i:n) from the right
287*
288 IF( i.LT.m )
289 $ CALL dlarf( 'Right', m-i, n-i+1, a( i, i ), lda,
290 $ taup( i ), a( i+1, i ), lda, work )
291 a( i, i ) = d( i )
292*
293 IF( i.LT.m ) THEN
294*
295* Generate elementary reflector H(i) to annihilate
296* A(i+2:m,i)
297*
298 CALL dlarfg( m-i, a( i+1, i ), a( min( i+2, m ), i ), 1,
299 $ tauq( i ) )
300 e( i ) = a( i+1, i )
301 a( i+1, i ) = one
302*
303* Apply H(i) to A(i+1:m,i+1:n) from the left
304*
305 CALL dlarf( 'Left', m-i, n-i, a( i+1, i ), 1, tauq( i ),
306 $ a( i+1, i+1 ), lda, work )
307 a( i+1, i ) = e( i )
308 ELSE
309 tauq( i ) = zero
310 END IF
311 20 CONTINUE
312 END IF
313 RETURN
314*
315* End of DGEBD2
316*
dlarfg
subroutine dlarfg(n, alpha, x, incx, tau)
DLARFG generates an elementary reflector (Householder matrix).
Definition dlarfg.f:106
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

◆ dgebrd()

subroutine dgebrd ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision, dimension( * ) tauq,
double precision, dimension( * ) taup,
double precision, dimension( * ) work,
integer lwork,
integer info )

DGEBRD

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

Purpose:
!>
!> DGEBRD reduces a general real M-by-N matrix A to upper or lower
!> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
!>
!> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows in the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns in the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N general matrix to be reduced.
!>          On exit,
!>          if m >= n, the diagonal and the first superdiagonal are
!>            overwritten with the upper bidiagonal matrix B; the
!>            elements below the diagonal, with the array TAUQ, represent
!>            the orthogonal matrix Q as a product of elementary
!>            reflectors, and the elements above the first superdiagonal,
!>            with the array TAUP, represent the orthogonal matrix P as
!>            a product of elementary reflectors;
!>          if m < n, the diagonal and the first subdiagonal are
!>            overwritten with the lower bidiagonal matrix B; the
!>            elements below the first subdiagonal, with the array TAUQ,
!>            represent the orthogonal matrix Q as a product of
!>            elementary reflectors, and the elements above the diagonal,
!>            with the array TAUP, represent the orthogonal matrix P as
!>            a product of elementary reflectors.
!>          See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (min(M,N)-1)
!>          The off-diagonal elements of the bidiagonal matrix B:
!>          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
!>          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
!>
[out]TAUQ
!>          TAUQ is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix Q. See Further Details.
!>
[out]TAUP
!>          TAUP is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix P. 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 length of the array WORK.  LWORK >= max(1,M,N).
!>          For optimum performance LWORK >= (M+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 matrices Q and P are represented as products of elementary
!>  reflectors:
!>
!>  If m >= n,
!>
!>     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
!>
!>  Each H(i) and G(i) has the form:
!>
!>     H(i) = I - tauq * v * v**T  and G(i) = I - taup * u * u**T
!>
!>  where tauq and taup are real scalars, and v and u are real vectors;
!>  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
!>  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
!>  tauq is stored in TAUQ(i) and taup in TAUP(i).
!>
!>  If m < n,
!>
!>     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
!>
!>  Each H(i) and G(i) has the form:
!>
!>     H(i) = I - tauq * v * v**T  and G(i) = I - taup * u * u**T
!>
!>  where tauq and taup are real scalars, and v and u are real vectors;
!>  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
!>  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
!>  tauq is stored in TAUQ(i) and taup in TAUP(i).
!>
!>  The contents of A on exit are illustrated by the following examples:
!>
!>  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
!>
!>    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
!>    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
!>    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
!>    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
!>    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
!>    (  v1  v2  v3  v4  v5 )
!>
!>  where d and e denote diagonal and off-diagonal elements of B, vi
!>  denotes an element of the vector defining H(i), and ui an element of
!>  the vector defining G(i).
!>

Definition at line 203 of file dgebrd.f.

205*
206* -- LAPACK computational routine --
207* -- LAPACK is a software package provided by Univ. of Tennessee, --
208* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
209*
210* .. Scalar Arguments ..
211 INTEGER INFO, LDA, LWORK, M, N
212* ..
213* .. Array Arguments ..
214 DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
215 $ TAUQ( * ), WORK( * )
216* ..
217*
218* =====================================================================
219*
220* .. Parameters ..
221 DOUBLE PRECISION ONE
222 parameter( one = 1.0d+0 )
223* ..
224* .. Local Scalars ..
225 LOGICAL LQUERY
226 INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
227 $ NBMIN, NX, WS
228* ..
229* .. External Subroutines ..
230 EXTERNAL dgebd2, dgemm, dlabrd, xerbla
231* ..
232* .. Intrinsic Functions ..
233 INTRINSIC dble, max, min
234* ..
235* .. External Functions ..
236 INTEGER ILAENV
237 EXTERNAL ilaenv
238* ..
239* .. Executable Statements ..
240*
241* Test the input parameters
242*
243 info = 0
244 nb = max( 1, ilaenv( 1, 'DGEBRD', ' ', m, n, -1, -1 ) )
245 lwkopt = ( m+n )*nb
246 work( 1 ) = dble( lwkopt )
247 lquery = ( lwork.EQ.-1 )
248 IF( m.LT.0 ) THEN
249 info = -1
250 ELSE IF( n.LT.0 ) THEN
251 info = -2
252 ELSE IF( lda.LT.max( 1, m ) ) THEN
253 info = -4
254 ELSE IF( lwork.LT.max( 1, m, n ) .AND. .NOT.lquery ) THEN
255 info = -10
256 END IF
257 IF( info.LT.0 ) THEN
258 CALL xerbla( 'DGEBRD', -info )
259 RETURN
260 ELSE IF( lquery ) THEN
261 RETURN
262 END IF
263*
264* Quick return if possible
265*
266 minmn = min( m, n )
267 IF( minmn.EQ.0 ) THEN
268 work( 1 ) = 1
269 RETURN
270 END IF
271*
272 ws = max( m, n )
273 ldwrkx = m
274 ldwrky = n
275*
276 IF( nb.GT.1 .AND. nb.LT.minmn ) THEN
277*
278* Set the crossover point NX.
279*
280 nx = max( nb, ilaenv( 3, 'DGEBRD', ' ', m, n, -1, -1 ) )
281*
282* Determine when to switch from blocked to unblocked code.
283*
284 IF( nx.LT.minmn ) THEN
285 ws = ( m+n )*nb
286 IF( lwork.LT.ws ) THEN
287*
288* Not enough work space for the optimal NB, consider using
289* a smaller block size.
290*
291 nbmin = ilaenv( 2, 'DGEBRD', ' ', m, n, -1, -1 )
292 IF( lwork.GE.( m+n )*nbmin ) THEN
293 nb = lwork / ( m+n )
294 ELSE
295 nb = 1
296 nx = minmn
297 END IF
298 END IF
299 END IF
300 ELSE
301 nx = minmn
302 END IF
303*
304 DO 30 i = 1, minmn - nx, nb
305*
306* Reduce rows and columns i:i+nb-1 to bidiagonal form and return
307* the matrices X and Y which are needed to update the unreduced
308* part of the matrix
309*
310 CALL dlabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),
311 $ tauq( i ), taup( i ), work, ldwrkx,
312 $ work( ldwrkx*nb+1 ), ldwrky )
313*
314* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update
315* of the form A := A - V*Y**T - X*U**T
316*
317 CALL dgemm( 'No transpose', 'Transpose', m-i-nb+1, n-i-nb+1,
318 $ nb, -one, a( i+nb, i ), lda,
319 $ work( ldwrkx*nb+nb+1 ), ldwrky, one,
320 $ a( i+nb, i+nb ), lda )
321 CALL dgemm( 'No transpose', 'No transpose', m-i-nb+1, n-i-nb+1,
322 $ nb, -one, work( nb+1 ), ldwrkx, a( i, i+nb ), lda,
323 $ one, a( i+nb, i+nb ), lda )
324*
325* Copy diagonal and off-diagonal elements of B back into A
326*
327 IF( m.GE.n ) THEN
328 DO 10 j = i, i + nb - 1
329 a( j, j ) = d( j )
330 a( j, j+1 ) = e( j )
331 10 CONTINUE
332 ELSE
333 DO 20 j = i, i + nb - 1
334 a( j, j ) = d( j )
335 a( j+1, j ) = e( j )
336 20 CONTINUE
337 END IF
338 30 CONTINUE
339*
340* Use unblocked code to reduce the remainder of the matrix
341*
342 CALL dgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),
343 $ tauq( i ), taup( i ), work, iinfo )
344 work( 1 ) = ws
345 RETURN
346*
347* End of DGEBRD
348*
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
dgebd2
subroutine dgebd2(m, n, a, lda, d, e, tauq, taup, work, info)
DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
Definition dgebd2.f:189
dlabrd
subroutine dlabrd(m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y, ldy)
DLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
Definition dlabrd.f:210
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187

◆ dgecon()

subroutine dgecon ( character norm,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision anorm,
double precision rcond,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DGECON

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

Purpose:
!>
!> DGECON estimates the reciprocal of the condition number of a general
!> real matrix A, in either the 1-norm or the infinity-norm, using
!> the LU factorization computed by DGETRF.
!>
!> An estimate is obtained for norm(inv(A)), and 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]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The factors L and U from the factorization A = P*L*U
!>          as computed by DGETRF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]ANORM
!>          ANORM is DOUBLE PRECISION
!>          If NORM = '1' or 'O', the 1-norm of the original matrix A.
!>          If NORM = 'I', the infinity-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/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (4*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 122 of file dgecon.f.

124*
125* -- LAPACK computational routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 CHARACTER NORM
131 INTEGER INFO, LDA, N
132 DOUBLE PRECISION ANORM, RCOND
133* ..
134* .. Array Arguments ..
135 INTEGER IWORK( * )
136 DOUBLE PRECISION A( LDA, * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 DOUBLE PRECISION ONE, ZERO
143 parameter( one = 1.0d+0, zero = 0.0d+0 )
144* ..
145* .. Local Scalars ..
146 LOGICAL ONENRM
147 CHARACTER NORMIN
148 INTEGER IX, KASE, KASE1
149 DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU
150* ..
151* .. Local Arrays ..
152 INTEGER ISAVE( 3 )
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 INTEGER IDAMAX
157 DOUBLE PRECISION DLAMCH
158 EXTERNAL lsame, idamax, dlamch
159* ..
160* .. External Subroutines ..
161 EXTERNAL dlacn2, dlatrs, drscl, xerbla
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC abs, max
165* ..
166* .. Executable Statements ..
167*
168* Test the input parameters.
169*
170 info = 0
171 onenrm = norm.EQ.'1' .OR. lsame( norm, 'O' )
172 IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN
173 info = -1
174 ELSE IF( n.LT.0 ) THEN
175 info = -2
176 ELSE IF( lda.LT.max( 1, n ) ) THEN
177 info = -4
178 ELSE IF( anorm.LT.zero ) THEN
179 info = -5
180 END IF
181 IF( info.NE.0 ) THEN
182 CALL xerbla( 'DGECON', -info )
183 RETURN
184 END IF
185*
186* Quick return if possible
187*
188 rcond = zero
189 IF( n.EQ.0 ) THEN
190 rcond = one
191 RETURN
192 ELSE IF( anorm.EQ.zero ) THEN
193 RETURN
194 END IF
195*
196 smlnum = dlamch( 'Safe minimum' )
197*
198* Estimate the norm of inv(A).
199*
200 ainvnm = zero
201 normin = 'N'
202 IF( onenrm ) THEN
203 kase1 = 1
204 ELSE
205 kase1 = 2
206 END IF
207 kase = 0
208 10 CONTINUE
209 CALL dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
210 IF( kase.NE.0 ) THEN
211 IF( kase.EQ.kase1 ) THEN
212*
213* Multiply by inv(L).
214*
215 CALL dlatrs( 'Lower', 'No transpose', 'Unit', normin, n, a,
216 $ lda, work, sl, work( 2*n+1 ), info )
217*
218* Multiply by inv(U).
219*
220 CALL dlatrs( 'Upper', 'No transpose', 'Non-unit', normin, n,
221 $ a, lda, work, su, work( 3*n+1 ), info )
222 ELSE
223*
224* Multiply by inv(U**T).
225*
226 CALL dlatrs( 'Upper', 'Transpose', 'Non-unit', normin, n, a,
227 $ lda, work, su, work( 3*n+1 ), info )
228*
229* Multiply by inv(L**T).
230*
231 CALL dlatrs( 'Lower', 'Transpose', 'Unit', normin, n, a,
232 $ lda, work, sl, work( 2*n+1 ), info )
233 END IF
234*
235* Divide X by 1/(SL*SU) if doing so will not cause overflow.
236*
237 scale = sl*su
238 normin = 'Y'
239 IF( scale.NE.one ) THEN
240 ix = idamax( n, work, 1 )
241 IF( scale.LT.abs( work( ix ) )*smlnum .OR. scale.EQ.zero )
242 $ GO TO 20
243 CALL drscl( n, scale, work, 1 )
244 END IF
245 GO TO 10
246 END IF
247*
248* Compute the estimate of the reciprocal condition number.
249*
250 IF( ainvnm.NE.zero )
251 $ rcond = ( one / ainvnm ) / anorm
252*
253 20 CONTINUE
254 RETURN
255*
256* End of DGECON
257*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
drscl
subroutine drscl(n, sa, sx, incx)
DRSCL multiplies a vector by the reciprocal of a real scalar.
Definition drscl.f:84
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
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

◆ dgeequ()

subroutine dgeequ ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) r,
double precision, dimension( * ) c,
double precision rowcnd,
double precision colcnd,
double precision amax,
integer info )

DGEEQU

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

Purpose:
!>
!> DGEEQU computes row and column scalings intended to equilibrate an
!> M-by-N matrix A and reduce its condition number.  R returns the row
!> scale factors and C the column scale factors, chosen to try to make
!> the largest element in each row and column of the matrix B with
!> elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!>
!> R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!> number and BIGNUM = largest safe number.  Use of these scaling
!> factors is not guaranteed to reduce the condition number of A but
!> works well in practice.
!>
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]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The M-by-N matrix whose equilibration factors are
!>          to be computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]R
!>          R is DOUBLE PRECISION array, dimension (M)
!>          If INFO = 0 or INFO > M, R contains the row scale factors
!>          for A.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (N)
!>          If INFO = 0,  C contains the column scale factors for A.
!>
[out]ROWCND
!>          ROWCND is DOUBLE PRECISION
!>          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
!>          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
!>          AMAX is neither too large nor too small, it is not worth
!>          scaling by R.
!>
[out]COLCND
!>          COLCND is DOUBLE PRECISION
!>          If INFO = 0, COLCND contains the ratio of the smallest
!>          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
!>          worth scaling by C.
!>
[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,  and i is
!>                <= M:  the i-th row of A is exactly zero
!>                >  M:  the (i-M)-th column of A is exactly zero
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 137 of file dgeequ.f.

139*
140* -- LAPACK computational routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144* .. Scalar Arguments ..
145 INTEGER INFO, LDA, M, N
146 DOUBLE PRECISION AMAX, COLCND, ROWCND
147* ..
148* .. Array Arguments ..
149 DOUBLE PRECISION A( LDA, * ), C( * ), R( * )
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 INTEGER I, J
160 DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM
161* ..
162* .. External Functions ..
163 DOUBLE PRECISION DLAMCH
164 EXTERNAL dlamch
165* ..
166* .. External Subroutines ..
167 EXTERNAL xerbla
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, max, min
171* ..
172* .. Executable Statements ..
173*
174* Test the input parameters.
175*
176 info = 0
177 IF( m.LT.0 ) THEN
178 info = -1
179 ELSE IF( n.LT.0 ) THEN
180 info = -2
181 ELSE IF( lda.LT.max( 1, m ) ) THEN
182 info = -4
183 END IF
184 IF( info.NE.0 ) THEN
185 CALL xerbla( 'DGEEQU', -info )
186 RETURN
187 END IF
188*
189* Quick return if possible
190*
191 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
192 rowcnd = one
193 colcnd = one
194 amax = zero
195 RETURN
196 END IF
197*
198* Get machine constants.
199*
200 smlnum = dlamch( 'S' )
201 bignum = one / smlnum
202*
203* Compute row scale factors.
204*
205 DO 10 i = 1, m
206 r( i ) = zero
207 10 CONTINUE
208*
209* Find the maximum element in each row.
210*
211 DO 30 j = 1, n
212 DO 20 i = 1, m
213 r( i ) = max( r( i ), abs( a( i, j ) ) )
214 20 CONTINUE
215 30 CONTINUE
216*
217* Find the maximum and minimum scale factors.
218*
219 rcmin = bignum
220 rcmax = zero
221 DO 40 i = 1, m
222 rcmax = max( rcmax, r( i ) )
223 rcmin = min( rcmin, r( i ) )
224 40 CONTINUE
225 amax = rcmax
226*
227 IF( rcmin.EQ.zero ) THEN
228*
229* Find the first zero scale factor and return an error code.
230*
231 DO 50 i = 1, m
232 IF( r( i ).EQ.zero ) THEN
233 info = i
234 RETURN
235 END IF
236 50 CONTINUE
237 ELSE
238*
239* Invert the scale factors.
240*
241 DO 60 i = 1, m
242 r( i ) = one / min( max( r( i ), smlnum ), bignum )
243 60 CONTINUE
244*
245* Compute ROWCND = min(R(I)) / max(R(I))
246*
247 rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
248 END IF
249*
250* Compute column scale factors
251*
252 DO 70 j = 1, n
253 c( j ) = zero
254 70 CONTINUE
255*
256* Find the maximum element in each column,
257* assuming the row scaling computed above.
258*
259 DO 90 j = 1, n
260 DO 80 i = 1, m
261 c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) )
262 80 CONTINUE
263 90 CONTINUE
264*
265* Find the maximum and minimum scale factors.
266*
267 rcmin = bignum
268 rcmax = zero
269 DO 100 j = 1, n
270 rcmin = min( rcmin, c( j ) )
271 rcmax = max( rcmax, c( j ) )
272 100 CONTINUE
273*
274 IF( rcmin.EQ.zero ) THEN
275*
276* Find the first zero scale factor and return an error code.
277*
278 DO 110 j = 1, n
279 IF( c( j ).EQ.zero ) THEN
280 info = m + j
281 RETURN
282 END IF
283 110 CONTINUE
284 ELSE
285*
286* Invert the scale factors.
287*
288 DO 120 j = 1, n
289 c( j ) = one / min( max( c( j ), smlnum ), bignum )
290 120 CONTINUE
291*
292* Compute COLCND = min(C(J)) / max(C(J))
293*
294 colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
295 END IF
296*
297 RETURN
298*
299* End of DGEEQU
300*

◆ dgeequb()

subroutine dgeequb ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) r,
double precision, dimension( * ) c,
double precision rowcnd,
double precision colcnd,
double precision amax,
integer info )

DGEEQUB

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

Purpose:
!>
!> DGEEQUB computes row and column scalings intended to equilibrate an
!> M-by-N matrix A and reduce its condition number.  R returns the row
!> scale factors and C the column scale factors, chosen to try to make
!> the largest element in each row and column of the matrix B with
!> elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
!> the radix.
!>
!> R(i) and C(j) are restricted to be a power of the radix between
!> SMLNUM = smallest safe number and BIGNUM = largest safe number.  Use
!> of these scaling factors is not guaranteed to reduce the condition
!> number of A but works well in practice.
!>
!> This routine differs from DGEEQU by restricting the scaling factors
!> to a power of the radix.  Barring over- and underflow, scaling by
!> these factors introduces no additional rounding errors.  However, the
!> scaled entries' magnitudes are no longer approximately 1 but lie
!> between sqrt(radix) and 1/sqrt(radix).
!>
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]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The M-by-N matrix whose equilibration factors are
!>          to be computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]R
!>          R is DOUBLE PRECISION array, dimension (M)
!>          If INFO = 0 or INFO > M, R contains the row scale factors
!>          for A.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (N)
!>          If INFO = 0,  C contains the column scale factors for A.
!>
[out]ROWCND
!>          ROWCND is DOUBLE PRECISION
!>          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
!>          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
!>          AMAX is neither too large nor too small, it is not worth
!>          scaling by R.
!>
[out]COLCND
!>          COLCND is DOUBLE PRECISION
!>          If INFO = 0, COLCND contains the ratio of the smallest
!>          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
!>          worth scaling by C.
!>
[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,  and i is
!>                <= M:  the i-th row of A is exactly zero
!>                >  M:  the (i-M)-th column of A is exactly zero
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 144 of file dgeequb.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 INTEGER INFO, LDA, M, N
153 DOUBLE PRECISION AMAX, COLCND, ROWCND
154* ..
155* .. Array Arguments ..
156 DOUBLE PRECISION A( LDA, * ), C( * ), R( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 DOUBLE PRECISION ONE, ZERO
163 parameter( one = 1.0d+0, zero = 0.0d+0 )
164* ..
165* .. Local Scalars ..
166 INTEGER I, J
167 DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX
168* ..
169* .. External Functions ..
170 DOUBLE PRECISION DLAMCH
171 EXTERNAL dlamch
172* ..
173* .. External Subroutines ..
174 EXTERNAL xerbla
175* ..
176* .. Intrinsic Functions ..
177 INTRINSIC abs, max, min, log
178* ..
179* .. Executable Statements ..
180*
181* Test the input parameters.
182*
183 info = 0
184 IF( m.LT.0 ) THEN
185 info = -1
186 ELSE IF( n.LT.0 ) THEN
187 info = -2
188 ELSE IF( lda.LT.max( 1, m ) ) THEN
189 info = -4
190 END IF
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'DGEEQUB', -info )
193 RETURN
194 END IF
195*
196* Quick return if possible.
197*
198 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
199 rowcnd = one
200 colcnd = one
201 amax = zero
202 RETURN
203 END IF
204*
205* Get machine constants. Assume SMLNUM is a power of the radix.
206*
207 smlnum = dlamch( 'S' )
208 bignum = one / smlnum
209 radix = dlamch( 'B' )
210 logrdx = log( radix )
211*
212* Compute row scale factors.
213*
214 DO 10 i = 1, m
215 r( i ) = zero
216 10 CONTINUE
217*
218* Find the maximum element in each row.
219*
220 DO 30 j = 1, n
221 DO 20 i = 1, m
222 r( i ) = max( r( i ), abs( a( i, j ) ) )
223 20 CONTINUE
224 30 CONTINUE
225 DO i = 1, m
226 IF( r( i ).GT.zero ) THEN
227 r( i ) = radix**int( log( r( i ) ) / logrdx )
228 END IF
229 END DO
230*
231* Find the maximum and minimum scale factors.
232*
233 rcmin = bignum
234 rcmax = zero
235 DO 40 i = 1, m
236 rcmax = max( rcmax, r( i ) )
237 rcmin = min( rcmin, r( i ) )
238 40 CONTINUE
239 amax = rcmax
240*
241 IF( rcmin.EQ.zero ) THEN
242*
243* Find the first zero scale factor and return an error code.
244*
245 DO 50 i = 1, m
246 IF( r( i ).EQ.zero ) THEN
247 info = i
248 RETURN
249 END IF
250 50 CONTINUE
251 ELSE
252*
253* Invert the scale factors.
254*
255 DO 60 i = 1, m
256 r( i ) = one / min( max( r( i ), smlnum ), bignum )
257 60 CONTINUE
258*
259* Compute ROWCND = min(R(I)) / max(R(I)).
260*
261 rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
262 END IF
263*
264* Compute column scale factors
265*
266 DO 70 j = 1, n
267 c( j ) = zero
268 70 CONTINUE
269*
270* Find the maximum element in each column,
271* assuming the row scaling computed above.
272*
273 DO 90 j = 1, n
274 DO 80 i = 1, m
275 c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) )
276 80 CONTINUE
277 IF( c( j ).GT.zero ) THEN
278 c( j ) = radix**int( log( c( j ) ) / logrdx )
279 END IF
280 90 CONTINUE
281*
282* Find the maximum and minimum scale factors.
283*
284 rcmin = bignum
285 rcmax = zero
286 DO 100 j = 1, n
287 rcmin = min( rcmin, c( j ) )
288 rcmax = max( rcmax, c( j ) )
289 100 CONTINUE
290*
291 IF( rcmin.EQ.zero ) THEN
292*
293* Find the first zero scale factor and return an error code.
294*
295 DO 110 j = 1, n
296 IF( c( j ).EQ.zero ) THEN
297 info = m + j
298 RETURN
299 END IF
300 110 CONTINUE
301 ELSE
302*
303* Invert the scale factors.
304*
305 DO 120 j = 1, n
306 c( j ) = one / min( max( c( j ), smlnum ), bignum )
307 120 CONTINUE
308*
309* Compute COLCND = min(C(J)) / max(C(J)).
310*
311 colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
312 END IF
313*
314 RETURN
315*
316* End of DGEEQUB
317*

◆ dgehd2()

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

DGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.

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

Purpose:
!>
!> DGEHD2 reduces a real general matrix A to upper Hessenberg form H by
!> an orthogonal similarity transformation:  Q**T * A * Q = H .
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
!>          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 DGEBAL; otherwise they should be
!>          set to 1 and N respectively. See Further Details.
!>          1 <= ILO <= IHI <= max(1,N).
!>
[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
!>          elements below the first subdiagonal, with the array TAU,
!>          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,N).
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[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:
!>
!>  The matrix Q is represented as a product of (ihi-ilo) elementary
!>  reflectors
!>
!>     Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
!>  exit in A(i+2:ihi,i), and tau in TAU(i).
!>
!>  The contents of A are illustrated by the following example, with
!>  n = 7, ilo = 2 and ihi = 6:
!>
!>  on entry,                        on exit,
!>
!>  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
!>  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
!>  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
!>  (                         a )    (                          a )
!>
!>  where a denotes an element of the original matrix A, h denotes a
!>  modified element of the upper Hessenberg matrix H, and vi denotes an
!>  element of the vector defining H(i).
!>

Definition at line 148 of file dgehd2.f.

149*
150* -- LAPACK computational routine --
151* -- LAPACK is a software package provided by Univ. of Tennessee, --
152* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153*
154* .. Scalar Arguments ..
155 INTEGER IHI, ILO, INFO, LDA, N
156* ..
157* .. Array Arguments ..
158 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 DOUBLE PRECISION ONE
165 parameter( one = 1.0d+0 )
166* ..
167* .. Local Scalars ..
168 INTEGER I
169 DOUBLE PRECISION AII
170* ..
171* .. External Subroutines ..
172 EXTERNAL dlarf, dlarfg, xerbla
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC max, min
176* ..
177* .. Executable Statements ..
178*
179* Test the input parameters
180*
181 info = 0
182 IF( n.LT.0 ) THEN
183 info = -1
184 ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
185 info = -2
186 ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
187 info = -3
188 ELSE IF( lda.LT.max( 1, n ) ) THEN
189 info = -5
190 END IF
191 IF( info.NE.0 ) THEN
192 CALL xerbla( 'DGEHD2', -info )
193 RETURN
194 END IF
195*
196 DO 10 i = ilo, ihi - 1
197*
198* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
199*
200 CALL dlarfg( ihi-i, a( i+1, i ), a( min( i+2, n ), i ), 1,
201 $ tau( i ) )
202 aii = a( i+1, i )
203 a( i+1, i ) = one
204*
205* Apply H(i) to A(1:ihi,i+1:ihi) from the right
206*
207 CALL dlarf( 'Right', ihi, ihi-i, a( i+1, i ), 1, tau( i ),
208 $ a( 1, i+1 ), lda, work )
209*
210* Apply H(i) to A(i+1:ihi,i+1:n) from the left
211*
212 CALL dlarf( 'Left', ihi-i, n-i, a( i+1, i ), 1, tau( i ),
213 $ a( i+1, i+1 ), lda, work )
214*
215 a( i+1, i ) = aii
216 10 CONTINUE
217*
218 RETURN
219*
220* End of DGEHD2
221*

◆ dgehrd()

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

DGEHRD

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

Purpose:
!>
!> DGEHRD reduces a real general matrix A to upper Hessenberg form H by
!> an orthogonal similarity transformation:  Q**T * A * Q = H .
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
!>          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 DGEBAL; otherwise they should be
!>          set to 1 and N respectively. See Further Details.
!>          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
!>          elements below the first subdiagonal, with the array TAU,
!>          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,N).
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
!>          zero.
!>
[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 >= max(1,N).
!>          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.
Further Details:
!>
!>  The matrix Q is represented as a product of (ihi-ilo) elementary
!>  reflectors
!>
!>     Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
!>  exit in A(i+2:ihi,i), and tau in TAU(i).
!>
!>  The contents of A are illustrated by the following example, with
!>  n = 7, ilo = 2 and ihi = 6:
!>
!>  on entry,                        on exit,
!>
!>  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
!>  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
!>  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
!>  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
!>  (                         a )    (                          a )
!>
!>  where a denotes an element of the original matrix A, h denotes a
!>  modified element of the upper Hessenberg matrix H, and vi denotes an
!>  element of the vector defining H(i).
!>
!>  This file is a slight modification of LAPACK-3.0's DGEHRD
!>  subroutine incorporating improvements proposed by Quintana-Orti and
!>  Van de Geijn (2006). (See DLAHR2.)
!>

Definition at line 166 of file dgehrd.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 INTEGER IHI, ILO, INFO, LDA, LWORK, N
174* ..
175* .. Array Arguments ..
176 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
177* ..
178*
179* =====================================================================
180*
181* .. Parameters ..
182 INTEGER NBMAX, LDT, TSIZE
183 parameter( nbmax = 64, ldt = nbmax+1,
184 $ tsize = ldt*nbmax )
185 DOUBLE PRECISION ZERO, ONE
186 parameter( zero = 0.0d+0,
187 $ one = 1.0d+0 )
188* ..
189* .. Local Scalars ..
190 LOGICAL LQUERY
191 INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB,
192 $ NBMIN, NH, NX
193 DOUBLE PRECISION EI
194* ..
195* .. External Subroutines ..
196 EXTERNAL daxpy, dgehd2, dgemm, dlahr2, dlarfb, dtrmm,
197 $ xerbla
198* ..
199* .. Intrinsic Functions ..
200 INTRINSIC max, min
201* ..
202* .. External Functions ..
203 INTEGER ILAENV
204 EXTERNAL ilaenv
205* ..
206* .. Executable Statements ..
207*
208* Test the input parameters
209*
210 info = 0
211 lquery = ( lwork.EQ.-1 )
212 IF( n.LT.0 ) THEN
213 info = -1
214 ELSE IF( ilo.LT.1 .OR. ilo.GT.max( 1, n ) ) THEN
215 info = -2
216 ELSE IF( ihi.LT.min( ilo, n ) .OR. ihi.GT.n ) THEN
217 info = -3
218 ELSE IF( lda.LT.max( 1, n ) ) THEN
219 info = -5
220 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
221 info = -8
222 END IF
223*
224 IF( info.EQ.0 ) THEN
225*
226* Compute the workspace requirements
227*
228 nb = min( nbmax, ilaenv( 1, 'DGEHRD', ' ', n, ilo, ihi, -1 ) )
229 lwkopt = n*nb + tsize
230 work( 1 ) = lwkopt
231 END IF
232*
233 IF( info.NE.0 ) THEN
234 CALL xerbla( 'DGEHRD', -info )
235 RETURN
236 ELSE IF( lquery ) THEN
237 RETURN
238 END IF
239*
240* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
241*
242 DO 10 i = 1, ilo - 1
243 tau( i ) = zero
244 10 CONTINUE
245 DO 20 i = max( 1, ihi ), n - 1
246 tau( i ) = zero
247 20 CONTINUE
248*
249* Quick return if possible
250*
251 nh = ihi - ilo + 1
252 IF( nh.LE.1 ) THEN
253 work( 1 ) = 1
254 RETURN
255 END IF
256*
257* Determine the block size
258*
259 nb = min( nbmax, ilaenv( 1, 'DGEHRD', ' ', n, ilo, ihi, -1 ) )
260 nbmin = 2
261 IF( nb.GT.1 .AND. nb.LT.nh ) THEN
262*
263* Determine when to cross over from blocked to unblocked code
264* (last block is always handled by unblocked code)
265*
266 nx = max( nb, ilaenv( 3, 'DGEHRD', ' ', n, ilo, ihi, -1 ) )
267 IF( nx.LT.nh ) THEN
268*
269* Determine if workspace is large enough for blocked code
270*
271 IF( lwork.LT.n*nb+tsize ) THEN
272*
273* Not enough workspace to use optimal NB: determine the
274* minimum value of NB, and reduce NB or force use of
275* unblocked code
276*
277 nbmin = max( 2, ilaenv( 2, 'DGEHRD', ' ', n, ilo, ihi,
278 $ -1 ) )
279 IF( lwork.GE.(n*nbmin + tsize) ) THEN
280 nb = (lwork-tsize) / n
281 ELSE
282 nb = 1
283 END IF
284 END IF
285 END IF
286 END IF
287 ldwork = n
288*
289 IF( nb.LT.nbmin .OR. nb.GE.nh ) THEN
290*
291* Use unblocked code below
292*
293 i = ilo
294*
295 ELSE
296*
297* Use blocked code
298*
299 iwt = 1 + n*nb
300 DO 40 i = ilo, ihi - 1 - nx, nb
301 ib = min( nb, ihi-i )
302*
303* Reduce columns i:i+ib-1 to Hessenberg form, returning the
304* matrices V and T of the block reflector H = I - V*T*V**T
305* which performs the reduction, and also the matrix Y = A*V*T
306*
307 CALL dlahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),
308 $ work( iwt ), ldt, work, ldwork )
309*
310* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
311* right, computing A := A - Y * V**T. V(i+ib,ib-1) must be set
312* to 1
313*
314 ei = a( i+ib, i+ib-1 )
315 a( i+ib, i+ib-1 ) = one
316 CALL dgemm( 'No transpose', 'Transpose',
317 $ ihi, ihi-i-ib+1,
318 $ ib, -one, work, ldwork, a( i+ib, i ), lda, one,
319 $ a( 1, i+ib ), lda )
320 a( i+ib, i+ib-1 ) = ei
321*
322* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
323* right
324*
325 CALL dtrmm( 'Right', 'Lower', 'Transpose',
326 $ 'Unit', i, ib-1,
327 $ one, a( i+1, i ), lda, work, ldwork )
328 DO 30 j = 0, ib-2
329 CALL daxpy( i, -one, work( ldwork*j+1 ), 1,
330 $ a( 1, i+j+1 ), 1 )
331 30 CONTINUE
332*
333* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
334* left
335*
336 CALL dlarfb( 'Left', 'Transpose', 'Forward',
337 $ 'Columnwise',
338 $ ihi-i, n-i-ib+1, ib, a( i+1, i ), lda,
339 $ work( iwt ), ldt, a( i+1, i+ib ), lda,
340 $ work, ldwork )
341 40 CONTINUE
342 END IF
343*
344* Use unblocked code to reduce the rest of the matrix
345*
346 CALL dgehd2( n, i, ihi, a, lda, tau, work, iinfo )
347 work( 1 ) = lwkopt
348*
349 RETURN
350*
351* End of DGEHRD
352*
dgehd2
subroutine dgehd2(n, ilo, ihi, a, lda, tau, work, info)
DGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
Definition dgehd2.f:149
dlahr2
subroutine dlahr2(n, k, nb, a, lda, tau, t, ldt, y, ldy)
DLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elemen...
Definition dlahr2.f:181
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
daxpy
subroutine daxpy(n, da, dx, incx, dy, incy)
DAXPY
Definition daxpy.f:89
dtrmm
subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRMM
Definition dtrmm.f:177

◆ dgelq2()

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

DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.

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

Purpose:
!>
!> DGELQ2 computes an LQ factorization of a real m-by-n matrix A:
!>
!>    A = ( L 0 ) *  Q
!>
!> where:
!>
!>    Q is a n-by-n orthogonal matrix;
!>    L is a lower-triangular m-by-m matrix;
!>    0 is a m-by-(n-m) zero matrix, if m < n.
!>
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the m by min(m,n) lower trapezoidal matrix L (L is
!>          lower triangular if m <= n); the elements above the diagonal,
!>          with the array TAU, 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]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[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 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(k) . . . H(2) H(1), where k = min(m,n).
!>
!>  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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
!>  and tau in TAU(i).
!>

Definition at line 128 of file dgelq2.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 INTEGER INFO, LDA, M, N
136* ..
137* .. Array Arguments ..
138 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ONE
145 parameter( one = 1.0d+0 )
146* ..
147* .. Local Scalars ..
148 INTEGER I, K
149 DOUBLE PRECISION AII
150* ..
151* .. External Subroutines ..
152 EXTERNAL dlarf, dlarfg, xerbla
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC max, min
156* ..
157* .. Executable Statements ..
158*
159* Test the input arguments
160*
161 info = 0
162 IF( m.LT.0 ) THEN
163 info = -1
164 ELSE IF( n.LT.0 ) THEN
165 info = -2
166 ELSE IF( lda.LT.max( 1, m ) ) THEN
167 info = -4
168 END IF
169 IF( info.NE.0 ) THEN
170 CALL xerbla( 'DGELQ2', -info )
171 RETURN
172 END IF
173*
174 k = min( m, n )
175*
176 DO 10 i = 1, k
177*
178* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
179*
180 CALL dlarfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,
181 $ tau( i ) )
182 IF( i.LT.m ) THEN
183*
184* Apply H(i) to A(i+1:m,i:n) from the right
185*
186 aii = a( i, i )
187 a( i, i ) = one
188 CALL dlarf( 'Right', m-i, n-i+1, a( i, i ), lda, tau( i ),
189 $ a( i+1, i ), lda, work )
190 a( i, i ) = aii
191 END IF
192 10 CONTINUE
193 RETURN
194*
195* End of DGELQ2
196*

◆ dgelqf()

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

DGELQF

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

Purpose:
!>
!> DGELQF computes an LQ factorization of a real M-by-N matrix A:
!>
!>    A = ( L 0 ) *  Q
!>
!> where:
!>
!>    Q is a N-by-N orthogonal matrix;
!>    L is a lower-triangular M-by-M matrix;
!>    0 is a M-by-(N-M) zero matrix, if M < N.
!>
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the m-by-min(m,n) lower trapezoidal matrix L (L is
!>          lower triangular if m <= n); the elements above the diagonal,
!>          with the array TAU, 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]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (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,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.
Further Details:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!>
!>  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-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
!>  and tau in TAU(i).
!>

Definition at line 142 of file dgelqf.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 INTEGER INFO, LDA, LWORK, M, N
150* ..
151* .. Array Arguments ..
152 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
153* ..
154*
155* =====================================================================
156*
157* .. Local Scalars ..
158 LOGICAL LQUERY
159 INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
160 $ NBMIN, NX
161* ..
162* .. External Subroutines ..
163 EXTERNAL dgelq2, dlarfb, dlarft, xerbla
164* ..
165* .. Intrinsic Functions ..
166 INTRINSIC max, min
167* ..
168* .. External Functions ..
169 INTEGER ILAENV
170 EXTERNAL ilaenv
171* ..
172* .. Executable Statements ..
173*
174* Test the input arguments
175*
176 info = 0
177 nb = ilaenv( 1, 'DGELQF', ' ', m, n, -1, -1 )
178 lwkopt = m*nb
179 work( 1 ) = lwkopt
180 lquery = ( lwork.EQ.-1 )
181 IF( m.LT.0 ) THEN
182 info = -1
183 ELSE IF( n.LT.0 ) THEN
184 info = -2
185 ELSE IF( lda.LT.max( 1, m ) ) THEN
186 info = -4
187 ELSE IF( lwork.LT.max( 1, m ) .AND. .NOT.lquery ) THEN
188 info = -7
189 END IF
190 IF( info.NE.0 ) THEN
191 CALL xerbla( 'DGELQF', -info )
192 RETURN
193 ELSE IF( lquery ) THEN
194 RETURN
195 END IF
196*
197* Quick return if possible
198*
199 k = min( m, n )
200 IF( k.EQ.0 ) THEN
201 work( 1 ) = 1
202 RETURN
203 END IF
204*
205 nbmin = 2
206 nx = 0
207 iws = m
208 IF( nb.GT.1 .AND. nb.LT.k ) THEN
209*
210* Determine when to cross over from blocked to unblocked code.
211*
212 nx = max( 0, ilaenv( 3, 'DGELQF', ' ', m, n, -1, -1 ) )
213 IF( nx.LT.k ) THEN
214*
215* Determine if workspace is large enough for blocked code.
216*
217 ldwork = m
218 iws = ldwork*nb
219 IF( lwork.LT.iws ) THEN
220*
221* Not enough workspace to use optimal NB: reduce NB and
222* determine the minimum value of NB.
223*
224 nb = lwork / ldwork
225 nbmin = max( 2, ilaenv( 2, 'DGELQF', ' ', m, n, -1,
226 $ -1 ) )
227 END IF
228 END IF
229 END IF
230*
231 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
232*
233* Use blocked code initially
234*
235 DO 10 i = 1, k - nx, nb
236 ib = min( k-i+1, nb )
237*
238* Compute the LQ factorization of the current block
239* A(i:i+ib-1,i:n)
240*
241 CALL dgelq2( ib, n-i+1, a( i, i ), lda, tau( i ), work,
242 $ iinfo )
243 IF( i+ib.LE.m ) THEN
244*
245* Form the triangular factor of the block reflector
246* H = H(i) H(i+1) . . . H(i+ib-1)
247*
248 CALL dlarft( 'Forward', 'Rowwise', n-i+1, ib, a( i, i ),
249 $ lda, tau( i ), work, ldwork )
250*
251* Apply H to A(i+ib:m,i:n) from the right
252*
253 CALL dlarfb( 'Right', 'No transpose', 'Forward',
254 $ 'Rowwise', m-i-ib+1, n-i+1, ib, a( i, i ),
255 $ lda, work, ldwork, a( i+ib, i ), lda,
256 $ work( ib+1 ), ldwork )
257 END IF
258 10 CONTINUE
259 ELSE
260 i = 1
261 END IF
262*
263* Use unblocked code to factor the last or only block.
264*
265 IF( i.LE.k )
266 $ CALL dgelq2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,
267 $ iinfo )
268*
269 work( 1 ) = iws
270 RETURN
271*
272* End of DGELQF
273*
dgelq2
subroutine dgelq2(m, n, a, lda, tau, work, info)
DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition dgelq2.f:129
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

◆ dgelqt()

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

DGELQT

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

Purpose:
!>
!> DGELQT computes a blocked LQ factorization of a real M-by-N matrix A
!> using the compact WY representation of Q.
!>
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]MB
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.  MIN(M,N) >= MB >= 1.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the M-by-MIN(M,N) lower trapezoidal matrix L (L is
!>          lower triangular if M <= N); the elements above the diagonal
!>          are the rows of V.
!>
[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,MIN(M,N))
!>          The upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.  See below
!>          for 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*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 matrix V stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1  v1 v1 v1 v1 )
!>                   (     1  v2 v2 v2 )
!>                   (         1 v3 v3 )
!>
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.
!>  Let K=MIN(M,N).  The number of blocks is B = ceiling(K/MB), where each
!>  block is of order MB except for the last block, which is of order
!>  IB = K - (B-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-K matrix T as
!>
!>               T = (T1 T2 ... TB).
!>

Definition at line 138 of file dgelqt.f.

139*
140* -- LAPACK computational routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144* .. Scalar Arguments ..
145 INTEGER INFO, LDA, LDT, M, N, MB
146* ..
147* .. Array Arguments ..
148 DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * )
149* ..
150*
151* =====================================================================
152*
153* ..
154* .. Local Scalars ..
155 INTEGER I, IB, IINFO, K
156* ..
157* .. External Subroutines ..
158 EXTERNAL dgelqt3, dlarfb, xerbla
159* ..
160* .. Executable Statements ..
161*
162* Test the input arguments
163*
164 info = 0
165 IF( m.LT.0 ) THEN
166 info = -1
167 ELSE IF( n.LT.0 ) THEN
168 info = -2
169 ELSE IF( mb.LT.1 .OR. ( mb.GT.min(m,n) .AND. min(m,n).GT.0 ) )THEN
170 info = -3
171 ELSE IF( lda.LT.max( 1, m ) ) THEN
172 info = -5
173 ELSE IF( ldt.LT.mb ) THEN
174 info = -7
175 END IF
176 IF( info.NE.0 ) THEN
177 CALL xerbla( 'DGELQT', -info )
178 RETURN
179 END IF
180*
181* Quick return if possible
182*
183 k = min( m, n )
184 IF( k.EQ.0 ) RETURN
185*
186* Blocked loop of length K
187*
188 DO i = 1, k, mb
189 ib = min( k-i+1, mb )
190*
191* Compute the LQ factorization of the current block A(I:M,I:I+IB-1)
192*
193 CALL dgelqt3( ib, n-i+1, a(i,i), lda, t(1,i), ldt, iinfo )
194 IF( i+ib.LE.m ) THEN
195*
196* Update by applying H**T to A(I:M,I+IB:N) from the right
197*
198 CALL dlarfb( 'R', 'N', 'F', 'R', m-i-ib+1, n-i+1, ib,
199 $ a( i, i ), lda, t( 1, i ), ldt,
200 $ a( i+ib, i ), lda, work , m-i-ib+1 )
201 END IF
202 END DO
203 RETURN
204*
205* End of DGELQT
206*
dgelqt3
recursive subroutine dgelqt3(m, n, a, lda, t, ldt, info)
DGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact...
Definition dgelqt3.f:131

◆ dgelqt3()

recursive subroutine dgelqt3 ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldt, * ) t,
integer ldt,
integer info )

DGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact WY representation of Q.

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

Purpose:
!>
!> DGELQT3 recursively computes a LQ factorization of a real M-by-N
!> matrix A, using the compact WY representation of Q.
!>
!> Based on the algorithm of Elmroth and Gustavson,
!> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M =< N.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the real M-by-N matrix A.  On exit, the elements on and
!>          below the diagonal contain the N-by-N lower triangular matrix L; the
!>          elements above the diagonal are the rows of V.  See below for
!>          further details.
!>
[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 N-by-N upper triangular factor of the block reflector.
!>          The elements on and above the diagonal contain the block
!>          reflector T; the elements below the diagonal are not used.
!>          See below for 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 matrix V stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1  v1 v1 v1 v1 )
!>                   (     1  v2 v2 v2 )
!>                   (     1  v3 v3 v3 )
!>
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.  The
!>  block reflector H is then given by
!>
!>               H = I - V * T * V**T
!>
!>  where V**T is the transpose of V.
!>
!>  For details of the algorithm, see Elmroth and Gustavson (cited above).
!>

Definition at line 130 of file dgelqt3.f.

131*
132* -- LAPACK computational routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136* .. Scalar Arguments ..
137 INTEGER INFO, LDA, M, N, LDT
138* ..
139* .. Array Arguments ..
140 DOUBLE PRECISION A( LDA, * ), T( LDT, * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 DOUBLE PRECISION ONE
147 parameter( one = 1.0d+00 )
148* ..
149* .. Local Scalars ..
150 INTEGER I, I1, J, J1, M1, M2, IINFO
151* ..
152* .. External Subroutines ..
153 EXTERNAL dlarfg, dtrmm, dgemm, xerbla
154* ..
155* .. Executable Statements ..
156*
157 info = 0
158 IF( m .LT. 0 ) THEN
159 info = -1
160 ELSE IF( n .LT. m ) THEN
161 info = -2
162 ELSE IF( lda .LT. max( 1, m ) ) THEN
163 info = -4
164 ELSE IF( ldt .LT. max( 1, m ) ) THEN
165 info = -6
166 END IF
167 IF( info.NE.0 ) THEN
168 CALL xerbla( 'DGELQT3', -info )
169 RETURN
170 END IF
171*
172 IF( m.EQ.1 ) THEN
173*
174* Compute Householder transform when M=1
175*
176 CALL dlarfg( n, a, a( 1, min( 2, n ) ), lda, t )
177*
178 ELSE
179*
180* Otherwise, split A into blocks...
181*
182 m1 = m/2
183 m2 = m-m1
184 i1 = min( m1+1, m )
185 j1 = min( m+1, n )
186*
187* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
188*
189 CALL dgelqt3( m1, n, a, lda, t, ldt, iinfo )
190*
191* Compute A(J1:M,1:N) = Q1^H A(J1:M,1:N) [workspace: T(1:N1,J1:N)]
192*
193 DO i=1,m2
194 DO j=1,m1
195 t( i+m1, j ) = a( i+m1, j )
196 END DO
197 END DO
198 CALL dtrmm( 'R', 'U', 'T', 'U', m2, m1, one,
199 & a, lda, t( i1, 1 ), ldt )
200*
201 CALL dgemm( 'N', 'T', m2, m1, n-m1, one, a( i1, i1 ), lda,
202 & a( 1, i1 ), lda, one, t( i1, 1 ), ldt)
203*
204 CALL dtrmm( 'R', 'U', 'N', 'N', m2, m1, one,
205 & t, ldt, t( i1, 1 ), ldt )
206*
207 CALL dgemm( 'N', 'N', m2, n-m1, m1, -one, t( i1, 1 ), ldt,
208 & a( 1, i1 ), lda, one, a( i1, i1 ), lda )
209*
210 CALL dtrmm( 'R', 'U', 'N', 'U', m2, m1 , one,
211 & a, lda, t( i1, 1 ), ldt )
212*
213 DO i=1,m2
214 DO j=1,m1
215 a( i+m1, j ) = a( i+m1, j ) - t( i+m1, j )
216 t( i+m1, j )=0
217 END DO
218 END DO
219*
220* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
221*
222 CALL dgelqt3( m2, n-m1, a( i1, i1 ), lda,
223 & t( i1, i1 ), ldt, iinfo )
224*
225* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2
226*
227 DO i=1,m2
228 DO j=1,m1
229 t( j, i+m1 ) = (a( j, i+m1 ))
230 END DO
231 END DO
232*
233 CALL dtrmm( 'R', 'U', 'T', 'U', m1, m2, one,
234 & a( i1, i1 ), lda, t( 1, i1 ), ldt )
235*
236 CALL dgemm( 'N', 'T', m1, m2, n-m, one, a( 1, j1 ), lda,
237 & a( i1, j1 ), lda, one, t( 1, i1 ), ldt )
238*
239 CALL dtrmm( 'L', 'U', 'N', 'N', m1, m2, -one, t, ldt,
240 & t( 1, i1 ), ldt )
241*
242 CALL dtrmm( 'R', 'U', 'N', 'N', m1, m2, one,
243 & t( i1, i1 ), ldt, t( 1, i1 ), ldt )
244*
245*
246*
247* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3]
248* [ A(1:N1,J1:N) L2 ] [ 0 T2]
249*
250 END IF
251*
252 RETURN
253*
254* End of DGELQT3
255*

◆ dgemlqt()

subroutine dgemlqt ( character side,
character trans,
integer m,
integer n,
integer k,
integer mb,
double precision, dimension( ldv, * ) v,
integer ldv,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) work,
integer info )

DGEMLQT

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

Purpose:
!>
!> DGEMLQT 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) = I - V T V**T
!>
!> generated using the compact WY representation as returned by DGELQT.
!>
!> 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;
!>          = 'C':  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]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 DGELQT.
!>
[in]V
!>          V is DOUBLE PRECISION array, dimension
!>                               (LDV,M) if SIDE = 'L',
!>                               (LDV,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
!>          DGELQT in the first K rows of its array argument A.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V.  LDV >= max(1,K).
!>
[in]T
!>          T is DOUBLE PRECISION array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by DGELQT, stored as a MB-by-K matrix.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= MB.
!>
[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, Q**T C, 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. 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.

Definition at line 166 of file dgemlqt.f.

168*
169* -- LAPACK computational routine --
170* -- LAPACK is a software package provided by Univ. of Tennessee, --
171* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172*
173* .. Scalar Arguments ..
174 CHARACTER SIDE, TRANS
175 INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
176* ..
177* .. Array Arguments ..
178 DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
179* ..
180*
181* =====================================================================
182*
183* ..
184* .. Local Scalars ..
185 LOGICAL LEFT, RIGHT, TRAN, NOTRAN
186 INTEGER I, IB, LDWORK, KF, Q
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 EXTERNAL lsame
191* ..
192* .. External Subroutines ..
193 EXTERNAL xerbla, dlarfb
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC max, min
197* ..
198* .. Executable Statements ..
199*
200* .. Test the input arguments ..
201*
202 info = 0
203 left = lsame( side, 'L' )
204 right = lsame( side, 'R' )
205 tran = lsame( trans, 'T' )
206 notran = lsame( trans, 'N' )
207*
208 IF( left ) THEN
209 ldwork = max( 1, n )
210 q = m
211 ELSE IF ( right ) THEN
212 ldwork = max( 1, m )
213 q = n
214 END IF
215 IF( .NOT.left .AND. .NOT.right ) THEN
216 info = -1
217 ELSE IF( .NOT.tran .AND. .NOT.notran ) THEN
218 info = -2
219 ELSE IF( m.LT.0 ) THEN
220 info = -3
221 ELSE IF( n.LT.0 ) THEN
222 info = -4
223 ELSE IF( k.LT.0 .OR. k.GT.q ) THEN
224 info = -5
225 ELSE IF( mb.LT.1 .OR. (mb.GT.k .AND. k.GT.0)) THEN
226 info = -6
227 ELSE IF( ldv.LT.max( 1, k ) ) THEN
228 info = -8
229 ELSE IF( ldt.LT.mb ) THEN
230 info = -10
231 ELSE IF( ldc.LT.max( 1, m ) ) THEN
232 info = -12
233 END IF
234*
235 IF( info.NE.0 ) THEN
236 CALL xerbla( 'DGEMLQT', -info )
237 RETURN
238 END IF
239*
240* .. Quick return if possible ..
241*
242 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) RETURN
243*
244 IF( left .AND. notran ) THEN
245*
246 DO i = 1, k, mb
247 ib = min( mb, k-i+1 )
248 CALL dlarfb( 'L', 'T', 'F', 'R', m-i+1, n, ib,
249 $ v( i, i ), ldv, t( 1, i ), ldt,
250 $ c( i, 1 ), ldc, work, ldwork )
251 END DO
252*
253 ELSE IF( right .AND. tran ) THEN
254*
255 DO i = 1, k, mb
256 ib = min( mb, k-i+1 )
257 CALL dlarfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,
258 $ v( i, i ), ldv, t( 1, i ), ldt,
259 $ c( 1, i ), ldc, work, ldwork )
260 END DO
261*
262 ELSE IF( left .AND. tran ) THEN
263*
264 kf = ((k-1)/mb)*mb+1
265 DO i = kf, 1, -mb
266 ib = min( mb, k-i+1 )
267 CALL dlarfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,
268 $ v( i, i ), ldv, t( 1, i ), ldt,
269 $ c( i, 1 ), ldc, work, ldwork )
270 END DO
271*
272 ELSE IF( right .AND. notran ) THEN
273*
274 kf = ((k-1)/mb)*mb+1
275 DO i = kf, 1, -mb
276 ib = min( mb, k-i+1 )
277 CALL dlarfb( 'R', 'T', 'F', 'R', m, n-i+1, ib,
278 $ v( i, i ), ldv, t( 1, i ), ldt,
279 $ c( 1, i ), ldc, work, ldwork )
280 END DO
281*
282 END IF
283*
284 RETURN
285*
286* End of DGEMLQT
287*

◆ dgemqrt()

subroutine dgemqrt ( character side,
character trans,
integer m,
integer n,
integer k,
integer nb,
double precision, dimension( ldv, * ) v,
integer ldv,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) work,
integer info )

DGEMQRT

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

Purpose:
!>
!> DGEMQRT 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) = I - V T V**T
!>
!> generated using the compact WY representation as returned by DGEQRT.
!>
!> 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;
!>          = 'C':  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]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 DGEQRT.
!>
[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
!>          DGEQRT in the first K columns of its array argument A.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V.
!>          If SIDE = 'L', LDA >= max(1,M);
!>          if SIDE = 'R', LDA >= max(1,N).
!>
[in]T
!>          T is DOUBLE PRECISION array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by DGEQRT, stored as a NB-by-N matrix.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB.
!>
[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, Q**T C, 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. 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.

Definition at line 166 of file dgemqrt.f.

168*
169* -- LAPACK computational routine --
170* -- LAPACK is a software package provided by Univ. of Tennessee, --
171* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172*
173* .. Scalar Arguments ..
174 CHARACTER SIDE, TRANS
175 INTEGER INFO, K, LDV, LDC, M, N, NB, LDT
176* ..
177* .. Array Arguments ..
178 DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
179* ..
180*
181* =====================================================================
182*
183* ..
184* .. Local Scalars ..
185 LOGICAL LEFT, RIGHT, TRAN, NOTRAN
186 INTEGER I, IB, LDWORK, KF, Q
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 EXTERNAL lsame
191* ..
192* .. External Subroutines ..
193 EXTERNAL xerbla, dlarfb
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC max, min
197* ..
198* .. Executable Statements ..
199*
200* .. Test the input arguments ..
201*
202 info = 0
203 left = lsame( side, 'L' )
204 right = lsame( side, 'R' )
205 tran = lsame( trans, 'T' )
206 notran = lsame( trans, 'N' )
207*
208 IF( left ) THEN
209 ldwork = max( 1, n )
210 q = m
211 ELSE IF ( right ) THEN
212 ldwork = max( 1, m )
213 q = n
214 END IF
215 IF( .NOT.left .AND. .NOT.right ) THEN
216 info = -1
217 ELSE IF( .NOT.tran .AND. .NOT.notran ) THEN
218 info = -2
219 ELSE IF( m.LT.0 ) THEN
220 info = -3
221 ELSE IF( n.LT.0 ) THEN
222 info = -4
223 ELSE IF( k.LT.0 .OR. k.GT.q ) THEN
224 info = -5
225 ELSE IF( nb.LT.1 .OR. (nb.GT.k .AND. k.GT.0)) THEN
226 info = -6
227 ELSE IF( ldv.LT.max( 1, q ) ) THEN
228 info = -8
229 ELSE IF( ldt.LT.nb ) THEN
230 info = -10
231 ELSE IF( ldc.LT.max( 1, m ) ) THEN
232 info = -12
233 END IF
234*
235 IF( info.NE.0 ) THEN
236 CALL xerbla( 'DGEMQRT', -info )
237 RETURN
238 END IF
239*
240* .. Quick return if possible ..
241*
242 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) RETURN
243*
244 IF( left .AND. tran ) THEN
245*
246 DO i = 1, k, nb
247 ib = min( nb, k-i+1 )
248 CALL dlarfb( 'L', 'T', 'F', 'C', m-i+1, n, ib,
249 $ v( i, i ), ldv, t( 1, i ), ldt,
250 $ c( i, 1 ), ldc, work, ldwork )
251 END DO
252*
253 ELSE IF( right .AND. notran ) THEN
254*
255 DO i = 1, k, nb
256 ib = min( nb, k-i+1 )
257 CALL dlarfb( 'R', 'N', 'F', 'C', m, n-i+1, ib,
258 $ v( i, i ), ldv, t( 1, i ), ldt,
259 $ c( 1, i ), ldc, work, ldwork )
260 END DO
261*
262 ELSE IF( left .AND. notran ) THEN
263*
264 kf = ((k-1)/nb)*nb+1
265 DO i = kf, 1, -nb
266 ib = min( nb, k-i+1 )
267 CALL dlarfb( 'L', 'N', 'F', 'C', m-i+1, n, ib,
268 $ v( i, i ), ldv, t( 1, i ), ldt,
269 $ c( i, 1 ), ldc, work, ldwork )
270 END DO
271*
272 ELSE IF( right .AND. tran ) THEN
273*
274 kf = ((k-1)/nb)*nb+1
275 DO i = kf, 1, -nb
276 ib = min( nb, k-i+1 )
277 CALL dlarfb( 'R', 'T', 'F', 'C', m, n-i+1, ib,
278 $ v( i, i ), ldv, t( 1, i ), ldt,
279 $ c( 1, i ), ldc, work, ldwork )
280 END DO
281*
282 END IF
283*
284 RETURN
285*
286* End of DGEMQRT
287*

◆ dgeql2()

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

DGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.

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

Purpose:
!>
!> DGEQL2 computes a QL factorization of a real m by n matrix A:
!> A = Q * L.
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, if m >= n, the lower triangle of the subarray
!>          A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
!>          if m <= n, the elements on and below the (n-m)-th
!>          superdiagonal contain the m by n lower trapezoidal matrix L;
!>          the remaining elements, with the array TAU, 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]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[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:
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!>
!>  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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
!>  A(1:m-k+i-1,n-k+i), and tau in TAU(i).
!>

Definition at line 122 of file dgeql2.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 INTEGER INFO, LDA, M, N
130* ..
131* .. Array Arguments ..
132 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 DOUBLE PRECISION ONE
139 parameter( one = 1.0d+0 )
140* ..
141* .. Local Scalars ..
142 INTEGER I, K
143 DOUBLE PRECISION AII
144* ..
145* .. External Subroutines ..
146 EXTERNAL dlarf, dlarfg, xerbla
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC max, min
150* ..
151* .. Executable Statements ..
152*
153* Test the input arguments
154*
155 info = 0
156 IF( m.LT.0 ) THEN
157 info = -1
158 ELSE IF( n.LT.0 ) THEN
159 info = -2
160 ELSE IF( lda.LT.max( 1, m ) ) THEN
161 info = -4
162 END IF
163 IF( info.NE.0 ) THEN
164 CALL xerbla( 'DGEQL2', -info )
165 RETURN
166 END IF
167*
168 k = min( m, n )
169*
170 DO 10 i = k, 1, -1
171*
172* Generate elementary reflector H(i) to annihilate
173* A(1:m-k+i-1,n-k+i)
174*
175 CALL dlarfg( m-k+i, a( m-k+i, n-k+i ), a( 1, n-k+i ), 1,
176 $ tau( i ) )
177*
178* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left
179*
180 aii = a( m-k+i, n-k+i )
181 a( m-k+i, n-k+i ) = one
182 CALL dlarf( 'Left', m-k+i, n-k+i-1, a( 1, n-k+i ), 1, tau( i ),
183 $ a, lda, work )
184 a( m-k+i, n-k+i ) = aii
185 10 CONTINUE
186 RETURN
187*
188* End of DGEQL2
189*

◆ dgeqlf()

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

DGEQLF

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

Purpose:
!>
!> DGEQLF computes a QL factorization of a real M-by-N matrix A:
!> A = Q * L.
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit,
!>          if m >= n, the lower triangle of the subarray
!>          A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
!>          if m <= n, the elements on and below the (n-m)-th
!>          superdiagonal contain the M-by-N lower trapezoidal matrix L;
!>          the remaining elements, with the array TAU, 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]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (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).
!>          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 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(k) . . . H(2) H(1), where k = min(m,n).
!>
!>  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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
!>  A(1:m-k+i-1,n-k+i), and tau in TAU(i).
!>

Definition at line 137 of file dgeqlf.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, LWORK, M, N
145* ..
146* .. Array Arguments ..
147 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
148* ..
149*
150* =====================================================================
151*
152* .. Local Scalars ..
153 LOGICAL LQUERY
154 INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
155 $ MU, NB, NBMIN, NU, NX
156* ..
157* .. External Subroutines ..
158 EXTERNAL dgeql2, dlarfb, dlarft, xerbla
159* ..
160* .. Intrinsic Functions ..
161 INTRINSIC max, min
162* ..
163* .. External Functions ..
164 INTEGER ILAENV
165 EXTERNAL ilaenv
166* ..
167* .. Executable Statements ..
168*
169* Test the input arguments
170*
171 info = 0
172 lquery = ( lwork.EQ.-1 )
173 IF( m.LT.0 ) THEN
174 info = -1
175 ELSE IF( n.LT.0 ) THEN
176 info = -2
177 ELSE IF( lda.LT.max( 1, m ) ) THEN
178 info = -4
179 END IF
180*
181 IF( info.EQ.0 ) THEN
182 k = min( m, n )
183 IF( k.EQ.0 ) THEN
184 lwkopt = 1
185 ELSE
186 nb = ilaenv( 1, 'DGEQLF', ' ', m, n, -1, -1 )
187 lwkopt = n*nb
188 END IF
189 work( 1 ) = lwkopt
190*
191 IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
192 info = -7
193 END IF
194 END IF
195*
196 IF( info.NE.0 ) THEN
197 CALL xerbla( 'DGEQLF', -info )
198 RETURN
199 ELSE IF( lquery ) THEN
200 RETURN
201 END IF
202*
203* Quick return if possible
204*
205 IF( k.EQ.0 ) THEN
206 RETURN
207 END IF
208*
209 nbmin = 2
210 nx = 1
211 iws = n
212 IF( nb.GT.1 .AND. nb.LT.k ) THEN
213*
214* Determine when to cross over from blocked to unblocked code.
215*
216 nx = max( 0, ilaenv( 3, 'DGEQLF', ' ', m, n, -1, -1 ) )
217 IF( nx.LT.k ) THEN
218*
219* Determine if workspace is large enough for blocked code.
220*
221 ldwork = n
222 iws = ldwork*nb
223 IF( lwork.LT.iws ) THEN
224*
225* Not enough workspace to use optimal NB: reduce NB and
226* determine the minimum value of NB.
227*
228 nb = lwork / ldwork
229 nbmin = max( 2, ilaenv( 2, 'DGEQLF', ' ', m, n, -1,
230 $ -1 ) )
231 END IF
232 END IF
233 END IF
234*
235 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
236*
237* Use blocked code initially.
238* The last kk columns are handled by the block method.
239*
240 ki = ( ( k-nx-1 ) / nb )*nb
241 kk = min( k, ki+nb )
242*
243 DO 10 i = k - kk + ki + 1, k - kk + 1, -nb
244 ib = min( k-i+1, nb )
245*
246* Compute the QL factorization of the current block
247* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
248*
249 CALL dgeql2( m-k+i+ib-1, ib, a( 1, n-k+i ), lda, tau( i ),
250 $ work, iinfo )
251 IF( n-k+i.GT.1 ) THEN
252*
253* Form the triangular factor of the block reflector
254* H = H(i+ib-1) . . . H(i+1) H(i)
255*
256 CALL dlarft( 'Backward', 'Columnwise', m-k+i+ib-1, ib,
257 $ a( 1, n-k+i ), lda, tau( i ), work, ldwork )
258*
259* Apply H**T to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
260*
261 CALL dlarfb( 'Left', 'Transpose', 'Backward',
262 $ 'Columnwise', m-k+i+ib-1, n-k+i-1, ib,
263 $ a( 1, n-k+i ), lda, work, ldwork, a, lda,
264 $ work( ib+1 ), ldwork )
265 END IF
266 10 CONTINUE
267 mu = m - k + i + nb - 1
268 nu = n - k + i + nb - 1
269 ELSE
270 mu = m
271 nu = n
272 END IF
273*
274* Use unblocked code to factor the last or only block
275*
276 IF( mu.GT.0 .AND. nu.GT.0 )
277 $ CALL dgeql2( mu, nu, a, lda, tau, work, iinfo )
278*
279 work( 1 ) = iws
280 RETURN
281*
282* End of DGEQLF
283*
dgeql2
subroutine dgeql2(m, n, a, lda, tau, work, info)
DGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.
Definition dgeql2.f:123

◆ dgeqp3()

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

DGEQP3

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

Purpose:
!>
!> DGEQP3 computes a QR factorization with column pivoting of a
!> matrix A:  A*P = Q*R  using Level 3 BLAS.
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the upper triangle of the array contains the
!>          min(M,N)-by-N upper trapezoidal matrix R; the elements below
!>          the diagonal, together with the array TAU, represent the
!>          orthogonal matrix Q as a product of min(M,N) elementary
!>          reflectors.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in,out]JPVT
!>          JPVT is INTEGER array, dimension (N)
!>          On entry, if JPVT(J).ne.0, the J-th column of A is permuted
!>          to the front of A*P (a leading column); if JPVT(J)=0,
!>          the J-th column of A is a free column.
!>          On exit, if JPVT(J)=K, then the J-th column of A*P was the
!>          the K-th column of A.
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          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 >= 3*N+1.
!>          For optimal performance LWORK >= 2*N+( 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.
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 - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real/complex vector
!>  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
!>  A(i+1:m,i), and tau in TAU(i).
!>
Contributors:
G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain X. Sun, Computer Science Dept., Duke University, USA

Definition at line 150 of file dgeqp3.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 INTEGER JPVT( * )
161 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 INTEGER INB, INBMIN, IXOVER
168 parameter( inb = 1, inbmin = 2, ixover = 3 )
169* ..
170* .. Local Scalars ..
171 LOGICAL LQUERY
172 INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB,
173 $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN
174* ..
175* .. External Subroutines ..
176 EXTERNAL dgeqrf, dlaqp2, dlaqps, dormqr, dswap, xerbla
177* ..
178* .. External Functions ..
179 INTEGER ILAENV
180 DOUBLE PRECISION DNRM2
181 EXTERNAL ilaenv, dnrm2
182* ..
183* .. Intrinsic Functions ..
184 INTRINSIC int, max, min
185* ..
186* .. Executable Statements ..
187*
188* Test input arguments
189* ====================
190*
191 info = 0
192 lquery = ( lwork.EQ.-1 )
193 IF( m.LT.0 ) THEN
194 info = -1
195 ELSE IF( n.LT.0 ) THEN
196 info = -2
197 ELSE IF( lda.LT.max( 1, m ) ) THEN
198 info = -4
199 END IF
200*
201 IF( info.EQ.0 ) THEN
202 minmn = min( m, n )
203 IF( minmn.EQ.0 ) THEN
204 iws = 1
205 lwkopt = 1
206 ELSE
207 iws = 3*n + 1
208 nb = ilaenv( inb, 'DGEQRF', ' ', m, n, -1, -1 )
209 lwkopt = 2*n + ( n + 1 )*nb
210 END IF
211 work( 1 ) = lwkopt
212*
213 IF( ( lwork.LT.iws ) .AND. .NOT.lquery ) THEN
214 info = -8
215 END IF
216 END IF
217*
218 IF( info.NE.0 ) THEN
219 CALL xerbla( 'DGEQP3', -info )
220 RETURN
221 ELSE IF( lquery ) THEN
222 RETURN
223 END IF
224*
225* Move initial columns up front.
226*
227 nfxd = 1
228 DO 10 j = 1, n
229 IF( jpvt( j ).NE.0 ) THEN
230 IF( j.NE.nfxd ) THEN
231 CALL dswap( m, a( 1, j ), 1, a( 1, nfxd ), 1 )
232 jpvt( j ) = jpvt( nfxd )
233 jpvt( nfxd ) = j
234 ELSE
235 jpvt( j ) = j
236 END IF
237 nfxd = nfxd + 1
238 ELSE
239 jpvt( j ) = j
240 END IF
241 10 CONTINUE
242 nfxd = nfxd - 1
243*
244* Factorize fixed columns
245* =======================
246*
247* Compute the QR factorization of fixed columns and update
248* remaining columns.
249*
250 IF( nfxd.GT.0 ) THEN
251 na = min( m, nfxd )
252*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
253 CALL dgeqrf( m, na, a, lda, tau, work, lwork, info )
254 iws = max( iws, int( work( 1 ) ) )
255 IF( na.LT.n ) THEN
256*CC CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
257*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO )
258 CALL dormqr( 'Left', 'Transpose', m, n-na, na, a, lda, tau,
259 $ a( 1, na+1 ), lda, work, lwork, info )
260 iws = max( iws, int( work( 1 ) ) )
261 END IF
262 END IF
263*
264* Factorize free columns
265* ======================
266*
267 IF( nfxd.LT.minmn ) THEN
268*
269 sm = m - nfxd
270 sn = n - nfxd
271 sminmn = minmn - nfxd
272*
273* Determine the block size.
274*
275 nb = ilaenv( inb, 'DGEQRF', ' ', sm, sn, -1, -1 )
276 nbmin = 2
277 nx = 0
278*
279 IF( ( nb.GT.1 ) .AND. ( nb.LT.sminmn ) ) THEN
280*
281* Determine when to cross over from blocked to unblocked code.
282*
283 nx = max( 0, ilaenv( ixover, 'DGEQRF', ' ', sm, sn, -1,
284 $ -1 ) )
285*
286*
287 IF( nx.LT.sminmn ) THEN
288*
289* Determine if workspace is large enough for blocked code.
290*
291 minws = 2*sn + ( sn+1 )*nb
292 iws = max( iws, minws )
293 IF( lwork.LT.minws ) THEN
294*
295* Not enough workspace to use optimal NB: Reduce NB and
296* determine the minimum value of NB.
297*
298 nb = ( lwork-2*sn ) / ( sn+1 )
299 nbmin = max( 2, ilaenv( inbmin, 'DGEQRF', ' ', sm, sn,
300 $ -1, -1 ) )
301*
302*
303 END IF
304 END IF
305 END IF
306*
307* Initialize partial column norms. The first N elements of work
308* store the exact column norms.
309*
310 DO 20 j = nfxd + 1, n
311 work( j ) = dnrm2( sm, a( nfxd+1, j ), 1 )
312 work( n+j ) = work( j )
313 20 CONTINUE
314*
315 IF( ( nb.GE.nbmin ) .AND. ( nb.LT.sminmn ) .AND.
316 $ ( nx.LT.sminmn ) ) THEN
317*
318* Use blocked code initially.
319*
320 j = nfxd + 1
321*
322* Compute factorization: while loop.
323*
324*
325 topbmn = minmn - nx
326 30 CONTINUE
327 IF( j.LE.topbmn ) THEN
328 jb = min( nb, topbmn-j+1 )
329*
330* Factorize JB columns among columns J:N.
331*
332 CALL dlaqps( m, n-j+1, j-1, jb, fjb, a( 1, j ), lda,
333 $ jpvt( j ), tau( j ), work( j ), work( n+j ),
334 $ work( 2*n+1 ), work( 2*n+jb+1 ), n-j+1 )
335*
336 j = j + fjb
337 GO TO 30
338 END IF
339 ELSE
340 j = nfxd + 1
341 END IF
342*
343* Use unblocked code to factor the last or only block.
344*
345*
346 IF( j.LE.minmn )
347 $ CALL dlaqp2( m, n-j+1, j-1, a( 1, j ), lda, jpvt( j ),
348 $ tau( j ), work( j ), work( n+j ),
349 $ work( 2*n+1 ) )
350*
351 END IF
352*
353 work( 1 ) = iws
354 RETURN
355*
356* End of DGEQP3
357*
dgeqrf
subroutine dgeqrf(m, n, a, lda, tau, work, lwork, info)
DGEQRF
Definition dgeqrf.f:146
dlaqps
subroutine dlaqps(m, n, offset, nb, kb, a, lda, jpvt, tau, vn1, vn2, auxv, f, ldf)
DLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BL...
Definition dlaqps.f:177
dlaqp2
subroutine dlaqp2(m, n, offset, a, lda, jpvt, tau, vn1, vn2, work)
DLAQP2 computes a QR factorization with column pivoting of the matrix block.
Definition dlaqp2.f:149
dormqr
subroutine dormqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
DORMQR
Definition dormqr.f:167

◆ dgeqpf()

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

DGEQPF

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine DGEQP3.
!>
!> DGEQPF computes a QR factorization with column pivoting of a
!> real M-by-N matrix A: A*P = Q*R.
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the upper triangle of the array contains the
!>          min(M,N)-by-N upper triangular matrix R; the elements
!>          below the diagonal, together with the array TAU,
!>          represent the orthogonal matrix Q as a product of
!>          min(m,n) elementary reflectors.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in,out]JPVT
!>          JPVT is INTEGER array, dimension (N)
!>          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
!>          to the front of A*P (a leading column); if JPVT(i) = 0,
!>          the i-th column of A is a free column.
!>          On exit, if JPVT(i) = k, then the i-th column of A*P
!>          was the k-th column of A.
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!>
[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 matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(n)
!>
!>  Each H(i) has the form
!>
!>     H = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
!>
!>  The matrix P is represented in jpvt as follows: If
!>     jpvt(j) = i
!>  then the jth column of P is the ith canonical unit vector.
!>
!>  Partial column norm updating strategy modified by
!>    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
!>    University of Zagreb, Croatia.
!>  -- April 2011                                                      --
!>  For more details see LAPACK Working Note 176.
!>

Definition at line 141 of file dgeqpf.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 INTEGER INFO, LDA, M, N
149* ..
150* .. Array Arguments ..
151 INTEGER JPVT( * )
152 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
153* ..
154*
155* =====================================================================
156*
157* .. Parameters ..
158 DOUBLE PRECISION ZERO, ONE
159 parameter( zero = 0.0d+0, one = 1.0d+0 )
160* ..
161* .. Local Scalars ..
162 INTEGER I, ITEMP, J, MA, MN, PVT
163 DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z
164* ..
165* .. External Subroutines ..
166 EXTERNAL dgeqr2, dlarf, dlarfg, dorm2r, dswap, xerbla
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC abs, max, min, sqrt
170* ..
171* .. External Functions ..
172 INTEGER IDAMAX
173 DOUBLE PRECISION DLAMCH, DNRM2
174 EXTERNAL idamax, dlamch, dnrm2
175* ..
176* .. Executable Statements ..
177*
178* Test the input arguments
179*
180 info = 0
181 IF( m.LT.0 ) THEN
182 info = -1
183 ELSE IF( n.LT.0 ) THEN
184 info = -2
185 ELSE IF( lda.LT.max( 1, m ) ) THEN
186 info = -4
187 END IF
188 IF( info.NE.0 ) THEN
189 CALL xerbla( 'DGEQPF', -info )
190 RETURN
191 END IF
192*
193 mn = min( m, n )
194 tol3z = sqrt(dlamch('Epsilon'))
195*
196* Move initial columns up front
197*
198 itemp = 1
199 DO 10 i = 1, n
200 IF( jpvt( i ).NE.0 ) THEN
201 IF( i.NE.itemp ) THEN
202 CALL dswap( m, a( 1, i ), 1, a( 1, itemp ), 1 )
203 jpvt( i ) = jpvt( itemp )
204 jpvt( itemp ) = i
205 ELSE
206 jpvt( i ) = i
207 END IF
208 itemp = itemp + 1
209 ELSE
210 jpvt( i ) = i
211 END IF
212 10 CONTINUE
213 itemp = itemp - 1
214*
215* Compute the QR factorization and update remaining columns
216*
217 IF( itemp.GT.0 ) THEN
218 ma = min( itemp, m )
219 CALL dgeqr2( m, ma, a, lda, tau, work, info )
220 IF( ma.LT.n ) THEN
221 CALL dorm2r( 'Left', 'Transpose', m, n-ma, ma, a, lda, tau,
222 $ a( 1, ma+1 ), lda, work, info )
223 END IF
224 END IF
225*
226 IF( itemp.LT.mn ) THEN
227*
228* Initialize partial column norms. The first n elements of
229* work store the exact column norms.
230*
231 DO 20 i = itemp + 1, n
232 work( i ) = dnrm2( m-itemp, a( itemp+1, i ), 1 )
233 work( n+i ) = work( i )
234 20 CONTINUE
235*
236* Compute factorization
237*
238 DO 40 i = itemp + 1, mn
239*
240* Determine ith pivot column and swap if necessary
241*
242 pvt = ( i-1 ) + idamax( n-i+1, work( i ), 1 )
243*
244 IF( pvt.NE.i ) THEN
245 CALL dswap( m, a( 1, pvt ), 1, a( 1, i ), 1 )
246 itemp = jpvt( pvt )
247 jpvt( pvt ) = jpvt( i )
248 jpvt( i ) = itemp
249 work( pvt ) = work( i )
250 work( n+pvt ) = work( n+i )
251 END IF
252*
253* Generate elementary reflector H(i)
254*
255 IF( i.LT.m ) THEN
256 CALL dlarfg( m-i+1, a( i, i ), a( i+1, i ), 1, tau( i ) )
257 ELSE
258 CALL dlarfg( 1, a( m, m ), a( m, m ), 1, tau( m ) )
259 END IF
260*
261 IF( i.LT.n ) THEN
262*
263* Apply H(i) to A(i:m,i+1:n) from the left
264*
265 aii = a( i, i )
266 a( i, i ) = one
267 CALL dlarf( 'LEFT', m-i+1, n-i, a( i, i ), 1, tau( i ),
268 $ a( i, i+1 ), lda, work( 2*n+1 ) )
269 a( i, i ) = aii
270 END IF
271*
272* Update partial column norms
273*
274 DO 30 j = i + 1, n
275 IF( work( j ).NE.zero ) THEN
276*
277* NOTE: The following 4 lines follow from the analysis in
278* Lapack Working Note 176.
279*
280 temp = abs( a( i, j ) ) / work( j )
281 temp = max( zero, ( one+temp )*( one-temp ) )
282 temp2 = temp*( work( j ) / work( n+j ) )**2
283 IF( temp2 .LE. tol3z ) THEN
284 IF( m-i.GT.0 ) THEN
285 work( j ) = dnrm2( m-i, a( i+1, j ), 1 )
286 work( n+j ) = work( j )
287 ELSE
288 work( j ) = zero
289 work( n+j ) = zero
290 END IF
291 ELSE
292 work( j ) = work( j )*sqrt( temp )
293 END IF
294 END IF
295 30 CONTINUE
296*
297 40 CONTINUE
298 END IF
299 RETURN
300*
301* End of DGEQPF
302*
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
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

◆ dgeqr2()

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

DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.

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

Purpose:
!>
!> DGEQR2 computes a QR factorization of a real m-by-n matrix A:
!>
!>    A = Q * ( R ),
!>            ( 0 )
!>
!> where:
!>
!>    Q is a m-by-m orthogonal matrix;
!>    R is an upper-triangular n-by-n matrix;
!>    0 is a (m-n)-by-n zero matrix, if m > n.
!>
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(m,n) by n upper trapezoidal matrix R (R is
!>          upper triangular if m >= n); the elements below the diagonal,
!>          with the array TAU, 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]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[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:
!>
!>  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 - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!>  and tau in TAU(i).
!>

Definition at line 129 of file dgeqr2.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 INTEGER INFO, LDA, M, N
137* ..
138* .. Array Arguments ..
139 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 DOUBLE PRECISION ONE
146 parameter( one = 1.0d+0 )
147* ..
148* .. Local Scalars ..
149 INTEGER I, K
150 DOUBLE PRECISION AII
151* ..
152* .. External Subroutines ..
153 EXTERNAL dlarf, dlarfg, xerbla
154* ..
155* .. Intrinsic Functions ..
156 INTRINSIC max, min
157* ..
158* .. Executable Statements ..
159*
160* Test the input arguments
161*
162 info = 0
163 IF( m.LT.0 ) THEN
164 info = -1
165 ELSE IF( n.LT.0 ) THEN
166 info = -2
167 ELSE IF( lda.LT.max( 1, m ) ) THEN
168 info = -4
169 END IF
170 IF( info.NE.0 ) THEN
171 CALL xerbla( 'DGEQR2', -info )
172 RETURN
173 END IF
174*
175 k = min( m, n )
176*
177 DO 10 i = 1, k
178*
179* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
180*
181 CALL dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,
182 $ tau( i ) )
183 IF( i.LT.n ) THEN
184*
185* Apply H(i) to A(i:m,i+1:n) from the left
186*
187 aii = a( i, i )
188 a( i, i ) = one
189 CALL dlarf( 'Left', m-i+1, n-i, a( i, i ), 1, tau( i ),
190 $ a( i, i+1 ), lda, work )
191 a( i, i ) = aii
192 END IF
193 10 CONTINUE
194 RETURN
195*
196* End of DGEQR2
197*

◆ dgeqr2p()

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

DGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elements using an unblocked algorithm.

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

Purpose:
!>
!> DGEQR2P computes a QR factorization of a real m-by-n matrix A:
!>
!>    A = Q * ( R ),
!>            ( 0 )
!>
!> where:
!>
!>    Q is a m-by-m orthogonal matrix;
!>    R is an upper-triangular n-by-n matrix with nonnegative diagonal
!>    entries;
!>    0 is a (m-n)-by-n zero matrix, if m > n.
!>
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(m,n) by n upper trapezoidal matrix R (R is
!>          upper triangular if m >= n). The diagonal entries of R are
!>          nonnegative; the elements below the diagonal,
!>          with the array TAU, 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]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[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:
!>
!>  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 - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!>  and tau in TAU(i).
!>
!> See Lapack Working Note 203 for details
!>

Definition at line 133 of file dgeqr2p.f.

134*
135* -- LAPACK computational routine --
136* -- LAPACK is a software package provided by Univ. of Tennessee, --
137* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
138*
139* .. Scalar Arguments ..
140 INTEGER INFO, LDA, M, N
141* ..
142* .. Array Arguments ..
143 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 DOUBLE PRECISION ONE
150 parameter( one = 1.0d+0 )
151* ..
152* .. Local Scalars ..
153 INTEGER I, K
154 DOUBLE PRECISION AII
155* ..
156* .. External Subroutines ..
157 EXTERNAL dlarf, dlarfgp, xerbla
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC max, min
161* ..
162* .. Executable Statements ..
163*
164* Test the input arguments
165*
166 info = 0
167 IF( m.LT.0 ) THEN
168 info = -1
169 ELSE IF( n.LT.0 ) THEN
170 info = -2
171 ELSE IF( lda.LT.max( 1, m ) ) THEN
172 info = -4
173 END IF
174 IF( info.NE.0 ) THEN
175 CALL xerbla( 'DGEQR2P', -info )
176 RETURN
177 END IF
178*
179 k = min( m, n )
180*
181 DO 10 i = 1, k
182*
183* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
184*
185 CALL dlarfgp( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,
186 $ tau( i ) )
187 IF( i.LT.n ) THEN
188*
189* Apply H(i) to A(i:m,i+1:n) from the left
190*
191 aii = a( i, i )
192 a( i, i ) = one
193 CALL dlarf( 'Left', m-i+1, n-i, a( i, i ), 1, tau( i ),
194 $ a( i, i+1 ), lda, work )
195 a( i, i ) = aii
196 END IF
197 10 CONTINUE
198 RETURN
199*
200* End of DGEQR2P
201*
dlarfgp
subroutine dlarfgp(n, alpha, x, incx, tau)
DLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.
Definition dlarfgp.f:104

◆ dgeqrf()

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

DGEQRF

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

Purpose:
!>
!> DGEQRF computes a QR factorization of a real M-by-N matrix A:
!>
!>    A = Q * ( R ),
!>            ( 0 )
!>
!> where:
!>
!>    Q is a M-by-M orthogonal matrix;
!>    R is an upper-triangular N-by-N matrix;
!>    0 is a (M-N)-by-N zero matrix, if M > N.
!>
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
!>          upper triangular if m >= n); the elements below the diagonal,
!>          with the array TAU, represent the orthogonal matrix Q as a
!>          product of min(m,n) elementary reflectors (see Further
!>          Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (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 >= 1, if MIN(M,N) = 0, and LWORK >= N, otherwise.
!>          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 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 - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!>  and tau in TAU(i).
!>

Definition at line 145 of file dgeqrf.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 INTEGER INFO, LDA, LWORK, M, N
153* ..
154* .. Array Arguments ..
155 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
156* ..
157*
158* =====================================================================
159*
160* .. Local Scalars ..
161 LOGICAL LQUERY
162 INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
163 $ NBMIN, NX
164* ..
165* .. External Subroutines ..
166 EXTERNAL dgeqr2, dlarfb, dlarft, xerbla
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC max, min
170* ..
171* .. External Functions ..
172 INTEGER ILAENV
173 EXTERNAL ilaenv
174* ..
175* .. Executable Statements ..
176*
177* Test the input arguments
178*
179 k = min( m, n )
180 info = 0
181 nb = ilaenv( 1, 'DGEQRF', ' ', m, n, -1, -1 )
182 lquery = ( lwork.EQ.-1 )
183 IF( m.LT.0 ) THEN
184 info = -1
185 ELSE IF( n.LT.0 ) THEN
186 info = -2
187 ELSE IF( lda.LT.max( 1, m ) ) THEN
188 info = -4
189 ELSE IF( .NOT.lquery ) THEN
190 IF( lwork.LE.0 .OR. ( m.GT.0 .AND. lwork.LT.max( 1, n ) ) )
191 $ info = -7
192 END IF
193 IF( info.NE.0 ) THEN
194 CALL xerbla( 'DGEQRF', -info )
195 RETURN
196 ELSE IF( lquery ) THEN
197 IF( k.EQ.0 ) THEN
198 lwkopt = 1
199 ELSE
200 lwkopt = n*nb
201 END IF
202 work( 1 ) = lwkopt
203 RETURN
204 END IF
205*
206* Quick return if possible
207*
208 IF( k.EQ.0 ) THEN
209 work( 1 ) = 1
210 RETURN
211 END IF
212*
213 nbmin = 2
214 nx = 0
215 iws = n
216 IF( nb.GT.1 .AND. nb.LT.k ) THEN
217*
218* Determine when to cross over from blocked to unblocked code.
219*
220 nx = max( 0, ilaenv( 3, 'DGEQRF', ' ', m, n, -1, -1 ) )
221 IF( nx.LT.k ) THEN
222*
223* Determine if workspace is large enough for blocked code.
224*
225 ldwork = n
226 iws = ldwork*nb
227 IF( lwork.LT.iws ) THEN
228*
229* Not enough workspace to use optimal NB: reduce NB and
230* determine the minimum value of NB.
231*
232 nb = lwork / ldwork
233 nbmin = max( 2, ilaenv( 2, 'DGEQRF', ' ', m, n, -1,
234 $ -1 ) )
235 END IF
236 END IF
237 END IF
238*
239 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
240*
241* Use blocked code initially
242*
243 DO 10 i = 1, k - nx, nb
244 ib = min( k-i+1, nb )
245*
246* Compute the QR factorization of the current block
247* A(i:m,i:i+ib-1)
248*
249 CALL dgeqr2( m-i+1, ib, a( i, i ), lda, tau( i ), work,
250 $ iinfo )
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**T to A(i:m,i+ib:n) from the left
260*
261 CALL dlarfb( 'Left', '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 10 CONTINUE
267 ELSE
268 i = 1
269 END IF
270*
271* Use unblocked code to factor the last or only block.
272*
273 IF( i.LE.k )
274 $ CALL dgeqr2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,
275 $ iinfo )
276*
277 work( 1 ) = iws
278 RETURN
279*
280* End of DGEQRF
281*

◆ dgeqrfp()

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

DGEQRFP

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

Purpose:
!>
!> DGEQR2P computes a QR factorization of a real M-by-N matrix A:
!>
!>    A = Q * ( R ),
!>            ( 0 )
!>
!> where:
!>
!>    Q is a M-by-M orthogonal matrix;
!>    R is an upper-triangular N-by-N matrix with nonnegative diagonal
!>    entries;
!>    0 is a (M-N)-by-N zero matrix, if M > N.
!>
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
!>          upper triangular if m >= n). The diagonal entries of R
!>          are nonnegative; the elements below the diagonal,
!>          with the array TAU, represent the orthogonal matrix Q as a
!>          product of min(m,n) elementary reflectors (see Further
!>          Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (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).
!>          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 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 - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!>  and tau in TAU(i).
!>
!> See Lapack Working Note 203 for details
!>

Definition at line 148 of file dgeqrfp.f.

149*
150* -- LAPACK computational routine --
151* -- LAPACK is a software package provided by Univ. of Tennessee, --
152* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153*
154* .. Scalar Arguments ..
155 INTEGER INFO, LDA, LWORK, M, N
156* ..
157* .. Array Arguments ..
158 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Local Scalars ..
164 LOGICAL LQUERY
165 INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
166 $ NBMIN, NX
167* ..
168* .. External Subroutines ..
169 EXTERNAL dgeqr2p, dlarfb, dlarft, xerbla
170* ..
171* .. Intrinsic Functions ..
172 INTRINSIC max, min
173* ..
174* .. External Functions ..
175 INTEGER ILAENV
176 EXTERNAL ilaenv
177* ..
178* .. Executable Statements ..
179*
180* Test the input arguments
181*
182 info = 0
183 nb = ilaenv( 1, 'DGEQRF', ' ', m, n, -1, -1 )
184 lwkopt = n*nb
185 work( 1 ) = lwkopt
186 lquery = ( lwork.EQ.-1 )
187 IF( m.LT.0 ) THEN
188 info = -1
189 ELSE IF( n.LT.0 ) THEN
190 info = -2
191 ELSE IF( lda.LT.max( 1, m ) ) THEN
192 info = -4
193 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
194 info = -7
195 END IF
196 IF( info.NE.0 ) THEN
197 CALL xerbla( 'DGEQRFP', -info )
198 RETURN
199 ELSE IF( lquery ) THEN
200 RETURN
201 END IF
202*
203* Quick return if possible
204*
205 k = min( m, n )
206 IF( k.EQ.0 ) THEN
207 work( 1 ) = 1
208 RETURN
209 END IF
210*
211 nbmin = 2
212 nx = 0
213 iws = n
214 IF( nb.GT.1 .AND. nb.LT.k ) THEN
215*
216* Determine when to cross over from blocked to unblocked code.
217*
218 nx = max( 0, ilaenv( 3, 'DGEQRF', ' ', m, n, -1, -1 ) )
219 IF( nx.LT.k ) THEN
220*
221* Determine if workspace is large enough for blocked code.
222*
223 ldwork = n
224 iws = ldwork*nb
225 IF( lwork.LT.iws ) THEN
226*
227* Not enough workspace to use optimal NB: reduce NB and
228* determine the minimum value of NB.
229*
230 nb = lwork / ldwork
231 nbmin = max( 2, ilaenv( 2, 'DGEQRF', ' ', m, n, -1,
232 $ -1 ) )
233 END IF
234 END IF
235 END IF
236*
237 IF( nb.GE.nbmin .AND. nb.LT.k .AND. nx.LT.k ) THEN
238*
239* Use blocked code initially
240*
241 DO 10 i = 1, k - nx, nb
242 ib = min( k-i+1, nb )
243*
244* Compute the QR factorization of the current block
245* A(i:m,i:i+ib-1)
246*
247 CALL dgeqr2p( m-i+1, ib, a( i, i ), lda, tau( i ), work,
248 $ iinfo )
249 IF( i+ib.LE.n ) THEN
250*
251* Form the triangular factor of the block reflector
252* H = H(i) H(i+1) . . . H(i+ib-1)
253*
254 CALL dlarft( 'Forward', 'Columnwise', m-i+1, ib,
255 $ a( i, i ), lda, tau( i ), work, ldwork )
256*
257* Apply H**T to A(i:m,i+ib:n) from the left
258*
259 CALL dlarfb( 'Left', 'Transpose', 'Forward',
260 $ 'Columnwise', m-i+1, n-i-ib+1, ib,
261 $ a( i, i ), lda, work, ldwork, a( i, i+ib ),
262 $ lda, work( ib+1 ), ldwork )
263 END IF
264 10 CONTINUE
265 ELSE
266 i = 1
267 END IF
268*
269* Use unblocked code to factor the last or only block.
270*
271 IF( i.LE.k )
272 $ CALL dgeqr2p( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work,
273 $ iinfo )
274*
275 work( 1 ) = iws
276 RETURN
277*
278* End of DGEQRFP
279*
dgeqr2p
subroutine dgeqr2p(m, n, a, lda, tau, work, info)
DGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elem...
Definition dgeqr2p.f:134

◆ dgeqrt()

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

DGEQRT

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

Purpose:
!>
!> DGEQRT computes a blocked QR factorization of a real M-by-N matrix A
!> using the compact WY representation of Q.
!>
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]NB
!>          NB is INTEGER
!>          The block size to be used in the blocked QR.  MIN(M,N) >= NB >= 1.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
!>          upper triangular if M >= N); the elements below the diagonal
!>          are the columns of V.
!>
[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,MIN(M,N))
!>          The upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.  See below
!>          for 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 matrix V stores the elementary reflectors H(i) in the i-th column
!>  below the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1       )
!>                   ( v1  1    )
!>                   ( v1 v2  1 )
!>                   ( v1 v2 v3 )
!>                   ( v1 v2 v3 )
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.
!>
!>  Let K=MIN(M,N).  The number of blocks is B = ceiling(K/NB), where each
!>  block is of order NB except for the last block, which is of order
!>  IB = K - (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-K matrix T as
!>
!>               T = (T1 T2 ... TB).
!>

Definition at line 140 of file dgeqrt.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 INTEGER INFO, LDA, LDT, M, N, NB
148* ..
149* .. Array Arguments ..
150 DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * )
151* ..
152*
153* =====================================================================
154*
155* ..
156* .. Local Scalars ..
157 INTEGER I, IB, IINFO, K
158 LOGICAL USE_RECURSIVE_QR
159 parameter( use_recursive_qr=.true. )
160* ..
161* .. External Subroutines ..
162 EXTERNAL dgeqrt2, dgeqrt3, dlarfb, xerbla
163* ..
164* .. Executable Statements ..
165*
166* Test the input arguments
167*
168 info = 0
169 IF( m.LT.0 ) THEN
170 info = -1
171 ELSE IF( n.LT.0 ) THEN
172 info = -2
173 ELSE IF( nb.LT.1 .OR. ( nb.GT.min(m,n) .AND. min(m,n).GT.0 ) )THEN
174 info = -3
175 ELSE IF( lda.LT.max( 1, m ) ) THEN
176 info = -5
177 ELSE IF( ldt.LT.nb ) THEN
178 info = -7
179 END IF
180 IF( info.NE.0 ) THEN
181 CALL xerbla( 'DGEQRT', -info )
182 RETURN
183 END IF
184*
185* Quick return if possible
186*
187 k = min( m, n )
188 IF( k.EQ.0 ) RETURN
189*
190* Blocked loop of length K
191*
192 DO i = 1, k, nb
193 ib = min( k-i+1, nb )
194*
195* Compute the QR factorization of the current block A(I:M,I:I+IB-1)
196*
197 IF( use_recursive_qr ) THEN
198 CALL dgeqrt3( m-i+1, ib, a(i,i), lda, t(1,i), ldt, iinfo )
199 ELSE
200 CALL dgeqrt2( m-i+1, ib, a(i,i), lda, t(1,i), ldt, iinfo )
201 END IF
202 IF( i+ib.LE.n ) THEN
203*
204* Update by applying H**T to A(I:M,I+IB:N) from the left
205*
206 CALL dlarfb( 'L', 'T', 'F', 'C', m-i+1, n-i-ib+1, ib,
207 $ a( i, i ), lda, t( 1, i ), ldt,
208 $ a( i, i+ib ), lda, work , n-i-ib+1 )
209 END IF
210 END DO
211 RETURN
212*
213* End of DGEQRT
214*
dgeqrt3
recursive subroutine dgeqrt3(m, n, a, lda, t, ldt, info)
DGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact...
Definition dgeqrt3.f:132
dgeqrt2
subroutine dgeqrt2(m, n, a, lda, t, ldt, info)
DGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY represen...
Definition dgeqrt2.f:127

◆ dgeqrt2()

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

DGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.

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

Purpose:
!>
!> DGEQRT2 computes a QR factorization of a real M-by-N matrix A,
!> using the compact WY representation of Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= N.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the real M-by-N matrix A.  On exit, the elements on and
!>          above the diagonal contain the N-by-N upper triangular matrix R; the
!>          elements below the diagonal are the columns of V.  See below for
!>          further details.
!>
[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 N-by-N upper triangular factor of the block reflector.
!>          The elements on and above the diagonal contain the block
!>          reflector T; the elements below the diagonal are not used.
!>          See below for 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 matrix V stores the elementary reflectors H(i) in the i-th column
!>  below the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1       )
!>                   ( v1  1    )
!>                   ( v1 v2  1 )
!>                   ( v1 v2 v3 )
!>                   ( v1 v2 v3 )
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.  The
!>  block reflector H is then given by
!>
!>               H = I - V * T * V**T
!>
!>  where V**T is the transpose of V.
!>

Definition at line 126 of file dgeqrt2.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, LDA, LDT, M, N
134* ..
135* .. Array Arguments ..
136 DOUBLE PRECISION A( LDA, * ), T( LDT, * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 DOUBLE PRECISION ONE, ZERO
143 parameter( one = 1.0d+00, zero = 0.0d+00 )
144* ..
145* .. Local Scalars ..
146 INTEGER I, K
147 DOUBLE PRECISION AII, ALPHA
148* ..
149* .. External Subroutines ..
150 EXTERNAL dlarfg, dgemv, dger, dtrmv, xerbla
151* ..
152* .. Executable Statements ..
153*
154* Test the input arguments
155*
156 info = 0
157 IF( n.LT.0 ) THEN
158 info = -2
159 ELSE IF( m.LT.n ) THEN
160 info = -1
161 ELSE IF( lda.LT.max( 1, m ) ) THEN
162 info = -4
163 ELSE IF( ldt.LT.max( 1, n ) ) THEN
164 info = -6
165 END IF
166 IF( info.NE.0 ) THEN
167 CALL xerbla( 'DGEQRT2', -info )
168 RETURN
169 END IF
170*
171 k = min( m, n )
172*
173 DO i = 1, k
174*
175* Generate elem. refl. H(i) to annihilate A(i+1:m,i), tau(I) -> T(I,1)
176*
177 CALL dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,
178 $ t( i, 1 ) )
179 IF( i.LT.n ) THEN
180*
181* Apply H(i) to A(I:M,I+1:N) from the left
182*
183 aii = a( i, i )
184 a( i, i ) = one
185*
186* W(1:N-I) := A(I:M,I+1:N)^H * A(I:M,I) [W = T(:,N)]
187*
188 CALL dgemv( 'T',m-i+1, n-i, one, a( i, i+1 ), lda,
189 $ a( i, i ), 1, zero, t( 1, n ), 1 )
190*
191* A(I:M,I+1:N) = A(I:m,I+1:N) + alpha*A(I:M,I)*W(1:N-1)^H
192*
193 alpha = -(t( i, 1 ))
194 CALL dger( m-i+1, n-i, alpha, a( i, i ), 1,
195 $ t( 1, n ), 1, a( i, i+1 ), lda )
196 a( i, i ) = aii
197 END IF
198 END DO
199*
200 DO i = 2, n
201 aii = a( i, i )
202 a( i, i ) = one
203*
204* T(1:I-1,I) := alpha * A(I:M,1:I-1)**T * A(I:M,I)
205*
206 alpha = -t( i, 1 )
207 CALL dgemv( 'T', m-i+1, i-1, alpha, a( i, 1 ), lda,
208 $ a( i, i ), 1, zero, t( 1, i ), 1 )
209 a( i, i ) = aii
210*
211* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I)
212*
213 CALL dtrmv( 'U', 'N', 'N', i-1, t, ldt, t( 1, i ), 1 )
214*
215* T(I,I) = tau(I)
216*
217 t( i, i ) = t( i, 1 )
218 t( i, 1) = zero
219 END DO
220
221*
222* End of DGEQRT2
223*
alpha
#define alpha
Definition eval.h:35
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
dger
subroutine dger(m, n, alpha, x, incx, y, incy, a, lda)
DGER
Definition dger.f:130

◆ dgeqrt3()

recursive subroutine dgeqrt3 ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldt, * ) t,
integer ldt,
integer info )

DGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.

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

Purpose:
!>
!> DGEQRT3 recursively computes a QR factorization of a real M-by-N
!> matrix A, using the compact WY representation of Q.
!>
!> Based on the algorithm of Elmroth and Gustavson,
!> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= N.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the real M-by-N matrix A.  On exit, the elements on and
!>          above the diagonal contain the N-by-N upper triangular matrix R; the
!>          elements below the diagonal are the columns of V.  See below for
!>          further details.
!>
[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 N-by-N upper triangular factor of the block reflector.
!>          The elements on and above the diagonal contain the block
!>          reflector T; the elements below the diagonal are not used.
!>          See below for 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 matrix V stores the elementary reflectors H(i) in the i-th column
!>  below the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1       )
!>                   ( v1  1    )
!>                   ( v1 v2  1 )
!>                   ( v1 v2 v3 )
!>                   ( v1 v2 v3 )
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.  The
!>  block reflector H is then given by
!>
!>               H = I - V * T * V**T
!>
!>  where V**T is the transpose of V.
!>
!>  For details of the algorithm, see Elmroth and Gustavson (cited above).
!>

Definition at line 131 of file dgeqrt3.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 INTEGER INFO, LDA, M, N, LDT
139* ..
140* .. Array Arguments ..
141 DOUBLE PRECISION A( LDA, * ), T( LDT, * )
142* ..
143*
144* =====================================================================
145*
146* .. Parameters ..
147 DOUBLE PRECISION ONE
148 parameter( one = 1.0d+00 )
149* ..
150* .. Local Scalars ..
151 INTEGER I, I1, J, J1, N1, N2, IINFO
152* ..
153* .. External Subroutines ..
154 EXTERNAL dlarfg, dtrmm, dgemm, xerbla
155* ..
156* .. Executable Statements ..
157*
158 info = 0
159 IF( n .LT. 0 ) THEN
160 info = -2
161 ELSE IF( m .LT. n ) THEN
162 info = -1
163 ELSE IF( lda .LT. max( 1, m ) ) THEN
164 info = -4
165 ELSE IF( ldt .LT. max( 1, n ) ) THEN
166 info = -6
167 END IF
168 IF( info.NE.0 ) THEN
169 CALL xerbla( 'DGEQRT3', -info )
170 RETURN
171 END IF
172*
173 IF( n.EQ.1 ) THEN
174*
175* Compute Householder transform when N=1
176*
177 CALL dlarfg( m, a(1,1), a( min( 2, m ), 1 ), 1, t(1,1) )
178*
179 ELSE
180*
181* Otherwise, split A into blocks...
182*
183 n1 = n/2
184 n2 = n-n1
185 j1 = min( n1+1, n )
186 i1 = min( n+1, m )
187*
188* Compute A(1:M,1:N1) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
189*
190 CALL dgeqrt3( m, n1, a, lda, t, ldt, iinfo )
191*
192* Compute A(1:M,J1:N) = Q1^H A(1:M,J1:N) [workspace: T(1:N1,J1:N)]
193*
194 DO j=1,n2
195 DO i=1,n1
196 t( i, j+n1 ) = a( i, j+n1 )
197 END DO
198 END DO
199 CALL dtrmm( 'L', 'L', 'T', 'U', n1, n2, one,
200 & a, lda, t( 1, j1 ), ldt )
201*
202 CALL dgemm( 'T', 'N', n1, n2, m-n1, one, a( j1, 1 ), lda,
203 & a( j1, j1 ), lda, one, t( 1, j1 ), ldt)
204*
205 CALL dtrmm( 'L', 'U', 'T', 'N', n1, n2, one,
206 & t, ldt, t( 1, j1 ), ldt )
207*
208 CALL dgemm( 'N', 'N', m-n1, n2, n1, -one, a( j1, 1 ), lda,
209 & t( 1, j1 ), ldt, one, a( j1, j1 ), lda )
210*
211 CALL dtrmm( 'L', 'L', 'N', 'U', n1, n2, one,
212 & a, lda, t( 1, j1 ), ldt )
213*
214 DO j=1,n2
215 DO i=1,n1
216 a( i, j+n1 ) = a( i, j+n1 ) - t( i, j+n1 )
217 END DO
218 END DO
219*
220* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
221*
222 CALL dgeqrt3( m-n1, n2, a( j1, j1 ), lda,
223 & t( j1, j1 ), ldt, iinfo )
224*
225* Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2
226*
227 DO i=1,n1
228 DO j=1,n2
229 t( i, j+n1 ) = (a( j+n1, i ))
230 END DO
231 END DO
232*
233 CALL dtrmm( 'R', 'L', 'N', 'U', n1, n2, one,
234 & a( j1, j1 ), lda, t( 1, j1 ), ldt )
235*
236 CALL dgemm( 'T', 'N', n1, n2, m-n, one, a( i1, 1 ), lda,
237 & a( i1, j1 ), lda, one, t( 1, j1 ), ldt )
238*
239 CALL dtrmm( 'L', 'U', 'N', 'N', n1, n2, -one, t, ldt,
240 & t( 1, j1 ), ldt )
241*
242 CALL dtrmm( 'R', 'U', 'N', 'N', n1, n2, one,
243 & t( j1, j1 ), ldt, t( 1, j1 ), ldt )
244*
245* Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3]
246* [ 0 R2 ] [ 0 T2]
247*
248 END IF
249*
250 RETURN
251*
252* End of DGEQRT3
253*

◆ dgerfs()

subroutine dgerfs ( character trans,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldaf, * ) af,
integer ldaf,
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 )

DGERFS

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

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

◆ dgerfsx()

subroutine dgerfsx ( character trans,
character equed,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
double precision, dimension( * ) r,
double precision, dimension( * ) c,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( ldx , * ) x,
integer ldx,
double precision rcond,
double precision, dimension( * ) berr,
integer n_err_bnds,
double precision, dimension( nrhs, * ) err_bnds_norm,
double precision, dimension( nrhs, * ) err_bnds_comp,
integer nparams,
double precision, dimension( * ) params,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DGERFSX

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

Purpose:
!>
!>    DGERFSX improves the computed solution to a system of linear
!>    equations and provides error bounds and backward error estimates
!>    for the solution.  In addition to normwise error bound, the code
!>    provides maximum componentwise error bound if possible.  See
!>    comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
!>    error bounds.
!>
!>    The original system of linear equations may have been equilibrated
!>    before calling this routine, as described by arguments EQUED, R
!>    and C below. In this case, the solution and error bounds returned
!>    are for the original unequilibrated system.
!> 
!>     Some optional parameters are bundled in the PARAMS array.  These
!>     settings determine how refinement is performed, but often the
!>     defaults are acceptable.  If the defaults are acceptable, users
!>     can pass NPARAMS = 0 which prevents the source code from accessing
!>     the PARAMS argument.
!>
Parameters
[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]EQUED
!>          EQUED is CHARACTER*1
!>     Specifies the form of equilibration that was done to A
!>     before calling this routine. This is needed to compute
!>     the solution and error bounds correctly.
!>       = 'N':  No equilibration
!>       = 'R':  Row equilibration, i.e., A has been premultiplied by
!>               diag(R).
!>       = 'C':  Column equilibration, i.e., A has been postmultiplied
!>               by diag(C).
!>       = 'B':  Both row and column equilibration, i.e., A has been
!>               replaced by diag(R) * A * diag(C).
!>               The right hand side B has been changed accordingly.
!>
[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 original N-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDAF,N)
!>     The factors L and U from the factorization A = P*L*U
!>     as computed by DGETRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     The pivot indices from DGETRF; for 1<=i<=N, row i of the
!>     matrix was interchanged with row IPIV(i).
!>
[in]R
!>          R is DOUBLE PRECISION array, dimension (N)
!>     The row scale factors for A.  If EQUED = 'R' or 'B', A is
!>     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
!>     is not accessed.
!>     If R is accessed, each element of R should be a power of the radix
!>     to ensure a reliable solution and error estimates. Scaling by
!>     powers of the radix does not cause rounding errors unless the
!>     result underflows or overflows. Rounding errors during scaling
!>     lead to refining with a matrix that is not equivalent to the
!>     input matrix, producing error estimates that may not be
!>     reliable.
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension (N)
!>     The column scale factors for A.  If EQUED = 'C' or 'B', A is
!>     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
!>     is not accessed.
!>     If C is accessed, each element of C should be a power of the radix
!>     to ensure a reliable solution and error estimates. Scaling by
!>     powers of the radix does not cause rounding errors unless the
!>     result underflows or overflows. Rounding errors during scaling
!>     lead to refining with a matrix that is not equivalent to the
!>     input matrix, producing error estimates that may not be
!>     reliable.
!>
[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 DGETRS.
!>     On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>     The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>     Reciprocal scaled condition number.  This is an estimate of the
!>     reciprocal Skeel condition number of the matrix A after
!>     equilibration (if done).  If this is less than the machine
!>     precision (in particular, if it is zero), the matrix is singular
!>     to working precision.  Note that the error may still be small even
!>     if this number is very small and the matrix appears ill-
!>     conditioned.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>     Componentwise relative backward error.  This is 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).
!>
[in]N_ERR_BNDS
!>          N_ERR_BNDS is INTEGER
!>     Number of error bounds to return for each right hand side
!>     and each type (normwise or componentwise).  See ERR_BNDS_NORM and
!>     ERR_BNDS_COMP below.
!>
[out]ERR_BNDS_NORM
!>          ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     normwise relative error, which is defined as follows:
!>
!>     Normwise relative error in the ith solution vector:
!>             max_j (abs(XTRUE(j,i) - X(j,i)))
!>            ------------------------------
!>                  max_j abs(X(j,i))
!>
!>     The array is indexed by the type of error information as described
!>     below. There currently are up to three pieces of information
!>     returned.
!>
!>     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_NORM(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * dlamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * dlamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated normwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * dlamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*A, where S scales each row by a power of the
!>              radix so all absolute row sums of Z are approximately 1.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[out]ERR_BNDS_COMP
!>          ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     componentwise relative error, which is defined as follows:
!>
!>     Componentwise relative error in the ith solution vector:
!>                    abs(XTRUE(j,i) - X(j,i))
!>             max_j ----------------------
!>                         abs(X(j,i))
!>
!>     The array is indexed by the right-hand side i (on which the
!>     componentwise relative error depends), and the type of error
!>     information as described below. There currently are up to three
!>     pieces of information returned for each right-hand side. If
!>     componentwise accuracy is not requested (PARAMS(3) = 0.0), then
!>     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS < 3, then at most
!>     the first (:,N_ERR_BNDS) entries are returned.
!>
!>     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_COMP(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * dlamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * dlamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated componentwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * dlamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*(A*diag(x)), where x is the solution for the
!>              current right-hand side and S scales each row of
!>              A*diag(x) by a power of the radix so all absolute row
!>              sums of Z are approximately 1.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[in]NPARAMS
!>          NPARAMS is INTEGER
!>     Specifies the number of parameters set in PARAMS.  If <= 0, the
!>     PARAMS array is never referenced and default values are used.
!>
[in,out]PARAMS
!>          PARAMS is DOUBLE PRECISION array, dimension (NPARAMS)
!>     Specifies algorithm parameters.  If an entry is < 0.0, then
!>     that entry will be filled with default value used for that
!>     parameter.  Only positions up to NPARAMS are accessed; defaults
!>     are used for higher-numbered parameters.
!>
!>       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
!>            refinement or not.
!>         Default: 1.0D+0
!>            = 0.0:  No refinement is performed, and no error bounds are
!>                    computed.
!>            = 1.0:  Use the double-precision refinement algorithm,
!>                    possibly with doubled-single computations if the
!>                    compilation environment does not support DOUBLE
!>                    PRECISION.
!>              (other values are reserved for future use)
!>
!>       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
!>            computations allowed for refinement.
!>         Default: 10
!>         Aggressive: Set to 100 to permit convergence using approximate
!>                     factorizations or factorizations other than LU. If
!>                     the factorization uses a technique other than
!>                     Gaussian elimination, the guarantees in
!>                     err_bnds_norm and err_bnds_comp may no longer be
!>                     trustworthy.
!>
!>       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
!>            will attempt to find a solution with small componentwise
!>            relative error in the double-precision algorithm.  Positive
!>            is true, 0.0 is false.
!>         Default: 1.0 (attempt componentwise convergence)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (4*N)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit. The solution to every right-hand side is
!>         guaranteed.
!>       < 0:  If INFO = -i, the i-th argument had an illegal value
!>       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization
!>         has been completed, but the factor U is exactly singular, so
!>         the solution and error bounds could not be computed. RCOND = 0
!>         is returned.
!>       = N+J: The solution corresponding to the Jth right-hand side is
!>         not guaranteed. The solutions corresponding to other right-
!>         hand sides K with K > J may not be guaranteed as well, but
!>         only the first such right-hand side is reported. If a small
!>         componentwise error is not requested (PARAMS(3) = 0.0) then
!>         the Jth right-hand side is the first with a normwise error
!>         bound that is not guaranteed (the smallest J such
!>         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
!>         the Jth right-hand side is the first with either a normwise or
!>         componentwise error bound that is not guaranteed (the smallest
!>         J such that either ERR_BNDS_NORM(J,1) = 0.0 or
!>         ERR_BNDS_COMP(J,1) = 0.0). See the definition of
!>         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
!>         about all of the right-hand sides check ERR_BNDS_NORM or
!>         ERR_BNDS_COMP.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 410 of file dgerfsx.f.

414*
415* -- LAPACK computational routine --
416* -- LAPACK is a software package provided by Univ. of Tennessee, --
417* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
418*
419* .. Scalar Arguments ..
420 CHARACTER TRANS, EQUED
421 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
422 $ N_ERR_BNDS
423 DOUBLE PRECISION RCOND
424* ..
425* .. Array Arguments ..
426 INTEGER IPIV( * ), IWORK( * )
427 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
428 $ X( LDX , * ), WORK( * )
429 DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ),
430 $ ERR_BNDS_NORM( NRHS, * ),
431 $ ERR_BNDS_COMP( NRHS, * )
432* ..
433*
434* ==================================================================
435*
436* .. Parameters ..
437 DOUBLE PRECISION ZERO, ONE
438 parameter( zero = 0.0d+0, one = 1.0d+0 )
439 DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
440 DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
441 DOUBLE PRECISION DZTHRESH_DEFAULT
442 parameter( itref_default = 1.0d+0 )
443 parameter( ithresh_default = 10.0d+0 )
444 parameter( componentwise_default = 1.0d+0 )
445 parameter( rthresh_default = 0.5d+0 )
446 parameter( dzthresh_default = 0.25d+0 )
447 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
448 $ LA_LINRX_CWISE_I
449 parameter( la_linrx_itref_i = 1,
450 $ la_linrx_ithresh_i = 2 )
451 parameter( la_linrx_cwise_i = 3 )
452 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
453 $ LA_LINRX_RCOND_I
454 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
455 parameter( la_linrx_rcond_i = 3 )
456* ..
457* .. Local Scalars ..
458 CHARACTER(1) NORM
459 LOGICAL ROWEQU, COLEQU, NOTRAN
460 INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE
461 INTEGER N_NORMS
462 DOUBLE PRECISION ANORM, RCOND_TMP
463 DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
464 LOGICAL IGNORE_CWISE
465 INTEGER ITHRESH
466 DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH
467* ..
468* .. External Subroutines ..
469 EXTERNAL xerbla, dgecon, dla_gerfsx_extended
470* ..
471* .. Intrinsic Functions ..
472 INTRINSIC max, sqrt
473* ..
474* .. External Functions ..
475 EXTERNAL lsame, ilatrans, ilaprec
476 EXTERNAL dlamch, dlange, dla_gercond
477 DOUBLE PRECISION DLAMCH, DLANGE, DLA_GERCOND
478 LOGICAL LSAME
479 INTEGER ILATRANS, ILAPREC
480* ..
481* .. Executable Statements ..
482*
483* Check the input parameters.
484*
485 info = 0
486 trans_type = ilatrans( trans )
487 ref_type = int( itref_default )
488 IF ( nparams .GE. la_linrx_itref_i ) THEN
489 IF ( params( la_linrx_itref_i ) .LT. 0.0d+0 ) THEN
490 params( la_linrx_itref_i ) = itref_default
491 ELSE
492 ref_type = params( la_linrx_itref_i )
493 END IF
494 END IF
495*
496* Set default parameters.
497*
498 illrcond_thresh = dble( n ) * dlamch( 'Epsilon' )
499 ithresh = int( ithresh_default )
500 rthresh = rthresh_default
501 unstable_thresh = dzthresh_default
502 ignore_cwise = componentwise_default .EQ. 0.0d+0
503*
504 IF ( nparams.GE.la_linrx_ithresh_i ) THEN
505 IF ( params( la_linrx_ithresh_i ).LT.0.0d+0 ) THEN
506 params( la_linrx_ithresh_i ) = ithresh
507 ELSE
508 ithresh = int( params( la_linrx_ithresh_i ) )
509 END IF
510 END IF
511 IF ( nparams.GE.la_linrx_cwise_i ) THEN
512 IF ( params( la_linrx_cwise_i ).LT.0.0d+0 ) THEN
513 IF ( ignore_cwise ) THEN
514 params( la_linrx_cwise_i ) = 0.0d+0
515 ELSE
516 params( la_linrx_cwise_i ) = 1.0d+0
517 END IF
518 ELSE
519 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+0
520 END IF
521 END IF
522 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 ) THEN
523 n_norms = 0
524 ELSE IF ( ignore_cwise ) THEN
525 n_norms = 1
526 ELSE
527 n_norms = 2
528 END IF
529*
530 notran = lsame( trans, 'N' )
531 rowequ = lsame( equed, 'R' ) .OR. lsame( equed, 'B' )
532 colequ = lsame( equed, 'C' ) .OR. lsame( equed, 'B' )
533*
534* Test input parameters.
535*
536 IF( trans_type.EQ.-1 ) THEN
537 info = -1
538 ELSE IF( .NOT.rowequ .AND. .NOT.colequ .AND.
539 $ .NOT.lsame( equed, 'N' ) ) THEN
540 info = -2
541 ELSE IF( n.LT.0 ) THEN
542 info = -3
543 ELSE IF( nrhs.LT.0 ) THEN
544 info = -4
545 ELSE IF( lda.LT.max( 1, n ) ) THEN
546 info = -6
547 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
548 info = -8
549 ELSE IF( ldb.LT.max( 1, n ) ) THEN
550 info = -13
551 ELSE IF( ldx.LT.max( 1, n ) ) THEN
552 info = -15
553 END IF
554 IF( info.NE.0 ) THEN
555 CALL xerbla( 'DGERFSX', -info )
556 RETURN
557 END IF
558*
559* Quick return if possible.
560*
561 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
562 rcond = 1.0d+0
563 DO j = 1, nrhs
564 berr( j ) = 0.0d+0
565 IF ( n_err_bnds .GE. 1 ) THEN
566 err_bnds_norm( j, la_linrx_trust_i) = 1.0d+0
567 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
568 END IF
569 IF ( n_err_bnds .GE. 2 ) THEN
570 err_bnds_norm( j, la_linrx_err_i) = 0.0d+0
571 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
572 END IF
573 IF ( n_err_bnds .GE. 3 ) THEN
574 err_bnds_norm( j, la_linrx_rcond_i) = 1.0d+0
575 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
576 END IF
577 END DO
578 RETURN
579 END IF
580*
581* Default to failure.
582*
583 rcond = 0.0d+0
584 DO j = 1, nrhs
585 berr( j ) = 1.0d+0
586 IF ( n_err_bnds .GE. 1 ) THEN
587 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
588 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
589 END IF
590 IF ( n_err_bnds .GE. 2 ) THEN
591 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
592 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
593 END IF
594 IF ( n_err_bnds .GE. 3 ) THEN
595 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
596 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
597 END IF
598 END DO
599*
600* Compute the norm of A and the reciprocal of the condition
601* number of A.
602*
603 IF( notran ) THEN
604 norm = 'I'
605 ELSE
606 norm = '1'
607 END IF
608 anorm = dlange( norm, n, n, a, lda, work )
609 CALL dgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info )
610*
611* Perform refinement on each right-hand side
612*
613 IF ( ref_type .NE. 0 ) THEN
614
615 prec_type = ilaprec( 'E' )
616
617 IF ( notran ) THEN
618 CALL dla_gerfsx_extended( prec_type, trans_type, n,
619 $ nrhs, a, lda, af, ldaf, ipiv, colequ, c, b,
620 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
621 $ err_bnds_comp, work(n+1), work(1), work(2*n+1),
622 $ work(1), rcond, ithresh, rthresh, unstable_thresh,
623 $ ignore_cwise, info )
624 ELSE
625 CALL dla_gerfsx_extended( prec_type, trans_type, n,
626 $ nrhs, a, lda, af, ldaf, ipiv, rowequ, r, b,
627 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
628 $ err_bnds_comp, work(n+1), work(1), work(2*n+1),
629 $ work(1), rcond, ithresh, rthresh, unstable_thresh,
630 $ ignore_cwise, info )
631 END IF
632 END IF
633
634 err_lbnd = max( 10.0d+0, sqrt( dble( n ) ) ) * dlamch( 'Epsilon' )
635 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 ) THEN
636*
637* Compute scaled normwise condition number cond(A*C).
638*
639 IF ( colequ .AND. notran ) THEN
640 rcond_tmp = dla_gercond( trans, n, a, lda, af, ldaf, ipiv,
641 $ -1, c, info, work, iwork )
642 ELSE IF ( rowequ .AND. .NOT. notran ) THEN
643 rcond_tmp = dla_gercond( trans, n, a, lda, af, ldaf, ipiv,
644 $ -1, r, info, work, iwork )
645 ELSE
646 rcond_tmp = dla_gercond( trans, n, a, lda, af, ldaf, ipiv,
647 $ 0, r, info, work, iwork )
648 END IF
649 DO j = 1, nrhs
650*
651* Cap the error at 1.0.
652*
653 IF ( n_err_bnds .GE. la_linrx_err_i
654 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0d+0 )
655 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
656*
657* Threshold the error (see LAWN).
658*
659 IF ( rcond_tmp .LT. illrcond_thresh ) THEN
660 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
661 err_bnds_norm( j, la_linrx_trust_i ) = 0.0d+0
662 IF ( info .LE. n ) info = n + j
663 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
664 $ THEN
665 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
666 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
667 END IF
668*
669* Save the condition number.
670*
671 IF ( n_err_bnds .GE. la_linrx_rcond_i ) THEN
672 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
673 END IF
674 END DO
675 END IF
676
677 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 2 ) THEN
678*
679* Compute componentwise condition number cond(A*diag(Y(:,J))) for
680* each right-hand side using the current solution as an estimate of
681* the true solution. If the componentwise error estimate is too
682* large, then the solution is a lousy estimate of truth and the
683* estimated RCOND may be too optimistic. To avoid misleading users,
684* the inverse condition number is set to 0.0 when the estimated
685* cwise error is at least CWISE_WRONG.
686*
687 cwise_wrong = sqrt( dlamch( 'Epsilon' ) )
688 DO j = 1, nrhs
689 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
690 $ THEN
691 rcond_tmp = dla_gercond( trans, n, a, lda, af, ldaf,
692 $ ipiv, 1, x(1,j), info, work, iwork )
693 ELSE
694 rcond_tmp = 0.0d+0
695 END IF
696*
697* Cap the error at 1.0.
698*
699 IF ( n_err_bnds .GE. la_linrx_err_i
700 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0d+0 )
701 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
702*
703* Threshold the error (see LAWN).
704*
705 IF ( rcond_tmp .LT. illrcond_thresh ) THEN
706 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
707 err_bnds_comp( j, la_linrx_trust_i ) = 0.0d+0
708 IF ( params( la_linrx_cwise_i ) .EQ. 1.0d+0
709 $ .AND. info.LT.n + j ) info = n + j
710 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
711 $ .LT. err_lbnd ) THEN
712 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
713 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
714 END IF
715*
716* Save the condition number.
717*
718 IF ( n_err_bnds .GE. la_linrx_rcond_i ) THEN
719 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
720 END IF
721 END DO
722 END IF
723*
724 RETURN
725*
726* End of DGERFSX
727*
ilaprec
integer function ilaprec(prec)
ILAPREC
Definition ilaprec.f:58
ilatrans
integer function ilatrans(trans)
ILATRANS
Definition ilatrans.f:58
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
dla_gerfsx_extended
subroutine dla_gerfsx_extended(prec_type, trans_type, n, nrhs, a, lda, af, ldaf, ipiv, colequ, c, b, ldb, y, ldy, berr_out, n_norms, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, info)
DLA_GERFSX_EXTENDED improves the computed solution to a system of linear equations for general matric...
Definition dla_gerfsx_extended.f:396
dgecon
subroutine dgecon(norm, n, a, lda, anorm, rcond, work, iwork, info)
DGECON
Definition dgecon.f:124
dla_gercond
double precision function dla_gercond(trans, n, a, lda, af, ldaf, ipiv, cmode, c, info, work, iwork)
DLA_GERCOND estimates the Skeel condition number for a general matrix.
Definition dla_gercond.f:152

◆ dgerq2()

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

DGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.

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

Purpose:
!>
!> DGERQ2 computes an RQ factorization of a real m by n matrix A:
!> A = R * Q.
!>
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,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 TAU, 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]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[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 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 - tau * v * v**T
!>
!>  where tau 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 tau in TAU(i).
!>

Definition at line 122 of file dgerq2.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 INTEGER INFO, LDA, M, N
130* ..
131* .. Array Arguments ..
132 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 DOUBLE PRECISION ONE
139 parameter( one = 1.0d+0 )
140* ..
141* .. Local Scalars ..
142 INTEGER I, K
143 DOUBLE PRECISION AII
144* ..
145* .. External Subroutines ..
146 EXTERNAL dlarf, dlarfg, xerbla
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC max, min
150* ..
151* .. Executable Statements ..
152*
153* Test the input arguments
154*
155 info = 0
156 IF( m.LT.0 ) THEN
157 info = -1
158 ELSE IF( n.LT.0 ) THEN
159 info = -2
160 ELSE IF( lda.LT.max( 1, m ) ) THEN
161 info = -4
162 END IF
163 IF( info.NE.0 ) THEN
164 CALL xerbla( 'DGERQ2', -info )
165 RETURN
166 END IF
167*
168 k = min( m, n )
169*
170 DO 10 i = k, 1, -1
171*
172* Generate elementary reflector H(i) to annihilate
173* A(m-k+i,1:n-k+i-1)
174*
175 CALL dlarfg( n-k+i, a( m-k+i, n-k+i ), a( m-k+i, 1 ), lda,
176 $ tau( i ) )
177*
178* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
179*
180 aii = a( m-k+i, n-k+i )
181 a( m-k+i, n-k+i ) = one
182 CALL dlarf( 'Right', m-k+i-1, n-k+i, a( m-k+i, 1 ), lda,
183 $ tau( i ), a, lda, work )
184 a( m-k+i, n-k+i ) = aii
185 10 CONTINUE
186 RETURN
187*
188* End of DGERQ2
189*

◆ dgerqf()

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

DGERQF

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

Purpose:
!>
!> DGERQF computes an RQ factorization of a real M-by-N matrix A:
!> A = R * Q.
!>
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,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 TAU, represent the
!>          orthogonal matrix Q as a product of min(m,n) elementary
!>          reflectors (see Further Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (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 >= 1, if MIN(M,N) = 0, and LWORK >= M, otherwise.
!>          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.
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 - tau * v * v**T
!>
!>  where tau 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 tau in TAU(i).
!>

Definition at line 138 of file dgerqf.f.

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

◆ dgesvj()

subroutine dgesvj ( character*1 joba,
character*1 jobu,
character*1 jobv,
integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( n ) sva,
integer mv,
double precision, dimension( ldv, * ) v,
integer ldv,
double precision, dimension( lwork ) work,
integer lwork,
integer info )

DGESVJ

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

Purpose:
!>
!> DGESVJ computes the singular value decomposition (SVD) of a real
!> M-by-N matrix A, where M >= N. The SVD of A is written as
!>                                    [++]   [xx]   [x0]   [xx]
!>              A = U * SIGMA * V^t,  [++] = [xx] * [ox] * [xx]
!>                                    [++]   [xx]
!> where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal
!> matrix, and V is an N-by-N orthogonal matrix. The diagonal elements
!> of SIGMA are the singular values of A. The columns of U and V are the
!> left and the right singular vectors of A, respectively.
!> DGESVJ can sometimes compute tiny singular values and their singular vectors much
!> more accurately than other SVD routines, see below under Further Details.
!>
Parameters
[in]JOBA
!>          JOBA is CHARACTER*1
!>          Specifies the structure of A.
!>          = 'L': The input matrix A is lower triangular;
!>          = 'U': The input matrix A is upper triangular;
!>          = 'G': The input matrix A is general M-by-N matrix, M >= N.
!>
[in]JOBU
!>          JOBU is CHARACTER*1
!>          Specifies whether to compute the left singular vectors
!>          (columns of U):
!>          = 'U': The left singular vectors corresponding to the nonzero
!>                 singular values are computed and returned in the leading
!>                 columns of A. See more details in the description of A.
!>                 The default numerical orthogonality threshold is set to
!>                 approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E').
!>          = 'C': Analogous to JOBU='U', except that user can control the
!>                 level of numerical orthogonality of the computed left
!>                 singular vectors. TOL can be set to TOL = CTOL*EPS, where
!>                 CTOL is given on input in the array WORK.
!>                 No CTOL smaller than ONE is allowed. CTOL greater
!>                 than 1 / EPS is meaningless. The option 'C'
!>                 can be used if M*EPS is satisfactory orthogonality
!>                 of the computed left singular vectors, so CTOL=M could
!>                 save few sweeps of Jacobi rotations.
!>                 See the descriptions of A and WORK(1).
!>          = 'N': The matrix U is not computed. However, see the
!>                 description of A.
!>
[in]JOBV
!>          JOBV is CHARACTER*1
!>          Specifies whether to compute the right singular vectors, that
!>          is, the matrix V:
!>          = 'V':  the matrix V is computed and returned in the array V
!>          = 'A':  the Jacobi rotations are applied to the MV-by-N
!>                  array V. In other words, the right singular vector
!>                  matrix V is not computed explicitly, instead it is
!>                  applied to an MV-by-N matrix initially stored in the
!>                  first MV rows of V.
!>          = 'N':  the matrix V is not computed and the array V is not
!>                  referenced
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the input matrix A. 1/DLAMCH('E') > 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, the M-by-N matrix A.
!>          On exit :
!>          If JOBU = 'U' .OR. JOBU = 'C' :
!>                 If INFO = 0 :
!>                 RANKA orthonormal columns of U are returned in the
!>                 leading RANKA columns of the array A. Here RANKA <= N
!>                 is the number of computed singular values of A that are
!>                 above the underflow threshold DLAMCH('S'). The singular
!>                 vectors corresponding to underflowed or zero singular
!>                 values are not computed. The value of RANKA is returned
!>                 in the array WORK as RANKA=NINT(WORK(2)). Also see the
!>                 descriptions of SVA and WORK. The computed columns of U
!>                 are mutually numerically orthogonal up to approximately
!>                 TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU = 'C'),
!>                 see the description of JOBU.
!>                 If INFO > 0 :
!>                 the procedure DGESVJ did not converge in the given number
!>                 of iterations (sweeps). In that case, the computed
!>                 columns of U may not be orthogonal up to TOL. The output
!>                 U (stored in A), SIGMA (given by the computed singular
!>                 values in SVA(1:N)) and V is still a decomposition of the
!>                 input matrix A in the sense that the residual
!>                 ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.
!>
!>          If JOBU = 'N' :
!>                 If INFO = 0 :
!>                 Note that the left singular vectors are 'for free' in the
!>                 one-sided Jacobi SVD algorithm. However, if only the
!>                 singular values are needed, the level of numerical
!>                 orthogonality of U is not an issue and iterations are
!>                 stopped when the columns of the iterated matrix are
!>                 numerically orthogonal up to approximately M*EPS. Thus,
!>                 on exit, A contains the columns of U scaled with the
!>                 corresponding singular values.
!>                 If INFO > 0 :
!>                 the procedure DGESVJ did not converge in the given number
!>                 of iterations (sweeps).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]SVA
!>          SVA is DOUBLE PRECISION array, dimension (N)
!>          On exit :
!>          If INFO = 0 :
!>          depending on the value SCALE = WORK(1), we have:
!>                 If SCALE = ONE :
!>                 SVA(1:N) contains the computed singular values of A.
!>                 During the computation SVA contains the Euclidean column
!>                 norms of the iterated matrices in the array A.
!>                 If SCALE .NE. ONE :
!>                 The singular values of A are SCALE*SVA(1:N), and this
!>                 factored representation is due to the fact that some of the
!>                 singular values of A might underflow or overflow.
!>          If INFO > 0 :
!>          the procedure DGESVJ did not converge in the given number of
!>          iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.
!>
[in]MV
!>          MV is INTEGER
!>          If JOBV = 'A', then the product of Jacobi rotations in DGESVJ
!>          is applied to the first MV rows of V. See the description of JOBV.
!>
[in,out]V
!>          V is DOUBLE PRECISION array, dimension (LDV,N)
!>          If JOBV = 'V', then V contains on exit the N-by-N matrix of
!>                         the right singular vectors;
!>          If JOBV = 'A', then V contains the product of the computed right
!>                         singular vector matrix and the initial matrix in
!>                         the array V.
!>          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', then LDV >= max(1,N).
!>          If JOBV = 'A', then LDV >= max(1,MV) .
!>
[in,out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>          On entry :
!>          If JOBU = 'C' :
!>          WORK(1) = CTOL, where CTOL defines the threshold for convergence.
!>                    The process stops if all columns of A are mutually
!>                    orthogonal up to CTOL*EPS, EPS=DLAMCH('E').
!>                    It is required that CTOL >= ONE, i.e. it is not
!>                    allowed to force the routine to obtain orthogonality
!>                    below EPS.
!>          On exit :
!>          WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)
!>                    are the computed singular values of A.
!>                    (See description of SVA().)
!>          WORK(2) = NINT(WORK(2)) is the number of the computed nonzero
!>                    singular values.
!>          WORK(3) = NINT(WORK(3)) is the number of the computed singular
!>                    values that are larger than the underflow threshold.
!>          WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi
!>                    rotations needed for numerical convergence.
!>          WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.
!>                    This is useful information in cases when DGESVJ did
!>                    not converge, as it can be used to estimate whether
!>                    the output is still useful and for post festum analysis.
!>          WORK(6) = the largest absolute value over all sines of the
!>                    Jacobi rotation angles in the last sweep. It can be
!>                    useful for a post festum analysis.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          length of WORK, WORK >= MAX(6,M+N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, then the i-th argument had an illegal value
!>          > 0:  DGESVJ did not converge in the maximal allowed number (30)
!>                of sweeps. The output may still be useful. See the
!>                description of WORK.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane
!>  rotations. The rotations are implemented as fast scaled rotations of
!>  Anda and Park [1]. In the case of underflow of the Jacobi angle, a
!>  modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses
!>  column interchanges of de Rijk [2]. The relative accuracy of the computed
!>  singular values and the accuracy of the computed singular vectors (in
!>  angle metric) is as guaranteed by the theory of Demmel and Veselic [3].
!>  The condition number that determines the accuracy in the full rank case
!>  is essentially min_{D=diag} kappa(A*D), where kappa(.) is the
!>  spectral condition number. The best performance of this Jacobi SVD
!>  procedure is achieved if used in an  accelerated version of Drmac and
!>  Veselic [5,6], and it is the kernel routine in the SIGMA library [7].
!>  Some tuning parameters (marked with [TP]) are available for the
!>  implementer.
!>  The computational range for the nonzero singular values is the  machine
!>  number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even
!>  denormalized singular values can be computed with the corresponding
!>  gradual loss of accurate digits.
!>
Contributors:
!>
!>  ============
!>
!>  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
!>
References:
!>
!> [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.
!>     SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.
!> [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the
!>     singular value decomposition on a vector computer.
!>     SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.
!> [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.
!> [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular
!>     value computation in floating point arithmetic.
!>     SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.
!> [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.
!>     SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.
!>     LAPACK Working note 169.
!> [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.
!>     SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.
!>     LAPACK Working note 170.
!> [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,
!>     QSVD, (H,K)-SVD computations.
!>     Department of Mathematics, University of Zagreb, 2008.
!>
Bugs, examples and comments:
!>  ===========================
!>  Please report all bugs and send interesting test examples and comments to
!>  drmac@math.hr. Thank you.
!>

Definition at line 335 of file dgesvj.f.

337*
338* -- LAPACK computational routine --
339* -- LAPACK is a software package provided by Univ. of Tennessee, --
340* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
341*
342* .. Scalar Arguments ..
343 INTEGER INFO, LDA, LDV, LWORK, M, MV, N
344 CHARACTER*1 JOBA, JOBU, JOBV
345* ..
346* .. Array Arguments ..
347 DOUBLE PRECISION A( LDA, * ), SVA( N ), V( LDV, * ),
348 $ WORK( LWORK )
349* ..
350*
351* =====================================================================
352*
353* .. Local Parameters ..
354 DOUBLE PRECISION ZERO, HALF, ONE
355 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0)
356 INTEGER NSWEEP
357 parameter( nsweep = 30 )
358* ..
359* .. Local Scalars ..
360 DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
361 $ BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,
362 $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,
363 $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,
364 $ THSIGN, TOL
365 INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
366 $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,
367 $ N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,
368 $ SWBAND
369 LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,
370 $ RSVEC, UCTOL, UPPER
371* ..
372* .. Local Arrays ..
373 DOUBLE PRECISION FASTR( 5 )
374* ..
375* .. Intrinsic Functions ..
376 INTRINSIC dabs, max, min, dble, dsign, dsqrt
377* ..
378* .. External Functions ..
379* ..
380* from BLAS
381 DOUBLE PRECISION DDOT, DNRM2
382 EXTERNAL ddot, dnrm2
383 INTEGER IDAMAX
384 EXTERNAL idamax
385* from LAPACK
386 DOUBLE PRECISION DLAMCH
387 EXTERNAL dlamch
388 LOGICAL LSAME
389 EXTERNAL lsame
390* ..
391* .. External Subroutines ..
392* ..
393* from BLAS
394 EXTERNAL daxpy, dcopy, drotm, dscal, dswap
395* from LAPACK
396 EXTERNAL dlascl, dlaset, dlassq, xerbla
397*
398 EXTERNAL dgsvj0, dgsvj1
399* ..
400* .. Executable Statements ..
401*
402* Test the input arguments
403*
404 lsvec = lsame( jobu, 'U' )
405 uctol = lsame( jobu, 'C' )
406 rsvec = lsame( jobv, 'V' )
407 applv = lsame( jobv, 'A' )
408 upper = lsame( joba, 'U' )
409 lower = lsame( joba, 'L' )
410*
411 IF( .NOT.( upper .OR. lower .OR. lsame( joba, 'G' ) ) ) THEN
412 info = -1
413 ELSE IF( .NOT.( lsvec .OR. uctol .OR. lsame( jobu, 'N' ) ) ) THEN
414 info = -2
415 ELSE IF( .NOT.( rsvec .OR. applv .OR. lsame( jobv, 'N' ) ) ) THEN
416 info = -3
417 ELSE IF( m.LT.0 ) THEN
418 info = -4
419 ELSE IF( ( n.LT.0 ) .OR. ( n.GT.m ) ) THEN
420 info = -5
421 ELSE IF( lda.LT.m ) THEN
422 info = -7
423 ELSE IF( mv.LT.0 ) THEN
424 info = -9
425 ELSE IF( ( rsvec .AND. ( ldv.LT.n ) ) .OR.
426 $ ( applv .AND. ( ldv.LT.mv ) ) ) THEN
427 info = -11
428 ELSE IF( uctol .AND. ( work( 1 ).LE.one ) ) THEN
429 info = -12
430 ELSE IF( lwork.LT.max( m+n, 6 ) ) THEN
431 info = -13
432 ELSE
433 info = 0
434 END IF
435*
436* #:(
437 IF( info.NE.0 ) THEN
438 CALL xerbla( 'DGESVJ', -info )
439 RETURN
440 END IF
441*
442* #:) Quick return for void matrix
443*
444 IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )RETURN
445*
446* Set numerical parameters
447* The stopping criterion for Jacobi rotations is
448*
449* max_{i<>j}|A(:,i)^T * A(:,j)|/(||A(:,i)||*||A(:,j)||) < CTOL*EPS
450*
451* where EPS is the round-off and CTOL is defined as follows:
452*
453 IF( uctol ) THEN
454* ... user controlled
455 ctol = work( 1 )
456 ELSE
457* ... default
458 IF( lsvec .OR. rsvec .OR. applv ) THEN
459 ctol = dsqrt( dble( m ) )
460 ELSE
461 ctol = dble( m )
462 END IF
463 END IF
464* ... and the machine dependent parameters are
465*[!] (Make sure that DLAMCH() works properly on the target machine.)
466*
467 epsln = dlamch( 'Epsilon' )
468 rooteps = dsqrt( epsln )
469 sfmin = dlamch( 'SafeMinimum' )
470 rootsfmin = dsqrt( sfmin )
471 small = sfmin / epsln
472 big = dlamch( 'Overflow' )
473* BIG = ONE / SFMIN
474 rootbig = one / rootsfmin
475 large = big / dsqrt( dble( m*n ) )
476 bigtheta = one / rooteps
477*
478 tol = ctol*epsln
479 roottol = dsqrt( tol )
480*
481 IF( dble( m )*epsln.GE.one ) THEN
482 info = -4
483 CALL xerbla( 'DGESVJ', -info )
484 RETURN
485 END IF
486*
487* Initialize the right singular vector matrix.
488*
489 IF( rsvec ) THEN
490 mvl = n
491 CALL dlaset( 'A', mvl, n, zero, one, v, ldv )
492 ELSE IF( applv ) THEN
493 mvl = mv
494 END IF
495 rsvec = rsvec .OR. applv
496*
497* Initialize SVA( 1:N ) = ( ||A e_i||_2, i = 1:N )
498*(!) If necessary, scale A to protect the largest singular value
499* from overflow. It is possible that saving the largest singular
500* value destroys the information about the small ones.
501* This initial scaling is almost minimal in the sense that the
502* goal is to make sure that no column norm overflows, and that
503* DSQRT(N)*max_i SVA(i) does not overflow. If INFinite entries
504* in A are detected, the procedure returns with INFO=-6.
505*
506 skl= one / dsqrt( dble( m )*dble( n ) )
507 noscale = .true.
508 goscale = .true.
509*
510 IF( lower ) THEN
511* the input matrix is M-by-N lower triangular (trapezoidal)
512 DO 1874 p = 1, n
513 aapp = zero
514 aaqq = one
515 CALL dlassq( m-p+1, a( p, p ), 1, aapp, aaqq )
516 IF( aapp.GT.big ) THEN
517 info = -6
518 CALL xerbla( 'DGESVJ', -info )
519 RETURN
520 END IF
521 aaqq = dsqrt( aaqq )
522 IF( ( aapp.LT.( big / aaqq ) ) .AND. noscale ) THEN
523 sva( p ) = aapp*aaqq
524 ELSE
525 noscale = .false.
526 sva( p ) = aapp*( aaqq*skl)
527 IF( goscale ) THEN
528 goscale = .false.
529 DO 1873 q = 1, p - 1
530 sva( q ) = sva( q )*skl
531 1873 CONTINUE
532 END IF
533 END IF
534 1874 CONTINUE
535 ELSE IF( upper ) THEN
536* the input matrix is M-by-N upper triangular (trapezoidal)
537 DO 2874 p = 1, n
538 aapp = zero
539 aaqq = one
540 CALL dlassq( p, a( 1, p ), 1, aapp, aaqq )
541 IF( aapp.GT.big ) THEN
542 info = -6
543 CALL xerbla( 'DGESVJ', -info )
544 RETURN
545 END IF
546 aaqq = dsqrt( aaqq )
547 IF( ( aapp.LT.( big / aaqq ) ) .AND. noscale ) THEN
548 sva( p ) = aapp*aaqq
549 ELSE
550 noscale = .false.
551 sva( p ) = aapp*( aaqq*skl)
552 IF( goscale ) THEN
553 goscale = .false.
554 DO 2873 q = 1, p - 1
555 sva( q ) = sva( q )*skl
556 2873 CONTINUE
557 END IF
558 END IF
559 2874 CONTINUE
560 ELSE
561* the input matrix is M-by-N general dense
562 DO 3874 p = 1, n
563 aapp = zero
564 aaqq = one
565 CALL dlassq( m, a( 1, p ), 1, aapp, aaqq )
566 IF( aapp.GT.big ) THEN
567 info = -6
568 CALL xerbla( 'DGESVJ', -info )
569 RETURN
570 END IF
571 aaqq = dsqrt( aaqq )
572 IF( ( aapp.LT.( big / aaqq ) ) .AND. noscale ) THEN
573 sva( p ) = aapp*aaqq
574 ELSE
575 noscale = .false.
576 sva( p ) = aapp*( aaqq*skl)
577 IF( goscale ) THEN
578 goscale = .false.
579 DO 3873 q = 1, p - 1
580 sva( q ) = sva( q )*skl
581 3873 CONTINUE
582 END IF
583 END IF
584 3874 CONTINUE
585 END IF
586*
587 IF( noscale )skl= one
588*
589* Move the smaller part of the spectrum from the underflow threshold
590*(!) Start by determining the position of the nonzero entries of the
591* array SVA() relative to ( SFMIN, BIG ).
592*
593 aapp = zero
594 aaqq = big
595 DO 4781 p = 1, n
596 IF( sva( p ).NE.zero )aaqq = min( aaqq, sva( p ) )
597 aapp = max( aapp, sva( p ) )
598 4781 CONTINUE
599*
600* #:) Quick return for zero matrix
601*
602 IF( aapp.EQ.zero ) THEN
603 IF( lsvec )CALL dlaset( 'G', m, n, zero, one, a, lda )
604 work( 1 ) = one
605 work( 2 ) = zero
606 work( 3 ) = zero
607 work( 4 ) = zero
608 work( 5 ) = zero
609 work( 6 ) = zero
610 RETURN
611 END IF
612*
613* #:) Quick return for one-column matrix
614*
615 IF( n.EQ.1 ) THEN
616 IF( lsvec )CALL dlascl( 'G', 0, 0, sva( 1 ), skl, m, 1,
617 $ a( 1, 1 ), lda, ierr )
618 work( 1 ) = one / skl
619 IF( sva( 1 ).GE.sfmin ) THEN
620 work( 2 ) = one
621 ELSE
622 work( 2 ) = zero
623 END IF
624 work( 3 ) = zero
625 work( 4 ) = zero
626 work( 5 ) = zero
627 work( 6 ) = zero
628 RETURN
629 END IF
630*
631* Protect small singular values from underflow, and try to
632* avoid underflows/overflows in computing Jacobi rotations.
633*
634 sn = dsqrt( sfmin / epsln )
635 temp1 = dsqrt( big / dble( n ) )
636 IF( ( aapp.LE.sn ) .OR. ( aaqq.GE.temp1 ) .OR.
637 $ ( ( sn.LE.aaqq ) .AND. ( aapp.LE.temp1 ) ) ) THEN
638 temp1 = min( big, temp1 / aapp )
639* AAQQ = AAQQ*TEMP1
640* AAPP = AAPP*TEMP1
641 ELSE IF( ( aaqq.LE.sn ) .AND. ( aapp.LE.temp1 ) ) THEN
642 temp1 = min( sn / aaqq, big / ( aapp*dsqrt( dble( n ) ) ) )
643* AAQQ = AAQQ*TEMP1
644* AAPP = AAPP*TEMP1
645 ELSE IF( ( aaqq.GE.sn ) .AND. ( aapp.GE.temp1 ) ) THEN
646 temp1 = max( sn / aaqq, temp1 / aapp )
647* AAQQ = AAQQ*TEMP1
648* AAPP = AAPP*TEMP1
649 ELSE IF( ( aaqq.LE.sn ) .AND. ( aapp.GE.temp1 ) ) THEN
650 temp1 = min( sn / aaqq, big / ( dsqrt( dble( n ) )*aapp ) )
651* AAQQ = AAQQ*TEMP1
652* AAPP = AAPP*TEMP1
653 ELSE
654 temp1 = one
655 END IF
656*
657* Scale, if necessary
658*
659 IF( temp1.NE.one ) THEN
660 CALL dlascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr )
661 END IF
662 skl= temp1*skl
663 IF( skl.NE.one ) THEN
664 CALL dlascl( joba, 0, 0, one, skl, m, n, a, lda, ierr )
665 skl= one / skl
666 END IF
667*
668* Row-cyclic Jacobi SVD algorithm with column pivoting
669*
670 emptsw = ( n*( n-1 ) ) / 2
671 notrot = 0
672 fastr( 1 ) = zero
673*
674* A is represented in factored form A = A * diag(WORK), where diag(WORK)
675* is initialized to identity. WORK is updated during fast scaled
676* rotations.
677*
678 DO 1868 q = 1, n
679 work( q ) = one
680 1868 CONTINUE
681*
682*
683 swband = 3
684*[TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective
685* if DGESVJ is used as a computational routine in the preconditioned
686* Jacobi SVD algorithm DGESVJ. For sweeps i=1:SWBAND the procedure
687* works on pivots inside a band-like region around the diagonal.
688* The boundaries are determined dynamically, based on the number of
689* pivots above a threshold.
690*
691 kbl = min( 8, n )
692*[TP] KBL is a tuning parameter that defines the tile size in the
693* tiling of the p-q loops of pivot pairs. In general, an optimal
694* value of KBL depends on the matrix dimensions and on the
695* parameters of the computer's memory.
696*
697 nbl = n / kbl
698 IF( ( nbl*kbl ).NE.n )nbl = nbl + 1
699*
700 blskip = kbl**2
701*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
702*
703 rowskip = min( 5, kbl )
704*[TP] ROWSKIP is a tuning parameter.
705*
706 lkahead = 1
707*[TP] LKAHEAD is a tuning parameter.
708*
709* Quasi block transformations, using the lower (upper) triangular
710* structure of the input matrix. The quasi-block-cycling usually
711* invokes cubic convergence. Big part of this cycle is done inside
712* canonical subspaces of dimensions less than M.
713*
714 IF( ( lower .OR. upper ) .AND. ( n.GT.max( 64, 4*kbl ) ) ) THEN
715*[TP] The number of partition levels and the actual partition are
716* tuning parameters.
717 n4 = n / 4
718 n2 = n / 2
719 n34 = 3*n4
720 IF( applv ) THEN
721 q = 0
722 ELSE
723 q = 1
724 END IF
725*
726 IF( lower ) THEN
727*
728* This works very well on lower triangular matrices, in particular
729* in the framework of the preconditioned Jacobi SVD (xGEJSV).
730* The idea is simple:
731* [+ 0 0 0] Note that Jacobi transformations of [0 0]
732* [+ + 0 0] [0 0]
733* [+ + x 0] actually work on [x 0] [x 0]
734* [+ + x x] [x x]. [x x]
735*
736 CALL dgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,
737 $ work( n34+1 ), sva( n34+1 ), mvl,
738 $ v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,
739 $ 2, work( n+1 ), lwork-n, ierr )
740*
741 CALL dgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,
742 $ work( n2+1 ), sva( n2+1 ), mvl,
743 $ v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2,
744 $ work( n+1 ), lwork-n, ierr )
745*
746 CALL dgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,
747 $ work( n2+1 ), sva( n2+1 ), mvl,
748 $ v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,
749 $ work( n+1 ), lwork-n, ierr )
750*
751 CALL dgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,
752 $ work( n4+1 ), sva( n4+1 ), mvl,
753 $ v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1,
754 $ work( n+1 ), lwork-n, ierr )
755*
756 CALL dgsvj0( jobv, m, n4, a, lda, work, sva, mvl, v, ldv,
757 $ epsln, sfmin, tol, 1, work( n+1 ), lwork-n,
758 $ ierr )
759*
760 CALL dgsvj1( jobv, m, n2, n4, a, lda, work, sva, mvl, v,
761 $ ldv, epsln, sfmin, tol, 1, work( n+1 ),
762 $ lwork-n, ierr )
763*
764*
765 ELSE IF( upper ) THEN
766*
767*
768 CALL dgsvj0( jobv, n4, n4, a, lda, work, sva, mvl, v, ldv,
769 $ epsln, sfmin, tol, 2, work( n+1 ), lwork-n,
770 $ ierr )
771*
772 CALL dgsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, work( n4+1 ),
773 $ sva( n4+1 ), mvl, v( n4*q+1, n4+1 ), ldv,
774 $ epsln, sfmin, tol, 1, work( n+1 ), lwork-n,
775 $ ierr )
776*
777 CALL dgsvj1( jobv, n2, n2, n4, a, lda, work, sva, mvl, v,
778 $ ldv, epsln, sfmin, tol, 1, work( n+1 ),
779 $ lwork-n, ierr )
780*
781 CALL dgsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,
782 $ work( n2+1 ), sva( n2+1 ), mvl,
783 $ v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,
784 $ work( n+1 ), lwork-n, ierr )
785
786 END IF
787*
788 END IF
789*
790* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
791*
792 DO 1993 i = 1, nsweep
793*
794* .. go go go ...
795*
796 mxaapq = zero
797 mxsinj = zero
798 iswrot = 0
799*
800 notrot = 0
801 pskipped = 0
802*
803* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs
804* 1 <= p < q <= N. This is the first step toward a blocked implementation
805* of the rotations. New implementation, based on block transformations,
806* is under development.
807*
808 DO 2000 ibr = 1, nbl
809*
810 igl = ( ibr-1 )*kbl + 1
811*
812 DO 1002 ir1 = 0, min( lkahead, nbl-ibr )
813*
814 igl = igl + ir1*kbl
815*
816 DO 2001 p = igl, min( igl+kbl-1, n-1 )
817*
818* .. de Rijk's pivoting
819*
820 q = idamax( n-p+1, sva( p ), 1 ) + p - 1
821 IF( p.NE.q ) THEN
822 CALL dswap( m, a( 1, p ), 1, a( 1, q ), 1 )
823 IF( rsvec )CALL dswap( mvl, v( 1, p ), 1,
824 $ v( 1, q ), 1 )
825 temp1 = sva( p )
826 sva( p ) = sva( q )
827 sva( q ) = temp1
828 temp1 = work( p )
829 work( p ) = work( q )
830 work( q ) = temp1
831 END IF
832*
833 IF( ir1.EQ.0 ) THEN
834*
835* Column norms are periodically updated by explicit
836* norm computation.
837* Caveat:
838* Unfortunately, some BLAS implementations compute DNRM2(M,A(1,p),1)
839* as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may cause the result to
840* overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and to
841* underflow for ||A(:,p)||_2 < DSQRT(underflow_threshold).
842* Hence, DNRM2 cannot be trusted, not even in the case when
843* the true norm is far from the under(over)flow boundaries.
844* If properly implemented DNRM2 is available, the IF-THEN-ELSE
845* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)".
846*
847 IF( ( sva( p ).LT.rootbig ) .AND.
848 $ ( sva( p ).GT.rootsfmin ) ) THEN
849 sva( p ) = dnrm2( m, a( 1, p ), 1 )*work( p )
850 ELSE
851 temp1 = zero
852 aapp = one
853 CALL dlassq( m, a( 1, p ), 1, temp1, aapp )
854 sva( p ) = temp1*dsqrt( aapp )*work( p )
855 END IF
856 aapp = sva( p )
857 ELSE
858 aapp = sva( p )
859 END IF
860*
861 IF( aapp.GT.zero ) THEN
862*
863 pskipped = 0
864*
865 DO 2002 q = p + 1, min( igl+kbl-1, n )
866*
867 aaqq = sva( q )
868*
869 IF( aaqq.GT.zero ) THEN
870*
871 aapp0 = aapp
872 IF( aaqq.GE.one ) THEN
873 rotok = ( small*aapp ).LE.aaqq
874 IF( aapp.LT.( big / aaqq ) ) THEN
875 aapq = ( ddot( m, a( 1, p ), 1, a( 1,
876 $ q ), 1 )*work( p )*work( q ) /
877 $ aaqq ) / aapp
878 ELSE
879 CALL dcopy( m, a( 1, p ), 1,
880 $ work( n+1 ), 1 )
881 CALL dlascl( 'G', 0, 0, aapp,
882 $ work( p ), m, 1,
883 $ work( n+1 ), lda, ierr )
884 aapq = ddot( m, work( n+1 ), 1,
885 $ a( 1, q ), 1 )*work( q ) / aaqq
886 END IF
887 ELSE
888 rotok = aapp.LE.( aaqq / small )
889 IF( aapp.GT.( small / aaqq ) ) THEN
890 aapq = ( ddot( m, a( 1, p ), 1, a( 1,
891 $ q ), 1 )*work( p )*work( q ) /
892 $ aaqq ) / aapp
893 ELSE
894 CALL dcopy( m, a( 1, q ), 1,
895 $ work( n+1 ), 1 )
896 CALL dlascl( 'G', 0, 0, aaqq,
897 $ work( q ), m, 1,
898 $ work( n+1 ), lda, ierr )
899 aapq = ddot( m, work( n+1 ), 1,
900 $ a( 1, p ), 1 )*work( p ) / aapp
901 END IF
902 END IF
903*
904 mxaapq = max( mxaapq, dabs( aapq ) )
905*
906* TO rotate or NOT to rotate, THAT is the question ...
907*
908 IF( dabs( aapq ).GT.tol ) THEN
909*
910* .. rotate
911*[RTD] ROTATED = ROTATED + ONE
912*
913 IF( ir1.EQ.0 ) THEN
914 notrot = 0
915 pskipped = 0
916 iswrot = iswrot + 1
917 END IF
918*
919 IF( rotok ) THEN
920*
921 aqoap = aaqq / aapp
922 apoaq = aapp / aaqq
923 theta = -half*dabs(aqoap-apoaq)/aapq
924*
925 IF( dabs( theta ).GT.bigtheta ) THEN
926*
927 t = half / theta
928 fastr( 3 ) = t*work( p ) / work( q )
929 fastr( 4 ) = -t*work( q ) /
930 $ work( p )
931 CALL drotm( m, a( 1, p ), 1,
932 $ a( 1, q ), 1, fastr )
933 IF( rsvec )CALL drotm( mvl,
934 $ v( 1, p ), 1,
935 $ v( 1, q ), 1,
936 $ fastr )
937 sva( q ) = aaqq*dsqrt( max( zero,
938 $ one+t*apoaq*aapq ) )
939 aapp = aapp*dsqrt( max( zero,
940 $ one-t*aqoap*aapq ) )
941 mxsinj = max( mxsinj, dabs( t ) )
942*
943 ELSE
944*
945* .. choose correct signum for THETA and rotate
946*
947 thsign = -dsign( one, aapq )
948 t = one / ( theta+thsign*
949 $ dsqrt( one+theta*theta ) )
950 cs = dsqrt( one / ( one+t*t ) )
951 sn = t*cs
952*
953 mxsinj = max( mxsinj, dabs( sn ) )
954 sva( q ) = aaqq*dsqrt( max( zero,
955 $ one+t*apoaq*aapq ) )
956 aapp = aapp*dsqrt( max( zero,
957 $ one-t*aqoap*aapq ) )
958*
959 apoaq = work( p ) / work( q )
960 aqoap = work( q ) / work( p )
961 IF( work( p ).GE.one ) THEN
962 IF( work( q ).GE.one ) THEN
963 fastr( 3 ) = t*apoaq
964 fastr( 4 ) = -t*aqoap
965 work( p ) = work( p )*cs
966 work( q ) = work( q )*cs
967 CALL drotm( m, a( 1, p ), 1,
968 $ a( 1, q ), 1,
969 $ fastr )
970 IF( rsvec )CALL drotm( mvl,
971 $ v( 1, p ), 1, v( 1, q ),
972 $ 1, fastr )
973 ELSE
974 CALL daxpy( m, -t*aqoap,
975 $ a( 1, q ), 1,
976 $ a( 1, p ), 1 )
977 CALL daxpy( m, cs*sn*apoaq,
978 $ a( 1, p ), 1,
979 $ a( 1, q ), 1 )
980 work( p ) = work( p )*cs
981 work( q ) = work( q ) / cs
982 IF( rsvec ) THEN
983 CALL daxpy( mvl, -t*aqoap,
984 $ v( 1, q ), 1,
985 $ v( 1, p ), 1 )
986 CALL daxpy( mvl,
987 $ cs*sn*apoaq,
988 $ v( 1, p ), 1,
989 $ v( 1, q ), 1 )
990 END IF
991 END IF
992 ELSE
993 IF( work( q ).GE.one ) THEN
994 CALL daxpy( m, t*apoaq,
995 $ a( 1, p ), 1,
996 $ a( 1, q ), 1 )
997 CALL daxpy( m, -cs*sn*aqoap,
998 $ a( 1, q ), 1,
999 $ a( 1, p ), 1 )
1000 work( p ) = work( p ) / cs
1001 work( q ) = work( q )*cs
1002 IF( rsvec ) THEN
1003 CALL daxpy( mvl, t*apoaq,
1004 $ v( 1, p ), 1,
1005 $ v( 1, q ), 1 )
1006 CALL daxpy( mvl,
1007 $ -cs*sn*aqoap,
1008 $ v( 1, q ), 1,
1009 $ v( 1, p ), 1 )
1010 END IF
1011 ELSE
1012 IF( work( p ).GE.work( q ) )
1013 $ THEN
1014 CALL daxpy( m, -t*aqoap,
1015 $ a( 1, q ), 1,
1016 $ a( 1, p ), 1 )
1017 CALL daxpy( m, cs*sn*apoaq,
1018 $ a( 1, p ), 1,
1019 $ a( 1, q ), 1 )
1020 work( p ) = work( p )*cs
1021 work( q ) = work( q ) / cs
1022 IF( rsvec ) THEN
1023 CALL daxpy( mvl,
1024 $ -t*aqoap,
1025 $ v( 1, q ), 1,
1026 $ v( 1, p ), 1 )
1027 CALL daxpy( mvl,
1028 $ cs*sn*apoaq,
1029 $ v( 1, p ), 1,
1030 $ v( 1, q ), 1 )
1031 END IF
1032 ELSE
1033 CALL daxpy( m, t*apoaq,
1034 $ a( 1, p ), 1,
1035 $ a( 1, q ), 1 )
1036 CALL daxpy( m,
1037 $ -cs*sn*aqoap,
1038 $ a( 1, q ), 1,
1039 $ a( 1, p ), 1 )
1040 work( p ) = work( p ) / cs
1041 work( q ) = work( q )*cs
1042 IF( rsvec ) THEN
1043 CALL daxpy( mvl,
1044 $ t*apoaq, v( 1, p ),
1045 $ 1, v( 1, q ), 1 )
1046 CALL daxpy( mvl,
1047 $ -cs*sn*aqoap,
1048 $ v( 1, q ), 1,
1049 $ v( 1, p ), 1 )
1050 END IF
1051 END IF
1052 END IF
1053 END IF
1054 END IF
1055*
1056 ELSE
1057* .. have to use modified Gram-Schmidt like transformation
1058 CALL dcopy( m, a( 1, p ), 1,
1059 $ work( n+1 ), 1 )
1060 CALL dlascl( 'G', 0, 0, aapp, one, m,
1061 $ 1, work( n+1 ), lda,
1062 $ ierr )
1063 CALL dlascl( 'G', 0, 0, aaqq, one, m,
1064 $ 1, a( 1, q ), lda, ierr )
1065 temp1 = -aapq*work( p ) / work( q )
1066 CALL daxpy( m, temp1, work( n+1 ), 1,
1067 $ a( 1, q ), 1 )
1068 CALL dlascl( 'G', 0, 0, one, aaqq, m,
1069 $ 1, a( 1, q ), lda, ierr )
1070 sva( q ) = aaqq*dsqrt( max( zero,
1071 $ one-aapq*aapq ) )
1072 mxsinj = max( mxsinj, sfmin )
1073 END IF
1074* END IF ROTOK THEN ... ELSE
1075*
1076* In the case of cancellation in updating SVA(q), SVA(p)
1077* recompute SVA(q), SVA(p).
1078*
1079 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
1080 $ THEN
1081 IF( ( aaqq.LT.rootbig ) .AND.
1082 $ ( aaqq.GT.rootsfmin ) ) THEN
1083 sva( q ) = dnrm2( m, a( 1, q ), 1 )*
1084 $ work( q )
1085 ELSE
1086 t = zero
1087 aaqq = one
1088 CALL dlassq( m, a( 1, q ), 1, t,
1089 $ aaqq )
1090 sva( q ) = t*dsqrt( aaqq )*work( q )
1091 END IF
1092 END IF
1093 IF( ( aapp / aapp0 ).LE.rooteps ) THEN
1094 IF( ( aapp.LT.rootbig ) .AND.
1095 $ ( aapp.GT.rootsfmin ) ) THEN
1096 aapp = dnrm2( m, a( 1, p ), 1 )*
1097 $ work( p )
1098 ELSE
1099 t = zero
1100 aapp = one
1101 CALL dlassq( m, a( 1, p ), 1, t,
1102 $ aapp )
1103 aapp = t*dsqrt( aapp )*work( p )
1104 END IF
1105 sva( p ) = aapp
1106 END IF
1107*
1108 ELSE
1109* A(:,p) and A(:,q) already numerically orthogonal
1110 IF( ir1.EQ.0 )notrot = notrot + 1
1111*[RTD] SKIPPED = SKIPPED + 1
1112 pskipped = pskipped + 1
1113 END IF
1114 ELSE
1115* A(:,q) is zero column
1116 IF( ir1.EQ.0 )notrot = notrot + 1
1117 pskipped = pskipped + 1
1118 END IF
1119*
1120 IF( ( i.LE.swband ) .AND.
1121 $ ( pskipped.GT.rowskip ) ) THEN
1122 IF( ir1.EQ.0 )aapp = -aapp
1123 notrot = 0
1124 GO TO 2103
1125 END IF
1126*
1127 2002 CONTINUE
1128* END q-LOOP
1129*
1130 2103 CONTINUE
1131* bailed out of q-loop
1132*
1133 sva( p ) = aapp
1134*
1135 ELSE
1136 sva( p ) = aapp
1137 IF( ( ir1.EQ.0 ) .AND. ( aapp.EQ.zero ) )
1138 $ notrot = notrot + min( igl+kbl-1, n ) - p
1139 END IF
1140*
1141 2001 CONTINUE
1142* end of the p-loop
1143* end of doing the block ( ibr, ibr )
1144 1002 CONTINUE
1145* end of ir1-loop
1146*
1147* ... go to the off diagonal blocks
1148*
1149 igl = ( ibr-1 )*kbl + 1
1150*
1151 DO 2010 jbc = ibr + 1, nbl
1152*
1153 jgl = ( jbc-1 )*kbl + 1
1154*
1155* doing the block at ( ibr, jbc )
1156*
1157 ijblsk = 0
1158 DO 2100 p = igl, min( igl+kbl-1, n )
1159*
1160 aapp = sva( p )
1161 IF( aapp.GT.zero ) THEN
1162*
1163 pskipped = 0
1164*
1165 DO 2200 q = jgl, min( jgl+kbl-1, n )
1166*
1167 aaqq = sva( q )
1168 IF( aaqq.GT.zero ) THEN
1169 aapp0 = aapp
1170*
1171* .. M x 2 Jacobi SVD ..
1172*
1173* Safe Gram matrix computation
1174*
1175 IF( aaqq.GE.one ) THEN
1176 IF( aapp.GE.aaqq ) THEN
1177 rotok = ( small*aapp ).LE.aaqq
1178 ELSE
1179 rotok = ( small*aaqq ).LE.aapp
1180 END IF
1181 IF( aapp.LT.( big / aaqq ) ) THEN
1182 aapq = ( ddot( m, a( 1, p ), 1, a( 1,
1183 $ q ), 1 )*work( p )*work( q ) /
1184 $ aaqq ) / aapp
1185 ELSE
1186 CALL dcopy( m, a( 1, p ), 1,
1187 $ work( n+1 ), 1 )
1188 CALL dlascl( 'G', 0, 0, aapp,
1189 $ work( p ), m, 1,
1190 $ work( n+1 ), lda, ierr )
1191 aapq = ddot( m, work( n+1 ), 1,
1192 $ a( 1, q ), 1 )*work( q ) / aaqq
1193 END IF
1194 ELSE
1195 IF( aapp.GE.aaqq ) THEN
1196 rotok = aapp.LE.( aaqq / small )
1197 ELSE
1198 rotok = aaqq.LE.( aapp / small )
1199 END IF
1200 IF( aapp.GT.( small / aaqq ) ) THEN
1201 aapq = ( ddot( m, a( 1, p ), 1, a( 1,
1202 $ q ), 1 )*work( p )*work( q ) /
1203 $ aaqq ) / aapp
1204 ELSE
1205 CALL dcopy( m, a( 1, q ), 1,
1206 $ work( n+1 ), 1 )
1207 CALL dlascl( 'G', 0, 0, aaqq,
1208 $ work( q ), m, 1,
1209 $ work( n+1 ), lda, ierr )
1210 aapq = ddot( m, work( n+1 ), 1,
1211 $ a( 1, p ), 1 )*work( p ) / aapp
1212 END IF
1213 END IF
1214*
1215 mxaapq = max( mxaapq, dabs( aapq ) )
1216*
1217* TO rotate or NOT to rotate, THAT is the question ...
1218*
1219 IF( dabs( aapq ).GT.tol ) THEN
1220 notrot = 0
1221*[RTD] ROTATED = ROTATED + 1
1222 pskipped = 0
1223 iswrot = iswrot + 1
1224*
1225 IF( rotok ) THEN
1226*
1227 aqoap = aaqq / aapp
1228 apoaq = aapp / aaqq
1229 theta = -half*dabs(aqoap-apoaq)/aapq
1230 IF( aaqq.GT.aapp0 )theta = -theta
1231*
1232 IF( dabs( theta ).GT.bigtheta ) THEN
1233 t = half / theta
1234 fastr( 3 ) = t*work( p ) / work( q )
1235 fastr( 4 ) = -t*work( q ) /
1236 $ work( p )
1237 CALL drotm( m, a( 1, p ), 1,
1238 $ a( 1, q ), 1, fastr )
1239 IF( rsvec )CALL drotm( mvl,
1240 $ v( 1, p ), 1,
1241 $ v( 1, q ), 1,
1242 $ fastr )
1243 sva( q ) = aaqq*dsqrt( max( zero,
1244 $ one+t*apoaq*aapq ) )
1245 aapp = aapp*dsqrt( max( zero,
1246 $ one-t*aqoap*aapq ) )
1247 mxsinj = max( mxsinj, dabs( t ) )
1248 ELSE
1249*
1250* .. choose correct signum for THETA and rotate
1251*
1252 thsign = -dsign( one, aapq )
1253 IF( aaqq.GT.aapp0 )thsign = -thsign
1254 t = one / ( theta+thsign*
1255 $ dsqrt( one+theta*theta ) )
1256 cs = dsqrt( one / ( one+t*t ) )
1257 sn = t*cs
1258 mxsinj = max( mxsinj, dabs( sn ) )
1259 sva( q ) = aaqq*dsqrt( max( zero,
1260 $ one+t*apoaq*aapq ) )
1261 aapp = aapp*dsqrt( max( zero,
1262 $ one-t*aqoap*aapq ) )
1263*
1264 apoaq = work( p ) / work( q )
1265 aqoap = work( q ) / work( p )
1266 IF( work( p ).GE.one ) THEN
1267*
1268 IF( work( q ).GE.one ) THEN
1269 fastr( 3 ) = t*apoaq
1270 fastr( 4 ) = -t*aqoap
1271 work( p ) = work( p )*cs
1272 work( q ) = work( q )*cs
1273 CALL drotm( m, a( 1, p ), 1,
1274 $ a( 1, q ), 1,
1275 $ fastr )
1276 IF( rsvec )CALL drotm( mvl,
1277 $ v( 1, p ), 1, v( 1, q ),
1278 $ 1, fastr )
1279 ELSE
1280 CALL daxpy( m, -t*aqoap,
1281 $ a( 1, q ), 1,
1282 $ a( 1, p ), 1 )
1283 CALL daxpy( m, cs*sn*apoaq,
1284 $ a( 1, p ), 1,
1285 $ a( 1, q ), 1 )
1286 IF( rsvec ) THEN
1287 CALL daxpy( mvl, -t*aqoap,
1288 $ v( 1, q ), 1,
1289 $ v( 1, p ), 1 )
1290 CALL daxpy( mvl,
1291 $ cs*sn*apoaq,
1292 $ v( 1, p ), 1,
1293 $ v( 1, q ), 1 )
1294 END IF
1295 work( p ) = work( p )*cs
1296 work( q ) = work( q ) / cs
1297 END IF
1298 ELSE
1299 IF( work( q ).GE.one ) THEN
1300 CALL daxpy( m, t*apoaq,
1301 $ a( 1, p ), 1,
1302 $ a( 1, q ), 1 )
1303 CALL daxpy( m, -cs*sn*aqoap,
1304 $ a( 1, q ), 1,
1305 $ a( 1, p ), 1 )
1306 IF( rsvec ) THEN
1307 CALL daxpy( mvl, t*apoaq,
1308 $ v( 1, p ), 1,
1309 $ v( 1, q ), 1 )
1310 CALL daxpy( mvl,
1311 $ -cs*sn*aqoap,
1312 $ v( 1, q ), 1,
1313 $ v( 1, p ), 1 )
1314 END IF
1315 work( p ) = work( p ) / cs
1316 work( q ) = work( q )*cs
1317 ELSE
1318 IF( work( p ).GE.work( q ) )
1319 $ THEN
1320 CALL daxpy( m, -t*aqoap,
1321 $ a( 1, q ), 1,
1322 $ a( 1, p ), 1 )
1323 CALL daxpy( m, cs*sn*apoaq,
1324 $ a( 1, p ), 1,
1325 $ a( 1, q ), 1 )
1326 work( p ) = work( p )*cs
1327 work( q ) = work( q ) / cs
1328 IF( rsvec ) THEN
1329 CALL daxpy( mvl,
1330 $ -t*aqoap,
1331 $ v( 1, q ), 1,
1332 $ v( 1, p ), 1 )
1333 CALL daxpy( mvl,
1334 $ cs*sn*apoaq,
1335 $ v( 1, p ), 1,
1336 $ v( 1, q ), 1 )
1337 END IF
1338 ELSE
1339 CALL daxpy( m, t*apoaq,
1340 $ a( 1, p ), 1,
1341 $ a( 1, q ), 1 )
1342 CALL daxpy( m,
1343 $ -cs*sn*aqoap,
1344 $ a( 1, q ), 1,
1345 $ a( 1, p ), 1 )
1346 work( p ) = work( p ) / cs
1347 work( q ) = work( q )*cs
1348 IF( rsvec ) THEN
1349 CALL daxpy( mvl,
1350 $ t*apoaq, v( 1, p ),
1351 $ 1, v( 1, q ), 1 )
1352 CALL daxpy( mvl,
1353 $ -cs*sn*aqoap,
1354 $ v( 1, q ), 1,
1355 $ v( 1, p ), 1 )
1356 END IF
1357 END IF
1358 END IF
1359 END IF
1360 END IF
1361*
1362 ELSE
1363 IF( aapp.GT.aaqq ) THEN
1364 CALL dcopy( m, a( 1, p ), 1,
1365 $ work( n+1 ), 1 )
1366 CALL dlascl( 'G', 0, 0, aapp, one,
1367 $ m, 1, work( n+1 ), lda,
1368 $ ierr )
1369 CALL dlascl( 'G', 0, 0, aaqq, one,
1370 $ m, 1, a( 1, q ), lda,
1371 $ ierr )
1372 temp1 = -aapq*work( p ) / work( q )
1373 CALL daxpy( m, temp1, work( n+1 ),
1374 $ 1, a( 1, q ), 1 )
1375 CALL dlascl( 'G', 0, 0, one, aaqq,
1376 $ m, 1, a( 1, q ), lda,
1377 $ ierr )
1378 sva( q ) = aaqq*dsqrt( max( zero,
1379 $ one-aapq*aapq ) )
1380 mxsinj = max( mxsinj, sfmin )
1381 ELSE
1382 CALL dcopy( m, a( 1, q ), 1,
1383 $ work( n+1 ), 1 )
1384 CALL dlascl( 'G', 0, 0, aaqq, one,
1385 $ m, 1, work( n+1 ), lda,
1386 $ ierr )
1387 CALL dlascl( 'G', 0, 0, aapp, one,
1388 $ m, 1, a( 1, p ), lda,
1389 $ ierr )
1390 temp1 = -aapq*work( q ) / work( p )
1391 CALL daxpy( m, temp1, work( n+1 ),
1392 $ 1, a( 1, p ), 1 )
1393 CALL dlascl( 'G', 0, 0, one, aapp,
1394 $ m, 1, a( 1, p ), lda,
1395 $ ierr )
1396 sva( p ) = aapp*dsqrt( max( zero,
1397 $ one-aapq*aapq ) )
1398 mxsinj = max( mxsinj, sfmin )
1399 END IF
1400 END IF
1401* END IF ROTOK THEN ... ELSE
1402*
1403* In the case of cancellation in updating SVA(q)
1404* .. recompute SVA(q)
1405 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
1406 $ THEN
1407 IF( ( aaqq.LT.rootbig ) .AND.
1408 $ ( aaqq.GT.rootsfmin ) ) THEN
1409 sva( q ) = dnrm2( m, a( 1, q ), 1 )*
1410 $ work( q )
1411 ELSE
1412 t = zero
1413 aaqq = one
1414 CALL dlassq( m, a( 1, q ), 1, t,
1415 $ aaqq )
1416 sva( q ) = t*dsqrt( aaqq )*work( q )
1417 END IF
1418 END IF
1419 IF( ( aapp / aapp0 )**2.LE.rooteps ) THEN
1420 IF( ( aapp.LT.rootbig ) .AND.
1421 $ ( aapp.GT.rootsfmin ) ) THEN
1422 aapp = dnrm2( m, a( 1, p ), 1 )*
1423 $ work( p )
1424 ELSE
1425 t = zero
1426 aapp = one
1427 CALL dlassq( m, a( 1, p ), 1, t,
1428 $ aapp )
1429 aapp = t*dsqrt( aapp )*work( p )
1430 END IF
1431 sva( p ) = aapp
1432 END IF
1433* end of OK rotation
1434 ELSE
1435 notrot = notrot + 1
1436*[RTD] SKIPPED = SKIPPED + 1
1437 pskipped = pskipped + 1
1438 ijblsk = ijblsk + 1
1439 END IF
1440 ELSE
1441 notrot = notrot + 1
1442 pskipped = pskipped + 1
1443 ijblsk = ijblsk + 1
1444 END IF
1445*
1446 IF( ( i.LE.swband ) .AND. ( ijblsk.GE.blskip ) )
1447 $ THEN
1448 sva( p ) = aapp
1449 notrot = 0
1450 GO TO 2011
1451 END IF
1452 IF( ( i.LE.swband ) .AND.
1453 $ ( pskipped.GT.rowskip ) ) THEN
1454 aapp = -aapp
1455 notrot = 0
1456 GO TO 2203
1457 END IF
1458*
1459 2200 CONTINUE
1460* end of the q-loop
1461 2203 CONTINUE
1462*
1463 sva( p ) = aapp
1464*
1465 ELSE
1466*
1467 IF( aapp.EQ.zero )notrot = notrot +
1468 $ min( jgl+kbl-1, n ) - jgl + 1
1469 IF( aapp.LT.zero )notrot = 0
1470*
1471 END IF
1472*
1473 2100 CONTINUE
1474* end of the p-loop
1475 2010 CONTINUE
1476* end of the jbc-loop
1477 2011 CONTINUE
1478*2011 bailed out of the jbc-loop
1479 DO 2012 p = igl, min( igl+kbl-1, n )
1480 sva( p ) = dabs( sva( p ) )
1481 2012 CONTINUE
1482***
1483 2000 CONTINUE
1484*2000 :: end of the ibr-loop
1485*
1486* .. update SVA(N)
1487 IF( ( sva( n ).LT.rootbig ) .AND. ( sva( n ).GT.rootsfmin ) )
1488 $ THEN
1489 sva( n ) = dnrm2( m, a( 1, n ), 1 )*work( n )
1490 ELSE
1491 t = zero
1492 aapp = one
1493 CALL dlassq( m, a( 1, n ), 1, t, aapp )
1494 sva( n ) = t*dsqrt( aapp )*work( n )
1495 END IF
1496*
1497* Additional steering devices
1498*
1499 IF( ( i.LT.swband ) .AND. ( ( mxaapq.LE.roottol ) .OR.
1500 $ ( iswrot.LE.n ) ) )swband = i
1501*
1502 IF( ( i.GT.swband+1 ) .AND. ( mxaapq.LT.dsqrt( dble( n ) )*
1503 $ tol ) .AND. ( dble( n )*mxaapq*mxsinj.LT.tol ) ) THEN
1504 GO TO 1994
1505 END IF
1506*
1507 IF( notrot.GE.emptsw )GO TO 1994
1508*
1509 1993 CONTINUE
1510* end i=1:NSWEEP loop
1511*
1512* #:( Reaching this point means that the procedure has not converged.
1513 info = nsweep - 1
1514 GO TO 1995
1515*
1516 1994 CONTINUE
1517* #:) Reaching this point means numerical convergence after the i-th
1518* sweep.
1519*
1520 info = 0
1521* #:) INFO = 0 confirms successful iterations.
1522 1995 CONTINUE
1523*
1524* Sort the singular values and find how many are above
1525* the underflow threshold.
1526*
1527 n2 = 0
1528 n4 = 0
1529 DO 5991 p = 1, n - 1
1530 q = idamax( n-p+1, sva( p ), 1 ) + p - 1
1531 IF( p.NE.q ) THEN
1532 temp1 = sva( p )
1533 sva( p ) = sva( q )
1534 sva( q ) = temp1
1535 temp1 = work( p )
1536 work( p ) = work( q )
1537 work( q ) = temp1
1538 CALL dswap( m, a( 1, p ), 1, a( 1, q ), 1 )
1539 IF( rsvec )CALL dswap( mvl, v( 1, p ), 1, v( 1, q ), 1 )
1540 END IF
1541 IF( sva( p ).NE.zero ) THEN
1542 n4 = n4 + 1
1543 IF( sva( p )*skl.GT.sfmin )n2 = n2 + 1
1544 END IF
1545 5991 CONTINUE
1546 IF( sva( n ).NE.zero ) THEN
1547 n4 = n4 + 1
1548 IF( sva( n )*skl.GT.sfmin )n2 = n2 + 1
1549 END IF
1550*
1551* Normalize the left singular vectors.
1552*
1553 IF( lsvec .OR. uctol ) THEN
1554 DO 1998 p = 1, n2
1555 CALL dscal( m, work( p ) / sva( p ), a( 1, p ), 1 )
1556 1998 CONTINUE
1557 END IF
1558*
1559* Scale the product of Jacobi rotations (assemble the fast rotations).
1560*
1561 IF( rsvec ) THEN
1562 IF( applv ) THEN
1563 DO 2398 p = 1, n
1564 CALL dscal( mvl, work( p ), v( 1, p ), 1 )
1565 2398 CONTINUE
1566 ELSE
1567 DO 2399 p = 1, n
1568 temp1 = one / dnrm2( mvl, v( 1, p ), 1 )
1569 CALL dscal( mvl, temp1, v( 1, p ), 1 )
1570 2399 CONTINUE
1571 END IF
1572 END IF
1573*
1574* Undo scaling, if necessary (and possible).
1575 IF( ( ( skl.GT.one ) .AND. ( sva( 1 ).LT.( big / skl) ) )
1576 $ .OR. ( ( skl.LT.one ) .AND. ( sva( max( n2, 1 ) ) .GT.
1577 $ ( sfmin / skl) ) ) ) THEN
1578 DO 2400 p = 1, n
1579 sva( p ) = skl*sva( p )
1580 2400 CONTINUE
1581 skl= one
1582 END IF
1583*
1584 work( 1 ) = skl
1585* The singular values of A are SKL*SVA(1:N). If SKL.NE.ONE
1586* then some of the singular values may overflow or underflow and
1587* the spectrum is given in this factored representation.
1588*
1589 work( 2 ) = dble( n4 )
1590* N4 is the number of computed nonzero singular values of A.
1591*
1592 work( 3 ) = dble( n2 )
1593* N2 is the number of singular values of A greater than SFMIN.
1594* If N2<N, SVA(N2:N) contains ZEROS and/or denormalized numbers
1595* that may carry some information.
1596*
1597 work( 4 ) = dble( i )
1598* i is the index of the last sweep before declaring convergence.
1599*
1600 work( 5 ) = mxaapq
1601* MXAAPQ is the largest absolute value of scaled pivots in the
1602* last sweep
1603*
1604 work( 6 ) = mxsinj
1605* MXSINJ is the largest absolute value of the sines of Jacobi angles
1606* in the last sweep
1607*
1608 RETURN
1609* ..
1610* .. END OF DGESVJ
1611* ..
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
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
dgsvj0
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.
Definition dgsvj0.f:218
dgsvj1
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 pivot...
Definition dgsvj1.f:236
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

◆ dgetf2()

subroutine dgetf2 ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

DGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm).

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

Purpose:
!>
!> DGETF2 computes an LU factorization of a general m-by-n matrix A
!> using partial pivoting with row interchanges.
!>
!> The factorization has the form
!>    A = P * L * U
!> where P is a permutation matrix, L is lower triangular with unit
!> diagonal elements (lower trapezoidal if m > n), and U is upper
!> triangular (upper trapezoidal if m < n).
!>
!> This is the right-looking Level 2 BLAS version of the algorithm.
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the m by n matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A = P*L*U; the unit diagonal elements of L are not stored.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices; for 1 <= i <= min(M,N), row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
!>               has been completed, but the factor U 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.

Definition at line 107 of file dgetf2.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 INTEGER INFO, LDA, M, N
115* ..
116* .. Array Arguments ..
117 INTEGER IPIV( * )
118 DOUBLE PRECISION A( LDA, * )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 DOUBLE PRECISION ONE, ZERO
125 parameter( one = 1.0d+0, zero = 0.0d+0 )
126* ..
127* .. Local Scalars ..
128 DOUBLE PRECISION SFMIN
129 INTEGER I, J, JP
130* ..
131* .. External Functions ..
132 DOUBLE PRECISION DLAMCH
133 INTEGER IDAMAX
134 EXTERNAL dlamch, idamax
135* ..
136* .. External Subroutines ..
137 EXTERNAL dger, dscal, dswap, xerbla
138* ..
139* .. Intrinsic Functions ..
140 INTRINSIC max, min
141* ..
142* .. Executable Statements ..
143*
144* Test the input parameters.
145*
146 info = 0
147 IF( m.LT.0 ) THEN
148 info = -1
149 ELSE IF( n.LT.0 ) THEN
150 info = -2
151 ELSE IF( lda.LT.max( 1, m ) ) THEN
152 info = -4
153 END IF
154 IF( info.NE.0 ) THEN
155 CALL xerbla( 'DGETF2', -info )
156 RETURN
157 END IF
158*
159* Quick return if possible
160*
161 IF( m.EQ.0 .OR. n.EQ.0 )
162 $ RETURN
163*
164* Compute machine safe minimum
165*
166 sfmin = dlamch('S')
167*
168 DO 10 j = 1, min( m, n )
169*
170* Find pivot and test for singularity.
171*
172 jp = j - 1 + idamax( m-j+1, a( j, j ), 1 )
173 ipiv( j ) = jp
174 IF( a( jp, j ).NE.zero ) THEN
175*
176* Apply the interchange to columns 1:N.
177*
178 IF( jp.NE.j )
179 $ CALL dswap( n, a( j, 1 ), lda, a( jp, 1 ), lda )
180*
181* Compute elements J+1:M of J-th column.
182*
183 IF( j.LT.m ) THEN
184 IF( abs(a( j, j )) .GE. sfmin ) THEN
185 CALL dscal( m-j, one / a( j, j ), a( j+1, j ), 1 )
186 ELSE
187 DO 20 i = 1, m-j
188 a( j+i, j ) = a( j+i, j ) / a( j, j )
189 20 CONTINUE
190 END IF
191 END IF
192*
193 ELSE IF( info.EQ.0 ) THEN
194*
195 info = j
196 END IF
197*
198 IF( j.LT.min( m, n ) ) THEN
199*
200* Update trailing submatrix.
201*
202 CALL dger( m-j, n-j, -one, a( j+1, j ), 1, a( j, j+1 ), lda,
203 $ a( j+1, j+1 ), lda )
204 END IF
205 10 CONTINUE
206 RETURN
207*
208* End of DGETF2
209*

◆ dgetrf()

subroutine dgetrf ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

DGETRF

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

Purpose:
!>
!> DGETRF computes an LU factorization of a general M-by-N matrix A
!> using partial pivoting with row interchanges.
!>
!> The factorization has the form
!>    A = P * L * U
!> where P is a permutation matrix, L is lower triangular with unit
!> diagonal elements (lower trapezoidal if m > n), and U is upper
!> triangular (upper trapezoidal if m < n).
!>
!> This is the right-looking Level 3 BLAS version of the algorithm.
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A = P*L*U; the unit diagonal elements of L are not stored.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices; for 1 <= i <= min(M,N), row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
!>                has been completed, but the factor U 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.

Definition at line 107 of file dgetrf.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 INTEGER INFO, LDA, M, N
115* ..
116* .. Array Arguments ..
117 INTEGER IPIV( * )
118 DOUBLE PRECISION A( LDA, * )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 DOUBLE PRECISION ONE
125 parameter( one = 1.0d+0 )
126* ..
127* .. Local Scalars ..
128 INTEGER I, IINFO, J, JB, NB
129* ..
130* .. External Subroutines ..
131 EXTERNAL dgemm, dgetrf2, dlaswp, dtrsm, xerbla
132* ..
133* .. External Functions ..
134 INTEGER ILAENV
135 EXTERNAL ilaenv
136* ..
137* .. Intrinsic Functions ..
138 INTRINSIC max, min
139* ..
140* .. Executable Statements ..
141*
142* Test the input parameters.
143*
144 info = 0
145 IF( m.LT.0 ) THEN
146 info = -1
147 ELSE IF( n.LT.0 ) THEN
148 info = -2
149 ELSE IF( lda.LT.max( 1, m ) ) THEN
150 info = -4
151 END IF
152 IF( info.NE.0 ) THEN
153 CALL xerbla( 'DGETRF', -info )
154 RETURN
155 END IF
156*
157* Quick return if possible
158*
159 IF( m.EQ.0 .OR. n.EQ.0 )
160 $ RETURN
161*
162* Determine the block size for this environment.
163*
164 nb = ilaenv( 1, 'DGETRF', ' ', m, n, -1, -1 )
165 IF( nb.LE.1 .OR. nb.GE.min( m, n ) ) THEN
166*
167* Use unblocked code.
168*
169 CALL dgetrf2( m, n, a, lda, ipiv, info )
170 ELSE
171*
172* Use blocked code.
173*
174 DO 20 j = 1, min( m, n ), nb
175 jb = min( min( m, n )-j+1, nb )
176*
177* Factor diagonal and subdiagonal blocks and test for exact
178* singularity.
179*
180 CALL dgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo )
181*
182* Adjust INFO and the pivot indices.
183*
184 IF( info.EQ.0 .AND. iinfo.GT.0 )
185 $ info = iinfo + j - 1
186 DO 10 i = j, min( m, j+jb-1 )
187 ipiv( i ) = j - 1 + ipiv( i )
188 10 CONTINUE
189*
190* Apply interchanges to columns 1:J-1.
191*
192 CALL dlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1 )
193*
194 IF( j+jb.LE.n ) THEN
195*
196* Apply interchanges to columns J+JB:N.
197*
198 CALL dlaswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,
199 $ ipiv, 1 )
200*
201* Compute block row of U.
202*
203 CALL dtrsm( 'Left', 'Lower', 'No transpose', 'Unit', jb,
204 $ n-j-jb+1, one, a( j, j ), lda, a( j, j+jb ),
205 $ lda )
206 IF( j+jb.LE.m ) THEN
207*
208* Update trailing submatrix.
209*
210 CALL dgemm( 'No transpose', 'No transpose', m-j-jb+1,
211 $ n-j-jb+1, jb, -one, a( j+jb, j ), lda,
212 $ a( j, j+jb ), lda, one, a( j+jb, j+jb ),
213 $ lda )
214 END IF
215 END IF
216 20 CONTINUE
217 END IF
218 RETURN
219*
220* End of DGETRF
221*
dgetrf2
recursive subroutine dgetrf2(m, n, a, lda, ipiv, info)
DGETRF2
Definition dgetrf2.f:113
dlaswp
subroutine dlaswp(n, a, lda, k1, k2, ipiv, incx)
DLASWP performs a series of row interchanges on a general rectangular matrix.
Definition dlaswp.f:115
dtrsm
subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRSM
Definition dtrsm.f:181

◆ dgetrf2()

recursive subroutine dgetrf2 ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

DGETRF2

Purpose:
!>
!> DGETRF2 computes an LU factorization of a general M-by-N matrix A
!> using partial pivoting with row interchanges.
!>
!> The factorization has the form
!>    A = P * L * U
!> where P is a permutation matrix, L is lower triangular with unit
!> diagonal elements (lower trapezoidal if m > n), and U is upper
!> triangular (upper trapezoidal if m < n).
!>
!> This is the recursive version of the algorithm. It divides
!> the matrix into four submatrices:
!>
!>        [  A11 | A12  ]  where A11 is n1 by n1 and A22 is n2 by n2
!>    A = [ -----|----- ]  with n1 = min(m,n)/2
!>        [  A21 | A22  ]       n2 = n-n1
!>
!>                                       [ A11 ]
!> The subroutine calls itself to factor [ --- ],
!>                                       [ A12 ]
!>                 [ A12 ]
!> do the swaps on [ --- ], solve A12, update A22,
!>                 [ A22 ]
!>
!> then calls itself to factor A22 and do the swaps on A21.
!>
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A = P*L*U; the unit diagonal elements of L are not stored.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices; for 1 <= i <= min(M,N), row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
!>                has been completed, but the factor U 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.

Definition at line 112 of file dgetrf2.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, LDA, M, N
120* ..
121* .. Array Arguments ..
122 INTEGER IPIV( * )
123 DOUBLE PRECISION A( LDA, * )
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 DOUBLE PRECISION SFMIN, TEMP
134 INTEGER I, IINFO, N1, N2
135* ..
136* .. External Functions ..
137 DOUBLE PRECISION DLAMCH
138 INTEGER IDAMAX
139 EXTERNAL dlamch, idamax
140* ..
141* .. External Subroutines ..
142 EXTERNAL dgemm, dscal, dlaswp, dtrsm, xerbla
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC max, min
146* ..
147* .. Executable Statements ..
148*
149* Test the input parameters
150*
151 info = 0
152 IF( m.LT.0 ) THEN
153 info = -1
154 ELSE IF( n.LT.0 ) THEN
155 info = -2
156 ELSE IF( lda.LT.max( 1, m ) ) THEN
157 info = -4
158 END IF
159 IF( info.NE.0 ) THEN
160 CALL xerbla( 'DGETRF2', -info )
161 RETURN
162 END IF
163*
164* Quick return if possible
165*
166 IF( m.EQ.0 .OR. n.EQ.0 )
167 $ RETURN
168
169 IF ( m.EQ.1 ) THEN
170*
171* Use unblocked code for one row case
172* Just need to handle IPIV and INFO
173*
174 ipiv( 1 ) = 1
175 IF ( a(1,1).EQ.zero )
176 $ info = 1
177*
178 ELSE IF( n.EQ.1 ) THEN
179*
180* Use unblocked code for one column case
181*
182*
183* Compute machine safe minimum
184*
185 sfmin = dlamch('S')
186*
187* Find pivot and test for singularity
188*
189 i = idamax( m, a( 1, 1 ), 1 )
190 ipiv( 1 ) = i
191 IF( a( i, 1 ).NE.zero ) THEN
192*
193* Apply the interchange
194*
195 IF( i.NE.1 ) THEN
196 temp = a( 1, 1 )
197 a( 1, 1 ) = a( i, 1 )
198 a( i, 1 ) = temp
199 END IF
200*
201* Compute elements 2:M of the column
202*
203 IF( abs(a( 1, 1 )) .GE. sfmin ) THEN
204 CALL dscal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 )
205 ELSE
206 DO 10 i = 1, m-1
207 a( 1+i, 1 ) = a( 1+i, 1 ) / a( 1, 1 )
208 10 CONTINUE
209 END IF
210*
211 ELSE
212 info = 1
213 END IF
214*
215 ELSE
216*
217* Use recursive code
218*
219 n1 = min( m, n ) / 2
220 n2 = n-n1
221*
222* [ A11 ]
223* Factor [ --- ]
224* [ A21 ]
225*
226 CALL dgetrf2( m, n1, a, lda, ipiv, iinfo )
227
228 IF ( info.EQ.0 .AND. iinfo.GT.0 )
229 $ info = iinfo
230*
231* [ A12 ]
232* Apply interchanges to [ --- ]
233* [ A22 ]
234*
235 CALL dlaswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 )
236*
237* Solve A12
238*
239 CALL dtrsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,
240 $ a( 1, n1+1 ), lda )
241*
242* Update A22
243*
244 CALL dgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,
245 $ a( 1, n1+1 ), lda, one, a( n1+1, n1+1 ), lda )
246*
247* Factor A22
248*
249 CALL dgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),
250 $ iinfo )
251*
252* Adjust INFO and the pivot indices
253*
254 IF ( info.EQ.0 .AND. iinfo.GT.0 )
255 $ info = iinfo + n1
256 DO 20 i = n1+1, min( m, n )
257 ipiv( i ) = ipiv( i ) + n1
258 20 CONTINUE
259*
260* Apply interchanges to A21
261*
262 CALL dlaswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 )
263*
264 END IF
265 RETURN
266*
267* End of DGETRF2
268*

◆ dgetri()

subroutine dgetri ( integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( * ) work,
integer lwork,
integer info )

DGETRI

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

Purpose:
!>
!> DGETRI computes the inverse of a matrix using the LU factorization
!> computed by DGETRF.
!>
!> This method inverts U and then computes inv(A) by solving the system
!> inv(A)*L = inv(U) for inv(A).
!>
Parameters
[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 factors L and U from the factorization
!>          A = P*L*U as computed by DGETRF.
!>          On exit, if INFO = 0, the inverse of the original matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from DGETRF; for 1<=i<=N, row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>          For optimal performance LWORK >= N*NB, where NB is
!>          the optimal blocksize returned by ILAENV.
!>
!>          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 INFO = i, U(i,i) is exactly zero; 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 113 of file dgetri.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, LDA, LWORK, N
121* ..
122* .. Array Arguments ..
123 INTEGER IPIV( * )
124 DOUBLE PRECISION A( LDA, * ), 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 LQUERY
135 INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
136 $ NBMIN, NN
137* ..
138* .. External Functions ..
139 INTEGER ILAENV
140 EXTERNAL ilaenv
141* ..
142* .. External Subroutines ..
143 EXTERNAL dgemm, dgemv, dswap, dtrsm, dtrtri, xerbla
144* ..
145* .. Intrinsic Functions ..
146 INTRINSIC max, min
147* ..
148* .. Executable Statements ..
149*
150* Test the input parameters.
151*
152 info = 0
153 nb = ilaenv( 1, 'DGETRI', ' ', n, -1, -1, -1 )
154 lwkopt = n*nb
155 work( 1 ) = lwkopt
156 lquery = ( lwork.EQ.-1 )
157 IF( n.LT.0 ) THEN
158 info = -1
159 ELSE IF( lda.LT.max( 1, n ) ) THEN
160 info = -3
161 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
162 info = -6
163 END IF
164 IF( info.NE.0 ) THEN
165 CALL xerbla( 'DGETRI', -info )
166 RETURN
167 ELSE IF( lquery ) THEN
168 RETURN
169 END IF
170*
171* Quick return if possible
172*
173 IF( n.EQ.0 )
174 $ RETURN
175*
176* Form inv(U). If INFO > 0 from DTRTRI, then U is singular,
177* and the inverse is not computed.
178*
179 CALL dtrtri( 'Upper', 'Non-unit', n, a, lda, info )
180 IF( info.GT.0 )
181 $ RETURN
182*
183 nbmin = 2
184 ldwork = n
185 IF( nb.GT.1 .AND. nb.LT.n ) THEN
186 iws = max( ldwork*nb, 1 )
187 IF( lwork.LT.iws ) THEN
188 nb = lwork / ldwork
189 nbmin = max( 2, ilaenv( 2, 'DGETRI', ' ', n, -1, -1, -1 ) )
190 END IF
191 ELSE
192 iws = n
193 END IF
194*
195* Solve the equation inv(A)*L = inv(U) for inv(A).
196*
197 IF( nb.LT.nbmin .OR. nb.GE.n ) THEN
198*
199* Use unblocked code.
200*
201 DO 20 j = n, 1, -1
202*
203* Copy current column of L to WORK and replace with zeros.
204*
205 DO 10 i = j + 1, n
206 work( i ) = a( i, j )
207 a( i, j ) = zero
208 10 CONTINUE
209*
210* Compute current column of inv(A).
211*
212 IF( j.LT.n )
213 $ CALL dgemv( 'No transpose', n, n-j, -one, a( 1, j+1 ),
214 $ lda, work( j+1 ), 1, one, a( 1, j ), 1 )
215 20 CONTINUE
216 ELSE
217*
218* Use blocked code.
219*
220 nn = ( ( n-1 ) / nb )*nb + 1
221 DO 50 j = nn, 1, -nb
222 jb = min( nb, n-j+1 )
223*
224* Copy current block column of L to WORK and replace with
225* zeros.
226*
227 DO 40 jj = j, j + jb - 1
228 DO 30 i = jj + 1, n
229 work( i+( jj-j )*ldwork ) = a( i, jj )
230 a( i, jj ) = zero
231 30 CONTINUE
232 40 CONTINUE
233*
234* Compute current block column of inv(A).
235*
236 IF( j+jb.LE.n )
237 $ CALL dgemm( 'No transpose', 'No transpose', n, jb,
238 $ n-j-jb+1, -one, a( 1, j+jb ), lda,
239 $ work( j+jb ), ldwork, one, a( 1, j ), lda )
240 CALL dtrsm( 'Right', 'Lower', 'No transpose', 'Unit', n, jb,
241 $ one, work( j ), ldwork, a( 1, j ), lda )
242 50 CONTINUE
243 END IF
244*
245* Apply column interchanges.
246*
247 DO 60 j = n - 1, 1, -1
248 jp = ipiv( j )
249 IF( jp.NE.j )
250 $ CALL dswap( n, a( 1, j ), 1, a( 1, jp ), 1 )
251 60 CONTINUE
252*
253 work( 1 ) = iws
254 RETURN
255*
256* End of DGETRI
257*
dtrtri
subroutine dtrtri(uplo, diag, n, a, lda, info)
DTRTRI
Definition dtrtri.f:109

◆ dgetrs()

subroutine dgetrs ( character trans,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DGETRS

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

Purpose:
!>
!> DGETRS solves a system of linear equations
!>    A * X = B  or  A**T * X = B
!> with a general N-by-N matrix A using the LU factorization computed
!> by DGETRF.
!>
Parameters
[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**T* X = B  (Conjugate transpose = Transpose)
!>
[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 factors L and U from the factorization A = P*L*U
!>          as computed by DGETRF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from DGETRF; for 1<=i<=N, row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[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 dgetrs.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 TRANS
128 INTEGER INFO, LDA, LDB, N, NRHS
129* ..
130* .. Array Arguments ..
131 INTEGER IPIV( * )
132 DOUBLE PRECISION A( LDA, * ), B( LDB, * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 DOUBLE PRECISION ONE
139 parameter( one = 1.0d+0 )
140* ..
141* .. Local Scalars ..
142 LOGICAL NOTRAN
143* ..
144* .. External Functions ..
145 LOGICAL LSAME
146 EXTERNAL lsame
147* ..
148* .. External Subroutines ..
149 EXTERNAL dlaswp, dtrsm, xerbla
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC max
153* ..
154* .. Executable Statements ..
155*
156* Test the input parameters.
157*
158 info = 0
159 notran = lsame( trans, 'N' )
160 IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
161 $ lsame( trans, 'C' ) ) THEN
162 info = -1
163 ELSE IF( n.LT.0 ) THEN
164 info = -2
165 ELSE IF( nrhs.LT.0 ) THEN
166 info = -3
167 ELSE IF( lda.LT.max( 1, n ) ) THEN
168 info = -5
169 ELSE IF( ldb.LT.max( 1, n ) ) THEN
170 info = -8
171 END IF
172 IF( info.NE.0 ) THEN
173 CALL xerbla( 'DGETRS', -info )
174 RETURN
175 END IF
176*
177* Quick return if possible
178*
179 IF( n.EQ.0 .OR. nrhs.EQ.0 )
180 $ RETURN
181*
182 IF( notran ) THEN
183*
184* Solve A * X = B.
185*
186* Apply row interchanges to the right hand sides.
187*
188 CALL dlaswp( nrhs, b, ldb, 1, n, ipiv, 1 )
189*
190* Solve L*X = B, overwriting B with X.
191*
192 CALL dtrsm( 'Left', 'Lower', 'No transpose', 'Unit', n, nrhs,
193 $ one, a, lda, b, ldb )
194*
195* Solve U*X = B, overwriting B with X.
196*
197 CALL dtrsm( 'Left', 'Upper', 'No transpose', 'Non-unit', n,
198 $ nrhs, one, a, lda, b, ldb )
199 ELSE
200*
201* Solve A**T * X = B.
202*
203* Solve U**T *X = B, overwriting B with X.
204*
205 CALL dtrsm( 'Left', 'Upper', 'Transpose', 'Non-unit', n, nrhs,
206 $ one, a, lda, b, ldb )
207*
208* Solve L**T *X = B, overwriting B with X.
209*
210 CALL dtrsm( 'Left', 'Lower', 'Transpose', 'Unit', n, nrhs, one,
211 $ a, lda, b, ldb )
212*
213* Apply row interchanges to the solution vectors.
214*
215 CALL dlaswp( nrhs, b, ldb, 1, n, ipiv, -1 )
216 END IF
217*
218 RETURN
219*
220* End of DGETRS
221*

◆ dhgeqz()

subroutine dhgeqz ( character job,
character compq,
character compz,
integer n,
integer ilo,
integer ihi,
double precision, dimension( ldh, * ) h,
integer ldh,
double precision, dimension( ldt, * ) t,
integer ldt,
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,
double precision, dimension( * ) work,
integer lwork,
integer info )

DHGEQZ

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

Purpose:
!>
!> DHGEQZ computes the eigenvalues of a real matrix pair (H,T),
!> where H is an upper Hessenberg matrix and T is upper triangular,
!> using the double-shift QZ method.
!> Matrix pairs of this type are produced by the reduction to
!> generalized upper Hessenberg form of a real matrix pair (A,B):
!>
!>    A = Q1*H*Z1**T,  B = Q1*T*Z1**T,
!>
!> as computed by DGGHRD.
!>
!> If JOB='S', then the Hessenberg-triangular pair (H,T) is
!> also reduced to generalized Schur form,
!>
!>    H = Q*S*Z**T,  T = Q*P*Z**T,
!>
!> where Q and Z are orthogonal matrices, P is an upper triangular
!> matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
!> diagonal blocks.
!>
!> The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
!> (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
!> eigenvalues.
!>
!> Additionally, the 2-by-2 upper triangular diagonal blocks of P
!> corresponding to 2-by-2 blocks of S are reduced to positive diagonal
!> form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
!> P(j,j) > 0, and P(j+1,j+1) > 0.
!>
!> Optionally, the orthogonal matrix Q from the generalized Schur
!> factorization may be postmultiplied into an input matrix Q1, and the
!> orthogonal matrix Z may be postmultiplied into an input matrix Z1.
!> If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced
!> the matrix pair (A,B) to generalized upper Hessenberg form, then the
!> output matrices Q1*Q and Z1*Z are the orthogonal factors from the
!> generalized Schur factorization of (A,B):
!>
!>    A = (Q1*Q)*S*(Z1*Z)**T,  B = (Q1*Q)*P*(Z1*Z)**T.
!>
!> To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
!> of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
!> complex and beta real.
!> If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
!> generalized nonsymmetric eigenvalue problem (GNEP)
!>    A*x = lambda*B*x
!> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
!> alternate form of the GNEP
!>    mu*A*y = B*y.
!> Real eigenvalues can be read directly from the generalized Schur
!> form:
!>   alpha = S(i,i), beta = P(i,i).
!>
!> Ref: C.B. Moler & G.W. Stewart, , SIAM J. Numer. Anal., 10(1973),
!>      pp. 241--256.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          = 'E': Compute eigenvalues only;
!>          = 'S': Compute eigenvalues and the Schur form.
!>
[in]COMPQ
!>          COMPQ is CHARACTER*1
!>          = 'N': Left Schur vectors (Q) are not computed;
!>          = 'I': Q is initialized to the unit matrix and the matrix Q
!>                 of left Schur vectors of (H,T) 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': Right Schur vectors (Z) are not computed;
!>          = 'I': Z is initialized to the unit matrix and the matrix Z
!>                 of right Schur vectors of (H,T) 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 H, T, Q, and Z.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>          ILO and IHI mark the rows and columns of H which are in
!>          Hessenberg form.  It is assumed that A is already upper
!>          triangular in rows and columns 1:ILO-1 and IHI+1:N.
!>          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
!>
[in,out]H
!>          H is DOUBLE PRECISION array, dimension (LDH, N)
!>          On entry, the N-by-N upper Hessenberg matrix H.
!>          On exit, if JOB = 'S', H contains the upper quasi-triangular
!>          matrix S from the generalized Schur factorization.
!>          If JOB = 'E', the diagonal blocks of H match those of S, but
!>          the rest of H is unspecified.
!>
[in]LDH
!>          LDH is INTEGER
!>          The leading dimension of the array H.  LDH >= max( 1, N ).
!>
[in,out]T
!>          T is DOUBLE PRECISION array, dimension (LDT, N)
!>          On entry, the N-by-N upper triangular matrix T.
!>          On exit, if JOB = 'S', T contains the upper triangular
!>          matrix P from the generalized Schur factorization;
!>          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
!>          are reduced to positive diagonal form, i.e., if H(j+1,j) is
!>          non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and
!>          T(j+1,j+1) > 0.
!>          If JOB = 'E', the diagonal blocks of T match those of P, but
!>          the rest of T is unspecified.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= max( 1, N ).
!>
[out]ALPHAR
!>          ALPHAR is DOUBLE PRECISION array, dimension (N)
!>          The real parts of each scalar alpha defining an eigenvalue
!>          of GNEP.
!>
[out]ALPHAI
!>          ALPHAI is DOUBLE PRECISION array, dimension (N)
!>          The imaginary parts of each scalar alpha defining an
!>          eigenvalue of GNEP.
!>          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) = -ALPHAI(j).
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>          The scalars beta that define the eigenvalues of GNEP.
!>          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
!>          beta = BETA(j) represent the j-th eigenvalue of the matrix
!>          pair (A,B), in one of the forms lambda = alpha/beta or
!>          mu = beta/alpha.  Since either lambda or mu may overflow,
!>          they should not, in general, be computed.
!>
[in,out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in
!>          the reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPQ = 'I', the orthogonal matrix of left Schur
!>          vectors of (H,T), and if COMPQ = 'V', the orthogonal matrix
!>          of left Schur vectors of (A,B).
!>          Not referenced if COMPQ = 'N'.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= 1.
!>          If COMPQ='V' or 'I', then LDQ >= N.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
!>          the reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPZ = 'I', the orthogonal matrix of
!>          right Schur vectors of (H,T), and if COMPZ = 'V', the
!>          orthogonal matrix of right Schur vectors of (A,B).
!>          Not referenced if COMPZ = 'N'.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1.
!>          If COMPZ='V' or 'I', then LDZ >= 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 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
!>          = 1,...,N: the QZ iteration did not converge.  (H,T) is not
!>                     in Schur form, but ALPHAR(i), ALPHAI(i), and
!>                     BETA(i), i=INFO+1,...,N should be correct.
!>          = N+1,...,2*N: the shift calculation failed.  (H,T) is not
!>                     in Schur form, but ALPHAR(i), ALPHAI(i), and
!>                     BETA(i), i=INFO-N+1,...,N should be correct.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Iteration counters:
!>
!>  JITER  -- counts iterations.
!>  IITER  -- counts iterations run since ILAST was last
!>            changed.  This is therefore reset only when a 1-by-1 or
!>            2-by-2 block deflates off the bottom.
!>

Definition at line 301 of file dhgeqz.f.

304*
305* -- LAPACK computational routine --
306* -- LAPACK is a software package provided by Univ. of Tennessee, --
307* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
308*
309* .. Scalar Arguments ..
310 CHARACTER COMPQ, COMPZ, JOB
311 INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
312* ..
313* .. Array Arguments ..
314 DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ),
315 $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ),
316 $ WORK( * ), Z( LDZ, * )
317* ..
318*
319* =====================================================================
320*
321* .. Parameters ..
322* $ SAFETY = 1.0E+0 )
323 DOUBLE PRECISION HALF, ZERO, ONE, SAFETY
324 parameter( half = 0.5d+0, zero = 0.0d+0, one = 1.0d+0,
325 $ safety = 1.0d+2 )
326* ..
327* .. Local Scalars ..
328 LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,
329 $ LQUERY
330 INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
331 $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
332 $ JR, MAXIT
333 DOUBLE PRECISION A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,
334 $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,
335 $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,
336 $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,
337 $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
338 $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
339 $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
340 $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L,
341 $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR,
342 $ WR2
343* ..
344* .. Local Arrays ..
345 DOUBLE PRECISION V( 3 )
346* ..
347* .. External Functions ..
348 LOGICAL LSAME
349 DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3
350 EXTERNAL lsame, dlamch, dlanhs, dlapy2, dlapy3
351* ..
352* .. External Subroutines ..
353 EXTERNAL dlag2, dlarfg, dlartg, dlaset, dlasv2, drot,
354 $ xerbla
355* ..
356* .. Intrinsic Functions ..
357 INTRINSIC abs, dble, max, min, sqrt
358* ..
359* .. Executable Statements ..
360*
361* Decode JOB, COMPQ, COMPZ
362*
363 IF( lsame( job, 'E' ) ) THEN
364 ilschr = .false.
365 ischur = 1
366 ELSE IF( lsame( job, 'S' ) ) THEN
367 ilschr = .true.
368 ischur = 2
369 ELSE
370 ischur = 0
371 END IF
372*
373 IF( lsame( compq, 'N' ) ) THEN
374 ilq = .false.
375 icompq = 1
376 ELSE IF( lsame( compq, 'V' ) ) THEN
377 ilq = .true.
378 icompq = 2
379 ELSE IF( lsame( compq, 'I' ) ) THEN
380 ilq = .true.
381 icompq = 3
382 ELSE
383 icompq = 0
384 END IF
385*
386 IF( lsame( compz, 'N' ) ) THEN
387 ilz = .false.
388 icompz = 1
389 ELSE IF( lsame( compz, 'V' ) ) THEN
390 ilz = .true.
391 icompz = 2
392 ELSE IF( lsame( compz, 'I' ) ) THEN
393 ilz = .true.
394 icompz = 3
395 ELSE
396 icompz = 0
397 END IF
398*
399* Check Argument Values
400*
401 info = 0
402 work( 1 ) = max( 1, n )
403 lquery = ( lwork.EQ.-1 )
404 IF( ischur.EQ.0 ) THEN
405 info = -1
406 ELSE IF( icompq.EQ.0 ) THEN
407 info = -2
408 ELSE IF( icompz.EQ.0 ) THEN
409 info = -3
410 ELSE IF( n.LT.0 ) THEN
411 info = -4
412 ELSE IF( ilo.LT.1 ) THEN
413 info = -5
414 ELSE IF( ihi.GT.n .OR. ihi.LT.ilo-1 ) THEN
415 info = -6
416 ELSE IF( ldh.LT.n ) THEN
417 info = -8
418 ELSE IF( ldt.LT.n ) THEN
419 info = -10
420 ELSE IF( ldq.LT.1 .OR. ( ilq .AND. ldq.LT.n ) ) THEN
421 info = -15
422 ELSE IF( ldz.LT.1 .OR. ( ilz .AND. ldz.LT.n ) ) THEN
423 info = -17
424 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
425 info = -19
426 END IF
427 IF( info.NE.0 ) THEN
428 CALL xerbla( 'DHGEQZ', -info )
429 RETURN
430 ELSE IF( lquery ) THEN
431 RETURN
432 END IF
433*
434* Quick return if possible
435*
436 IF( n.LE.0 ) THEN
437 work( 1 ) = dble( 1 )
438 RETURN
439 END IF
440*
441* Initialize Q and Z
442*
443 IF( icompq.EQ.3 )
444 $ CALL dlaset( 'Full', n, n, zero, one, q, ldq )
445 IF( icompz.EQ.3 )
446 $ CALL dlaset( 'Full', n, n, zero, one, z, ldz )
447*
448* Machine Constants
449*
450 in = ihi + 1 - ilo
451 safmin = dlamch( 'S' )
452 safmax = one / safmin
453 ulp = dlamch( 'E' )*dlamch( 'B' )
454 anorm = dlanhs( 'F', in, h( ilo, ilo ), ldh, work )
455 bnorm = dlanhs( 'F', in, t( ilo, ilo ), ldt, work )
456 atol = max( safmin, ulp*anorm )
457 btol = max( safmin, ulp*bnorm )
458 ascale = one / max( safmin, anorm )
459 bscale = one / max( safmin, bnorm )
460*
461* Set Eigenvalues IHI+1:N
462*
463 DO 30 j = ihi + 1, n
464 IF( t( j, j ).LT.zero ) THEN
465 IF( ilschr ) THEN
466 DO 10 jr = 1, j
467 h( jr, j ) = -h( jr, j )
468 t( jr, j ) = -t( jr, j )
469 10 CONTINUE
470 ELSE
471 h( j, j ) = -h( j, j )
472 t( j, j ) = -t( j, j )
473 END IF
474 IF( ilz ) THEN
475 DO 20 jr = 1, n
476 z( jr, j ) = -z( jr, j )
477 20 CONTINUE
478 END IF
479 END IF
480 alphar( j ) = h( j, j )
481 alphai( j ) = zero
482 beta( j ) = t( j, j )
483 30 CONTINUE
484*
485* If IHI < ILO, skip QZ steps
486*
487 IF( ihi.LT.ilo )
488 $ GO TO 380
489*
490* MAIN QZ ITERATION LOOP
491*
492* Initialize dynamic indices
493*
494* Eigenvalues ILAST+1:N have been found.
495* Column operations modify rows IFRSTM:whatever.
496* Row operations modify columns whatever:ILASTM.
497*
498* If only eigenvalues are being computed, then
499* IFRSTM is the row of the last splitting row above row ILAST;
500* this is always at least ILO.
501* IITER counts iterations since the last eigenvalue was found,
502* to tell when to use an extraordinary shift.
503* MAXIT is the maximum number of QZ sweeps allowed.
504*
505 ilast = ihi
506 IF( ilschr ) THEN
507 ifrstm = 1
508 ilastm = n
509 ELSE
510 ifrstm = ilo
511 ilastm = ihi
512 END IF
513 iiter = 0
514 eshift = zero
515 maxit = 30*( ihi-ilo+1 )
516*
517 DO 360 jiter = 1, maxit
518*
519* Split the matrix if possible.
520*
521* Two tests:
522* 1: H(j,j-1)=0 or j=ILO
523* 2: T(j,j)=0
524*
525 IF( ilast.EQ.ilo ) THEN
526*
527* Special case: j=ILAST
528*
529 GO TO 80
530 ELSE
531 IF( abs( h( ilast, ilast-1 ) ).LE.max( safmin, ulp*(
532 $ abs( h( ilast, ilast ) ) + abs( h( ilast-1, ilast-1 ) )
533 $ ) ) ) THEN
534 h( ilast, ilast-1 ) = zero
535 GO TO 80
536 END IF
537 END IF
538*
539 IF( abs( t( ilast, ilast ) ).LE.max( safmin, ulp*(
540 $ abs( t( ilast - 1, ilast ) ) + abs( t( ilast-1, ilast-1 )
541 $ ) ) ) ) THEN
542 t( ilast, ilast ) = zero
543 GO TO 70
544 END IF
545*
546* General case: j<ILAST
547*
548 DO 60 j = ilast - 1, ilo, -1
549*
550* Test 1: for H(j,j-1)=0 or j=ILO
551*
552 IF( j.EQ.ilo ) THEN
553 ilazro = .true.
554 ELSE
555 IF( abs( h( j, j-1 ) ).LE.max( safmin, ulp*(
556 $ abs( h( j, j ) ) + abs( h( j-1, j-1 ) )
557 $ ) ) ) THEN
558 h( j, j-1 ) = zero
559 ilazro = .true.
560 ELSE
561 ilazro = .false.
562 END IF
563 END IF
564*
565* Test 2: for T(j,j)=0
566*
567 temp = abs( t( j, j + 1 ) )
568 IF ( j .GT. ilo )
569 $ temp = temp + abs( t( j - 1, j ) )
570 IF( abs( t( j, j ) ).LT.max( safmin,ulp*temp ) ) THEN
571 t( j, j ) = zero
572*
573* Test 1a: Check for 2 consecutive small subdiagonals in A
574*
575 ilazr2 = .false.
576 IF( .NOT.ilazro ) THEN
577 temp = abs( h( j, j-1 ) )
578 temp2 = abs( h( j, j ) )
579 tempr = max( temp, temp2 )
580 IF( tempr.LT.one .AND. tempr.NE.zero ) THEN
581 temp = temp / tempr
582 temp2 = temp2 / tempr
583 END IF
584 IF( temp*( ascale*abs( h( j+1, j ) ) ).LE.temp2*
585 $ ( ascale*atol ) )ilazr2 = .true.
586 END IF
587*
588* If both tests pass (1 & 2), i.e., the leading diagonal
589* element of B in the block is zero, split a 1x1 block off
590* at the top. (I.e., at the J-th row/column) The leading
591* diagonal element of the remainder can also be zero, so
592* this may have to be done repeatedly.
593*
594 IF( ilazro .OR. ilazr2 ) THEN
595 DO 40 jch = j, ilast - 1
596 temp = h( jch, jch )
597 CALL dlartg( temp, h( jch+1, jch ), c, s,
598 $ h( jch, jch ) )
599 h( jch+1, jch ) = zero
600 CALL drot( ilastm-jch, h( jch, jch+1 ), ldh,
601 $ h( jch+1, jch+1 ), ldh, c, s )
602 CALL drot( ilastm-jch, t( jch, jch+1 ), ldt,
603 $ t( jch+1, jch+1 ), ldt, c, s )
604 IF( ilq )
605 $ CALL drot( n, q( 1, jch ), 1, q( 1, jch+1 ), 1,
606 $ c, s )
607 IF( ilazr2 )
608 $ h( jch, jch-1 ) = h( jch, jch-1 )*c
609 ilazr2 = .false.
610 IF( abs( t( jch+1, jch+1 ) ).GE.btol ) THEN
611 IF( jch+1.GE.ilast ) THEN
612 GO TO 80
613 ELSE
614 ifirst = jch + 1
615 GO TO 110
616 END IF
617 END IF
618 t( jch+1, jch+1 ) = zero
619 40 CONTINUE
620 GO TO 70
621 ELSE
622*
623* Only test 2 passed -- chase the zero to T(ILAST,ILAST)
624* Then process as in the case T(ILAST,ILAST)=0
625*
626 DO 50 jch = j, ilast - 1
627 temp = t( jch, jch+1 )
628 CALL dlartg( temp, t( jch+1, jch+1 ), c, s,
629 $ t( jch, jch+1 ) )
630 t( jch+1, jch+1 ) = zero
631 IF( jch.LT.ilastm-1 )
632 $ CALL drot( ilastm-jch-1, t( jch, jch+2 ), ldt,
633 $ t( jch+1, jch+2 ), ldt, c, s )
634 CALL drot( ilastm-jch+2, h( jch, jch-1 ), ldh,
635 $ h( jch+1, jch-1 ), ldh, c, s )
636 IF( ilq )
637 $ CALL drot( n, q( 1, jch ), 1, q( 1, jch+1 ), 1,
638 $ c, s )
639 temp = h( jch+1, jch )
640 CALL dlartg( temp, h( jch+1, jch-1 ), c, s,
641 $ h( jch+1, jch ) )
642 h( jch+1, jch-1 ) = zero
643 CALL drot( jch+1-ifrstm, h( ifrstm, jch ), 1,
644 $ h( ifrstm, jch-1 ), 1, c, s )
645 CALL drot( jch-ifrstm, t( ifrstm, jch ), 1,
646 $ t( ifrstm, jch-1 ), 1, c, s )
647 IF( ilz )
648 $ CALL drot( n, z( 1, jch ), 1, z( 1, jch-1 ), 1,
649 $ c, s )
650 50 CONTINUE
651 GO TO 70
652 END IF
653 ELSE IF( ilazro ) THEN
654*
655* Only test 1 passed -- work on J:ILAST
656*
657 ifirst = j
658 GO TO 110
659 END IF
660*
661* Neither test passed -- try next J
662*
663 60 CONTINUE
664*
665* (Drop-through is "impossible")
666*
667 info = n + 1
668 GO TO 420
669*
670* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a
671* 1x1 block.
672*
673 70 CONTINUE
674 temp = h( ilast, ilast )
675 CALL dlartg( temp, h( ilast, ilast-1 ), c, s,
676 $ h( ilast, ilast ) )
677 h( ilast, ilast-1 ) = zero
678 CALL drot( ilast-ifrstm, h( ifrstm, ilast ), 1,
679 $ h( ifrstm, ilast-1 ), 1, c, s )
680 CALL drot( ilast-ifrstm, t( ifrstm, ilast ), 1,
681 $ t( ifrstm, ilast-1 ), 1, c, s )
682 IF( ilz )
683 $ CALL drot( n, z( 1, ilast ), 1, z( 1, ilast-1 ), 1, c, s )
684*
685* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI,
686* and BETA
687*
688 80 CONTINUE
689 IF( t( ilast, ilast ).LT.zero ) THEN
690 IF( ilschr ) THEN
691 DO 90 j = ifrstm, ilast
692 h( j, ilast ) = -h( j, ilast )
693 t( j, ilast ) = -t( j, ilast )
694 90 CONTINUE
695 ELSE
696 h( ilast, ilast ) = -h( ilast, ilast )
697 t( ilast, ilast ) = -t( ilast, ilast )
698 END IF
699 IF( ilz ) THEN
700 DO 100 j = 1, n
701 z( j, ilast ) = -z( j, ilast )
702 100 CONTINUE
703 END IF
704 END IF
705 alphar( ilast ) = h( ilast, ilast )
706 alphai( ilast ) = zero
707 beta( ilast ) = t( ilast, ilast )
708*
709* Go to next block -- exit if finished.
710*
711 ilast = ilast - 1
712 IF( ilast.LT.ilo )
713 $ GO TO 380
714*
715* Reset counters
716*
717 iiter = 0
718 eshift = zero
719 IF( .NOT.ilschr ) THEN
720 ilastm = ilast
721 IF( ifrstm.GT.ilast )
722 $ ifrstm = ilo
723 END IF
724 GO TO 350
725*
726* QZ step
727*
728* This iteration only involves rows/columns IFIRST:ILAST. We
729* assume IFIRST < ILAST, and that the diagonal of B is non-zero.
730*
731 110 CONTINUE
732 iiter = iiter + 1
733 IF( .NOT.ilschr ) THEN
734 ifrstm = ifirst
735 END IF
736*
737* Compute single shifts.
738*
739* At this point, IFIRST < ILAST, and the diagonal elements of
740* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
741* magnitude)
742*
743 IF( ( iiter / 10 )*10.EQ.iiter ) THEN
744*
745* Exceptional shift. Chosen for no particularly good reason.
746* (Single shift only.)
747*
748 IF( ( dble( maxit )*safmin )*abs( h( ilast, ilast-1 ) ).LT.
749 $ abs( t( ilast-1, ilast-1 ) ) ) THEN
750 eshift = h( ilast, ilast-1 ) /
751 $ t( ilast-1, ilast-1 )
752 ELSE
753 eshift = eshift + one / ( safmin*dble( maxit ) )
754 END IF
755 s1 = one
756 wr = eshift
757*
758 ELSE
759*
760* Shifts based on the generalized eigenvalues of the
761* bottom-right 2x2 block of A and B. The first eigenvalue
762* returned by DLAG2 is the Wilkinson shift (AEP p.512),
763*
764 CALL dlag2( h( ilast-1, ilast-1 ), ldh,
765 $ t( ilast-1, ilast-1 ), ldt, safmin*safety, s1,
766 $ s2, wr, wr2, wi )
767*
768 IF ( abs( (wr/s1)*t( ilast, ilast ) - h( ilast, ilast ) )
769 $ .GT. abs( (wr2/s2)*t( ilast, ilast )
770 $ - h( ilast, ilast ) ) ) THEN
771 temp = wr
772 wr = wr2
773 wr2 = temp
774 temp = s1
775 s1 = s2
776 s2 = temp
777 END IF
778 temp = max( s1, safmin*max( one, abs( wr ), abs( wi ) ) )
779 IF( wi.NE.zero )
780 $ GO TO 200
781 END IF
782*
783* Fiddle with shift to avoid overflow
784*
785 temp = min( ascale, one )*( half*safmax )
786 IF( s1.GT.temp ) THEN
787 scale = temp / s1
788 ELSE
789 scale = one
790 END IF
791*
792 temp = min( bscale, one )*( half*safmax )
793 IF( abs( wr ).GT.temp )
794 $ scale = min( scale, temp / abs( wr ) )
795 s1 = scale*s1
796 wr = scale*wr
797*
798* Now check for two consecutive small subdiagonals.
799*
800 DO 120 j = ilast - 1, ifirst + 1, -1
801 istart = j
802 temp = abs( s1*h( j, j-1 ) )
803 temp2 = abs( s1*h( j, j )-wr*t( j, j ) )
804 tempr = max( temp, temp2 )
805 IF( tempr.LT.one .AND. tempr.NE.zero ) THEN
806 temp = temp / tempr
807 temp2 = temp2 / tempr
808 END IF
809 IF( abs( ( ascale*h( j+1, j ) )*temp ).LE.( ascale*atol )*
810 $ temp2 )GO TO 130
811 120 CONTINUE
812*
813 istart = ifirst
814 130 CONTINUE
815*
816* Do an implicit single-shift QZ sweep.
817*
818* Initial Q
819*
820 temp = s1*h( istart, istart ) - wr*t( istart, istart )
821 temp2 = s1*h( istart+1, istart )
822 CALL dlartg( temp, temp2, c, s, tempr )
823*
824* Sweep
825*
826 DO 190 j = istart, ilast - 1
827 IF( j.GT.istart ) THEN
828 temp = h( j, j-1 )
829 CALL dlartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) )
830 h( j+1, j-1 ) = zero
831 END IF
832*
833 DO 140 jc = j, ilastm
834 temp = c*h( j, jc ) + s*h( j+1, jc )
835 h( j+1, jc ) = -s*h( j, jc ) + c*h( j+1, jc )
836 h( j, jc ) = temp
837 temp2 = c*t( j, jc ) + s*t( j+1, jc )
838 t( j+1, jc ) = -s*t( j, jc ) + c*t( j+1, jc )
839 t( j, jc ) = temp2
840 140 CONTINUE
841 IF( ilq ) THEN
842 DO 150 jr = 1, n
843 temp = c*q( jr, j ) + s*q( jr, j+1 )
844 q( jr, j+1 ) = -s*q( jr, j ) + c*q( jr, j+1 )
845 q( jr, j ) = temp
846 150 CONTINUE
847 END IF
848*
849 temp = t( j+1, j+1 )
850 CALL dlartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) )
851 t( j+1, j ) = zero
852*
853 DO 160 jr = ifrstm, min( j+2, ilast )
854 temp = c*h( jr, j+1 ) + s*h( jr, j )
855 h( jr, j ) = -s*h( jr, j+1 ) + c*h( jr, j )
856 h( jr, j+1 ) = temp
857 160 CONTINUE
858 DO 170 jr = ifrstm, j
859 temp = c*t( jr, j+1 ) + s*t( jr, j )
860 t( jr, j ) = -s*t( jr, j+1 ) + c*t( jr, j )
861 t( jr, j+1 ) = temp
862 170 CONTINUE
863 IF( ilz ) THEN
864 DO 180 jr = 1, n
865 temp = c*z( jr, j+1 ) + s*z( jr, j )
866 z( jr, j ) = -s*z( jr, j+1 ) + c*z( jr, j )
867 z( jr, j+1 ) = temp
868 180 CONTINUE
869 END IF
870 190 CONTINUE
871*
872 GO TO 350
873*
874* Use Francis double-shift
875*
876* Note: the Francis double-shift should work with real shifts,
877* but only if the block is at least 3x3.
878* This code may break if this point is reached with
879* a 2x2 block with real eigenvalues.
880*
881 200 CONTINUE
882 IF( ifirst+1.EQ.ilast ) THEN
883*
884* Special case -- 2x2 block with complex eigenvectors
885*
886* Step 1: Standardize, that is, rotate so that
887*
888* ( B11 0 )
889* B = ( ) with B11 non-negative.
890* ( 0 B22 )
891*
892 CALL dlasv2( t( ilast-1, ilast-1 ), t( ilast-1, ilast ),
893 $ t( ilast, ilast ), b22, b11, sr, cr, sl, cl )
894*
895 IF( b11.LT.zero ) THEN
896 cr = -cr
897 sr = -sr
898 b11 = -b11
899 b22 = -b22
900 END IF
901*
902 CALL drot( ilastm+1-ifirst, h( ilast-1, ilast-1 ), ldh,
903 $ h( ilast, ilast-1 ), ldh, cl, sl )
904 CALL drot( ilast+1-ifrstm, h( ifrstm, ilast-1 ), 1,
905 $ h( ifrstm, ilast ), 1, cr, sr )
906*
907 IF( ilast.LT.ilastm )
908 $ CALL drot( ilastm-ilast, t( ilast-1, ilast+1 ), ldt,
909 $ t( ilast, ilast+1 ), ldt, cl, sl )
910 IF( ifrstm.LT.ilast-1 )
911 $ CALL drot( ifirst-ifrstm, t( ifrstm, ilast-1 ), 1,
912 $ t( ifrstm, ilast ), 1, cr, sr )
913*
914 IF( ilq )
915 $ CALL drot( n, q( 1, ilast-1 ), 1, q( 1, ilast ), 1, cl,
916 $ sl )
917 IF( ilz )
918 $ CALL drot( n, z( 1, ilast-1 ), 1, z( 1, ilast ), 1, cr,
919 $ sr )
920*
921 t( ilast-1, ilast-1 ) = b11
922 t( ilast-1, ilast ) = zero
923 t( ilast, ilast-1 ) = zero
924 t( ilast, ilast ) = b22
925*
926* If B22 is negative, negate column ILAST
927*
928 IF( b22.LT.zero ) THEN
929 DO 210 j = ifrstm, ilast
930 h( j, ilast ) = -h( j, ilast )
931 t( j, ilast ) = -t( j, ilast )
932 210 CONTINUE
933*
934 IF( ilz ) THEN
935 DO 220 j = 1, n
936 z( j, ilast ) = -z( j, ilast )
937 220 CONTINUE
938 END IF
939 b22 = -b22
940 END IF
941*
942* Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.)
943*
944* Recompute shift
945*
946 CALL dlag2( h( ilast-1, ilast-1 ), ldh,
947 $ t( ilast-1, ilast-1 ), ldt, safmin*safety, s1,
948 $ temp, wr, temp2, wi )
949*
950* If standardization has perturbed the shift onto real line,
951* do another (real single-shift) QR step.
952*
953 IF( wi.EQ.zero )
954 $ GO TO 350
955 s1inv = one / s1
956*
957* Do EISPACK (QZVAL) computation of alpha and beta
958*
959 a11 = h( ilast-1, ilast-1 )
960 a21 = h( ilast, ilast-1 )
961 a12 = h( ilast-1, ilast )
962 a22 = h( ilast, ilast )
963*
964* Compute complex Givens rotation on right
965* (Assume some element of C = (sA - wB) > unfl )
966* __
967* (sA - wB) ( CZ -SZ )
968* ( SZ CZ )
969*
970 c11r = s1*a11 - wr*b11
971 c11i = -wi*b11
972 c12 = s1*a12
973 c21 = s1*a21
974 c22r = s1*a22 - wr*b22
975 c22i = -wi*b22
976*
977 IF( abs( c11r )+abs( c11i )+abs( c12 ).GT.abs( c21 )+
978 $ abs( c22r )+abs( c22i ) ) THEN
979 t1 = dlapy3( c12, c11r, c11i )
980 cz = c12 / t1
981 szr = -c11r / t1
982 szi = -c11i / t1
983 ELSE
984 cz = dlapy2( c22r, c22i )
985 IF( cz.LE.safmin ) THEN
986 cz = zero
987 szr = one
988 szi = zero
989 ELSE
990 tempr = c22r / cz
991 tempi = c22i / cz
992 t1 = dlapy2( cz, c21 )
993 cz = cz / t1
994 szr = -c21*tempr / t1
995 szi = c21*tempi / t1
996 END IF
997 END IF
998*
999* Compute Givens rotation on left
1000*
1001* ( CQ SQ )
1002* ( __ ) A or B
1003* ( -SQ CQ )
1004*
1005 an = abs( a11 ) + abs( a12 ) + abs( a21 ) + abs( a22 )
1006 bn = abs( b11 ) + abs( b22 )
1007 wabs = abs( wr ) + abs( wi )
1008 IF( s1*an.GT.wabs*bn ) THEN
1009 cq = cz*b11
1010 sqr = szr*b22
1011 sqi = -szi*b22
1012 ELSE
1013 a1r = cz*a11 + szr*a12
1014 a1i = szi*a12
1015 a2r = cz*a21 + szr*a22
1016 a2i = szi*a22
1017 cq = dlapy2( a1r, a1i )
1018 IF( cq.LE.safmin ) THEN
1019 cq = zero
1020 sqr = one
1021 sqi = zero
1022 ELSE
1023 tempr = a1r / cq
1024 tempi = a1i / cq
1025 sqr = tempr*a2r + tempi*a2i
1026 sqi = tempi*a2r - tempr*a2i
1027 END IF
1028 END IF
1029 t1 = dlapy3( cq, sqr, sqi )
1030 cq = cq / t1
1031 sqr = sqr / t1
1032 sqi = sqi / t1
1033*
1034* Compute diagonal elements of QBZ
1035*
1036 tempr = sqr*szr - sqi*szi
1037 tempi = sqr*szi + sqi*szr
1038 b1r = cq*cz*b11 + tempr*b22
1039 b1i = tempi*b22
1040 b1a = dlapy2( b1r, b1i )
1041 b2r = cq*cz*b22 + tempr*b11
1042 b2i = -tempi*b11
1043 b2a = dlapy2( b2r, b2i )
1044*
1045* Normalize so beta > 0, and Im( alpha1 ) > 0
1046*
1047 beta( ilast-1 ) = b1a
1048 beta( ilast ) = b2a
1049 alphar( ilast-1 ) = ( wr*b1a )*s1inv
1050 alphai( ilast-1 ) = ( wi*b1a )*s1inv
1051 alphar( ilast ) = ( wr*b2a )*s1inv
1052 alphai( ilast ) = -( wi*b2a )*s1inv
1053*
1054* Step 3: Go to next block -- exit if finished.
1055*
1056 ilast = ifirst - 1
1057 IF( ilast.LT.ilo )
1058 $ GO TO 380
1059*
1060* Reset counters
1061*
1062 iiter = 0
1063 eshift = zero
1064 IF( .NOT.ilschr ) THEN
1065 ilastm = ilast
1066 IF( ifrstm.GT.ilast )
1067 $ ifrstm = ilo
1068 END IF
1069 GO TO 350
1070 ELSE
1071*
1072* Usual case: 3x3 or larger block, using Francis implicit
1073* double-shift
1074*
1075* 2
1076* Eigenvalue equation is w - c w + d = 0,
1077*
1078* -1 2 -1
1079* so compute 1st column of (A B ) - c A B + d
1080* using the formula in QZIT (from EISPACK)
1081*
1082* We assume that the block is at least 3x3
1083*
1084 ad11 = ( ascale*h( ilast-1, ilast-1 ) ) /
1085 $ ( bscale*t( ilast-1, ilast-1 ) )
1086 ad21 = ( ascale*h( ilast, ilast-1 ) ) /
1087 $ ( bscale*t( ilast-1, ilast-1 ) )
1088 ad12 = ( ascale*h( ilast-1, ilast ) ) /
1089 $ ( bscale*t( ilast, ilast ) )
1090 ad22 = ( ascale*h( ilast, ilast ) ) /
1091 $ ( bscale*t( ilast, ilast ) )
1092 u12 = t( ilast-1, ilast ) / t( ilast, ilast )
1093 ad11l = ( ascale*h( ifirst, ifirst ) ) /
1094 $ ( bscale*t( ifirst, ifirst ) )
1095 ad21l = ( ascale*h( ifirst+1, ifirst ) ) /
1096 $ ( bscale*t( ifirst, ifirst ) )
1097 ad12l = ( ascale*h( ifirst, ifirst+1 ) ) /
1098 $ ( bscale*t( ifirst+1, ifirst+1 ) )
1099 ad22l = ( ascale*h( ifirst+1, ifirst+1 ) ) /
1100 $ ( bscale*t( ifirst+1, ifirst+1 ) )
1101 ad32l = ( ascale*h( ifirst+2, ifirst+1 ) ) /
1102 $ ( bscale*t( ifirst+1, ifirst+1 ) )
1103 u12l = t( ifirst, ifirst+1 ) / t( ifirst+1, ifirst+1 )
1104*
1105 v( 1 ) = ( ad11-ad11l )*( ad22-ad11l ) - ad12*ad21 +
1106 $ ad21*u12*ad11l + ( ad12l-ad11l*u12l )*ad21l
1107 v( 2 ) = ( ( ad22l-ad11l )-ad21l*u12l-( ad11-ad11l )-
1108 $ ( ad22-ad11l )+ad21*u12 )*ad21l
1109 v( 3 ) = ad32l*ad21l
1110*
1111 istart = ifirst
1112*
1113 CALL dlarfg( 3, v( 1 ), v( 2 ), 1, tau )
1114 v( 1 ) = one
1115*
1116* Sweep
1117*
1118 DO 290 j = istart, ilast - 2
1119*
1120* All but last elements: use 3x3 Householder transforms.
1121*
1122* Zero (j-1)st column of A
1123*
1124 IF( j.GT.istart ) THEN
1125 v( 1 ) = h( j, j-1 )
1126 v( 2 ) = h( j+1, j-1 )
1127 v( 3 ) = h( j+2, j-1 )
1128*
1129 CALL dlarfg( 3, h( j, j-1 ), v( 2 ), 1, tau )
1130 v( 1 ) = one
1131 h( j+1, j-1 ) = zero
1132 h( j+2, j-1 ) = zero
1133 END IF
1134*
1135 DO 230 jc = j, ilastm
1136 temp = tau*( h( j, jc )+v( 2 )*h( j+1, jc )+v( 3 )*
1137 $ h( j+2, jc ) )
1138 h( j, jc ) = h( j, jc ) - temp
1139 h( j+1, jc ) = h( j+1, jc ) - temp*v( 2 )
1140 h( j+2, jc ) = h( j+2, jc ) - temp*v( 3 )
1141 temp2 = tau*( t( j, jc )+v( 2 )*t( j+1, jc )+v( 3 )*
1142 $ t( j+2, jc ) )
1143 t( j, jc ) = t( j, jc ) - temp2
1144 t( j+1, jc ) = t( j+1, jc ) - temp2*v( 2 )
1145 t( j+2, jc ) = t( j+2, jc ) - temp2*v( 3 )
1146 230 CONTINUE
1147 IF( ilq ) THEN
1148 DO 240 jr = 1, n
1149 temp = tau*( q( jr, j )+v( 2 )*q( jr, j+1 )+v( 3 )*
1150 $ q( jr, j+2 ) )
1151 q( jr, j ) = q( jr, j ) - temp
1152 q( jr, j+1 ) = q( jr, j+1 ) - temp*v( 2 )
1153 q( jr, j+2 ) = q( jr, j+2 ) - temp*v( 3 )
1154 240 CONTINUE
1155 END IF
1156*
1157* Zero j-th column of B (see DLAGBC for details)
1158*
1159* Swap rows to pivot
1160*
1161 ilpivt = .false.
1162 temp = max( abs( t( j+1, j+1 ) ), abs( t( j+1, j+2 ) ) )
1163 temp2 = max( abs( t( j+2, j+1 ) ), abs( t( j+2, j+2 ) ) )
1164 IF( max( temp, temp2 ).LT.safmin ) THEN
1165 scale = zero
1166 u1 = one
1167 u2 = zero
1168 GO TO 250
1169 ELSE IF( temp.GE.temp2 ) THEN
1170 w11 = t( j+1, j+1 )
1171 w21 = t( j+2, j+1 )
1172 w12 = t( j+1, j+2 )
1173 w22 = t( j+2, j+2 )
1174 u1 = t( j+1, j )
1175 u2 = t( j+2, j )
1176 ELSE
1177 w21 = t( j+1, j+1 )
1178 w11 = t( j+2, j+1 )
1179 w22 = t( j+1, j+2 )
1180 w12 = t( j+2, j+2 )
1181 u2 = t( j+1, j )
1182 u1 = t( j+2, j )
1183 END IF
1184*
1185* Swap columns if nec.
1186*
1187 IF( abs( w12 ).GT.abs( w11 ) ) THEN
1188 ilpivt = .true.
1189 temp = w12
1190 temp2 = w22
1191 w12 = w11
1192 w22 = w21
1193 w11 = temp
1194 w21 = temp2
1195 END IF
1196*
1197* LU-factor
1198*
1199 temp = w21 / w11
1200 u2 = u2 - temp*u1
1201 w22 = w22 - temp*w12
1202 w21 = zero
1203*
1204* Compute SCALE
1205*
1206 scale = one
1207 IF( abs( w22 ).LT.safmin ) THEN
1208 scale = zero
1209 u2 = one
1210 u1 = -w12 / w11
1211 GO TO 250
1212 END IF
1213 IF( abs( w22 ).LT.abs( u2 ) )
1214 $ scale = abs( w22 / u2 )
1215 IF( abs( w11 ).LT.abs( u1 ) )
1216 $ scale = min( scale, abs( w11 / u1 ) )
1217*
1218* Solve
1219*
1220 u2 = ( scale*u2 ) / w22
1221 u1 = ( scale*u1-w12*u2 ) / w11
1222*
1223 250 CONTINUE
1224 IF( ilpivt ) THEN
1225 temp = u2
1226 u2 = u1
1227 u1 = temp
1228 END IF
1229*
1230* Compute Householder Vector
1231*
1232 t1 = sqrt( scale**2+u1**2+u2**2 )
1233 tau = one + scale / t1
1234 vs = -one / ( scale+t1 )
1235 v( 1 ) = one
1236 v( 2 ) = vs*u1
1237 v( 3 ) = vs*u2
1238*
1239* Apply transformations from the right.
1240*
1241 DO 260 jr = ifrstm, min( j+3, ilast )
1242 temp = tau*( h( jr, j )+v( 2 )*h( jr, j+1 )+v( 3 )*
1243 $ h( jr, j+2 ) )
1244 h( jr, j ) = h( jr, j ) - temp
1245 h( jr, j+1 ) = h( jr, j+1 ) - temp*v( 2 )
1246 h( jr, j+2 ) = h( jr, j+2 ) - temp*v( 3 )
1247 260 CONTINUE
1248 DO 270 jr = ifrstm, j + 2
1249 temp = tau*( t( jr, j )+v( 2 )*t( jr, j+1 )+v( 3 )*
1250 $ t( jr, j+2 ) )
1251 t( jr, j ) = t( jr, j ) - temp
1252 t( jr, j+1 ) = t( jr, j+1 ) - temp*v( 2 )
1253 t( jr, j+2 ) = t( jr, j+2 ) - temp*v( 3 )
1254 270 CONTINUE
1255 IF( ilz ) THEN
1256 DO 280 jr = 1, n
1257 temp = tau*( z( jr, j )+v( 2 )*z( jr, j+1 )+v( 3 )*
1258 $ z( jr, j+2 ) )
1259 z( jr, j ) = z( jr, j ) - temp
1260 z( jr, j+1 ) = z( jr, j+1 ) - temp*v( 2 )
1261 z( jr, j+2 ) = z( jr, j+2 ) - temp*v( 3 )
1262 280 CONTINUE
1263 END IF
1264 t( j+1, j ) = zero
1265 t( j+2, j ) = zero
1266 290 CONTINUE
1267*
1268* Last elements: Use Givens rotations
1269*
1270* Rotations from the left
1271*
1272 j = ilast - 1
1273 temp = h( j, j-1 )
1274 CALL dlartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) )
1275 h( j+1, j-1 ) = zero
1276*
1277 DO 300 jc = j, ilastm
1278 temp = c*h( j, jc ) + s*h( j+1, jc )
1279 h( j+1, jc ) = -s*h( j, jc ) + c*h( j+1, jc )
1280 h( j, jc ) = temp
1281 temp2 = c*t( j, jc ) + s*t( j+1, jc )
1282 t( j+1, jc ) = -s*t( j, jc ) + c*t( j+1, jc )
1283 t( j, jc ) = temp2
1284 300 CONTINUE
1285 IF( ilq ) THEN
1286 DO 310 jr = 1, n
1287 temp = c*q( jr, j ) + s*q( jr, j+1 )
1288 q( jr, j+1 ) = -s*q( jr, j ) + c*q( jr, j+1 )
1289 q( jr, j ) = temp
1290 310 CONTINUE
1291 END IF
1292*
1293* Rotations from the right.
1294*
1295 temp = t( j+1, j+1 )
1296 CALL dlartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) )
1297 t( j+1, j ) = zero
1298*
1299 DO 320 jr = ifrstm, ilast
1300 temp = c*h( jr, j+1 ) + s*h( jr, j )
1301 h( jr, j ) = -s*h( jr, j+1 ) + c*h( jr, j )
1302 h( jr, j+1 ) = temp
1303 320 CONTINUE
1304 DO 330 jr = ifrstm, ilast - 1
1305 temp = c*t( jr, j+1 ) + s*t( jr, j )
1306 t( jr, j ) = -s*t( jr, j+1 ) + c*t( jr, j )
1307 t( jr, j+1 ) = temp
1308 330 CONTINUE
1309 IF( ilz ) THEN
1310 DO 340 jr = 1, n
1311 temp = c*z( jr, j+1 ) + s*z( jr, j )
1312 z( jr, j ) = -s*z( jr, j+1 ) + c*z( jr, j )
1313 z( jr, j+1 ) = temp
1314 340 CONTINUE
1315 END IF
1316*
1317* End of Double-Shift code
1318*
1319 END IF
1320*
1321 GO TO 350
1322*
1323* End of iteration loop
1324*
1325 350 CONTINUE
1326 360 CONTINUE
1327*
1328* Drop-through = non-convergence
1329*
1330 info = ilast
1331 GO TO 420
1332*
1333* Successful completion of all QZ steps
1334*
1335 380 CONTINUE
1336*
1337* Set Eigenvalues 1:ILO-1
1338*
1339 DO 410 j = 1, ilo - 1
1340 IF( t( j, j ).LT.zero ) THEN
1341 IF( ilschr ) THEN
1342 DO 390 jr = 1, j
1343 h( jr, j ) = -h( jr, j )
1344 t( jr, j ) = -t( jr, j )
1345 390 CONTINUE
1346 ELSE
1347 h( j, j ) = -h( j, j )
1348 t( j, j ) = -t( j, j )
1349 END IF
1350 IF( ilz ) THEN
1351 DO 400 jr = 1, n
1352 z( jr, j ) = -z( jr, j )
1353 400 CONTINUE
1354 END IF
1355 END IF
1356 alphar( j ) = h( j, j )
1357 alphai( j ) = zero
1358 beta( j ) = t( j, j )
1359 410 CONTINUE
1360*
1361* Normal Termination
1362*
1363 info = 0
1364*
1365* Exit (other than argument error) -- return optimal workspace size
1366*
1367 420 CONTINUE
1368 work( 1 ) = dble( n )
1369 RETURN
1370*
1371* End of DHGEQZ
1372*
dlapy3
double precision function dlapy3(x, y, z)
DLAPY3 returns sqrt(x2+y2+z2).
Definition dlapy3.f:68
dlartg
subroutine dlartg(f, g, c, s, r)
DLARTG generates a plane rotation with real cosine and real sine.
Definition dlartg.f90:113
dlasv2
subroutine dlasv2(f, g, h, ssmin, ssmax, snr, csr, snl, csl)
DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
Definition dlasv2.f:138
dlapy2
double precision function dlapy2(x, y)
DLAPY2 returns sqrt(x2+y2).
Definition dlapy2.f:63
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
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
drot
subroutine drot(n, dx, incx, dy, incy, c, s)
DROT
Definition drot.f:92
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ dla_geamv()

subroutine dla_geamv ( integer trans,
integer m,
integer n,
double precision alpha,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) x,
integer incx,
double precision beta,
double precision, dimension( * ) y,
integer incy )

DLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds.

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

Purpose:
!>
!> DLA_GEAMV  performs one of the matrix-vector operations
!>
!>         y := alpha*abs(A)*abs(x) + beta*abs(y),
!>    or   y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!>
!> where alpha and beta are scalars, x and y are vectors and A is an
!> m by n matrix.
!>
!> This function is primarily used in calculating error bounds.
!> To protect against underflow during evaluation, components in
!> the resulting vector are perturbed away from zero by (N+1)
!> times the underflow threshold.  To prevent unnecessarily large
!> errors for block-structure embedded in general matrices,
!>  zero components are not perturbed.  A zero
!> entry is considered  if all multiplications involved
!> in computing that entry have at least one zero multiplicand.
!>
Parameters
[in]TRANS
!>          TRANS is INTEGER
!>           On entry, TRANS specifies the operation to be performed as
!>           follows:
!>
!>             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)
!>             BLAS_TRANS         y := alpha*abs(A**T)*abs(x) + beta*abs(y)
!>             BLAS_CONJ_TRANS    y := alpha*abs(A**T)*abs(x) + beta*abs(y)
!>
!>           Unchanged on exit.
!>
[in]M
!>          M is INTEGER
!>           On entry, M specifies the number of rows of the matrix A.
!>           M must be at least zero.
!>           Unchanged on exit.
!>
[in]N
!>          N is INTEGER
!>           On entry, N specifies the number of columns of the matrix A.
!>           N 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, n )
!>           Before entry, the leading m by n part of the array A must
!>           contain the matrix of coefficients.
!>           Unchanged on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>           On entry, LDA specifies the first dimension of A as declared
!>           in the calling (sub) program. LDA must be at least
!>           max( 1, m ).
!>           Unchanged on exit.
!>
[in]X
!>          X is DOUBLE PRECISION array, dimension
!>           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
!>           and at least
!>           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
!>           Before entry, the incremented array X must contain the
!>           vector x.
!>           Unchanged on exit.
!>
[in]INCX
!>          INCX is INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           X. INCX must not be zero.
!>           Unchanged on exit.
!>
[in]BETA
!>          BETA is DOUBLE PRECISION
!>           On entry, BETA specifies the scalar beta. When BETA is
!>           supplied as zero then Y need not be set on input.
!>           Unchanged on exit.
!>
[in,out]Y
!>          Y is DOUBLE PRECISION array,
!>           dimension at least
!>           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
!>           and at least
!>           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
!>           Before entry with BETA non-zero, the incremented array Y
!>           must contain the vector y. On exit, Y is overwritten by the
!>           updated vector y.
!>
[in]INCY
!>          INCY is INTEGER
!>           On entry, INCY specifies the increment for the elements of
!>           Y. INCY must not be zero.
!>           Unchanged on exit.
!>
!>  Level 2 Blas routine.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 172 of file dla_geamv.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 DOUBLE PRECISION ALPHA, BETA
181 INTEGER INCX, INCY, LDA, M, N, TRANS
182* ..
183* .. Array Arguments ..
184 DOUBLE PRECISION A( LDA, * ), X( * ), Y( * )
185* ..
186*
187* =====================================================================
188*
189* .. Parameters ..
190 DOUBLE PRECISION ONE, ZERO
191 parameter( one = 1.0d+0, zero = 0.0d+0 )
192* ..
193* .. Local Scalars ..
194 LOGICAL SYMB_ZERO
195 DOUBLE PRECISION TEMP, SAFE1
196 INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY
197* ..
198* .. External Subroutines ..
199 EXTERNAL xerbla, dlamch
200 DOUBLE PRECISION DLAMCH
201* ..
202* .. External Functions ..
203 EXTERNAL ilatrans
204 INTEGER ILATRANS
205* ..
206* .. Intrinsic Functions ..
207 INTRINSIC max, abs, sign
208* ..
209* .. Executable Statements ..
210*
211* Test the input parameters.
212*
213 info = 0
214 IF ( .NOT.( ( trans.EQ.ilatrans( 'N' ) )
215 $ .OR. ( trans.EQ.ilatrans( 'T' ) )
216 $ .OR. ( trans.EQ.ilatrans( 'C' )) ) ) THEN
217 info = 1
218 ELSE IF( m.LT.0 )THEN
219 info = 2
220 ELSE IF( n.LT.0 )THEN
221 info = 3
222 ELSE IF( lda.LT.max( 1, m ) )THEN
223 info = 6
224 ELSE IF( incx.EQ.0 )THEN
225 info = 8
226 ELSE IF( incy.EQ.0 )THEN
227 info = 11
228 END IF
229 IF( info.NE.0 )THEN
230 CALL xerbla( 'DLA_GEAMV ', info )
231 RETURN
232 END IF
233*
234* Quick return if possible.
235*
236 IF( ( m.EQ.0 ).OR.( n.EQ.0 ).OR.
237 $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
238 $ RETURN
239*
240* Set LENX and LENY, the lengths of the vectors x and y, and set
241* up the start points in X and Y.
242*
243 IF( trans.EQ.ilatrans( 'N' ) )THEN
244 lenx = n
245 leny = m
246 ELSE
247 lenx = m
248 leny = n
249 END IF
250 IF( incx.GT.0 )THEN
251 kx = 1
252 ELSE
253 kx = 1 - ( lenx - 1 )*incx
254 END IF
255 IF( incy.GT.0 )THEN
256 ky = 1
257 ELSE
258 ky = 1 - ( leny - 1 )*incy
259 END IF
260*
261* Set SAFE1 essentially to be the underflow threshold times the
262* number of additions in each row.
263*
264 safe1 = dlamch( 'Safe minimum' )
265 safe1 = (n+1)*safe1
266*
267* Form y := alpha*abs(A)*abs(x) + beta*abs(y).
268*
269* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to
270* the inexact flag. Still doesn't help change the iteration order
271* to per-column.
272*
273 iy = ky
274 IF ( incx.EQ.1 ) THEN
275 IF( trans.EQ.ilatrans( 'N' ) )THEN
276 DO i = 1, leny
277 IF ( beta .EQ. zero ) THEN
278 symb_zero = .true.
279 y( iy ) = 0.0d+0
280 ELSE IF ( y( iy ) .EQ. zero ) THEN
281 symb_zero = .true.
282 ELSE
283 symb_zero = .false.
284 y( iy ) = beta * abs( y( iy ) )
285 END IF
286 IF ( alpha .NE. zero ) THEN
287 DO j = 1, lenx
288 temp = abs( a( i, j ) )
289 symb_zero = symb_zero .AND.
290 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
291
292 y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
293 END DO
294 END IF
295
296 IF ( .NOT.symb_zero )
297 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
298
299 iy = iy + incy
300 END DO
301 ELSE
302 DO i = 1, leny
303 IF ( beta .EQ. zero ) THEN
304 symb_zero = .true.
305 y( iy ) = 0.0d+0
306 ELSE IF ( y( iy ) .EQ. zero ) THEN
307 symb_zero = .true.
308 ELSE
309 symb_zero = .false.
310 y( iy ) = beta * abs( y( iy ) )
311 END IF
312 IF ( alpha .NE. zero ) THEN
313 DO j = 1, lenx
314 temp = abs( a( j, i ) )
315 symb_zero = symb_zero .AND.
316 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
317
318 y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
319 END DO
320 END IF
321
322 IF ( .NOT.symb_zero )
323 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
324
325 iy = iy + incy
326 END DO
327 END IF
328 ELSE
329 IF( trans.EQ.ilatrans( 'N' ) )THEN
330 DO i = 1, leny
331 IF ( beta .EQ. zero ) THEN
332 symb_zero = .true.
333 y( iy ) = 0.0d+0
334 ELSE IF ( y( iy ) .EQ. zero ) THEN
335 symb_zero = .true.
336 ELSE
337 symb_zero = .false.
338 y( iy ) = beta * abs( y( iy ) )
339 END IF
340 IF ( alpha .NE. zero ) THEN
341 jx = kx
342 DO j = 1, lenx
343 temp = abs( a( i, j ) )
344 symb_zero = symb_zero .AND.
345 $ ( x( jx ) .EQ. zero .OR. temp .EQ. zero )
346
347 y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
348 jx = jx + incx
349 END DO
350 END IF
351
352 IF (.NOT.symb_zero)
353 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
354
355 iy = iy + incy
356 END DO
357 ELSE
358 DO i = 1, leny
359 IF ( beta .EQ. zero ) THEN
360 symb_zero = .true.
361 y( iy ) = 0.0d+0
362 ELSE IF ( y( iy ) .EQ. zero ) THEN
363 symb_zero = .true.
364 ELSE
365 symb_zero = .false.
366 y( iy ) = beta * abs( y( iy ) )
367 END IF
368 IF ( alpha .NE. zero ) THEN
369 jx = kx
370 DO j = 1, lenx
371 temp = abs( a( j, i ) )
372 symb_zero = symb_zero .AND.
373 $ ( x( jx ) .EQ. zero .OR. temp .EQ. zero )
374
375 y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
376 jx = jx + incx
377 END DO
378 END IF
379
380 IF (.NOT.symb_zero)
381 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
382
383 iy = iy + incy
384 END DO
385 END IF
386
387 END IF
388*
389 RETURN
390*
391* End of DLA_GEAMV
392*

◆ dla_gercond()

double precision function dla_gercond ( character trans,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
integer cmode,
double precision, dimension( * ) c,
integer info,
double precision, dimension( * ) work,
integer, dimension( * ) iwork )

DLA_GERCOND estimates the Skeel condition number for a general matrix.

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

Purpose:
!>
!>    DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)
!>    where op2 is determined by CMODE as follows
!>    CMODE =  1    op2(C) = C
!>    CMODE =  0    op2(C) = I
!>    CMODE = -1    op2(C) = inv(C)
!>    The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!>    is computed by computing scaling factors R such that
!>    diag(R)*A*op2(C) is row equilibrated and computing the standard
!>    infinity-norm condition number.
!>
Parameters
[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]N
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>     On entry, the N-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by DGETRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     The pivot indices from the factorization A = P*L*U
!>     as computed by DGETRF; row i of the matrix was interchanged
!>     with row IPIV(i).
!>
[in]CMODE
!>          CMODE is INTEGER
!>     Determines op2(C) in the formula op(A) * op2(C) as follows:
!>     CMODE =  1    op2(C) = C
!>     CMODE =  0    op2(C) = I
!>     CMODE = -1    op2(C) = inv(C)
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension (N)
!>     The vector C in the formula op(A) * op2(C).
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit.
!>     i > 0:  The ith argument is invalid.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (3*N).
!>     Workspace.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N).
!>     Workspace.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 149 of file dla_gercond.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 TRANS
159 INTEGER N, LDA, LDAF, INFO, CMODE
160* ..
161* .. Array Arguments ..
162 INTEGER IPIV( * ), IWORK( * )
163 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ),
164 $ C( * )
165* ..
166*
167* =====================================================================
168*
169* .. Local Scalars ..
170 LOGICAL NOTRANS
171 INTEGER KASE, I, J
172 DOUBLE PRECISION AINVNM, TMP
173* ..
174* .. Local Arrays ..
175 INTEGER ISAVE( 3 )
176* ..
177* .. External Functions ..
178 LOGICAL LSAME
179 EXTERNAL lsame
180* ..
181* .. External Subroutines ..
182 EXTERNAL dlacn2, dgetrs, xerbla
183* ..
184* .. Intrinsic Functions ..
185 INTRINSIC abs, max
186* ..
187* .. Executable Statements ..
188*
189 dla_gercond = 0.0d+0
190*
191 info = 0
192 notrans = lsame( trans, 'N' )
193 IF ( .NOT. notrans .AND. .NOT. lsame(trans, 'T')
194 $ .AND. .NOT. lsame(trans, 'C') ) THEN
195 info = -1
196 ELSE IF( n.LT.0 ) THEN
197 info = -2
198 ELSE IF( lda.LT.max( 1, n ) ) THEN
199 info = -4
200 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
201 info = -6
202 END IF
203 IF( info.NE.0 ) THEN
204 CALL xerbla( 'DLA_GERCOND', -info )
205 RETURN
206 END IF
207 IF( n.EQ.0 ) THEN
208 dla_gercond = 1.0d+0
209 RETURN
210 END IF
211*
212* Compute the equilibration matrix R such that
213* inv(R)*A*C has unit 1-norm.
214*
215 IF (notrans) THEN
216 DO i = 1, n
217 tmp = 0.0d+0
218 IF ( cmode .EQ. 1 ) THEN
219 DO j = 1, n
220 tmp = tmp + abs( a( i, j ) * c( j ) )
221 END DO
222 ELSE IF ( cmode .EQ. 0 ) THEN
223 DO j = 1, n
224 tmp = tmp + abs( a( i, j ) )
225 END DO
226 ELSE
227 DO j = 1, n
228 tmp = tmp + abs( a( i, j ) / c( j ) )
229 END DO
230 END IF
231 work( 2*n+i ) = tmp
232 END DO
233 ELSE
234 DO i = 1, n
235 tmp = 0.0d+0
236 IF ( cmode .EQ. 1 ) THEN
237 DO j = 1, n
238 tmp = tmp + abs( a( j, i ) * c( j ) )
239 END DO
240 ELSE IF ( cmode .EQ. 0 ) THEN
241 DO j = 1, n
242 tmp = tmp + abs( a( j, i ) )
243 END DO
244 ELSE
245 DO j = 1, n
246 tmp = tmp + abs( a( j, i ) / c( j ) )
247 END DO
248 END IF
249 work( 2*n+i ) = tmp
250 END DO
251 END IF
252*
253* Estimate the norm of inv(op(A)).
254*
255 ainvnm = 0.0d+0
256
257 kase = 0
258 10 CONTINUE
259 CALL dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
260 IF( kase.NE.0 ) THEN
261 IF( kase.EQ.2 ) THEN
262*
263* Multiply by R.
264*
265 DO i = 1, n
266 work(i) = work(i) * work(2*n+i)
267 END DO
268
269 IF (notrans) THEN
270 CALL dgetrs( 'No transpose', n, 1, af, ldaf, ipiv,
271 $ work, n, info )
272 ELSE
273 CALL dgetrs( 'Transpose', n, 1, af, ldaf, ipiv,
274 $ work, n, info )
275 END IF
276*
277* Multiply by inv(C).
278*
279 IF ( cmode .EQ. 1 ) THEN
280 DO i = 1, n
281 work( i ) = work( i ) / c( i )
282 END DO
283 ELSE IF ( cmode .EQ. -1 ) THEN
284 DO i = 1, n
285 work( i ) = work( i ) * c( i )
286 END DO
287 END IF
288 ELSE
289*
290* Multiply by inv(C**T).
291*
292 IF ( cmode .EQ. 1 ) THEN
293 DO i = 1, n
294 work( i ) = work( i ) / c( i )
295 END DO
296 ELSE IF ( cmode .EQ. -1 ) THEN
297 DO i = 1, n
298 work( i ) = work( i ) * c( i )
299 END DO
300 END IF
301
302 IF (notrans) THEN
303 CALL dgetrs( 'Transpose', n, 1, af, ldaf, ipiv,
304 $ work, n, info )
305 ELSE
306 CALL dgetrs( 'No transpose', n, 1, af, ldaf, ipiv,
307 $ work, n, info )
308 END IF
309*
310* Multiply by R.
311*
312 DO i = 1, n
313 work( i ) = work( i ) * work( 2*n+i )
314 END DO
315 END IF
316 GO TO 10
317 END IF
318*
319* Compute the estimate of the reciprocal condition number.
320*
321 IF( ainvnm .NE. 0.0d+0 )
322 $ dla_gercond = ( 1.0d+0 / ainvnm )
323*
324 RETURN
325*
326* End of DLA_GERCOND
327*

◆ dla_gerfsx_extended()

subroutine dla_gerfsx_extended ( integer prec_type,
integer trans_type,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
logical colequ,
double precision, dimension( * ) c,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( ldy, * ) y,
integer ldy,
double precision, dimension( * ) berr_out,
integer n_norms,
double precision, dimension( nrhs, * ) errs_n,
double precision, dimension( nrhs, * ) errs_c,
double precision, dimension( * ) res,
double precision, dimension( * ) ayb,
double precision, dimension( * ) dy,
double precision, dimension( * ) y_tail,
double precision rcond,
integer ithresh,
double precision rthresh,
double precision dz_ub,
logical ignore_cwise,
integer info )

DLA_GERFSX_EXTENDED improves the computed solution to a system of linear equations for general matrices by performing extra-precise iterative refinement and provides error bounds and backward error estimates for the solution.

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

Purpose:
!>
!>
!> DLA_GERFSX_EXTENDED improves the computed solution to a system of
!> linear equations by performing extra-precise iterative refinement
!> and provides error bounds and backward error estimates for the solution.
!> This subroutine is called by DGERFSX to perform iterative refinement.
!> In addition to normwise error bound, the code provides maximum
!> componentwise error bound if possible. See comments for ERRS_N
!> and ERRS_C for details of the error bounds. Note that this
!> subroutine is only responsible for setting the second fields of
!> ERRS_N and ERRS_C.
!>
Parameters
[in]PREC_TYPE
!>          PREC_TYPE is INTEGER
!>     Specifies the intermediate precision to be used in refinement.
!>     The value is defined by ILAPREC(P) where P is a CHARACTER and P
!>          = 'S':  Single
!>          = 'D':  Double
!>          = 'I':  Indigenous
!>          = 'X' or 'E':  Extra
!>
[in]TRANS_TYPE
!>          TRANS_TYPE is INTEGER
!>     Specifies the transposition operation on A.
!>     The value is defined by ILATRANS(T) where T is a CHARACTER and T
!>          = 'N':  No transpose
!>          = 'T':  Transpose
!>          = 'C':  Conjugate transpose
!>
[in]N
!>          N is INTEGER
!>     The number of linear equations, i.e., 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.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>     On entry, the N-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by DGETRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>     The pivot indices from the factorization A = P*L*U
!>     as computed by DGETRF; row i of the matrix was interchanged
!>     with row IPIV(i).
!>
[in]COLEQU
!>          COLEQU is LOGICAL
!>     If .TRUE. then column equilibration was done to A before calling
!>     this routine. This is needed to compute the solution and error
!>     bounds correctly.
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension (N)
!>     The column scale factors for A. If COLEQU = .FALSE., C
!>     is not accessed. If C is input, each element of C should be a power
!>     of the radix to ensure a reliable solution and error estimates.
!>     Scaling by powers of the radix does not cause rounding errors unless
!>     the result underflows or overflows. Rounding errors during scaling
!>     lead to refining with a matrix that is not equivalent to the
!>     input matrix, producing error estimates that may not be
!>     reliable.
!>
[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]Y
!>          Y is DOUBLE PRECISION array, dimension (LDY,NRHS)
!>     On entry, the solution matrix X, as computed by DGETRS.
!>     On exit, the improved solution matrix Y.
!>
[in]LDY
!>          LDY is INTEGER
!>     The leading dimension of the array Y.  LDY >= max(1,N).
!>
[out]BERR_OUT
!>          BERR_OUT is DOUBLE PRECISION array, dimension (NRHS)
!>     On exit, BERR_OUT(j) contains the componentwise relative backward
!>     error for right-hand-side j from the formula
!>         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
!>     where abs(Z) is the componentwise absolute value of the matrix
!>     or vector Z. This is computed by DLA_LIN_BERR.
!>
[in]N_NORMS
!>          N_NORMS is INTEGER
!>     Determines which error bounds to return (see ERRS_N
!>     and ERRS_C).
!>     If N_NORMS >= 1 return normwise error bounds.
!>     If N_NORMS >= 2 return componentwise error bounds.
!>
[in,out]ERRS_N
!>          ERRS_N is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     normwise relative error, which is defined as follows:
!>
!>     Normwise relative error in the ith solution vector:
!>             max_j (abs(XTRUE(j,i) - X(j,i)))
!>            ------------------------------
!>                  max_j abs(X(j,i))
!>
!>     The array is indexed by the type of error information as described
!>     below. There currently are up to three pieces of information
!>     returned.
!>
!>     The first index in ERRS_N(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERRS_N(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * slamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * slamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated normwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * slamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*A, where S scales each row by a power of the
!>              radix so all absolute row sums of Z are approximately 1.
!>
!>     This subroutine is only responsible for setting the second field
!>     above.
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[in,out]ERRS_C
!>          ERRS_C is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     componentwise relative error, which is defined as follows:
!>
!>     Componentwise relative error in the ith solution vector:
!>                    abs(XTRUE(j,i) - X(j,i))
!>             max_j ----------------------
!>                         abs(X(j,i))
!>
!>     The array is indexed by the right-hand side i (on which the
!>     componentwise relative error depends), and the type of error
!>     information as described below. There currently are up to three
!>     pieces of information returned for each right-hand side. If
!>     componentwise accuracy is not requested (PARAMS(3) = 0.0), then
!>     ERRS_C is not accessed.  If N_ERR_BNDS < 3, then at most
!>     the first (:,N_ERR_BNDS) entries are returned.
!>
!>     The first index in ERRS_C(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERRS_C(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * slamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * slamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated componentwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * slamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*(A*diag(x)), where x is the solution for the
!>              current right-hand side and S scales each row of
!>              A*diag(x) by a power of the radix so all absolute row
!>              sums of Z are approximately 1.
!>
!>     This subroutine is only responsible for setting the second field
!>     above.
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[in]RES
!>          RES is DOUBLE PRECISION array, dimension (N)
!>     Workspace to hold the intermediate residual.
!>
[in]AYB
!>          AYB is DOUBLE PRECISION array, dimension (N)
!>     Workspace. This can be the same workspace passed for Y_TAIL.
!>
[in]DY
!>          DY is DOUBLE PRECISION array, dimension (N)
!>     Workspace to hold the intermediate solution.
!>
[in]Y_TAIL
!>          Y_TAIL is DOUBLE PRECISION array, dimension (N)
!>     Workspace to hold the trailing bits of the intermediate solution.
!>
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>     Reciprocal scaled condition number.  This is an estimate of the
!>     reciprocal Skeel condition number of the matrix A after
!>     equilibration (if done).  If this is less than the machine
!>     precision (in particular, if it is zero), the matrix is singular
!>     to working precision.  Note that the error may still be small even
!>     if this number is very small and the matrix appears ill-
!>     conditioned.
!>
[in]ITHRESH
!>          ITHRESH is INTEGER
!>     The maximum number of residual computations allowed for
!>     refinement. The default is 10. For 'aggressive' set to 100 to
!>     permit convergence using approximate factorizations or
!>     factorizations other than LU. If the factorization uses a
!>     technique other than Gaussian elimination, the guarantees in
!>     ERRS_N and ERRS_C may no longer be trustworthy.
!>
[in]RTHRESH
!>          RTHRESH is DOUBLE PRECISION
!>     Determines when to stop refinement if the error estimate stops
!>     decreasing. Refinement will stop when the next solution no longer
!>     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is
!>     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The
!>     default value is 0.5. For 'aggressive' set to 0.9 to permit
!>     convergence on extremely ill-conditioned matrices. See LAWN 165
!>     for more details.
!>
[in]DZ_UB
!>          DZ_UB is DOUBLE PRECISION
!>     Determines when to start considering componentwise convergence.
!>     Componentwise convergence is only considered after each component
!>     of the solution Y is stable, which we define as the relative
!>     change in each component being less than DZ_UB. The default value
!>     is 0.25, requiring the first bit to be stable. See LAWN 165 for
!>     more details.
!>
[in]IGNORE_CWISE
!>          IGNORE_CWISE is LOGICAL
!>     If .TRUE. then ignore componentwise convergence. Default value
!>     is .FALSE..
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit.
!>       < 0:  if INFO = -i, the ith argument to DGETRS had an illegal
!>             value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 390 of file dla_gerfsx_extended.f.

396*
397* -- LAPACK computational routine --
398* -- LAPACK is a software package provided by Univ. of Tennessee, --
399* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
400*
401* .. Scalar Arguments ..
402 INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE,
403 $ TRANS_TYPE, N_NORMS, ITHRESH
404 LOGICAL COLEQU, IGNORE_CWISE
405 DOUBLE PRECISION RTHRESH, DZ_UB
406* ..
407* .. Array Arguments ..
408 INTEGER IPIV( * )
409 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
410 $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * )
411 DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ),
412 $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
413* ..
414*
415* =====================================================================
416*
417* .. Local Scalars ..
418 CHARACTER TRANS
419 INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE
420 DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,
421 $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,
422 $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,
423 $ EPS, HUGEVAL, INCR_THRESH
424 LOGICAL INCR_PREC
425* ..
426* .. Parameters ..
427 INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE,
428 $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL,
429 $ EXTRA_Y
430 parameter( unstable_state = 0, working_state = 1,
431 $ conv_state = 2, noprog_state = 3 )
432 parameter( base_residual = 0, extra_residual = 1,
433 $ extra_y = 2 )
434 INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I
435 INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I
436 INTEGER CMP_ERR_I, PIV_GROWTH_I
437 parameter( final_nrm_err_i = 1, final_cmp_err_i = 2,
438 $ berr_i = 3 )
439 parameter( rcond_i = 4, nrm_rcond_i = 5, nrm_err_i = 6 )
440 parameter( cmp_rcond_i = 7, cmp_err_i = 8,
441 $ piv_growth_i = 9 )
442 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
443 $ LA_LINRX_CWISE_I
444 parameter( la_linrx_itref_i = 1,
445 $ la_linrx_ithresh_i = 2 )
446 parameter( la_linrx_cwise_i = 3 )
447 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
448 $ LA_LINRX_RCOND_I
449 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
450 parameter( la_linrx_rcond_i = 3 )
451* ..
452* .. External Subroutines ..
453 EXTERNAL daxpy, dcopy, dgetrs, dgemv, blas_dgemv_x,
454 $ blas_dgemv2_x, dla_geamv, dla_wwaddw, dlamch,
455 $ chla_transtype, dla_lin_berr
456 DOUBLE PRECISION DLAMCH
457 CHARACTER CHLA_TRANSTYPE
458* ..
459* .. Intrinsic Functions ..
460 INTRINSIC abs, max, min
461* ..
462* .. Executable Statements ..
463*
464 IF ( info.NE.0 ) RETURN
465 trans = chla_transtype(trans_type)
466 eps = dlamch( 'Epsilon' )
467 hugeval = dlamch( 'Overflow' )
468* Force HUGEVAL to Inf
469 hugeval = hugeval * hugeval
470* Using HUGEVAL may lead to spurious underflows.
471 incr_thresh = dble( n ) * eps
472*
473 DO j = 1, nrhs
474 y_prec_state = extra_residual
475 IF ( y_prec_state .EQ. extra_y ) THEN
476 DO i = 1, n
477 y_tail( i ) = 0.0d+0
478 END DO
479 END IF
480
481 dxrat = 0.0d+0
482 dxratmax = 0.0d+0
483 dzrat = 0.0d+0
484 dzratmax = 0.0d+0
485 final_dx_x = hugeval
486 final_dz_z = hugeval
487 prevnormdx = hugeval
488 prev_dz_z = hugeval
489 dz_z = hugeval
490 dx_x = hugeval
491
492 x_state = working_state
493 z_state = unstable_state
494 incr_prec = .false.
495
496 DO cnt = 1, ithresh
497*
498* Compute residual RES = B_s - op(A_s) * Y,
499* op(A) = A, A**T, or A**H depending on TRANS (and type).
500*
501 CALL dcopy( n, b( 1, j ), 1, res, 1 )
502 IF ( y_prec_state .EQ. base_residual ) THEN
503 CALL dgemv( trans, n, n, -1.0d+0, a, lda, y( 1, j ), 1,
504 $ 1.0d+0, res, 1 )
505 ELSE IF ( y_prec_state .EQ. extra_residual ) THEN
506 CALL blas_dgemv_x( trans_type, n, n, -1.0d+0, a, lda,
507 $ y( 1, j ), 1, 1.0d+0, res, 1, prec_type )
508 ELSE
509 CALL blas_dgemv2_x( trans_type, n, n, -1.0d+0, a, lda,
510 $ y( 1, j ), y_tail, 1, 1.0d+0, res, 1, prec_type )
511 END IF
512
513! XXX: RES is no longer needed.
514 CALL dcopy( n, res, 1, dy, 1 )
515 CALL dgetrs( trans, n, 1, af, ldaf, ipiv, dy, n, info )
516*
517* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT.
518*
519 normx = 0.0d+0
520 normy = 0.0d+0
521 normdx = 0.0d+0
522 dz_z = 0.0d+0
523 ymin = hugeval
524*
525 DO i = 1, n
526 yk = abs( y( i, j ) )
527 dyk = abs( dy( i ) )
528
529 IF ( yk .NE. 0.0d+0 ) THEN
530 dz_z = max( dz_z, dyk / yk )
531 ELSE IF ( dyk .NE. 0.0d+0 ) THEN
532 dz_z = hugeval
533 END IF
534
535 ymin = min( ymin, yk )
536
537 normy = max( normy, yk )
538
539 IF ( colequ ) THEN
540 normx = max( normx, yk * c( i ) )
541 normdx = max( normdx, dyk * c( i ) )
542 ELSE
543 normx = normy
544 normdx = max( normdx, dyk )
545 END IF
546 END DO
547
548 IF ( normx .NE. 0.0d+0 ) THEN
549 dx_x = normdx / normx
550 ELSE IF ( normdx .EQ. 0.0d+0 ) THEN
551 dx_x = 0.0d+0
552 ELSE
553 dx_x = hugeval
554 END IF
555
556 dxrat = normdx / prevnormdx
557 dzrat = dz_z / prev_dz_z
558*
559* Check termination criteria
560*
561 IF (.NOT.ignore_cwise
562 $ .AND. ymin*rcond .LT. incr_thresh*normy
563 $ .AND. y_prec_state .LT. extra_y)
564 $ incr_prec = .true.
565
566 IF ( x_state .EQ. noprog_state .AND. dxrat .LE. rthresh )
567 $ x_state = working_state
568 IF ( x_state .EQ. working_state ) THEN
569 IF ( dx_x .LE. eps ) THEN
570 x_state = conv_state
571 ELSE IF ( dxrat .GT. rthresh ) THEN
572 IF ( y_prec_state .NE. extra_y ) THEN
573 incr_prec = .true.
574 ELSE
575 x_state = noprog_state
576 END IF
577 ELSE
578 IF ( dxrat .GT. dxratmax ) dxratmax = dxrat
579 END IF
580 IF ( x_state .GT. working_state ) final_dx_x = dx_x
581 END IF
582
583 IF ( z_state .EQ. unstable_state .AND. dz_z .LE. dz_ub )
584 $ z_state = working_state
585 IF ( z_state .EQ. noprog_state .AND. dzrat .LE. rthresh )
586 $ z_state = working_state
587 IF ( z_state .EQ. working_state ) THEN
588 IF ( dz_z .LE. eps ) THEN
589 z_state = conv_state
590 ELSE IF ( dz_z .GT. dz_ub ) THEN
591 z_state = unstable_state
592 dzratmax = 0.0d+0
593 final_dz_z = hugeval
594 ELSE IF ( dzrat .GT. rthresh ) THEN
595 IF ( y_prec_state .NE. extra_y ) THEN
596 incr_prec = .true.
597 ELSE
598 z_state = noprog_state
599 END IF
600 ELSE
601 IF ( dzrat .GT. dzratmax ) dzratmax = dzrat
602 END IF
603 IF ( z_state .GT. working_state ) final_dz_z = dz_z
604 END IF
605*
606* Exit if both normwise and componentwise stopped working,
607* but if componentwise is unstable, let it go at least two
608* iterations.
609*
610 IF ( x_state.NE.working_state ) THEN
611 IF ( ignore_cwise) GOTO 666
612 IF ( z_state.EQ.noprog_state .OR. z_state.EQ.conv_state )
613 $ GOTO 666
614 IF ( z_state.EQ.unstable_state .AND. cnt.GT.1 ) GOTO 666
615 END IF
616
617 IF ( incr_prec ) THEN
618 incr_prec = .false.
619 y_prec_state = y_prec_state + 1
620 DO i = 1, n
621 y_tail( i ) = 0.0d+0
622 END DO
623 END IF
624
625 prevnormdx = normdx
626 prev_dz_z = dz_z
627*
628* Update soluton.
629*
630 IF ( y_prec_state .LT. extra_y ) THEN
631 CALL daxpy( n, 1.0d+0, dy, 1, y( 1, j ), 1 )
632 ELSE
633 CALL dla_wwaddw( n, y( 1, j ), y_tail, dy )
634 END IF
635
636 END DO
637* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT.
638 666 CONTINUE
639*
640* Set final_* when cnt hits ithresh.
641*
642 IF ( x_state .EQ. working_state ) final_dx_x = dx_x
643 IF ( z_state .EQ. working_state ) final_dz_z = dz_z
644*
645* Compute error bounds
646*
647 IF (n_norms .GE. 1) THEN
648 errs_n( j, la_linrx_err_i ) = final_dx_x / (1 - dxratmax)
649 END IF
650 IF ( n_norms .GE. 2 ) THEN
651 errs_c( j, la_linrx_err_i ) = final_dz_z / (1 - dzratmax)
652 END IF
653*
654* Compute componentwise relative backward error from formula
655* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
656* where abs(Z) is the componentwise absolute value of the matrix
657* or vector Z.
658*
659* Compute residual RES = B_s - op(A_s) * Y,
660* op(A) = A, A**T, or A**H depending on TRANS (and type).
661*
662 CALL dcopy( n, b( 1, j ), 1, res, 1 )
663 CALL dgemv( trans, n, n, -1.0d+0, a, lda, y(1,j), 1, 1.0d+0,
664 $ res, 1 )
665
666 DO i = 1, n
667 ayb( i ) = abs( b( i, j ) )
668 END DO
669*
670* Compute abs(op(A_s))*abs(Y) + abs(B_s).
671*
672 CALL dla_geamv ( trans_type, n, n, 1.0d+0,
673 $ a, lda, y(1, j), 1, 1.0d+0, ayb, 1 )
674
675 CALL dla_lin_berr ( n, n, 1, res, ayb, berr_out( j ) )
676*
677* End of loop for each RHS.
678*
679 END DO
680*
681 RETURN
682*
683* End of DLA_GERFSX_EXTENDED
684*
chla_transtype
character *1 function chla_transtype(trans)
CHLA_TRANSTYPE
Definition chla_transtype.f:58
dla_geamv
subroutine dla_geamv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
DLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds.
Definition dla_geamv.f:174
dla_lin_berr
subroutine dla_lin_berr(n, nz, nrhs, res, ayb, berr)
DLA_LIN_BERR computes a component-wise relative backward error.
Definition dla_lin_berr.f:101
dla_wwaddw
subroutine dla_wwaddw(n, x, y, w)
DLA_WWADDW adds a vector into a doubled-single vector.
Definition dla_wwaddw.f:81

◆ dla_gerpvgrw()

double precision function dla_gerpvgrw ( integer n,
integer ncols,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldaf, * ) af,
integer ldaf )

DLA_GERPVGRW

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

Purpose:
!>
!>
!> DLA_GERPVGRW computes the reciprocal pivot growth factor
!> norm(A)/norm(U). The  norm is used. If this is
!> much less than 1, the stability of the LU factorization of the
!> (equilibrated) matrix A could be poor. This also means that the
!> solution X, estimated condition numbers, and error bounds could be
!> unreliable.
!>
Parameters
[in]N
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!>
[in]NCOLS
!>          NCOLS is INTEGER
!>     The number of columns of the matrix A. NCOLS >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>     On entry, the N-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by DGETRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 98 of file dla_gerpvgrw.f.

100*
101* -- LAPACK computational routine --
102* -- LAPACK is a software package provided by Univ. of Tennessee, --
103* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
104*
105* .. Scalar Arguments ..
106 INTEGER N, NCOLS, LDA, LDAF
107* ..
108* .. Array Arguments ..
109 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * )
110* ..
111*
112* =====================================================================
113*
114* .. Local Scalars ..
115 INTEGER I, J
116 DOUBLE PRECISION AMAX, UMAX, RPVGRW
117* ..
118* .. Intrinsic Functions ..
119 INTRINSIC abs, max, min
120* ..
121* .. Executable Statements ..
122*
123 rpvgrw = 1.0d+0
124
125 DO j = 1, ncols
126 amax = 0.0d+0
127 umax = 0.0d+0
128 DO i = 1, n
129 amax = max( abs( a( i, j ) ), amax )
130 END DO
131 DO i = 1, j
132 umax = max( abs( af( i, j ) ), umax )
133 END DO
134 IF ( umax /= 0.0d+0 ) THEN
135 rpvgrw = min( amax / umax, rpvgrw )
136 END IF
137 END DO
138 dla_gerpvgrw = rpvgrw
139*
140* End of DLA_GERPVGRW
141*
dla_gerpvgrw
double precision function dla_gerpvgrw(n, ncols, a, lda, af, ldaf)
DLA_GERPVGRW
Definition dla_gerpvgrw.f:100

◆ dlaorhr_col_getrfnp()

subroutine dlaorhr_col_getrfnp ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
integer info )

DLAORHR_COL_GETRFNP

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

Purpose:
!>
!> DLAORHR_COL_GETRFNP computes the modified LU factorization without
!> pivoting of a real general M-by-N matrix A. The factorization has
!> the form:
!>
!>     A - S = L * U,
!>
!> where:
!>    S is a m-by-n diagonal sign matrix with the diagonal D, so that
!>    D(i) = S(i,i), 1 <= i <= min(M,N). The diagonal D is constructed
!>    as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing
!>    i-1 steps of Gaussian elimination. This means that the diagonal
!>    element at each step of  Gaussian elimination is
!>    at least one in absolute value (so that division-by-zero not
!>    not possible during the division by the diagonal element);
!>
!>    L is a M-by-N lower triangular matrix with unit diagonal elements
!>    (lower trapezoidal if M > N);
!>
!>    and U is a M-by-N upper triangular matrix
!>    (upper trapezoidal if M < N).
!>
!> This routine is an auxiliary routine used in the Householder
!> reconstruction routine DORHR_COL. In DORHR_COL, this routine is
!> applied to an M-by-N matrix A with orthonormal columns, where each
!> element is bounded by one in absolute value. With the choice of
!> the matrix S above, one can show that the diagonal element at each
!> step of Gaussian elimination is the largest (in absolute value) in
!> the column on or below the diagonal, so that no pivoting is required
!> for numerical stability [1].
!>
!> For more details on the Householder reconstruction algorithm,
!> including the modified LU factorization, see [1].
!>
!> This is the blocked right-looking version of the algorithm,
!> calling Level 3 BLAS to update the submatrix. To factorize a block,
!> this routine calls the recursive routine DLAORHR_COL_GETRFNP2.
!>
!> [1] ,
!>     G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen,
!>     E. Solomonik, J. Parallel Distrib. Comput.,
!>     vol. 85, pp. 3-31, 2015.
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A-S=L*U; the unit diagonal elements of L are not stored.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension min(M,N)
!>          The diagonal elements of the diagonal M-by-N sign matrix S,
!>          D(i) = S(i,i), where 1 <= i <= min(M,N). The elements can
!>          be only plus or minus one.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if 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 145 of file dlaorhr_col_getrfnp.f.

146 IMPLICIT NONE
147*
148* -- LAPACK computational routine --
149* -- LAPACK is a software package provided by Univ. of Tennessee, --
150* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
151*
152* .. Scalar Arguments ..
153 INTEGER INFO, LDA, M, N
154* ..
155* .. Array Arguments ..
156 DOUBLE PRECISION A( LDA, * ), D( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 DOUBLE PRECISION ONE
163 parameter( one = 1.0d+0 )
164* ..
165* .. Local Scalars ..
166 INTEGER IINFO, J, JB, NB
167* ..
168* .. External Subroutines ..
169 EXTERNAL dgemm, dlaorhr_col_getrfnp2, dtrsm, xerbla
170* ..
171* .. External Functions ..
172 INTEGER ILAENV
173 EXTERNAL ilaenv
174* ..
175* .. Intrinsic Functions ..
176 INTRINSIC max, min
177* ..
178* .. Executable Statements ..
179*
180* Test the input parameters.
181*
182 info = 0
183 IF( m.LT.0 ) THEN
184 info = -1
185 ELSE IF( n.LT.0 ) THEN
186 info = -2
187 ELSE IF( lda.LT.max( 1, m ) ) THEN
188 info = -4
189 END IF
190 IF( info.NE.0 ) THEN
191 CALL xerbla( 'DLAORHR_COL_GETRFNP', -info )
192 RETURN
193 END IF
194*
195* Quick return if possible
196*
197 IF( min( m, n ).EQ.0 )
198 $ RETURN
199*
200* Determine the block size for this environment.
201*
202
203 nb = ilaenv( 1, 'DLAORHR_COL_GETRFNP', ' ', m, n, -1, -1 )
204
205 IF( nb.LE.1 .OR. nb.GE.min( m, n ) ) THEN
206*
207* Use unblocked code.
208*
209 CALL dlaorhr_col_getrfnp2( m, n, a, lda, d, info )
210 ELSE
211*
212* Use blocked code.
213*
214 DO j = 1, min( m, n ), nb
215 jb = min( min( m, n )-j+1, nb )
216*
217* Factor diagonal and subdiagonal blocks.
218*
219 CALL dlaorhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,
220 $ d( j ), iinfo )
221*
222 IF( j+jb.LE.n ) THEN
223*
224* Compute block row of U.
225*
226 CALL dtrsm( 'Left', 'Lower', 'No transpose', 'Unit', jb,
227 $ n-j-jb+1, one, a( j, j ), lda, a( j, j+jb ),
228 $ lda )
229 IF( j+jb.LE.m ) THEN
230*
231* Update trailing submatrix.
232*
233 CALL dgemm( 'No transpose', 'No transpose', m-j-jb+1,
234 $ n-j-jb+1, jb, -one, a( j+jb, j ), lda,
235 $ a( j, j+jb ), lda, one, a( j+jb, j+jb ),
236 $ lda )
237 END IF
238 END IF
239 END DO
240 END IF
241 RETURN
242*
243* End of DLAORHR_COL_GETRFNP
244*
dlaorhr_col_getrfnp2
recursive subroutine dlaorhr_col_getrfnp2(m, n, a, lda, d, info)
DLAORHR_COL_GETRFNP2
Definition dlaorhr_col_getrfnp2.f:167

◆ dlaorhr_col_getrfnp2()

recursive subroutine dlaorhr_col_getrfnp2 ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
integer info )

DLAORHR_COL_GETRFNP2

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

Purpose:
!>
!> DLAORHR_COL_GETRFNP2 computes the modified LU factorization without
!> pivoting of a real general M-by-N matrix A. The factorization has
!> the form:
!>
!>     A - S = L * U,
!>
!> where:
!>    S is a m-by-n diagonal sign matrix with the diagonal D, so that
!>    D(i) = S(i,i), 1 <= i <= min(M,N). The diagonal D is constructed
!>    as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing
!>    i-1 steps of Gaussian elimination. This means that the diagonal
!>    element at each step of  Gaussian elimination is at
!>    least one in absolute value (so that division-by-zero not
!>    possible during the division by the diagonal element);
!>
!>    L is a M-by-N lower triangular matrix with unit diagonal elements
!>    (lower trapezoidal if M > N);
!>
!>    and U is a M-by-N upper triangular matrix
!>    (upper trapezoidal if M < N).
!>
!> This routine is an auxiliary routine used in the Householder
!> reconstruction routine DORHR_COL. In DORHR_COL, this routine is
!> applied to an M-by-N matrix A with orthonormal columns, where each
!> element is bounded by one in absolute value. With the choice of
!> the matrix S above, one can show that the diagonal element at each
!> step of Gaussian elimination is the largest (in absolute value) in
!> the column on or below the diagonal, so that no pivoting is required
!> for numerical stability [1].
!>
!> For more details on the Householder reconstruction algorithm,
!> including the modified LU factorization, see [1].
!>
!> This is the recursive version of the LU factorization algorithm.
!> Denote A - S by B. The algorithm divides the matrix B into four
!> submatrices:
!>
!>        [  B11 | B12  ]  where B11 is n1 by n1,
!>    B = [ -----|----- ]        B21 is (m-n1) by n1,
!>        [  B21 | B22  ]        B12 is n1 by n2,
!>                               B22 is (m-n1) by n2,
!>                               with n1 = min(m,n)/2, n2 = n-n1.
!>
!>
!> The subroutine calls itself to factor B11, solves for B21,
!> solves for B12, updates B22, then calls itself to factor B22.
!>
!> For more details on the recursive LU algorithm, see [2].
!>
!> DLAORHR_COL_GETRFNP2 is called to factorize a block by the blocked
!> routine DLAORHR_COL_GETRFNP, which uses blocked code calling
!> Level 3 BLAS to update the submatrix. However, DLAORHR_COL_GETRFNP2
!> is self-sufficient and can be used without DLAORHR_COL_GETRFNP.
!>
!> [1] ,
!>     G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen,
!>     E. Solomonik, J. Parallel Distrib. Comput.,
!>     vol. 85, pp. 3-31, 2015.
!>
!> [2] , F. Gustavson, IBM J. of Res. and Dev.,
!>     vol. 41, no. 6, pp. 737-755, 1997.
!>
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,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A-S=L*U; the unit diagonal elements of L are not stored.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension min(M,N)
!>          The diagonal elements of the diagonal M-by-N sign matrix S,
!>          D(i) = S(i,i), where 1 <= i <= min(M,N). The elements can
!>          be only plus or minus one.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if 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 166 of file dlaorhr_col_getrfnp2.f.

167 IMPLICIT NONE
168*
169* -- LAPACK computational routine --
170* -- LAPACK is a software package provided by Univ. of Tennessee, --
171* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172*
173* .. Scalar Arguments ..
174 INTEGER INFO, LDA, M, N
175* ..
176* .. Array Arguments ..
177 DOUBLE PRECISION A( LDA, * ), D( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 DOUBLE PRECISION ONE
184 parameter( one = 1.0d+0 )
185* ..
186* .. Local Scalars ..
187 DOUBLE PRECISION SFMIN
188 INTEGER I, IINFO, N1, N2
189* ..
190* .. External Functions ..
191 DOUBLE PRECISION DLAMCH
192 EXTERNAL dlamch
193* ..
194* .. External Subroutines ..
195 EXTERNAL dgemm, dscal, dtrsm, xerbla
196* ..
197* .. Intrinsic Functions ..
198 INTRINSIC abs, dsign, max, min
199* ..
200* .. Executable Statements ..
201*
202* Test the input parameters
203*
204 info = 0
205 IF( m.LT.0 ) THEN
206 info = -1
207 ELSE IF( n.LT.0 ) THEN
208 info = -2
209 ELSE IF( lda.LT.max( 1, m ) ) THEN
210 info = -4
211 END IF
212 IF( info.NE.0 ) THEN
213 CALL xerbla( 'DLAORHR_COL_GETRFNP2', -info )
214 RETURN
215 END IF
216*
217* Quick return if possible
218*
219 IF( min( m, n ).EQ.0 )
220 $ RETURN
221
222 IF ( m.EQ.1 ) THEN
223*
224* One row case, (also recursion termination case),
225* use unblocked code
226*
227* Transfer the sign
228*
229 d( 1 ) = -dsign( one, a( 1, 1 ) )
230*
231* Construct the row of U
232*
233 a( 1, 1 ) = a( 1, 1 ) - d( 1 )
234*
235 ELSE IF( n.EQ.1 ) THEN
236*
237* One column case, (also recursion termination case),
238* use unblocked code
239*
240* Transfer the sign
241*
242 d( 1 ) = -dsign( one, a( 1, 1 ) )
243*
244* Construct the row of U
245*
246 a( 1, 1 ) = a( 1, 1 ) - d( 1 )
247*
248* Scale the elements 2:M of the column
249*
250* Determine machine safe minimum
251*
252 sfmin = dlamch('S')
253*
254* Construct the subdiagonal elements of L
255*
256 IF( abs( a( 1, 1 ) ) .GE. sfmin ) THEN
257 CALL dscal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 )
258 ELSE
259 DO i = 2, m
260 a( i, 1 ) = a( i, 1 ) / a( 1, 1 )
261 END DO
262 END IF
263*
264 ELSE
265*
266* Divide the matrix B into four submatrices
267*
268 n1 = min( m, n ) / 2
269 n2 = n-n1
270
271*
272* Factor B11, recursive call
273*
274 CALL dlaorhr_col_getrfnp2( n1, n1, a, lda, d, iinfo )
275*
276* Solve for B21
277*
278 CALL dtrsm( 'R', 'U', 'N', 'N', m-n1, n1, one, a, lda,
279 $ a( n1+1, 1 ), lda )
280*
281* Solve for B12
282*
283 CALL dtrsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,
284 $ a( 1, n1+1 ), lda )
285*
286* Update B22, i.e. compute the Schur complement
287* B22 := B22 - B21*B12
288*
289 CALL dgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,
290 $ a( 1, n1+1 ), lda, one, a( n1+1, n1+1 ), lda )
291*
292* Factor B22, recursive call
293*
294 CALL dlaorhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,
295 $ d( n1+1 ), iinfo )
296*
297 END IF
298 RETURN
299*
300* End of DLAORHR_COL_GETRFNP2
301*

◆ dlaqz0()

recursive subroutine dlaqz0 ( character, intent(in) wants,
character, intent(in) wantq,
character, intent(in) wantz,
integer, intent(in) n,
integer, intent(in) ilo,
integer, intent(in) ihi,
double precision, dimension( lda, * ), intent(inout) a,
integer, intent(in) lda,
double precision, dimension( ldb, * ), intent(inout) b,
integer, intent(in) ldb,
double precision, dimension( * ), intent(inout) alphar,
double precision, dimension( * ), intent(inout) alphai,
double precision, dimension( * ), intent(inout) beta,
double precision, dimension( ldq, * ), intent(inout) q,
integer, intent(in) ldq,
double precision, dimension( ldz, * ), intent(inout) z,
integer, intent(in) ldz,
double precision, dimension( * ), intent(inout) work,
integer, intent(in) lwork,
integer, intent(in) rec,
integer, intent(out) info )

DLAQZ0

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

Purpose:
!>
!> DLAQZ0 computes the eigenvalues of a real matrix pair (H,T),
!> where H is an upper Hessenberg matrix and T is upper triangular,
!> using the double-shift QZ method.
!> Matrix pairs of this type are produced by the reduction to
!> generalized upper Hessenberg form of a real matrix pair (A,B):
!>
!>    A = Q1*H*Z1**T,  B = Q1*T*Z1**T,
!>
!> as computed by DGGHRD.
!>
!> If JOB='S', then the Hessenberg-triangular pair (H,T) is
!> also reduced to generalized Schur form,
!>
!>    H = Q*S*Z**T,  T = Q*P*Z**T,
!>
!> where Q and Z are orthogonal matrices, P is an upper triangular
!> matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
!> diagonal blocks.
!>
!> The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
!> (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
!> eigenvalues.
!>
!> Additionally, the 2-by-2 upper triangular diagonal blocks of P
!> corresponding to 2-by-2 blocks of S are reduced to positive diagonal
!> form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
!> P(j,j) > 0, and P(j+1,j+1) > 0.
!>
!> Optionally, the orthogonal matrix Q from the generalized Schur
!> factorization may be postmultiplied into an input matrix Q1, and the
!> orthogonal matrix Z may be postmultiplied into an input matrix Z1.
!> If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced
!> the matrix pair (A,B) to generalized upper Hessenberg form, then the
!> output matrices Q1*Q and Z1*Z are the orthogonal factors from the
!> generalized Schur factorization of (A,B):
!>
!>    A = (Q1*Q)*S*(Z1*Z)**T,  B = (Q1*Q)*P*(Z1*Z)**T.
!>
!> To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
!> of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
!> complex and beta real.
!> If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
!> generalized nonsymmetric eigenvalue problem (GNEP)
!>    A*x = lambda*B*x
!> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
!> alternate form of the GNEP
!>    mu*A*y = B*y.
!> Real eigenvalues can be read directly from the generalized Schur
!> form:
!>   alpha = S(i,i), beta = P(i,i).
!>
!> Ref: C.B. Moler & G.W. Stewart, , SIAM J. Numer. Anal., 10(1973),
!>      pp. 241--256.
!>
!> Ref: B. Kagstrom, D. Kressner, , SIAM J. Numer.
!>      Anal., 29(2006), pp. 199--227.
!>
!> Ref: T. Steel, D. Camps, K. Meerbergen, R. Vandebril 
!>
Parameters
[in]WANTS
!>          WANTS is CHARACTER*1
!>          = 'E': Compute eigenvalues only;
!>          = 'S': Compute eigenvalues and the Schur form.
!>
[in]WANTQ
!>          WANTQ is CHARACTER*1
!>          = 'N': Left Schur vectors (Q) are not computed;
!>          = 'I': Q is initialized to the unit matrix and the matrix Q
!>                 of left Schur vectors of (A,B) is returned;
!>          = 'V': Q must contain an orthogonal matrix Q1 on entry and
!>                 the product Q1*Q is returned.
!>
[in]WANTZ
!>          WANTZ is CHARACTER*1
!>          = 'N': Right Schur vectors (Z) are not computed;
!>          = 'I': Z is initialized to the unit matrix and the matrix Z
!>                 of right Schur vectors of (A,B) 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, B, Q, and Z.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>          ILO and IHI mark the rows and columns of A which are in
!>          Hessenberg form.  It is assumed that A is already upper
!>          triangular in rows and columns 1:ILO-1 and IHI+1:N.
!>          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA, N)
!>          On entry, the N-by-N upper Hessenberg matrix A.
!>          On exit, if JOB = 'S', A contains the upper quasi-triangular
!>          matrix S from the generalized Schur factorization.
!>          If JOB = 'E', the diagonal blocks of A match those of S, but
!>          the rest of A is unspecified.
!>
[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, if JOB = 'S', B contains the upper triangular
!>          matrix P from the generalized Schur factorization;
!>          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
!>          are reduced to positive diagonal form, i.e., if A(j+1,j) is
!>          non-zero, then B(j+1,j) = B(j,j+1) = 0, B(j,j) > 0, and
!>          B(j+1,j+1) > 0.
!>          If JOB = 'E', the diagonal blocks of B match those of P, but
!>          the rest of B is unspecified.
!>
[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)
!>          The real parts of each scalar alpha defining an eigenvalue
!>          of GNEP.
!>
[out]ALPHAI
!>          ALPHAI is DOUBLE PRECISION array, dimension (N)
!>          The imaginary parts of each scalar alpha defining an
!>          eigenvalue of GNEP.
!>          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) = -ALPHAI(j).
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>          The scalars beta that define the eigenvalues of GNEP.
!>          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
!>          beta = BETA(j) represent the j-th eigenvalue of the matrix
!>          pair (A,B), in one of the forms lambda = alpha/beta or
!>          mu = beta/alpha.  Since either lambda or mu may overflow,
!>          they should not, in general, be computed.
!>
[in,out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in
!>          the reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPQ = 'I', the orthogonal matrix of left Schur
!>          vectors of (A,B), and if COMPQ = 'V', the orthogonal matrix
!>          of left Schur vectors of (A,B).
!>          Not referenced if COMPQ = 'N'.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= 1.
!>          If COMPQ='V' or 'I', then LDQ >= N.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
!>          the reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPZ = 'I', the orthogonal matrix of
!>          right Schur vectors of (H,T), and if COMPZ = 'V', the
!>          orthogonal matrix of right Schur vectors of (A,B).
!>          Not referenced if COMPZ = 'N'.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1.
!>          If COMPZ='V' or 'I', then LDZ >= 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 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.
!>
[in]REC
!>          REC is INTEGER
!>             REC indicates the current recursion level. Should be set
!>             to 0 on first call.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          = 1,...,N: the QZ iteration did not converge.  (A,B) is not
!>                     in Schur form, but ALPHAR(i), ALPHAI(i), and
!>                     BETA(i), i=INFO+1,...,N should be correct.
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 302 of file dlaqz0.f.

306 IMPLICIT NONE
307
308* Arguments
309 CHARACTER, INTENT( IN ) :: WANTS, WANTQ, WANTZ
310 INTEGER, INTENT( IN ) :: N, ILO, IHI, LDA, LDB, LDQ, LDZ, LWORK,
311 $ REC
312
313 INTEGER, INTENT( OUT ) :: INFO
314
315 DOUBLE PRECISION, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ),
316 $ Q( LDQ, * ), Z( LDZ, * ), ALPHAR( * ),
317 $ ALPHAI( * ), BETA( * ), WORK( * )
318
319* Parameters
320 DOUBLE PRECISION :: ZERO, ONE, HALF
321 parameter( zero = 0.0d0, one = 1.0d0, half = 0.5d0 )
322
323* Local scalars
324 DOUBLE PRECISION :: SMLNUM, ULP, ESHIFT, SAFMIN, SAFMAX, C1, S1,
325 $ TEMP, SWAP
326 INTEGER :: ISTART, ISTOP, IITER, MAXIT, ISTART2, K, LD, NSHIFTS,
327 $ NBLOCK, NW, NMIN, NIBBLE, N_UNDEFLATED, N_DEFLATED,
328 $ NS, SWEEP_INFO, SHIFTPOS, LWORKREQ, K2, ISTARTM,
329 $ ISTOPM, IWANTS, IWANTQ, IWANTZ, NORM_INFO, AED_INFO,
330 $ NWR, NBR, NSR, ITEMP1, ITEMP2, RCOST, I
331 LOGICAL :: ILSCHUR, ILQ, ILZ
332 CHARACTER :: JBCMPZ*3
333
334* External Functions
335 EXTERNAL :: xerbla, dhgeqz, dlaset, dlaqz3, dlaqz4, dlabad,
336 $ dlartg, drot
337 DOUBLE PRECISION, EXTERNAL :: DLAMCH
338 LOGICAL, EXTERNAL :: LSAME
339 INTEGER, EXTERNAL :: ILAENV
340
341*
342* Decode wantS,wantQ,wantZ
343*
344 IF( lsame( wants, 'E' ) ) THEN
345 ilschur = .false.
346 iwants = 1
347 ELSE IF( lsame( wants, 'S' ) ) THEN
348 ilschur = .true.
349 iwants = 2
350 ELSE
351 iwants = 0
352 END IF
353
354 IF( lsame( wantq, 'N' ) ) THEN
355 ilq = .false.
356 iwantq = 1
357 ELSE IF( lsame( wantq, 'V' ) ) THEN
358 ilq = .true.
359 iwantq = 2
360 ELSE IF( lsame( wantq, 'I' ) ) THEN
361 ilq = .true.
362 iwantq = 3
363 ELSE
364 iwantq = 0
365 END IF
366
367 IF( lsame( wantz, 'N' ) ) THEN
368 ilz = .false.
369 iwantz = 1
370 ELSE IF( lsame( wantz, 'V' ) ) THEN
371 ilz = .true.
372 iwantz = 2
373 ELSE IF( lsame( wantz, 'I' ) ) THEN
374 ilz = .true.
375 iwantz = 3
376 ELSE
377 iwantz = 0
378 END IF
379*
380* Check Argument Values
381*
382 info = 0
383 IF( iwants.EQ.0 ) THEN
384 info = -1
385 ELSE IF( iwantq.EQ.0 ) THEN
386 info = -2
387 ELSE IF( iwantz.EQ.0 ) THEN
388 info = -3
389 ELSE IF( n.LT.0 ) THEN
390 info = -4
391 ELSE IF( ilo.LT.1 ) THEN
392 info = -5
393 ELSE IF( ihi.GT.n .OR. ihi.LT.ilo-1 ) THEN
394 info = -6
395 ELSE IF( lda.LT.n ) THEN
396 info = -8
397 ELSE IF( ldb.LT.n ) THEN
398 info = -10
399 ELSE IF( ldq.LT.1 .OR. ( ilq .AND. ldq.LT.n ) ) THEN
400 info = -15
401 ELSE IF( ldz.LT.1 .OR. ( ilz .AND. ldz.LT.n ) ) THEN
402 info = -17
403 END IF
404 IF( info.NE.0 ) THEN
405 CALL xerbla( 'DLAQZ0', -info )
406 RETURN
407 END IF
408
409*
410* Quick return if possible
411*
412 IF( n.LE.0 ) THEN
413 work( 1 ) = dble( 1 )
414 RETURN
415 END IF
416
417*
418* Get the parameters
419*
420 jbcmpz( 1:1 ) = wants
421 jbcmpz( 2:2 ) = wantq
422 jbcmpz( 3:3 ) = wantz
423
424 nmin = ilaenv( 12, 'DLAQZ0', jbcmpz, n, ilo, ihi, lwork )
425
426 nwr = ilaenv( 13, 'DLAQZ0', jbcmpz, n, ilo, ihi, lwork )
427 nwr = max( 2, nwr )
428 nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr )
429
430 nibble = ilaenv( 14, 'DLAQZ0', jbcmpz, n, ilo, ihi, lwork )
431
432 nsr = ilaenv( 15, 'DLAQZ0', jbcmpz, n, ilo, ihi, lwork )
433 nsr = min( nsr, ( n+6 ) / 9, ihi-ilo )
434 nsr = max( 2, nsr-mod( nsr, 2 ) )
435
436 rcost = ilaenv( 17, 'DLAQZ0', jbcmpz, n, ilo, ihi, lwork )
437 itemp1 = int( nsr/sqrt( 1+2*nsr/( dble( rcost )/100*n ) ) )
438 itemp1 = ( ( itemp1-1 )/4 )*4+4
439 nbr = nsr+itemp1
440
441 IF( n .LT. nmin .OR. rec .GE. 2 ) THEN
442 CALL dhgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,
443 $ alphar, alphai, beta, q, ldq, z, ldz, work,
444 $ lwork, info )
445 RETURN
446 END IF
447
448*
449* Find out required workspace
450*
451
452* Workspace query to dlaqz3
453 nw = max( nwr, nmin )
454 CALL dlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,
455 $ q, ldq, z, ldz, n_undeflated, n_deflated, alphar,
456 $ alphai, beta, work, nw, work, nw, work, -1, rec,
457 $ aed_info )
458 itemp1 = int( work( 1 ) )
459* Workspace query to dlaqz4
460 CALL dlaqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,
461 $ alphai, beta, a, lda, b, ldb, q, ldq, z, ldz, work,
462 $ nbr, work, nbr, work, -1, sweep_info )
463 itemp2 = int( work( 1 ) )
464
465 lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 )
466 IF ( lwork .EQ.-1 ) THEN
467 work( 1 ) = dble( lworkreq )
468 RETURN
469 ELSE IF ( lwork .LT. lworkreq ) THEN
470 info = -19
471 END IF
472 IF( info.NE.0 ) THEN
473 CALL xerbla( 'DLAQZ0', info )
474 RETURN
475 END IF
476*
477* Initialize Q and Z
478*
479 IF( iwantq.EQ.3 ) CALL dlaset( 'FULL', n, n, zero, one, q, ldq )
480 IF( iwantz.EQ.3 ) CALL dlaset( 'FULL', n, n, zero, one, z, ldz )
481
482* Get machine constants
483 safmin = dlamch( 'SAFE MINIMUM' )
484 safmax = one/safmin
485 CALL dlabad( safmin, safmax )
486 ulp = dlamch( 'PRECISION' )
487 smlnum = safmin*( dble( n )/ulp )
488
489 istart = ilo
490 istop = ihi
491 maxit = 3*( ihi-ilo+1 )
492 ld = 0
493
494 DO iiter = 1, maxit
495 IF( iiter .GE. maxit ) THEN
496 info = istop+1
497 GOTO 80
498 END IF
499 IF ( istart+1 .GE. istop ) THEN
500 istop = istart
501 EXIT
502 END IF
503
504* Check deflations at the end
505 IF ( abs( a( istop-1, istop-2 ) ) .LE. max( smlnum,
506 $ ulp*( abs( a( istop-1, istop-1 ) )+abs( a( istop-2,
507 $ istop-2 ) ) ) ) ) THEN
508 a( istop-1, istop-2 ) = zero
509 istop = istop-2
510 ld = 0
511 eshift = zero
512 ELSE IF ( abs( a( istop, istop-1 ) ) .LE. max( smlnum,
513 $ ulp*( abs( a( istop, istop ) )+abs( a( istop-1,
514 $ istop-1 ) ) ) ) ) THEN
515 a( istop, istop-1 ) = zero
516 istop = istop-1
517 ld = 0
518 eshift = zero
519 END IF
520* Check deflations at the start
521 IF ( abs( a( istart+2, istart+1 ) ) .LE. max( smlnum,
522 $ ulp*( abs( a( istart+1, istart+1 ) )+abs( a( istart+2,
523 $ istart+2 ) ) ) ) ) THEN
524 a( istart+2, istart+1 ) = zero
525 istart = istart+2
526 ld = 0
527 eshift = zero
528 ELSE IF ( abs( a( istart+1, istart ) ) .LE. max( smlnum,
529 $ ulp*( abs( a( istart, istart ) )+abs( a( istart+1,
530 $ istart+1 ) ) ) ) ) THEN
531 a( istart+1, istart ) = zero
532 istart = istart+1
533 ld = 0
534 eshift = zero
535 END IF
536
537 IF ( istart+1 .GE. istop ) THEN
538 EXIT
539 END IF
540
541* Check interior deflations
542 istart2 = istart
543 DO k = istop, istart+1, -1
544 IF ( abs( a( k, k-1 ) ) .LE. max( smlnum, ulp*( abs( a( k,
545 $ k ) )+abs( a( k-1, k-1 ) ) ) ) ) THEN
546 a( k, k-1 ) = zero
547 istart2 = k
548 EXIT
549 END IF
550 END DO
551
552* Get range to apply rotations to
553 IF ( ilschur ) THEN
554 istartm = 1
555 istopm = n
556 ELSE
557 istartm = istart2
558 istopm = istop
559 END IF
560
561* Check infinite eigenvalues, this is done without blocking so might
562* slow down the method when many infinite eigenvalues are present
563 k = istop
564 DO WHILE ( k.GE.istart2 )
565 temp = zero
566 IF( k .LT. istop ) THEN
567 temp = temp+abs( b( k, k+1 ) )
568 END IF
569 IF( k .GT. istart2 ) THEN
570 temp = temp+abs( b( k-1, k ) )
571 END IF
572
573 IF( abs( b( k, k ) ) .LT. max( smlnum, ulp*temp ) ) THEN
574* A diagonal element of B is negligable, move it
575* to the top and deflate it
576
577 DO k2 = k, istart2+1, -1
578 CALL dlartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,
579 $ temp )
580 b( k2-1, k2 ) = temp
581 b( k2-1, k2-1 ) = zero
582
583 CALL drot( k2-2-istartm+1, b( istartm, k2 ), 1,
584 $ b( istartm, k2-1 ), 1, c1, s1 )
585 CALL drot( min( k2+1, istop )-istartm+1, a( istartm,
586 $ k2 ), 1, a( istartm, k2-1 ), 1, c1, s1 )
587 IF ( ilz ) THEN
588 CALL drot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,
589 $ s1 )
590 END IF
591
592 IF( k2.LT.istop ) THEN
593 CALL dlartg( a( k2, k2-1 ), a( k2+1, k2-1 ), c1,
594 $ s1, temp )
595 a( k2, k2-1 ) = temp
596 a( k2+1, k2-1 ) = zero
597
598 CALL drot( istopm-k2+1, a( k2, k2 ), lda, a( k2+1,
599 $ k2 ), lda, c1, s1 )
600 CALL drot( istopm-k2+1, b( k2, k2 ), ldb, b( k2+1,
601 $ k2 ), ldb, c1, s1 )
602 IF( ilq ) THEN
603 CALL drot( n, q( 1, k2 ), 1, q( 1, k2+1 ), 1,
604 $ c1, s1 )
605 END IF
606 END IF
607
608 END DO
609
610 IF( istart2.LT.istop )THEN
611 CALL dlartg( a( istart2, istart2 ), a( istart2+1,
612 $ istart2 ), c1, s1, temp )
613 a( istart2, istart2 ) = temp
614 a( istart2+1, istart2 ) = zero
615
616 CALL drot( istopm-( istart2+1 )+1, a( istart2,
617 $ istart2+1 ), lda, a( istart2+1,
618 $ istart2+1 ), lda, c1, s1 )
619 CALL drot( istopm-( istart2+1 )+1, b( istart2,
620 $ istart2+1 ), ldb, b( istart2+1,
621 $ istart2+1 ), ldb, c1, s1 )
622 IF( ilq ) THEN
623 CALL drot( n, q( 1, istart2 ), 1, q( 1,
624 $ istart2+1 ), 1, c1, s1 )
625 END IF
626 END IF
627
628 istart2 = istart2+1
629
630 END IF
631 k = k-1
632 END DO
633
634* istart2 now points to the top of the bottom right
635* unreduced Hessenberg block
636 IF ( istart2 .GE. istop ) THEN
637 istop = istart2-1
638 ld = 0
639 eshift = zero
640 cycle
641 END IF
642
643 nw = nwr
644 nshifts = nsr
645 nblock = nbr
646
647 IF ( istop-istart2+1 .LT. nmin ) THEN
648* Setting nw to the size of the subblock will make AED deflate
649* all the eigenvalues. This is slightly more efficient than just
650* using DHGEQZ because the off diagonal part gets updated via BLAS.
651 IF ( istop-istart+1 .LT. nmin ) THEN
652 nw = istop-istart+1
653 istart2 = istart
654 ELSE
655 nw = istop-istart2+1
656 END IF
657 END IF
658
659*
660* Time for AED
661*
662 CALL dlaqz3( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,
663 $ b, ldb, q, ldq, z, ldz, n_undeflated, n_deflated,
664 $ alphar, alphai, beta, work, nw, work( nw**2+1 ),
665 $ nw, work( 2*nw**2+1 ), lwork-2*nw**2, rec,
666 $ aed_info )
667
668 IF ( n_deflated > 0 ) THEN
669 istop = istop-n_deflated
670 ld = 0
671 eshift = zero
672 END IF
673
674 IF ( 100*n_deflated > nibble*( n_deflated+n_undeflated ) .OR.
675 $ istop-istart2+1 .LT. nmin ) THEN
676* AED has uncovered many eigenvalues. Skip a QZ sweep and run
677* AED again.
678 cycle
679 END IF
680
681 ld = ld+1
682
683 ns = min( nshifts, istop-istart2 )
684 ns = min( ns, n_undeflated )
685 shiftpos = istop-n_deflated-n_undeflated+1
686*
687* Shuffle shifts to put double shifts in front
688* This ensures that we don't split up a double shift
689*
690 DO i = shiftpos, shiftpos+n_undeflated-1, 2
691 IF( alphai( i ).NE.-alphai( i+1 ) ) THEN
692*
693 swap = alphar( i )
694 alphar( i ) = alphar( i+1 )
695 alphar( i+1 ) = alphar( i+2 )
696 alphar( i+2 ) = swap
697
698 swap = alphai( i )
699 alphai( i ) = alphai( i+1 )
700 alphai( i+1 ) = alphai( i+2 )
701 alphai( i+2 ) = swap
702
703 swap = beta( i )
704 beta( i ) = beta( i+1 )
705 beta( i+1 ) = beta( i+2 )
706 beta( i+2 ) = swap
707 END IF
708 END DO
709
710 IF ( mod( ld, 6 ) .EQ. 0 ) THEN
711*
712* Exceptional shift. Chosen for no particularly good reason.
713*
714 IF( ( dble( maxit )*safmin )*abs( a( istop,
715 $ istop-1 ) ).LT.abs( a( istop-1, istop-1 ) ) ) THEN
716 eshift = a( istop, istop-1 )/b( istop-1, istop-1 )
717 ELSE
718 eshift = eshift+one/( safmin*dble( maxit ) )
719 END IF
720 alphar( shiftpos ) = one
721 alphar( shiftpos+1 ) = zero
722 alphai( shiftpos ) = zero
723 alphai( shiftpos+1 ) = zero
724 beta( shiftpos ) = eshift
725 beta( shiftpos+1 ) = eshift
726 ns = 2
727 END IF
728
729*
730* Time for a QZ sweep
731*
732 CALL dlaqz4( ilschur, ilq, ilz, n, istart2, istop, ns, nblock,
733 $ alphar( shiftpos ), alphai( shiftpos ),
734 $ beta( shiftpos ), a, lda, b, ldb, q, ldq, z, ldz,
735 $ work, nblock, work( nblock**2+1 ), nblock,
736 $ work( 2*nblock**2+1 ), lwork-2*nblock**2,
737 $ sweep_info )
738
739 END DO
740
741*
742* Call DHGEQZ to normalize the eigenvalue blocks and set the eigenvalues
743* If all the eigenvalues have been found, DHGEQZ will not do any iterations
744* and only normalize the blocks. In case of a rare convergence failure,
745* the single shift might perform better.
746*
747 80 CALL dhgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,
748 $ alphar, alphai, beta, q, ldq, z, ldz, work, lwork,
749 $ norm_info )
750
751 info = norm_info
752
dlabad
subroutine dlabad(small, large)
DLABAD
Definition dlabad.f:74
dhgeqz
subroutine dhgeqz(job, compq, compz, n, ilo, ihi, h, ldh, t, ldt, alphar, alphai, beta, q, ldq, z, ldz, work, lwork, info)
DHGEQZ
Definition dhgeqz.f:304
dlaqz4
subroutine dlaqz4(ilschur, ilq, ilz, n, ilo, ihi, nshifts, nblock_desired, sr, si, ss, a, lda, b, ldb, q, ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork, info)
DLAQZ4
Definition dlaqz4.f:213
dlaqz3
recursive subroutine dlaqz3(ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb, q, ldq, z, ldz, ns, nd, alphar, alphai, beta, qc, ldqc, zc, ldzc, work, lwork, rec, info)
DLAQZ3
Definition dlaqz3.f:239
swap
#define swap(a, b, tmp)
Definition macros.h:40

◆ dlaqz1()

subroutine dlaqz1 ( double precision, dimension( lda, * ), intent(in) a,
integer, intent(in) lda,
double precision, dimension( ldb, * ), intent(in) b,
integer, intent(in) ldb,
double precision, intent(in) sr1,
double precision, intent(in) sr2,
double precision, intent(in) si,
double precision, intent(in) beta1,
double precision, intent(in) beta2,
double precision, dimension( * ), intent(out) v )

DLAQZ1

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

Purpose:
!>
!>      Given a 3-by-3 matrix pencil (A,B), DLAQZ1 sets v to a
!>      scalar multiple of the first column of the product
!>
!>      (*)  K = (A - (beta2*sr2 - i*si)*B)*B^(-1)*(beta1*A - (sr2 + i*si2)*B)*B^(-1).
!>
!>      It is assumed that either
!>
!>              1) sr1 = sr2
!>          or
!>              2) si = 0.
!>
!>      This is useful for starting double implicit shift bulges
!>      in the QZ algorithm.
!>
Parameters
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>              The 3-by-3 matrix A in (*).
!>
[in]LDA
!>          LDA is INTEGER
!>              The leading dimension of A as declared in
!>              the calling procedure.
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>              The 3-by-3 matrix B in (*).
!>
[in]LDB
!>          LDB is INTEGER
!>              The leading dimension of B as declared in
!>              the calling procedure.
!>
[in]SR1
!>          SR1 is DOUBLE PRECISION
!>
[in]SR2
!>          SR2 is DOUBLE PRECISION
!>
[in]SI
!>          SI is DOUBLE PRECISION
!>
[in]BETA1
!>          BETA1 is DOUBLE PRECISION
!>
[in]BETA2
!>          BETA2 is DOUBLE PRECISION
!>
[out]V
!>          V is DOUBLE PRECISION array, dimension (N)
!>              A scalar multiple of the first column of the
!>              matrix K in (*).
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 125 of file dlaqz1.f.

127 IMPLICIT NONE
128*
129* Arguments
130 INTEGER, INTENT( IN ) :: LDA, LDB
131 DOUBLE PRECISION, INTENT( IN ) :: A( LDA, * ), B( LDB, * ), SR1,
132 $ SR2, SI, BETA1, BETA2
133 DOUBLE PRECISION, INTENT( OUT ) :: V( * )
134*
135* Parameters
136 DOUBLE PRECISION :: ZERO, ONE, HALF
137 parameter( zero = 0.0d0, one = 1.0d0, half = 0.5d0 )
138*
139* Local scalars
140 DOUBLE PRECISION :: W( 2 ), SAFMIN, SAFMAX, SCALE1, SCALE2
141*
142* External Functions
143 DOUBLE PRECISION, EXTERNAL :: DLAMCH
144 LOGICAL, EXTERNAL :: DISNAN
145*
146 safmin = dlamch( 'SAFE MINIMUM' )
147 safmax = one/safmin
148*
149* Calculate first shifted vector
150*
151 w( 1 ) = beta1*a( 1, 1 )-sr1*b( 1, 1 )
152 w( 2 ) = beta1*a( 2, 1 )-sr1*b( 2, 1 )
153 scale1 = sqrt( abs( w( 1 ) ) ) * sqrt( abs( w( 2 ) ) )
154 IF( scale1 .GE. safmin .AND. scale1 .LE. safmax ) THEN
155 w( 1 ) = w( 1 )/scale1
156 w( 2 ) = w( 2 )/scale1
157 END IF
158*
159* Solve linear system
160*
161 w( 2 ) = w( 2 )/b( 2, 2 )
162 w( 1 ) = ( w( 1 )-b( 1, 2 )*w( 2 ) )/b( 1, 1 )
163 scale2 = sqrt( abs( w( 1 ) ) ) * sqrt( abs( w( 2 ) ) )
164 IF( scale2 .GE. safmin .AND. scale2 .LE. safmax ) THEN
165 w( 1 ) = w( 1 )/scale2
166 w( 2 ) = w( 2 )/scale2
167 END IF
168*
169* Apply second shift
170*
171 v( 1 ) = beta2*( a( 1, 1 )*w( 1 )+a( 1, 2 )*w( 2 ) )-sr2*( b( 1,
172 $ 1 )*w( 1 )+b( 1, 2 )*w( 2 ) )
173 v( 2 ) = beta2*( a( 2, 1 )*w( 1 )+a( 2, 2 )*w( 2 ) )-sr2*( b( 2,
174 $ 1 )*w( 1 )+b( 2, 2 )*w( 2 ) )
175 v( 3 ) = beta2*( a( 3, 1 )*w( 1 )+a( 3, 2 )*w( 2 ) )-sr2*( b( 3,
176 $ 1 )*w( 1 )+b( 3, 2 )*w( 2 ) )
177*
178* Account for imaginary part
179*
180 v( 1 ) = v( 1 )+si*si*b( 1, 1 )/scale1/scale2
181*
182* Check for overflow
183*
184 IF( abs( v( 1 ) ).GT.safmax .OR. abs( v( 2 ) ) .GT. safmax .OR.
185 $ abs( v( 3 ) ).GT.safmax .OR. disnan( v( 1 ) ) .OR.
186 $ disnan( v( 2 ) ) .OR. disnan( v( 3 ) ) ) THEN
187 v( 1 ) = zero
188 v( 2 ) = zero
189 v( 3 ) = zero
190 END IF
191*
192* End of DLAQZ1
193*

◆ dlaqz2()

subroutine dlaqz2 ( logical, intent(in) ilq,
logical, intent(in) ilz,
integer, intent(in) k,
integer, intent(in) istartm,
integer, intent(in) istopm,
integer, intent(in) ihi,
double precision, dimension( lda, * ) a,
integer, intent(in) lda,
double precision, dimension( ldb, * ) b,
integer, intent(in) ldb,
integer, intent(in) nq,
integer, intent(in) qstart,
double precision, dimension( ldq, * ) q,
integer, intent(in) ldq,
integer, intent(in) nz,
integer, intent(in) zstart,
double precision, dimension( ldz, * ) z,
integer, intent(in) ldz )

DLAQZ2

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

Purpose:
!>
!>      DLAQZ2 chases a 2x2 shift bulge in a matrix pencil down a single position
!>
Parameters
[in]ILQ
!>          ILQ is LOGICAL
!>              Determines whether or not to update the matrix Q
!>
[in]ILZ
!>          ILZ is LOGICAL
!>              Determines whether or not to update the matrix Z
!>
[in]K
!>          K is INTEGER
!>              Index indicating the position of the bulge.
!>              On entry, the bulge is located in
!>              (A(k+1:k+2,k:k+1),B(k+1:k+2,k:k+1)).
!>              On exit, the bulge is located in
!>              (A(k+2:k+3,k+1:k+2),B(k+2:k+3,k+1:k+2)).
!>
[in]ISTARTM
!>          ISTARTM is INTEGER
!>
[in]ISTOPM
!>          ISTOPM is INTEGER
!>              Updates to (A,B) are restricted to
!>              (istartm:k+3,k:istopm). It is assumed
!>              without checking that istartm <= k+1 and
!>              k+2 <= istopm
!>
[in]IHI
!>          IHI is INTEGER
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>
[in]LDA
!>          LDA is INTEGER
!>              The leading dimension of A as declared in
!>              the calling procedure.
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>
[in]LDB
!>          LDB is INTEGER
!>              The leading dimension of B as declared in
!>              the calling procedure.
!>
[in]NQ
!>          NQ is INTEGER
!>              The order of the matrix Q
!>
[in]QSTART
!>          QSTART is INTEGER
!>              Start index of the matrix Q. Rotations are applied
!>              To columns k+2-qStart:k+4-qStart of Q.
!>
[in,out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ,NQ)
!>
[in]LDQ
!>          LDQ is INTEGER
!>              The leading dimension of Q as declared in
!>              the calling procedure.
!>
[in]NZ
!>          NZ is INTEGER
!>              The order of the matrix Z
!>
[in]ZSTART
!>          ZSTART is INTEGER
!>              Start index of the matrix Z. Rotations are applied
!>              To columns k+1-qStart:k+3-qStart of Z.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ,NZ)
!>
[in]LDZ
!>          LDZ is INTEGER
!>              The leading dimension of Q as declared in
!>              the calling procedure.
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 172 of file dlaqz2.f.

174 IMPLICIT NONE
175*
176* Arguments
177 LOGICAL, INTENT( IN ) :: ILQ, ILZ
178 INTEGER, INTENT( IN ) :: K, LDA, LDB, LDQ, LDZ, ISTARTM, ISTOPM,
179 $ NQ, NZ, QSTART, ZSTART, IHI
180 DOUBLE PRECISION :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ), Z( LDZ,
181 $ * )
182*
183* Parameters
184 DOUBLE PRECISION :: ZERO, ONE, HALF
185 parameter( zero = 0.0d0, one = 1.0d0, half = 0.5d0 )
186*
187* Local variables
188 DOUBLE PRECISION :: H( 2, 3 ), C1, S1, C2, S2, TEMP
189*
190* External functions
191 EXTERNAL :: dlartg, drot
192*
193 IF( k+2 .EQ. ihi ) THEN
194* Shift is located on the edge of the matrix, remove it
195 h = b( ihi-1:ihi, ihi-2:ihi )
196* Make H upper triangular
197 CALL dlartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp )
198 h( 2, 1 ) = zero
199 h( 1, 1 ) = temp
200 CALL drot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 )
201*
202 CALL dlartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp )
203 CALL drot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 )
204 CALL dlartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp )
205*
206 CALL drot( ihi-istartm+1, b( istartm, ihi ), 1, b( istartm,
207 $ ihi-1 ), 1, c1, s1 )
208 CALL drot( ihi-istartm+1, b( istartm, ihi-1 ), 1, b( istartm,
209 $ ihi-2 ), 1, c2, s2 )
210 b( ihi-1, ihi-2 ) = zero
211 b( ihi, ihi-2 ) = zero
212 CALL drot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,
213 $ ihi-1 ), 1, c1, s1 )
214 CALL drot( ihi-istartm+1, a( istartm, ihi-1 ), 1, a( istartm,
215 $ ihi-2 ), 1, c2, s2 )
216 IF ( ilz ) THEN
217 CALL drot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+
218 $ 1 ), 1, c1, s1 )
219 CALL drot( nz, z( 1, ihi-1-zstart+1 ), 1, z( 1,
220 $ ihi-2-zstart+1 ), 1, c2, s2 )
221 END IF
222*
223 CALL dlartg( a( ihi-1, ihi-2 ), a( ihi, ihi-2 ), c1, s1,
224 $ temp )
225 a( ihi-1, ihi-2 ) = temp
226 a( ihi, ihi-2 ) = zero
227 CALL drot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,
228 $ ihi-1 ), lda, c1, s1 )
229 CALL drot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,
230 $ ihi-1 ), ldb, c1, s1 )
231 IF ( ilq ) THEN
232 CALL drot( nq, q( 1, ihi-1-qstart+1 ), 1, q( 1, ihi-qstart+
233 $ 1 ), 1, c1, s1 )
234 END IF
235*
236 CALL dlartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp )
237 b( ihi, ihi ) = temp
238 b( ihi, ihi-1 ) = zero
239 CALL drot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,
240 $ ihi-1 ), 1, c1, s1 )
241 CALL drot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,
242 $ ihi-1 ), 1, c1, s1 )
243 IF ( ilz ) THEN
244 CALL drot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+
245 $ 1 ), 1, c1, s1 )
246 END IF
247*
248 ELSE
249*
250* Normal operation, move bulge down
251*
252 h = b( k+1:k+2, k:k+2 )
253*
254* Make H upper triangular
255*
256 CALL dlartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp )
257 h( 2, 1 ) = zero
258 h( 1, 1 ) = temp
259 CALL drot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 )
260*
261* Calculate Z1 and Z2
262*
263 CALL dlartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp )
264 CALL drot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 )
265 CALL dlartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp )
266*
267* Apply transformations from the right
268*
269 CALL drot( k+3-istartm+1, a( istartm, k+2 ), 1, a( istartm,
270 $ k+1 ), 1, c1, s1 )
271 CALL drot( k+3-istartm+1, a( istartm, k+1 ), 1, a( istartm,
272 $ k ), 1, c2, s2 )
273 CALL drot( k+2-istartm+1, b( istartm, k+2 ), 1, b( istartm,
274 $ k+1 ), 1, c1, s1 )
275 CALL drot( k+2-istartm+1, b( istartm, k+1 ), 1, b( istartm,
276 $ k ), 1, c2, s2 )
277 IF ( ilz ) THEN
278 CALL drot( nz, z( 1, k+2-zstart+1 ), 1, z( 1, k+1-zstart+
279 $ 1 ), 1, c1, s1 )
280 CALL drot( nz, z( 1, k+1-zstart+1 ), 1, z( 1, k-zstart+1 ),
281 $ 1, c2, s2 )
282 END IF
283 b( k+1, k ) = zero
284 b( k+2, k ) = zero
285*
286* Calculate Q1 and Q2
287*
288 CALL dlartg( a( k+2, k ), a( k+3, k ), c1, s1, temp )
289 a( k+2, k ) = temp
290 a( k+3, k ) = zero
291 CALL dlartg( a( k+1, k ), a( k+2, k ), c2, s2, temp )
292 a( k+1, k ) = temp
293 a( k+2, k ) = zero
294*
295* Apply transformations from the left
296*
297 CALL drot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,
298 $ c1, s1 )
299 CALL drot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,
300 $ c2, s2 )
301*
302 CALL drot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,
303 $ c1, s1 )
304 CALL drot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,
305 $ c2, s2 )
306 IF ( ilq ) THEN
307 CALL drot( nq, q( 1, k+2-qstart+1 ), 1, q( 1, k+3-qstart+
308 $ 1 ), 1, c1, s1 )
309 CALL drot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+
310 $ 1 ), 1, c2, s2 )
311 END IF
312*
313 END IF
314*
315* End of DLAQZ2
316*

◆ dlaqz3()

recursive subroutine dlaqz3 ( logical, intent(in) ilschur,
logical, intent(in) ilq,
logical, intent(in) ilz,
integer, intent(in) n,
integer, intent(in) ilo,
integer, intent(in) ihi,
integer, intent(in) nw,
double precision, dimension( lda, * ), intent(inout) a,
integer, intent(in) lda,
double precision, dimension( ldb, * ), intent(inout) b,
integer, intent(in) ldb,
double precision, dimension( ldq, * ), intent(inout) q,
integer, intent(in) ldq,
double precision, dimension( ldz, * ), intent(inout) z,
integer, intent(in) ldz,
integer, intent(out) ns,
integer, intent(out) nd,
double precision, dimension( * ), intent(inout) alphar,
double precision, dimension( * ), intent(inout) alphai,
double precision, dimension( * ), intent(inout) beta,
double precision, dimension( ldqc, * ) qc,
integer, intent(in) ldqc,
double precision, dimension( ldzc, * ) zc,
integer, intent(in) ldzc,
double precision, dimension( * ) work,
integer, intent(in) lwork,
integer, intent(in) rec,
integer, intent(out) info )

DLAQZ3

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

Purpose:
!>
!> DLAQZ3 performs AED
!>
Parameters
[in]ILSCHUR
!>          ILSCHUR is LOGICAL
!>              Determines whether or not to update the full Schur form
!>
[in]ILQ
!>          ILQ is LOGICAL
!>              Determines whether or not to update the matrix Q
!>
[in]ILZ
!>          ILZ is LOGICAL
!>              Determines whether or not to update the matrix Z
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A, B, Q, and Z.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>          ILO and IHI mark the rows and columns of (A,B) which
!>          are to be normalized
!>
[in]NW
!>          NW is INTEGER
!>          The desired size of the deflation window.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA, N)
!>
[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)
!>
[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)
!>
[in]LDQ
!>          LDQ is INTEGER
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ, N)
!>
[in]LDZ
!>          LDZ is INTEGER
!>
[out]NS
!>          NS is INTEGER
!>          The number of unconverged eigenvalues available to
!>          use as shifts.
!>
[out]ND
!>          ND is INTEGER
!>          The number of converged eigenvalues found.
!>
[out]ALPHAR
!>          ALPHAR is DOUBLE PRECISION array, dimension (N)
!>          The real parts of each scalar alpha defining an eigenvalue
!>          of GNEP.
!>
[out]ALPHAI
!>          ALPHAI is DOUBLE PRECISION array, dimension (N)
!>          The imaginary parts of each scalar alpha defining an
!>          eigenvalue of GNEP.
!>          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) = -ALPHAI(j).
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>          The scalars beta that define the eigenvalues of GNEP.
!>          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
!>          beta = BETA(j) represent the j-th eigenvalue of the matrix
!>          pair (A,B), in one of the forms lambda = alpha/beta or
!>          mu = beta/alpha.  Since either lambda or mu may overflow,
!>          they should not, in general, be computed.
!>
[in,out]QC
!>          QC is DOUBLE PRECISION array, dimension (LDQC, NW)
!>
[in]LDQC
!>          LDQC is INTEGER
!>
[in,out]ZC
!>          ZC is DOUBLE PRECISION array, dimension (LDZC, NW)
!>
[in]LDZC
!>          LDZ is INTEGER
!>
[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 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.
!>
[in]REC
!>          REC is INTEGER
!>             REC indicates the current recursion level. Should be set
!>             to 0 on first call.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 235 of file dlaqz3.f.

239 IMPLICIT NONE
240
241* Arguments
242 LOGICAL, INTENT( IN ) :: ILSCHUR, ILQ, ILZ
243 INTEGER, INTENT( IN ) :: N, ILO, IHI, NW, LDA, LDB, LDQ, LDZ,
244 $ LDQC, LDZC, LWORK, REC
245
246 DOUBLE PRECISION, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ),
247 $ Q( LDQ, * ), Z( LDZ, * ), ALPHAR( * ),
248 $ ALPHAI( * ), BETA( * )
249 INTEGER, INTENT( OUT ) :: NS, ND, INFO
250 DOUBLE PRECISION :: QC( LDQC, * ), ZC( LDZC, * ), WORK( * )
251
252* Parameters
253 DOUBLE PRECISION :: ZERO, ONE, HALF
254 parameter( zero = 0.0d0, one = 1.0d0, half = 0.5d0 )
255
256* Local Scalars
257 LOGICAL :: BULGE
258 INTEGER :: JW, KWTOP, KWBOT, ISTOPM, ISTARTM, K, K2, DTGEXC_INFO,
259 $ IFST, ILST, LWORKREQ, QZ_SMALL_INFO
260 DOUBLE PRECISION :: S, SMLNUM, ULP, SAFMIN, SAFMAX, C1, S1, TEMP
261
262* External Functions
263 EXTERNAL :: xerbla, dtgexc, dlabad, dlaqz0, dlacpy, dlaset,
264 $ dlaqz2, drot, dlartg, dlag2, dgemm
265 DOUBLE PRECISION, EXTERNAL :: DLAMCH
266
267 info = 0
268
269* Set up deflation window
270 jw = min( nw, ihi-ilo+1 )
271 kwtop = ihi-jw+1
272 IF ( kwtop .EQ. ilo ) THEN
273 s = zero
274 ELSE
275 s = a( kwtop, kwtop-1 )
276 END IF
277
278* Determine required workspace
279 ifst = 1
280 ilst = jw
281 CALL dtgexc( .true., .true., jw, a, lda, b, ldb, qc, ldqc, zc,
282 $ ldzc, ifst, ilst, work, -1, dtgexc_info )
283 lworkreq = int( work( 1 ) )
284 CALL dlaqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,
285 $ b( kwtop, kwtop ), ldb, alphar, alphai, beta, qc,
286 $ ldqc, zc, ldzc, work, -1, rec+1, qz_small_info )
287 lworkreq = max( lworkreq, int( work( 1 ) )+2*jw**2 )
288 lworkreq = max( lworkreq, n*nw, 2*nw**2+n )
289 IF ( lwork .EQ.-1 ) THEN
290* workspace query, quick return
291 work( 1 ) = lworkreq
292 RETURN
293 ELSE IF ( lwork .LT. lworkreq ) THEN
294 info = -26
295 END IF
296
297 IF( info.NE.0 ) THEN
298 CALL xerbla( 'DLAQZ3', -info )
299 RETURN
300 END IF
301
302* Get machine constants
303 safmin = dlamch( 'SAFE MINIMUM' )
304 safmax = one/safmin
305 CALL dlabad( safmin, safmax )
306 ulp = dlamch( 'PRECISION' )
307 smlnum = safmin*( dble( n )/ulp )
308
309 IF ( ihi .EQ. kwtop ) THEN
310* 1 by 1 deflation window, just try a regular deflation
311 alphar( kwtop ) = a( kwtop, kwtop )
312 alphai( kwtop ) = zero
313 beta( kwtop ) = b( kwtop, kwtop )
314 ns = 1
315 nd = 0
316 IF ( abs( s ) .LE. max( smlnum, ulp*abs( a( kwtop,
317 $ kwtop ) ) ) ) THEN
318 ns = 0
319 nd = 1
320 IF ( kwtop .GT. ilo ) THEN
321 a( kwtop, kwtop-1 ) = zero
322 END IF
323 END IF
324 END IF
325
326
327* Store window in case of convergence failure
328 CALL dlacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw )
329 CALL dlacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+
330 $ 1 ), jw )
331
332* Transform window to real schur form
333 CALL dlaset( 'FULL', jw, jw, zero, one, qc, ldqc )
334 CALL dlaset( 'FULL', jw, jw, zero, one, zc, ldzc )
335 CALL dlaqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,
336 $ b( kwtop, kwtop ), ldb, alphar, alphai, beta, qc,
337 $ ldqc, zc, ldzc, work( 2*jw**2+1 ), lwork-2*jw**2,
338 $ rec+1, qz_small_info )
339
340 IF( qz_small_info .NE. 0 ) THEN
341* Convergence failure, restore the window and exit
342 nd = 0
343 ns = jw-qz_small_info
344 CALL dlacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda )
345 CALL dlacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,
346 $ kwtop ), ldb )
347 RETURN
348 END IF
349
350* Deflation detection loop
351 IF ( kwtop .EQ. ilo .OR. s .EQ. zero ) THEN
352 kwbot = kwtop-1
353 ELSE
354 kwbot = ihi
355 k = 1
356 k2 = 1
357 DO WHILE ( k .LE. jw )
358 bulge = .false.
359 IF ( kwbot-kwtop+1 .GE. 2 ) THEN
360 bulge = a( kwbot, kwbot-1 ) .NE. zero
361 END IF
362 IF ( bulge ) THEN
363
364* Try to deflate complex conjugate eigenvalue pair
365 temp = abs( a( kwbot, kwbot ) )+sqrt( abs( a( kwbot,
366 $ kwbot-1 ) ) )*sqrt( abs( a( kwbot-1, kwbot ) ) )
367 IF( temp .EQ. zero )THEN
368 temp = abs( s )
369 END IF
370 IF ( max( abs( s*qc( 1, kwbot-kwtop ) ), abs( s*qc( 1,
371 $ kwbot-kwtop+1 ) ) ) .LE. max( smlnum,
372 $ ulp*temp ) ) THEN
373* Deflatable
374 kwbot = kwbot-2
375 ELSE
376* Not deflatable, move out of the way
377 ifst = kwbot-kwtop+1
378 ilst = k2
379 CALL dtgexc( .true., .true., jw, a( kwtop, kwtop ),
380 $ lda, b( kwtop, kwtop ), ldb, qc, ldqc,
381 $ zc, ldzc, ifst, ilst, work, lwork,
382 $ dtgexc_info )
383 k2 = k2+2
384 END IF
385 k = k+2
386 ELSE
387
388* Try to deflate real eigenvalue
389 temp = abs( a( kwbot, kwbot ) )
390 IF( temp .EQ. zero ) THEN
391 temp = abs( s )
392 END IF
393 IF ( ( abs( s*qc( 1, kwbot-kwtop+1 ) ) ) .LE. max( ulp*
394 $ temp, smlnum ) ) THEN
395* Deflatable
396 kwbot = kwbot-1
397 ELSE
398* Not deflatable, move out of the way
399 ifst = kwbot-kwtop+1
400 ilst = k2
401 CALL dtgexc( .true., .true., jw, a( kwtop, kwtop ),
402 $ lda, b( kwtop, kwtop ), ldb, qc, ldqc,
403 $ zc, ldzc, ifst, ilst, work, lwork,
404 $ dtgexc_info )
405 k2 = k2+1
406 END IF
407
408 k = k+1
409
410 END IF
411 END DO
412 END IF
413
414* Store eigenvalues
415 nd = ihi-kwbot
416 ns = jw-nd
417 k = kwtop
418 DO WHILE ( k .LE. ihi )
419 bulge = .false.
420 IF ( k .LT. ihi ) THEN
421 IF ( a( k+1, k ) .NE. zero ) THEN
422 bulge = .true.
423 END IF
424 END IF
425 IF ( bulge ) THEN
426* 2x2 eigenvalue block
427 CALL dlag2( a( k, k ), lda, b( k, k ), ldb, safmin,
428 $ beta( k ), beta( k+1 ), alphar( k ),
429 $ alphar( k+1 ), alphai( k ) )
430 alphai( k+1 ) = -alphai( k )
431 k = k+2
432 ELSE
433* 1x1 eigenvalue block
434 alphar( k ) = a( k, k )
435 alphai( k ) = zero
436 beta( k ) = b( k, k )
437 k = k+1
438 END IF
439 END DO
440
441 IF ( kwtop .NE. ilo .AND. s .NE. zero ) THEN
442* Reflect spike back, this will create optimally packed bulges
443 a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 )*qc( 1,
444 $ 1:jw-nd )
445 DO k = kwbot-1, kwtop, -1
446 CALL dlartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,
447 $ temp )
448 a( k, kwtop-1 ) = temp
449 a( k+1, kwtop-1 ) = zero
450 k2 = max( kwtop, k-1 )
451 CALL drot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,
452 $ s1 )
453 CALL drot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),
454 $ ldb, c1, s1 )
455 CALL drot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),
456 $ 1, c1, s1 )
457 END DO
458
459* Chase bulges down
460 istartm = kwtop
461 istopm = ihi
462 k = kwbot-1
463 DO WHILE ( k .GE. kwtop )
464 IF ( ( k .GE. kwtop+1 ) .AND. a( k+1, k-1 ) .NE. zero ) THEN
465
466* Move double pole block down and remove it
467 DO k2 = k-1, kwbot-2
468 CALL dlaqz2( .true., .true., k2, kwtop, kwtop+jw-1,
469 $ kwbot, a, lda, b, ldb, jw, kwtop, qc,
470 $ ldqc, jw, kwtop, zc, ldzc )
471 END DO
472
473 k = k-2
474 ELSE
475
476* k points to single shift
477 DO k2 = k, kwbot-2
478
479* Move shift down
480 CALL dlartg( b( k2+1, k2+1 ), b( k2+1, k2 ), c1, s1,
481 $ temp )
482 b( k2+1, k2+1 ) = temp
483 b( k2+1, k2 ) = zero
484 CALL drot( k2+2-istartm+1, a( istartm, k2+1 ), 1,
485 $ a( istartm, k2 ), 1, c1, s1 )
486 CALL drot( k2-istartm+1, b( istartm, k2+1 ), 1,
487 $ b( istartm, k2 ), 1, c1, s1 )
488 CALL drot( jw, zc( 1, k2+1-kwtop+1 ), 1, zc( 1,
489 $ k2-kwtop+1 ), 1, c1, s1 )
490
491 CALL dlartg( a( k2+1, k2 ), a( k2+2, k2 ), c1, s1,
492 $ temp )
493 a( k2+1, k2 ) = temp
494 a( k2+2, k2 ) = zero
495 CALL drot( istopm-k2, a( k2+1, k2+1 ), lda, a( k2+2,
496 $ k2+1 ), lda, c1, s1 )
497 CALL drot( istopm-k2, b( k2+1, k2+1 ), ldb, b( k2+2,
498 $ k2+1 ), ldb, c1, s1 )
499 CALL drot( jw, qc( 1, k2+1-kwtop+1 ), 1, qc( 1,
500 $ k2+2-kwtop+1 ), 1, c1, s1 )
501
502 END DO
503
504* Remove the shift
505 CALL dlartg( b( kwbot, kwbot ), b( kwbot, kwbot-1 ), c1,
506 $ s1, temp )
507 b( kwbot, kwbot ) = temp
508 b( kwbot, kwbot-1 ) = zero
509 CALL drot( kwbot-istartm, b( istartm, kwbot ), 1,
510 $ b( istartm, kwbot-1 ), 1, c1, s1 )
511 CALL drot( kwbot-istartm+1, a( istartm, kwbot ), 1,
512 $ a( istartm, kwbot-1 ), 1, c1, s1 )
513 CALL drot( jw, zc( 1, kwbot-kwtop+1 ), 1, zc( 1,
514 $ kwbot-1-kwtop+1 ), 1, c1, s1 )
515
516 k = k-1
517 END IF
518 END DO
519
520 END IF
521
522* Apply Qc and Zc to rest of the matrix
523 IF ( ilschur ) THEN
524 istartm = 1
525 istopm = n
526 ELSE
527 istartm = ilo
528 istopm = ihi
529 END IF
530
531 IF ( istopm-ihi > 0 ) THEN
532 CALL dgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,
533 $ a( kwtop, ihi+1 ), lda, zero, work, jw )
534 CALL dlacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,
535 $ ihi+1 ), lda )
536 CALL dgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,
537 $ b( kwtop, ihi+1 ), ldb, zero, work, jw )
538 CALL dlacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,
539 $ ihi+1 ), ldb )
540 END IF
541 IF ( ilq ) THEN
542 CALL dgemm( 'N', 'N', n, jw, jw, one, q( 1, kwtop ), ldq, qc,
543 $ ldqc, zero, work, n )
544 CALL dlacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq )
545 END IF
546
547 IF ( kwtop-1-istartm+1 > 0 ) THEN
548 CALL dgemm( 'N', 'N', kwtop-istartm, jw, jw, one, a( istartm,
549 $ kwtop ), lda, zc, ldzc, zero, work,
550 $ kwtop-istartm )
551 CALL dlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,
552 $ a( istartm, kwtop ), lda )
553 CALL dgemm( 'N', 'N', kwtop-istartm, jw, jw, one, b( istartm,
554 $ kwtop ), ldb, zc, ldzc, zero, work,
555 $ kwtop-istartm )
556 CALL dlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,
557 $ b( istartm, kwtop ), ldb )
558 END IF
559 IF ( ilz ) THEN
560 CALL dgemm( 'N', 'N', n, jw, jw, one, z( 1, kwtop ), ldz, zc,
561 $ ldzc, zero, work, n )
562 CALL dlacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz )
563 END IF
564
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
dtgexc
subroutine dtgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, work, lwork, info)
DTGEXC
Definition dtgexc.f:220
dlaqz0
recursive subroutine dlaqz0(wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb, alphar, alphai, beta, q, ldq, z, ldz, work, lwork, rec, info)
DLAQZ0
Definition dlaqz0.f:306
dlaqz2
subroutine dlaqz2(ilq, ilz, k, istartm, istopm, ihi, a, lda, b, ldb, nq, qstart, q, ldq, nz, zstart, z, ldz)
DLAQZ2
Definition dlaqz2.f:174

◆ dlaqz4()

subroutine dlaqz4 ( logical, intent(in) ilschur,
logical, intent(in) ilq,
logical, intent(in) ilz,
integer, intent(in) n,
integer, intent(in) ilo,
integer, intent(in) ihi,
integer, intent(in) nshifts,
integer, intent(in) nblock_desired,
double precision, dimension( * ), intent(inout) sr,
double precision, dimension( * ), intent(inout) si,
double precision, dimension( * ), intent(inout) ss,
double precision, dimension( lda, * ), intent(inout) a,
integer, intent(in) lda,
double precision, dimension( ldb, * ), intent(inout) b,
integer, intent(in) ldb,
double precision, dimension( ldq, * ), intent(inout) q,
integer, intent(in) ldq,
double precision, dimension( ldz, * ), intent(inout) z,
integer, intent(in) ldz,
double precision, dimension( ldqc, * ), intent(inout) qc,
integer, intent(in) ldqc,
double precision, dimension( ldzc, * ), intent(inout) zc,
integer, intent(in) ldzc,
double precision, dimension( * ), intent(inout) work,
integer, intent(in) lwork,
integer, intent(out) info )

DLAQZ4

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

Purpose:
!>
!> DLAQZ4 Executes a single multishift QZ sweep
!>
Parameters
[in]ILSCHUR
!>          ILSCHUR is LOGICAL
!>              Determines whether or not to update the full Schur form
!>
[in]ILQ
!>          ILQ is LOGICAL
!>              Determines whether or not to update the matrix Q
!>
[in]ILZ
!>          ILZ is LOGICAL
!>              Determines whether or not to update the matrix Z
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A, B, Q, and Z.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
[in]NSHIFTS
!>          NSHIFTS is INTEGER
!>          The desired number of shifts to use
!>
[in]NBLOCK_DESIRED
!>          NBLOCK_DESIRED is INTEGER
!>          The desired size of the computational windows
!>
[in]SR
!>          SR is DOUBLE PRECISION array. SR contains
!>          the real parts of the shifts to use.
!>
[in]SI
!>          SI is DOUBLE PRECISION array. SI contains
!>          the imaginary parts of the shifts to use.
!>
[in]SS
!>          SS is DOUBLE PRECISION array. SS contains
!>          the scale of the shifts to use.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA, N)
!>
[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)
!>
[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)
!>
[in]LDQ
!>          LDQ is INTEGER
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ, N)
!>
[in]LDZ
!>          LDZ is INTEGER
!>
[in,out]QC
!>          QC is DOUBLE PRECISION array, dimension (LDQC, NBLOCK_DESIRED)
!>
[in]LDQC
!>          LDQC is INTEGER
!>
[in,out]ZC
!>          ZC is DOUBLE PRECISION array, dimension (LDZC, NBLOCK_DESIRED)
!>
[in]LDZC
!>          LDZ is INTEGER
!>
[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 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
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 209 of file dlaqz4.f.

213 IMPLICIT NONE
214
215* Function arguments
216 LOGICAL, INTENT( IN ) :: ILSCHUR, ILQ, ILZ
217 INTEGER, INTENT( IN ) :: N, ILO, IHI, LDA, LDB, LDQ, LDZ, LWORK,
218 $ NSHIFTS, NBLOCK_DESIRED, LDQC, LDZC
219
220 DOUBLE PRECISION, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ),
221 $ Q( LDQ, * ), Z( LDZ, * ), QC( LDQC, * ),
222 $ ZC( LDZC, * ), WORK( * ), SR( * ), SI( * ),
223 $ SS( * )
224
225 INTEGER, INTENT( OUT ) :: INFO
226
227* Parameters
228 DOUBLE PRECISION :: ZERO, ONE, HALF
229 parameter( zero = 0.0d0, one = 1.0d0, half = 0.5d0 )
230
231* Local scalars
232 INTEGER :: I, J, NS, ISTARTM, ISTOPM, SHEIGHT, SWIDTH, K, NP,
233 $ ISTARTB, ISTOPB, ISHIFT, NBLOCK, NPOS
234 DOUBLE PRECISION :: TEMP, V( 3 ), C1, S1, C2, S2, SWAP
235*
236* External functions
237 EXTERNAL :: xerbla, dgemm, dlaqz1, dlaqz2, dlaset, dlartg, drot,
238 $ dlacpy
239
240 info = 0
241 IF ( nblock_desired .LT. nshifts+1 ) THEN
242 info = -8
243 END IF
244 IF ( lwork .EQ.-1 ) THEN
245* workspace query, quick return
246 work( 1 ) = n*nblock_desired
247 RETURN
248 ELSE IF ( lwork .LT. n*nblock_desired ) THEN
249 info = -25
250 END IF
251
252 IF( info.NE.0 ) THEN
253 CALL xerbla( 'DLAQZ4', -info )
254 RETURN
255 END IF
256
257* Executable statements
258
259 IF ( nshifts .LT. 2 ) THEN
260 RETURN
261 END IF
262
263 IF ( ilo .GE. ihi ) THEN
264 RETURN
265 END IF
266
267 IF ( ilschur ) THEN
268 istartm = 1
269 istopm = n
270 ELSE
271 istartm = ilo
272 istopm = ihi
273 END IF
274
275* Shuffle shifts into pairs of real shifts and pairs
276* of complex conjugate shifts assuming complex
277* conjugate shifts are already adjacent to one
278* another
279
280 DO i = 1, nshifts-2, 2
281 IF( si( i ).NE.-si( i+1 ) ) THEN
282*
283 swap = sr( i )
284 sr( i ) = sr( i+1 )
285 sr( i+1 ) = sr( i+2 )
286 sr( i+2 ) = swap
287
288 swap = si( i )
289 si( i ) = si( i+1 )
290 si( i+1 ) = si( i+2 )
291 si( i+2 ) = swap
292
293 swap = ss( i )
294 ss( i ) = ss( i+1 )
295 ss( i+1 ) = ss( i+2 )
296 ss( i+2 ) = swap
297 END IF
298 END DO
299
300* NSHFTS is supposed to be even, but if it is odd,
301* then simply reduce it by one. The shuffle above
302* ensures that the dropped shift is real and that
303* the remaining shifts are paired.
304
305 ns = nshifts-mod( nshifts, 2 )
306 npos = max( nblock_desired-ns, 1 )
307
308* The following block introduces the shifts and chases
309* them down one by one just enough to make space for
310* the other shifts. The near-the-diagonal block is
311* of size (ns+1) x ns.
312
313 CALL dlaset( 'FULL', ns+1, ns+1, zero, one, qc, ldqc )
314 CALL dlaset( 'FULL', ns, ns, zero, one, zc, ldzc )
315
316 DO i = 1, ns, 2
317* Introduce the shift
318 CALL dlaqz1( a( ilo, ilo ), lda, b( ilo, ilo ), ldb, sr( i ),
319 $ sr( i+1 ), si( i ), ss( i ), ss( i+1 ), v )
320
321 temp = v( 2 )
322 CALL dlartg( temp, v( 3 ), c1, s1, v( 2 ) )
323 CALL dlartg( v( 1 ), v( 2 ), c2, s2, temp )
324
325 CALL drot( ns, a( ilo+1, ilo ), lda, a( ilo+2, ilo ), lda, c1,
326 $ s1 )
327 CALL drot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c2,
328 $ s2 )
329 CALL drot( ns, b( ilo+1, ilo ), ldb, b( ilo+2, ilo ), ldb, c1,
330 $ s1 )
331 CALL drot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c2,
332 $ s2 )
333 CALL drot( ns+1, qc( 1, 2 ), 1, qc( 1, 3 ), 1, c1, s1 )
334 CALL drot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c2, s2 )
335
336* Chase the shift down
337 DO j = 1, ns-1-i
338
339 CALL dlaqz2( .true., .true., j, 1, ns, ihi-ilo+1, a( ilo,
340 $ ilo ), lda, b( ilo, ilo ), ldb, ns+1, 1, qc,
341 $ ldqc, ns, 1, zc, ldzc )
342
343 END DO
344
345 END DO
346
347* Update the rest of the pencil
348
349* Update A(ilo:ilo+ns,ilo+ns:istopm) and B(ilo:ilo+ns,ilo+ns:istopm)
350* from the left with Qc(1:ns+1,1:ns+1)'
351 sheight = ns+1
352 swidth = istopm-( ilo+ns )+1
353 IF ( swidth > 0 ) THEN
354 CALL dgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,
355 $ a( ilo, ilo+ns ), lda, zero, work, sheight )
356 CALL dlacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,
357 $ ilo+ns ), lda )
358 CALL dgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,
359 $ b( ilo, ilo+ns ), ldb, zero, work, sheight )
360 CALL dlacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,
361 $ ilo+ns ), ldb )
362 END IF
363 IF ( ilq ) THEN
364 CALL dgemm( 'N', 'N', n, sheight, sheight, one, q( 1, ilo ),
365 $ ldq, qc, ldqc, zero, work, n )
366 CALL dlacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq )
367 END IF
368
369* Update A(istartm:ilo-1,ilo:ilo+ns-1) and B(istartm:ilo-1,ilo:ilo+ns-1)
370* from the right with Zc(1:ns,1:ns)
371 sheight = ilo-1-istartm+1
372 swidth = ns
373 IF ( sheight > 0 ) THEN
374 CALL dgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,
375 $ ilo ), lda, zc, ldzc, zero, work, sheight )
376 CALL dlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,
377 $ ilo ), lda )
378 CALL dgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,
379 $ ilo ), ldb, zc, ldzc, zero, work, sheight )
380 CALL dlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,
381 $ ilo ), ldb )
382 END IF
383 IF ( ilz ) THEN
384 CALL dgemm( 'N', 'N', n, swidth, swidth, one, z( 1, ilo ), ldz,
385 $ zc, ldzc, zero, work, n )
386 CALL dlacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz )
387 END IF
388
389* The following block chases the shifts down to the bottom
390* right block. If possible, a shift is moved down npos
391* positions at a time
392
393 k = ilo
394 DO WHILE ( k < ihi-ns )
395 np = min( ihi-ns-k, npos )
396* Size of the near-the-diagonal block
397 nblock = ns+np
398* istartb points to the first row we will be updating
399 istartb = k+1
400* istopb points to the last column we will be updating
401 istopb = k+nblock-1
402
403 CALL dlaset( 'FULL', ns+np, ns+np, zero, one, qc, ldqc )
404 CALL dlaset( 'FULL', ns+np, ns+np, zero, one, zc, ldzc )
405
406* Near the diagonal shift chase
407 DO i = ns-1, 0, -2
408 DO j = 0, np-1
409* Move down the block with index k+i+j-1, updating
410* the (ns+np x ns+np) block:
411* (k:k+ns+np,k:k+ns+np-1)
412 CALL dlaqz2( .true., .true., k+i+j-1, istartb, istopb,
413 $ ihi, a, lda, b, ldb, nblock, k+1, qc, ldqc,
414 $ nblock, k, zc, ldzc )
415 END DO
416 END DO
417
418* Update rest of the pencil
419
420* Update A(k+1:k+ns+np, k+ns+np:istopm) and
421* B(k+1:k+ns+np, k+ns+np:istopm)
422* from the left with Qc(1:ns+np,1:ns+np)'
423 sheight = ns+np
424 swidth = istopm-( k+ns+np )+1
425 IF ( swidth > 0 ) THEN
426 CALL dgemm( 'T', 'N', sheight, swidth, sheight, one, qc,
427 $ ldqc, a( k+1, k+ns+np ), lda, zero, work,
428 $ sheight )
429 CALL dlacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,
430 $ k+ns+np ), lda )
431 CALL dgemm( 'T', 'N', sheight, swidth, sheight, one, qc,
432 $ ldqc, b( k+1, k+ns+np ), ldb, zero, work,
433 $ sheight )
434 CALL dlacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,
435 $ k+ns+np ), ldb )
436 END IF
437 IF ( ilq ) THEN
438 CALL dgemm( 'N', 'N', n, nblock, nblock, one, q( 1, k+1 ),
439 $ ldq, qc, ldqc, zero, work, n )
440 CALL dlacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq )
441 END IF
442
443* Update A(istartm:k,k:k+ns+npos-1) and B(istartm:k,k:k+ns+npos-1)
444* from the right with Zc(1:ns+np,1:ns+np)
445 sheight = k-istartm+1
446 swidth = nblock
447 IF ( sheight > 0 ) THEN
448 CALL dgemm( 'N', 'N', sheight, swidth, swidth, one,
449 $ a( istartm, k ), lda, zc, ldzc, zero, work,
450 $ sheight )
451 CALL dlacpy( 'ALL', sheight, swidth, work, sheight,
452 $ a( istartm, k ), lda )
453 CALL dgemm( 'N', 'N', sheight, swidth, swidth, one,
454 $ b( istartm, k ), ldb, zc, ldzc, zero, work,
455 $ sheight )
456 CALL dlacpy( 'ALL', sheight, swidth, work, sheight,
457 $ b( istartm, k ), ldb )
458 END IF
459 IF ( ilz ) THEN
460 CALL dgemm( 'N', 'N', n, nblock, nblock, one, z( 1, k ),
461 $ ldz, zc, ldzc, zero, work, n )
462 CALL dlacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz )
463 END IF
464
465 k = k+np
466
467 END DO
468
469* The following block removes the shifts from the bottom right corner
470* one by one. Updates are initially applied to A(ihi-ns+1:ihi,ihi-ns:ihi).
471
472 CALL dlaset( 'FULL', ns, ns, zero, one, qc, ldqc )
473 CALL dlaset( 'FULL', ns+1, ns+1, zero, one, zc, ldzc )
474
475* istartb points to the first row we will be updating
476 istartb = ihi-ns+1
477* istopb points to the last column we will be updating
478 istopb = ihi
479
480 DO i = 1, ns, 2
481* Chase the shift down to the bottom right corner
482 DO ishift = ihi-i-1, ihi-2
483 CALL dlaqz2( .true., .true., ishift, istartb, istopb, ihi,
484 $ a, lda, b, ldb, ns, ihi-ns+1, qc, ldqc, ns+1,
485 $ ihi-ns, zc, ldzc )
486 END DO
487
488 END DO
489
490* Update rest of the pencil
491
492* Update A(ihi-ns+1:ihi, ihi+1:istopm)
493* from the left with Qc(1:ns,1:ns)'
494 sheight = ns
495 swidth = istopm-( ihi+1 )+1
496 IF ( swidth > 0 ) THEN
497 CALL dgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,
498 $ a( ihi-ns+1, ihi+1 ), lda, zero, work, sheight )
499 CALL dlacpy( 'ALL', sheight, swidth, work, sheight,
500 $ a( ihi-ns+1, ihi+1 ), lda )
501 CALL dgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,
502 $ b( ihi-ns+1, ihi+1 ), ldb, zero, work, sheight )
503 CALL dlacpy( 'ALL', sheight, swidth, work, sheight,
504 $ b( ihi-ns+1, ihi+1 ), ldb )
505 END IF
506 IF ( ilq ) THEN
507 CALL dgemm( 'N', 'N', n, ns, ns, one, q( 1, ihi-ns+1 ), ldq,
508 $ qc, ldqc, zero, work, n )
509 CALL dlacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq )
510 END IF
511
512* Update A(istartm:ihi-ns,ihi-ns:ihi)
513* from the right with Zc(1:ns+1,1:ns+1)
514 sheight = ihi-ns-istartm+1
515 swidth = ns+1
516 IF ( sheight > 0 ) THEN
517 CALL dgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,
518 $ ihi-ns ), lda, zc, ldzc, zero, work, sheight )
519 CALL dlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,
520 $ ihi-ns ), lda )
521 CALL dgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,
522 $ ihi-ns ), ldb, zc, ldzc, zero, work, sheight )
523 CALL dlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,
524 $ ihi-ns ), ldb )
525 END IF
526 IF ( ilz ) THEN
527 CALL dgemm( 'N', 'N', n, ns+1, ns+1, one, z( 1, ihi-ns ), ldz,
528 $ zc, ldzc, zero, work, n )
529 CALL dlacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz )
530 END IF
531
dlaqz1
subroutine dlaqz1(a, lda, b, ldb, sr1, sr2, si, beta1, beta2, v)
DLAQZ1
Definition dlaqz1.f:127

◆ dtgevc()

subroutine dtgevc ( character side,
character howmny,
logical, dimension( * ) select,
integer n,
double precision, dimension( lds, * ) s,
integer lds,
double precision, dimension( ldp, * ) p,
integer ldp,
double precision, dimension( ldvl, * ) vl,
integer ldvl,
double precision, dimension( ldvr, * ) vr,
integer ldvr,
integer mm,
integer m,
double precision, dimension( * ) work,
integer info )

DTGEVC

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

Purpose:
!>
!> DTGEVC computes some or all of the right and/or left eigenvectors of
!> a pair of real matrices (S,P), where S is a quasi-triangular matrix
!> and P is upper triangular.  Matrix pairs of this type are produced by
!> the generalized Schur factorization of a matrix pair (A,B):
!>
!>    A = Q*S*Z**T,  B = Q*P*Z**T
!>
!> as computed by DGGHRD + DHGEQZ.
!>
!> The right eigenvector x and the left eigenvector y of (S,P)
!> corresponding to an eigenvalue w are defined by:
!>
!>    S*x = w*P*x,  (y**H)*S = w*(y**H)*P,
!>
!> where y**H denotes the conjugate tranpose of y.
!> The eigenvalues are not input to this routine, but are computed
!> directly from the diagonal blocks of S and P.
!>
!> This routine returns the matrices X and/or Y of right and left
!> eigenvectors of (S,P), or the products Z*X and/or Q*Y,
!> where Z and Q are input matrices.
!> If Q and Z are the orthogonal factors from the generalized Schur
!> factorization of a matrix pair (A,B), then Z*X and Q*Y
!> are the matrices of right and left eigenvectors of (A,B).
!>
!>
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,
!>                 specified by the logical array SELECT.
!>
[in]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 matrices S and P.  N >= 0.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (LDS,N)
!>          The upper quasi-triangular matrix S from a generalized Schur
!>          factorization, as computed by DHGEQZ.
!>
[in]LDS
!>          LDS is INTEGER
!>          The leading dimension of array S.  LDS >= max(1,N).
!>
[in]P
!>          P is DOUBLE PRECISION array, dimension (LDP,N)
!>          The upper triangular matrix P from a generalized Schur
!>          factorization, as computed by DHGEQZ.
!>          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks
!>          of S must be in positive diagonal form.
!>
[in]LDP
!>          LDP is INTEGER
!>          The leading dimension of array P.  LDP >= 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 left Schur vectors returned by DHGEQZ).
!>          On exit, if SIDE = 'L' or 'B', VL contains:
!>          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
!>          if HOWMNY = 'B', the matrix Q*Y;
!>          if HOWMNY = 'S', the left eigenvectors of (S,P) 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 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 Z (usually the orthogonal matrix Z
!>          of right Schur vectors returned by DHGEQZ).
!>
!>          On exit, if SIDE = 'R' or 'B', VR contains:
!>          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
!>          if HOWMNY = 'B' or 'b', the matrix Z*X;
!>          if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)
!>                      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 (6*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  the 2-by-2 block (INFO:INFO+1) does not have a complex
!>                eigenvalue.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Allocation of workspace:
!>  ---------- -- ---------
!>
!>     WORK( j ) = 1-norm of j-th column of A, above the diagonal
!>     WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
!>     WORK( 2*N+1:3*N ) = real part of eigenvector
!>     WORK( 3*N+1:4*N ) = imaginary part of eigenvector
!>     WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
!>     WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
!>
!>  Rowwise vs. columnwise solution methods:
!>  ------- --  ---------- -------- -------
!>
!>  Finding a generalized eigenvector consists basically of solving the
!>  singular triangular system
!>
!>   (A - w B) x = 0     (for right) or:   (A - w B)**H y = 0  (for left)
!>
!>  Consider finding the i-th right eigenvector (assume all eigenvalues
!>  are real). The equation to be solved is:
!>       n                   i
!>  0 = sum  C(j,k) v(k)  = sum  C(j,k) v(k)     for j = i,. . .,1
!>      k=j                 k=j
!>
!>  where  C = (A - w B)  (The components v(i+1:n) are 0.)
!>
!>  The  method is:
!>
!>  (1)  v(i) := 1
!>  for j = i-1,. . .,1:
!>                          i
!>      (2) compute  s = - sum C(j,k) v(k)   and
!>                        k=j+1
!>
!>      (3) v(j) := s / C(j,j)
!>
!>  Step 2 is sometimes called the  step, since it is an
!>  inner product between the j-th row and the portion of the eigenvector
!>  that has been computed so far.
!>
!>  The  method consists basically in doing the sums
!>  for all the rows in parallel.  As each v(j) is computed, the
!>  contribution of v(j) times the j-th column of C is added to the
!>  partial sums.  Since FORTRAN arrays are stored columnwise, this has
!>  the advantage that at each step, the elements of C that are accessed
!>  are adjacent to one another, whereas with the rowwise method, the
!>  elements accessed at a step are spaced LDS (and LDP) words apart.
!>
!>  When finding left eigenvectors, the matrix in question is the
!>  transpose of the one in storage, so the rowwise method then
!>  actually accesses columns of A and B at each step, and so is the
!>  preferred method.
!>

Definition at line 293 of file dtgevc.f.

295*
296* -- LAPACK computational routine --
297* -- LAPACK is a software package provided by Univ. of Tennessee, --
298* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
299*
300* .. Scalar Arguments ..
301 CHARACTER HOWMNY, SIDE
302 INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
303* ..
304* .. Array Arguments ..
305 LOGICAL SELECT( * )
306 DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
307 $ VR( LDVR, * ), WORK( * )
308* ..
309*
310*
311* =====================================================================
312*
313* .. Parameters ..
314 DOUBLE PRECISION ZERO, ONE, SAFETY
315 parameter( zero = 0.0d+0, one = 1.0d+0,
316 $ safety = 1.0d+2 )
317* ..
318* .. Local Scalars ..
319 LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK,
320 $ ILBBAD, ILCOMP, ILCPLX, LSA, LSB
321 INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE,
322 $ J, JA, JC, JE, JR, JW, NA, NW
323 DOUBLE PRECISION ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI,
324 $ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A,
325 $ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA,
326 $ CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE,
327 $ SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX,
328 $ XSCALE
329* ..
330* .. Local Arrays ..
331 DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ),
332 $ SUMP( 2, 2 )
333* ..
334* .. External Functions ..
335 LOGICAL LSAME
336 DOUBLE PRECISION DLAMCH
337 EXTERNAL lsame, dlamch
338* ..
339* .. External Subroutines ..
340 EXTERNAL dgemv, dlabad, dlacpy, dlag2, dlaln2, xerbla
341* ..
342* .. Intrinsic Functions ..
343 INTRINSIC abs, max, min
344* ..
345* .. Executable Statements ..
346*
347* Decode and Test the input parameters
348*
349 IF( lsame( howmny, 'A' ) ) THEN
350 ihwmny = 1
351 ilall = .true.
352 ilback = .false.
353 ELSE IF( lsame( howmny, 'S' ) ) THEN
354 ihwmny = 2
355 ilall = .false.
356 ilback = .false.
357 ELSE IF( lsame( howmny, 'B' ) ) THEN
358 ihwmny = 3
359 ilall = .true.
360 ilback = .true.
361 ELSE
362 ihwmny = -1
363 ilall = .true.
364 END IF
365*
366 IF( lsame( side, 'R' ) ) THEN
367 iside = 1
368 compl = .false.
369 compr = .true.
370 ELSE IF( lsame( side, 'L' ) ) THEN
371 iside = 2
372 compl = .true.
373 compr = .false.
374 ELSE IF( lsame( side, 'B' ) ) THEN
375 iside = 3
376 compl = .true.
377 compr = .true.
378 ELSE
379 iside = -1
380 END IF
381*
382 info = 0
383 IF( iside.LT.0 ) THEN
384 info = -1
385 ELSE IF( ihwmny.LT.0 ) THEN
386 info = -2
387 ELSE IF( n.LT.0 ) THEN
388 info = -4
389 ELSE IF( lds.LT.max( 1, n ) ) THEN
390 info = -6
391 ELSE IF( ldp.LT.max( 1, n ) ) THEN
392 info = -8
393 END IF
394 IF( info.NE.0 ) THEN
395 CALL xerbla( 'DTGEVC', -info )
396 RETURN
397 END IF
398*
399* Count the number of eigenvectors to be computed
400*
401 IF( .NOT.ilall ) THEN
402 im = 0
403 ilcplx = .false.
404 DO 10 j = 1, n
405 IF( ilcplx ) THEN
406 ilcplx = .false.
407 GO TO 10
408 END IF
409 IF( j.LT.n ) THEN
410 IF( s( j+1, j ).NE.zero )
411 $ ilcplx = .true.
412 END IF
413 IF( ilcplx ) THEN
414 IF( SELECT( j ) .OR. SELECT( j+1 ) )
415 $ im = im + 2
416 ELSE
417 IF( SELECT( j ) )
418 $ im = im + 1
419 END IF
420 10 CONTINUE
421 ELSE
422 im = n
423 END IF
424*
425* Check 2-by-2 diagonal blocks of A, B
426*
427 ilabad = .false.
428 ilbbad = .false.
429 DO 20 j = 1, n - 1
430 IF( s( j+1, j ).NE.zero ) THEN
431 IF( p( j, j ).EQ.zero .OR. p( j+1, j+1 ).EQ.zero .OR.
432 $ p( j, j+1 ).NE.zero )ilbbad = .true.
433 IF( j.LT.n-1 ) THEN
434 IF( s( j+2, j+1 ).NE.zero )
435 $ ilabad = .true.
436 END IF
437 END IF
438 20 CONTINUE
439*
440 IF( ilabad ) THEN
441 info = -5
442 ELSE IF( ilbbad ) THEN
443 info = -7
444 ELSE IF( compl .AND. ldvl.LT.n .OR. ldvl.LT.1 ) THEN
445 info = -10
446 ELSE IF( compr .AND. ldvr.LT.n .OR. ldvr.LT.1 ) THEN
447 info = -12
448 ELSE IF( mm.LT.im ) THEN
449 info = -13
450 END IF
451 IF( info.NE.0 ) THEN
452 CALL xerbla( 'DTGEVC', -info )
453 RETURN
454 END IF
455*
456* Quick return if possible
457*
458 m = im
459 IF( n.EQ.0 )
460 $ RETURN
461*
462* Machine Constants
463*
464 safmin = dlamch( 'Safe minimum' )
465 big = one / safmin
466 CALL dlabad( safmin, big )
467 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
468 small = safmin*n / ulp
469 big = one / small
470 bignum = one / ( safmin*n )
471*
472* Compute the 1-norm of each column of the strictly upper triangular
473* part (i.e., excluding all elements belonging to the diagonal
474* blocks) of A and B to check for possible overflow in the
475* triangular solver.
476*
477 anorm = abs( s( 1, 1 ) )
478 IF( n.GT.1 )
479 $ anorm = anorm + abs( s( 2, 1 ) )
480 bnorm = abs( p( 1, 1 ) )
481 work( 1 ) = zero
482 work( n+1 ) = zero
483*
484 DO 50 j = 2, n
485 temp = zero
486 temp2 = zero
487 IF( s( j, j-1 ).EQ.zero ) THEN
488 iend = j - 1
489 ELSE
490 iend = j - 2
491 END IF
492 DO 30 i = 1, iend
493 temp = temp + abs( s( i, j ) )
494 temp2 = temp2 + abs( p( i, j ) )
495 30 CONTINUE
496 work( j ) = temp
497 work( n+j ) = temp2
498 DO 40 i = iend + 1, min( j+1, n )
499 temp = temp + abs( s( i, j ) )
500 temp2 = temp2 + abs( p( i, j ) )
501 40 CONTINUE
502 anorm = max( anorm, temp )
503 bnorm = max( bnorm, temp2 )
504 50 CONTINUE
505*
506 ascale = one / max( anorm, safmin )
507 bscale = one / max( bnorm, safmin )
508*
509* Left eigenvectors
510*
511 IF( compl ) THEN
512 ieig = 0
513*
514* Main loop over eigenvalues
515*
516 ilcplx = .false.
517 DO 220 je = 1, n
518*
519* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
520* (b) this would be the second of a complex pair.
521* Check for complex eigenvalue, so as to be sure of which
522* entry(-ies) of SELECT to look at.
523*
524 IF( ilcplx ) THEN
525 ilcplx = .false.
526 GO TO 220
527 END IF
528 nw = 1
529 IF( je.LT.n ) THEN
530 IF( s( je+1, je ).NE.zero ) THEN
531 ilcplx = .true.
532 nw = 2
533 END IF
534 END IF
535 IF( ilall ) THEN
536 ilcomp = .true.
537 ELSE IF( ilcplx ) THEN
538 ilcomp = SELECT( je ) .OR. SELECT( je+1 )
539 ELSE
540 ilcomp = SELECT( je )
541 END IF
542 IF( .NOT.ilcomp )
543 $ GO TO 220
544*
545* Decide if (a) singular pencil, (b) real eigenvalue, or
546* (c) complex eigenvalue.
547*
548 IF( .NOT.ilcplx ) THEN
549 IF( abs( s( je, je ) ).LE.safmin .AND.
550 $ abs( p( je, je ) ).LE.safmin ) THEN
551*
552* Singular matrix pencil -- return unit eigenvector
553*
554 ieig = ieig + 1
555 DO 60 jr = 1, n
556 vl( jr, ieig ) = zero
557 60 CONTINUE
558 vl( ieig, ieig ) = one
559 GO TO 220
560 END IF
561 END IF
562*
563* Clear vector
564*
565 DO 70 jr = 1, nw*n
566 work( 2*n+jr ) = zero
567 70 CONTINUE
568* T
569* Compute coefficients in ( a A - b B ) y = 0
570* a is ACOEF
571* b is BCOEFR + i*BCOEFI
572*
573 IF( .NOT.ilcplx ) THEN
574*
575* Real eigenvalue
576*
577 temp = one / max( abs( s( je, je ) )*ascale,
578 $ abs( p( je, je ) )*bscale, safmin )
579 salfar = ( temp*s( je, je ) )*ascale
580 sbeta = ( temp*p( je, je ) )*bscale
581 acoef = sbeta*ascale
582 bcoefr = salfar*bscale
583 bcoefi = zero
584*
585* Scale to avoid underflow
586*
587 scale = one
588 lsa = abs( sbeta ).GE.safmin .AND. abs( acoef ).LT.small
589 lsb = abs( salfar ).GE.safmin .AND. abs( bcoefr ).LT.
590 $ small
591 IF( lsa )
592 $ scale = ( small / abs( sbeta ) )*min( anorm, big )
593 IF( lsb )
594 $ scale = max( scale, ( small / abs( salfar ) )*
595 $ min( bnorm, big ) )
596 IF( lsa .OR. lsb ) THEN
597 scale = min( scale, one /
598 $ ( safmin*max( one, abs( acoef ),
599 $ abs( bcoefr ) ) ) )
600 IF( lsa ) THEN
601 acoef = ascale*( scale*sbeta )
602 ELSE
603 acoef = scale*acoef
604 END IF
605 IF( lsb ) THEN
606 bcoefr = bscale*( scale*salfar )
607 ELSE
608 bcoefr = scale*bcoefr
609 END IF
610 END IF
611 acoefa = abs( acoef )
612 bcoefa = abs( bcoefr )
613*
614* First component is 1
615*
616 work( 2*n+je ) = one
617 xmax = one
618 ELSE
619*
620* Complex eigenvalue
621*
622 CALL dlag2( s( je, je ), lds, p( je, je ), ldp,
623 $ safmin*safety, acoef, temp, bcoefr, temp2,
624 $ bcoefi )
625 bcoefi = -bcoefi
626 IF( bcoefi.EQ.zero ) THEN
627 info = je
628 RETURN
629 END IF
630*
631* Scale to avoid over/underflow
632*
633 acoefa = abs( acoef )
634 bcoefa = abs( bcoefr ) + abs( bcoefi )
635 scale = one
636 IF( acoefa*ulp.LT.safmin .AND. acoefa.GE.safmin )
637 $ scale = ( safmin / ulp ) / acoefa
638 IF( bcoefa*ulp.LT.safmin .AND. bcoefa.GE.safmin )
639 $ scale = max( scale, ( safmin / ulp ) / bcoefa )
640 IF( safmin*acoefa.GT.ascale )
641 $ scale = ascale / ( safmin*acoefa )
642 IF( safmin*bcoefa.GT.bscale )
643 $ scale = min( scale, bscale / ( safmin*bcoefa ) )
644 IF( scale.NE.one ) THEN
645 acoef = scale*acoef
646 acoefa = abs( acoef )
647 bcoefr = scale*bcoefr
648 bcoefi = scale*bcoefi
649 bcoefa = abs( bcoefr ) + abs( bcoefi )
650 END IF
651*
652* Compute first two components of eigenvector
653*
654 temp = acoef*s( je+1, je )
655 temp2r = acoef*s( je, je ) - bcoefr*p( je, je )
656 temp2i = -bcoefi*p( je, je )
657 IF( abs( temp ).GT.abs( temp2r )+abs( temp2i ) ) THEN
658 work( 2*n+je ) = one
659 work( 3*n+je ) = zero
660 work( 2*n+je+1 ) = -temp2r / temp
661 work( 3*n+je+1 ) = -temp2i / temp
662 ELSE
663 work( 2*n+je+1 ) = one
664 work( 3*n+je+1 ) = zero
665 temp = acoef*s( je, je+1 )
666 work( 2*n+je ) = ( bcoefr*p( je+1, je+1 )-acoef*
667 $ s( je+1, je+1 ) ) / temp
668 work( 3*n+je ) = bcoefi*p( je+1, je+1 ) / temp
669 END IF
670 xmax = max( abs( work( 2*n+je ) )+abs( work( 3*n+je ) ),
671 $ abs( work( 2*n+je+1 ) )+abs( work( 3*n+je+1 ) ) )
672 END IF
673*
674 dmin = max( ulp*acoefa*anorm, ulp*bcoefa*bnorm, safmin )
675*
676* T
677* Triangular solve of (a A - b B) y = 0
678*
679* T
680* (rowwise in (a A - b B) , or columnwise in (a A - b B) )
681*
682 il2by2 = .false.
683*
684 DO 160 j = je + nw, n
685 IF( il2by2 ) THEN
686 il2by2 = .false.
687 GO TO 160
688 END IF
689*
690 na = 1
691 bdiag( 1 ) = p( j, j )
692 IF( j.LT.n ) THEN
693 IF( s( j+1, j ).NE.zero ) THEN
694 il2by2 = .true.
695 bdiag( 2 ) = p( j+1, j+1 )
696 na = 2
697 END IF
698 END IF
699*
700* Check whether scaling is necessary for dot products
701*
702 xscale = one / max( one, xmax )
703 temp = max( work( j ), work( n+j ),
704 $ acoefa*work( j )+bcoefa*work( n+j ) )
705 IF( il2by2 )
706 $ temp = max( temp, work( j+1 ), work( n+j+1 ),
707 $ acoefa*work( j+1 )+bcoefa*work( n+j+1 ) )
708 IF( temp.GT.bignum*xscale ) THEN
709 DO 90 jw = 0, nw - 1
710 DO 80 jr = je, j - 1
711 work( ( jw+2 )*n+jr ) = xscale*
712 $ work( ( jw+2 )*n+jr )
713 80 CONTINUE
714 90 CONTINUE
715 xmax = xmax*xscale
716 END IF
717*
718* Compute dot products
719*
720* j-1
721* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k)
722* k=je
723*
724* To reduce the op count, this is done as
725*
726* _ j-1 _ j-1
727* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) )
728* k=je k=je
729*
730* which may cause underflow problems if A or B are close
731* to underflow. (E.g., less than SMALL.)
732*
733*
734 DO 120 jw = 1, nw
735 DO 110 ja = 1, na
736 sums( ja, jw ) = zero
737 sump( ja, jw ) = zero
738*
739 DO 100 jr = je, j - 1
740 sums( ja, jw ) = sums( ja, jw ) +
741 $ s( jr, j+ja-1 )*
742 $ work( ( jw+1 )*n+jr )
743 sump( ja, jw ) = sump( ja, jw ) +
744 $ p( jr, j+ja-1 )*
745 $ work( ( jw+1 )*n+jr )
746 100 CONTINUE
747 110 CONTINUE
748 120 CONTINUE
749*
750 DO 130 ja = 1, na
751 IF( ilcplx ) THEN
752 sum( ja, 1 ) = -acoef*sums( ja, 1 ) +
753 $ bcoefr*sump( ja, 1 ) -
754 $ bcoefi*sump( ja, 2 )
755 sum( ja, 2 ) = -acoef*sums( ja, 2 ) +
756 $ bcoefr*sump( ja, 2 ) +
757 $ bcoefi*sump( ja, 1 )
758 ELSE
759 sum( ja, 1 ) = -acoef*sums( ja, 1 ) +
760 $ bcoefr*sump( ja, 1 )
761 END IF
762 130 CONTINUE
763*
764* T
765* Solve ( a A - b B ) y = SUM(,)
766* with scaling and perturbation of the denominator
767*
768 CALL dlaln2( .true., na, nw, dmin, acoef, s( j, j ), lds,
769 $ bdiag( 1 ), bdiag( 2 ), sum, 2, bcoefr,
770 $ bcoefi, work( 2*n+j ), n, scale, temp,
771 $ iinfo )
772 IF( scale.LT.one ) THEN
773 DO 150 jw = 0, nw - 1
774 DO 140 jr = je, j - 1
775 work( ( jw+2 )*n+jr ) = scale*
776 $ work( ( jw+2 )*n+jr )
777 140 CONTINUE
778 150 CONTINUE
779 xmax = scale*xmax
780 END IF
781 xmax = max( xmax, temp )
782 160 CONTINUE
783*
784* Copy eigenvector to VL, back transforming if
785* HOWMNY='B'.
786*
787 ieig = ieig + 1
788 IF( ilback ) THEN
789 DO 170 jw = 0, nw - 1
790 CALL dgemv( 'N', n, n+1-je, one, vl( 1, je ), ldvl,
791 $ work( ( jw+2 )*n+je ), 1, zero,
792 $ work( ( jw+4 )*n+1 ), 1 )
793 170 CONTINUE
794 CALL dlacpy( ' ', n, nw, work( 4*n+1 ), n, vl( 1, je ),
795 $ ldvl )
796 ibeg = 1
797 ELSE
798 CALL dlacpy( ' ', n, nw, work( 2*n+1 ), n, vl( 1, ieig ),
799 $ ldvl )
800 ibeg = je
801 END IF
802*
803* Scale eigenvector
804*
805 xmax = zero
806 IF( ilcplx ) THEN
807 DO 180 j = ibeg, n
808 xmax = max( xmax, abs( vl( j, ieig ) )+
809 $ abs( vl( j, ieig+1 ) ) )
810 180 CONTINUE
811 ELSE
812 DO 190 j = ibeg, n
813 xmax = max( xmax, abs( vl( j, ieig ) ) )
814 190 CONTINUE
815 END IF
816*
817 IF( xmax.GT.safmin ) THEN
818 xscale = one / xmax
819*
820 DO 210 jw = 0, nw - 1
821 DO 200 jr = ibeg, n
822 vl( jr, ieig+jw ) = xscale*vl( jr, ieig+jw )
823 200 CONTINUE
824 210 CONTINUE
825 END IF
826 ieig = ieig + nw - 1
827*
828 220 CONTINUE
829 END IF
830*
831* Right eigenvectors
832*
833 IF( compr ) THEN
834 ieig = im + 1
835*
836* Main loop over eigenvalues
837*
838 ilcplx = .false.
839 DO 500 je = n, 1, -1
840*
841* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
842* (b) this would be the second of a complex pair.
843* Check for complex eigenvalue, so as to be sure of which
844* entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
845* or SELECT(JE-1).
846* If this is a complex pair, the 2-by-2 diagonal block
847* corresponding to the eigenvalue is in rows/columns JE-1:JE
848*
849 IF( ilcplx ) THEN
850 ilcplx = .false.
851 GO TO 500
852 END IF
853 nw = 1
854 IF( je.GT.1 ) THEN
855 IF( s( je, je-1 ).NE.zero ) THEN
856 ilcplx = .true.
857 nw = 2
858 END IF
859 END IF
860 IF( ilall ) THEN
861 ilcomp = .true.
862 ELSE IF( ilcplx ) THEN
863 ilcomp = SELECT( je ) .OR. SELECT( je-1 )
864 ELSE
865 ilcomp = SELECT( je )
866 END IF
867 IF( .NOT.ilcomp )
868 $ GO TO 500
869*
870* Decide if (a) singular pencil, (b) real eigenvalue, or
871* (c) complex eigenvalue.
872*
873 IF( .NOT.ilcplx ) THEN
874 IF( abs( s( je, je ) ).LE.safmin .AND.
875 $ abs( p( je, je ) ).LE.safmin ) THEN
876*
877* Singular matrix pencil -- unit eigenvector
878*
879 ieig = ieig - 1
880 DO 230 jr = 1, n
881 vr( jr, ieig ) = zero
882 230 CONTINUE
883 vr( ieig, ieig ) = one
884 GO TO 500
885 END IF
886 END IF
887*
888* Clear vector
889*
890 DO 250 jw = 0, nw - 1
891 DO 240 jr = 1, n
892 work( ( jw+2 )*n+jr ) = zero
893 240 CONTINUE
894 250 CONTINUE
895*
896* Compute coefficients in ( a A - b B ) x = 0
897* a is ACOEF
898* b is BCOEFR + i*BCOEFI
899*
900 IF( .NOT.ilcplx ) THEN
901*
902* Real eigenvalue
903*
904 temp = one / max( abs( s( je, je ) )*ascale,
905 $ abs( p( je, je ) )*bscale, safmin )
906 salfar = ( temp*s( je, je ) )*ascale
907 sbeta = ( temp*p( je, je ) )*bscale
908 acoef = sbeta*ascale
909 bcoefr = salfar*bscale
910 bcoefi = zero
911*
912* Scale to avoid underflow
913*
914 scale = one
915 lsa = abs( sbeta ).GE.safmin .AND. abs( acoef ).LT.small
916 lsb = abs( salfar ).GE.safmin .AND. abs( bcoefr ).LT.
917 $ small
918 IF( lsa )
919 $ scale = ( small / abs( sbeta ) )*min( anorm, big )
920 IF( lsb )
921 $ scale = max( scale, ( small / abs( salfar ) )*
922 $ min( bnorm, big ) )
923 IF( lsa .OR. lsb ) THEN
924 scale = min( scale, one /
925 $ ( safmin*max( one, abs( acoef ),
926 $ abs( bcoefr ) ) ) )
927 IF( lsa ) THEN
928 acoef = ascale*( scale*sbeta )
929 ELSE
930 acoef = scale*acoef
931 END IF
932 IF( lsb ) THEN
933 bcoefr = bscale*( scale*salfar )
934 ELSE
935 bcoefr = scale*bcoefr
936 END IF
937 END IF
938 acoefa = abs( acoef )
939 bcoefa = abs( bcoefr )
940*
941* First component is 1
942*
943 work( 2*n+je ) = one
944 xmax = one
945*
946* Compute contribution from column JE of A and B to sum
947* (See "Further Details", above.)
948*
949 DO 260 jr = 1, je - 1
950 work( 2*n+jr ) = bcoefr*p( jr, je ) -
951 $ acoef*s( jr, je )
952 260 CONTINUE
953 ELSE
954*
955* Complex eigenvalue
956*
957 CALL dlag2( s( je-1, je-1 ), lds, p( je-1, je-1 ), ldp,
958 $ safmin*safety, acoef, temp, bcoefr, temp2,
959 $ bcoefi )
960 IF( bcoefi.EQ.zero ) THEN
961 info = je - 1
962 RETURN
963 END IF
964*
965* Scale to avoid over/underflow
966*
967 acoefa = abs( acoef )
968 bcoefa = abs( bcoefr ) + abs( bcoefi )
969 scale = one
970 IF( acoefa*ulp.LT.safmin .AND. acoefa.GE.safmin )
971 $ scale = ( safmin / ulp ) / acoefa
972 IF( bcoefa*ulp.LT.safmin .AND. bcoefa.GE.safmin )
973 $ scale = max( scale, ( safmin / ulp ) / bcoefa )
974 IF( safmin*acoefa.GT.ascale )
975 $ scale = ascale / ( safmin*acoefa )
976 IF( safmin*bcoefa.GT.bscale )
977 $ scale = min( scale, bscale / ( safmin*bcoefa ) )
978 IF( scale.NE.one ) THEN
979 acoef = scale*acoef
980 acoefa = abs( acoef )
981 bcoefr = scale*bcoefr
982 bcoefi = scale*bcoefi
983 bcoefa = abs( bcoefr ) + abs( bcoefi )
984 END IF
985*
986* Compute first two components of eigenvector
987* and contribution to sums
988*
989 temp = acoef*s( je, je-1 )
990 temp2r = acoef*s( je, je ) - bcoefr*p( je, je )
991 temp2i = -bcoefi*p( je, je )
992 IF( abs( temp ).GE.abs( temp2r )+abs( temp2i ) ) THEN
993 work( 2*n+je ) = one
994 work( 3*n+je ) = zero
995 work( 2*n+je-1 ) = -temp2r / temp
996 work( 3*n+je-1 ) = -temp2i / temp
997 ELSE
998 work( 2*n+je-1 ) = one
999 work( 3*n+je-1 ) = zero
1000 temp = acoef*s( je-1, je )
1001 work( 2*n+je ) = ( bcoefr*p( je-1, je-1 )-acoef*
1002 $ s( je-1, je-1 ) ) / temp
1003 work( 3*n+je ) = bcoefi*p( je-1, je-1 ) / temp
1004 END IF
1005*
1006 xmax = max( abs( work( 2*n+je ) )+abs( work( 3*n+je ) ),
1007 $ abs( work( 2*n+je-1 ) )+abs( work( 3*n+je-1 ) ) )
1008*
1009* Compute contribution from columns JE and JE-1
1010* of A and B to the sums.
1011*
1012 creala = acoef*work( 2*n+je-1 )
1013 cimaga = acoef*work( 3*n+je-1 )
1014 crealb = bcoefr*work( 2*n+je-1 ) -
1015 $ bcoefi*work( 3*n+je-1 )
1016 cimagb = bcoefi*work( 2*n+je-1 ) +
1017 $ bcoefr*work( 3*n+je-1 )
1018 cre2a = acoef*work( 2*n+je )
1019 cim2a = acoef*work( 3*n+je )
1020 cre2b = bcoefr*work( 2*n+je ) - bcoefi*work( 3*n+je )
1021 cim2b = bcoefi*work( 2*n+je ) + bcoefr*work( 3*n+je )
1022 DO 270 jr = 1, je - 2
1023 work( 2*n+jr ) = -creala*s( jr, je-1 ) +
1024 $ crealb*p( jr, je-1 ) -
1025 $ cre2a*s( jr, je ) + cre2b*p( jr, je )
1026 work( 3*n+jr ) = -cimaga*s( jr, je-1 ) +
1027 $ cimagb*p( jr, je-1 ) -
1028 $ cim2a*s( jr, je ) + cim2b*p( jr, je )
1029 270 CONTINUE
1030 END IF
1031*
1032 dmin = max( ulp*acoefa*anorm, ulp*bcoefa*bnorm, safmin )
1033*
1034* Columnwise triangular solve of (a A - b B) x = 0
1035*
1036 il2by2 = .false.
1037 DO 370 j = je - nw, 1, -1
1038*
1039* If a 2-by-2 block, is in position j-1:j, wait until
1040* next iteration to process it (when it will be j:j+1)
1041*
1042 IF( .NOT.il2by2 .AND. j.GT.1 ) THEN
1043 IF( s( j, j-1 ).NE.zero ) THEN
1044 il2by2 = .true.
1045 GO TO 370
1046 END IF
1047 END IF
1048 bdiag( 1 ) = p( j, j )
1049 IF( il2by2 ) THEN
1050 na = 2
1051 bdiag( 2 ) = p( j+1, j+1 )
1052 ELSE
1053 na = 1
1054 END IF
1055*
1056* Compute x(j) (and x(j+1), if 2-by-2 block)
1057*
1058 CALL dlaln2( .false., na, nw, dmin, acoef, s( j, j ),
1059 $ lds, bdiag( 1 ), bdiag( 2 ), work( 2*n+j ),
1060 $ n, bcoefr, bcoefi, sum, 2, scale, temp,
1061 $ iinfo )
1062 IF( scale.LT.one ) THEN
1063*
1064 DO 290 jw = 0, nw - 1
1065 DO 280 jr = 1, je
1066 work( ( jw+2 )*n+jr ) = scale*
1067 $ work( ( jw+2 )*n+jr )
1068 280 CONTINUE
1069 290 CONTINUE
1070 END IF
1071 xmax = max( scale*xmax, temp )
1072*
1073 DO 310 jw = 1, nw
1074 DO 300 ja = 1, na
1075 work( ( jw+1 )*n+j+ja-1 ) = sum( ja, jw )
1076 300 CONTINUE
1077 310 CONTINUE
1078*
1079* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
1080*
1081 IF( j.GT.1 ) THEN
1082*
1083* Check whether scaling is necessary for sum.
1084*
1085 xscale = one / max( one, xmax )
1086 temp = acoefa*work( j ) + bcoefa*work( n+j )
1087 IF( il2by2 )
1088 $ temp = max( temp, acoefa*work( j+1 )+bcoefa*
1089 $ work( n+j+1 ) )
1090 temp = max( temp, acoefa, bcoefa )
1091 IF( temp.GT.bignum*xscale ) THEN
1092*
1093 DO 330 jw = 0, nw - 1
1094 DO 320 jr = 1, je
1095 work( ( jw+2 )*n+jr ) = xscale*
1096 $ work( ( jw+2 )*n+jr )
1097 320 CONTINUE
1098 330 CONTINUE
1099 xmax = xmax*xscale
1100 END IF
1101*
1102* Compute the contributions of the off-diagonals of
1103* column j (and j+1, if 2-by-2 block) of A and B to the
1104* sums.
1105*
1106*
1107 DO 360 ja = 1, na
1108 IF( ilcplx ) THEN
1109 creala = acoef*work( 2*n+j+ja-1 )
1110 cimaga = acoef*work( 3*n+j+ja-1 )
1111 crealb = bcoefr*work( 2*n+j+ja-1 ) -
1112 $ bcoefi*work( 3*n+j+ja-1 )
1113 cimagb = bcoefi*work( 2*n+j+ja-1 ) +
1114 $ bcoefr*work( 3*n+j+ja-1 )
1115 DO 340 jr = 1, j - 1
1116 work( 2*n+jr ) = work( 2*n+jr ) -
1117 $ creala*s( jr, j+ja-1 ) +
1118 $ crealb*p( jr, j+ja-1 )
1119 work( 3*n+jr ) = work( 3*n+jr ) -
1120 $ cimaga*s( jr, j+ja-1 ) +
1121 $ cimagb*p( jr, j+ja-1 )
1122 340 CONTINUE
1123 ELSE
1124 creala = acoef*work( 2*n+j+ja-1 )
1125 crealb = bcoefr*work( 2*n+j+ja-1 )
1126 DO 350 jr = 1, j - 1
1127 work( 2*n+jr ) = work( 2*n+jr ) -
1128 $ creala*s( jr, j+ja-1 ) +
1129 $ crealb*p( jr, j+ja-1 )
1130 350 CONTINUE
1131 END IF
1132 360 CONTINUE
1133 END IF
1134*
1135 il2by2 = .false.
1136 370 CONTINUE
1137*
1138* Copy eigenvector to VR, back transforming if
1139* HOWMNY='B'.
1140*
1141 ieig = ieig - nw
1142 IF( ilback ) THEN
1143*
1144 DO 410 jw = 0, nw - 1
1145 DO 380 jr = 1, n
1146 work( ( jw+4 )*n+jr ) = work( ( jw+2 )*n+1 )*
1147 $ vr( jr, 1 )
1148 380 CONTINUE
1149*
1150* A series of compiler directives to defeat
1151* vectorization for the next loop
1152*
1153*
1154 DO 400 jc = 2, je
1155 DO 390 jr = 1, n
1156 work( ( jw+4 )*n+jr ) = work( ( jw+4 )*n+jr ) +
1157 $ work( ( jw+2 )*n+jc )*vr( jr, jc )
1158 390 CONTINUE
1159 400 CONTINUE
1160 410 CONTINUE
1161*
1162 DO 430 jw = 0, nw - 1
1163 DO 420 jr = 1, n
1164 vr( jr, ieig+jw ) = work( ( jw+4 )*n+jr )
1165 420 CONTINUE
1166 430 CONTINUE
1167*
1168 iend = n
1169 ELSE
1170 DO 450 jw = 0, nw - 1
1171 DO 440 jr = 1, n
1172 vr( jr, ieig+jw ) = work( ( jw+2 )*n+jr )
1173 440 CONTINUE
1174 450 CONTINUE
1175*
1176 iend = je
1177 END IF
1178*
1179* Scale eigenvector
1180*
1181 xmax = zero
1182 IF( ilcplx ) THEN
1183 DO 460 j = 1, iend
1184 xmax = max( xmax, abs( vr( j, ieig ) )+
1185 $ abs( vr( j, ieig+1 ) ) )
1186 460 CONTINUE
1187 ELSE
1188 DO 470 j = 1, iend
1189 xmax = max( xmax, abs( vr( j, ieig ) ) )
1190 470 CONTINUE
1191 END IF
1192*
1193 IF( xmax.GT.safmin ) THEN
1194 xscale = one / xmax
1195 DO 490 jw = 0, nw - 1
1196 DO 480 jr = 1, iend
1197 vr( jr, ieig+jw ) = xscale*vr( jr, ieig+jw )
1198 480 CONTINUE
1199 490 CONTINUE
1200 END IF
1201 500 CONTINUE
1202 END IF
1203*
1204 RETURN
1205*
1206* End of DTGEVC
1207*
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

◆ dtgexc()

subroutine dtgexc ( logical wantq,
logical wantz,
integer n,
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 ifst,
integer ilst,
double precision, dimension( * ) work,
integer lwork,
integer info )

DTGEXC

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

Purpose:
!>
!> DTGEXC reorders the generalized real Schur decomposition of a real
!> matrix pair (A,B) using an orthogonal equivalence transformation
!>
!>                (A, B) = Q * (A, B) * Z**T,
!>
!> so that the diagonal block of (A, B) with row index IFST is moved
!> to row ILST.
!>
!> (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.
!>
!> Optionally, the matrices Q and Z of generalized Schur vectors are
!> updated.
!>
!>        Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T
!>        Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T
!>
!>
Parameters
[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]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 matrix A in generalized real Schur canonical
!>          form.
!>          On exit, the updated matrix A, again in generalized
!>          real Schur canonical form.
!>
[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 matrix B in generalized real Schur canonical
!>          form (A,B).
!>          On exit, the updated matrix B, again in generalized
!>          real Schur canonical form (A,B).
!>
[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 WANTQ = .TRUE., the orthogonal matrix Q.
!>          On exit, the updated matrix Q.
!>          If WANTQ = .FALSE., Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= 1.
!>          If WANTQ = .TRUE., LDQ >= N.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ,N)
!>          On entry, if WANTZ = .TRUE., the orthogonal matrix Z.
!>          On exit, the updated matrix Z.
!>          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.
!>
[in,out]IFST
!>          IFST is INTEGER
!>
[in,out]ILST
!>          ILST is INTEGER
!>          Specify the reordering of the diagonal blocks of (A, B).
!>          The block with row index IFST is moved to row ILST, by a
!>          sequence of swapping 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, ILST <= 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 >= 1 when N <= 1, otherwise LWORK >= 4*N + 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]INFO
!>          INFO is INTEGER
!>           =0:  successful exit.
!>           <0:  if INFO = -i, the i-th argument had an illegal value.
!>           =1:  The transformed matrix pair (A, B) would be too far
!>                from generalized Schur form; the problem is ill-
!>                conditioned. (A, B) 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.
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.
!>

Definition at line 218 of file dtgexc.f.

220*
221* -- LAPACK computational routine --
222* -- LAPACK is a software package provided by Univ. of Tennessee, --
223* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
224*
225* .. Scalar Arguments ..
226 LOGICAL WANTQ, WANTZ
227 INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
228* ..
229* .. Array Arguments ..
230 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
231 $ WORK( * ), Z( LDZ, * )
232* ..
233*
234* =====================================================================
235*
236* .. Parameters ..
237 DOUBLE PRECISION ZERO
238 parameter( zero = 0.0d+0 )
239* ..
240* .. Local Scalars ..
241 LOGICAL LQUERY
242 INTEGER HERE, LWMIN, NBF, NBL, NBNEXT
243* ..
244* .. External Subroutines ..
245 EXTERNAL dtgex2, xerbla
246* ..
247* .. Intrinsic Functions ..
248 INTRINSIC max
249* ..
250* .. Executable Statements ..
251*
252* Decode and test input arguments.
253*
254 info = 0
255 lquery = ( lwork.EQ.-1 )
256 IF( n.LT.0 ) THEN
257 info = -3
258 ELSE IF( lda.LT.max( 1, n ) ) THEN
259 info = -5
260 ELSE IF( ldb.LT.max( 1, n ) ) THEN
261 info = -7
262 ELSE IF( ldq.LT.1 .OR. wantq .AND. ( ldq.LT.max( 1, n ) ) ) THEN
263 info = -9
264 ELSE IF( ldz.LT.1 .OR. wantz .AND. ( ldz.LT.max( 1, n ) ) ) THEN
265 info = -11
266 ELSE IF( ifst.LT.1 .OR. ifst.GT.n ) THEN
267 info = -12
268 ELSE IF( ilst.LT.1 .OR. ilst.GT.n ) THEN
269 info = -13
270 END IF
271*
272 IF( info.EQ.0 ) THEN
273 IF( n.LE.1 ) THEN
274 lwmin = 1
275 ELSE
276 lwmin = 4*n + 16
277 END IF
278 work(1) = lwmin
279*
280 IF (lwork.LT.lwmin .AND. .NOT.lquery) THEN
281 info = -15
282 END IF
283 END IF
284*
285 IF( info.NE.0 ) THEN
286 CALL xerbla( 'DTGEXC', -info )
287 RETURN
288 ELSE IF( lquery ) THEN
289 RETURN
290 END IF
291*
292* Quick return if possible
293*
294 IF( n.LE.1 )
295 $ RETURN
296*
297* Determine the first row of the specified block and find out
298* if it is 1-by-1 or 2-by-2.
299*
300 IF( ifst.GT.1 ) THEN
301 IF( a( ifst, ifst-1 ).NE.zero )
302 $ ifst = ifst - 1
303 END IF
304 nbf = 1
305 IF( ifst.LT.n ) THEN
306 IF( a( ifst+1, ifst ).NE.zero )
307 $ nbf = 2
308 END IF
309*
310* Determine the first row of the final block
311* and find out if it is 1-by-1 or 2-by-2.
312*
313 IF( ilst.GT.1 ) THEN
314 IF( a( ilst, ilst-1 ).NE.zero )
315 $ ilst = ilst - 1
316 END IF
317 nbl = 1
318 IF( ilst.LT.n ) THEN
319 IF( a( ilst+1, ilst ).NE.zero )
320 $ nbl = 2
321 END IF
322 IF( ifst.EQ.ilst )
323 $ RETURN
324*
325 IF( ifst.LT.ilst ) THEN
326*
327* Update ILST.
328*
329 IF( nbf.EQ.2 .AND. nbl.EQ.1 )
330 $ ilst = ilst - 1
331 IF( nbf.EQ.1 .AND. nbl.EQ.2 )
332 $ ilst = ilst + 1
333*
334 here = ifst
335*
336 10 CONTINUE
337*
338* Swap with next one below.
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+nbf+1.LE.n ) THEN
346 IF( a( here+nbf+1, here+nbf ).NE.zero )
347 $ nbnext = 2
348 END IF
349 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
350 $ ldz, here, nbf, nbnext, work, lwork, 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( a( 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+3.LE.n ) THEN
371 IF( a( here+3, here+2 ).NE.zero )
372 $ nbnext = 2
373 END IF
374 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
375 $ ldz, here+1, 1, nbnext, work, lwork, 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.
383*
384 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
385 $ ldz, here, 1, 1, work, lwork, info )
386 IF( info.NE.0 ) THEN
387 ilst = here
388 RETURN
389 END IF
390 here = here + 1
391*
392 ELSE
393*
394* Recompute NBNEXT in case of 2-by-2 split.
395*
396 IF( a( here+2, here+1 ).EQ.zero )
397 $ nbnext = 1
398 IF( nbnext.EQ.2 ) THEN
399*
400* 2-by-2 block did not split.
401*
402 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
403 $ z, ldz, here, 1, nbnext, work, lwork,
404 $ info )
405 IF( info.NE.0 ) THEN
406 ilst = here
407 RETURN
408 END IF
409 here = here + 2
410 ELSE
411*
412* 2-by-2 block did split.
413*
414 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
415 $ z, ldz, here, 1, 1, work, lwork, info )
416 IF( info.NE.0 ) THEN
417 ilst = here
418 RETURN
419 END IF
420 here = here + 1
421 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
422 $ z, ldz, here, 1, 1, work, lwork, info )
423 IF( info.NE.0 ) THEN
424 ilst = here
425 RETURN
426 END IF
427 here = here + 1
428 END IF
429*
430 END IF
431 END IF
432 IF( here.LT.ilst )
433 $ GO TO 10
434 ELSE
435 here = ifst
436*
437 20 CONTINUE
438*
439* Swap with next one below.
440*
441 IF( nbf.EQ.1 .OR. nbf.EQ.2 ) THEN
442*
443* Current block either 1-by-1 or 2-by-2.
444*
445 nbnext = 1
446 IF( here.GE.3 ) THEN
447 IF( a( here-1, here-2 ).NE.zero )
448 $ nbnext = 2
449 END IF
450 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
451 $ ldz, here-nbnext, nbnext, nbf, work, lwork,
452 $ info )
453 IF( info.NE.0 ) THEN
454 ilst = here
455 RETURN
456 END IF
457 here = here - nbnext
458*
459* Test if 2-by-2 block breaks into two 1-by-1 blocks.
460*
461 IF( nbf.EQ.2 ) THEN
462 IF( a( here+1, here ).EQ.zero )
463 $ nbf = 3
464 END IF
465*
466 ELSE
467*
468* Current block consists of two 1-by-1 blocks, each of which
469* must be swapped individually.
470*
471 nbnext = 1
472 IF( here.GE.3 ) THEN
473 IF( a( here-1, here-2 ).NE.zero )
474 $ nbnext = 2
475 END IF
476 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
477 $ ldz, here-nbnext, nbnext, 1, work, lwork,
478 $ info )
479 IF( info.NE.0 ) THEN
480 ilst = here
481 RETURN
482 END IF
483 IF( nbnext.EQ.1 ) THEN
484*
485* Swap two 1-by-1 blocks.
486*
487 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,
488 $ ldz, here, nbnext, 1, work, lwork, info )
489 IF( info.NE.0 ) THEN
490 ilst = here
491 RETURN
492 END IF
493 here = here - 1
494 ELSE
495*
496* Recompute NBNEXT in case of 2-by-2 split.
497*
498 IF( a( here, here-1 ).EQ.zero )
499 $ nbnext = 1
500 IF( nbnext.EQ.2 ) THEN
501*
502* 2-by-2 block did not split.
503*
504 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
505 $ z, ldz, here-1, 2, 1, work, lwork, info )
506 IF( info.NE.0 ) THEN
507 ilst = here
508 RETURN
509 END IF
510 here = here - 2
511 ELSE
512*
513* 2-by-2 block did split.
514*
515 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
516 $ z, ldz, here, 1, 1, work, lwork, info )
517 IF( info.NE.0 ) THEN
518 ilst = here
519 RETURN
520 END IF
521 here = here - 1
522 CALL dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,
523 $ z, ldz, here, 1, 1, work, lwork, info )
524 IF( info.NE.0 ) THEN
525 ilst = here
526 RETURN
527 END IF
528 here = here - 1
529 END IF
530 END IF
531 END IF
532 IF( here.GT.ilst )
533 $ GO TO 20
534 END IF
535 ilst = here
536 work( 1 ) = lwmin
537 RETURN
538*
539* End of DTGEXC
540*
dtgex2
subroutine dtgex2(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, j1, n1, n2, work, lwork, info)
DTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogonal equ...
Definition dtgex2.f:221

◆ sgelqt()

subroutine sgelqt ( integer m,
integer n,
integer mb,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldt, * ) t,
integer ldt,
real, dimension( * ) work,
integer info )

SGELQT

Purpose:
!>
!> DGELQT computes a blocked LQ factorization of a real M-by-N matrix A
!> using the compact WY representation of Q.
!>
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]MB
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.  MIN(M,N) >= MB >= 1.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the M-by-MIN(M,N) lower trapezoidal matrix L (L is
!>          lower triangular if M <= N); the elements above the diagonal
!>          are the rows of V.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is REAL array, dimension (LDT,MIN(M,N))
!>          The upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.  See below
!>          for further details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= MB.
!>
[out]WORK
!>          WORK is REAL array, dimension (MB*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 matrix V stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1  v1 v1 v1 v1 )
!>                   (     1  v2 v2 v2 )
!>                   (         1 v3 v3 )
!>
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.
!>  Let K=MIN(M,N).  The number of blocks is B = ceiling(K/MB), where each
!>  block is of order MB except for the last block, which is of order
!>  IB = K - (B-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-K matrix T as
!>
!>               T = (T1 T2 ... TB).
!>

Definition at line 123 of file sgelqt.f.

124*
125* -- LAPACK computational routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 INTEGER INFO, LDA, LDT, M, N, MB
131* ..
132* .. Array Arguments ..
133 REAL A( LDA, * ), T( LDT, * ), WORK( * )
134* ..
135*
136* =====================================================================
137*
138* ..
139* .. Local Scalars ..
140 INTEGER I, IB, IINFO, K
141* ..
142* .. External Subroutines ..
143 EXTERNAL sgeqrt2, sgeqrt3, sgelqt3, slarfb, xerbla
144* ..
145* .. Executable Statements ..
146*
147* Test the input arguments
148*
149 info = 0
150 IF( m.LT.0 ) THEN
151 info = -1
152 ELSE IF( n.LT.0 ) THEN
153 info = -2
154 ELSE IF( mb.LT.1 .OR. ( mb.GT.min(m,n) .AND. min(m,n).GT.0 ) )THEN
155 info = -3
156 ELSE IF( lda.LT.max( 1, m ) ) THEN
157 info = -5
158 ELSE IF( ldt.LT.mb ) THEN
159 info = -7
160 END IF
161 IF( info.NE.0 ) THEN
162 CALL xerbla( 'SGELQT', -info )
163 RETURN
164 END IF
165*
166* Quick return if possible
167*
168 k = min( m, n )
169 IF( k.EQ.0 ) RETURN
170*
171* Blocked loop of length K
172*
173 DO i = 1, k, mb
174 ib = min( k-i+1, mb )
175*
176* Compute the LQ factorization of the current block A(I:M,I:I+IB-1)
177*
178 CALL sgelqt3( ib, n-i+1, a(i,i), lda, t(1,i), ldt, iinfo )
179 IF( i+ib.LE.m ) THEN
180*
181* Update by applying H**T to A(I:M,I+IB:N) from the right
182*
183 CALL slarfb( 'R', 'N', 'F', 'R', m-i-ib+1, n-i+1, ib,
184 $ a( i, i ), lda, t( 1, i ), ldt,
185 $ a( i+ib, i ), lda, work , m-i-ib+1 )
186 END IF
187 END DO
188 RETURN
189*
190* End of SGELQT
191*
sgelqt3
recursive subroutine sgelqt3(m, n, a, lda, t, ldt, info)
SGELQT3
Definition sgelqt3.f:116
sgeqrt3
recursive subroutine sgeqrt3(m, n, a, lda, t, ldt, info)
SGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact...
Definition sgeqrt3.f:132
sgeqrt2
subroutine sgeqrt2(m, n, a, lda, t, ldt, info)
SGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY represen...
Definition sgeqrt2.f:127
slarfb
subroutine slarfb(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
SLARFB applies a block reflector or its transpose to a general rectangular matrix.
Definition slarfb.f:197

◆ sgelqt3()

recursive subroutine sgelqt3 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldt, * ) t,
integer ldt,
integer info )

SGELQT3

Purpose:
!>
!> SGELQT3 recursively computes a LQ factorization of a real M-by-N
!> matrix A, using the compact WY representation of Q.
!>
!> Based on the algorithm of Elmroth and Gustavson,
!> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M =< N.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the real M-by-N matrix A.  On exit, the elements on and
!>          below the diagonal contain the N-by-N lower triangular matrix L; the
!>          elements above the diagonal are the rows of V.  See below for
!>          further details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is REAL array, dimension (LDT,N)
!>          The N-by-N upper triangular factor of the block reflector.
!>          The elements on and above the diagonal contain the block
!>          reflector T; the elements below the diagonal are not used.
!>          See below for 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 matrix V stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1  v1 v1 v1 v1 )
!>                   (     1  v2 v2 v2 )
!>                   (     1  v3 v3 v3 )
!>
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.  The
!>  block reflector H is then given by
!>
!>               H = I - V * T * V**T
!>
!>  where V**T is the transpose of V.
!>
!>  For details of the algorithm, see Elmroth and Gustavson (cited above).
!>

Definition at line 115 of file sgelqt3.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 INTEGER INFO, LDA, M, N, LDT
123* ..
124* .. Array Arguments ..
125 REAL A( LDA, * ), T( LDT, * )
126* ..
127*
128* =====================================================================
129*
130* .. Parameters ..
131 REAL ONE
132 parameter( one = 1.0e+00 )
133* ..
134* .. Local Scalars ..
135 INTEGER I, I1, J, J1, M1, M2, IINFO
136* ..
137* .. External Subroutines ..
138 EXTERNAL slarfg, strmm, sgemm, xerbla
139* ..
140* .. Executable Statements ..
141*
142 info = 0
143 IF( m .LT. 0 ) THEN
144 info = -1
145 ELSE IF( n .LT. m ) THEN
146 info = -2
147 ELSE IF( lda .LT. max( 1, m ) ) THEN
148 info = -4
149 ELSE IF( ldt .LT. max( 1, m ) ) THEN
150 info = -6
151 END IF
152 IF( info.NE.0 ) THEN
153 CALL xerbla( 'SGELQT3', -info )
154 RETURN
155 END IF
156*
157 IF( m.EQ.1 ) THEN
158*
159* Compute Householder transform when M=1
160*
161 CALL slarfg( n, a, a( 1, min( 2, n ) ), lda, t )
162*
163 ELSE
164*
165* Otherwise, split A into blocks...
166*
167 m1 = m/2
168 m2 = m-m1
169 i1 = min( m1+1, m )
170 j1 = min( m+1, n )
171*
172* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
173*
174 CALL sgelqt3( m1, n, a, lda, t, ldt, iinfo )
175*
176* Compute A(J1:M,1:N) = Q1^H A(J1:M,1:N) [workspace: T(1:N1,J1:N)]
177*
178 DO i=1,m2
179 DO j=1,m1
180 t( i+m1, j ) = a( i+m1, j )
181 END DO
182 END DO
183 CALL strmm( 'R', 'U', 'T', 'U', m2, m1, one,
184 & a, lda, t( i1, 1 ), ldt )
185*
186 CALL sgemm( 'N', 'T', m2, m1, n-m1, one, a( i1, i1 ), lda,
187 & a( 1, i1 ), lda, one, t( i1, 1 ), ldt)
188*
189 CALL strmm( 'R', 'U', 'N', 'N', m2, m1, one,
190 & t, ldt, t( i1, 1 ), ldt )
191*
192 CALL sgemm( 'N', 'N', m2, n-m1, m1, -one, t( i1, 1 ), ldt,
193 & a( 1, i1 ), lda, one, a( i1, i1 ), lda )
194*
195 CALL strmm( 'R', 'U', 'N', 'U', m2, m1 , one,
196 & a, lda, t( i1, 1 ), ldt )
197*
198 DO i=1,m2
199 DO j=1,m1
200 a( i+m1, j ) = a( i+m1, j ) - t( i+m1, j )
201 t( i+m1, j )=0
202 END DO
203 END DO
204*
205* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
206*
207 CALL sgelqt3( m2, n-m1, a( i1, i1 ), lda,
208 & t( i1, i1 ), ldt, iinfo )
209*
210* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2
211*
212 DO i=1,m2
213 DO j=1,m1
214 t( j, i+m1 ) = (a( j, i+m1 ))
215 END DO
216 END DO
217*
218 CALL strmm( 'R', 'U', 'T', 'U', m1, m2, one,
219 & a( i1, i1 ), lda, t( 1, i1 ), ldt )
220*
221 CALL sgemm( 'N', 'T', m1, m2, n-m, one, a( 1, j1 ), lda,
222 & a( i1, j1 ), lda, one, t( 1, i1 ), ldt )
223*
224 CALL strmm( 'L', 'U', 'N', 'N', m1, m2, -one, t, ldt,
225 & t( 1, i1 ), ldt )
226*
227 CALL strmm( 'R', 'U', 'N', 'N', m1, m2, one,
228 & t( i1, i1 ), ldt, t( 1, i1 ), ldt )
229*
230*
231*
232* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3]
233* [ A(1:N1,J1:N) L2 ] [ 0 T2]
234*
235 END IF
236*
237 RETURN
238*
239* End of SGELQT3
240*
slarfg
subroutine slarfg(n, alpha, x, incx, tau)
SLARFG generates an elementary reflector (Householder matrix).
Definition slarfg.f:106
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187
strmm
subroutine strmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRMM
Definition strmm.f:177

◆ sgemlqt()

subroutine sgemlqt ( character side,
character trans,
integer m,
integer n,
integer k,
integer mb,
real, dimension( ldv, * ) v,
integer ldv,
real, dimension( ldt, * ) t,
integer ldt,
real, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) work,
integer info )

SGEMLQT

Purpose:
!>
!> DGEMLQT 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) = I - V T V**T
!>
!> generated using the compact WY representation as returned by SGELQT.
!>
!> 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;
!>          = 'C':  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]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 SGELQT.
!>
[in]V
!>          V is REAL array, dimension
!>                               (LDV,M) if SIDE = 'L',
!>                               (LDV,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
!>          SGELQT in the first K rows of its array argument A.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= max(1,K).
!>
[in]T
!>          T is REAL array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by SGELQT, stored as a MB-by-K matrix.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= MB.
!>
[in,out]C
!>          C is REAL array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q C, Q**T C, C Q**T or C Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is REAL array. 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.

Definition at line 151 of file sgemlqt.f.

153*
154* -- LAPACK computational routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
161* ..
162* .. Array Arguments ..
163 REAL V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
164* ..
165*
166* =====================================================================
167*
168* ..
169* .. Local Scalars ..
170 LOGICAL LEFT, RIGHT, TRAN, NOTRAN
171 INTEGER I, IB, LDWORK, KF, Q
172* ..
173* .. External Functions ..
174 LOGICAL LSAME
175 EXTERNAL lsame
176* ..
177* .. External Subroutines ..
178 EXTERNAL xerbla, slarfb
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC max, min
182* ..
183* .. Executable Statements ..
184*
185* .. Test the input arguments ..
186*
187 info = 0
188 left = lsame( side, 'L' )
189 right = lsame( side, 'R' )
190 tran = lsame( trans, 'T' )
191 notran = lsame( trans, 'N' )
192*
193 IF( left ) THEN
194 ldwork = max( 1, n )
195 q = m
196 ELSE IF ( right ) THEN
197 ldwork = max( 1, m )
198 q = n
199 END IF
200 IF( .NOT.left .AND. .NOT.right ) THEN
201 info = -1
202 ELSE IF( .NOT.tran .AND. .NOT.notran ) THEN
203 info = -2
204 ELSE IF( m.LT.0 ) THEN
205 info = -3
206 ELSE IF( n.LT.0 ) THEN
207 info = -4
208 ELSE IF( k.LT.0 .OR. k.GT.q ) THEN
209 info = -5
210 ELSE IF( mb.LT.1 .OR. (mb.GT.k .AND. k.GT.0)) THEN
211 info = -6
212 ELSE IF( ldv.LT.max( 1, k ) ) THEN
213 info = -8
214 ELSE IF( ldt.LT.mb ) THEN
215 info = -10
216 ELSE IF( ldc.LT.max( 1, m ) ) THEN
217 info = -12
218 END IF
219*
220 IF( info.NE.0 ) THEN
221 CALL xerbla( 'SGEMLQT', -info )
222 RETURN
223 END IF
224*
225* .. Quick return if possible ..
226*
227 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) RETURN
228*
229 IF( left .AND. notran ) THEN
230*
231 DO i = 1, k, mb
232 ib = min( mb, k-i+1 )
233 CALL slarfb( 'L', 'T', 'F', 'R', m-i+1, n, ib,
234 $ v( i, i ), ldv, t( 1, i ), ldt,
235 $ c( i, 1 ), ldc, work, ldwork )
236 END DO
237*
238 ELSE IF( right .AND. tran ) THEN
239*
240 DO i = 1, k, mb
241 ib = min( mb, k-i+1 )
242 CALL slarfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,
243 $ v( i, i ), ldv, t( 1, i ), ldt,
244 $ c( 1, i ), ldc, work, ldwork )
245 END DO
246*
247 ELSE IF( left .AND. tran ) THEN
248*
249 kf = ((k-1)/mb)*mb+1
250 DO i = kf, 1, -mb
251 ib = min( mb, k-i+1 )
252 CALL slarfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,
253 $ v( i, i ), ldv, t( 1, i ), ldt,
254 $ c( i, 1 ), ldc, work, ldwork )
255 END DO
256*
257 ELSE IF( right .AND. notran ) THEN
258*
259 kf = ((k-1)/mb)*mb+1
260 DO i = kf, 1, -mb
261 ib = min( mb, k-i+1 )
262 CALL slarfb( 'R', 'T', 'F', 'R', m, n-i+1, ib,
263 $ v( i, i ), ldv, t( 1, i ), ldt,
264 $ c( 1, i ), ldc, work, ldwork )
265 END DO
266*
267 END IF
268*
269 RETURN
270*
271* End of SGEMLQT
272*

◆ slaqz0()

recursive subroutine slaqz0 ( character, intent(in) wants,
character, intent(in) wantq,
character, intent(in) wantz,
integer, intent(in) n,
integer, intent(in) ilo,
integer, intent(in) ihi,
real, dimension( lda, * ), intent(inout) a,
integer, intent(in) lda,
real, dimension( ldb, * ), intent(inout) b,
integer, intent(in) ldb,
real, dimension( * ), intent(inout) alphar,
real, dimension( * ), intent(inout) alphai,
real, dimension( * ), intent(inout) beta,
real, dimension( ldq, * ), intent(inout) q,
integer, intent(in) ldq,
real, dimension( ldz, * ), intent(inout) z,
integer, intent(in) ldz,
real, dimension( * ), intent(inout) work,
integer, intent(in) lwork,
integer, intent(in) rec,
integer, intent(out) info )

SLAQZ0

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

Purpose:
!>
!> SLAQZ0 computes the eigenvalues of a real matrix pair (H,T),
!> where H is an upper Hessenberg matrix and T is upper triangular,
!> using the double-shift QZ method.
!> Matrix pairs of this type are produced by the reduction to
!> generalized upper Hessenberg form of a real matrix pair (A,B):
!>
!>    A = Q1*H*Z1**T,  B = Q1*T*Z1**T,
!>
!> as computed by SGGHRD.
!>
!> If JOB='S', then the Hessenberg-triangular pair (H,T) is
!> also reduced to generalized Schur form,
!>
!>    H = Q*S*Z**T,  T = Q*P*Z**T,
!>
!> where Q and Z are orthogonal matrices, P is an upper triangular
!> matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
!> diagonal blocks.
!>
!> The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
!> (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
!> eigenvalues.
!>
!> Additionally, the 2-by-2 upper triangular diagonal blocks of P
!> corresponding to 2-by-2 blocks of S are reduced to positive diagonal
!> form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
!> P(j,j) > 0, and P(j+1,j+1) > 0.
!>
!> Optionally, the orthogonal matrix Q from the generalized Schur
!> factorization may be postmultiplied into an input matrix Q1, and the
!> orthogonal matrix Z may be postmultiplied into an input matrix Z1.
!> If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced
!> the matrix pair (A,B) to generalized upper Hessenberg form, then the
!> output matrices Q1*Q and Z1*Z are the orthogonal factors from the
!> generalized Schur factorization of (A,B):
!>
!>    A = (Q1*Q)*S*(Z1*Z)**T,  B = (Q1*Q)*P*(Z1*Z)**T.
!>
!> To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
!> of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
!> complex and beta real.
!> If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
!> generalized nonsymmetric eigenvalue problem (GNEP)
!>    A*x = lambda*B*x
!> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
!> alternate form of the GNEP
!>    mu*A*y = B*y.
!> Real eigenvalues can be read directly from the generalized Schur
!> form:
!>   alpha = S(i,i), beta = P(i,i).
!>
!> Ref: C.B. Moler & G.W. Stewart, , SIAM J. Numer. Anal., 10(1973),
!>      pp. 241--256.
!>
!> Ref: B. Kagstrom, D. Kressner, , SIAM J. Numer.
!>      Anal., 29(2006), pp. 199--227.
!>
!> Ref: T. Steel, D. Camps, K. Meerbergen, R. Vandebril 
!>
Parameters
[in]WANTS
!>          WANTS is CHARACTER*1
!>          = 'E': Compute eigenvalues only;
!>          = 'S': Compute eigenvalues and the Schur form.
!>
[in]WANTQ
!>          WANTQ is CHARACTER*1
!>          = 'N': Left Schur vectors (Q) are not computed;
!>          = 'I': Q is initialized to the unit matrix and the matrix Q
!>                 of left Schur vectors of (A,B) is returned;
!>          = 'V': Q must contain an orthogonal matrix Q1 on entry and
!>                 the product Q1*Q is returned.
!>
[in]WANTZ
!>          WANTZ is CHARACTER*1
!>          = 'N': Right Schur vectors (Z) are not computed;
!>          = 'I': Z is initialized to the unit matrix and the matrix Z
!>                 of right Schur vectors of (A,B) 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, B, Q, and Z.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>          ILO and IHI mark the rows and columns of A which are in
!>          Hessenberg form.  It is assumed that A is already upper
!>          triangular in rows and columns 1:ILO-1 and IHI+1:N.
!>          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA, N)
!>          On entry, the N-by-N upper Hessenberg matrix A.
!>          On exit, if JOB = 'S', A contains the upper quasi-triangular
!>          matrix S from the generalized Schur factorization.
!>          If JOB = 'E', the diagonal blocks of A match those of S, but
!>          the rest of A is unspecified.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max( 1, N ).
!>
[in,out]B
!>          B is REAL array, dimension (LDB, N)
!>          On entry, the N-by-N upper triangular matrix B.
!>          On exit, if JOB = 'S', B contains the upper triangular
!>          matrix P from the generalized Schur factorization;
!>          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
!>          are reduced to positive diagonal form, i.e., if A(j+1,j) is
!>          non-zero, then B(j+1,j) = B(j,j+1) = 0, B(j,j) > 0, and
!>          B(j+1,j+1) > 0.
!>          If JOB = 'E', the diagonal blocks of B match those of P, but
!>          the rest of B is unspecified.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max( 1, N ).
!>
[out]ALPHAR
!>          ALPHAR is REAL array, dimension (N)
!>          The real parts of each scalar alpha defining an eigenvalue
!>          of GNEP.
!>
[out]ALPHAI
!>          ALPHAI is REAL array, dimension (N)
!>          The imaginary parts of each scalar alpha defining an
!>          eigenvalue of GNEP.
!>          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) = -ALPHAI(j).
!>
[out]BETA
!>          BETA is REAL array, dimension (N)
!>          The scalars beta that define the eigenvalues of GNEP.
!>          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
!>          beta = BETA(j) represent the j-th eigenvalue of the matrix
!>          pair (A,B), in one of the forms lambda = alpha/beta or
!>          mu = beta/alpha.  Since either lambda or mu may overflow,
!>          they should not, in general, be computed.
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in
!>          the reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPQ = 'I', the orthogonal matrix of left Schur
!>          vectors of (A,B), and if COMPQ = 'V', the orthogonal matrix
!>          of left Schur vectors of (A,B).
!>          Not referenced if COMPQ = 'N'.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= 1.
!>          If COMPQ='V' or 'I', then LDQ >= N.
!>
[in,out]Z
!>          Z is REAL array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
!>          the reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPZ = 'I', the orthogonal matrix of
!>          right Schur vectors of (H,T), and if COMPZ = 'V', the
!>          orthogonal matrix of right Schur vectors of (A,B).
!>          Not referenced if COMPZ = 'N'.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1.
!>          If COMPZ='V' or 'I', then LDZ >= N.
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>
!>          If 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.
!>
[in]REC
!>          REC is INTEGER
!>             REC indicates the current recursion level. Should be set
!>             to 0 on first call.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          = 1,...,N: the QZ iteration did not converge.  (A,B) is not
!>                     in Schur form, but ALPHAR(i), ALPHAI(i), and
!>                     BETA(i), i=INFO+1,...,N should be correct.
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 300 of file slaqz0.f.

304 IMPLICIT NONE
305
306* Arguments
307 CHARACTER, INTENT( IN ) :: WANTS, WANTQ, WANTZ
308 INTEGER, INTENT( IN ) :: N, ILO, IHI, LDA, LDB, LDQ, LDZ, LWORK,
309 $ REC
310
311 INTEGER, INTENT( OUT ) :: INFO
312
313 REAL, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
314 $ Z( LDZ, * ), ALPHAR( * ), ALPHAI( * ), BETA( * ), WORK( * )
315
316* Parameters
317 REAL :: ZERO, ONE, HALF
318 parameter( zero = 0.0, one = 1.0, half = 0.5 )
319
320* Local scalars
321 REAL :: SMLNUM, ULP, ESHIFT, SAFMIN, SAFMAX, C1, S1, TEMP, SWAP
322 INTEGER :: ISTART, ISTOP, IITER, MAXIT, ISTART2, K, LD, NSHIFTS,
323 $ NBLOCK, NW, NMIN, NIBBLE, N_UNDEFLATED, N_DEFLATED,
324 $ NS, SWEEP_INFO, SHIFTPOS, LWORKREQ, K2, ISTARTM,
325 $ ISTOPM, IWANTS, IWANTQ, IWANTZ, NORM_INFO, AED_INFO,
326 $ NWR, NBR, NSR, ITEMP1, ITEMP2, RCOST, I
327 LOGICAL :: ILSCHUR, ILQ, ILZ
328 CHARACTER :: JBCMPZ*3
329
330* External Functions
331 EXTERNAL :: xerbla, shgeqz, slaqz3, slaqz4, slaset, slabad,
332 $ slartg, srot
333 REAL, EXTERNAL :: SLAMCH
334 LOGICAL, EXTERNAL :: LSAME
335 INTEGER, EXTERNAL :: ILAENV
336
337*
338* Decode wantS,wantQ,wantZ
339*
340 IF( lsame( wants, 'E' ) ) THEN
341 ilschur = .false.
342 iwants = 1
343 ELSE IF( lsame( wants, 'S' ) ) THEN
344 ilschur = .true.
345 iwants = 2
346 ELSE
347 iwants = 0
348 END IF
349
350 IF( lsame( wantq, 'N' ) ) THEN
351 ilq = .false.
352 iwantq = 1
353 ELSE IF( lsame( wantq, 'V' ) ) THEN
354 ilq = .true.
355 iwantq = 2
356 ELSE IF( lsame( wantq, 'I' ) ) THEN
357 ilq = .true.
358 iwantq = 3
359 ELSE
360 iwantq = 0
361 END IF
362
363 IF( lsame( wantz, 'N' ) ) THEN
364 ilz = .false.
365 iwantz = 1
366 ELSE IF( lsame( wantz, 'V' ) ) THEN
367 ilz = .true.
368 iwantz = 2
369 ELSE IF( lsame( wantz, 'I' ) ) THEN
370 ilz = .true.
371 iwantz = 3
372 ELSE
373 iwantz = 0
374 END IF
375*
376* Check Argument Values
377*
378 info = 0
379 IF( iwants.EQ.0 ) THEN
380 info = -1
381 ELSE IF( iwantq.EQ.0 ) THEN
382 info = -2
383 ELSE IF( iwantz.EQ.0 ) THEN
384 info = -3
385 ELSE IF( n.LT.0 ) THEN
386 info = -4
387 ELSE IF( ilo.LT.1 ) THEN
388 info = -5
389 ELSE IF( ihi.GT.n .OR. ihi.LT.ilo-1 ) THEN
390 info = -6
391 ELSE IF( lda.LT.n ) THEN
392 info = -8
393 ELSE IF( ldb.LT.n ) THEN
394 info = -10
395 ELSE IF( ldq.LT.1 .OR. ( ilq .AND. ldq.LT.n ) ) THEN
396 info = -15
397 ELSE IF( ldz.LT.1 .OR. ( ilz .AND. ldz.LT.n ) ) THEN
398 info = -17
399 END IF
400 IF( info.NE.0 ) THEN
401 CALL xerbla( 'SLAQZ0', -info )
402 RETURN
403 END IF
404
405*
406* Quick return if possible
407*
408 IF( n.LE.0 ) THEN
409 work( 1 ) = real( 1 )
410 RETURN
411 END IF
412
413*
414* Get the parameters
415*
416 jbcmpz( 1:1 ) = wants
417 jbcmpz( 2:2 ) = wantq
418 jbcmpz( 3:3 ) = wantz
419
420 nmin = ilaenv( 12, 'SLAQZ0', jbcmpz, n, ilo, ihi, lwork )
421
422 nwr = ilaenv( 13, 'SLAQZ0', jbcmpz, n, ilo, ihi, lwork )
423 nwr = max( 2, nwr )
424 nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr )
425
426 nibble = ilaenv( 14, 'SLAQZ0', jbcmpz, n, ilo, ihi, lwork )
427
428 nsr = ilaenv( 15, 'SLAQZ0', jbcmpz, n, ilo, ihi, lwork )
429 nsr = min( nsr, ( n+6 ) / 9, ihi-ilo )
430 nsr = max( 2, nsr-mod( nsr, 2 ) )
431
432 rcost = ilaenv( 17, 'SLAQZ0', jbcmpz, n, ilo, ihi, lwork )
433 itemp1 = int( nsr/sqrt( 1+2*nsr/( real( rcost )/100*n ) ) )
434 itemp1 = ( ( itemp1-1 )/4 )*4+4
435 nbr = nsr+itemp1
436
437 IF( n .LT. nmin .OR. rec .GE. 2 ) THEN
438 CALL shgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,
439 $ alphar, alphai, beta, q, ldq, z, ldz, work,
440 $ lwork, info )
441 RETURN
442 END IF
443
444*
445* Find out required workspace
446*
447
448* Workspace query to slaqz3
449 nw = max( nwr, nmin )
450 CALL slaqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,
451 $ q, ldq, z, ldz, n_undeflated, n_deflated, alphar,
452 $ alphai, beta, work, nw, work, nw, work, -1, rec,
453 $ aed_info )
454 itemp1 = int( work( 1 ) )
455* Workspace query to slaqz4
456 CALL slaqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,
457 $ alphai, beta, a, lda, b, ldb, q, ldq, z, ldz, work,
458 $ nbr, work, nbr, work, -1, sweep_info )
459 itemp2 = int( work( 1 ) )
460
461 lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 )
462 IF ( lwork .EQ.-1 ) THEN
463 work( 1 ) = real( lworkreq )
464 RETURN
465 ELSE IF ( lwork .LT. lworkreq ) THEN
466 info = -19
467 END IF
468 IF( info.NE.0 ) THEN
469 CALL xerbla( 'SLAQZ0', info )
470 RETURN
471 END IF
472*
473* Initialize Q and Z
474*
475 IF( iwantq.EQ.3 ) CALL slaset( 'FULL', n, n, zero, one, q, ldq )
476 IF( iwantz.EQ.3 ) CALL slaset( 'FULL', n, n, zero, one, z, ldz )
477
478* Get machine constants
479 safmin = slamch( 'SAFE MINIMUM' )
480 safmax = one/safmin
481 CALL slabad( safmin, safmax )
482 ulp = slamch( 'PRECISION' )
483 smlnum = safmin*( real( n )/ulp )
484
485 istart = ilo
486 istop = ihi
487 maxit = 3*( ihi-ilo+1 )
488 ld = 0
489
490 DO iiter = 1, maxit
491 IF( iiter .GE. maxit ) THEN
492 info = istop+1
493 GOTO 80
494 END IF
495 IF ( istart+1 .GE. istop ) THEN
496 istop = istart
497 EXIT
498 END IF
499
500* Check deflations at the end
501 IF ( abs( a( istop-1, istop-2 ) ) .LE. max( smlnum,
502 $ ulp*( abs( a( istop-1, istop-1 ) )+abs( a( istop-2,
503 $ istop-2 ) ) ) ) ) THEN
504 a( istop-1, istop-2 ) = zero
505 istop = istop-2
506 ld = 0
507 eshift = zero
508 ELSE IF ( abs( a( istop, istop-1 ) ) .LE. max( smlnum,
509 $ ulp*( abs( a( istop, istop ) )+abs( a( istop-1,
510 $ istop-1 ) ) ) ) ) THEN
511 a( istop, istop-1 ) = zero
512 istop = istop-1
513 ld = 0
514 eshift = zero
515 END IF
516* Check deflations at the start
517 IF ( abs( a( istart+2, istart+1 ) ) .LE. max( smlnum,
518 $ ulp*( abs( a( istart+1, istart+1 ) )+abs( a( istart+2,
519 $ istart+2 ) ) ) ) ) THEN
520 a( istart+2, istart+1 ) = zero
521 istart = istart+2
522 ld = 0
523 eshift = zero
524 ELSE IF ( abs( a( istart+1, istart ) ) .LE. max( smlnum,
525 $ ulp*( abs( a( istart, istart ) )+abs( a( istart+1,
526 $ istart+1 ) ) ) ) ) THEN
527 a( istart+1, istart ) = zero
528 istart = istart+1
529 ld = 0
530 eshift = zero
531 END IF
532
533 IF ( istart+1 .GE. istop ) THEN
534 EXIT
535 END IF
536
537* Check interior deflations
538 istart2 = istart
539 DO k = istop, istart+1, -1
540 IF ( abs( a( k, k-1 ) ) .LE. max( smlnum, ulp*( abs( a( k,
541 $ k ) )+abs( a( k-1, k-1 ) ) ) ) ) THEN
542 a( k, k-1 ) = zero
543 istart2 = k
544 EXIT
545 END IF
546 END DO
547
548* Get range to apply rotations to
549 IF ( ilschur ) THEN
550 istartm = 1
551 istopm = n
552 ELSE
553 istartm = istart2
554 istopm = istop
555 END IF
556
557* Check infinite eigenvalues, this is done without blocking so might
558* slow down the method when many infinite eigenvalues are present
559 k = istop
560 DO WHILE ( k.GE.istart2 )
561 temp = zero
562 IF( k .LT. istop ) THEN
563 temp = temp+abs( b( k, k+1 ) )
564 END IF
565 IF( k .GT. istart2 ) THEN
566 temp = temp+abs( b( k-1, k ) )
567 END IF
568
569 IF( abs( b( k, k ) ) .LT. max( smlnum, ulp*temp ) ) THEN
570* A diagonal element of B is negligable, move it
571* to the top and deflate it
572
573 DO k2 = k, istart2+1, -1
574 CALL slartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,
575 $ temp )
576 b( k2-1, k2 ) = temp
577 b( k2-1, k2-1 ) = zero
578
579 CALL srot( k2-2-istartm+1, b( istartm, k2 ), 1,
580 $ b( istartm, k2-1 ), 1, c1, s1 )
581 CALL srot( min( k2+1, istop )-istartm+1, a( istartm,
582 $ k2 ), 1, a( istartm, k2-1 ), 1, c1, s1 )
583 IF ( ilz ) THEN
584 CALL srot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,
585 $ s1 )
586 END IF
587
588 IF( k2.LT.istop ) THEN
589 CALL slartg( a( k2, k2-1 ), a( k2+1, k2-1 ), c1,
590 $ s1, temp )
591 a( k2, k2-1 ) = temp
592 a( k2+1, k2-1 ) = zero
593
594 CALL srot( istopm-k2+1, a( k2, k2 ), lda, a( k2+1,
595 $ k2 ), lda, c1, s1 )
596 CALL srot( istopm-k2+1, b( k2, k2 ), ldb, b( k2+1,
597 $ k2 ), ldb, c1, s1 )
598 IF( ilq ) THEN
599 CALL srot( n, q( 1, k2 ), 1, q( 1, k2+1 ), 1,
600 $ c1, s1 )
601 END IF
602 END IF
603
604 END DO
605
606 IF( istart2.LT.istop )THEN
607 CALL slartg( a( istart2, istart2 ), a( istart2+1,
608 $ istart2 ), c1, s1, temp )
609 a( istart2, istart2 ) = temp
610 a( istart2+1, istart2 ) = zero
611
612 CALL srot( istopm-( istart2+1 )+1, a( istart2,
613 $ istart2+1 ), lda, a( istart2+1,
614 $ istart2+1 ), lda, c1, s1 )
615 CALL srot( istopm-( istart2+1 )+1, b( istart2,
616 $ istart2+1 ), ldb, b( istart2+1,
617 $ istart2+1 ), ldb, c1, s1 )
618 IF( ilq ) THEN
619 CALL srot( n, q( 1, istart2 ), 1, q( 1,
620 $ istart2+1 ), 1, c1, s1 )
621 END IF
622 END IF
623
624 istart2 = istart2+1
625
626 END IF
627 k = k-1
628 END DO
629
630* istart2 now points to the top of the bottom right
631* unreduced Hessenberg block
632 IF ( istart2 .GE. istop ) THEN
633 istop = istart2-1
634 ld = 0
635 eshift = zero
636 cycle
637 END IF
638
639 nw = nwr
640 nshifts = nsr
641 nblock = nbr
642
643 IF ( istop-istart2+1 .LT. nmin ) THEN
644* Setting nw to the size of the subblock will make AED deflate
645* all the eigenvalues. This is slightly more efficient than just
646* using qz_small because the off diagonal part gets updated via BLAS.
647 IF ( istop-istart+1 .LT. nmin ) THEN
648 nw = istop-istart+1
649 istart2 = istart
650 ELSE
651 nw = istop-istart2+1
652 END IF
653 END IF
654
655*
656* Time for AED
657*
658 CALL slaqz3( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,
659 $ b, ldb, q, ldq, z, ldz, n_undeflated, n_deflated,
660 $ alphar, alphai, beta, work, nw, work( nw**2+1 ),
661 $ nw, work( 2*nw**2+1 ), lwork-2*nw**2, rec,
662 $ aed_info )
663
664 IF ( n_deflated > 0 ) THEN
665 istop = istop-n_deflated
666 ld = 0
667 eshift = zero
668 END IF
669
670 IF ( 100*n_deflated > nibble*( n_deflated+n_undeflated ) .OR.
671 $ istop-istart2+1 .LT. nmin ) THEN
672* AED has uncovered many eigenvalues. Skip a QZ sweep and run
673* AED again.
674 cycle
675 END IF
676
677 ld = ld+1
678
679 ns = min( nshifts, istop-istart2 )
680 ns = min( ns, n_undeflated )
681 shiftpos = istop-n_deflated-n_undeflated+1
682*
683* Shuffle shifts to put double shifts in front
684* This ensures that we don't split up a double shift
685*
686 DO i = shiftpos, shiftpos+n_undeflated-1, 2
687 IF( alphai( i ).NE.-alphai( i+1 ) ) THEN
688*
689 swap = alphar( i )
690 alphar( i ) = alphar( i+1 )
691 alphar( i+1 ) = alphar( i+2 )
692 alphar( i+2 ) = swap
693
694 swap = alphai( i )
695 alphai( i ) = alphai( i+1 )
696 alphai( i+1 ) = alphai( i+2 )
697 alphai( i+2 ) = swap
698
699 swap = beta( i )
700 beta( i ) = beta( i+1 )
701 beta( i+1 ) = beta( i+2 )
702 beta( i+2 ) = swap
703 END IF
704 END DO
705
706 IF ( mod( ld, 6 ) .EQ. 0 ) THEN
707*
708* Exceptional shift. Chosen for no particularly good reason.
709*
710 IF( ( real( maxit )*safmin )*abs( a( istop,
711 $ istop-1 ) ).LT.abs( a( istop-1, istop-1 ) ) ) THEN
712 eshift = a( istop, istop-1 )/b( istop-1, istop-1 )
713 ELSE
714 eshift = eshift+one/( safmin*real( maxit ) )
715 END IF
716 alphar( shiftpos ) = one
717 alphar( shiftpos+1 ) = zero
718 alphai( shiftpos ) = zero
719 alphai( shiftpos+1 ) = zero
720 beta( shiftpos ) = eshift
721 beta( shiftpos+1 ) = eshift
722 ns = 2
723 END IF
724
725*
726* Time for a QZ sweep
727*
728 CALL slaqz4( ilschur, ilq, ilz, n, istart2, istop, ns, nblock,
729 $ alphar( shiftpos ), alphai( shiftpos ),
730 $ beta( shiftpos ), a, lda, b, ldb, q, ldq, z, ldz,
731 $ work, nblock, work( nblock**2+1 ), nblock,
732 $ work( 2*nblock**2+1 ), lwork-2*nblock**2,
733 $ sweep_info )
734
735 END DO
736
737*
738* Call SHGEQZ to normalize the eigenvalue blocks and set the eigenvalues
739* If all the eigenvalues have been found, SHGEQZ will not do any iterations
740* and only normalize the blocks. In case of a rare convergence failure,
741* the single shift might perform better.
742*
743 80 CALL shgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,
744 $ alphar, alphai, beta, q, ldq, z, ldz, work, lwork,
745 $ norm_info )
746
747 info = norm_info
748
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74
slaset
subroutine slaset(uplo, m, n, alpha, beta, a, lda)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition slaset.f:110
slartg
subroutine slartg(f, g, c, s, r)
SLARTG generates a plane rotation with real cosine and real sine.
Definition slartg.f90:113
slaqz4
subroutine slaqz4(ilschur, ilq, ilz, n, ilo, ihi, nshifts, nblock_desired, sr, si, ss, a, lda, b, ldb, q, ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork, info)
SLAQZ4
Definition slaqz4.f:214
slaqz3
recursive subroutine slaqz3(ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb, q, ldq, z, ldz, ns, nd, alphar, alphai, beta, qc, ldqc, zc, ldzc, work, lwork, rec, info)
SLAQZ3
Definition slaqz3.f:238
shgeqz
subroutine shgeqz(job, compq, compz, n, ilo, ihi, h, ldh, t, ldt, alphar, alphai, beta, q, ldq, z, ldz, work, lwork, info)
SHGEQZ
Definition shgeqz.f:304
srot
subroutine srot(n, sx, incx, sy, incy, c, s)
SROT
Definition srot.f:92
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68

◆ slaqz1()

subroutine slaqz1 ( real, dimension( lda, * ), intent(in) a,
integer, intent(in) lda,
real, dimension( ldb, * ), intent(in) b,
integer, intent(in) ldb,
real, intent(in) sr1,
real, intent(in) sr2,
real, intent(in) si,
real, intent(in) beta1,
real, intent(in) beta2,
real, dimension( * ), intent(out) v )

SLAQZ1

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

Purpose:
!>
!>      Given a 3-by-3 matrix pencil (A,B), SLAQZ1 sets v to a
!>      scalar multiple of the first column of the product
!>
!>      (*)  K = (A - (beta2*sr2 - i*si)*B)*B^(-1)*(beta1*A - (sr2 + i*si2)*B)*B^(-1).
!>
!>      It is assumed that either
!>
!>              1) sr1 = sr2
!>          or
!>              2) si = 0.
!>
!>      This is useful for starting double implicit shift bulges
!>      in the QZ algorithm.
!>
Parameters
[in]A
!>          A is REAL array, dimension (LDA,N)
!>              The 3-by-3 matrix A in (*).
!>
[in]LDA
!>          LDA is INTEGER
!>              The leading dimension of A as declared in
!>              the calling procedure.
!>
[in]B
!>          B is REAL array, dimension (LDB,N)
!>              The 3-by-3 matrix B in (*).
!>
[in]LDB
!>          LDB is INTEGER
!>              The leading dimension of B as declared in
!>              the calling procedure.
!>
[in]SR1
!>          SR1 is REAL
!>
[in]SR2
!>          SR2 is REAL
!>
[in]SI
!>          SI is REAL
!>
[in]BETA1
!>          BETA1 is REAL
!>
[in]BETA2
!>          BETA2 is REAL
!>
[out]V
!>          V is REAL array, dimension (N)
!>              A scalar multiple of the first column of the
!>              matrix K in (*).
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 125 of file slaqz1.f.

127 IMPLICIT NONE
128*
129* Arguments
130 INTEGER, INTENT( IN ) :: LDA, LDB
131 REAL, INTENT( IN ) :: A( LDA, * ), B( LDB, * ), SR1, SR2, SI,
132 $ BETA1, BETA2
133 REAL, INTENT( OUT ) :: V( * )
134*
135* Parameters
136 REAL :: ZERO, ONE, HALF
137 parameter( zero = 0.0, one = 1.0, half = 0.5 )
138*
139* Local scalars
140 REAL :: W( 2 ), SAFMIN, SAFMAX, SCALE1, SCALE2
141*
142* External Functions
143 REAL, EXTERNAL :: SLAMCH
144 LOGICAL, EXTERNAL :: SISNAN
145*
146 safmin = slamch( 'SAFE MINIMUM' )
147 safmax = one/safmin
148*
149* Calculate first shifted vector
150*
151 w( 1 ) = beta1*a( 1, 1 )-sr1*b( 1, 1 )
152 w( 2 ) = beta1*a( 2, 1 )-sr1*b( 2, 1 )
153 scale1 = sqrt( abs( w( 1 ) ) ) * sqrt( abs( w( 2 ) ) )
154 IF( scale1 .GE. safmin .AND. scale1 .LE. safmax ) THEN
155 w( 1 ) = w( 1 )/scale1
156 w( 2 ) = w( 2 )/scale1
157 END IF
158*
159* Solve linear system
160*
161 w( 2 ) = w( 2 )/b( 2, 2 )
162 w( 1 ) = ( w( 1 )-b( 1, 2 )*w( 2 ) )/b( 1, 1 )
163 scale2 = sqrt( abs( w( 1 ) ) ) * sqrt( abs( w( 2 ) ) )
164 IF( scale2 .GE. safmin .AND. scale2 .LE. safmax ) THEN
165 w( 1 ) = w( 1 )/scale2
166 w( 2 ) = w( 2 )/scale2
167 END IF
168*
169* Apply second shift
170*
171 v( 1 ) = beta2*( a( 1, 1 )*w( 1 )+a( 1, 2 )*w( 2 ) )-sr2*( b( 1,
172 $ 1 )*w( 1 )+b( 1, 2 )*w( 2 ) )
173 v( 2 ) = beta2*( a( 2, 1 )*w( 1 )+a( 2, 2 )*w( 2 ) )-sr2*( b( 2,
174 $ 1 )*w( 1 )+b( 2, 2 )*w( 2 ) )
175 v( 3 ) = beta2*( a( 3, 1 )*w( 1 )+a( 3, 2 )*w( 2 ) )-sr2*( b( 3,
176 $ 1 )*w( 1 )+b( 3, 2 )*w( 2 ) )
177*
178* Account for imaginary part
179*
180 v( 1 ) = v( 1 )+si*si*b( 1, 1 )/scale1/scale2
181*
182* Check for overflow
183*
184 IF( abs( v( 1 ) ).GT.safmax .OR. abs( v( 2 ) ) .GT. safmax .OR.
185 $ abs( v( 3 ) ).GT.safmax .OR. sisnan( v( 1 ) ) .OR.
186 $ sisnan( v( 2 ) ) .OR. sisnan( v( 3 ) ) ) THEN
187 v( 1 ) = zero
188 v( 2 ) = zero
189 v( 3 ) = zero
190 END IF
191*
192* End of SLAQZ1
193*
sisnan
logical function sisnan(sin)
SISNAN tests input for NaN.
Definition sisnan.f:59

◆ slaqz2()

subroutine slaqz2 ( logical, intent(in) ilq,
logical, intent(in) ilz,
integer, intent(in) k,
integer, intent(in) istartm,
integer, intent(in) istopm,
integer, intent(in) ihi,
real, dimension( lda, * ) a,
integer, intent(in) lda,
real, dimension( ldb, * ) b,
integer, intent(in) ldb,
integer, intent(in) nq,
integer, intent(in) qstart,
real, dimension( ldq, * ) q,
integer, intent(in) ldq,
integer, intent(in) nz,
integer, intent(in) zstart,
real, dimension( ldz, * ) z,
integer, intent(in) ldz )

SLAQZ2

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

Purpose:
!>
!>      SLAQZ2 chases a 2x2 shift bulge in a matrix pencil down a single position
!>
Parameters
[in]ILQ
!>          ILQ is LOGICAL
!>              Determines whether or not to update the matrix Q
!>
[in]ILZ
!>          ILZ is LOGICAL
!>              Determines whether or not to update the matrix Z
!>
[in]K
!>          K is INTEGER
!>              Index indicating the position of the bulge.
!>              On entry, the bulge is located in
!>              (A(k+1:k+2,k:k+1),B(k+1:k+2,k:k+1)).
!>              On exit, the bulge is located in
!>              (A(k+2:k+3,k+1:k+2),B(k+2:k+3,k+1:k+2)).
!>
[in]ISTARTM
!>          ISTARTM is INTEGER
!>
[in]ISTOPM
!>          ISTOPM is INTEGER
!>              Updates to (A,B) are restricted to
!>              (istartm:k+3,k:istopm). It is assumed
!>              without checking that istartm <= k+1 and
!>              k+2 <= istopm
!>
[in]IHI
!>          IHI is INTEGER
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>
[in]LDA
!>          LDA is INTEGER
!>              The leading dimension of A as declared in
!>              the calling procedure.
!>
[in,out]B
!>          B is REAL array, dimension (LDB,N)
!>
[in]LDB
!>          LDB is INTEGER
!>              The leading dimension of B as declared in
!>              the calling procedure.
!>
[in]NQ
!>          NQ is INTEGER
!>              The order of the matrix Q
!>
[in]QSTART
!>          QSTART is INTEGER
!>              Start index of the matrix Q. Rotations are applied
!>              To columns k+2-qStart:k+4-qStart of Q.
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ,NQ)
!>
[in]LDQ
!>          LDQ is INTEGER
!>              The leading dimension of Q as declared in
!>              the calling procedure.
!>
[in]NZ
!>          NZ is INTEGER
!>              The order of the matrix Z
!>
[in]ZSTART
!>          ZSTART is INTEGER
!>              Start index of the matrix Z. Rotations are applied
!>              To columns k+1-qStart:k+3-qStart of Z.
!>
[in,out]Z
!>          Z is REAL array, dimension (LDZ,NZ)
!>
[in]LDZ
!>          LDZ is INTEGER
!>              The leading dimension of Q as declared in
!>              the calling procedure.
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 171 of file slaqz2.f.

173 IMPLICIT NONE
174*
175* Arguments
176 LOGICAL, INTENT( IN ) :: ILQ, ILZ
177 INTEGER, INTENT( IN ) :: K, LDA, LDB, LDQ, LDZ, ISTARTM, ISTOPM,
178 $ NQ, NZ, QSTART, ZSTART, IHI
179 REAL :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ), Z( LDZ, * )
180*
181* Parameters
182 REAL :: ZERO, ONE, HALF
183 parameter( zero = 0.0, one = 1.0, half = 0.5 )
184*
185* Local variables
186 REAL :: H( 2, 3 ), C1, S1, C2, S2, TEMP
187*
188* External functions
189 EXTERNAL :: slartg, srot
190*
191 IF( k+2 .EQ. ihi ) THEN
192* Shift is located on the edge of the matrix, remove it
193 h = b( ihi-1:ihi, ihi-2:ihi )
194* Make H upper triangular
195 CALL slartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp )
196 h( 2, 1 ) = zero
197 h( 1, 1 ) = temp
198 CALL srot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 )
199*
200 CALL slartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp )
201 CALL srot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 )
202 CALL slartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp )
203*
204 CALL srot( ihi-istartm+1, b( istartm, ihi ), 1, b( istartm,
205 $ ihi-1 ), 1, c1, s1 )
206 CALL srot( ihi-istartm+1, b( istartm, ihi-1 ), 1, b( istartm,
207 $ ihi-2 ), 1, c2, s2 )
208 b( ihi-1, ihi-2 ) = zero
209 b( ihi, ihi-2 ) = zero
210 CALL srot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,
211 $ ihi-1 ), 1, c1, s1 )
212 CALL srot( ihi-istartm+1, a( istartm, ihi-1 ), 1, a( istartm,
213 $ ihi-2 ), 1, c2, s2 )
214 IF ( ilz ) THEN
215 CALL srot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+
216 $ 1 ), 1, c1, s1 )
217 CALL srot( nz, z( 1, ihi-1-zstart+1 ), 1, z( 1,
218 $ ihi-2-zstart+1 ), 1, c2, s2 )
219 END IF
220*
221 CALL slartg( a( ihi-1, ihi-2 ), a( ihi, ihi-2 ), c1, s1,
222 $ temp )
223 a( ihi-1, ihi-2 ) = temp
224 a( ihi, ihi-2 ) = zero
225 CALL srot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,
226 $ ihi-1 ), lda, c1, s1 )
227 CALL srot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,
228 $ ihi-1 ), ldb, c1, s1 )
229 IF ( ilq ) THEN
230 CALL srot( nq, q( 1, ihi-1-qstart+1 ), 1, q( 1, ihi-qstart+
231 $ 1 ), 1, c1, s1 )
232 END IF
233*
234 CALL slartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp )
235 b( ihi, ihi ) = temp
236 b( ihi, ihi-1 ) = zero
237 CALL srot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,
238 $ ihi-1 ), 1, c1, s1 )
239 CALL srot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,
240 $ ihi-1 ), 1, c1, s1 )
241 IF ( ilz ) THEN
242 CALL srot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+
243 $ 1 ), 1, c1, s1 )
244 END IF
245*
246 ELSE
247*
248* Normal operation, move bulge down
249*
250 h = b( k+1:k+2, k:k+2 )
251*
252* Make H upper triangular
253*
254 CALL slartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp )
255 h( 2, 1 ) = zero
256 h( 1, 1 ) = temp
257 CALL srot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 )
258*
259* Calculate Z1 and Z2
260*
261 CALL slartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp )
262 CALL srot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 )
263 CALL slartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp )
264*
265* Apply transformations from the right
266*
267 CALL srot( k+3-istartm+1, a( istartm, k+2 ), 1, a( istartm,
268 $ k+1 ), 1, c1, s1 )
269 CALL srot( k+3-istartm+1, a( istartm, k+1 ), 1, a( istartm,
270 $ k ), 1, c2, s2 )
271 CALL srot( k+2-istartm+1, b( istartm, k+2 ), 1, b( istartm,
272 $ k+1 ), 1, c1, s1 )
273 CALL srot( k+2-istartm+1, b( istartm, k+1 ), 1, b( istartm,
274 $ k ), 1, c2, s2 )
275 IF ( ilz ) THEN
276 CALL srot( nz, z( 1, k+2-zstart+1 ), 1, z( 1, k+1-zstart+
277 $ 1 ), 1, c1, s1 )
278 CALL srot( nz, z( 1, k+1-zstart+1 ), 1, z( 1, k-zstart+1 ),
279 $ 1, c2, s2 )
280 END IF
281 b( k+1, k ) = zero
282 b( k+2, k ) = zero
283*
284* Calculate Q1 and Q2
285*
286 CALL slartg( a( k+2, k ), a( k+3, k ), c1, s1, temp )
287 a( k+2, k ) = temp
288 a( k+3, k ) = zero
289 CALL slartg( a( k+1, k ), a( k+2, k ), c2, s2, temp )
290 a( k+1, k ) = temp
291 a( k+2, k ) = zero
292*
293* Apply transformations from the left
294*
295 CALL srot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,
296 $ c1, s1 )
297 CALL srot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,
298 $ c2, s2 )
299*
300 CALL srot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,
301 $ c1, s1 )
302 CALL srot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,
303 $ c2, s2 )
304 IF ( ilq ) THEN
305 CALL srot( nq, q( 1, k+2-qstart+1 ), 1, q( 1, k+3-qstart+
306 $ 1 ), 1, c1, s1 )
307 CALL srot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+
308 $ 1 ), 1, c2, s2 )
309 END IF
310*
311 END IF
312*
313* End of SLAQZ2
314*

◆ slaqz3()

recursive subroutine slaqz3 ( logical, intent(in) ilschur,
logical, intent(in) ilq,
logical, intent(in) ilz,
integer, intent(in) n,
integer, intent(in) ilo,
integer, intent(in) ihi,
integer, intent(in) nw,
real, dimension( lda, * ), intent(inout) a,
integer, intent(in) lda,
real, dimension( ldb, * ), intent(inout) b,
integer, intent(in) ldb,
real, dimension( ldq, * ), intent(inout) q,
integer, intent(in) ldq,
real, dimension( ldz, * ), intent(inout) z,
integer, intent(in) ldz,
integer, intent(out) ns,
integer, intent(out) nd,
real, dimension( * ), intent(inout) alphar,
real, dimension( * ), intent(inout) alphai,
real, dimension( * ), intent(inout) beta,
real, dimension( ldqc, * ) qc,
integer, intent(in) ldqc,
real, dimension( ldzc, * ) zc,
integer, intent(in) ldzc,
real, dimension( * ) work,
integer, intent(in) lwork,
integer, intent(in) rec,
integer, intent(out) info )

SLAQZ3

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

Purpose:
!>
!> SLAQZ3 performs AED
!>
Parameters
[in]ILSCHUR
!>          ILSCHUR is LOGICAL
!>              Determines whether or not to update the full Schur form
!>
[in]ILQ
!>          ILQ is LOGICAL
!>              Determines whether or not to update the matrix Q
!>
[in]ILZ
!>          ILZ is LOGICAL
!>              Determines whether or not to update the matrix Z
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A, B, Q, and Z.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>          ILO and IHI mark the rows and columns of (A,B) which
!>          are to be normalized
!>
[in]NW
!>          NW is INTEGER
!>          The desired size of the deflation window.
!>
[in,out]A
!>          A is REAL array, dimension (LDA, N)
!>
[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)
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max( 1, N ).
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ, N)
!>
[in]LDQ
!>          LDQ is INTEGER
!>
[in,out]Z
!>          Z is REAL array, dimension (LDZ, N)
!>
[in]LDZ
!>          LDZ is INTEGER
!>
[out]NS
!>          NS is INTEGER
!>          The number of unconverged eigenvalues available to
!>          use as shifts.
!>
[out]ND
!>          ND is INTEGER
!>          The number of converged eigenvalues found.
!>
[out]ALPHAR
!>          ALPHAR is REAL array, dimension (N)
!>          The real parts of each scalar alpha defining an eigenvalue
!>          of GNEP.
!>
[out]ALPHAI
!>          ALPHAI is REAL array, dimension (N)
!>          The imaginary parts of each scalar alpha defining an
!>          eigenvalue of GNEP.
!>          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) = -ALPHAI(j).
!>
[out]BETA
!>          BETA is REAL array, dimension (N)
!>          The scalars beta that define the eigenvalues of GNEP.
!>          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
!>          beta = BETA(j) represent the j-th eigenvalue of the matrix
!>          pair (A,B), in one of the forms lambda = alpha/beta or
!>          mu = beta/alpha.  Since either lambda or mu may overflow,
!>          they should not, in general, be computed.
!>
[in,out]QC
!>          QC is REAL array, dimension (LDQC, NW)
!>
[in]LDQC
!>          LDQC is INTEGER
!>
[in,out]ZC
!>          ZC is REAL array, dimension (LDZC, NW)
!>
[in]LDZC
!>          LDZ is INTEGER
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>
!>          If 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.
!>
[in]REC
!>          REC is INTEGER
!>             REC indicates the current recursion level. Should be set
!>             to 0 on first call.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 234 of file slaqz3.f.

238 IMPLICIT NONE
239
240* Arguments
241 LOGICAL, INTENT( IN ) :: ILSCHUR, ILQ, ILZ
242 INTEGER, INTENT( IN ) :: N, ILO, IHI, NW, LDA, LDB, LDQ, LDZ,
243 $ LDQC, LDZC, LWORK, REC
244
245 REAL, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
246 $ Z( LDZ, * ), ALPHAR( * ), ALPHAI( * ), BETA( * )
247 INTEGER, INTENT( OUT ) :: NS, ND, INFO
248 REAL :: QC( LDQC, * ), ZC( LDZC, * ), WORK( * )
249
250* Parameters
251 REAL :: ZERO, ONE, HALF
252 parameter( zero = 0.0, one = 1.0, half = 0.5 )
253
254* Local Scalars
255 LOGICAL :: BULGE
256 INTEGER :: JW, KWTOP, KWBOT, ISTOPM, ISTARTM, K, K2, STGEXC_INFO,
257 $ IFST, ILST, LWORKREQ, QZ_SMALL_INFO
258 REAL :: S, SMLNUM, ULP, SAFMIN, SAFMAX, C1, S1, TEMP
259
260* External Functions
261 EXTERNAL :: xerbla, stgexc, slabad, slaqz0, slacpy, slaset,
262 $ slaqz2, srot, slartg, slag2, sgemm
263 REAL, EXTERNAL :: SLAMCH
264
265 info = 0
266
267* Set up deflation window
268 jw = min( nw, ihi-ilo+1 )
269 kwtop = ihi-jw+1
270 IF ( kwtop .EQ. ilo ) THEN
271 s = zero
272 ELSE
273 s = a( kwtop, kwtop-1 )
274 END IF
275
276* Determine required workspace
277 ifst = 1
278 ilst = jw
279 CALL stgexc( .true., .true., jw, a, lda, b, ldb, qc, ldqc, zc,
280 $ ldzc, ifst, ilst, work, -1, stgexc_info )
281 lworkreq = int( work( 1 ) )
282 CALL slaqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,
283 $ b( kwtop, kwtop ), ldb, alphar, alphai, beta, qc,
284 $ ldqc, zc, ldzc, work, -1, rec+1, qz_small_info )
285 lworkreq = max( lworkreq, int( work( 1 ) )+2*jw**2 )
286 lworkreq = max( lworkreq, n*nw, 2*nw**2+n )
287 IF ( lwork .EQ.-1 ) THEN
288* workspace query, quick return
289 work( 1 ) = lworkreq
290 RETURN
291 ELSE IF ( lwork .LT. lworkreq ) THEN
292 info = -26
293 END IF
294
295 IF( info.NE.0 ) THEN
296 CALL xerbla( 'SLAQZ3', -info )
297 RETURN
298 END IF
299
300* Get machine constants
301 safmin = slamch( 'SAFE MINIMUM' )
302 safmax = one/safmin
303 CALL slabad( safmin, safmax )
304 ulp = slamch( 'PRECISION' )
305 smlnum = safmin*( real( n )/ulp )
306
307 IF ( ihi .EQ. kwtop ) THEN
308* 1 by 1 deflation window, just try a regular deflation
309 alphar( kwtop ) = a( kwtop, kwtop )
310 alphai( kwtop ) = zero
311 beta( kwtop ) = b( kwtop, kwtop )
312 ns = 1
313 nd = 0
314 IF ( abs( s ) .LE. max( smlnum, ulp*abs( a( kwtop,
315 $ kwtop ) ) ) ) THEN
316 ns = 0
317 nd = 1
318 IF ( kwtop .GT. ilo ) THEN
319 a( kwtop, kwtop-1 ) = zero
320 END IF
321 END IF
322 END IF
323
324
325* Store window in case of convergence failure
326 CALL slacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw )
327 CALL slacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+
328 $ 1 ), jw )
329
330* Transform window to real schur form
331 CALL slaset( 'FULL', jw, jw, zero, one, qc, ldqc )
332 CALL slaset( 'FULL', jw, jw, zero, one, zc, ldzc )
333 CALL slaqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,
334 $ b( kwtop, kwtop ), ldb, alphar, alphai, beta, qc,
335 $ ldqc, zc, ldzc, work( 2*jw**2+1 ), lwork-2*jw**2,
336 $ rec+1, qz_small_info )
337
338 IF( qz_small_info .NE. 0 ) THEN
339* Convergence failure, restore the window and exit
340 nd = 0
341 ns = jw-qz_small_info
342 CALL slacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda )
343 CALL slacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,
344 $ kwtop ), ldb )
345 RETURN
346 END IF
347
348* Deflation detection loop
349 IF ( kwtop .EQ. ilo .OR. s .EQ. zero ) THEN
350 kwbot = kwtop-1
351 ELSE
352 kwbot = ihi
353 k = 1
354 k2 = 1
355 DO WHILE ( k .LE. jw )
356 bulge = .false.
357 IF ( kwbot-kwtop+1 .GE. 2 ) THEN
358 bulge = a( kwbot, kwbot-1 ) .NE. zero
359 END IF
360 IF ( bulge ) THEN
361
362* Try to deflate complex conjugate eigenvalue pair
363 temp = abs( a( kwbot, kwbot ) )+sqrt( abs( a( kwbot,
364 $ kwbot-1 ) ) )*sqrt( abs( a( kwbot-1, kwbot ) ) )
365 IF( temp .EQ. zero )THEN
366 temp = abs( s )
367 END IF
368 IF ( max( abs( s*qc( 1, kwbot-kwtop ) ), abs( s*qc( 1,
369 $ kwbot-kwtop+1 ) ) ) .LE. max( smlnum,
370 $ ulp*temp ) ) THEN
371* Deflatable
372 kwbot = kwbot-2
373 ELSE
374* Not deflatable, move out of the way
375 ifst = kwbot-kwtop+1
376 ilst = k2
377 CALL stgexc( .true., .true., jw, a( kwtop, kwtop ),
378 $ lda, b( kwtop, kwtop ), ldb, qc, ldqc,
379 $ zc, ldzc, ifst, ilst, work, lwork,
380 $ stgexc_info )
381 k2 = k2+2
382 END IF
383 k = k+2
384 ELSE
385
386* Try to deflate real eigenvalue
387 temp = abs( a( kwbot, kwbot ) )
388 IF( temp .EQ. zero ) THEN
389 temp = abs( s )
390 END IF
391 IF ( ( abs( s*qc( 1, kwbot-kwtop+1 ) ) ) .LE. max( ulp*
392 $ temp, smlnum ) ) THEN
393* Deflatable
394 kwbot = kwbot-1
395 ELSE
396* Not deflatable, move out of the way
397 ifst = kwbot-kwtop+1
398 ilst = k2
399 CALL stgexc( .true., .true., jw, a( kwtop, kwtop ),
400 $ lda, b( kwtop, kwtop ), ldb, qc, ldqc,
401 $ zc, ldzc, ifst, ilst, work, lwork,
402 $ stgexc_info )
403 k2 = k2+1
404 END IF
405
406 k = k+1
407
408 END IF
409 END DO
410 END IF
411
412* Store eigenvalues
413 nd = ihi-kwbot
414 ns = jw-nd
415 k = kwtop
416 DO WHILE ( k .LE. ihi )
417 bulge = .false.
418 IF ( k .LT. ihi ) THEN
419 IF ( a( k+1, k ) .NE. zero ) THEN
420 bulge = .true.
421 END IF
422 END IF
423 IF ( bulge ) THEN
424* 2x2 eigenvalue block
425 CALL slag2( a( k, k ), lda, b( k, k ), ldb, safmin,
426 $ beta( k ), beta( k+1 ), alphar( k ),
427 $ alphar( k+1 ), alphai( k ) )
428 alphai( k+1 ) = -alphai( k )
429 k = k+2
430 ELSE
431* 1x1 eigenvalue block
432 alphar( k ) = a( k, k )
433 alphai( k ) = zero
434 beta( k ) = b( k, k )
435 k = k+1
436 END IF
437 END DO
438
439 IF ( kwtop .NE. ilo .AND. s .NE. zero ) THEN
440* Reflect spike back, this will create optimally packed bulges
441 a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 )*qc( 1,
442 $ 1:jw-nd )
443 DO k = kwbot-1, kwtop, -1
444 CALL slartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,
445 $ temp )
446 a( k, kwtop-1 ) = temp
447 a( k+1, kwtop-1 ) = zero
448 k2 = max( kwtop, k-1 )
449 CALL srot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,
450 $ s1 )
451 CALL srot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),
452 $ ldb, c1, s1 )
453 CALL srot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),
454 $ 1, c1, s1 )
455 END DO
456
457* Chase bulges down
458 istartm = kwtop
459 istopm = ihi
460 k = kwbot-1
461 DO WHILE ( k .GE. kwtop )
462 IF ( ( k .GE. kwtop+1 ) .AND. a( k+1, k-1 ) .NE. zero ) THEN
463
464* Move double pole block down and remove it
465 DO k2 = k-1, kwbot-2
466 CALL slaqz2( .true., .true., k2, kwtop, kwtop+jw-1,
467 $ kwbot, a, lda, b, ldb, jw, kwtop, qc,
468 $ ldqc, jw, kwtop, zc, ldzc )
469 END DO
470
471 k = k-2
472 ELSE
473
474* k points to single shift
475 DO k2 = k, kwbot-2
476
477* Move shift down
478 CALL slartg( b( k2+1, k2+1 ), b( k2+1, k2 ), c1, s1,
479 $ temp )
480 b( k2+1, k2+1 ) = temp
481 b( k2+1, k2 ) = zero
482 CALL srot( k2+2-istartm+1, a( istartm, k2+1 ), 1,
483 $ a( istartm, k2 ), 1, c1, s1 )
484 CALL srot( k2-istartm+1, b( istartm, k2+1 ), 1,
485 $ b( istartm, k2 ), 1, c1, s1 )
486 CALL srot( jw, zc( 1, k2+1-kwtop+1 ), 1, zc( 1,
487 $ k2-kwtop+1 ), 1, c1, s1 )
488
489 CALL slartg( a( k2+1, k2 ), a( k2+2, k2 ), c1, s1,
490 $ temp )
491 a( k2+1, k2 ) = temp
492 a( k2+2, k2 ) = zero
493 CALL srot( istopm-k2, a( k2+1, k2+1 ), lda, a( k2+2,
494 $ k2+1 ), lda, c1, s1 )
495 CALL srot( istopm-k2, b( k2+1, k2+1 ), ldb, b( k2+2,
496 $ k2+1 ), ldb, c1, s1 )
497 CALL srot( jw, qc( 1, k2+1-kwtop+1 ), 1, qc( 1,
498 $ k2+2-kwtop+1 ), 1, c1, s1 )
499
500 END DO
501
502* Remove the shift
503 CALL slartg( b( kwbot, kwbot ), b( kwbot, kwbot-1 ), c1,
504 $ s1, temp )
505 b( kwbot, kwbot ) = temp
506 b( kwbot, kwbot-1 ) = zero
507 CALL srot( kwbot-istartm, b( istartm, kwbot ), 1,
508 $ b( istartm, kwbot-1 ), 1, c1, s1 )
509 CALL srot( kwbot-istartm+1, a( istartm, kwbot ), 1,
510 $ a( istartm, kwbot-1 ), 1, c1, s1 )
511 CALL srot( jw, zc( 1, kwbot-kwtop+1 ), 1, zc( 1,
512 $ kwbot-1-kwtop+1 ), 1, c1, s1 )
513
514 k = k-1
515 END IF
516 END DO
517
518 END IF
519
520* Apply Qc and Zc to rest of the matrix
521 IF ( ilschur ) THEN
522 istartm = 1
523 istopm = n
524 ELSE
525 istartm = ilo
526 istopm = ihi
527 END IF
528
529 IF ( istopm-ihi > 0 ) THEN
530 CALL sgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,
531 $ a( kwtop, ihi+1 ), lda, zero, work, jw )
532 CALL slacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,
533 $ ihi+1 ), lda )
534 CALL sgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,
535 $ b( kwtop, ihi+1 ), ldb, zero, work, jw )
536 CALL slacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,
537 $ ihi+1 ), ldb )
538 END IF
539 IF ( ilq ) THEN
540 CALL sgemm( 'N', 'N', n, jw, jw, one, q( 1, kwtop ), ldq, qc,
541 $ ldqc, zero, work, n )
542 CALL slacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq )
543 END IF
544
545 IF ( kwtop-1-istartm+1 > 0 ) THEN
546 CALL sgemm( 'N', 'N', kwtop-istartm, jw, jw, one, a( istartm,
547 $ kwtop ), lda, zc, ldzc, zero, work,
548 $ kwtop-istartm )
549 CALL slacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,
550 $ a( istartm, kwtop ), lda )
551 CALL sgemm( 'N', 'N', kwtop-istartm, jw, jw, one, b( istartm,
552 $ kwtop ), ldb, zc, ldzc, zero, work,
553 $ kwtop-istartm )
554 CALL slacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,
555 $ b( istartm, kwtop ), ldb )
556 END IF
557 IF ( ilz ) THEN
558 CALL sgemm( 'N', 'N', n, jw, jw, one, z( 1, kwtop ), ldz, zc,
559 $ ldzc, zero, work, n )
560 CALL slacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz )
561 END IF
562
slacpy
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
Definition slacpy.f:103
slaqz2
subroutine slaqz2(ilq, ilz, k, istartm, istopm, ihi, a, lda, b, ldb, nq, qstart, q, ldq, nz, zstart, z, ldz)
SLAQZ2
Definition slaqz2.f:173
slaqz0
recursive subroutine slaqz0(wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb, alphar, alphai, beta, q, ldq, z, ldz, work, lwork, rec, info)
SLAQZ0
Definition slaqz0.f:304
stgexc
subroutine stgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, work, lwork, info)
STGEXC
Definition stgexc.f:220
slag2
subroutine slag2(a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2, wi)
SLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary ...
Definition slag2.f:156

◆ slaqz4()

subroutine slaqz4 ( logical, intent(in) ilschur,
logical, intent(in) ilq,
logical, intent(in) ilz,
integer, intent(in) n,
integer, intent(in) ilo,
integer, intent(in) ihi,
integer, intent(in) nshifts,
integer, intent(in) nblock_desired,
real, dimension( * ), intent(inout) sr,
real, dimension( * ), intent(inout) si,
real, dimension( * ), intent(inout) ss,
real, dimension( lda, * ), intent(inout) a,
integer, intent(in) lda,
real, dimension( ldb, * ), intent(inout) b,
integer, intent(in) ldb,
real, dimension( ldq, * ), intent(inout) q,
integer, intent(in) ldq,
real, dimension( ldz, * ), intent(inout) z,
integer, intent(in) ldz,
real, dimension( ldqc, * ), intent(inout) qc,
integer, intent(in) ldqc,
real, dimension( ldzc, * ), intent(inout) zc,
integer, intent(in) ldzc,
real, dimension( * ), intent(inout) work,
integer, intent(in) lwork,
integer, intent(out) info )

SLAQZ4

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

Purpose:
!>
!> SLAQZ4 Executes a single multishift QZ sweep
!>
Parameters
[in]ILSCHUR
!>          ILSCHUR is LOGICAL
!>              Determines whether or not to update the full Schur form
!>
[in]ILQ
!>          ILQ is LOGICAL
!>              Determines whether or not to update the matrix Q
!>
[in]ILZ
!>          ILZ is LOGICAL
!>              Determines whether or not to update the matrix Z
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices A, B, Q, and Z.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
[in]NSHIFTS
!>          NSHIFTS is INTEGER
!>          The desired number of shifts to use
!>
[in]NBLOCK_DESIRED
!>          NBLOCK_DESIRED is INTEGER
!>          The desired size of the computational windows
!>
[in]SR
!>          SR is REAL array. SR contains
!>          the real parts of the shifts to use.
!>
[in]SI
!>          SI is REAL array. SI contains
!>          the imaginary parts of the shifts to use.
!>
[in]SS
!>          SS is REAL array. SS contains
!>          the scale of the shifts to use.
!>
[in,out]A
!>          A is REAL array, dimension (LDA, N)
!>
[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)
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max( 1, N ).
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ, N)
!>
[in]LDQ
!>          LDQ is INTEGER
!>
[in,out]Z
!>          Z is REAL array, dimension (LDZ, N)
!>
[in]LDZ
!>          LDZ is INTEGER
!>
[in,out]QC
!>          QC is REAL array, dimension (LDQC, NBLOCK_DESIRED)
!>
[in]LDQC
!>          LDQC is INTEGER
!>
[in,out]ZC
!>          ZC is REAL array, dimension (LDZC, NBLOCK_DESIRED)
!>
[in]LDZC
!>          LDZ is INTEGER
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>
!>          If 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
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 210 of file slaqz4.f.

214 IMPLICIT NONE
215
216* Function arguments
217 LOGICAL, INTENT( IN ) :: ILSCHUR, ILQ, ILZ
218 INTEGER, INTENT( IN ) :: N, ILO, IHI, LDA, LDB, LDQ, LDZ, LWORK,
219 $ NSHIFTS, NBLOCK_DESIRED, LDQC, LDZC
220
221 REAL, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
222 $ Z( LDZ, * ), QC( LDQC, * ), ZC( LDZC, * ), WORK( * ), SR( * ),
223 $ SI( * ), SS( * )
224
225 INTEGER, INTENT( OUT ) :: INFO
226
227* Parameters
228 REAL :: ZERO, ONE, HALF
229 parameter( zero = 0.0, one = 1.0, half = 0.5 )
230
231* Local scalars
232 INTEGER :: I, J, NS, ISTARTM, ISTOPM, SHEIGHT, SWIDTH, K, NP,
233 $ ISTARTB, ISTOPB, ISHIFT, NBLOCK, NPOS
234 REAL :: TEMP, V( 3 ), C1, S1, C2, S2, SWAP
235*
236* External functions
237 EXTERNAL :: xerbla, sgemm, slaqz1, slaqz2, slaset, slartg, srot,
238 $ slacpy
239
240 info = 0
241 IF ( nblock_desired .LT. nshifts+1 ) THEN
242 info = -8
243 END IF
244 IF ( lwork .EQ.-1 ) THEN
245* workspace query, quick return
246 work( 1 ) = n*nblock_desired
247 RETURN
248 ELSE IF ( lwork .LT. n*nblock_desired ) THEN
249 info = -25
250 END IF
251
252 IF( info.NE.0 ) THEN
253 CALL xerbla( 'SLAQZ4', -info )
254 RETURN
255 END IF
256
257* Executable statements
258
259 IF ( nshifts .LT. 2 ) THEN
260 RETURN
261 END IF
262
263 IF ( ilo .GE. ihi ) THEN
264 RETURN
265 END IF
266
267 IF ( ilschur ) THEN
268 istartm = 1
269 istopm = n
270 ELSE
271 istartm = ilo
272 istopm = ihi
273 END IF
274
275* Shuffle shifts into pairs of real shifts and pairs
276* of complex conjugate shifts assuming complex
277* conjugate shifts are already adjacent to one
278* another
279
280 DO i = 1, nshifts-2, 2
281 IF( si( i ).NE.-si( i+1 ) ) THEN
282*
283 swap = sr( i )
284 sr( i ) = sr( i+1 )
285 sr( i+1 ) = sr( i+2 )
286 sr( i+2 ) = swap
287
288 swap = si( i )
289 si( i ) = si( i+1 )
290 si( i+1 ) = si( i+2 )
291 si( i+2 ) = swap
292
293 swap = ss( i )
294 ss( i ) = ss( i+1 )
295 ss( i+1 ) = ss( i+2 )
296 ss( i+2 ) = swap
297 END IF
298 END DO
299
300* NSHFTS is supposed to be even, but if it is odd,
301* then simply reduce it by one. The shuffle above
302* ensures that the dropped shift is real and that
303* the remaining shifts are paired.
304
305 ns = nshifts-mod( nshifts, 2 )
306 npos = max( nblock_desired-ns, 1 )
307
308* The following block introduces the shifts and chases
309* them down one by one just enough to make space for
310* the other shifts. The near-the-diagonal block is
311* of size (ns+1) x ns.
312
313 CALL slaset( 'FULL', ns+1, ns+1, zero, one, qc, ldqc )
314 CALL slaset( 'FULL', ns, ns, zero, one, zc, ldzc )
315
316 DO i = 1, ns, 2
317* Introduce the shift
318 CALL slaqz1( a( ilo, ilo ), lda, b( ilo, ilo ), ldb, sr( i ),
319 $ sr( i+1 ), si( i ), ss( i ), ss( i+1 ), v )
320
321 temp = v( 2 )
322 CALL slartg( temp, v( 3 ), c1, s1, v( 2 ) )
323 CALL slartg( v( 1 ), v( 2 ), c2, s2, temp )
324
325 CALL srot( ns, a( ilo+1, ilo ), lda, a( ilo+2, ilo ), lda, c1,
326 $ s1 )
327 CALL srot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c2,
328 $ s2 )
329 CALL srot( ns, b( ilo+1, ilo ), ldb, b( ilo+2, ilo ), ldb, c1,
330 $ s1 )
331 CALL srot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c2,
332 $ s2 )
333 CALL srot( ns+1, qc( 1, 2 ), 1, qc( 1, 3 ), 1, c1, s1 )
334 CALL srot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c2, s2 )
335
336* Chase the shift down
337 DO j = 1, ns-1-i
338
339 CALL slaqz2( .true., .true., j, 1, ns, ihi-ilo+1, a( ilo,
340 $ ilo ), lda, b( ilo, ilo ), ldb, ns+1, 1, qc,
341 $ ldqc, ns, 1, zc, ldzc )
342
343 END DO
344
345 END DO
346
347* Update the rest of the pencil
348
349* Update A(ilo:ilo+ns,ilo+ns:istopm) and B(ilo:ilo+ns,ilo+ns:istopm)
350* from the left with Qc(1:ns+1,1:ns+1)'
351 sheight = ns+1
352 swidth = istopm-( ilo+ns )+1
353 IF ( swidth > 0 ) THEN
354 CALL sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,
355 $ a( ilo, ilo+ns ), lda, zero, work, sheight )
356 CALL slacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,
357 $ ilo+ns ), lda )
358 CALL sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,
359 $ b( ilo, ilo+ns ), ldb, zero, work, sheight )
360 CALL slacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,
361 $ ilo+ns ), ldb )
362 END IF
363 IF ( ilq ) THEN
364 CALL sgemm( 'N', 'N', n, sheight, sheight, one, q( 1, ilo ),
365 $ ldq, qc, ldqc, zero, work, n )
366 CALL slacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq )
367 END IF
368
369* Update A(istartm:ilo-1,ilo:ilo+ns-1) and B(istartm:ilo-1,ilo:ilo+ns-1)
370* from the right with Zc(1:ns,1:ns)
371 sheight = ilo-1-istartm+1
372 swidth = ns
373 IF ( sheight > 0 ) THEN
374 CALL sgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,
375 $ ilo ), lda, zc, ldzc, zero, work, sheight )
376 CALL slacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,
377 $ ilo ), lda )
378 CALL sgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,
379 $ ilo ), ldb, zc, ldzc, zero, work, sheight )
380 CALL slacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,
381 $ ilo ), ldb )
382 END IF
383 IF ( ilz ) THEN
384 CALL sgemm( 'N', 'N', n, swidth, swidth, one, z( 1, ilo ), ldz,
385 $ zc, ldzc, zero, work, n )
386 CALL slacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz )
387 END IF
388
389* The following block chases the shifts down to the bottom
390* right block. If possible, a shift is moved down npos
391* positions at a time
392
393 k = ilo
394 DO WHILE ( k < ihi-ns )
395 np = min( ihi-ns-k, npos )
396* Size of the near-the-diagonal block
397 nblock = ns+np
398* istartb points to the first row we will be updating
399 istartb = k+1
400* istopb points to the last column we will be updating
401 istopb = k+nblock-1
402
403 CALL slaset( 'FULL', ns+np, ns+np, zero, one, qc, ldqc )
404 CALL slaset( 'FULL', ns+np, ns+np, zero, one, zc, ldzc )
405
406* Near the diagonal shift chase
407 DO i = ns-1, 0, -2
408 DO j = 0, np-1
409* Move down the block with index k+i+j-1, updating
410* the (ns+np x ns+np) block:
411* (k:k+ns+np,k:k+ns+np-1)
412 CALL slaqz2( .true., .true., k+i+j-1, istartb, istopb,
413 $ ihi, a, lda, b, ldb, nblock, k+1, qc, ldqc,
414 $ nblock, k, zc, ldzc )
415 END DO
416 END DO
417
418* Update rest of the pencil
419
420* Update A(k+1:k+ns+np, k+ns+np:istopm) and
421* B(k+1:k+ns+np, k+ns+np:istopm)
422* from the left with Qc(1:ns+np,1:ns+np)'
423 sheight = ns+np
424 swidth = istopm-( k+ns+np )+1
425 IF ( swidth > 0 ) THEN
426 CALL sgemm( 'T', 'N', sheight, swidth, sheight, one, qc,
427 $ ldqc, a( k+1, k+ns+np ), lda, zero, work,
428 $ sheight )
429 CALL slacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,
430 $ k+ns+np ), lda )
431 CALL sgemm( 'T', 'N', sheight, swidth, sheight, one, qc,
432 $ ldqc, b( k+1, k+ns+np ), ldb, zero, work,
433 $ sheight )
434 CALL slacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,
435 $ k+ns+np ), ldb )
436 END IF
437 IF ( ilq ) THEN
438 CALL sgemm( 'N', 'N', n, nblock, nblock, one, q( 1, k+1 ),
439 $ ldq, qc, ldqc, zero, work, n )
440 CALL slacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq )
441 END IF
442
443* Update A(istartm:k,k:k+ns+npos-1) and B(istartm:k,k:k+ns+npos-1)
444* from the right with Zc(1:ns+np,1:ns+np)
445 sheight = k-istartm+1
446 swidth = nblock
447 IF ( sheight > 0 ) THEN
448 CALL sgemm( 'N', 'N', sheight, swidth, swidth, one,
449 $ a( istartm, k ), lda, zc, ldzc, zero, work,
450 $ sheight )
451 CALL slacpy( 'ALL', sheight, swidth, work, sheight,
452 $ a( istartm, k ), lda )
453 CALL sgemm( 'N', 'N', sheight, swidth, swidth, one,
454 $ b( istartm, k ), ldb, zc, ldzc, zero, work,
455 $ sheight )
456 CALL slacpy( 'ALL', sheight, swidth, work, sheight,
457 $ b( istartm, k ), ldb )
458 END IF
459 IF ( ilz ) THEN
460 CALL sgemm( 'N', 'N', n, nblock, nblock, one, z( 1, k ),
461 $ ldz, zc, ldzc, zero, work, n )
462 CALL slacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz )
463 END IF
464
465 k = k+np
466
467 END DO
468
469* The following block removes the shifts from the bottom right corner
470* one by one. Updates are initially applied to A(ihi-ns+1:ihi,ihi-ns:ihi).
471
472 CALL slaset( 'FULL', ns, ns, zero, one, qc, ldqc )
473 CALL slaset( 'FULL', ns+1, ns+1, zero, one, zc, ldzc )
474
475* istartb points to the first row we will be updating
476 istartb = ihi-ns+1
477* istopb points to the last column we will be updating
478 istopb = ihi
479
480 DO i = 1, ns, 2
481* Chase the shift down to the bottom right corner
482 DO ishift = ihi-i-1, ihi-2
483 CALL slaqz2( .true., .true., ishift, istartb, istopb, ihi,
484 $ a, lda, b, ldb, ns, ihi-ns+1, qc, ldqc, ns+1,
485 $ ihi-ns, zc, ldzc )
486 END DO
487
488 END DO
489
490* Update rest of the pencil
491
492* Update A(ihi-ns+1:ihi, ihi+1:istopm)
493* from the left with Qc(1:ns,1:ns)'
494 sheight = ns
495 swidth = istopm-( ihi+1 )+1
496 IF ( swidth > 0 ) THEN
497 CALL sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,
498 $ a( ihi-ns+1, ihi+1 ), lda, zero, work, sheight )
499 CALL slacpy( 'ALL', sheight, swidth, work, sheight,
500 $ a( ihi-ns+1, ihi+1 ), lda )
501 CALL sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,
502 $ b( ihi-ns+1, ihi+1 ), ldb, zero, work, sheight )
503 CALL slacpy( 'ALL', sheight, swidth, work, sheight,
504 $ b( ihi-ns+1, ihi+1 ), ldb )
505 END IF
506 IF ( ilq ) THEN
507 CALL sgemm( 'N', 'N', n, ns, ns, one, q( 1, ihi-ns+1 ), ldq,
508 $ qc, ldqc, zero, work, n )
509 CALL slacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq )
510 END IF
511
512* Update A(istartm:ihi-ns,ihi-ns:ihi)
513* from the right with Zc(1:ns+1,1:ns+1)
514 sheight = ihi-ns-istartm+1
515 swidth = ns+1
516 IF ( sheight > 0 ) THEN
517 CALL sgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,
518 $ ihi-ns ), lda, zc, ldzc, zero, work, sheight )
519 CALL slacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,
520 $ ihi-ns ), lda )
521 CALL sgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,
522 $ ihi-ns ), ldb, zc, ldzc, zero, work, sheight )
523 CALL slacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,
524 $ ihi-ns ), ldb )
525 END IF
526 IF ( ilz ) THEN
527 CALL sgemm( 'N', 'N', n, ns+1, ns+1, one, z( 1, ihi-ns ), ldz, zc,
528 $ ldzc, zero, work, n )
529 CALL slacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz )
530 END IF
531
slaqz1
subroutine slaqz1(a, lda, b, ldb, sr1, sr2, si, beta1, beta2, v)
SLAQZ1
Definition slaqz1.f:127

◆ zgelqt()

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

ZGELQT

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

Purpose:
!>
!> ZGELQT computes a blocked LQ factorization of a complex M-by-N matrix A
!> using the compact WY representation of Q.
!>
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]MB
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.  MIN(M,N) >= MB >= 1.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the M-by-MIN(M,N) lower trapezoidal matrix L (L is
!>          lower triangular if M <= N); the elements above the diagonal
!>          are the rows of V.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDT,MIN(M,N))
!>          The upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.  See below
!>          for 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*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 matrix V stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1  v1 v1 v1 v1 )
!>                   (     1  v2 v2 v2 )
!>                   (         1 v3 v3 )
!>
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.
!>  Let K=MIN(M,N).  The number of blocks is B = ceiling(K/MB), where each
!>  block is of order MB except for the last block, which is of order
!>  IB = K - (B-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-K matrix T as
!>
!>               T = (T1 T2 ... TB).
!>

Definition at line 138 of file zgelqt.f.

139*
140* -- LAPACK computational routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144* .. Scalar Arguments ..
145 INTEGER INFO, LDA, LDT, M, N, MB
146* ..
147* .. Array Arguments ..
148 COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * )
149* ..
150*
151* =====================================================================
152*
153* ..
154* .. Local Scalars ..
155 INTEGER I, IB, IINFO, K
156* ..
157* .. External Subroutines ..
158 EXTERNAL zgelqt3, zlarfb, xerbla
159* ..
160* .. Executable Statements ..
161*
162* Test the input arguments
163*
164 info = 0
165 IF( m.LT.0 ) THEN
166 info = -1
167 ELSE IF( n.LT.0 ) THEN
168 info = -2
169 ELSE IF( mb.LT.1 .OR. (mb.GT.min(m,n) .AND. min(m,n).GT.0 ))THEN
170 info = -3
171 ELSE IF( lda.LT.max( 1, m ) ) THEN
172 info = -5
173 ELSE IF( ldt.LT.mb ) THEN
174 info = -7
175 END IF
176 IF( info.NE.0 ) THEN
177 CALL xerbla( 'ZGELQT', -info )
178 RETURN
179 END IF
180*
181* Quick return if possible
182*
183 k = min( m, n )
184 IF( k.EQ.0 ) RETURN
185*
186* Blocked loop of length K
187*
188 DO i = 1, k, mb
189 ib = min( k-i+1, mb )
190*
191* Compute the LQ factorization of the current block A(I:M,I:I+IB-1)
192*
193 CALL zgelqt3( ib, n-i+1, a(i,i), lda, t(1,i), ldt, iinfo )
194 IF( i+ib.LE.m ) THEN
195*
196* Update by applying H**T to A(I:M,I+IB:N) from the right
197*
198 CALL zlarfb( 'R', 'N', 'F', 'R', m-i-ib+1, n-i+1, ib,
199 $ a( i, i ), lda, t( 1, i ), ldt,
200 $ a( i+ib, i ), lda, work , m-i-ib+1 )
201 END IF
202 END DO
203 RETURN
204*
205* End of ZGELQT
206*
zlarfb
subroutine zlarfb(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
Definition zlarfb.f:197
zgelqt3
recursive subroutine zgelqt3(m, n, a, lda, t, ldt, info)
ZGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact...
Definition zgelqt3.f:131

◆ zgelqt3()

recursive subroutine zgelqt3 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldt, * ) t,
integer ldt,
integer info )

ZGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact WY representation of Q.

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

Purpose:
!>
!> ZGELQT3 recursively computes a LQ factorization of a complex M-by-N
!> matrix A, using the compact WY representation of Q.
!>
!> Based on the algorithm of Elmroth and Gustavson,
!> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M =< N.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the complex M-by-N matrix A.  On exit, the elements on and
!>          below the diagonal contain the N-by-N lower triangular matrix L; the
!>          elements above the diagonal are the rows of V.  See below for
!>          further details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDT,N)
!>          The N-by-N upper triangular factor of the block reflector.
!>          The elements on and above the diagonal contain the block
!>          reflector T; the elements below the diagonal are not used.
!>          See below for 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 matrix V stores the elementary reflectors H(i) in the i-th row
!>  above the diagonal. For example, if M=5 and N=3, the matrix V is
!>
!>               V = (  1  v1 v1 v1 v1 )
!>                   (     1  v2 v2 v2 )
!>                   (     1  v3 v3 v3 )
!>
!>
!>  where the vi's represent the vectors which define H(i), which are returned
!>  in the matrix A.  The 1's along the diagonal of V are not stored in A.  The
!>  block reflector H is then given by
!>
!>               H = I - V * T * V**T
!>
!>  where V**T is the transpose of V.
!>
!>  For details of the algorithm, see Elmroth and Gustavson (cited above).
!>

Definition at line 130 of file zgelqt3.f.

131*
132* -- LAPACK computational routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136* .. Scalar Arguments ..
137 INTEGER INFO, LDA, M, N, LDT
138* ..
139* .. Array Arguments ..
140 COMPLEX*16 A( LDA, * ), T( LDT, * )
141* ..
142*
143* =====================================================================
144*
145* .. Parameters ..
146 COMPLEX*16 ONE, ZERO
147 parameter( one = (1.0d+00,0.0d+00) )
148 parameter( zero = (0.0d+00,0.0d+00))
149* ..
150* .. Local Scalars ..
151 INTEGER I, I1, J, J1, M1, M2, IINFO
152* ..
153* .. External Subroutines ..
154 EXTERNAL zlarfg, ztrmm, zgemm, xerbla
155* ..
156* .. Executable Statements ..
157*
158 info = 0
159 IF( m .LT. 0 ) THEN
160 info = -1
161 ELSE IF( n .LT. m ) THEN
162 info = -2
163 ELSE IF( lda .LT. max( 1, m ) ) THEN
164 info = -4
165 ELSE IF( ldt .LT. max( 1, m ) ) THEN
166 info = -6
167 END IF
168 IF( info.NE.0 ) THEN
169 CALL xerbla( 'ZGELQT3', -info )
170 RETURN
171 END IF
172*
173 IF( m.EQ.1 ) THEN
174*
175* Compute Householder transform when M=1
176*
177 CALL zlarfg( n, a, a( 1, min( 2, n ) ), lda, t )
178 t(1,1)=conjg(t(1,1))
179*
180 ELSE
181*
182* Otherwise, split A into blocks...
183*
184 m1 = m/2
185 m2 = m-m1
186 i1 = min( m1+1, m )
187 j1 = min( m+1, n )
188*
189* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
190*
191 CALL zgelqt3( m1, n, a, lda, t, ldt, iinfo )
192*
193* Compute A(J1:M,1:N) = A(J1:M,1:N) Q1^H [workspace: T(1:N1,J1:N)]
194*
195 DO i=1,m2
196 DO j=1,m1
197 t( i+m1, j ) = a( i+m1, j )
198 END DO
199 END DO
200 CALL ztrmm( 'R', 'U', 'C', 'U', m2, m1, one,
201 & a, lda, t( i1, 1 ), ldt )
202*
203 CALL zgemm( 'N', 'C', m2, m1, n-m1, one, a( i1, i1 ), lda,
204 & a( 1, i1 ), lda, one, t( i1, 1 ), ldt)
205*
206 CALL ztrmm( 'R', 'U', 'N', 'N', m2, m1, one,
207 & t, ldt, t( i1, 1 ), ldt )
208*
209 CALL zgemm( 'N', 'N', m2, n-m1, m1, -one, t( i1, 1 ), ldt,
210 & a( 1, i1 ), lda, one, a( i1, i1 ), lda )
211*
212 CALL ztrmm( 'R', 'U', 'N', 'U', m2, m1 , one,
213 & a, lda, t( i1, 1 ), ldt )
214*
215 DO i=1,m2
216 DO j=1,m1
217 a( i+m1, j ) = a( i+m1, j ) - t( i+m1, j )
218 t( i+m1, j )= zero
219 END DO
220 END DO
221*
222* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
223*
224 CALL zgelqt3( m2, n-m1, a( i1, i1 ), lda,
225 & t( i1, i1 ), ldt, iinfo )
226*
227* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2
228*
229 DO i=1,m2
230 DO j=1,m1
231 t( j, i+m1 ) = (a( j, i+m1 ))
232 END DO
233 END DO
234*
235 CALL ztrmm( 'R', 'U', 'C', 'U', m1, m2, one,
236 & a( i1, i1 ), lda, t( 1, i1 ), ldt )
237*
238 CALL zgemm( 'N', 'C', m1, m2, n-m, one, a( 1, j1 ), lda,
239 & a( i1, j1 ), lda, one, t( 1, i1 ), ldt )
240*
241 CALL ztrmm( 'L', 'U', 'N', 'N', m1, m2, -one, t, ldt,
242 & t( 1, i1 ), ldt )
243*
244 CALL ztrmm( 'R', 'U', 'N', 'N', m1, m2, one,
245 & t( i1, i1 ), ldt, t( 1, i1 ), ldt )
246*
247*
248*
249* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3]
250* [ A(1:N1,J1:N) L2 ] [ 0 T2]
251*
252 END IF
253*
254 RETURN
255*
256* End of ZGELQT3
257*
zlarfg
subroutine zlarfg(n, alpha, x, incx, tau)
ZLARFG generates an elementary reflector (Householder matrix).
Definition zlarfg.f:106
ztrmm
subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRMM
Definition ztrmm.f:177
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187

◆ zgemlqt()

subroutine zgemlqt ( character side,
character trans,
integer m,
integer n,
integer k,
integer mb,
complex*16, dimension( ldv, * ) v,
integer ldv,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work,
integer info )

ZGEMLQT

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

Purpose:
!>
!> ZGEMLQT overwrites the general complex M-by-N matrix C with
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q C            C Q
!> TRANS = 'C':   Q**H C            C Q**H
!>
!> where Q is a complex unitary matrix defined as the product of K
!> elementary reflectors:
!>
!>       Q = H(1) H(2) . . . H(K) = I - V T V**H
!>
!> generated using the compact WY representation as returned by ZGELQT.
!>
!> Q is of order M if SIDE = 'L' and of order N  if SIDE = 'R'.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate transpose, apply Q**H.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]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 ZGELQT.
!>
[in]V
!>          V is COMPLEX*16 array, dimension
!>                               (LDV,M) if SIDE = 'L',
!>                               (LDV,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
!>          ZGELQT in the first K rows of its array argument A.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= max(1,K).
!>
[in]T
!>          T is COMPLEX*16 array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by ZGELQT, stored as a MB-by-K matrix.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= MB.
!>
[in,out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q C, Q**H C, C Q**H or C Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array. 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.

Definition at line 166 of file zgemlqt.f.

168*
169* -- LAPACK computational routine --
170* -- LAPACK is a software package provided by Univ. of Tennessee, --
171* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172*
173* .. Scalar Arguments ..
174 CHARACTER SIDE, TRANS
175 INTEGER INFO, K, LDV, LDC, M, N, MB, LDT
176* ..
177* .. Array Arguments ..
178 COMPLEX*16 V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
179* ..
180*
181* =====================================================================
182*
183* ..
184* .. Local Scalars ..
185 LOGICAL LEFT, RIGHT, TRAN, NOTRAN
186 INTEGER I, IB, LDWORK, KF, Q
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 EXTERNAL lsame
191* ..
192* .. External Subroutines ..
193 EXTERNAL xerbla, zlarfb
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC max, min
197* ..
198* .. Executable Statements ..
199*
200* .. Test the input arguments ..
201*
202 info = 0
203 left = lsame( side, 'L' )
204 right = lsame( side, 'R' )
205 tran = lsame( trans, 'C' )
206 notran = lsame( trans, 'N' )
207*
208 IF( left ) THEN
209 ldwork = max( 1, n )
210 q = m
211 ELSE IF ( right ) THEN
212 ldwork = max( 1, m )
213 q = n
214 END IF
215 IF( .NOT.left .AND. .NOT.right ) THEN
216 info = -1
217 ELSE IF( .NOT.tran .AND. .NOT.notran ) THEN
218 info = -2
219 ELSE IF( m.LT.0 ) THEN
220 info = -3
221 ELSE IF( n.LT.0 ) THEN
222 info = -4
223 ELSE IF( k.LT.0 .OR. k.GT.q ) THEN
224 info = -5
225 ELSE IF( mb.LT.1 .OR. (mb.GT.k .AND. k.GT.0)) THEN
226 info = -6
227 ELSE IF( ldv.LT.max( 1, k ) ) THEN
228 info = -8
229 ELSE IF( ldt.LT.mb ) THEN
230 info = -10
231 ELSE IF( ldc.LT.max( 1, m ) ) THEN
232 info = -12
233 END IF
234*
235 IF( info.NE.0 ) THEN
236 CALL xerbla( 'ZGEMLQT', -info )
237 RETURN
238 END IF
239*
240* .. Quick return if possible ..
241*
242 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) RETURN
243*
244 IF( left .AND. notran ) THEN
245*
246 DO i = 1, k, mb
247 ib = min( mb, k-i+1 )
248 CALL zlarfb( 'L', 'C', 'F', 'R', m-i+1, n, ib,
249 $ v( i, i ), ldv, t( 1, i ), ldt,
250 $ c( i, 1 ), ldc, work, ldwork )
251 END DO
252*
253 ELSE IF( right .AND. tran ) THEN
254*
255 DO i = 1, k, mb
256 ib = min( mb, k-i+1 )
257 CALL zlarfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,
258 $ v( i, i ), ldv, t( 1, i ), ldt,
259 $ c( 1, i ), ldc, work, ldwork )
260 END DO
261*
262 ELSE IF( left .AND. tran ) THEN
263*
264 kf = ((k-1)/mb)*mb+1
265 DO i = kf, 1, -mb
266 ib = min( mb, k-i+1 )
267 CALL zlarfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,
268 $ v( i, i ), ldv, t( 1, i ), ldt,
269 $ c( i, 1 ), ldc, work, ldwork )
270 END DO
271*
272 ELSE IF( right .AND. notran ) THEN
273*
274 kf = ((k-1)/mb)*mb+1
275 DO i = kf, 1, -mb
276 ib = min( mb, k-i+1 )
277 CALL zlarfb( 'R', 'C', 'F', 'R', m, n-i+1, ib,
278 $ v( i, i ), ldv, t( 1, i ), ldt,
279 $ c( 1, i ), ldc, work, ldwork )
280 END DO
281*
282 END IF
283*
284 RETURN
285*
286* End of ZGEMLQT
287*