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

Functions

subroutine cgebak (job, side, n, ilo, ihi, scale, m, v, ldv, info)
 CGEBAK
subroutine cgebal (job, n, a, lda, ilo, ihi, scale, info)
 CGEBAL
subroutine cgebd2 (m, n, a, lda, d, e, tauq, taup, work, info)
 CGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
subroutine cgebrd (m, n, a, lda, d, e, tauq, taup, work, lwork, info)
 CGEBRD
subroutine cgecon (norm, n, a, lda, anorm, rcond, work, rwork, info)
 CGECON
subroutine cgeequ (m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
 CGEEQU
subroutine cgeequb (m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
 CGEEQUB
subroutine cgehd2 (n, ilo, ihi, a, lda, tau, work, info)
 CGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
subroutine cgehrd (n, ilo, ihi, a, lda, tau, work, lwork, info)
 CGEHRD
subroutine cgelq2 (m, n, a, lda, tau, work, info)
 CGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
subroutine cgelqf (m, n, a, lda, tau, work, lwork, info)
 CGELQF
subroutine cgemqrt (side, trans, m, n, k, nb, v, ldv, t, ldt, c, ldc, work, info)
 CGEMQRT
subroutine cgeql2 (m, n, a, lda, tau, work, info)
 CGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.
subroutine cgeqlf (m, n, a, lda, tau, work, lwork, info)
 CGEQLF
subroutine cgeqp3 (m, n, a, lda, jpvt, tau, work, lwork, rwork, info)
 CGEQP3
subroutine cgeqr2 (m, n, a, lda, tau, work, info)
 CGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
subroutine cgeqr2p (m, n, a, lda, tau, work, info)
 CGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elements using an unblocked algorithm.
subroutine cgeqrf (m, n, a, lda, tau, work, lwork, info)
 CGEQRF
subroutine cgeqrfp (m, n, a, lda, tau, work, lwork, info)
 CGEQRFP
subroutine cgeqrt (m, n, nb, a, lda, t, ldt, work, info)
 CGEQRT
subroutine cgeqrt2 (m, n, a, lda, t, ldt, info)
 CGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.
recursive subroutine cgeqrt3 (m, n, a, lda, t, ldt, info)
  CGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.
subroutine cgerfs (trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 CGERFS
subroutine cgerfsx (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, rwork, info)
 CGERFSX
subroutine cgerq2 (m, n, a, lda, tau, work, info)
 CGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
subroutine cgerqf (m, n, a, lda, tau, work, lwork, info)
 CGERQF
subroutine cgesvj (joba, jobu, jobv, m, n, a, lda, sva, mv, v, ldv, cwork, lwork, rwork, lrwork, info)
  CGESVJ
subroutine cgetf2 (m, n, a, lda, ipiv, info)
 CGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm).
subroutine cgetrf (m, n, a, lda, ipiv, info)
 CGETRF
recursive subroutine cgetrf2 (m, n, a, lda, ipiv, info)
 CGETRF2
subroutine cgetri (n, a, lda, ipiv, work, lwork, info)
 CGETRI
subroutine cgetrs (trans, n, nrhs, a, lda, ipiv, b, ldb, info)
 CGETRS
subroutine chgeqz (job, compq, compz, n, ilo, ihi, h, ldh, t, ldt, alpha, beta, q, ldq, z, ldz, work, lwork, rwork, info)
 CHGEQZ
subroutine cla_geamv (trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
 CLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds.
real function cla_gercond_c (trans, n, a, lda, af, ldaf, ipiv, c, capply, info, work, rwork)
 CLA_GERCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for general matrices.
real function cla_gercond_x (trans, n, a, lda, af, ldaf, ipiv, x, info, work, rwork)
 CLA_GERCOND_X computes the infinity norm condition number of op(A)*diag(x) for general matrices.
subroutine cla_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)
 CLA_GERFSX_EXTENDED
real function cla_gerpvgrw (n, ncols, a, lda, af, ldaf)
 CLA_GERPVGRW multiplies a square real matrix by a complex matrix.
recursive subroutine claqz0 (wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb, alpha, beta, q, ldq, z, ldz, work, lwork, rwork, rec, info)
 CLAQZ0
subroutine claqz1 (ilq, ilz, k, istartm, istopm, ihi, a, lda, b, ldb, nq, qstart, q, ldq, nz, zstart, z, ldz)
 CLAQZ1
recursive subroutine claqz2 (ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb, q, ldq, z, ldz, ns, nd, alpha, beta, qc, ldqc, zc, ldzc, work, lwork, rwork, rec, info)
 CLAQZ2
subroutine claqz3 (ilschur, ilq, ilz, n, ilo, ihi, nshifts, nblock_desired, alpha, beta, a, lda, b, ldb, q, ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork, info)
 CLAQZ3
subroutine claunhr_col_getrfnp (m, n, a, lda, d, info)
 CLAUNHR_COL_GETRFNP
recursive subroutine claunhr_col_getrfnp2 (m, n, a, lda, d, info)
 CLAUNHR_COL_GETRFNP2
subroutine ctgevc (side, howmny, select, n, s, lds, p, ldp, vl, ldvl, vr, ldvr, mm, m, work, rwork, info)
 CTGEVC
subroutine ctgexc (wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, info)
 CTGEXC
subroutine cgeqpf (m, n, a, lda, jpvt, tau, work, rwork, info)
 CGEQPF

Detailed Description

This is the group of complex computational functions for GE matrices

Function Documentation

◆ cgebak()

subroutine cgebak ( character job,
character side,
integer n,
integer ilo,
integer ihi,
real, dimension( * ) scale,
integer m,
complex, dimension( ldv, * ) v,
integer ldv,
integer info )

CGEBAK

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

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

◆ cgebal()

subroutine cgebal ( character job,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer ilo,
integer ihi,
real, dimension( * ) scale,
integer info )

CGEBAL

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

Purpose:
!>
!> CGEBAL balances a general complex 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 COMPLEX 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 REAL 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 CBAL.
!>
!>  Modified by Tzu-Yi Chen, Computer Science Division, University of
!>    California at Berkeley, USA
!>

Definition at line 160 of file cgebal.f.

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

◆ cgebd2()

subroutine cgebd2 ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( * ) tauq,
complex, dimension( * ) taup,
complex, dimension( * ) work,
integer info )

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

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

Purpose:
!>
!> CGEBD2 reduces a complex general m by n matrix A to upper or lower
!> real bidiagonal form B by a unitary transformation: Q**H * 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 COMPLEX 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 unitary matrix Q as a product of elementary
!>            reflectors, and the elements above the first superdiagonal,
!>            with the array TAUP, represent the unitary 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 unitary matrix Q as a product of
!>            elementary reflectors, and the elements above the diagonal,
!>            with the array TAUP, represent the unitary 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 REAL array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is REAL 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 COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix Q. See Further Details.
!>
[out]TAUP
!>          TAUP is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix P. See Further Details.
!>
[out]WORK
!>          WORK is COMPLEX 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**H  and G(i) = I - taup * u * u**H
!>
!>  where tauq and taup are complex scalars, and v and u are complex
!>  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**H  and G(i) = I - taup * u * u**H
!>
!>  where tauq and taup are complex scalars, v and u are complex 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 189 of file cgebd2.f.

190*
191* -- LAPACK computational routine --
192* -- LAPACK is a software package provided by Univ. of Tennessee, --
193* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
194*
195* .. Scalar Arguments ..
196 INTEGER INFO, LDA, M, N
197* ..
198* .. Array Arguments ..
199 REAL D( * ), E( * )
200 COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
201* ..
202*
203* =====================================================================
204*
205* .. Parameters ..
206 COMPLEX ZERO, ONE
207 parameter( zero = ( 0.0e+0, 0.0e+0 ),
208 $ one = ( 1.0e+0, 0.0e+0 ) )
209* ..
210* .. Local Scalars ..
211 INTEGER I
212 COMPLEX ALPHA
213* ..
214* .. External Subroutines ..
215 EXTERNAL clacgv, clarf, clarfg, xerbla
216* ..
217* .. Intrinsic Functions ..
218 INTRINSIC conjg, max, min
219* ..
220* .. Executable Statements ..
221*
222* Test the input parameters
223*
224 info = 0
225 IF( m.LT.0 ) THEN
226 info = -1
227 ELSE IF( n.LT.0 ) THEN
228 info = -2
229 ELSE IF( lda.LT.max( 1, m ) ) THEN
230 info = -4
231 END IF
232 IF( info.LT.0 ) THEN
233 CALL xerbla( 'CGEBD2', -info )
234 RETURN
235 END IF
236*
237 IF( m.GE.n ) THEN
238*
239* Reduce to upper bidiagonal form
240*
241 DO 10 i = 1, n
242*
243* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
244*
245 alpha = a( i, i )
246 CALL clarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,
247 $ tauq( i ) )
248 d( i ) = real( alpha )
249 a( i, i ) = one
250*
251* Apply H(i)**H to A(i:m,i+1:n) from the left
252*
253 IF( i.LT.n )
254 $ CALL clarf( 'Left', m-i+1, n-i, a( i, i ), 1,
255 $ conjg( tauq( i ) ), a( i, i+1 ), lda, work )
256 a( i, i ) = d( i )
257*
258 IF( i.LT.n ) THEN
259*
260* Generate elementary reflector G(i) to annihilate
261* A(i,i+2:n)
262*
263 CALL clacgv( n-i, a( i, i+1 ), lda )
264 alpha = a( i, i+1 )
265 CALL clarfg( n-i, alpha, a( i, min( i+2, n ) ),
266 $ lda, taup( i ) )
267 e( i ) = real( alpha )
268 a( i, i+1 ) = one
269*
270* Apply G(i) to A(i+1:m,i+1:n) from the right
271*
272 CALL clarf( 'Right', m-i, n-i, a( i, i+1 ), lda,
273 $ taup( i ), a( i+1, i+1 ), lda, work )
274 CALL clacgv( n-i, a( i, i+1 ), lda )
275 a( i, i+1 ) = e( i )
276 ELSE
277 taup( i ) = zero
278 END IF
279 10 CONTINUE
280 ELSE
281*
282* Reduce to lower bidiagonal form
283*
284 DO 20 i = 1, m
285*
286* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
287*
288 CALL clacgv( n-i+1, a( i, i ), lda )
289 alpha = a( i, i )
290 CALL clarfg( n-i+1, alpha, a( i, min( i+1, n ) ), lda,
291 $ taup( i ) )
292 d( i ) = real( alpha )
293 a( i, i ) = one
294*
295* Apply G(i) to A(i+1:m,i:n) from the right
296*
297 IF( i.LT.m )
298 $ CALL clarf( 'Right', m-i, n-i+1, a( i, i ), lda,
299 $ taup( i ), a( i+1, i ), lda, work )
300 CALL clacgv( n-i+1, a( i, i ), lda )
301 a( i, i ) = d( i )
302*
303 IF( i.LT.m ) THEN
304*
305* Generate elementary reflector H(i) to annihilate
306* A(i+2:m,i)
307*
308 alpha = a( i+1, i )
309 CALL clarfg( m-i, alpha, a( min( i+2, m ), i ), 1,
310 $ tauq( i ) )
311 e( i ) = real( alpha )
312 a( i+1, i ) = one
313*
314* Apply H(i)**H to A(i+1:m,i+1:n) from the left
315*
316 CALL clarf( 'Left', m-i, n-i, a( i+1, i ), 1,
317 $ conjg( tauq( i ) ), a( i+1, i+1 ), lda,
318 $ work )
319 a( i+1, i ) = e( i )
320 ELSE
321 tauq( i ) = zero
322 END IF
323 20 CONTINUE
324 END IF
325 RETURN
326*
327* End of CGEBD2
328*
alpha
#define alpha
Definition eval.h:35
clarfg
subroutine clarfg(n, alpha, x, incx, tau)
CLARFG generates an elementary reflector (Householder matrix).
Definition clarfg.f:106
clacgv
subroutine clacgv(n, x, incx)
CLACGV conjugates a complex vector.
Definition clacgv.f:74
clarf
subroutine clarf(side, m, n, v, incv, tau, c, ldc, work)
CLARF applies an elementary reflector to a general rectangular matrix.
Definition clarf.f:128

◆ cgebrd()

subroutine cgebrd ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( * ) tauq,
complex, dimension( * ) taup,
complex, dimension( * ) work,
integer lwork,
integer info )

CGEBRD

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

Purpose:
!>
!> CGEBRD reduces a general complex M-by-N matrix A to upper or lower
!> bidiagonal form B by a unitary transformation: Q**H * 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 COMPLEX 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 unitary matrix Q as a product of elementary
!>            reflectors, and the elements above the first superdiagonal,
!>            with the array TAUP, represent the unitary 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 unitary matrix Q as a product of
!>            elementary reflectors, and the elements above the diagonal,
!>            with the array TAUP, represent the unitary 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 REAL array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is REAL 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 COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix Q. See Further Details.
!>
[out]TAUP
!>          TAUP is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix P. See Further Details.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The 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**H  and G(i) = I - taup * u * u**H
!>
!>  where tauq and taup are complex scalars, and v and u are complex
!>  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**H  and G(i) = I - taup * u * u**H
!>
!>  where tauq and taup are complex scalars, and v and u are complex
!>  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 204 of file cgebrd.f.

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

◆ cgecon()

subroutine cgecon ( character norm,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real anorm,
real rcond,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CGECON

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

Purpose:
!>
!> CGECON estimates the reciprocal of the condition number of a general
!> complex matrix A, in either the 1-norm or the infinity-norm, using
!> the LU factorization computed by CGETRF.
!>
!> 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 COMPLEX array, dimension (LDA,N)
!>          The factors L and U from the factorization A = P*L*U
!>          as computed by CGETRF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]ANORM
!>          ANORM is REAL
!>          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 REAL
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file cgecon.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 REAL ANORM, RCOND
133* ..
134* .. Array Arguments ..
135 REAL RWORK( * )
136 COMPLEX A( LDA, * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 REAL ONE, ZERO
143 parameter( one = 1.0e+0, zero = 0.0e+0 )
144* ..
145* .. Local Scalars ..
146 LOGICAL ONENRM
147 CHARACTER NORMIN
148 INTEGER IX, KASE, KASE1
149 REAL AINVNM, SCALE, SL, SMLNUM, SU
150 COMPLEX ZDUM
151* ..
152* .. Local Arrays ..
153 INTEGER ISAVE( 3 )
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 INTEGER ICAMAX
158 REAL SLAMCH
159 EXTERNAL lsame, icamax, slamch
160* ..
161* .. External Subroutines ..
162 EXTERNAL clacn2, clatrs, csrscl, xerbla
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC abs, aimag, max, real
166* ..
167* .. Statement Functions ..
168 REAL CABS1
169* ..
170* .. Statement Function definitions ..
171 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
172* ..
173* .. Executable Statements ..
174*
175* Test the input parameters.
176*
177 info = 0
178 onenrm = norm.EQ.'1' .OR. lsame( norm, 'O' )
179 IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN
180 info = -1
181 ELSE IF( n.LT.0 ) THEN
182 info = -2
183 ELSE IF( lda.LT.max( 1, n ) ) THEN
184 info = -4
185 ELSE IF( anorm.LT.zero ) THEN
186 info = -5
187 END IF
188 IF( info.NE.0 ) THEN
189 CALL xerbla( 'CGECON', -info )
190 RETURN
191 END IF
192*
193* Quick return if possible
194*
195 rcond = zero
196 IF( n.EQ.0 ) THEN
197 rcond = one
198 RETURN
199 ELSE IF( anorm.EQ.zero ) THEN
200 RETURN
201 END IF
202*
203 smlnum = slamch( 'Safe minimum' )
204*
205* Estimate the norm of inv(A).
206*
207 ainvnm = zero
208 normin = 'N'
209 IF( onenrm ) THEN
210 kase1 = 1
211 ELSE
212 kase1 = 2
213 END IF
214 kase = 0
215 10 CONTINUE
216 CALL clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
217 IF( kase.NE.0 ) THEN
218 IF( kase.EQ.kase1 ) THEN
219*
220* Multiply by inv(L).
221*
222 CALL clatrs( 'Lower', 'No transpose', 'Unit', normin, n, a,
223 $ lda, work, sl, rwork, info )
224*
225* Multiply by inv(U).
226*
227 CALL clatrs( 'Upper', 'No transpose', 'Non-unit', normin, n,
228 $ a, lda, work, su, rwork( n+1 ), info )
229 ELSE
230*
231* Multiply by inv(U**H).
232*
233 CALL clatrs( 'Upper', 'Conjugate transpose', 'Non-unit',
234 $ normin, n, a, lda, work, su, rwork( n+1 ),
235 $ info )
236*
237* Multiply by inv(L**H).
238*
239 CALL clatrs( 'Lower', 'Conjugate transpose', 'Unit', normin,
240 $ n, a, lda, work, sl, rwork, info )
241 END IF
242*
243* Divide X by 1/(SL*SU) if doing so will not cause overflow.
244*
245 scale = sl*su
246 normin = 'Y'
247 IF( scale.NE.one ) THEN
248 ix = icamax( n, work, 1 )
249 IF( scale.LT.cabs1( work( ix ) )*smlnum .OR. scale.EQ.zero )
250 $ GO TO 20
251 CALL csrscl( n, scale, work, 1 )
252 END IF
253 GO TO 10
254 END IF
255*
256* Compute the estimate of the reciprocal condition number.
257*
258 IF( ainvnm.NE.zero )
259 $ rcond = ( one / ainvnm ) / anorm
260*
261 20 CONTINUE
262 RETURN
263*
264* End of CGECON
265*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
csrscl
subroutine csrscl(n, sa, sx, incx)
CSRSCL multiplies a vector by the reciprocal of a real scalar.
Definition csrscl.f:84
clatrs
subroutine clatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
CLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition clatrs.f:239
clacn2
subroutine clacn2(n, v, x, est, kase, isave)
CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
Definition clacn2.f:133

◆ cgeequ()

subroutine cgeequ ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) r,
real, dimension( * ) c,
real rowcnd,
real colcnd,
real amax,
integer info )

CGEEQU

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

Purpose:
!>
!> CGEEQU 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 COMPLEX 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 REAL array, dimension (M)
!>          If INFO = 0 or INFO > M, R contains the row scale factors
!>          for A.
!>
[out]C
!>          C is REAL array, dimension (N)
!>          If INFO = 0,  C contains the column scale factors for A.
!>
[out]ROWCND
!>          ROWCND is REAL
!>          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 REAL
!>          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 REAL
!>          Absolute value of largest matrix element.  If AMAX is very
!>          close to overflow or very close to underflow, the matrix
!>          should be scaled.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i,  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 138 of file cgeequ.f.

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

◆ cgeequb()

subroutine cgeequb ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) r,
real, dimension( * ) c,
real rowcnd,
real colcnd,
real amax,
integer info )

CGEEQUB

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

Purpose:
!>
!> CGEEQUB 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 CGEEQU 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 COMPLEX 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 REAL array, dimension (M)
!>          If INFO = 0 or INFO > M, R contains the row scale factors
!>          for A.
!>
[out]C
!>          C is REAL array, dimension (N)
!>          If INFO = 0,  C contains the column scale factors for A.
!>
[out]ROWCND
!>          ROWCND is REAL
!>          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 REAL
!>          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 REAL
!>          Absolute value of largest matrix element.  If AMAX is very
!>          close to overflow or very close to underflow, the matrix
!>          should be scaled.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i,  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 145 of file cgeequb.f.

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

◆ cgehd2()

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

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

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

Purpose:
!>
!> CGEHD2 reduces a complex general matrix A to upper Hessenberg form H
!> by a unitary similarity transformation:  Q**H * 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 CGEBAL; otherwise they should be
!>          set to 1 and N respectively. See Further Details.
!>          1 <= ILO <= IHI <= max(1,N).
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the n by n general matrix to be reduced.
!>          On exit, the upper triangle and the first subdiagonal of A
!>          are overwritten with the upper Hessenberg matrix H, and the
!>          elements below the first subdiagonal, with the array TAU,
!>          represent the unitary matrix Q as a product of elementary
!>          reflectors. See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  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**H
!>
!>  where tau is a complex scalar, and v is a complex 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 cgehd2.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 COMPLEX A( LDA, * ), TAU( * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 COMPLEX ONE
165 parameter( one = ( 1.0e+0, 0.0e+0 ) )
166* ..
167* .. Local Scalars ..
168 INTEGER I
169 COMPLEX ALPHA
170* ..
171* .. External Subroutines ..
172 EXTERNAL clarf, clarfg, xerbla
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC conjg, 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( 'CGEHD2', -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 alpha = a( i+1, i )
201 CALL clarfg( ihi-i, alpha, a( min( i+2, n ), i ), 1, tau( i ) )
202 a( i+1, i ) = one
203*
204* Apply H(i) to A(1:ihi,i+1:ihi) from the right
205*
206 CALL clarf( 'Right', ihi, ihi-i, a( i+1, i ), 1, tau( i ),
207 $ a( 1, i+1 ), lda, work )
208*
209* Apply H(i)**H to A(i+1:ihi,i+1:n) from the left
210*
211 CALL clarf( 'Left', ihi-i, n-i, a( i+1, i ), 1,
212 $ conjg( tau( i ) ), a( i+1, i+1 ), lda, work )
213*
214 a( i+1, i ) = alpha
215 10 CONTINUE
216*
217 RETURN
218*
219* End of CGEHD2
220*

◆ cgehrd()

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

CGEHRD

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

Purpose:
!>
!> CGEHRD reduces a complex general matrix A to upper Hessenberg form H by
!> an unitary similarity transformation:  Q**H * 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 CGEBAL; 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 COMPLEX array, dimension (LDA,N)
!>          On entry, the N-by-N general matrix to be reduced.
!>          On exit, the upper triangle and the first subdiagonal of A
!>          are overwritten with the upper Hessenberg matrix H, and the
!>          elements below the first subdiagonal, with the array TAU,
!>          represent the unitary matrix Q as a product of elementary
!>          reflectors. See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TAU
!>          TAU is COMPLEX 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 COMPLEX array, dimension (LWORK)
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= 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**H
!>
!>  where tau is a complex scalar, and v is a complex 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 CGEHRD
!>  subroutine incorporating improvements proposed by Quintana-Orti and
!>  Van de Geijn (2006). (See CLAHR2.)
!>

Definition at line 166 of file cgehrd.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 COMPLEX 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 COMPLEX ZERO, ONE
186 parameter( zero = ( 0.0e+0, 0.0e+0 ),
187 $ one = ( 1.0e+0, 0.0e+0 ) )
188* ..
189* .. Local Scalars ..
190 LOGICAL LQUERY
191 INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB,
192 $ NBMIN, NH, NX
193 COMPLEX EI
194* ..
195* .. External Subroutines ..
196 EXTERNAL caxpy, cgehd2, cgemm, clahr2, clarfb, ctrmm,
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, 'CGEHRD', ' ', 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( 'CGEHRD', -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, 'CGEHRD', ' ', 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, 'CGEHRD', ' ', 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, 'CGEHRD', ' ', 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**H
305* which performs the reduction, and also the matrix Y = A*V*T
306*
307 CALL clahr2( 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**H. 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 cgemm( 'No transpose', 'Conjugate 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 ctrmm( 'Right', 'Lower', 'Conjugate transpose',
326 $ 'Unit', i, ib-1,
327 $ one, a( i+1, i ), lda, work, ldwork )
328 DO 30 j = 0, ib-2
329 CALL caxpy( 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 clarfb( 'Left', 'Conjugate 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 cgehd2( n, i, ihi, a, lda, tau, work, iinfo )
347 work( 1 ) = lwkopt
348*
349 RETURN
350*
351* End of CGEHRD
352*
cgehd2
subroutine cgehd2(n, ilo, ihi, a, lda, tau, work, info)
CGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
Definition cgehd2.f:149
clahr2
subroutine clahr2(n, k, nb, a, lda, tau, t, ldt, y, ldy)
CLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elemen...
Definition clahr2.f:181
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
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
Definition caxpy.f:88
ctrmm
subroutine ctrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRMM
Definition ctrmm.f:177

◆ cgelq2()

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

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

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

Purpose:
!>
!> CGELQ2 computes an LQ factorization of a complex 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 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,
!>          with the array TAU, represent the unitary matrix Q as a
!>          product of elementary reflectors (see Further Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX 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 . . . H(2)**H H(1)**H, where k = min(m,n).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(1:i-1) = 0 and v(i) = 1; conjg(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 cgelq2.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 COMPLEX A( LDA, * ), TAU( * ), WORK( * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 COMPLEX ONE
145 parameter( one = ( 1.0e+0, 0.0e+0 ) )
146* ..
147* .. Local Scalars ..
148 INTEGER I, K
149 COMPLEX ALPHA
150* ..
151* .. External Subroutines ..
152 EXTERNAL clacgv, clarf, clarfg, 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( 'CGELQ2', -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 clacgv( n-i+1, a( i, i ), lda )
181 alpha = a( i, i )
182 CALL clarfg( n-i+1, alpha, a( i, min( i+1, n ) ), lda,
183 $ tau( i ) )
184 IF( i.LT.m ) THEN
185*
186* Apply H(i) to A(i+1:m,i:n) from the right
187*
188 a( i, i ) = one
189 CALL clarf( 'Right', m-i, n-i+1, a( i, i ), lda, tau( i ),
190 $ a( i+1, i ), lda, work )
191 END IF
192 a( i, i ) = alpha
193 CALL clacgv( n-i+1, a( i, i ), lda )
194 10 CONTINUE
195 RETURN
196*
197* End of CGELQ2
198*

◆ cgelqf()

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

CGELQF

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

Purpose:
!>
!> CGELQF computes an LQ factorization of a complex 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 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,
!>          with the array TAU, represent the unitary matrix Q as a
!>          product of elementary reflectors (see Further Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,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 . . . H(2)**H H(1)**H, where k = min(m,n).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(1:i-1) = 0 and v(i) = 1; conjg(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 cgelqf.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 COMPLEX 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 cgelq2, clarfb, clarft, 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, 'CGELQF', ' ', 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( 'CGELQF', -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, 'CGELQF', ' ', 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, 'CGELQF', ' ', 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 cgelq2( 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 clarft( '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 clarfb( '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 cgelq2( 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 CGELQF
273*
cgelq2
subroutine cgelq2(m, n, a, lda, tau, work, info)
CGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition cgelq2.f:129
clarft
subroutine clarft(direct, storev, n, k, v, ldv, tau, t, ldt)
CLARFT forms the triangular factor T of a block reflector H = I - vtvH
Definition clarft.f:163

◆ cgemqrt()

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

CGEMQRT

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

Purpose:
!>
!> CGEMQRT 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 orthogonal 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 CGEQRT.
!>
!> 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]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 CGEQRT.
!>
[in]V
!>          V is COMPLEX array, dimension (LDV,K)
!>          The i-th column must contain the vector which defines the
!>          elementary reflector H(i), for i = 1,2,...,k, as returned by
!>          CGEQRT 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 COMPLEX array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by CGEQRT, 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 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*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 cgemqrt.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 COMPLEX 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, clarfb
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( 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( 'CGEMQRT', -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 clarfb( 'L', 'C', '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 clarfb( '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 clarfb( '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 clarfb( 'R', 'C', '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 CGEMQRT
287*

◆ cgeql2()

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

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

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

Purpose:
!>
!> CGEQL2 computes a QL factorization of a complex 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 COMPLEX 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
!>          unitary matrix Q as a product of elementary reflectors
!>          (see Further Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  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**H
!>
!>  where tau is a complex scalar, and v is a complex 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 cgeql2.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 COMPLEX A( LDA, * ), TAU( * ), WORK( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 COMPLEX ONE
139 parameter( one = ( 1.0e+0, 0.0e+0 ) )
140* ..
141* .. Local Scalars ..
142 INTEGER I, K
143 COMPLEX ALPHA
144* ..
145* .. External Subroutines ..
146 EXTERNAL clarf, clarfg, xerbla
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC conjg, 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( 'CGEQL2', -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 alpha = a( m-k+i, n-k+i )
176 CALL clarfg( m-k+i, alpha, a( 1, n-k+i ), 1, tau( i ) )
177*
178* Apply H(i)**H to A(1:m-k+i,1:n-k+i-1) from the left
179*
180 a( m-k+i, n-k+i ) = one
181 CALL clarf( 'Left', m-k+i, n-k+i-1, a( 1, n-k+i ), 1,
182 $ conjg( tau( i ) ), a, lda, work )
183 a( m-k+i, n-k+i ) = alpha
184 10 CONTINUE
185 RETURN
186*
187* End of CGEQL2
188*

◆ cgeqlf()

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

CGEQLF

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

Purpose:
!>
!> CGEQLF computes a QL factorization of a complex 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 COMPLEX 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
!>          unitary matrix Q as a product of elementary reflectors
!>          (see Further Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>          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**H
!>
!>  where tau is a complex scalar, and v is a complex 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 cgeqlf.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 COMPLEX 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 cgeql2, clarfb, clarft, 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, 'CGEQLF', ' ', 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( 'CGEQLF', -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, 'CGEQLF', ' ', 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, 'CGEQLF', ' ', 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 cgeql2( 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 clarft( 'Backward', 'Columnwise', m-k+i+ib-1, ib,
257 $ a( 1, n-k+i ), lda, tau( i ), work, ldwork )
258*
259* Apply H**H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
260*
261 CALL clarfb( 'Left', 'Conjugate 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 cgeql2( mu, nu, a, lda, tau, work, iinfo )
278*
279 work( 1 ) = iws
280 RETURN
281*
282* End of CGEQLF
283*
cgeql2
subroutine cgeql2(m, n, a, lda, tau, work, info)
CGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.
Definition cgeql2.f:123

◆ cgeqp3()

subroutine cgeqp3 ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) jpvt,
complex, dimension( * ) tau,
complex, dimension( * ) work,
integer lwork,
real, dimension( * ) rwork,
integer info )

CGEQP3

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

Purpose:
!>
!> CGEQP3 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 COMPLEX 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
!>          unitary 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 COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO=0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= N+1.
!>          For optimal performance LWORK >= ( N+1 )*NB, where NB
!>          is the optimal blocksize.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit.
!>          < 0: if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
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**H
!>
!>  where tau is a complex 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 157 of file cgeqp3.f.

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

◆ cgeqpf()

subroutine cgeqpf ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) jpvt,
complex, dimension( * ) tau,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CGEQPF

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine CGEQP3.
!>
!> CGEQPF computes a QR factorization with column pivoting of a
!> complex 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 COMPLEX 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 unitary 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 COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
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**H
!>
!>  where tau is a complex scalar, and v is a 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).
!>
!>  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 147 of file cgeqpf.f.

148*
149* -- LAPACK computational routine --
150* -- LAPACK is a software package provided by Univ. of Tennessee, --
151* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
152*
153* .. Scalar Arguments ..
154 INTEGER INFO, LDA, M, N
155* ..
156* .. Array Arguments ..
157 INTEGER JPVT( * )
158 REAL RWORK( * )
159 COMPLEX A( LDA, * ), TAU( * ), WORK( * )
160* ..
161*
162* =====================================================================
163*
164* .. Parameters ..
165 REAL ZERO, ONE
166 parameter( zero = 0.0e+0, one = 1.0e+0 )
167* ..
168* .. Local Scalars ..
169 INTEGER I, ITEMP, J, MA, MN, PVT
170 REAL TEMP, TEMP2, TOL3Z
171 COMPLEX AII
172* ..
173* .. External Subroutines ..
174 EXTERNAL cgeqr2, clarf, clarfg, cswap, cunm2r, xerbla
175* ..
176* .. Intrinsic Functions ..
177 INTRINSIC abs, cmplx, conjg, max, min, sqrt
178* ..
179* .. External Functions ..
180 INTEGER ISAMAX
181 REAL SCNRM2, SLAMCH
182 EXTERNAL isamax, scnrm2, slamch
183* ..
184* .. Executable Statements ..
185*
186* Test the input arguments
187*
188 info = 0
189 IF( m.LT.0 ) THEN
190 info = -1
191 ELSE IF( n.LT.0 ) THEN
192 info = -2
193 ELSE IF( lda.LT.max( 1, m ) ) THEN
194 info = -4
195 END IF
196 IF( info.NE.0 ) THEN
197 CALL xerbla( 'CGEQPF', -info )
198 RETURN
199 END IF
200*
201 mn = min( m, n )
202 tol3z = sqrt(slamch('Epsilon'))
203*
204* Move initial columns up front
205*
206 itemp = 1
207 DO 10 i = 1, n
208 IF( jpvt( i ).NE.0 ) THEN
209 IF( i.NE.itemp ) THEN
210 CALL cswap( m, a( 1, i ), 1, a( 1, itemp ), 1 )
211 jpvt( i ) = jpvt( itemp )
212 jpvt( itemp ) = i
213 ELSE
214 jpvt( i ) = i
215 END IF
216 itemp = itemp + 1
217 ELSE
218 jpvt( i ) = i
219 END IF
220 10 CONTINUE
221 itemp = itemp - 1
222*
223* Compute the QR factorization and update remaining columns
224*
225 IF( itemp.GT.0 ) THEN
226 ma = min( itemp, m )
227 CALL cgeqr2( m, ma, a, lda, tau, work, info )
228 IF( ma.LT.n ) THEN
229 CALL cunm2r( 'Left', 'Conjugate transpose', m, n-ma, ma, a,
230 $ lda, tau, a( 1, ma+1 ), lda, work, info )
231 END IF
232 END IF
233*
234 IF( itemp.LT.mn ) THEN
235*
236* Initialize partial column norms. The first n elements of
237* work store the exact column norms.
238*
239 DO 20 i = itemp + 1, n
240 rwork( i ) = scnrm2( m-itemp, a( itemp+1, i ), 1 )
241 rwork( n+i ) = rwork( i )
242 20 CONTINUE
243*
244* Compute factorization
245*
246 DO 40 i = itemp + 1, mn
247*
248* Determine ith pivot column and swap if necessary
249*
250 pvt = ( i-1 ) + isamax( n-i+1, rwork( i ), 1 )
251*
252 IF( pvt.NE.i ) THEN
253 CALL cswap( m, a( 1, pvt ), 1, a( 1, i ), 1 )
254 itemp = jpvt( pvt )
255 jpvt( pvt ) = jpvt( i )
256 jpvt( i ) = itemp
257 rwork( pvt ) = rwork( i )
258 rwork( n+pvt ) = rwork( n+i )
259 END IF
260*
261* Generate elementary reflector H(i)
262*
263 aii = a( i, i )
264 CALL clarfg( m-i+1, aii, a( min( i+1, m ), i ), 1,
265 $ tau( i ) )
266 a( i, i ) = aii
267*
268 IF( i.LT.n ) THEN
269*
270* Apply H(i) to A(i:m,i+1:n) from the left
271*
272 aii = a( i, i )
273 a( i, i ) = cmplx( one )
274 CALL clarf( 'Left', m-i+1, n-i, a( i, i ), 1,
275 $ conjg( tau( i ) ), a( i, i+1 ), lda, work )
276 a( i, i ) = aii
277 END IF
278*
279* Update partial column norms
280*
281 DO 30 j = i + 1, n
282 IF( rwork( j ).NE.zero ) THEN
283*
284* NOTE: The following 4 lines follow from the analysis in
285* Lapack Working Note 176.
286*
287 temp = abs( a( i, j ) ) / rwork( j )
288 temp = max( zero, ( one+temp )*( one-temp ) )
289 temp2 = temp*( rwork( j ) / rwork( n+j ) )**2
290 IF( temp2 .LE. tol3z ) THEN
291 IF( m-i.GT.0 ) THEN
292 rwork( j ) = scnrm2( m-i, a( i+1, j ), 1 )
293 rwork( n+j ) = rwork( j )
294 ELSE
295 rwork( j ) = zero
296 rwork( n+j ) = zero
297 END IF
298 ELSE
299 rwork( j ) = rwork( j )*sqrt( temp )
300 END IF
301 END IF
302 30 CONTINUE
303*
304 40 CONTINUE
305 END IF
306 RETURN
307*
308* End of CGEQPF
309*
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
cgeqr2
subroutine cgeqr2(m, n, a, lda, tau, work, info)
CGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition cgeqr2.f:130
cunm2r
subroutine cunm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
CUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...
Definition cunm2r.f:159

◆ cgeqr2()

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

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

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

Purpose:
!>
!> CGEQR2 computes a QR factorization of a complex 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 COMPLEX 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 unitary matrix Q as a
!>          product of elementary reflectors (see Further Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  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**H
!>
!>  where tau is a complex scalar, and v is a 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).
!>

Definition at line 129 of file cgeqr2.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 COMPLEX A( LDA, * ), TAU( * ), WORK( * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 COMPLEX ONE
146 parameter( one = ( 1.0e+0, 0.0e+0 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER I, K
150 COMPLEX ALPHA
151* ..
152* .. External Subroutines ..
153 EXTERNAL clarf, clarfg, xerbla
154* ..
155* .. Intrinsic Functions ..
156 INTRINSIC conjg, 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( 'CGEQR2', -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 clarfg( 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)**H to A(i:m,i+1:n) from the left
186*
187 alpha = a( i, i )
188 a( i, i ) = one
189 CALL clarf( 'Left', m-i+1, n-i, a( i, i ), 1,
190 $ conjg( tau( i ) ), a( i, i+1 ), lda, work )
191 a( i, i ) = alpha
192 END IF
193 10 CONTINUE
194 RETURN
195*
196* End of CGEQR2
197*

◆ cgeqr2p()

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

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

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

Purpose:
!>
!> CGEQR2P computes a QR factorization of a complex 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 COMPLEX 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
!>          real and nonnegative; the elements below the diagonal,
!>          with the array TAU, represent the unitary matrix Q as a
!>          product of elementary reflectors (see Further Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  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**H
!>
!>  where tau is a complex scalar, and v is a 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).
!>
!> See Lapack Working Note 203 for details
!>

Definition at line 133 of file cgeqr2p.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 COMPLEX A( LDA, * ), TAU( * ), WORK( * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 COMPLEX ONE
150 parameter( one = ( 1.0e+0, 0.0e+0 ) )
151* ..
152* .. Local Scalars ..
153 INTEGER I, K
154 COMPLEX ALPHA
155* ..
156* .. External Subroutines ..
157 EXTERNAL clarf, clarfgp, xerbla
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC conjg, 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( 'CGEQR2P', -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 clarfgp( 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)**H to A(i:m,i+1:n) from the left
190*
191 alpha = a( i, i )
192 a( i, i ) = one
193 CALL clarf( 'Left', m-i+1, n-i, a( i, i ), 1,
194 $ conjg( tau( i ) ), a( i, i+1 ), lda, work )
195 a( i, i ) = alpha
196 END IF
197 10 CONTINUE
198 RETURN
199*
200* End of CGEQR2P
201*
clarfgp
subroutine clarfgp(n, alpha, x, incx, tau)
CLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.
Definition clarfgp.f:104

◆ cgeqrf()

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

CGEQRF

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

Purpose:
!>
!> CGEQRF computes a QR factorization of a complex 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 COMPLEX 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 unitary 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 COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          LWORK >= 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**H
!>
!>  where tau is a complex scalar, and v is a 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).
!>

Definition at line 145 of file cgeqrf.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 COMPLEX 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 cgeqr2, clarfb, clarft, 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, 'CGEQRF', ' ', 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( 'CGEQRF', -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, 'CGEQRF', ' ', 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, 'CGEQRF', ' ', 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 cgeqr2( 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 clarft( 'Forward', 'Columnwise', m-i+1, ib,
257 $ a( i, i ), lda, tau( i ), work, ldwork )
258*
259* Apply H**H to A(i:m,i+ib:n) from the left
260*
261 CALL clarfb( 'Left', 'Conjugate 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 cgeqr2( 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 CGEQRF
281*

◆ cgeqrfp()

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

CGEQRFP

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

Purpose:
!>
!> CGEQR2P computes a QR factorization of a complex 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 COMPLEX 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 real and nonnegative; the elements below the diagonal,
!>          with the array TAU, represent the unitary 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 COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>          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**H
!>
!>  where tau is a complex scalar, and v is a 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).
!>
!> See Lapack Working Note 203 for details
!>

Definition at line 148 of file cgeqrfp.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 COMPLEX 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 cgeqr2p, clarfb, clarft, 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, 'CGEQRF', ' ', 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( 'CGEQRFP', -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, 'CGEQRF', ' ', 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, 'CGEQRF', ' ', 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 cgeqr2p( 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 clarft( 'Forward', 'Columnwise', m-i+1, ib,
255 $ a( i, i ), lda, tau( i ), work, ldwork )
256*
257* Apply H**H to A(i:m,i+ib:n) from the left
258*
259 CALL clarfb( 'Left', 'Conjugate 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 cgeqr2p( 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 CGEQRFP
279*
cgeqr2p
subroutine cgeqr2p(m, n, a, lda, tau, work, info)
CGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elem...
Definition cgeqr2p.f:134

◆ cgeqrt()

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

CGEQRT

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

Purpose:
!>
!> CGEQRT computes a blocked QR 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]NB
!>          NB is INTEGER
!>          The block size to be used in the blocked QR.  MIN(M,N) >= NB >= 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 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 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 >= NB.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NB*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The 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 cgeqrt.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 COMPLEX 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 cgeqrt2, cgeqrt3, clarfb, 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( 'CGEQRT', -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 cgeqrt3( m-i+1, ib, a(i,i), lda, t(1,i), ldt, iinfo )
199 ELSE
200 CALL cgeqrt2( 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**H to A(I:M,I+IB:N) from the left
205*
206 CALL clarfb( 'L', 'C', '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 CGEQRT
214*
cgeqrt2
subroutine cgeqrt2(m, n, a, lda, t, ldt, info)
CGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY represen...
Definition cgeqrt2.f:127
cgeqrt3
recursive subroutine cgeqrt3(m, n, a, lda, t, ldt, info)
CGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact...
Definition cgeqrt3.f:132

◆ cgeqrt2()

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

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

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

Purpose:
!>
!> CGEQRT2 computes a QR 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 >= 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
!>          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 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 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**H
!>
!>  where V**H is the conjugate transpose of V.
!>

Definition at line 126 of file cgeqrt2.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 COMPLEX A( LDA, * ), T( LDT, * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 COMPLEX ONE, ZERO
143 parameter( one = (1.0,0.0), zero = (0.0,0.0) )
144* ..
145* .. Local Scalars ..
146 INTEGER I, K
147 COMPLEX AII, ALPHA
148* ..
149* .. External Subroutines ..
150 EXTERNAL clarfg, cgemv, cgerc, ctrmv, 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( 'CGEQRT2', -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 clarfg( 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 cgemv( 'C',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 = -conjg(t( i, 1 ))
194 CALL cgerc( 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)**H * A(I:M,I)
205*
206 alpha = -t( i, 1 )
207 CALL cgemv( 'C', 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 ctrmv( '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 CGEQRT2
223*
ctrmv
subroutine ctrmv(uplo, trans, diag, n, a, lda, x, incx)
CTRMV
Definition ctrmv.f:147
cgemv
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
Definition cgemv.f:158
cgerc
subroutine cgerc(m, n, alpha, x, incx, y, incy, a, lda)
CGERC
Definition cgerc.f:130

◆ cgeqrt3()

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

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

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

Purpose:
!>
!> CGEQRT3 recursively computes a QR 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
!>          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 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 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**H
!>
!>  where V**H is the conjugate transpose of V.
!>
!>  For details of the algorithm, see Elmroth and Gustavson (cited above).
!>

Definition at line 131 of file cgeqrt3.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 COMPLEX A( LDA, * ), T( LDT, * )
142* ..
143*
144* =====================================================================
145*
146* .. Parameters ..
147 COMPLEX ONE
148 parameter( one = (1.0,0.0) )
149* ..
150* .. Local Scalars ..
151 INTEGER I, I1, J, J1, N1, N2, IINFO
152* ..
153* .. External Subroutines ..
154 EXTERNAL clarfg, ctrmm, cgemm, 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( 'CGEQRT3', -info )
170 RETURN
171 END IF
172*
173 IF( n.EQ.1 ) THEN
174*
175* Compute Householder transform when N=1
176*
177 CALL clarfg( 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 cgeqrt3( 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 ctrmm( 'L', 'L', 'C', 'U', n1, n2, one,
200 & a, lda, t( 1, j1 ), ldt )
201*
202 CALL cgemm( 'C', 'N', n1, n2, m-n1, one, a( j1, 1 ), lda,
203 & a( j1, j1 ), lda, one, t( 1, j1 ), ldt)
204*
205 CALL ctrmm( 'L', 'U', 'C', 'N', n1, n2, one,
206 & t, ldt, t( 1, j1 ), ldt )
207*
208 CALL cgemm( 'N', 'N', m-n1, n2, n1, -one, a( j1, 1 ), lda,
209 & t( 1, j1 ), ldt, one, a( j1, j1 ), lda )
210*
211 CALL ctrmm( '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 cgeqrt3( 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 ) = conjg(a( j+n1, i ))
230 END DO
231 END DO
232*
233 CALL ctrmm( 'R', 'L', 'N', 'U', n1, n2, one,
234 & a( j1, j1 ), lda, t( 1, j1 ), ldt )
235*
236 CALL cgemm( 'C', 'N', n1, n2, m-n, one, a( i1, 1 ), lda,
237 & a( i1, j1 ), lda, one, t( 1, j1 ), ldt )
238*
239 CALL ctrmm( 'L', 'U', 'N', 'N', n1, n2, -one, t, ldt,
240 & t( 1, j1 ), ldt )
241*
242 CALL ctrmm( '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 CGEQRT3
253*

◆ cgerfs()

subroutine cgerfs ( character trans,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldx, * ) x,
integer ldx,
real, dimension( * ) ferr,
real, dimension( * ) berr,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CGERFS

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

Purpose:
!>
!> CGERFS 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)
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The 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 COMPLEX array, dimension (LDAF,N)
!>          The factors L and U from the factorization A = P*L*U
!>          as computed by CGETRF.
!>
[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 CGETRF; for 1<=i<=N, row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[in]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]X
!>          X is COMPLEX array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by CGETRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is REAL array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is REAL array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Internal Parameters:
!>  ITMAX is the maximum number of steps of iterative refinement.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 184 of file cgerfs.f.

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

◆ cgerfsx()

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

CGERFSX

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

Purpose:
!>
!>    CGERFSX 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)
!>
[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 COMPLEX 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 COMPLEX array, dimension (LDAF,N)
!>     The factors L and U from the factorization A = P*L*U
!>     as computed by CGETRF.
!>
[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 CGETRF; for 1<=i<=N, row i of the
!>     matrix was interchanged with row IPIV(i).
!>
[in]R
!>          R is REAL 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 REAL 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 COMPLEX array, dimension (LDB,NRHS)
!>     The right hand side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>     The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]X
!>          X is COMPLEX array, dimension (LDX,NRHS)
!>     On entry, the solution matrix X, as computed by CGETRS.
!>     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 REAL
!>     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 REAL 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 REAL 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) * 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.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[out]ERR_BNDS_COMP
!>          ERR_BNDS_COMP is REAL 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) * 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.
!>
!>     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 REAL 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.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 COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (2*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 cgerfsx.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 REAL RCOND
424* ..
425* .. Array Arguments ..
426 INTEGER IPIV( * )
427 COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
428 $ X( LDX , * ), WORK( * )
429 REAL R( * ), C( * ), PARAMS( * ), BERR( * ),
430 $ ERR_BNDS_NORM( NRHS, * ),
431 $ ERR_BNDS_COMP( NRHS, * ), RWORK( * )
432* ..
433*
434* ==================================================================
435*
436* .. Parameters ..
437 REAL ZERO, ONE
438 parameter( zero = 0.0e+0, one = 1.0e+0 )
439 REAL ITREF_DEFAULT, ITHRESH_DEFAULT,
440 $ COMPONENTWISE_DEFAULT
441 REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT
442 parameter( itref_default = 1.0 )
443 parameter( ithresh_default = 10.0 )
444 parameter( componentwise_default = 1.0 )
445 parameter( rthresh_default = 0.5 )
446 parameter( dzthresh_default = 0.25 )
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 REAL ANORM, RCOND_TMP
463 REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
464 LOGICAL IGNORE_CWISE
465 INTEGER ITHRESH
466 REAL RTHRESH, UNSTABLE_THRESH
467* ..
468* .. External Subroutines ..
469 EXTERNAL xerbla, cgecon, cla_gerfsx_extended
470* ..
471* .. Intrinsic Functions ..
472 INTRINSIC max, sqrt, transfer
473* ..
474* .. External Functions ..
475 EXTERNAL lsame, ilatrans, ilaprec
476 EXTERNAL slamch, clange, cla_gercond_x, cla_gercond_c
477 REAL SLAMCH, CLANGE, CLA_GERCOND_X, CLA_GERCOND_C
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.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 = real( n ) * slamch( 'Epsilon' )
499 ithresh = int( ithresh_default )
500 rthresh = rthresh_default
501 unstable_thresh = dzthresh_default
502 ignore_cwise = componentwise_default .EQ. 0.0
503*
504 IF ( nparams.GE.la_linrx_ithresh_i ) THEN
505 IF ( params( la_linrx_ithresh_i ).LT.0.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.0 ) THEN
513 IF ( ignore_cwise ) THEN
514 params( la_linrx_cwise_i ) = 0.0
515 ELSE
516 params( la_linrx_cwise_i ) = 1.0
517 END IF
518 ELSE
519 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.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( 'CGERFSX', -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.0
563 DO j = 1, nrhs
564 berr( j ) = 0.0
565 IF ( n_err_bnds .GE. 1 ) THEN
566 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
567 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
568 END IF
569 IF ( n_err_bnds .GE. 2 ) THEN
570 err_bnds_norm( j, la_linrx_err_i ) = 0.0
571 err_bnds_comp( j, la_linrx_err_i ) = 0.0
572 END IF
573 IF ( n_err_bnds .GE. 3 ) THEN
574 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0
575 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0
576 END IF
577 END DO
578 RETURN
579 END IF
580*
581* Default to failure.
582*
583 rcond = 0.0
584 DO j = 1, nrhs
585 berr( j ) = 1.0
586 IF ( n_err_bnds .GE. 1 ) THEN
587 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
588 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
589 END IF
590 IF ( n_err_bnds .GE. 2 ) THEN
591 err_bnds_norm( j, la_linrx_err_i ) = 1.0
592 err_bnds_comp( j, la_linrx_err_i ) = 1.0
593 END IF
594 IF ( n_err_bnds .GE. 3 ) THEN
595 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0
596 err_bnds_comp( j, la_linrx_rcond_i ) = 0.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 = clange( norm, n, n, a, lda, rwork )
609 CALL cgecon( norm, n, af, ldaf, anorm, rcond, work, rwork, info )
610*
611* Perform refinement on each right-hand side
612*
613 IF ( ref_type .NE. 0 ) THEN
614
615 prec_type = ilaprec( 'D' )
616
617 IF ( notran ) THEN
618 CALL cla_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, rwork, work(n+1),
622 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n),
623 $ rcond, ithresh, rthresh, unstable_thresh, ignore_cwise,
624 $ info )
625 ELSE
626 CALL cla_gerfsx_extended( prec_type, trans_type, n,
627 $ nrhs, a, lda, af, ldaf, ipiv, rowequ, r, b,
628 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
629 $ err_bnds_comp, work, rwork, work(n+1),
630 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n),
631 $ rcond, ithresh, rthresh, unstable_thresh, ignore_cwise,
632 $ info )
633 END IF
634 END IF
635
636 err_lbnd = max( 10.0, sqrt( real( n ) ) ) * slamch( 'Epsilon' )
637 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 ) THEN
638*
639* Compute scaled normwise condition number cond(A*C).
640*
641 IF ( colequ .AND. notran ) THEN
642 rcond_tmp = cla_gercond_c( trans, n, a, lda, af, ldaf, ipiv,
643 $ c, .true., info, work, rwork )
644 ELSE IF ( rowequ .AND. .NOT. notran ) THEN
645 rcond_tmp = cla_gercond_c( trans, n, a, lda, af, ldaf, ipiv,
646 $ r, .true., info, work, rwork )
647 ELSE
648 rcond_tmp = cla_gercond_c( trans, n, a, lda, af, ldaf, ipiv,
649 $ c, .false., info, work, rwork )
650 END IF
651 DO j = 1, nrhs
652*
653* Cap the error at 1.0.
654*
655 IF ( n_err_bnds .GE. la_linrx_err_i
656 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0 )
657 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0
658*
659* Threshold the error (see LAWN).
660*
661 IF ( rcond_tmp .LT. illrcond_thresh ) THEN
662 err_bnds_norm( j, la_linrx_err_i ) = 1.0
663 err_bnds_norm( j, la_linrx_trust_i ) = 0.0
664 IF ( info .LE. n ) info = n + j
665 ELSE IF (err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd)
666 $ THEN
667 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
668 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
669 END IF
670*
671* Save the condition number.
672*
673 IF ( n_err_bnds .GE. la_linrx_rcond_i ) THEN
674 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
675 END IF
676 END DO
677 END IF
678
679 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 2 ) THEN
680*
681* Compute componentwise condition number cond(A*diag(Y(:,J))) for
682* each right-hand side using the current solution as an estimate of
683* the true solution. If the componentwise error estimate is too
684* large, then the solution is a lousy estimate of truth and the
685* estimated RCOND may be too optimistic. To avoid misleading users,
686* the inverse condition number is set to 0.0 when the estimated
687* cwise error is at least CWISE_WRONG.
688*
689 cwise_wrong = sqrt( slamch( 'Epsilon' ) )
690 DO j = 1, nrhs
691 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
692 $ THEN
693 rcond_tmp = cla_gercond_x( trans, n, a, lda, af, ldaf,
694 $ ipiv, x(1,j), info, work, rwork )
695 ELSE
696 rcond_tmp = 0.0
697 END IF
698*
699* Cap the error at 1.0.
700*
701 IF ( n_err_bnds .GE. la_linrx_err_i
702 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0 )
703 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0
704*
705* Threshold the error (see LAWN).
706*
707 IF ( rcond_tmp .LT. illrcond_thresh ) THEN
708 err_bnds_comp( j, la_linrx_err_i ) = 1.0
709 err_bnds_comp( j, la_linrx_trust_i ) = 0.0
710 IF ( params( la_linrx_cwise_i ) .EQ. 1.0
711 $ .AND. info.LT.n + j ) info = n + j
712 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
713 $ .LT. err_lbnd ) THEN
714 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
715 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
716 END IF
717*
718* Save the condition number.
719*
720 IF ( n_err_bnds .GE. la_linrx_rcond_i ) THEN
721 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
722 END IF
723
724 END DO
725 END IF
726*
727 RETURN
728*
729* End of CGERFSX
730*
ilaprec
integer function ilaprec(prec)
ILAPREC
Definition ilaprec.f:58
ilatrans
integer function ilatrans(trans)
ILATRANS
Definition ilatrans.f:58
clange
real function clange(norm, m, n, a, lda, work)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clange.f:115
cla_gerfsx_extended
subroutine cla_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)
CLA_GERFSX_EXTENDED
Definition cla_gerfsx_extended.f:397
cla_gercond_c
real function cla_gercond_c(trans, n, a, lda, af, ldaf, ipiv, c, capply, info, work, rwork)
CLA_GERCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for general matrices.
Definition cla_gercond_c.f:142
cgecon
subroutine cgecon(norm, n, a, lda, anorm, rcond, work, rwork, info)
CGECON
Definition cgecon.f:124
cla_gercond_x
real function cla_gercond_x(trans, n, a, lda, af, ldaf, ipiv, x, info, work, rwork)
CLA_GERCOND_X computes the infinity norm condition number of op(A)*diag(x) for general matrices.
Definition cla_gercond_x.f:135

◆ cgerq2()

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

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

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

Purpose:
!>
!> CGERQ2 computes an RQ factorization of a complex 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 COMPLEX array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, if m <= n, the upper triangle of the subarray
!>          A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
!>          if m >= n, the elements on and above the (m-n)-th subdiagonal
!>          contain the m by n upper trapezoidal matrix R; the remaining
!>          elements, with the array TAU, represent the unitary matrix
!>          Q as a product of elementary reflectors (see Further
!>          Details).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX 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 H(2)**H . . . H(k)**H, where k = min(m,n).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(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 cgerq2.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 COMPLEX A( LDA, * ), TAU( * ), WORK( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 COMPLEX ONE
139 parameter( one = ( 1.0e+0, 0.0e+0 ) )
140* ..
141* .. Local Scalars ..
142 INTEGER I, K
143 COMPLEX ALPHA
144* ..
145* .. External Subroutines ..
146 EXTERNAL clacgv, clarf, clarfg, 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( 'CGERQ2', -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 clacgv( n-k+i, a( m-k+i, 1 ), lda )
176 alpha = a( m-k+i, n-k+i )
177 CALL clarfg( n-k+i, alpha, a( m-k+i, 1 ), lda,
178 $ tau( i ) )
179*
180* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
181*
182 a( m-k+i, n-k+i ) = one
183 CALL clarf( 'Right', m-k+i-1, n-k+i, a( m-k+i, 1 ), lda,
184 $ tau( i ), a, lda, work )
185 a( m-k+i, n-k+i ) = alpha
186 CALL clacgv( n-k+i-1, a( m-k+i, 1 ), lda )
187 10 CONTINUE
188 RETURN
189*
190* End of CGERQ2
191*

◆ cgerqf()

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

CGERQF

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

Purpose:
!>
!> CGERQF computes an RQ factorization of a complex 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 COMPLEX array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit,
!>          if m <= n, the upper triangle of the subarray
!>          A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
!>          if m >= n, the elements on and above the (m-n)-th subdiagonal
!>          contain the M-by-N upper trapezoidal matrix R;
!>          the remaining elements, with the array TAU, represent the
!>          unitary 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 COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          LWORK >= 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 H(2)**H . . . H(k)**H, where k = min(m,n).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(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 cgerqf.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 COMPLEX 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 cgerq2, clarfb, clarft, 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, 'CGERQF', ' ', 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( 'CGERQF', -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, 'CGERQF', ' ', 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, 'CGERQF', ' ', 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 cgerq2( 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 clarft( '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 clarfb( '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 cgerq2( mu, nu, a, lda, tau, work, iinfo )
280*
281 work( 1 ) = iws
282 RETURN
283*
284* End of CGERQF
285*
cgerq2
subroutine cgerq2(m, n, a, lda, tau, work, info)
CGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition cgerq2.f:123

◆ cgesvj()

subroutine cgesvj ( character*1 joba,
character*1 jobu,
character*1 jobv,
integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( n ) sva,
integer mv,
complex, dimension( ldv, * ) v,
integer ldv,
complex, dimension( lwork ) cwork,
integer lwork,
real, dimension( lrwork ) rwork,
integer lrwork,
integer info )

CGESVJ

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

Purpose:
!>
!> CGESVJ computes the singular value decomposition (SVD) of a complex
!> M-by-N matrix A, where M >= N. The SVD of A is written as
!>                                    [++]   [xx]   [x0]   [xx]
!>              A = U * SIGMA * V^*,  [++] = [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 unitary 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.
!>
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' or 'F': 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=SQRT(M), EPS=SLAMCH('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' or 'J': 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/SLAMCH('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 COMPLEX 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 SLAMCH('S'). The singular
!>                 vectors corresponding to underflowed or zero singular
!>                 values are not computed. The value of RANKA is returned
!>                 in the array RWORK as RANKA=NINT(RWORK(2)). Also see the
!>                 descriptions of SVA and RWORK. The computed columns of U
!>                 are mutually numerically orthogonal up to approximately
!>                 TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU = 'C'),
!>                 see the description of JOBU.
!>                 If INFO > 0,
!>                 the procedure CGESVJ 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^* ||_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 CGESVJ 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 REAL array, dimension (N)
!>          On exit,
!>          If INFO = 0 :
!>          depending on the value SCALE = RWORK(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 CGESVJ 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 CGESVJ
!>          is applied to the first MV rows of V. See the description of JOBV.
!>
[in,out]V
!>          V is COMPLEX 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]CWORK
!>          CWORK is COMPLEX array, dimension (max(1,LWORK))
!>          Used as workspace.
!>          If on entry LWORK = -1, then a workspace query is assumed and
!>          no computation is done; CWORK(1) is set to the minial (and optimal)
!>          length of CWORK.
!>
[in]LWORK
!>          LWORK is INTEGER.
!>          Length of CWORK, LWORK >= M+N.
!>
[in,out]RWORK
!>          RWORK is REAL array, dimension (max(6,LRWORK))
!>          On entry,
!>          If JOBU = 'C' :
!>          RWORK(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=SLAMCH('E').
!>                    It is required that CTOL >= ONE, i.e. it is not
!>                    allowed to force the routine to obtain orthogonality
!>                    below EPSILON.
!>          On exit,
!>          RWORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)
!>                    are the computed singular values of A.
!>                    (See description of SVA().)
!>          RWORK(2) = NINT(RWORK(2)) is the number of the computed nonzero
!>                    singular values.
!>          RWORK(3) = NINT(RWORK(3)) is the number of the computed singular
!>                    values that are larger than the underflow threshold.
!>          RWORK(4) = NINT(RWORK(4)) is the number of sweeps of Jacobi
!>                    rotations needed for numerical convergence.
!>          RWORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.
!>                    This is useful information in cases when CGESVJ did
!>                    not converge, as it can be used to estimate whether
!>                    the output is still useful and for post festum analysis.
!>          RWORK(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.
!>         If on entry LRWORK = -1, then a workspace query is assumed and
!>         no computation is done; RWORK(1) is set to the minial (and optimal)
!>         length of RWORK.
!>
[in]LRWORK
!>         LRWORK is INTEGER
!>         Length of RWORK, LRWORK >= MAX(6,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, then the i-th argument had an illegal value
!>          > 0:  CGESVJ did not converge in the maximal allowed number
!>                (NSWEEP=30) of sweeps. The output may still be useful.
!>                See the description of RWORK.
!>
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. In the case of underflow of the tangent of the Jacobi angle, a
!> modified Jacobi transformation of Drmac [3] is used. Pivot strategy uses
!> column interchanges of de Rijk [1]. 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 [2].
!> 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 [4,5], and it is the kernel routine in the SIGMA library [6].
!> 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.
!>
Contributor:
!>
!>  ============
!>
!>  Zlatko Drmac (Zagreb, Croatia)
!>
!>
References:
!>
!> [1] 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.
!> [2] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.
!> [3] 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.
!> [4] 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.
!> [5] 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.
!> [6] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,
!>    QSVD, (H,K)-SVD computations.
!>    Department of Mathematics, University of Zagreb, 2008, 2015.
!>
Bugs, examples and comments:
!>  ===========================
!>  Please report all bugs and send interesting test examples and comments to
!>  drmac@math.hr. Thank you.
!>

Definition at line 349 of file cgesvj.f.

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

◆ cgetf2()

subroutine cgetf2 ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

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

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

Purpose:
!>
!> CGETF2 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 COMPLEX 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 cgetf2.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 COMPLEX A( LDA, * )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 COMPLEX ONE, ZERO
125 parameter( one = ( 1.0e+0, 0.0e+0 ),
126 $ zero = ( 0.0e+0, 0.0e+0 ) )
127* ..
128* .. Local Scalars ..
129 REAL SFMIN
130 INTEGER I, J, JP
131* ..
132* .. External Functions ..
133 REAL SLAMCH
134 INTEGER ICAMAX
135 EXTERNAL slamch, icamax
136* ..
137* .. External Subroutines ..
138 EXTERNAL cgeru, cscal, cswap, xerbla
139* ..
140* .. Intrinsic Functions ..
141 INTRINSIC max, min
142* ..
143* .. Executable Statements ..
144*
145* Test the input parameters.
146*
147 info = 0
148 IF( m.LT.0 ) THEN
149 info = -1
150 ELSE IF( n.LT.0 ) THEN
151 info = -2
152 ELSE IF( lda.LT.max( 1, m ) ) THEN
153 info = -4
154 END IF
155 IF( info.NE.0 ) THEN
156 CALL xerbla( 'CGETF2', -info )
157 RETURN
158 END IF
159*
160* Quick return if possible
161*
162 IF( m.EQ.0 .OR. n.EQ.0 )
163 $ RETURN
164*
165* Compute machine safe minimum
166*
167 sfmin = slamch('S')
168*
169 DO 10 j = 1, min( m, n )
170*
171* Find pivot and test for singularity.
172*
173 jp = j - 1 + icamax( m-j+1, a( j, j ), 1 )
174 ipiv( j ) = jp
175 IF( a( jp, j ).NE.zero ) THEN
176*
177* Apply the interchange to columns 1:N.
178*
179 IF( jp.NE.j )
180 $ CALL cswap( n, a( j, 1 ), lda, a( jp, 1 ), lda )
181*
182* Compute elements J+1:M of J-th column.
183*
184 IF( j.LT.m ) THEN
185 IF( abs(a( j, j )) .GE. sfmin ) THEN
186 CALL cscal( m-j, one / a( j, j ), a( j+1, j ), 1 )
187 ELSE
188 DO 20 i = 1, m-j
189 a( j+i, j ) = a( j+i, j ) / a( j, j )
190 20 CONTINUE
191 END IF
192 END IF
193*
194 ELSE IF( info.EQ.0 ) THEN
195*
196 info = j
197 END IF
198*
199 IF( j.LT.min( m, n ) ) THEN
200*
201* Update trailing submatrix.
202*
203 CALL cgeru( m-j, n-j, -one, a( j+1, j ), 1, a( j, j+1 ),
204 $ lda, a( j+1, j+1 ), lda )
205 END IF
206 10 CONTINUE
207 RETURN
208*
209* End of CGETF2
210*
cscal
subroutine cscal(n, ca, cx, incx)
CSCAL
Definition cscal.f:78
cgeru
subroutine cgeru(m, n, alpha, x, incx, y, incy, a, lda)
CGERU
Definition cgeru.f:130

◆ cgetrf()

subroutine cgetrf ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

CGETRF

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

Purpose:
!>
!> CGETRF 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 COMPLEX 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 cgetrf.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 COMPLEX A( LDA, * )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 COMPLEX ONE
125 parameter( one = ( 1.0e+0, 0.0e+0 ) )
126* ..
127* .. Local Scalars ..
128 INTEGER I, IINFO, J, JB, NB
129* ..
130* .. External Subroutines ..
131 EXTERNAL cgemm, cgetrf2, claswp, ctrsm, 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( 'CGETRF', -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, 'CGETRF', ' ', m, n, -1, -1 )
165 IF( nb.LE.1 .OR. nb.GE.min( m, n ) ) THEN
166*
167* Use unblocked code.
168*
169 CALL cgetrf2( 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 cgetrf2( 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 claswp( 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 claswp( 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 ctrsm( '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 cgemm( '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 CGETRF
221*
cgetrf2
recursive subroutine cgetrf2(m, n, a, lda, ipiv, info)
CGETRF2
Definition cgetrf2.f:113
claswp
subroutine claswp(n, a, lda, k1, k2, ipiv, incx)
CLASWP performs a series of row interchanges on a general rectangular matrix.
Definition claswp.f:115
ctrsm
subroutine ctrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRSM
Definition ctrsm.f:180

◆ cgetrf2()

recursive subroutine cgetrf2 ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
integer info )

CGETRF2

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

◆ cgetri()

subroutine cgetri ( integer n,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( * ) work,
integer lwork,
integer info )

CGETRI

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

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

◆ cgetrs()

subroutine cgetrs ( character trans,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex, dimension( ldb, * ) b,
integer ldb,
integer info )

CGETRS

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

Purpose:
!>
!> CGETRS solves a system of linear equations
!>    A * X = B,  A**T * X = B,  or  A**H * X = B
!> with a general N-by-N matrix A using the LU factorization computed
!> by CGETRF.
!>
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)
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The factors L and U from the factorization A = P*L*U
!>          as computed by CGETRF.
!>
[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 CGETRF; for 1<=i<=N, row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 120 of file cgetrs.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 COMPLEX A( LDA, * ), B( LDB, * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 COMPLEX ONE
139 parameter( one = ( 1.0e+0, 0.0e+0 ) )
140* ..
141* .. Local Scalars ..
142 LOGICAL NOTRAN
143* ..
144* .. External Functions ..
145 LOGICAL LSAME
146 EXTERNAL lsame
147* ..
148* .. External Subroutines ..
149 EXTERNAL claswp, ctrsm, 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( 'CGETRS', -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 claswp( nrhs, b, ldb, 1, n, ipiv, 1 )
189*
190* Solve L*X = B, overwriting B with X.
191*
192 CALL ctrsm( '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 ctrsm( 'Left', 'Upper', 'No transpose', 'Non-unit', n,
198 $ nrhs, one, a, lda, b, ldb )
199 ELSE
200*
201* Solve A**T * X = B or A**H * X = B.
202*
203* Solve U**T *X = B or U**H *X = B, overwriting B with X.
204*
205 CALL ctrsm( 'Left', 'Upper', trans, 'Non-unit', n, nrhs, one,
206 $ a, lda, b, ldb )
207*
208* Solve L**T *X = B, or L**H *X = B overwriting B with X.
209*
210 CALL ctrsm( 'Left', 'Lower', trans, 'Unit', n, nrhs, one, a,
211 $ lda, b, ldb )
212*
213* Apply row interchanges to the solution vectors.
214*
215 CALL claswp( nrhs, b, ldb, 1, n, ipiv, -1 )
216 END IF
217*
218 RETURN
219*
220* End of CGETRS
221*

◆ chgeqz()

subroutine chgeqz ( character job,
character compq,
character compz,
integer n,
integer ilo,
integer ihi,
complex, dimension( ldh, * ) h,
integer ldh,
complex, dimension( ldt, * ) t,
integer ldt,
complex, dimension( * ) alpha,
complex, dimension( * ) beta,
complex, dimension( ldq, * ) q,
integer ldq,
complex, dimension( ldz, * ) z,
integer ldz,
complex, dimension( * ) work,
integer lwork,
real, dimension( * ) rwork,
integer info )

CHGEQZ

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

Purpose:
!>
!> CHGEQZ computes the eigenvalues of a complex matrix pair (H,T),
!> where H is an upper Hessenberg matrix and T is upper triangular,
!> using the single-shift QZ method.
!> Matrix pairs of this type are produced by the reduction to
!> generalized upper Hessenberg form of a complex matrix pair (A,B):
!>
!>    A = Q1*H*Z1**H,  B = Q1*T*Z1**H,
!>
!> as computed by CGGHRD.
!>
!> If JOB='S', then the Hessenberg-triangular pair (H,T) is
!> also reduced to generalized Schur form,
!>
!>    H = Q*S*Z**H,  T = Q*P*Z**H,
!>
!> where Q and Z are unitary matrices and S and P are upper triangular.
!>
!> Optionally, the unitary matrix Q from the generalized Schur
!> factorization may be postmultiplied into an input matrix Q1, and the
!> unitary matrix Z may be postmultiplied into an input matrix Z1.
!> If Q1 and Z1 are the unitary matrices from CGGHRD that reduced
!> the matrix pair (A,B) to generalized Hessenberg form, then the output
!> matrices Q1*Q and Z1*Z are the unitary factors from the generalized
!> Schur factorization of (A,B):
!>
!>    A = (Q1*Q)*S*(Z1*Z)**H,  B = (Q1*Q)*P*(Z1*Z)**H.
!>
!> To avoid overflow, eigenvalues of the matrix pair (H,T)
!> (equivalently, of (A,B)) are computed as a pair of complex values
!> (alpha,beta).  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.
!> The values of alpha and beta for the i-th eigenvalue 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': Computer 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 a unitary 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': Q is initialized to the unit matrix and the matrix Z
!>                 of right Schur vectors of (H,T) is returned;
!>          = 'V': Z must contain a unitary matrix Z1 on entry and
!>                 the product Z1*Z is returned.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices 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 COMPLEX array, dimension (LDH, N)
!>          On entry, the N-by-N upper Hessenberg matrix H.
!>          On exit, if JOB = 'S', H contains the upper triangular
!>          matrix S from the generalized Schur factorization.
!>          If JOB = 'E', the diagonal of H matches that 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 COMPLEX 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.
!>          If JOB = 'E', the diagonal of T matches that 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]ALPHA
!>          ALPHA is COMPLEX array, dimension (N)
!>          The complex scalars alpha that define the eigenvalues of
!>          GNEP.  ALPHA(i) = S(i,i) in the generalized Schur
!>          factorization.
!>
[out]BETA
!>          BETA is COMPLEX array, dimension (N)
!>          The real non-negative scalars beta that define the
!>          eigenvalues of GNEP.  BETA(i) = P(i,i) in the generalized
!>          Schur factorization.
!>
!>          Together, the quantities alpha = ALPHA(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 COMPLEX array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the unitary matrix Q1 used in the
!>          reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPQ = 'I', the unitary matrix of left Schur
!>          vectors of (H,T), and if COMPQ = 'V', the unitary 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 COMPLEX array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the unitary matrix Z1 used in the
!>          reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPZ = 'I', the unitary matrix of right Schur
!>          vectors of (H,T), and if COMPZ = 'V', the unitary 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 COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[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 ALPHA(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 ALPHA(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:
!>
!>  We assume that complex ABS works as long as its value is less than
!>  overflow.
!>

Definition at line 281 of file chgeqz.f.

284*
285* -- LAPACK computational routine --
286* -- LAPACK is a software package provided by Univ. of Tennessee, --
287* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
288*
289* .. Scalar Arguments ..
290 CHARACTER COMPQ, COMPZ, JOB
291 INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
292* ..
293* .. Array Arguments ..
294 REAL RWORK( * )
295 COMPLEX ALPHA( * ), BETA( * ), H( LDH, * ),
296 $ Q( LDQ, * ), T( LDT, * ), WORK( * ),
297 $ Z( LDZ, * )
298* ..
299*
300* =====================================================================
301*
302* .. Parameters ..
303 COMPLEX CZERO, CONE
304 parameter( czero = ( 0.0e+0, 0.0e+0 ),
305 $ cone = ( 1.0e+0, 0.0e+0 ) )
306 REAL ZERO, ONE
307 parameter( zero = 0.0e+0, one = 1.0e+0 )
308 REAL HALF
309 parameter( half = 0.5e+0 )
310* ..
311* .. Local Scalars ..
312 LOGICAL ILAZR2, ILAZRO, ILQ, ILSCHR, ILZ, LQUERY
313 INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
314 $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
315 $ JR, MAXIT
316 REAL ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL,
317 $ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP
318 COMPLEX ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2,
319 $ CTEMP3, ESHIFT, S, SHIFT, SIGNBC,
320 $ U12, X, ABI12, Y
321* ..
322* .. External Functions ..
323 COMPLEX CLADIV
324 LOGICAL LSAME
325 REAL CLANHS, SLAMCH
326 EXTERNAL cladiv, lsame, clanhs, slamch
327* ..
328* .. External Subroutines ..
329 EXTERNAL clartg, claset, crot, cscal, xerbla
330* ..
331* .. Intrinsic Functions ..
332 INTRINSIC abs, aimag, cmplx, conjg, max, min, real, sqrt
333* ..
334* .. Statement Functions ..
335 REAL ABS1
336* ..
337* .. Statement Function definitions ..
338 abs1( x ) = abs( real( x ) ) + abs( aimag( x ) )
339* ..
340* .. Executable Statements ..
341*
342* Decode JOB, COMPQ, COMPZ
343*
344 IF( lsame( job, 'E' ) ) THEN
345 ilschr = .false.
346 ischur = 1
347 ELSE IF( lsame( job, 'S' ) ) THEN
348 ilschr = .true.
349 ischur = 2
350 ELSE
351 ilschr = .true.
352 ischur = 0
353 END IF
354*
355 IF( lsame( compq, 'N' ) ) THEN
356 ilq = .false.
357 icompq = 1
358 ELSE IF( lsame( compq, 'V' ) ) THEN
359 ilq = .true.
360 icompq = 2
361 ELSE IF( lsame( compq, 'I' ) ) THEN
362 ilq = .true.
363 icompq = 3
364 ELSE
365 ilq = .true.
366 icompq = 0
367 END IF
368*
369 IF( lsame( compz, 'N' ) ) THEN
370 ilz = .false.
371 icompz = 1
372 ELSE IF( lsame( compz, 'V' ) ) THEN
373 ilz = .true.
374 icompz = 2
375 ELSE IF( lsame( compz, 'I' ) ) THEN
376 ilz = .true.
377 icompz = 3
378 ELSE
379 ilz = .true.
380 icompz = 0
381 END IF
382*
383* Check Argument Values
384*
385 info = 0
386 work( 1 ) = max( 1, n )
387 lquery = ( lwork.EQ.-1 )
388 IF( ischur.EQ.0 ) THEN
389 info = -1
390 ELSE IF( icompq.EQ.0 ) THEN
391 info = -2
392 ELSE IF( icompz.EQ.0 ) THEN
393 info = -3
394 ELSE IF( n.LT.0 ) THEN
395 info = -4
396 ELSE IF( ilo.LT.1 ) THEN
397 info = -5
398 ELSE IF( ihi.GT.n .OR. ihi.LT.ilo-1 ) THEN
399 info = -6
400 ELSE IF( ldh.LT.n ) THEN
401 info = -8
402 ELSE IF( ldt.LT.n ) THEN
403 info = -10
404 ELSE IF( ldq.LT.1 .OR. ( ilq .AND. ldq.LT.n ) ) THEN
405 info = -14
406 ELSE IF( ldz.LT.1 .OR. ( ilz .AND. ldz.LT.n ) ) THEN
407 info = -16
408 ELSE IF( lwork.LT.max( 1, n ) .AND. .NOT.lquery ) THEN
409 info = -18
410 END IF
411 IF( info.NE.0 ) THEN
412 CALL xerbla( 'CHGEQZ', -info )
413 RETURN
414 ELSE IF( lquery ) THEN
415 RETURN
416 END IF
417*
418* Quick return if possible
419*
420* WORK( 1 ) = CMPLX( 1 )
421 IF( n.LE.0 ) THEN
422 work( 1 ) = cmplx( 1 )
423 RETURN
424 END IF
425*
426* Initialize Q and Z
427*
428 IF( icompq.EQ.3 )
429 $ CALL claset( 'Full', n, n, czero, cone, q, ldq )
430 IF( icompz.EQ.3 )
431 $ CALL claset( 'Full', n, n, czero, cone, z, ldz )
432*
433* Machine Constants
434*
435 in = ihi + 1 - ilo
436 safmin = slamch( 'S' )
437 ulp = slamch( 'E' )*slamch( 'B' )
438 anorm = clanhs( 'F', in, h( ilo, ilo ), ldh, rwork )
439 bnorm = clanhs( 'F', in, t( ilo, ilo ), ldt, rwork )
440 atol = max( safmin, ulp*anorm )
441 btol = max( safmin, ulp*bnorm )
442 ascale = one / max( safmin, anorm )
443 bscale = one / max( safmin, bnorm )
444*
445*
446* Set Eigenvalues IHI+1:N
447*
448 DO 10 j = ihi + 1, n
449 absb = abs( t( j, j ) )
450 IF( absb.GT.safmin ) THEN
451 signbc = conjg( t( j, j ) / absb )
452 t( j, j ) = absb
453 IF( ilschr ) THEN
454 CALL cscal( j-1, signbc, t( 1, j ), 1 )
455 CALL cscal( j, signbc, h( 1, j ), 1 )
456 ELSE
457 CALL cscal( 1, signbc, h( j, j ), 1 )
458 END IF
459 IF( ilz )
460 $ CALL cscal( n, signbc, z( 1, j ), 1 )
461 ELSE
462 t( j, j ) = czero
463 END IF
464 alpha( j ) = h( j, j )
465 beta( j ) = t( j, j )
466 10 CONTINUE
467*
468* If IHI < ILO, skip QZ steps
469*
470 IF( ihi.LT.ilo )
471 $ GO TO 190
472*
473* MAIN QZ ITERATION LOOP
474*
475* Initialize dynamic indices
476*
477* Eigenvalues ILAST+1:N have been found.
478* Column operations modify rows IFRSTM:whatever
479* Row operations modify columns whatever:ILASTM
480*
481* If only eigenvalues are being computed, then
482* IFRSTM is the row of the last splitting row above row ILAST;
483* this is always at least ILO.
484* IITER counts iterations since the last eigenvalue was found,
485* to tell when to use an extraordinary shift.
486* MAXIT is the maximum number of QZ sweeps allowed.
487*
488 ilast = ihi
489 IF( ilschr ) THEN
490 ifrstm = 1
491 ilastm = n
492 ELSE
493 ifrstm = ilo
494 ilastm = ihi
495 END IF
496 iiter = 0
497 eshift = czero
498 maxit = 30*( ihi-ilo+1 )
499*
500 DO 170 jiter = 1, maxit
501*
502* Check for too many iterations.
503*
504 IF( jiter.GT.maxit )
505 $ GO TO 180
506*
507* Split the matrix if possible.
508*
509* Two tests:
510* 1: H(j,j-1)=0 or j=ILO
511* 2: T(j,j)=0
512*
513* Special case: j=ILAST
514*
515 IF( ilast.EQ.ilo ) THEN
516 GO TO 60
517 ELSE
518 IF( abs1( h( ilast, ilast-1 ) ).LE.max( safmin, ulp*(
519 $ abs1( h( ilast, ilast ) ) + abs1( h( ilast-1, ilast-1 )
520 $ ) ) ) ) THEN
521 h( ilast, ilast-1 ) = czero
522 GO TO 60
523 END IF
524 END IF
525*
526 IF( abs( t( ilast, ilast ) ).LE.max( safmin, ulp*(
527 $ abs( t( ilast - 1, ilast ) ) + abs( t( ilast-1, ilast-1 )
528 $ ) ) ) ) THEN
529 t( ilast, ilast ) = czero
530 GO TO 50
531 END IF
532*
533* General case: j<ILAST
534*
535 DO 40 j = ilast - 1, ilo, -1
536*
537* Test 1: for H(j,j-1)=0 or j=ILO
538*
539 IF( j.EQ.ilo ) THEN
540 ilazro = .true.
541 ELSE
542 IF( abs1( h( j, j-1 ) ).LE.max( safmin, ulp*(
543 $ abs1( h( j, j ) ) + abs1( h( j-1, j-1 ) )
544 $ ) ) ) THEN
545 h( j, j-1 ) = czero
546 ilazro = .true.
547 ELSE
548 ilazro = .false.
549 END IF
550 END IF
551*
552* Test 2: for T(j,j)=0
553*
554 temp = abs( t( j, j + 1 ) )
555 IF ( j .GT. ilo )
556 $ temp = temp + abs( t( j - 1, j ) )
557 IF( abs( t( j, j ) ).LT.max( safmin,ulp*temp ) ) THEN
558 t( j, j ) = czero
559*
560* Test 1a: Check for 2 consecutive small subdiagonals in A
561*
562 ilazr2 = .false.
563 IF( .NOT.ilazro ) THEN
564 IF( abs1( h( j, j-1 ) )*( ascale*abs1( h( j+1,
565 $ j ) ) ).LE.abs1( h( j, j ) )*( ascale*atol ) )
566 $ ilazr2 = .true.
567 END IF
568*
569* If both tests pass (1 & 2), i.e., the leading diagonal
570* element of B in the block is zero, split a 1x1 block off
571* at the top. (I.e., at the J-th row/column) The leading
572* diagonal element of the remainder can also be zero, so
573* this may have to be done repeatedly.
574*
575 IF( ilazro .OR. ilazr2 ) THEN
576 DO 20 jch = j, ilast - 1
577 ctemp = h( jch, jch )
578 CALL clartg( ctemp, h( jch+1, jch ), c, s,
579 $ h( jch, jch ) )
580 h( jch+1, jch ) = czero
581 CALL crot( ilastm-jch, h( jch, jch+1 ), ldh,
582 $ h( jch+1, jch+1 ), ldh, c, s )
583 CALL crot( ilastm-jch, t( jch, jch+1 ), ldt,
584 $ t( jch+1, jch+1 ), ldt, c, s )
585 IF( ilq )
586 $ CALL crot( n, q( 1, jch ), 1, q( 1, jch+1 ), 1,
587 $ c, conjg( s ) )
588 IF( ilazr2 )
589 $ h( jch, jch-1 ) = h( jch, jch-1 )*c
590 ilazr2 = .false.
591 IF( abs1( t( jch+1, jch+1 ) ).GE.btol ) THEN
592 IF( jch+1.GE.ilast ) THEN
593 GO TO 60
594 ELSE
595 ifirst = jch + 1
596 GO TO 70
597 END IF
598 END IF
599 t( jch+1, jch+1 ) = czero
600 20 CONTINUE
601 GO TO 50
602 ELSE
603*
604* Only test 2 passed -- chase the zero to T(ILAST,ILAST)
605* Then process as in the case T(ILAST,ILAST)=0
606*
607 DO 30 jch = j, ilast - 1
608 ctemp = t( jch, jch+1 )
609 CALL clartg( ctemp, t( jch+1, jch+1 ), c, s,
610 $ t( jch, jch+1 ) )
611 t( jch+1, jch+1 ) = czero
612 IF( jch.LT.ilastm-1 )
613 $ CALL crot( ilastm-jch-1, t( jch, jch+2 ), ldt,
614 $ t( jch+1, jch+2 ), ldt, c, s )
615 CALL crot( ilastm-jch+2, h( jch, jch-1 ), ldh,
616 $ h( jch+1, jch-1 ), ldh, c, s )
617 IF( ilq )
618 $ CALL crot( n, q( 1, jch ), 1, q( 1, jch+1 ), 1,
619 $ c, conjg( s ) )
620 ctemp = h( jch+1, jch )
621 CALL clartg( ctemp, h( jch+1, jch-1 ), c, s,
622 $ h( jch+1, jch ) )
623 h( jch+1, jch-1 ) = czero
624 CALL crot( jch+1-ifrstm, h( ifrstm, jch ), 1,
625 $ h( ifrstm, jch-1 ), 1, c, s )
626 CALL crot( jch-ifrstm, t( ifrstm, jch ), 1,
627 $ t( ifrstm, jch-1 ), 1, c, s )
628 IF( ilz )
629 $ CALL crot( n, z( 1, jch ), 1, z( 1, jch-1 ), 1,
630 $ c, s )
631 30 CONTINUE
632 GO TO 50
633 END IF
634 ELSE IF( ilazro ) THEN
635*
636* Only test 1 passed -- work on J:ILAST
637*
638 ifirst = j
639 GO TO 70
640 END IF
641*
642* Neither test passed -- try next J
643*
644 40 CONTINUE
645*
646* (Drop-through is "impossible")
647*
648 info = 2*n + 1
649 GO TO 210
650*
651* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a
652* 1x1 block.
653*
654 50 CONTINUE
655 ctemp = h( ilast, ilast )
656 CALL clartg( ctemp, h( ilast, ilast-1 ), c, s,
657 $ h( ilast, ilast ) )
658 h( ilast, ilast-1 ) = czero
659 CALL crot( ilast-ifrstm, h( ifrstm, ilast ), 1,
660 $ h( ifrstm, ilast-1 ), 1, c, s )
661 CALL crot( ilast-ifrstm, t( ifrstm, ilast ), 1,
662 $ t( ifrstm, ilast-1 ), 1, c, s )
663 IF( ilz )
664 $ CALL crot( n, z( 1, ilast ), 1, z( 1, ilast-1 ), 1, c, s )
665*
666* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA
667*
668 60 CONTINUE
669 absb = abs( t( ilast, ilast ) )
670 IF( absb.GT.safmin ) THEN
671 signbc = conjg( t( ilast, ilast ) / absb )
672 t( ilast, ilast ) = absb
673 IF( ilschr ) THEN
674 CALL cscal( ilast-ifrstm, signbc, t( ifrstm, ilast ), 1 )
675 CALL cscal( ilast+1-ifrstm, signbc, h( ifrstm, ilast ),
676 $ 1 )
677 ELSE
678 CALL cscal( 1, signbc, h( ilast, ilast ), 1 )
679 END IF
680 IF( ilz )
681 $ CALL cscal( n, signbc, z( 1, ilast ), 1 )
682 ELSE
683 t( ilast, ilast ) = czero
684 END IF
685 alpha( ilast ) = h( ilast, ilast )
686 beta( ilast ) = t( ilast, ilast )
687*
688* Go to next block -- exit if finished.
689*
690 ilast = ilast - 1
691 IF( ilast.LT.ilo )
692 $ GO TO 190
693*
694* Reset counters
695*
696 iiter = 0
697 eshift = czero
698 IF( .NOT.ilschr ) THEN
699 ilastm = ilast
700 IF( ifrstm.GT.ilast )
701 $ ifrstm = ilo
702 END IF
703 GO TO 160
704*
705* QZ step
706*
707* This iteration only involves rows/columns IFIRST:ILAST. We
708* assume IFIRST < ILAST, and that the diagonal of B is non-zero.
709*
710 70 CONTINUE
711 iiter = iiter + 1
712 IF( .NOT.ilschr ) THEN
713 ifrstm = ifirst
714 END IF
715*
716* Compute the Shift.
717*
718* At this point, IFIRST < ILAST, and the diagonal elements of
719* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
720* magnitude)
721*
722 IF( ( iiter / 10 )*10.NE.iiter ) THEN
723*
724* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of
725* the bottom-right 2x2 block of A inv(B) which is nearest to
726* the bottom-right element.
727*
728* We factor B as U*D, where U has unit diagonals, and
729* compute (A*inv(D))*inv(U).
730*
731 u12 = ( bscale*t( ilast-1, ilast ) ) /
732 $ ( bscale*t( ilast, ilast ) )
733 ad11 = ( ascale*h( ilast-1, ilast-1 ) ) /
734 $ ( bscale*t( ilast-1, ilast-1 ) )
735 ad21 = ( ascale*h( ilast, ilast-1 ) ) /
736 $ ( bscale*t( ilast-1, ilast-1 ) )
737 ad12 = ( ascale*h( ilast-1, ilast ) ) /
738 $ ( bscale*t( ilast, ilast ) )
739 ad22 = ( ascale*h( ilast, ilast ) ) /
740 $ ( bscale*t( ilast, ilast ) )
741 abi22 = ad22 - u12*ad21
742 abi12 = ad12 - u12*ad11
743*
744 shift = abi22
745 ctemp = sqrt( abi12 )*sqrt( ad21 )
746 temp = abs1( ctemp )
747 IF( ctemp.NE.zero ) THEN
748 x = half*( ad11-shift )
749 temp2 = abs1( x )
750 temp = max( temp, abs1( x ) )
751 y = temp*sqrt( ( x / temp )**2+( ctemp / temp )**2 )
752 IF( temp2.GT.zero ) THEN
753 IF( real( x / temp2 )*real( y )+
754 $ aimag( x / temp2 )*aimag( y ).LT.zero )y = -y
755 END IF
756 shift = shift - ctemp*cladiv( ctemp, ( x+y ) )
757 END IF
758 ELSE
759*
760* Exceptional shift. Chosen for no particularly good reason.
761*
762 IF( ( iiter / 20 )*20.EQ.iiter .AND.
763 $ bscale*abs1(t( ilast, ilast )).GT.safmin ) THEN
764 eshift = eshift + ( ascale*h( ilast,
765 $ ilast ) )/( bscale*t( ilast, ilast ) )
766 ELSE
767 eshift = eshift + ( ascale*h( ilast,
768 $ ilast-1 ) )/( bscale*t( ilast-1, ilast-1 ) )
769 END IF
770 shift = eshift
771 END IF
772*
773* Now check for two consecutive small subdiagonals.
774*
775 DO 80 j = ilast - 1, ifirst + 1, -1
776 istart = j
777 ctemp = ascale*h( j, j ) - shift*( bscale*t( j, j ) )
778 temp = abs1( ctemp )
779 temp2 = ascale*abs1( h( j+1, j ) )
780 tempr = max( temp, temp2 )
781 IF( tempr.LT.one .AND. tempr.NE.zero ) THEN
782 temp = temp / tempr
783 temp2 = temp2 / tempr
784 END IF
785 IF( abs1( h( j, j-1 ) )*temp2.LE.temp*atol )
786 $ GO TO 90
787 80 CONTINUE
788*
789 istart = ifirst
790 ctemp = ascale*h( ifirst, ifirst ) -
791 $ shift*( bscale*t( ifirst, ifirst ) )
792 90 CONTINUE
793*
794* Do an implicit-shift QZ sweep.
795*
796* Initial Q
797*
798 ctemp2 = ascale*h( istart+1, istart )
799 CALL clartg( ctemp, ctemp2, c, s, ctemp3 )
800*
801* Sweep
802*
803 DO 150 j = istart, ilast - 1
804 IF( j.GT.istart ) THEN
805 ctemp = h( j, j-1 )
806 CALL clartg( ctemp, h( j+1, j-1 ), c, s, h( j, j-1 ) )
807 h( j+1, j-1 ) = czero
808 END IF
809*
810 DO 100 jc = j, ilastm
811 ctemp = c*h( j, jc ) + s*h( j+1, jc )
812 h( j+1, jc ) = -conjg( s )*h( j, jc ) + c*h( j+1, jc )
813 h( j, jc ) = ctemp
814 ctemp2 = c*t( j, jc ) + s*t( j+1, jc )
815 t( j+1, jc ) = -conjg( s )*t( j, jc ) + c*t( j+1, jc )
816 t( j, jc ) = ctemp2
817 100 CONTINUE
818 IF( ilq ) THEN
819 DO 110 jr = 1, n
820 ctemp = c*q( jr, j ) + conjg( s )*q( jr, j+1 )
821 q( jr, j+1 ) = -s*q( jr, j ) + c*q( jr, j+1 )
822 q( jr, j ) = ctemp
823 110 CONTINUE
824 END IF
825*
826 ctemp = t( j+1, j+1 )
827 CALL clartg( ctemp, t( j+1, j ), c, s, t( j+1, j+1 ) )
828 t( j+1, j ) = czero
829*
830 DO 120 jr = ifrstm, min( j+2, ilast )
831 ctemp = c*h( jr, j+1 ) + s*h( jr, j )
832 h( jr, j ) = -conjg( s )*h( jr, j+1 ) + c*h( jr, j )
833 h( jr, j+1 ) = ctemp
834 120 CONTINUE
835 DO 130 jr = ifrstm, j
836 ctemp = c*t( jr, j+1 ) + s*t( jr, j )
837 t( jr, j ) = -conjg( s )*t( jr, j+1 ) + c*t( jr, j )
838 t( jr, j+1 ) = ctemp
839 130 CONTINUE
840 IF( ilz ) THEN
841 DO 140 jr = 1, n
842 ctemp = c*z( jr, j+1 ) + s*z( jr, j )
843 z( jr, j ) = -conjg( s )*z( jr, j+1 ) + c*z( jr, j )
844 z( jr, j+1 ) = ctemp
845 140 CONTINUE
846 END IF
847 150 CONTINUE
848*
849 160 CONTINUE
850*
851 170 CONTINUE
852*
853* Drop-through = non-convergence
854*
855 180 CONTINUE
856 info = ilast
857 GO TO 210
858*
859* Successful completion of all QZ steps
860*
861 190 CONTINUE
862*
863* Set Eigenvalues 1:ILO-1
864*
865 DO 200 j = 1, ilo - 1
866 absb = abs( t( j, j ) )
867 IF( absb.GT.safmin ) THEN
868 signbc = conjg( t( j, j ) / absb )
869 t( j, j ) = absb
870 IF( ilschr ) THEN
871 CALL cscal( j-1, signbc, t( 1, j ), 1 )
872 CALL cscal( j, signbc, h( 1, j ), 1 )
873 ELSE
874 CALL cscal( 1, signbc, h( j, j ), 1 )
875 END IF
876 IF( ilz )
877 $ CALL cscal( n, signbc, z( 1, j ), 1 )
878 ELSE
879 t( j, j ) = czero
880 END IF
881 alpha( j ) = h( j, j )
882 beta( j ) = t( j, j )
883 200 CONTINUE
884*
885* Normal Termination
886*
887 info = 0
888*
889* Exit (other than argument error) -- return optimal workspace size
890*
891 210 CONTINUE
892 work( 1 ) = cmplx( n )
893 RETURN
894*
895* End of CHGEQZ
896*
clartg
subroutine clartg(f, g, c, s, r)
CLARTG generates a plane rotation with real cosine and complex sine.
Definition clartg.f90:118
cladiv
complex function cladiv(x, y)
CLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
Definition cladiv.f:64
clanhs
real function clanhs(norm, n, a, lda, work)
CLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clanhs.f:109
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ cla_geamv()

subroutine cla_geamv ( integer trans,
integer m,
integer n,
real alpha,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) x,
integer incx,
real beta,
real, dimension( * ) y,
integer incy )

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

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

Purpose:
!>
!> CLA_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 REAL
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]A
!>          A is COMPLEX 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 COMPLEX 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 REAL
!>           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 REAL array, dimension
!>           ( 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 173 of file cla_geamv.f.

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

◆ cla_gercond_c()

real function cla_gercond_c ( character trans,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
real, dimension( * ) c,
logical capply,
integer info,
complex, dimension( * ) work,
real, dimension( * ) rwork )

CLA_GERCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for general matrices.

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

Purpose:
!>
!>
!>    CLA_GERCOND_C computes the infinity norm condition number of
!>    op(A) * inv(diag(C)) where C is a REAL vector.
!>
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 COMPLEX 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 COMPLEX array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by CGETRF.
!>
[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 CGETRF; row i of the matrix was interchanged
!>     with row IPIV(i).
!>
[in]C
!>          C is REAL array, dimension (N)
!>     The vector C in the formula op(A) * inv(diag(C)).
!>
[in]CAPPLY
!>          CAPPLY is LOGICAL
!>     If .TRUE. then access the vector C in the formula above.
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit.
!>     i > 0:  The ith argument is invalid.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N).
!>     Workspace.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N).
!>     Workspace.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 140 of file cla_gercond_c.f.

142*
143* -- LAPACK computational routine --
144* -- LAPACK is a software package provided by Univ. of Tennessee, --
145* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
146*
147* .. Scalar Arguments ..
148 CHARACTER TRANS
149 LOGICAL CAPPLY
150 INTEGER N, LDA, LDAF, INFO
151* ..
152* .. Array Arguments ..
153 INTEGER IPIV( * )
154 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * )
155 REAL C( * ), RWORK( * )
156* ..
157*
158* =====================================================================
159*
160* .. Local Scalars ..
161 LOGICAL NOTRANS
162 INTEGER KASE, I, J
163 REAL AINVNM, ANORM, TMP
164 COMPLEX ZDUM
165* ..
166* .. Local Arrays ..
167 INTEGER ISAVE( 3 )
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 EXTERNAL lsame
172* ..
173* .. External Subroutines ..
174 EXTERNAL clacn2, cgetrs, xerbla
175* ..
176* .. Intrinsic Functions ..
177 INTRINSIC abs, max, real, aimag
178* ..
179* .. Statement Functions ..
180 REAL CABS1
181* ..
182* .. Statement Function Definitions ..
183 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
184* ..
185* .. Executable Statements ..
186 cla_gercond_c = 0.0e+0
187*
188 info = 0
189 notrans = lsame( trans, 'N' )
190 IF ( .NOT. notrans .AND. .NOT. lsame( trans, 'T' ) .AND. .NOT.
191 $ lsame( trans, 'C' ) ) THEN
192 info = -1
193 ELSE IF( n.LT.0 ) THEN
194 info = -2
195 ELSE IF( lda.LT.max( 1, n ) ) THEN
196 info = -4
197 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
198 info = -6
199 END IF
200 IF( info.NE.0 ) THEN
201 CALL xerbla( 'CLA_GERCOND_C', -info )
202 RETURN
203 END IF
204*
205* Compute norm of op(A)*op2(C).
206*
207 anorm = 0.0e+0
208 IF ( notrans ) THEN
209 DO i = 1, n
210 tmp = 0.0e+0
211 IF ( capply ) THEN
212 DO j = 1, n
213 tmp = tmp + cabs1( a( i, j ) ) / c( j )
214 END DO
215 ELSE
216 DO j = 1, n
217 tmp = tmp + cabs1( a( i, j ) )
218 END DO
219 END IF
220 rwork( i ) = tmp
221 anorm = max( anorm, tmp )
222 END DO
223 ELSE
224 DO i = 1, n
225 tmp = 0.0e+0
226 IF ( capply ) THEN
227 DO j = 1, n
228 tmp = tmp + cabs1( a( j, i ) ) / c( j )
229 END DO
230 ELSE
231 DO j = 1, n
232 tmp = tmp + cabs1( a( j, i ) )
233 END DO
234 END IF
235 rwork( i ) = tmp
236 anorm = max( anorm, tmp )
237 END DO
238 END IF
239*
240* Quick return if possible.
241*
242 IF( n.EQ.0 ) THEN
243 cla_gercond_c = 1.0e+0
244 RETURN
245 ELSE IF( anorm .EQ. 0.0e+0 ) THEN
246 RETURN
247 END IF
248*
249* Estimate the norm of inv(op(A)).
250*
251 ainvnm = 0.0e+0
252*
253 kase = 0
254 10 CONTINUE
255 CALL clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
256 IF( kase.NE.0 ) THEN
257 IF( kase.EQ.2 ) THEN
258*
259* Multiply by R.
260*
261 DO i = 1, n
262 work( i ) = work( i ) * rwork( i )
263 END DO
264*
265 IF (notrans) THEN
266 CALL cgetrs( 'No transpose', n, 1, af, ldaf, ipiv,
267 $ work, n, info )
268 ELSE
269 CALL cgetrs( 'Conjugate transpose', n, 1, af, ldaf, ipiv,
270 $ work, n, info )
271 ENDIF
272*
273* Multiply by inv(C).
274*
275 IF ( capply ) THEN
276 DO i = 1, n
277 work( i ) = work( i ) * c( i )
278 END DO
279 END IF
280 ELSE
281*
282* Multiply by inv(C**H).
283*
284 IF ( capply ) THEN
285 DO i = 1, n
286 work( i ) = work( i ) * c( i )
287 END DO
288 END IF
289*
290 IF ( notrans ) THEN
291 CALL cgetrs( 'Conjugate transpose', n, 1, af, ldaf, ipiv,
292 $ work, n, info )
293 ELSE
294 CALL cgetrs( 'No transpose', n, 1, af, ldaf, ipiv,
295 $ work, n, info )
296 END IF
297*
298* Multiply by R.
299*
300 DO i = 1, n
301 work( i ) = work( i ) * rwork( i )
302 END DO
303 END IF
304 GO TO 10
305 END IF
306*
307* Compute the estimate of the reciprocal condition number.
308*
309 IF( ainvnm .NE. 0.0e+0 )
310 $ cla_gercond_c = 1.0e+0 / ainvnm
311*
312 RETURN
313*
314* End of CLA_GERCOND_C
315*

◆ cla_gercond_x()

real function cla_gercond_x ( character trans,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
complex, dimension( * ) x,
integer info,
complex, dimension( * ) work,
real, dimension( * ) rwork )

CLA_GERCOND_X computes the infinity norm condition number of op(A)*diag(x) for general matrices.

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

Purpose:
!>
!>
!>    CLA_GERCOND_X computes the infinity norm condition number of
!>    op(A) * diag(X) where X is a COMPLEX vector.
!>
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 COMPLEX 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 COMPLEX array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by CGETRF.
!>
[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 CGETRF; row i of the matrix was interchanged
!>     with row IPIV(i).
!>
[in]X
!>          X is COMPLEX array, dimension (N)
!>     The vector X in the formula op(A) * diag(X).
!>
[out]INFO
!>          INFO is INTEGER
!>       = 0:  Successful exit.
!>     i > 0:  The ith argument is invalid.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N).
!>     Workspace.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N).
!>     Workspace.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 133 of file cla_gercond_x.f.

135*
136* -- LAPACK computational routine --
137* -- LAPACK is a software package provided by Univ. of Tennessee, --
138* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
139*
140* .. Scalar Arguments ..
141 CHARACTER TRANS
142 INTEGER N, LDA, LDAF, INFO
143* ..
144* .. Array Arguments ..
145 INTEGER IPIV( * )
146 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
147 REAL RWORK( * )
148* ..
149*
150* =====================================================================
151*
152* .. Local Scalars ..
153 LOGICAL NOTRANS
154 INTEGER KASE
155 REAL AINVNM, ANORM, TMP
156 INTEGER I, J
157 COMPLEX ZDUM
158* ..
159* .. Local Arrays ..
160 INTEGER ISAVE( 3 )
161* ..
162* .. External Functions ..
163 LOGICAL LSAME
164 EXTERNAL lsame
165* ..
166* .. External Subroutines ..
167 EXTERNAL clacn2, cgetrs, xerbla
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, max, real, aimag
171* ..
172* .. Statement Functions ..
173 REAL CABS1
174* ..
175* .. Statement Function Definitions ..
176 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
177* ..
178* .. Executable Statements ..
179*
180 cla_gercond_x = 0.0e+0
181*
182 info = 0
183 notrans = lsame( trans, 'N' )
184 IF ( .NOT. notrans .AND. .NOT. lsame( trans, 'T' ) .AND. .NOT.
185 $ lsame( trans, 'C' ) ) THEN
186 info = -1
187 ELSE IF( n.LT.0 ) THEN
188 info = -2
189 ELSE IF( lda.LT.max( 1, n ) ) THEN
190 info = -4
191 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
192 info = -6
193 END IF
194 IF( info.NE.0 ) THEN
195 CALL xerbla( 'CLA_GERCOND_X', -info )
196 RETURN
197 END IF
198*
199* Compute norm of op(A)*op2(C).
200*
201 anorm = 0.0
202 IF ( notrans ) THEN
203 DO i = 1, n
204 tmp = 0.0e+0
205 DO j = 1, n
206 tmp = tmp + cabs1( a( i, j ) * x( j ) )
207 END DO
208 rwork( i ) = tmp
209 anorm = max( anorm, tmp )
210 END DO
211 ELSE
212 DO i = 1, n
213 tmp = 0.0e+0
214 DO j = 1, n
215 tmp = tmp + cabs1( a( j, i ) * x( j ) )
216 END DO
217 rwork( i ) = tmp
218 anorm = max( anorm, tmp )
219 END DO
220 END IF
221*
222* Quick return if possible.
223*
224 IF( n.EQ.0 ) THEN
225 cla_gercond_x = 1.0e+0
226 RETURN
227 ELSE IF( anorm .EQ. 0.0e+0 ) THEN
228 RETURN
229 END IF
230*
231* Estimate the norm of inv(op(A)).
232*
233 ainvnm = 0.0e+0
234*
235 kase = 0
236 10 CONTINUE
237 CALL clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
238 IF( kase.NE.0 ) THEN
239 IF( kase.EQ.2 ) THEN
240* Multiply by R.
241 DO i = 1, n
242 work( i ) = work( i ) * rwork( i )
243 END DO
244*
245 IF ( notrans ) THEN
246 CALL cgetrs( 'No transpose', n, 1, af, ldaf, ipiv,
247 $ work, n, info )
248 ELSE
249 CALL cgetrs( 'Conjugate transpose', n, 1, af, ldaf, ipiv,
250 $ work, n, info )
251 ENDIF
252*
253* Multiply by inv(X).
254*
255 DO i = 1, n
256 work( i ) = work( i ) / x( i )
257 END DO
258 ELSE
259*
260* Multiply by inv(X**H).
261*
262 DO i = 1, n
263 work( i ) = work( i ) / x( i )
264 END DO
265*
266 IF ( notrans ) THEN
267 CALL cgetrs( 'Conjugate transpose', n, 1, af, ldaf, ipiv,
268 $ work, n, info )
269 ELSE
270 CALL cgetrs( 'No transpose', n, 1, af, ldaf, ipiv,
271 $ work, n, info )
272 END IF
273*
274* Multiply by R.
275*
276 DO i = 1, n
277 work( i ) = work( i ) * rwork( i )
278 END DO
279 END IF
280 GO TO 10
281 END IF
282*
283* Compute the estimate of the reciprocal condition number.
284*
285 IF( ainvnm .NE. 0.0e+0 )
286 $ cla_gercond_x = 1.0e+0 / ainvnm
287*
288 RETURN
289*
290* End of CLA_GERCOND_X
291*

◆ cla_gerfsx_extended()

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

CLA_GERFSX_EXTENDED

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

Purpose:
!>
!>
!> CLA_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 CGERFSX 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 COMPLEX 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 COMPLEX array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by CGETRF.
!>
[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 CGETRF; 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 REAL 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 COMPLEX array, dimension (LDB,NRHS)
!>     The right-hand-side matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>     The leading dimension of the array B.  LDB >= max(1,N).
!>
[in,out]Y
!>          Y is COMPLEX array, dimension (LDY,NRHS)
!>     On entry, the solution matrix X, as computed by CGETRS.
!>     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 REAL 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 CLA_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 REAL 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 REAL 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 COMPLEX array, dimension (N)
!>     Workspace to hold the intermediate residual.
!>
[in]AYB
!>          AYB is REAL array, dimension (N)
!>     Workspace.
!>
[in]DY
!>          DY is COMPLEX array, dimension (N)
!>     Workspace to hold the intermediate solution.
!>
[in]Y_TAIL
!>          Y_TAIL is COMPLEX array, dimension (N)
!>     Workspace to hold the trailing bits of the intermediate solution.
!>
[in]RCOND
!>          RCOND is REAL
!>     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 REAL
!>     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 REAL
!>     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 CGETRS had an illegal
!>             value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 391 of file cla_gerfsx_extended.f.

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

◆ cla_gerpvgrw()

real function cla_gerpvgrw ( integer n,
integer ncols,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldaf, * ) af,
integer ldaf )

CLA_GERPVGRW multiplies a square real matrix by a complex matrix.

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

Purpose:
!>
!>
!> CLA_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 COMPLEX 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 COMPLEX array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by CGETRF.
!>
[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 97 of file cla_gerpvgrw.f.

98*
99* -- LAPACK computational routine --
100* -- LAPACK is a software package provided by Univ. of Tennessee, --
101* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
102*
103* .. Scalar Arguments ..
104 INTEGER N, NCOLS, LDA, LDAF
105* ..
106* .. Array Arguments ..
107 COMPLEX A( LDA, * ), AF( LDAF, * )
108* ..
109*
110* =====================================================================
111*
112* .. Local Scalars ..
113 INTEGER I, J
114 REAL AMAX, UMAX, RPVGRW
115 COMPLEX ZDUM
116* ..
117* .. Intrinsic Functions ..
118 INTRINSIC max, min, abs, real, aimag
119* ..
120* .. Statement Functions ..
121 REAL CABS1
122* ..
123* .. Statement Function Definitions ..
124 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
125* ..
126* .. Executable Statements ..
127*
128 rpvgrw = 1.0
129
130 DO j = 1, ncols
131 amax = 0.0
132 umax = 0.0
133 DO i = 1, n
134 amax = max( cabs1( a( i, j ) ), amax )
135 END DO
136 DO i = 1, j
137 umax = max( cabs1( af( i, j ) ), umax )
138 END DO
139 IF ( umax /= 0.0 ) THEN
140 rpvgrw = min( amax / umax, rpvgrw )
141 END IF
142 END DO
143 cla_gerpvgrw = rpvgrw
144*
145* End of CLA_GERPVGRW
146*
cla_gerpvgrw
real function cla_gerpvgrw(n, ncols, a, lda, af, ldaf)
CLA_GERPVGRW multiplies a square real matrix by a complex matrix.
Definition cla_gerpvgrw.f:98

◆ claqz0()

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

CLAQZ0

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

Purpose:
!>
!> CLAQZ0 computes the eigenvalues of a 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 matrix pair (A,B):
!>
!>    A = Q1*H*Z1**H,  B = Q1*T*Z1**H,
!>
!> as computed by CGGHRD.
!>
!> If JOB='S', then the Hessenberg-triangular pair (H,T) is
!> also reduced to generalized Schur form,
!>
!>    H = Q*S*Z**H,  T = Q*P*Z**H,
!>
!> where Q and Z are unitary matrices, P and S are an upper triangular
!> matrices.
!>
!> Optionally, the unitary matrix Q from the generalized Schur
!> factorization may be postmultiplied into an input matrix Q1, and the
!> unitary matrix Z may be postmultiplied into an input matrix Z1.
!> If Q1 and Z1 are the unitary matrices from CGGHRD that reduced
!> the matrix pair (A,B) to generalized upper Hessenberg form, then the
!> output matrices Q1*Q and Z1*Z are the unitary factors from the
!> generalized Schur factorization of (A,B):
!>
!>    A = (Q1*Q)*S*(Z1*Z)**H,  B = (Q1*Q)*P*(Z1*Z)**H.
!>
!> 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.
!> 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 unitary 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 unitary 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 COMPLEX array, dimension (LDA, N)
!>          On entry, the N-by-N upper Hessenberg matrix A.
!>          On exit, if JOB = 'S', A contains the upper triangular
!>          matrix S from the generalized Schur factorization.
!>          If JOB = 'E', the diagonal of A matches that 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 COMPLEX 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.
!>          If JOB = 'E', the diagonal of B matches that 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]ALPHA
!>          ALPHA is COMPLEX array, dimension (N)
!>          Each scalar alpha defining an eigenvalue
!>          of GNEP.
!>
[out]BETA
!>          BETA is COMPLEX array, dimension (N)
!>          The scalars beta that define the eigenvalues of GNEP.
!>          Together, the quantities alpha = ALPHA(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 COMPLEX array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the unitary matrix Q1 used in
!>          the reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPQ = 'I', the unitary matrix of left Schur
!>          vectors of (A,B), and if COMPQ = 'V', the unitary 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 COMPLEX array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the unitary matrix Z1 used in
!>          the reduction of (A,B) to generalized Hessenberg form.
!>          On exit, if COMPZ = 'I', the unitary matrix of
!>          right Schur vectors of (H,T), and if COMPZ = 'V', the
!>          unitary 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 COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[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 ALPHA(i) and
!>                     BETA(i), i=INFO+1,...,N should be correct.
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

Definition at line 280 of file claqz0.f.

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

◆ claqz1()

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

CLAQZ1

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

Purpose:
!>
!>      CLAQZ1 chases a 1x1 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),B(k+1,k)).
!>              On exit, the bulge is located in
!>              (A(k+2,k+1),B(k+2,k+1)).
!>
[in]ISTARTM
!>          ISTARTM is INTEGER
!>
[in]ISTOPM
!>          ISTOPM is INTEGER
!>              Updates to (A,B) are restricted to
!>              (istartm:k+2,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 COMPLEX 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 COMPLEX 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+3-qStart of Q.
!>
[in,out]Q
!>          Q is COMPLEX 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+2-qStart of Z.
!>
[in,out]Z
!>          Z is COMPLEX 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 claqz1.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 COMPLEX :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ), Z( LDZ, * )
180*
181* Parameters
182 COMPLEX CZERO, CONE
183 parameter( czero = ( 0.0, 0.0 ), cone = ( 1.0, 0.0 ) )
184 REAL :: ZERO, ONE, HALF
185 parameter( zero = 0.0, one = 1.0, half = 0.5 )
186*
187* Local variables
188 REAL :: C
189 COMPLEX :: S, TEMP
190*
191* External Functions
192 EXTERNAL :: clartg, crot
193*
194 IF( k+1 .EQ. ihi ) THEN
195*
196* Shift is located on the edge of the matrix, remove it
197*
198 CALL clartg( b( ihi, ihi ), b( ihi, ihi-1 ), c, s, temp )
199 b( ihi, ihi ) = temp
200 b( ihi, ihi-1 ) = czero
201 CALL crot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,
202 $ ihi-1 ), 1, c, s )
203 CALL crot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,
204 $ ihi-1 ), 1, c, s )
205 IF ( ilz ) THEN
206 CALL crot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+
207 $ 1 ), 1, c, s )
208 END IF
209*
210 ELSE
211*
212* Normal operation, move bulge down
213*
214*
215* Apply transformation from the right
216*
217 CALL clartg( b( k+1, k+1 ), b( k+1, k ), c, s, temp )
218 b( k+1, k+1 ) = temp
219 b( k+1, k ) = czero
220 CALL crot( k+2-istartm+1, a( istartm, k+1 ), 1, a( istartm,
221 $ k ), 1, c, s )
222 CALL crot( k-istartm+1, b( istartm, k+1 ), 1, b( istartm, k ),
223 $ 1, c, s )
224 IF ( ilz ) THEN
225 CALL crot( nz, z( 1, k+1-zstart+1 ), 1, z( 1, k-zstart+1 ),
226 $ 1, c, s )
227 END IF
228*
229* Apply transformation from the left
230*
231 CALL clartg( a( k+1, k ), a( k+2, k ), c, s, temp )
232 a( k+1, k ) = temp
233 a( k+2, k ) = czero
234 CALL crot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda, c,
235 $ s )
236 CALL crot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb, c,
237 $ s )
238 IF ( ilq ) THEN
239 CALL crot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+
240 $ 1 ), 1, c, conjg( s ) )
241 END IF
242*
243 END IF
244*
245* End of CLAQZ1
246*

◆ claqz2()

recursive subroutine claqz2 ( 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,
complex, dimension( lda, * ), intent(inout) a,
integer, intent(in) lda,
complex, dimension( ldb, * ), intent(inout) b,
integer, intent(in) ldb,
complex, dimension( ldq, * ), intent(inout) q,
integer, intent(in) ldq,
complex, dimension( ldz, * ), intent(inout) z,
integer, intent(in) ldz,
integer, intent(out) ns,
integer, intent(out) nd,
complex, dimension( * ), intent(inout) alpha,
complex, dimension( * ), intent(inout) beta,
complex, dimension( ldqc, * ) qc,
integer, intent(in) ldqc,
complex, dimension( ldzc, * ) zc,
integer, intent(in) ldzc,
complex, dimension( * ) work,
integer, intent(in) lwork,
real, dimension( * ) rwork,
integer, intent(in) rec,
integer, intent(out) info )

CLAQZ2

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

Purpose:
!>
!> CLAQZ2 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 COMPLEX 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 COMPLEX 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 COMPLEX array, dimension (LDQ, N)
!>
[in]LDQ
!>          LDQ is INTEGER
!>
[in,out]Z
!>          Z is COMPLEX 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]ALPHA
!>          ALPHA is COMPLEX array, dimension (N)
!>          Each scalar alpha defining an eigenvalue
!>          of GNEP.
!>
[out]BETA
!>          BETA is COMPLEX array, dimension (N)
!>          The scalars beta that define the eigenvalues of GNEP.
!>          Together, the quantities alpha = ALPHA(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 COMPLEX array, dimension (LDQC, NW)
!>
[in]LDQC
!>          LDQC is INTEGER
!>
[in,out]ZC
!>          ZC is COMPLEX array, dimension (LDZC, NW)
!>
[in]LDZC
!>          LDZ is INTEGER
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[in]REC
!>          REC is INTEGER
!>             REC indicates the current recursion level. Should be set
!>             to 0 on first call.
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Thijs Steel, KU Leuven, KU Leuven
Date
May 2020

Definition at line 230 of file claqz2.f.

234 IMPLICIT NONE
235
236* Arguments
237 LOGICAL, INTENT( IN ) :: ILSCHUR, ILQ, ILZ
238 INTEGER, INTENT( IN ) :: N, ILO, IHI, NW, LDA, LDB, LDQ, LDZ,
239 $ LDQC, LDZC, LWORK, REC
240
241 COMPLEX, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
242 $ Z( LDZ, * ), ALPHA( * ), BETA( * )
243 INTEGER, INTENT( OUT ) :: NS, ND, INFO
244 COMPLEX :: QC( LDQC, * ), ZC( LDZC, * ), WORK( * )
245 REAL :: RWORK( * )
246
247* Parameters
248 COMPLEX CZERO, CONE
249 parameter( czero = ( 0.0, 0.0 ), cone = ( 1.0, 0.0 ) )
250 REAL :: ZERO, ONE, HALF
251 parameter( zero = 0.0, one = 1.0, half = 0.5 )
252
253* Local Scalars
254 INTEGER :: JW, KWTOP, KWBOT, ISTOPM, ISTARTM, K, K2, CTGEXC_INFO,
255 $ IFST, ILST, LWORKREQ, QZ_SMALL_INFO
256 REAL :: SMLNUM, ULP, SAFMIN, SAFMAX, C1, TEMPR
257 COMPLEX :: S, S1, TEMP
258
259* External Functions
260 EXTERNAL :: xerbla, claqz0, claqz1, slabad, clacpy, claset, cgemm,
261 $ ctgexc, clartg, crot
262 REAL, EXTERNAL :: SLAMCH
263
264 info = 0
265
266* Set up deflation window
267 jw = min( nw, ihi-ilo+1 )
268 kwtop = ihi-jw+1
269 IF ( kwtop .EQ. ilo ) THEN
270 s = czero
271 ELSE
272 s = a( kwtop, kwtop-1 )
273 END IF
274
275* Determine required workspace
276 ifst = 1
277 ilst = jw
278 CALL claqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,
279 $ b( kwtop, kwtop ), ldb, alpha, beta, qc, ldqc, zc,
280 $ ldzc, work, -1, rwork, rec+1, qz_small_info )
281 lworkreq = int( work( 1 ) )+2*jw**2
282 lworkreq = max( lworkreq, n*nw, 2*nw**2+n )
283 IF ( lwork .EQ.-1 ) THEN
284* workspace query, quick return
285 work( 1 ) = lworkreq
286 RETURN
287 ELSE IF ( lwork .LT. lworkreq ) THEN
288 info = -26
289 END IF
290
291 IF( info.NE.0 ) THEN
292 CALL xerbla( 'CLAQZ2', -info )
293 RETURN
294 END IF
295
296* Get machine constants
297 safmin = slamch( 'SAFE MINIMUM' )
298 safmax = one/safmin
299 CALL slabad( safmin, safmax )
300 ulp = slamch( 'PRECISION' )
301 smlnum = safmin*( real( n )/ulp )
302
303 IF ( ihi .EQ. kwtop ) THEN
304* 1 by 1 deflation window, just try a regular deflation
305 alpha( kwtop ) = a( kwtop, kwtop )
306 beta( kwtop ) = b( kwtop, kwtop )
307 ns = 1
308 nd = 0
309 IF ( abs( s ) .LE. max( smlnum, ulp*abs( a( kwtop,
310 $ kwtop ) ) ) ) THEN
311 ns = 0
312 nd = 1
313 IF ( kwtop .GT. ilo ) THEN
314 a( kwtop, kwtop-1 ) = czero
315 END IF
316 END IF
317 END IF
318
319
320* Store window in case of convergence failure
321 CALL clacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw )
322 CALL clacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+
323 $ 1 ), jw )
324
325* Transform window to real schur form
326 CALL claset( 'FULL', jw, jw, czero, cone, qc, ldqc )
327 CALL claset( 'FULL', jw, jw, czero, cone, zc, ldzc )
328 CALL claqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,
329 $ b( kwtop, kwtop ), ldb, alpha, beta, qc, ldqc, zc,
330 $ ldzc, work( 2*jw**2+1 ), lwork-2*jw**2, rwork,
331 $ rec+1, qz_small_info )
332
333 IF( qz_small_info .NE. 0 ) THEN
334* Convergence failure, restore the window and exit
335 nd = 0
336 ns = jw-qz_small_info
337 CALL clacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda )
338 CALL clacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,
339 $ kwtop ), ldb )
340 RETURN
341 END IF
342
343* Deflation detection loop
344 IF ( kwtop .EQ. ilo .OR. s .EQ. czero ) THEN
345 kwbot = kwtop-1
346 ELSE
347 kwbot = ihi
348 k = 1
349 k2 = 1
350 DO WHILE ( k .LE. jw )
351* Try to deflate eigenvalue
352 tempr = abs( a( kwbot, kwbot ) )
353 IF( tempr .EQ. zero ) THEN
354 tempr = abs( s )
355 END IF
356 IF ( ( abs( s*qc( 1, kwbot-kwtop+1 ) ) ) .LE. max( ulp*
357 $ tempr, smlnum ) ) THEN
358* Deflatable
359 kwbot = kwbot-1
360 ELSE
361* Not deflatable, move out of the way
362 ifst = kwbot-kwtop+1
363 ilst = k2
364 CALL ctgexc( .true., .true., jw, a( kwtop, kwtop ),
365 $ lda, b( kwtop, kwtop ), ldb, qc, ldqc,
366 $ zc, ldzc, ifst, ilst, ctgexc_info )
367 k2 = k2+1
368 END IF
369
370 k = k+1
371 END DO
372 END IF
373
374* Store eigenvalues
375 nd = ihi-kwbot
376 ns = jw-nd
377 k = kwtop
378 DO WHILE ( k .LE. ihi )
379 alpha( k ) = a( k, k )
380 beta( k ) = b( k, k )
381 k = k+1
382 END DO
383
384 IF ( kwtop .NE. ilo .AND. s .NE. czero ) THEN
385* Reflect spike back, this will create optimally packed bulges
386 a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 ) *conjg( qc( 1,
387 $ 1:jw-nd ) )
388 DO k = kwbot-1, kwtop, -1
389 CALL clartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,
390 $ temp )
391 a( k, kwtop-1 ) = temp
392 a( k+1, kwtop-1 ) = czero
393 k2 = max( kwtop, k-1 )
394 CALL crot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,
395 $ s1 )
396 CALL crot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),
397 $ ldb, c1, s1 )
398 CALL crot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),
399 $ 1, c1, conjg( s1 ) )
400 END DO
401
402* Chase bulges down
403 istartm = kwtop
404 istopm = ihi
405 k = kwbot-1
406 DO WHILE ( k .GE. kwtop )
407
408* Move bulge down and remove it
409 DO k2 = k, kwbot-1
410 CALL claqz1( .true., .true., k2, kwtop, kwtop+jw-1,
411 $ kwbot, a, lda, b, ldb, jw, kwtop, qc, ldqc,
412 $ jw, kwtop, zc, ldzc )
413 END DO
414
415 k = k-1
416 END DO
417
418 END IF
419
420* Apply Qc and Zc to rest of the matrix
421 IF ( ilschur ) THEN
422 istartm = 1
423 istopm = n
424 ELSE
425 istartm = ilo
426 istopm = ihi
427 END IF
428
429 IF ( istopm-ihi > 0 ) THEN
430 CALL cgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,
431 $ a( kwtop, ihi+1 ), lda, czero, work, jw )
432 CALL clacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,
433 $ ihi+1 ), lda )
434 CALL cgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,
435 $ b( kwtop, ihi+1 ), ldb, czero, work, jw )
436 CALL clacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,
437 $ ihi+1 ), ldb )
438 END IF
439 IF ( ilq ) THEN
440 CALL cgemm( 'N', 'N', n, jw, jw, cone, q( 1, kwtop ), ldq, qc,
441 $ ldqc, czero, work, n )
442 CALL clacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq )
443 END IF
444
445 IF ( kwtop-1-istartm+1 > 0 ) THEN
446 CALL cgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, a( istartm,
447 $ kwtop ), lda, zc, ldzc, czero, work,
448 $ kwtop-istartm )
449 CALL clacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,
450 $ a( istartm, kwtop ), lda )
451 CALL cgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, b( istartm,
452 $ kwtop ), ldb, zc, ldzc, czero, work,
453 $ kwtop-istartm )
454 CALL clacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,
455 $ b( istartm, kwtop ), ldb )
456 END IF
457 IF ( ilz ) THEN
458 CALL cgemm( 'N', 'N', n, jw, jw, cone, z( 1, kwtop ), ldz, zc,
459 $ ldzc, czero, work, n )
460 CALL clacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz )
461 END IF
462
ctgexc
subroutine ctgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, info)
CTGEXC
Definition ctgexc.f:200
claqz1
subroutine claqz1(ilq, ilz, k, istartm, istopm, ihi, a, lda, b, ldb, nq, qstart, q, ldq, nz, zstart, z, ldz)
CLAQZ1
Definition claqz1.f:173
claqz0
recursive subroutine claqz0(wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb, alpha, beta, q, ldq, z, ldz, work, lwork, rwork, rec, info)
CLAQZ0
Definition claqz0.f:284
clacpy
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
Definition clacpy.f:103

◆ claqz3()

subroutine claqz3 ( 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,
complex, dimension( * ), intent(inout) alpha,
complex, dimension( * ), intent(inout) beta,
complex, dimension( lda, * ), intent(inout) a,
integer, intent(in) lda,
complex, dimension( ldb, * ), intent(inout) b,
integer, intent(in) ldb,
complex, dimension( ldq, * ), intent(inout) q,
integer, intent(in) ldq,
complex, dimension( ldz, * ), intent(inout) z,
integer, intent(in) ldz,
complex, dimension( ldqc, * ), intent(inout) qc,
integer, intent(in) ldqc,
complex, dimension( ldzc, * ), intent(inout) zc,
integer, intent(in) ldzc,
complex, dimension( * ), intent(inout) work,
integer, intent(in) lwork,
integer, intent(out) info )

CLAQZ3

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

Purpose:
!>
!> CLAQZ3 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]ALPHA
!>          ALPHA is COMPLEX array. SR contains
!>          the alpha parts of the shifts to use.
!>
[in]BETA
!>          BETA is COMPLEX array. SS contains
!>          the scale of the shifts to use.
!>
[in,out]A
!>          A is COMPLEX 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 COMPLEX 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 COMPLEX array, dimension (LDQ, N)
!>
[in]LDQ
!>          LDQ is INTEGER
!>
[in,out]Z
!>          Z is COMPLEX array, dimension (LDZ, N)
!>
[in]LDZ
!>          LDZ is INTEGER
!>
[in,out]QC
!>          QC is COMPLEX array, dimension (LDQC, NBLOCK_DESIRED)
!>
[in]LDQC
!>          LDQC is INTEGER
!>
[in,out]ZC
!>          ZC is COMPLEX array, dimension (LDZC, NBLOCK_DESIRED)
!>
[in]LDZC
!>          LDZ is INTEGER
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,N).
!>
!>          If 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 203 of file claqz3.f.

207 IMPLICIT NONE
208
209* Function arguments
210 LOGICAL, INTENT( IN ) :: ILSCHUR, ILQ, ILZ
211 INTEGER, INTENT( IN ) :: N, ILO, IHI, LDA, LDB, LDQ, LDZ, LWORK,
212 $ NSHIFTS, NBLOCK_DESIRED, LDQC, LDZC
213
214 COMPLEX, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
215 $ Z( LDZ, * ), QC( LDQC, * ), ZC( LDZC, * ), WORK( * ),
216 $ ALPHA( * ), BETA( * )
217
218 INTEGER, INTENT( OUT ) :: INFO
219
220* Parameters
221 COMPLEX CZERO, CONE
222 parameter( czero = ( 0.0, 0.0 ), cone = ( 1.0, 0.0 ) )
223 REAL :: ZERO, ONE, HALF
224 parameter( zero = 0.0, one = 1.0, half = 0.5 )
225
226* Local scalars
227 INTEGER :: I, J, NS, ISTARTM, ISTOPM, SHEIGHT, SWIDTH, K, NP,
228 $ ISTARTB, ISTOPB, ISHIFT, NBLOCK, NPOS
229 REAL :: SAFMIN, SAFMAX, C, SCALE
230 COMPLEX :: TEMP, TEMP2, TEMP3, S
231
232* External Functions
233 EXTERNAL :: xerbla, slabad, claset, clartg, crot, claqz1, cgemm,
234 $ clacpy
235 REAL, EXTERNAL :: SLAMCH
236
237 info = 0
238 IF ( nblock_desired .LT. nshifts+1 ) THEN
239 info = -8
240 END IF
241 IF ( lwork .EQ.-1 ) THEN
242* workspace query, quick return
243 work( 1 ) = n*nblock_desired
244 RETURN
245 ELSE IF ( lwork .LT. n*nblock_desired ) THEN
246 info = -25
247 END IF
248
249 IF( info.NE.0 ) THEN
250 CALL xerbla( 'CLAQZ3', -info )
251 RETURN
252 END IF
253
254*
255* Executable statements
256*
257
258* Get machine constants
259 safmin = slamch( 'SAFE MINIMUM' )
260 safmax = one/safmin
261 CALL slabad( safmin, safmax )
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 ns = nshifts
276 npos = max( nblock_desired-ns, 1 )
277
278
279* The following block introduces the shifts and chases
280* them down one by one just enough to make space for
281* the other shifts. The near-the-diagonal block is
282* of size (ns+1) x ns.
283
284 CALL claset( 'FULL', ns+1, ns+1, czero, cone, qc, ldqc )
285 CALL claset( 'FULL', ns, ns, czero, cone, zc, ldzc )
286
287 DO i = 1, ns
288* Introduce the shift
289 scale = sqrt( abs( alpha( i ) ) ) * sqrt( abs( beta( i ) ) )
290 IF( scale .GE. safmin .AND. scale .LE. safmax ) THEN
291 alpha( i ) = alpha( i )/scale
292 beta( i ) = beta( i )/scale
293 END IF
294
295 temp2 = beta( i )*a( ilo, ilo )-alpha( i )*b( ilo, ilo )
296 temp3 = beta( i )*a( ilo+1, ilo )
297
298 IF ( abs( temp2 ) .GT. safmax .OR.
299 $ abs( temp3 ) .GT. safmax ) THEN
300 temp2 = cone
301 temp3 = czero
302 END IF
303
304 CALL clartg( temp2, temp3, c, s, temp )
305 CALL crot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c,
306 $ s )
307 CALL crot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c,
308 $ s )
309 CALL crot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c, conjg( s ) )
310
311* Chase the shift down
312 DO j = 1, ns-i
313
314 CALL claqz1( .true., .true., j, 1, ns, ihi-ilo+1, a( ilo,
315 $ ilo ), lda, b( ilo, ilo ), ldb, ns+1, 1, qc,
316 $ ldqc, ns, 1, zc, ldzc )
317
318 END DO
319
320 END DO
321
322* Update the rest of the pencil
323
324* Update A(ilo:ilo+ns,ilo+ns:istopm) and B(ilo:ilo+ns,ilo+ns:istopm)
325* from the left with Qc(1:ns+1,1:ns+1)'
326 sheight = ns+1
327 swidth = istopm-( ilo+ns )+1
328 IF ( swidth > 0 ) THEN
329 CALL cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,
330 $ a( ilo, ilo+ns ), lda, czero, work, sheight )
331 CALL clacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,
332 $ ilo+ns ), lda )
333 CALL cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,
334 $ b( ilo, ilo+ns ), ldb, czero, work, sheight )
335 CALL clacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,
336 $ ilo+ns ), ldb )
337 END IF
338 IF ( ilq ) THEN
339 CALL cgemm( 'N', 'N', n, sheight, sheight, cone, q( 1, ilo ),
340 $ ldq, qc, ldqc, czero, work, n )
341 CALL clacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq )
342 END IF
343
344* Update A(istartm:ilo-1,ilo:ilo+ns-1) and B(istartm:ilo-1,ilo:ilo+ns-1)
345* from the right with Zc(1:ns,1:ns)
346 sheight = ilo-1-istartm+1
347 swidth = ns
348 IF ( sheight > 0 ) THEN
349 CALL cgemm( 'N', 'N', sheight, swidth, swidth, cone,
350 $ a( istartm, ilo ), lda, zc, ldzc, czero, work,
351 $ sheight )
352 CALL clacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,
353 $ ilo ), lda )
354 CALL cgemm( 'N', 'N', sheight, swidth, swidth, cone,
355 $ b( istartm, ilo ), ldb, zc, ldzc, czero, work,
356 $ sheight )
357 CALL clacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,
358 $ ilo ), ldb )
359 END IF
360 IF ( ilz ) THEN
361 CALL cgemm( 'N', 'N', n, swidth, swidth, cone, z( 1, ilo ),
362 $ ldz, zc, ldzc, czero, work, n )
363 CALL clacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz )
364 END IF
365
366* The following block chases the shifts down to the bottom
367* right block. If possible, a shift is moved down npos
368* positions at a time
369
370 k = ilo
371 DO WHILE ( k < ihi-ns )
372 np = min( ihi-ns-k, npos )
373* Size of the near-the-diagonal block
374 nblock = ns+np
375* istartb points to the first row we will be updating
376 istartb = k+1
377* istopb points to the last column we will be updating
378 istopb = k+nblock-1
379
380 CALL claset( 'FULL', ns+np, ns+np, czero, cone, qc, ldqc )
381 CALL claset( 'FULL', ns+np, ns+np, czero, cone, zc, ldzc )
382
383* Near the diagonal shift chase
384 DO i = ns-1, 0, -1
385 DO j = 0, np-1
386* Move down the block with index k+i+j, updating
387* the (ns+np x ns+np) block:
388* (k:k+ns+np,k:k+ns+np-1)
389 CALL claqz1( .true., .true., k+i+j, istartb, istopb, ihi,
390 $ a, lda, b, ldb, nblock, k+1, qc, ldqc,
391 $ nblock, k, zc, ldzc )
392 END DO
393 END DO
394
395* Update rest of the pencil
396
397* Update A(k+1:k+ns+np, k+ns+np:istopm) and
398* B(k+1:k+ns+np, k+ns+np:istopm)
399* from the left with Qc(1:ns+np,1:ns+np)'
400 sheight = ns+np
401 swidth = istopm-( k+ns+np )+1
402 IF ( swidth > 0 ) THEN
403 CALL cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,
404 $ ldqc, a( k+1, k+ns+np ), lda, czero, work,
405 $ sheight )
406 CALL clacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,
407 $ k+ns+np ), lda )
408 CALL cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,
409 $ ldqc, b( k+1, k+ns+np ), ldb, czero, work,
410 $ sheight )
411 CALL clacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,
412 $ k+ns+np ), ldb )
413 END IF
414 IF ( ilq ) THEN
415 CALL cgemm( 'N', 'N', n, nblock, nblock, cone, q( 1, k+1 ),
416 $ ldq, qc, ldqc, czero, work, n )
417 CALL clacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq )
418 END IF
419
420* Update A(istartm:k,k:k+ns+npos-1) and B(istartm:k,k:k+ns+npos-1)
421* from the right with Zc(1:ns+np,1:ns+np)
422 sheight = k-istartm+1
423 swidth = nblock
424 IF ( sheight > 0 ) THEN
425 CALL cgemm( 'N', 'N', sheight, swidth, swidth, cone,
426 $ a( istartm, k ), lda, zc, ldzc, czero, work,
427 $ sheight )
428 CALL clacpy( 'ALL', sheight, swidth, work, sheight,
429 $ a( istartm, k ), lda )
430 CALL cgemm( 'N', 'N', sheight, swidth, swidth, cone,
431 $ b( istartm, k ), ldb, zc, ldzc, czero, work,
432 $ sheight )
433 CALL clacpy( 'ALL', sheight, swidth, work, sheight,
434 $ b( istartm, k ), ldb )
435 END IF
436 IF ( ilz ) THEN
437 CALL cgemm( 'N', 'N', n, nblock, nblock, cone, z( 1, k ),
438 $ ldz, zc, ldzc, czero, work, n )
439 CALL clacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz )
440 END IF
441
442 k = k+np
443
444 END DO
445
446* The following block removes the shifts from the bottom right corner
447* one by one. Updates are initially applied to A(ihi-ns+1:ihi,ihi-ns:ihi).
448
449 CALL claset( 'FULL', ns, ns, czero, cone, qc, ldqc )
450 CALL claset( 'FULL', ns+1, ns+1, czero, cone, zc, ldzc )
451
452* istartb points to the first row we will be updating
453 istartb = ihi-ns+1
454* istopb points to the last column we will be updating
455 istopb = ihi
456
457 DO i = 1, ns
458* Chase the shift down to the bottom right corner
459 DO ishift = ihi-i, ihi-1
460 CALL claqz1( .true., .true., ishift, istartb, istopb, ihi,
461 $ a, lda, b, ldb, ns, ihi-ns+1, qc, ldqc, ns+1,
462 $ ihi-ns, zc, ldzc )
463 END DO
464
465 END DO
466
467* Update rest of the pencil
468
469* Update A(ihi-ns+1:ihi, ihi+1:istopm)
470* from the left with Qc(1:ns,1:ns)'
471 sheight = ns
472 swidth = istopm-( ihi+1 )+1
473 IF ( swidth > 0 ) THEN
474 CALL cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,
475 $ a( ihi-ns+1, ihi+1 ), lda, czero, work, sheight )
476 CALL clacpy( 'ALL', sheight, swidth, work, sheight,
477 $ a( ihi-ns+1, ihi+1 ), lda )
478 CALL cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,
479 $ b( ihi-ns+1, ihi+1 ), ldb, czero, work, sheight )
480 CALL clacpy( 'ALL', sheight, swidth, work, sheight,
481 $ b( ihi-ns+1, ihi+1 ), ldb )
482 END IF
483 IF ( ilq ) THEN
484 CALL cgemm( 'N', 'N', n, ns, ns, cone, q( 1, ihi-ns+1 ), ldq,
485 $ qc, ldqc, czero, work, n )
486 CALL clacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq )
487 END IF
488
489* Update A(istartm:ihi-ns,ihi-ns:ihi)
490* from the right with Zc(1:ns+1,1:ns+1)
491 sheight = ihi-ns-istartm+1
492 swidth = ns+1
493 IF ( sheight > 0 ) THEN
494 CALL cgemm( 'N', 'N', sheight, swidth, swidth, cone,
495 $ a( istartm, ihi-ns ), lda, zc, ldzc, czero, work,
496 $ sheight )
497 CALL clacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,
498 $ ihi-ns ), lda )
499 CALL cgemm( 'N', 'N', sheight, swidth, swidth, cone,
500 $ b( istartm, ihi-ns ), ldb, zc, ldzc, czero, work,
501 $ sheight )
502 CALL clacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,
503 $ ihi-ns ), ldb )
504 END IF
505 IF ( ilz ) THEN
506 CALL cgemm( 'N', 'N', n, ns+1, ns+1, cone, z( 1, ihi-ns ), ldz,
507 $ zc, ldzc, czero, work, n )
508 CALL clacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz )
509 END IF
510

◆ claunhr_col_getrfnp()

subroutine claunhr_col_getrfnp ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) d,
integer info )

CLAUNHR_COL_GETRFNP

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

Purpose:
!>
!> CLAUNHR_COL_GETRFNP computes the modified LU factorization without
!> pivoting of a complex 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 CUNHR_COL. In CUNHR_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 CLAUNHR_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 COMPLEX 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 COMPLEX 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 ( +1.0, 0.0 ) or (-1.0, 0.0 ).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if 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 claunhr_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 COMPLEX A( LDA, * ), D( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 COMPLEX CONE
163 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
164* ..
165* .. Local Scalars ..
166 INTEGER IINFO, J, JB, NB
167* ..
168* .. External Subroutines ..
169 EXTERNAL cgemm, claunhr_col_getrfnp2, ctrsm, 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( 'CLAUNHR_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, 'CLAUNHR_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 claunhr_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 claunhr_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 ctrsm( 'Left', 'Lower', 'No transpose', 'Unit', jb,
227 $ n-j-jb+1, cone, 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 cgemm( 'No transpose', 'No transpose', m-j-jb+1,
234 $ n-j-jb+1, jb, -cone, a( j+jb, j ), lda,
235 $ a( j, j+jb ), lda, cone, 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 CLAUNHR_COL_GETRFNP
244*
claunhr_col_getrfnp2
recursive subroutine claunhr_col_getrfnp2(m, n, a, lda, d, info)
CLAUNHR_COL_GETRFNP2
Definition claunhr_col_getrfnp2.f:167

◆ claunhr_col_getrfnp2()

recursive subroutine claunhr_col_getrfnp2 ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) d,
integer info )

CLAUNHR_COL_GETRFNP2

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

Purpose:
!>
!> CLAUNHR_COL_GETRFNP2 computes the modified LU factorization without
!> pivoting of a complex 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 CUNHR_COL. In CUNHR_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].
!>
!> CLAUNHR_COL_GETRFNP2 is called to factorize a block by the blocked
!> routine CLAUNHR_COL_GETRFNP, which uses blocked code calling
!> Level 3 BLAS to update the submatrix. However, CLAUNHR_COL_GETRFNP2
!> is self-sufficient and can be used without CLAUNHR_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 COMPLEX 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 COMPLEX 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 ( +1.0, 0.0 ) or (-1.0, 0.0 ).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if 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 claunhr_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 COMPLEX A( LDA, * ), D( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 REAL ONE
184 parameter( one = 1.0e+0 )
185 COMPLEX CONE
186 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
187* ..
188* .. Local Scalars ..
189 REAL SFMIN
190 INTEGER I, IINFO, N1, N2
191 COMPLEX Z
192* ..
193* .. External Functions ..
194 REAL SLAMCH
195 EXTERNAL slamch
196* ..
197* .. External Subroutines ..
198 EXTERNAL cgemm, cscal, ctrsm, xerbla
199* ..
200* .. Intrinsic Functions ..
201 INTRINSIC abs, real, cmplx, aimag, sign, max, min
202* ..
203* .. Statement Functions ..
204 DOUBLE PRECISION CABS1
205* ..
206* .. Statement Function definitions ..
207 cabs1( z ) = abs( real( z ) ) + abs( aimag( z ) )
208* ..
209* .. Executable Statements ..
210*
211* Test the input parameters
212*
213 info = 0
214 IF( m.LT.0 ) THEN
215 info = -1
216 ELSE IF( n.LT.0 ) THEN
217 info = -2
218 ELSE IF( lda.LT.max( 1, m ) ) THEN
219 info = -4
220 END IF
221 IF( info.NE.0 ) THEN
222 CALL xerbla( 'CLAUNHR_COL_GETRFNP2', -info )
223 RETURN
224 END IF
225*
226* Quick return if possible
227*
228 IF( min( m, n ).EQ.0 )
229 $ RETURN
230
231 IF ( m.EQ.1 ) THEN
232*
233* One row case, (also recursion termination case),
234* use unblocked code
235*
236* Transfer the sign
237*
238 d( 1 ) = cmplx( -sign( one, real( a( 1, 1 ) ) ) )
239*
240* Construct the row of U
241*
242 a( 1, 1 ) = a( 1, 1 ) - d( 1 )
243*
244 ELSE IF( n.EQ.1 ) THEN
245*
246* One column case, (also recursion termination case),
247* use unblocked code
248*
249* Transfer the sign
250*
251 d( 1 ) = cmplx( -sign( one, real( a( 1, 1 ) ) ) )
252*
253* Construct the row of U
254*
255 a( 1, 1 ) = a( 1, 1 ) - d( 1 )
256*
257* Scale the elements 2:M of the column
258*
259* Determine machine safe minimum
260*
261 sfmin = slamch('S')
262*
263* Construct the subdiagonal elements of L
264*
265 IF( cabs1( a( 1, 1 ) ) .GE. sfmin ) THEN
266 CALL cscal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 )
267 ELSE
268 DO i = 2, m
269 a( i, 1 ) = a( i, 1 ) / a( 1, 1 )
270 END DO
271 END IF
272*
273 ELSE
274*
275* Divide the matrix B into four submatrices
276*
277 n1 = min( m, n ) / 2
278 n2 = n-n1
279
280*
281* Factor B11, recursive call
282*
283 CALL claunhr_col_getrfnp2( n1, n1, a, lda, d, iinfo )
284*
285* Solve for B21
286*
287 CALL ctrsm( 'R', 'U', 'N', 'N', m-n1, n1, cone, a, lda,
288 $ a( n1+1, 1 ), lda )
289*
290* Solve for B12
291*
292 CALL ctrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,
293 $ a( 1, n1+1 ), lda )
294*
295* Update B22, i.e. compute the Schur complement
296* B22 := B22 - B21*B12
297*
298 CALL cgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,
299 $ a( 1, n1+1 ), lda, cone, a( n1+1, n1+1 ), lda )
300*
301* Factor B22, recursive call
302*
303 CALL claunhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,
304 $ d( n1+1 ), iinfo )
305*
306 END IF
307 RETURN
308*
309* End of CLAUNHR_COL_GETRFNP2
310*

◆ ctgevc()

subroutine ctgevc ( character side,
character howmny,
logical, dimension( * ) select,
integer n,
complex, dimension( lds, * ) s,
integer lds,
complex, dimension( ldp, * ) p,
integer ldp,
complex, dimension( ldvl, * ) vl,
integer ldvl,
complex, dimension( ldvr, * ) vr,
integer ldvr,
integer mm,
integer m,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CTGEVC

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

Purpose:
!>
!> CTGEVC computes some or all of the right and/or left eigenvectors of
!> a pair of complex matrices (S,P), where S and P are upper triangular.
!> Matrix pairs of this type are produced by the generalized Schur
!> factorization of a complex matrix pair (A,B):
!>
!>    A = Q*S*Z**H,  B = Q*P*Z**H
!>
!> as computed by CGGHRD + CHGEQZ.
!>
!> 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 elements 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 unitary 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.  The eigenvector corresponding to the j-th
!>          eigenvalue is computed if SELECT(j) = .TRUE..
!>          Not referenced if HOWMNY = 'A' or 'B'.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrices S and P.  N >= 0.
!>
[in]S
!>          S is COMPLEX array, dimension (LDS,N)
!>          The upper triangular matrix S from a generalized Schur
!>          factorization, as computed by CHGEQZ.
!>
[in]LDS
!>          LDS is INTEGER
!>          The leading dimension of array S.  LDS >= max(1,N).
!>
[in]P
!>          P is COMPLEX array, dimension (LDP,N)
!>          The upper triangular matrix P from a generalized Schur
!>          factorization, as computed by CHGEQZ.  P must have real
!>          diagonal elements.
!>
[in]LDP
!>          LDP is INTEGER
!>          The leading dimension of array P.  LDP >= max(1,N).
!>
[in,out]VL
!>          VL is COMPLEX array, dimension (LDVL,MM)
!>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
!>          contain an N-by-N matrix Q (usually the unitary matrix Q
!>          of left Schur vectors returned by CHGEQZ).
!>          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.
!>          Not referenced if SIDE = 'R'.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          The leading dimension of array VL.  LDVL >= 1, and if
!>          SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.
!>
[in,out]VR
!>          VR is COMPLEX array, dimension (LDVR,MM)
!>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
!>          contain an N-by-N matrix Q (usually the unitary matrix Z
!>          of right Schur vectors returned by CHGEQZ).
!>          On exit, if SIDE = 'R' or 'B', VR contains:
!>          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
!>          if HOWMNY = 'B', the matrix Z*X;
!>          if HOWMNY = 'S', the right eigenvectors of (S,P) specified by
!>                      SELECT, stored consecutively in the columns of
!>                      VR, in the same order as their eigenvalues.
!>          Not referenced if SIDE = 'L'.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.  LDVR >= 1, and if
!>          SIDE = 'R' or 'B', LDVR >= N.
!>
[in]MM
!>          MM is INTEGER
!>          The number of columns in the arrays VL and/or VR. MM >= M.
!>
[out]M
!>          M is INTEGER
!>          The number of columns in the arrays VL and/or VR actually
!>          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
!>          is set to N.  Each selected eigenvector occupies one column.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 217 of file ctgevc.f.

219*
220* -- LAPACK computational routine --
221* -- LAPACK is a software package provided by Univ. of Tennessee, --
222* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
223*
224* .. Scalar Arguments ..
225 CHARACTER HOWMNY, SIDE
226 INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
227* ..
228* .. Array Arguments ..
229 LOGICAL SELECT( * )
230 REAL RWORK( * )
231 COMPLEX P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
232 $ VR( LDVR, * ), WORK( * )
233* ..
234*
235*
236* =====================================================================
237*
238* .. Parameters ..
239 REAL ZERO, ONE
240 parameter( zero = 0.0e+0, one = 1.0e+0 )
241 COMPLEX CZERO, CONE
242 parameter( czero = ( 0.0e+0, 0.0e+0 ),
243 $ cone = ( 1.0e+0, 0.0e+0 ) )
244* ..
245* .. Local Scalars ..
246 LOGICAL COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP,
247 $ LSA, LSB
248 INTEGER I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC,
249 $ J, JE, JR
250 REAL ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG,
251 $ BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA,
252 $ SCALE, SMALL, TEMP, ULP, XMAX
253 COMPLEX BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X
254* ..
255* .. External Functions ..
256 LOGICAL LSAME
257 REAL SLAMCH
258 COMPLEX CLADIV
259 EXTERNAL lsame, slamch, cladiv
260* ..
261* .. External Subroutines ..
262 EXTERNAL cgemv, slabad, xerbla
263* ..
264* .. Intrinsic Functions ..
265 INTRINSIC abs, aimag, cmplx, conjg, max, min, real
266* ..
267* .. Statement Functions ..
268 REAL ABS1
269* ..
270* .. Statement Function definitions ..
271 abs1( x ) = abs( real( x ) ) + abs( aimag( x ) )
272* ..
273* .. Executable Statements ..
274*
275* Decode and Test the input parameters
276*
277 IF( lsame( howmny, 'A' ) ) THEN
278 ihwmny = 1
279 ilall = .true.
280 ilback = .false.
281 ELSE IF( lsame( howmny, 'S' ) ) THEN
282 ihwmny = 2
283 ilall = .false.
284 ilback = .false.
285 ELSE IF( lsame( howmny, 'B' ) ) THEN
286 ihwmny = 3
287 ilall = .true.
288 ilback = .true.
289 ELSE
290 ihwmny = -1
291 END IF
292*
293 IF( lsame( side, 'R' ) ) THEN
294 iside = 1
295 compl = .false.
296 compr = .true.
297 ELSE IF( lsame( side, 'L' ) ) THEN
298 iside = 2
299 compl = .true.
300 compr = .false.
301 ELSE IF( lsame( side, 'B' ) ) THEN
302 iside = 3
303 compl = .true.
304 compr = .true.
305 ELSE
306 iside = -1
307 END IF
308*
309 info = 0
310 IF( iside.LT.0 ) THEN
311 info = -1
312 ELSE IF( ihwmny.LT.0 ) THEN
313 info = -2
314 ELSE IF( n.LT.0 ) THEN
315 info = -4
316 ELSE IF( lds.LT.max( 1, n ) ) THEN
317 info = -6
318 ELSE IF( ldp.LT.max( 1, n ) ) THEN
319 info = -8
320 END IF
321 IF( info.NE.0 ) THEN
322 CALL xerbla( 'CTGEVC', -info )
323 RETURN
324 END IF
325*
326* Count the number of eigenvectors
327*
328 IF( .NOT.ilall ) THEN
329 im = 0
330 DO 10 j = 1, n
331 IF( SELECT( j ) )
332 $ im = im + 1
333 10 CONTINUE
334 ELSE
335 im = n
336 END IF
337*
338* Check diagonal of B
339*
340 ilbbad = .false.
341 DO 20 j = 1, n
342 IF( aimag( p( j, j ) ).NE.zero )
343 $ ilbbad = .true.
344 20 CONTINUE
345*
346 IF( ilbbad ) THEN
347 info = -7
348 ELSE IF( compl .AND. ldvl.LT.n .OR. ldvl.LT.1 ) THEN
349 info = -10
350 ELSE IF( compr .AND. ldvr.LT.n .OR. ldvr.LT.1 ) THEN
351 info = -12
352 ELSE IF( mm.LT.im ) THEN
353 info = -13
354 END IF
355 IF( info.NE.0 ) THEN
356 CALL xerbla( 'CTGEVC', -info )
357 RETURN
358 END IF
359*
360* Quick return if possible
361*
362 m = im
363 IF( n.EQ.0 )
364 $ RETURN
365*
366* Machine Constants
367*
368 safmin = slamch( 'Safe minimum' )
369 big = one / safmin
370 CALL slabad( safmin, big )
371 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
372 small = safmin*n / ulp
373 big = one / small
374 bignum = one / ( safmin*n )
375*
376* Compute the 1-norm of each column of the strictly upper triangular
377* part of A and B to check for possible overflow in the triangular
378* solver.
379*
380 anorm = abs1( s( 1, 1 ) )
381 bnorm = abs1( p( 1, 1 ) )
382 rwork( 1 ) = zero
383 rwork( n+1 ) = zero
384 DO 40 j = 2, n
385 rwork( j ) = zero
386 rwork( n+j ) = zero
387 DO 30 i = 1, j - 1
388 rwork( j ) = rwork( j ) + abs1( s( i, j ) )
389 rwork( n+j ) = rwork( n+j ) + abs1( p( i, j ) )
390 30 CONTINUE
391 anorm = max( anorm, rwork( j )+abs1( s( j, j ) ) )
392 bnorm = max( bnorm, rwork( n+j )+abs1( p( j, j ) ) )
393 40 CONTINUE
394*
395 ascale = one / max( anorm, safmin )
396 bscale = one / max( bnorm, safmin )
397*
398* Left eigenvectors
399*
400 IF( compl ) THEN
401 ieig = 0
402*
403* Main loop over eigenvalues
404*
405 DO 140 je = 1, n
406 IF( ilall ) THEN
407 ilcomp = .true.
408 ELSE
409 ilcomp = SELECT( je )
410 END IF
411 IF( ilcomp ) THEN
412 ieig = ieig + 1
413*
414 IF( abs1( s( je, je ) ).LE.safmin .AND.
415 $ abs( real( p( je, je ) ) ).LE.safmin ) THEN
416*
417* Singular matrix pencil -- return unit eigenvector
418*
419 DO 50 jr = 1, n
420 vl( jr, ieig ) = czero
421 50 CONTINUE
422 vl( ieig, ieig ) = cone
423 GO TO 140
424 END IF
425*
426* Non-singular eigenvalue:
427* Compute coefficients a and b in
428* H
429* y ( a A - b B ) = 0
430*
431 temp = one / max( abs1( s( je, je ) )*ascale,
432 $ abs( real( p( je, je ) ) )*bscale, safmin )
433 salpha = ( temp*s( je, je ) )*ascale
434 sbeta = ( temp*real( p( je, je ) ) )*bscale
435 acoeff = sbeta*ascale
436 bcoeff = salpha*bscale
437*
438* Scale to avoid underflow
439*
440 lsa = abs( sbeta ).GE.safmin .AND. abs( acoeff ).LT.small
441 lsb = abs1( salpha ).GE.safmin .AND. abs1( bcoeff ).LT.
442 $ small
443*
444 scale = one
445 IF( lsa )
446 $ scale = ( small / abs( sbeta ) )*min( anorm, big )
447 IF( lsb )
448 $ scale = max( scale, ( small / abs1( salpha ) )*
449 $ min( bnorm, big ) )
450 IF( lsa .OR. lsb ) THEN
451 scale = min( scale, one /
452 $ ( safmin*max( one, abs( acoeff ),
453 $ abs1( bcoeff ) ) ) )
454 IF( lsa ) THEN
455 acoeff = ascale*( scale*sbeta )
456 ELSE
457 acoeff = scale*acoeff
458 END IF
459 IF( lsb ) THEN
460 bcoeff = bscale*( scale*salpha )
461 ELSE
462 bcoeff = scale*bcoeff
463 END IF
464 END IF
465*
466 acoefa = abs( acoeff )
467 bcoefa = abs1( bcoeff )
468 xmax = one
469 DO 60 jr = 1, n
470 work( jr ) = czero
471 60 CONTINUE
472 work( je ) = cone
473 dmin = max( ulp*acoefa*anorm, ulp*bcoefa*bnorm, safmin )
474*
475* H
476* Triangular solve of (a A - b B) y = 0
477*
478* H
479* (rowwise in (a A - b B) , or columnwise in a A - b B)
480*
481 DO 100 j = je + 1, n
482*
483* Compute
484* j-1
485* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k)
486* k=je
487* (Scale if necessary)
488*
489 temp = one / xmax
490 IF( acoefa*rwork( j )+bcoefa*rwork( n+j ).GT.bignum*
491 $ temp ) THEN
492 DO 70 jr = je, j - 1
493 work( jr ) = temp*work( jr )
494 70 CONTINUE
495 xmax = one
496 END IF
497 suma = czero
498 sumb = czero
499*
500 DO 80 jr = je, j - 1
501 suma = suma + conjg( s( jr, j ) )*work( jr )
502 sumb = sumb + conjg( p( jr, j ) )*work( jr )
503 80 CONTINUE
504 sum = acoeff*suma - conjg( bcoeff )*sumb
505*
506* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) )
507*
508* with scaling and perturbation of the denominator
509*
510 d = conjg( acoeff*s( j, j )-bcoeff*p( j, j ) )
511 IF( abs1( d ).LE.dmin )
512 $ d = cmplx( dmin )
513*
514 IF( abs1( d ).LT.one ) THEN
515 IF( abs1( sum ).GE.bignum*abs1( d ) ) THEN
516 temp = one / abs1( sum )
517 DO 90 jr = je, j - 1
518 work( jr ) = temp*work( jr )
519 90 CONTINUE
520 xmax = temp*xmax
521 sum = temp*sum
522 END IF
523 END IF
524 work( j ) = cladiv( -sum, d )
525 xmax = max( xmax, abs1( work( j ) ) )
526 100 CONTINUE
527*
528* Back transform eigenvector if HOWMNY='B'.
529*
530 IF( ilback ) THEN
531 CALL cgemv( 'N', n, n+1-je, cone, vl( 1, je ), ldvl,
532 $ work( je ), 1, czero, work( n+1 ), 1 )
533 isrc = 2
534 ibeg = 1
535 ELSE
536 isrc = 1
537 ibeg = je
538 END IF
539*
540* Copy and scale eigenvector into column of VL
541*
542 xmax = zero
543 DO 110 jr = ibeg, n
544 xmax = max( xmax, abs1( work( ( isrc-1 )*n+jr ) ) )
545 110 CONTINUE
546*
547 IF( xmax.GT.safmin ) THEN
548 temp = one / xmax
549 DO 120 jr = ibeg, n
550 vl( jr, ieig ) = temp*work( ( isrc-1 )*n+jr )
551 120 CONTINUE
552 ELSE
553 ibeg = n + 1
554 END IF
555*
556 DO 130 jr = 1, ibeg - 1
557 vl( jr, ieig ) = czero
558 130 CONTINUE
559*
560 END IF
561 140 CONTINUE
562 END IF
563*
564* Right eigenvectors
565*
566 IF( compr ) THEN
567 ieig = im + 1
568*
569* Main loop over eigenvalues
570*
571 DO 250 je = n, 1, -1
572 IF( ilall ) THEN
573 ilcomp = .true.
574 ELSE
575 ilcomp = SELECT( je )
576 END IF
577 IF( ilcomp ) THEN
578 ieig = ieig - 1
579*
580 IF( abs1( s( je, je ) ).LE.safmin .AND.
581 $ abs( real( p( je, je ) ) ).LE.safmin ) THEN
582*
583* Singular matrix pencil -- return unit eigenvector
584*
585 DO 150 jr = 1, n
586 vr( jr, ieig ) = czero
587 150 CONTINUE
588 vr( ieig, ieig ) = cone
589 GO TO 250
590 END IF
591*
592* Non-singular eigenvalue:
593* Compute coefficients a and b in
594*
595* ( a A - b B ) x = 0
596*
597 temp = one / max( abs1( s( je, je ) )*ascale,
598 $ abs( real( p( je, je ) ) )*bscale, safmin )
599 salpha = ( temp*s( je, je ) )*ascale
600 sbeta = ( temp*real( p( je, je ) ) )*bscale
601 acoeff = sbeta*ascale
602 bcoeff = salpha*bscale
603*
604* Scale to avoid underflow
605*
606 lsa = abs( sbeta ).GE.safmin .AND. abs( acoeff ).LT.small
607 lsb = abs1( salpha ).GE.safmin .AND. abs1( bcoeff ).LT.
608 $ small
609*
610 scale = one
611 IF( lsa )
612 $ scale = ( small / abs( sbeta ) )*min( anorm, big )
613 IF( lsb )
614 $ scale = max( scale, ( small / abs1( salpha ) )*
615 $ min( bnorm, big ) )
616 IF( lsa .OR. lsb ) THEN
617 scale = min( scale, one /
618 $ ( safmin*max( one, abs( acoeff ),
619 $ abs1( bcoeff ) ) ) )
620 IF( lsa ) THEN
621 acoeff = ascale*( scale*sbeta )
622 ELSE
623 acoeff = scale*acoeff
624 END IF
625 IF( lsb ) THEN
626 bcoeff = bscale*( scale*salpha )
627 ELSE
628 bcoeff = scale*bcoeff
629 END IF
630 END IF
631*
632 acoefa = abs( acoeff )
633 bcoefa = abs1( bcoeff )
634 xmax = one
635 DO 160 jr = 1, n
636 work( jr ) = czero
637 160 CONTINUE
638 work( je ) = cone
639 dmin = max( ulp*acoefa*anorm, ulp*bcoefa*bnorm, safmin )
640*
641* Triangular solve of (a A - b B) x = 0 (columnwise)
642*
643* WORK(1:j-1) contains sums w,
644* WORK(j+1:JE) contains x
645*
646 DO 170 jr = 1, je - 1
647 work( jr ) = acoeff*s( jr, je ) - bcoeff*p( jr, je )
648 170 CONTINUE
649 work( je ) = cone
650*
651 DO 210 j = je - 1, 1, -1
652*
653* Form x(j) := - w(j) / d
654* with scaling and perturbation of the denominator
655*
656 d = acoeff*s( j, j ) - bcoeff*p( j, j )
657 IF( abs1( d ).LE.dmin )
658 $ d = cmplx( dmin )
659*
660 IF( abs1( d ).LT.one ) THEN
661 IF( abs1( work( j ) ).GE.bignum*abs1( d ) ) THEN
662 temp = one / abs1( work( j ) )
663 DO 180 jr = 1, je
664 work( jr ) = temp*work( jr )
665 180 CONTINUE
666 END IF
667 END IF
668*
669 work( j ) = cladiv( -work( j ), d )
670*
671 IF( j.GT.1 ) THEN
672*
673* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
674*
675 IF( abs1( work( j ) ).GT.one ) THEN
676 temp = one / abs1( work( j ) )
677 IF( acoefa*rwork( j )+bcoefa*rwork( n+j ).GE.
678 $ bignum*temp ) THEN
679 DO 190 jr = 1, je
680 work( jr ) = temp*work( jr )
681 190 CONTINUE
682 END IF
683 END IF
684*
685 ca = acoeff*work( j )
686 cb = bcoeff*work( j )
687 DO 200 jr = 1, j - 1
688 work( jr ) = work( jr ) + ca*s( jr, j ) -
689 $ cb*p( jr, j )
690 200 CONTINUE
691 END IF
692 210 CONTINUE
693*
694* Back transform eigenvector if HOWMNY='B'.
695*
696 IF( ilback ) THEN
697 CALL cgemv( 'N', n, je, cone, vr, ldvr, work, 1,
698 $ czero, work( n+1 ), 1 )
699 isrc = 2
700 iend = n
701 ELSE
702 isrc = 1
703 iend = je
704 END IF
705*
706* Copy and scale eigenvector into column of VR
707*
708 xmax = zero
709 DO 220 jr = 1, iend
710 xmax = max( xmax, abs1( work( ( isrc-1 )*n+jr ) ) )
711 220 CONTINUE
712*
713 IF( xmax.GT.safmin ) THEN
714 temp = one / xmax
715 DO 230 jr = 1, iend
716 vr( jr, ieig ) = temp*work( ( isrc-1 )*n+jr )
717 230 CONTINUE
718 ELSE
719 iend = 0
720 END IF
721*
722 DO 240 jr = iend + 1, n
723 vr( jr, ieig ) = czero
724 240 CONTINUE
725*
726 END IF
727 250 CONTINUE
728 END IF
729*
730 RETURN
731*
732* End of CTGEVC
733*

◆ ctgexc()

subroutine ctgexc ( logical wantq,
logical wantz,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldq, * ) q,
integer ldq,
complex, dimension( ldz, * ) z,
integer ldz,
integer ifst,
integer ilst,
integer info )

CTGEXC

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

Purpose:
!>
!> CTGEXC reorders the generalized Schur decomposition of a complex
!> matrix pair (A,B), using an unitary equivalence transformation
!> (A, B) := Q * (A, B) * Z**H, so that the diagonal block of (A, B) with
!> row index IFST is moved to row ILST.
!>
!> (A, B) must be in generalized Schur canonical form, that is, A and
!> B are both upper triangular.
!>
!> Optionally, the matrices Q and Z of generalized Schur vectors are
!> updated.
!>
!>        Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H
!>        Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H
!>
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 COMPLEX array, dimension (LDA,N)
!>          On entry, the upper triangular matrix A in the pair (A, B).
!>          On exit, the updated matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,N)
!>          On entry, the upper triangular matrix B in the pair (A, B).
!>          On exit, the updated matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!>
[in,out]Q
!>          Q is COMPLEX array, dimension (LDQ,N)
!>          On entry, if WANTQ = .TRUE., the unitary 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 COMPLEX array, dimension (LDZ,N)
!>          On entry, if WANTZ = .TRUE., the unitary 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]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.
!>
[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.
[2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified Eigenvalues of a Regular Matrix Pair (A, B) and Condition Estimation: Theory, Algorithms and Software, Report UMINF - 94.04, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. To appear in Numerical Algorithms, 1996.
[3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software for Solving the Generalized Sylvester Equation and Estimating the Separation between Regular Matrix Pairs, Report UMINF - 93.23, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, December 1993, Revised April 1994, Also as LAPACK working Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.

Definition at line 198 of file ctgexc.f.

200*
201* -- LAPACK computational routine --
202* -- LAPACK is a software package provided by Univ. of Tennessee, --
203* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
204*
205* .. Scalar Arguments ..
206 LOGICAL WANTQ, WANTZ
207 INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N
208* ..
209* .. Array Arguments ..
210 COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
211 $ Z( LDZ, * )
212* ..
213*
214* =====================================================================
215*
216* .. Local Scalars ..
217 INTEGER HERE
218* ..
219* .. External Subroutines ..
220 EXTERNAL ctgex2, xerbla
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC max
224* ..
225* .. Executable Statements ..
226*
227* Decode and test input arguments.
228 info = 0
229 IF( n.LT.0 ) THEN
230 info = -3
231 ELSE IF( lda.LT.max( 1, n ) ) THEN
232 info = -5
233 ELSE IF( ldb.LT.max( 1, n ) ) THEN
234 info = -7
235 ELSE IF( ldq.LT.1 .OR. wantq .AND. ( ldq.LT.max( 1, n ) ) ) THEN
236 info = -9
237 ELSE IF( ldz.LT.1 .OR. wantz .AND. ( ldz.LT.max( 1, n ) ) ) THEN
238 info = -11
239 ELSE IF( ifst.LT.1 .OR. ifst.GT.n ) THEN
240 info = -12
241 ELSE IF( ilst.LT.1 .OR. ilst.GT.n ) THEN
242 info = -13
243 END IF
244 IF( info.NE.0 ) THEN
245 CALL xerbla( 'CTGEXC', -info )
246 RETURN
247 END IF
248*
249* Quick return if possible
250*
251 IF( n.LE.1 )
252 $ RETURN
253 IF( ifst.EQ.ilst )
254 $ RETURN
255*
256 IF( ifst.LT.ilst ) THEN
257*
258 here = ifst
259*
260 10 CONTINUE
261*
262* Swap with next one below
263*
264 CALL ctgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,
265 $ here, info )
266 IF( info.NE.0 ) THEN
267 ilst = here
268 RETURN
269 END IF
270 here = here + 1
271 IF( here.LT.ilst )
272 $ GO TO 10
273 here = here - 1
274 ELSE
275 here = ifst - 1
276*
277 20 CONTINUE
278*
279* Swap with next one above
280*
281 CALL ctgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,
282 $ here, info )
283 IF( info.NE.0 ) THEN
284 ilst = here
285 RETURN
286 END IF
287 here = here - 1
288 IF( here.GE.ilst )
289 $ GO TO 20
290 here = here + 1
291 END IF
292 ilst = here
293 RETURN
294*
295* End of CTGEXC
296*
ctgex2
subroutine ctgex2(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, j1, info)
CTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an unitary equiva...
Definition ctgex2.f:190