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

Functions

subroutine zgeqpf (m, n, a, lda, jpvt, tau, work, rwork, info)
 ZGEQPF
subroutine zgebak (job, side, n, ilo, ihi, scale, m, v, ldv, info)
 ZGEBAK
subroutine zgebal (job, n, a, lda, ilo, ihi, scale, info)
 ZGEBAL
subroutine zgebd2 (m, n, a, lda, d, e, tauq, taup, work, info)
 ZGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
subroutine zgebrd (m, n, a, lda, d, e, tauq, taup, work, lwork, info)
 ZGEBRD
subroutine zgecon (norm, n, a, lda, anorm, rcond, work, rwork, info)
 ZGECON
subroutine zgeequ (m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
 ZGEEQU
subroutine zgeequb (m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
 ZGEEQUB
subroutine zgehd2 (n, ilo, ihi, a, lda, tau, work, info)
 ZGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
subroutine zgehrd (n, ilo, ihi, a, lda, tau, work, lwork, info)
 ZGEHRD
subroutine zgelq2 (m, n, a, lda, tau, work, info)
 ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
subroutine zgelqf (m, n, a, lda, tau, work, lwork, info)
 ZGELQF
subroutine zgemqrt (side, trans, m, n, k, nb, v, ldv, t, ldt, c, ldc, work, info)
 ZGEMQRT
subroutine zgeql2 (m, n, a, lda, tau, work, info)
 ZGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.
subroutine zgeqlf (m, n, a, lda, tau, work, lwork, info)
 ZGEQLF
subroutine zgeqp3 (m, n, a, lda, jpvt, tau, work, lwork, rwork, info)
 ZGEQP3
subroutine zgeqr2 (m, n, a, lda, tau, work, info)
 ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
subroutine zgeqr2p (m, n, a, lda, tau, work, info)
 ZGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elements using an unblocked algorithm.
subroutine zgeqrf (m, n, a, lda, tau, work, lwork, info)
 ZGEQRF
subroutine zgeqrfp (m, n, a, lda, tau, work, lwork, info)
 ZGEQRFP
subroutine zgeqrt (m, n, nb, a, lda, t, ldt, work, info)
 ZGEQRT
subroutine zgeqrt2 (m, n, a, lda, t, ldt, info)
 ZGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.
recursive subroutine zgeqrt3 (m, n, a, lda, t, ldt, info)
 ZGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.
subroutine zgerfs (trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
 ZGERFS
subroutine zgerfsx (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)
 ZGERFSX
subroutine zgerq2 (m, n, a, lda, tau, work, info)
 ZGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
subroutine zgerqf (m, n, a, lda, tau, work, lwork, info)
 ZGERQF
subroutine zgesvj (joba, jobu, jobv, m, n, a, lda, sva, mv, v, ldv, cwork, lwork, rwork, lrwork, info)
  ZGESVJ
subroutine zgetf2 (m, n, a, lda, ipiv, info)
 ZGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm).
subroutine zgetrf (m, n, a, lda, ipiv, info)
 ZGETRF
recursive subroutine zgetrf2 (m, n, a, lda, ipiv, info)
 ZGETRF2
subroutine zgetri (n, a, lda, ipiv, work, lwork, info)
 ZGETRI
subroutine zgetrs (trans, n, nrhs, a, lda, ipiv, b, ldb, info)
 ZGETRS
subroutine zhgeqz (job, compq, compz, n, ilo, ihi, h, ldh, t, ldt, alpha, beta, q, ldq, z, ldz, work, lwork, rwork, info)
 ZHGEQZ
subroutine zla_geamv (trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
 ZLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds.
double precision function zla_gercond_c (trans, n, a, lda, af, ldaf, ipiv, c, capply, info, work, rwork)
 ZLA_GERCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for general matrices.
double precision function zla_gercond_x (trans, n, a, lda, af, ldaf, ipiv, x, info, work, rwork)
 ZLA_GERCOND_X computes the infinity norm condition number of op(A)*diag(x) for general matrices.
subroutine zla_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)
 ZLA_GERFSX_EXTENDED
double precision function zla_gerpvgrw (n, ncols, a, lda, af, ldaf)
 ZLA_GERPVGRW multiplies a square real matrix by a complex matrix.
recursive subroutine zlaqz0 (wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb, alpha, beta, q, ldq, z, ldz, work, lwork, rwork, rec, info)
 ZLAQZ0
subroutine zlaqz1 (ilq, ilz, k, istartm, istopm, ihi, a, lda, b, ldb, nq, qstart, q, ldq, nz, zstart, z, ldz)
 ZLAQZ1
recursive subroutine zlaqz2 (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)
 ZLAQZ2
subroutine zlaqz3 (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)
 ZLAQZ3
subroutine zlaunhr_col_getrfnp (m, n, a, lda, d, info)
 ZLAUNHR_COL_GETRFNP
recursive subroutine zlaunhr_col_getrfnp2 (m, n, a, lda, d, info)
 ZLAUNHR_COL_GETRFNP2
subroutine ztgevc (side, howmny, select, n, s, lds, p, ldp, vl, ldvl, vr, ldvr, mm, m, work, rwork, info)
 ZTGEVC
subroutine ztgexc (wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, info)
 ZTGEXC

Detailed Description

This is the group of complex16 computational functions for GE matrices

Function Documentation

◆ zgebak()

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

ZGEBAK

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

Purpose:
!>
!> ZGEBAK forms the right or left eigenvectors of a complex general
!> matrix by backward transformation on the computed eigenvectors of the
!> balanced matrix output by ZGEBAL.
!>
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 ZGEBAL.
!>
[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 ZGEBAL.
!>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!>
[in]SCALE
!>          SCALE is DOUBLE PRECISION array, dimension (N)
!>          Details of the permutation and scaling factors, as returned
!>          by ZGEBAL.
!>
[in]M
!>          M is INTEGER
!>          The number of columns of the matrix V.  M >= 0.
!>
[in,out]V
!>          V is COMPLEX*16 array, dimension (LDV,M)
!>          On entry, the matrix of right or left eigenvectors to be
!>          transformed, as returned by ZHSEIN or ZTREVC.
!>          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 zgebak.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 DOUBLE PRECISION SCALE( * )
142 COMPLEX*16 V( LDV, * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 DOUBLE PRECISION ONE
149 parameter( one = 1.0d+0 )
150* ..
151* .. Local Scalars ..
152 LOGICAL LEFTV, RIGHTV
153 INTEGER I, II, K
154 DOUBLE PRECISION S
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 EXTERNAL lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL xerbla, zdscal, zswap
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( 'ZGEBAK', -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 zdscal( 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 zdscal( 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 zswap( 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 zswap( 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 ZGEBAK
266*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
zdscal
subroutine zdscal(n, da, zx, incx)
ZDSCAL
Definition zdscal.f:78
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ zgebal()

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

ZGEBAL

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

Purpose:
!>
!> ZGEBAL 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*16 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 INTEGER such that on exit
!>          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
!>          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION array, dimension (N)
!>          Details of the permutations and scaling factors applied to
!>          A.  If P(j) is the index of the row and column interchanged
!>          with row and column j and D(j) is the scaling factor
!>          applied to row and column j, then
!>          SCALE(j) = P(j)    for j = 1,...,ILO-1
!>                   = D(j)    for j = ILO,...,IHI
!>                   = P(j)    for j = IHI+1,...,N.
!>          The order in which the interchanges are made is N to IHI+1,
!>          then 1 to ILO-1.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The permutations consist of row and column interchanges which put
!>  the matrix in the form
!>
!>             ( T1   X   Y  )
!>     P A P = (  0   B   Z  )
!>             (  0   0   T2 )
!>
!>  where T1 and T2 are upper triangular matrices whose eigenvalues lie
!>  along the diagonal.  The column indices ILO and IHI mark the starting
!>  and ending columns of the submatrix B. Balancing consists of applying
!>  a diagonal similarity transformation inv(D) * B * D to make the
!>  1-norms of each row of B and its corresponding column nearly equal.
!>  The output matrix is
!>
!>     ( T1     X*D          Y    )
!>     (  0  inv(D)*B*D  inv(D)*Z ).
!>     (  0      0           T2   )
!>
!>  Information about the permutations P and the diagonal matrix D is
!>  returned in the vector SCALE.
!>
!>  This subroutine is based on the EISPACK routine CBAL.
!>
!>  Modified by Tzu-Yi Chen, Computer Science Division, University of
!>    California at Berkeley, USA
!>

Definition at line 161 of file zgebal.f.

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

◆ zgebd2()

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

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

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

Purpose:
!>
!> ZGEBD2 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*16 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 DOUBLE PRECISION array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (min(M,N)-1)
!>          The off-diagonal elements of the bidiagonal matrix B:
!>          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
!>          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
!>
[out]TAUQ
!>          TAUQ is COMPLEX*16 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*16 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*16 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 188 of file zgebd2.f.

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

◆ zgebrd()

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

ZGEBRD

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

Purpose:
!>
!> ZGEBRD 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*16 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 DOUBLE PRECISION array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B:
!>          D(i) = A(i,i).
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (min(M,N)-1)
!>          The off-diagonal elements of the bidiagonal matrix B:
!>          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
!>          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
!>
[out]TAUQ
!>          TAUQ is COMPLEX*16 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*16 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*16 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 203 of file zgebrd.f.

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

◆ zgecon()

subroutine zgecon ( character norm,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision anorm,
double precision rcond,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZGECON

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

Purpose:
!>
!> ZGECON 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 ZGETRF.
!>
!> 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*16 array, dimension (LDA,N)
!>          The factors L and U from the factorization A = P*L*U
!>          as computed by ZGETRF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]ANORM
!>          ANORM is DOUBLE PRECISION
!>          If NORM = '1' or 'O', the 1-norm of the original matrix A.
!>          If NORM = 'I', the infinity-norm of the original matrix A.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file zgecon.f.

124*
125* -- LAPACK computational routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 CHARACTER NORM
131 INTEGER INFO, LDA, N
132 DOUBLE PRECISION ANORM, RCOND
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION RWORK( * )
136 COMPLEX*16 A( LDA, * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 DOUBLE PRECISION ONE, ZERO
143 parameter( one = 1.0d+0, zero = 0.0d+0 )
144* ..
145* .. Local Scalars ..
146 LOGICAL ONENRM
147 CHARACTER NORMIN
148 INTEGER IX, KASE, KASE1
149 DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU
150 COMPLEX*16 ZDUM
151* ..
152* .. Local Arrays ..
153 INTEGER ISAVE( 3 )
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 INTEGER IZAMAX
158 DOUBLE PRECISION DLAMCH
159 EXTERNAL lsame, izamax, dlamch
160* ..
161* .. External Subroutines ..
162 EXTERNAL xerbla, zdrscl, zlacn2, zlatrs
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC abs, dble, dimag, max
166* ..
167* .. Statement Functions ..
168 DOUBLE PRECISION CABS1
169* ..
170* .. Statement Function definitions ..
171 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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( 'ZGECON', -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 = dlamch( '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 zlacn2( 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 zlatrs( 'Lower', 'No transpose', 'Unit', normin, n, a,
223 $ lda, work, sl, rwork, info )
224*
225* Multiply by inv(U).
226*
227 CALL zlatrs( '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 zlatrs( '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 zlatrs( '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 = izamax( n, work, 1 )
249 IF( scale.LT.cabs1( work( ix ) )*smlnum .OR. scale.EQ.zero )
250 $ GO TO 20
251 CALL zdrscl( 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 ZGECON
265*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
zdrscl
subroutine zdrscl(n, sa, sx, incx)
ZDRSCL multiplies a vector by the reciprocal of a real scalar.
Definition zdrscl.f:84
zlacn2
subroutine zlacn2(n, v, x, est, kase, isave)
ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
Definition zlacn2.f:133
zlatrs
subroutine zlatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition zlatrs.f:239

◆ zgeequ()

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

ZGEEQU

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

Purpose:
!>
!> ZGEEQU 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*16 array, dimension (LDA,N)
!>          The M-by-N matrix whose equilibration factors are
!>          to be computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]R
!>          R is DOUBLE PRECISION array, dimension (M)
!>          If INFO = 0 or INFO > M, R contains the row scale factors
!>          for A.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (N)
!>          If INFO = 0,  C contains the column scale factors for A.
!>
[out]ROWCND
!>          ROWCND is DOUBLE PRECISION
!>          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
!>          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
!>          AMAX is neither too large nor too small, it is not worth
!>          scaling by R.
!>
[out]COLCND
!>          COLCND is DOUBLE PRECISION
!>          If INFO = 0, COLCND contains the ratio of the smallest
!>          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
!>          worth scaling by C.
!>
[out]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix element.  If AMAX is very
!>          close to overflow or very close to underflow, the matrix
!>          should be scaled.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i,  and i is
!>                <= M:  the i-th row of A is exactly zero
!>                >  M:  the (i-M)-th column of A is exactly zero
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 138 of file zgeequ.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 DOUBLE PRECISION AMAX, COLCND, ROWCND
148* ..
149* .. Array Arguments ..
150 DOUBLE PRECISION C( * ), R( * )
151 COMPLEX*16 A( LDA, * )
152* ..
153*
154* =====================================================================
155*
156* .. Parameters ..
157 DOUBLE PRECISION ONE, ZERO
158 parameter( one = 1.0d+0, zero = 0.0d+0 )
159* ..
160* .. Local Scalars ..
161 INTEGER I, J
162 DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM
163 COMPLEX*16 ZDUM
164* ..
165* .. External Functions ..
166 DOUBLE PRECISION DLAMCH
167 EXTERNAL dlamch
168* ..
169* .. External Subroutines ..
170 EXTERNAL xerbla
171* ..
172* .. Intrinsic Functions ..
173 INTRINSIC abs, dble, dimag, max, min
174* ..
175* .. Statement Functions ..
176 DOUBLE PRECISION CABS1
177* ..
178* .. Statement Function definitions ..
179 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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( 'ZGEEQU', -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 = dlamch( '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 ZGEEQU
309*

◆ zgeequb()

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

ZGEEQUB

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

Purpose:
!>
!> ZGEEQUB 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 ZGEEQU 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*16 array, dimension (LDA,N)
!>          The M-by-N matrix whose equilibration factors are
!>          to be computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]R
!>          R is DOUBLE PRECISION array, dimension (M)
!>          If INFO = 0 or INFO > M, R contains the row scale factors
!>          for A.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (N)
!>          If INFO = 0,  C contains the column scale factors for A.
!>
[out]ROWCND
!>          ROWCND is DOUBLE PRECISION
!>          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
!>          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
!>          AMAX is neither too large nor too small, it is not worth
!>          scaling by R.
!>
[out]COLCND
!>          COLCND is DOUBLE PRECISION
!>          If INFO = 0, COLCND contains the ratio of the smallest
!>          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
!>          worth scaling by C.
!>
[out]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix element.  If AMAX is very
!>          close to overflow or very close to underflow, the matrix
!>          should be scaled.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i,  and i is
!>                <= M:  the i-th row of A is exactly zero
!>                >  M:  the (i-M)-th column of A is exactly zero
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 145 of file zgeequb.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 DOUBLE PRECISION AMAX, COLCND, ROWCND
155* ..
156* .. Array Arguments ..
157 DOUBLE PRECISION C( * ), R( * )
158 COMPLEX*16 A( LDA, * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 DOUBLE PRECISION ONE, ZERO
165 parameter( one = 1.0d+0, zero = 0.0d+0 )
166* ..
167* .. Local Scalars ..
168 INTEGER I, J
169 DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX
170 COMPLEX*16 ZDUM
171* ..
172* .. External Functions ..
173 DOUBLE PRECISION DLAMCH
174 EXTERNAL dlamch
175* ..
176* .. External Subroutines ..
177 EXTERNAL xerbla
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC abs, max, min, log, dble, dimag
181* ..
182* .. Statement Functions ..
183 DOUBLE PRECISION CABS1
184* ..
185* .. Statement Function definitions ..
186 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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( 'ZGEEQUB', -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 = dlamch( 'S' )
217 bignum = one / smlnum
218 radix = dlamch( '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 ZGEEQUB
326*

◆ zgehd2()

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

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

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

Purpose:
!>
!> ZGEHD2 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 ZGEBAL; 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*16 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*16 array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 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 zgehd2.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*16 A( LDA, * ), TAU( * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 COMPLEX*16 ONE
165 parameter( one = ( 1.0d+0, 0.0d+0 ) )
166* ..
167* .. Local Scalars ..
168 INTEGER I
169 COMPLEX*16 ALPHA
170* ..
171* .. External Subroutines ..
172 EXTERNAL xerbla, zlarf, zlarfg
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC dconjg, 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( 'ZGEHD2', -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 zlarfg( 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 zlarf( '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 zlarf( 'Left', ihi-i, n-i, a( i+1, i ), 1,
212 $ dconjg( 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 ZGEHD2
220*

◆ zgehrd()

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

ZGEHRD

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

Purpose:
!>
!> ZGEHRD 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 ZGEBAL; 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*16 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*16 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*16 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 ZGEHRD
!>  subroutine incorporating improvements proposed by Quintana-Orti and
!>  Van de Geijn (2006). (See ZLAHR2.)
!>

Definition at line 166 of file zgehrd.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*16 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*16 ZERO, ONE
186 parameter( zero = ( 0.0d+0, 0.0d+0 ),
187 $ one = ( 1.0d+0, 0.0d+0 ) )
188* ..
189* .. Local Scalars ..
190 LOGICAL LQUERY
191 INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB,
192 $ NBMIN, NH, NX
193 COMPLEX*16 EI
194* ..
195* .. External Subroutines ..
196 EXTERNAL zaxpy, zgehd2, zgemm, zlahr2, zlarfb, ztrmm,
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, 'ZGEHRD', ' ', n, ilo, ihi, -1 ) )
229 lwkopt = n*nb + tsize
230 work( 1 ) = lwkopt
231 ENDIF
232*
233 IF( info.NE.0 ) THEN
234 CALL xerbla( 'ZGEHRD', -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, 'ZGEHRD', ' ', 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, 'ZGEHRD', ' ', 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, 'ZGEHRD', ' ', 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 zlahr2( 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 zgemm( '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 ztrmm( '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 zaxpy( 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 zlarfb( '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 zgehd2( n, i, ihi, a, lda, tau, work, iinfo )
347 work( 1 ) = lwkopt
348*
349 RETURN
350*
351* End of ZGEHRD
352*
zgehd2
subroutine zgehd2(n, ilo, ihi, a, lda, tau, work, info)
ZGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
Definition zgehd2.f:149
zlarfb
subroutine zlarfb(side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
Definition zlarfb.f:197
zlahr2
subroutine zlahr2(n, k, nb, a, lda, tau, t, ldt, y, ldy)
ZLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elemen...
Definition zlahr2.f:181
zaxpy
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
Definition zaxpy.f:88
ztrmm
subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRMM
Definition ztrmm.f:177

◆ zgelq2()

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

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

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

Purpose:
!>
!> ZGELQ2 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*16 array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the m by min(m,n) lower trapezoidal matrix L (L is
!>          lower triangular if m <= n); the elements above the diagonal,
!>          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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 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 zgelq2.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*16 A( LDA, * ), TAU( * ), WORK( * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 COMPLEX*16 ONE
145 parameter( one = ( 1.0d+0, 0.0d+0 ) )
146* ..
147* .. Local Scalars ..
148 INTEGER I, K
149 COMPLEX*16 ALPHA
150* ..
151* .. External Subroutines ..
152 EXTERNAL xerbla, zlacgv, zlarf, zlarfg
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( 'ZGELQ2', -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 zlacgv( n-i+1, a( i, i ), lda )
181 alpha = a( i, i )
182 CALL zlarfg( 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 zlarf( '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 zlacgv( n-i+1, a( i, i ), lda )
194 10 CONTINUE
195 RETURN
196*
197* End of ZGELQ2
198*

◆ zgelqf()

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

ZGELQF

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

Purpose:
!>
!> ZGELQF 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*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the m-by-min(m,n) lower trapezoidal matrix L (L is
!>          lower triangular if m <= n); the elements above the diagonal,
!>          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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  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 zgelqf.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*16 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 xerbla, zgelq2, zlarfb, zlarft
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, 'ZGELQF', ' ', 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( 'ZGELQF', -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, 'ZGELQF', ' ', 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, 'ZGELQF', ' ', 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 zgelq2( 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 zlarft( '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 zlarfb( '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 zgelq2( 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 ZGELQF
273*
zgelq2
subroutine zgelq2(m, n, a, lda, tau, work, info)
ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition zgelq2.f:129
zlarft
subroutine zlarft(direct, storev, n, k, v, ldv, tau, t, ldt)
ZLARFT forms the triangular factor T of a block reflector H = I - vtvH
Definition zlarft.f:163

◆ zgemqrt()

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

ZGEMQRT

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

Purpose:
!>
!> ZGEMQRT 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 ZGEQRT.
!>
!> 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 ZGEQRT.
!>
[in]V
!>          V is COMPLEX*16 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
!>          ZGEQRT 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*16 array, dimension (LDT,K)
!>          The upper triangular factors of the block reflectors
!>          as returned by ZGEQRT, 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*16 array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q C, Q**H C, C Q**H or C Q.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array. The dimension of WORK is
!>           N*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 zgemqrt.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*16 V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * )
179* ..
180*
181* =====================================================================
182*
183* ..
184* .. Local Scalars ..
185 LOGICAL LEFT, RIGHT, TRAN, NOTRAN
186 INTEGER I, IB, LDWORK, KF, Q
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 EXTERNAL lsame
191* ..
192* .. External Subroutines ..
193 EXTERNAL xerbla, zlarfb
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC max, min
197* ..
198* .. Executable Statements ..
199*
200* .. Test the input arguments ..
201*
202 info = 0
203 left = lsame( side, 'L' )
204 right = lsame( side, 'R' )
205 tran = lsame( trans, 'C' )
206 notran = lsame( trans, 'N' )
207*
208 IF( left ) THEN
209 ldwork = max( 1, n )
210 q = m
211 ELSE IF ( right ) THEN
212 ldwork = max( 1, m )
213 q = n
214 END IF
215 IF( .NOT.left .AND. .NOT.right ) THEN
216 info = -1
217 ELSE IF( .NOT.tran .AND. .NOT.notran ) THEN
218 info = -2
219 ELSE IF( m.LT.0 ) THEN
220 info = -3
221 ELSE IF( n.LT.0 ) THEN
222 info = -4
223 ELSE IF( k.LT.0 .OR. k.GT.q ) THEN
224 info = -5
225 ELSE IF( 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( 'ZGEMQRT', -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 zlarfb( '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 zlarfb( '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 zlarfb( '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 zlarfb( '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 ZGEMQRT
287*

◆ zgeql2()

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

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

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

Purpose:
!>
!> ZGEQL2 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 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 zgeql2.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*16 A( LDA, * ), TAU( * ), WORK( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 COMPLEX*16 ONE
139 parameter( one = ( 1.0d+0, 0.0d+0 ) )
140* ..
141* .. Local Scalars ..
142 INTEGER I, K
143 COMPLEX*16 ALPHA
144* ..
145* .. External Subroutines ..
146 EXTERNAL xerbla, zlarf, zlarfg
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC dconjg, 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( 'ZGEQL2', -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 zlarfg( 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 zlarf( 'Left', m-k+i, n-k+i-1, a( 1, n-k+i ), 1,
182 $ dconjg( tau( i ) ), a, lda, work )
183 a( m-k+i, n-k+i ) = alpha
184 10 CONTINUE
185 RETURN
186*
187* End of ZGEQL2
188*

◆ zgeqlf()

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

ZGEQLF

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

Purpose:
!>
!> ZGEQLF 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  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 zgeqlf.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*16 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 xerbla, zgeql2, zlarfb, zlarft
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, 'ZGEQLF', ' ', 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( 'ZGEQLF', -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, 'ZGEQLF', ' ', 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, 'ZGEQLF', ' ', 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 zgeql2( 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 zlarft( '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 zlarfb( '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 zgeql2( mu, nu, a, lda, tau, work, iinfo )
278*
279 work( 1 ) = iws
280 RETURN
281*
282* End of ZGEQLF
283*
zgeql2
subroutine zgeql2(m, n, a, lda, tau, work, info)
ZGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.
Definition zgeql2.f:123

◆ zgeqp3()

subroutine zgeqp3 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) jpvt,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer info )

ZGEQP3

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

Purpose:
!>
!> ZGEQP3 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO=0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK. 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 DOUBLE PRECISION array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit.
!>          < 0: if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
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 zgeqp3.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 DOUBLE PRECISION RWORK( * )
170 COMPLEX*16 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 xerbla, zgeqrf, zlaqp2, zlaqps, zswap, zunmqr
186* ..
187* .. External Functions ..
188 INTEGER ILAENV
189 DOUBLE PRECISION DZNRM2
190 EXTERNAL ilaenv, dznrm2
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, 'ZGEQRF', ' ', m, n, -1, -1 )
218 lwkopt = ( n + 1 )*nb
219 END IF
220 work( 1 ) = dcmplx( 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( 'ZGEQP3', -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 zswap( 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 ZGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
262 CALL zgeqrf( m, na, a, lda, tau, work, lwork, info )
263 iws = max( iws, int( work( 1 ) ) )
264 IF( na.LT.n ) THEN
265*CC CALL ZUNM2R( 'Left', 'Conjugate Transpose', M, N-NA,
266*CC $ NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK,
267*CC $ INFO )
268 CALL zunmqr( '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, 'ZGEQRF', ' ', 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, 'ZGEQRF', ' ', 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, 'ZGEQRF', ' ', 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 ) = dznrm2( 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 zlaqps( 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 zlaqp2( 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 ) = dcmplx( lwkopt )
365 RETURN
366*
367* End of ZGEQP3
368*
zlaqp2
subroutine zlaqp2(m, n, offset, a, lda, jpvt, tau, vn1, vn2, work)
ZLAQP2 computes a QR factorization with column pivoting of the matrix block.
Definition zlaqp2.f:149
zlaqps
subroutine zlaqps(m, n, offset, nb, kb, a, lda, jpvt, tau, vn1, vn2, auxv, f, ldf)
ZLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BL...
Definition zlaqps.f:177
zunmqr
subroutine zunmqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMQR
Definition zunmqr.f:167
zgeqrf
subroutine zgeqrf(m, n, a, lda, tau, work, lwork, info)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
Definition zgeqrf.f:151

◆ zgeqpf()

subroutine zgeqpf ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) jpvt,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZGEQPF

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine ZGEQP3.
!>
!> ZGEQPF 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
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 zgeqpf.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 DOUBLE PRECISION RWORK( * )
159 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
160* ..
161*
162* =====================================================================
163*
164* .. Parameters ..
165 DOUBLE PRECISION ZERO, ONE
166 parameter( zero = 0.0d+0, one = 1.0d+0 )
167* ..
168* .. Local Scalars ..
169 INTEGER I, ITEMP, J, MA, MN, PVT
170 DOUBLE PRECISION TEMP, TEMP2, TOL3Z
171 COMPLEX*16 AII
172* ..
173* .. External Subroutines ..
174 EXTERNAL xerbla, zgeqr2, zlarf, zlarfg, zswap, zunm2r
175* ..
176* .. Intrinsic Functions ..
177 INTRINSIC abs, dcmplx, dconjg, max, min, sqrt
178* ..
179* .. External Functions ..
180 INTEGER IDAMAX
181 DOUBLE PRECISION DLAMCH, DZNRM2
182 EXTERNAL idamax, dlamch, dznrm2
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( 'ZGEQPF', -info )
198 RETURN
199 END IF
200*
201 mn = min( m, n )
202 tol3z = sqrt(dlamch('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 zswap( 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 zgeqr2( m, ma, a, lda, tau, work, info )
228 IF( ma.LT.n ) THEN
229 CALL zunm2r( '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 ) = dznrm2( 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 ) + idamax( n-i+1, rwork( i ), 1 )
251*
252 IF( pvt.NE.i ) THEN
253 CALL zswap( 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 zlarfg( 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 ) = dcmplx( one )
274 CALL zlarf( 'Left', m-i+1, n-i, a( i, i ), 1,
275 $ dconjg( 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 ) = dznrm2( 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 ZGEQPF
309*
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71
zgeqr2
subroutine zgeqr2(m, n, a, lda, tau, work, info)
ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition zgeqr2.f:130
zunm2r
subroutine zunm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...
Definition zunm2r.f:159

◆ zgeqr2()

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

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

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

Purpose:
!>
!> ZGEQR2 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 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 zgeqr2.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*16 A( LDA, * ), TAU( * ), WORK( * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 COMPLEX*16 ONE
146 parameter( one = ( 1.0d+0, 0.0d+0 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER I, K
150 COMPLEX*16 ALPHA
151* ..
152* .. External Subroutines ..
153 EXTERNAL xerbla, zlarf, zlarfg
154* ..
155* .. Intrinsic Functions ..
156 INTRINSIC dconjg, 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( 'ZGEQR2', -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 zlarfg( 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 zlarf( 'Left', m-i+1, n-i, a( i, i ), 1,
190 $ dconjg( 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 ZGEQR2
197*

◆ zgeqr2p()

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

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

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

Purpose:
!>
!> ZGEQR2P 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 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 zgeqr2p.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*16 A( LDA, * ), TAU( * ), WORK( * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 COMPLEX*16 ONE
150 parameter( one = ( 1.0d+0, 0.0d+0 ) )
151* ..
152* .. Local Scalars ..
153 INTEGER I, K
154 COMPLEX*16 ALPHA
155* ..
156* .. External Subroutines ..
157 EXTERNAL xerbla, zlarf, zlarfgp
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC dconjg, 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( 'ZGEQR2P', -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 zlarfgp( 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 zlarf( 'Left', m-i+1, n-i, a( i, i ), 1,
194 $ dconjg( 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 ZGEQR2P
201*
zlarfgp
subroutine zlarfgp(n, alpha, x, incx, tau)
ZLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.
Definition zlarfgp.f:104

◆ zgeqrf()

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

ZGEQRF

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

Purpose:
!>
!> ZGEQRF 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          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 zgeqrf.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*16 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 xerbla, zgeqr2, zlarfb, zlarft
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, 'ZGEQRF', ' ', 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( 'ZGEQRF', -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, 'ZGEQRF', ' ', 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, 'ZGEQRF', ' ', 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 zgeqr2( 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 zlarft( '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 zlarfb( '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 zgeqr2( 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 ZGEQRF
281*

◆ zgeqrfp()

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

ZGEQRFP

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

Purpose:
!>
!> ZGEQR2P 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  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 zgeqrfp.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*16 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 xerbla, zgeqr2p, zlarfb, zlarft
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, 'ZGEQRF', ' ', 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( 'ZGEQRFP', -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, 'ZGEQRF', ' ', 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, 'ZGEQRF', ' ', 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 zgeqr2p( 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 zlarft( '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 zlarfb( '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 zgeqr2p( 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 ZGEQRFP
279*
zgeqr2p
subroutine zgeqr2p(m, n, a, lda, tau, work, info)
ZGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elem...
Definition zgeqr2p.f:134

◆ zgeqrt()

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

ZGEQRT

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

Purpose:
!>
!> ZGEQRT 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*16 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*16 array, dimension (LDT,MIN(M,N))
!>          The upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.  See below
!>          for further details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB.
!>
[out]WORK
!>          WORK is COMPLEX*16 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 zgeqrt.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*16 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 zgeqrt2, zgeqrt3, zlarfb, 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( 'ZGEQRT', -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 zgeqrt3( m-i+1, ib, a(i,i), lda, t(1,i), ldt, iinfo )
199 ELSE
200 CALL zgeqrt2( 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 zlarfb( '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 ZGEQRT
214*
zgeqrt3
recursive subroutine zgeqrt3(m, n, a, lda, t, ldt, info)
ZGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact...
Definition zgeqrt3.f:132
zgeqrt2
subroutine zgeqrt2(m, n, a, lda, t, ldt, info)
ZGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY represen...
Definition zgeqrt2.f:127

◆ zgeqrt2()

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

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

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

Purpose:
!>
!> ZGEQRT2 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*16 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*16 array, dimension (LDT,N)
!>          The N-by-N upper triangular factor of the block reflector.
!>          The elements on and above the diagonal contain the block
!>          reflector T; the elements below the diagonal are not used.
!>          See below for further details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The matrix V stores the elementary reflectors H(i) in the i-th 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 zgeqrt2.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*16 A( LDA, * ), T( LDT, * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 COMPLEX*16 ONE, ZERO
143 parameter( one = (1.0d+00,0.0d+00), zero = (0.0d+00,0.0d+00) )
144* ..
145* .. Local Scalars ..
146 INTEGER I, K
147 COMPLEX*16 AII, ALPHA
148* ..
149* .. External Subroutines ..
150 EXTERNAL zlarfg, zgemv, zgerc, ztrmv, 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( 'ZGEQRT2', -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 zlarfg( 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 zgemv( '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 zgerc( 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 zgemv( '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 ztrmv( '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 ZGEQRT2
223*
ztrmv
subroutine ztrmv(uplo, trans, diag, n, a, lda, x, incx)
ZTRMV
Definition ztrmv.f:147
zgemv
subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
ZGEMV
Definition zgemv.f:158
zgerc
subroutine zgerc(m, n, alpha, x, incx, y, incy, a, lda)
ZGERC
Definition zgerc.f:130

◆ zgeqrt3()

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

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

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

Purpose:
!>
!> ZGEQRT3 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*16 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*16 array, dimension (LDT,N)
!>          The N-by-N upper triangular factor of the block reflector.
!>          The elements on and above the diagonal contain the block
!>          reflector T; the elements below the diagonal are not used.
!>          See below for further details.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The matrix V stores the elementary reflectors H(i) in the i-th 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 zgeqrt3.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*16 A( LDA, * ), T( LDT, * )
142* ..
143*
144* =====================================================================
145*
146* .. Parameters ..
147 COMPLEX*16 ONE
148 parameter( one = (1.0d+00,0.0d+00) )
149* ..
150* .. Local Scalars ..
151 INTEGER I, I1, J, J1, N1, N2, IINFO
152* ..
153* .. External Subroutines ..
154 EXTERNAL zlarfg, ztrmm, zgemm, 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( 'ZGEQRT3', -info )
170 RETURN
171 END IF
172*
173 IF( n.EQ.1 ) THEN
174*
175* Compute Householder transform when N=1
176*
177 CALL zlarfg( 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 zgeqrt3( 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 ztrmm( 'L', 'L', 'C', 'U', n1, n2, one,
200 & a, lda, t( 1, j1 ), ldt )
201*
202 CALL zgemm( 'C', 'N', n1, n2, m-n1, one, a( j1, 1 ), lda,
203 & a( j1, j1 ), lda, one, t( 1, j1 ), ldt)
204*
205 CALL ztrmm( 'L', 'U', 'C', 'N', n1, n2, one,
206 & t, ldt, t( 1, j1 ), ldt )
207*
208 CALL zgemm( 'N', 'N', m-n1, n2, n1, -one, a( j1, 1 ), lda,
209 & t( 1, j1 ), ldt, one, a( j1, j1 ), lda )
210*
211 CALL ztrmm( '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 zgeqrt3( 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 ztrmm( 'R', 'L', 'N', 'U', n1, n2, one,
234 & a( j1, j1 ), lda, t( 1, j1 ), ldt )
235*
236 CALL zgemm( 'C', 'N', n1, n2, m-n, one, a( i1, 1 ), lda,
237 & a( i1, j1 ), lda, one, t( 1, j1 ), ldt )
238*
239 CALL ztrmm( 'L', 'U', 'N', 'N', n1, n2, -one, t, ldt,
240 & t( 1, j1 ), ldt )
241*
242 CALL ztrmm( '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 ZGEQRT3
253*

◆ zgerfs()

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

ZGERFS

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

Purpose:
!>
!> ZGERFS 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*16 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*16 array, dimension (LDAF,N)
!>          The factors L and U from the factorization A = P*L*U
!>          as computed by ZGETRF.
!>
[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 ZGETRF; for 1<=i<=N, row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[in]B
!>          B is COMPLEX*16 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*16 array, dimension (LDX,NRHS)
!>          On entry, the solution matrix X, as computed by ZGETRS.
!>          On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bound for each solution vector
!>          X(j) (the j-th column of the solution matrix X).
!>          If XTRUE is the true solution corresponding to X(j), FERR(j)
!>          is an estimated upper bound for the magnitude of the largest
!>          element in (X(j) - XTRUE) divided by the magnitude of the
!>          largest element in X(j).  The estimate is as reliable as
!>          the estimate for RCOND, and is almost always a slight
!>          overestimate of the true error.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector X(j) (i.e., the smallest relative change in
!>          any element of A or B that makes X(j) an exact solution).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
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 zgerfs.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 DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
198 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
199 $ WORK( * ), X( LDX, * )
200* ..
201*
202* =====================================================================
203*
204* .. Parameters ..
205 INTEGER ITMAX
206 parameter( itmax = 5 )
207 DOUBLE PRECISION ZERO
208 parameter( zero = 0.0d+0 )
209 COMPLEX*16 ONE
210 parameter( one = ( 1.0d+0, 0.0d+0 ) )
211 DOUBLE PRECISION TWO
212 parameter( two = 2.0d+0 )
213 DOUBLE PRECISION THREE
214 parameter( three = 3.0d+0 )
215* ..
216* .. Local Scalars ..
217 LOGICAL NOTRAN
218 CHARACTER TRANSN, TRANST
219 INTEGER COUNT, I, J, K, KASE, NZ
220 DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
221 COMPLEX*16 ZDUM
222* ..
223* .. Local Arrays ..
224 INTEGER ISAVE( 3 )
225* ..
226* .. External Functions ..
227 LOGICAL LSAME
228 DOUBLE PRECISION DLAMCH
229 EXTERNAL lsame, dlamch
230* ..
231* .. External Subroutines ..
232 EXTERNAL xerbla, zaxpy, zcopy, zgemv, zgetrs, zlacn2
233* ..
234* .. Intrinsic Functions ..
235 INTRINSIC abs, dble, dimag, max
236* ..
237* .. Statement Functions ..
238 DOUBLE PRECISION CABS1
239* ..
240* .. Statement Function definitions ..
241 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( 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( 'ZGERFS', -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 = dlamch( 'Epsilon' )
292 safmin = dlamch( '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 zcopy( n, b( 1, j ), 1, work, 1 )
310 CALL zgemv( 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 zgetrs( trans, n, 1, af, ldaf, ipiv, work, n, info )
367 CALL zaxpy( 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 ZLACN2 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 zlacn2( 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 zgetrs( 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 zgetrs( 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 ZGERFS
444*
zgetrs
subroutine zgetrs(trans, n, nrhs, a, lda, ipiv, b, ldb, info)
ZGETRS
Definition zgetrs.f:121
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81

◆ zgerfsx()

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

ZGERFSX

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

Purpose:
!>
!>    ZGERFSX 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*16 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*16 array, dimension (LDAF,N)
!>     The factors L and U from the factorization A = P*L*U
!>     as computed by ZGETRF.
!>
[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 ZGETRF; for 1<=i<=N, row i of the
!>     matrix was interchanged with row IPIV(i).
!>
[in]R
!>          R is DOUBLE PRECISION array, dimension (N)
!>     The row scale factors for A.  If EQUED = 'R' or 'B', A is
!>     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
!>     is not accessed.
!>     If R is accessed, each element of R should be a power of the radix
!>     to ensure a reliable solution and error estimates. Scaling by
!>     powers of the radix does not cause rounding errors unless the
!>     result underflows or overflows. Rounding errors during scaling
!>     lead to refining with a matrix that is not equivalent to the
!>     input matrix, producing error estimates that may not be
!>     reliable.
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension (N)
!>     The column scale factors for A.  If EQUED = 'C' or 'B', A is
!>     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
!>     is not accessed.
!>     If C is accessed, each element of C should be a power of the radix
!>     to ensure a reliable solution and error estimates. Scaling by
!>     powers of the radix does not cause rounding errors unless the
!>     result underflows or overflows. Rounding errors during scaling
!>     lead to refining with a matrix that is not equivalent to the
!>     input matrix, producing error estimates that may not be
!>     reliable.
!>
[in]B
!>          B is COMPLEX*16 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*16 array, dimension (LDX,NRHS)
!>     On entry, the solution matrix X, as computed by ZGETRS.
!>     On exit, the improved solution matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>     The leading dimension of the array X.  LDX >= max(1,N).
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>     Reciprocal scaled condition number.  This is an estimate of the
!>     reciprocal Skeel condition number of the matrix A after
!>     equilibration (if done).  If this is less than the machine
!>     precision (in particular, if it is zero), the matrix is singular
!>     to working precision.  Note that the error may still be small even
!>     if this number is very small and the matrix appears ill-
!>     conditioned.
!>
[out]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>     Componentwise relative backward error.  This is the
!>     componentwise relative backward error of each solution vector X(j)
!>     (i.e., the smallest relative change in any element of A or B that
!>     makes X(j) an exact solution).
!>
[in]N_ERR_BNDS
!>          N_ERR_BNDS is INTEGER
!>     Number of error bounds to return for each right hand side
!>     and each type (normwise or componentwise).  See ERR_BNDS_NORM and
!>     ERR_BNDS_COMP below.
!>
[out]ERR_BNDS_NORM
!>          ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     normwise relative error, which is defined as follows:
!>
!>     Normwise relative error in the ith solution vector:
!>             max_j (abs(XTRUE(j,i) - X(j,i)))
!>            ------------------------------
!>                  max_j abs(X(j,i))
!>
!>     The array is indexed by the type of error information as described
!>     below. There currently are up to three pieces of information
!>     returned.
!>
!>     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_NORM(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * dlamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * dlamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated normwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * dlamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*A, where S scales each row by a power of the
!>              radix so all absolute row sums of Z are approximately 1.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[out]ERR_BNDS_COMP
!>          ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
!>     For each right-hand side, this array contains information about
!>     various error bounds and condition numbers corresponding to the
!>     componentwise relative error, which is defined as follows:
!>
!>     Componentwise relative error in the ith solution vector:
!>                    abs(XTRUE(j,i) - X(j,i))
!>             max_j ----------------------
!>                         abs(X(j,i))
!>
!>     The array is indexed by the right-hand side i (on which the
!>     componentwise relative error depends), and the type of error
!>     information as described below. There currently are up to three
!>     pieces of information returned for each right-hand side. If
!>     componentwise accuracy is not requested (PARAMS(3) = 0.0), then
!>     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS < 3, then at most
!>     the first (:,N_ERR_BNDS) entries are returned.
!>
!>     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
!>     right-hand side.
!>
!>     The second index in ERR_BNDS_COMP(:,err) contains the following
!>     three fields:
!>     err = 1  boolean. Trust the answer if the
!>              reciprocal condition number is less than the threshold
!>              sqrt(n) * dlamch('Epsilon').
!>
!>     err = 2  error bound: The estimated forward error,
!>              almost certainly within a factor of 10 of the true error
!>              so long as the next entry is greater than the threshold
!>              sqrt(n) * dlamch('Epsilon'). This error bound should only
!>              be trusted if the previous boolean is true.
!>
!>     err = 3  Reciprocal condition number: Estimated componentwise
!>              reciprocal condition number.  Compared with the threshold
!>              sqrt(n) * dlamch('Epsilon') to determine if the error
!>              estimate is . These reciprocal condition
!>              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
!>              appropriately scaled matrix Z.
!>              Let Z = S*(A*diag(x)), where x is the solution for the
!>              current right-hand side and S scales each row of
!>              A*diag(x) by a power of the radix so all absolute row
!>              sums of Z are approximately 1.
!>
!>     See Lapack Working Note 165 for further details and extra
!>     cautions.
!>
[in]NPARAMS
!>          NPARAMS is INTEGER
!>     Specifies the number of parameters set in PARAMS.  If <= 0, the
!>     PARAMS array is never referenced and default values are used.
!>
[in,out]PARAMS
!>          PARAMS is DOUBLE PRECISION array, dimension NPARAMS
!>     Specifies algorithm parameters.  If an entry is < 0.0, then
!>     that entry will be filled with default value used for that
!>     parameter.  Only positions up to NPARAMS are accessed; defaults
!>     are used for higher-numbered parameters.
!>
!>       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
!>            refinement or not.
!>         Default: 1.0D+0
!>            = 0.0:  No refinement is performed, and no error bounds are
!>                    computed.
!>            = 1.0:  Use the double-precision refinement algorithm,
!>                    possibly with doubled-single computations if the
!>                    compilation environment does not support DOUBLE
!>                    PRECISION.
!>              (other values are reserved for future use)
!>
!>       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
!>            computations allowed for refinement.
!>         Default: 10
!>         Aggressive: Set to 100 to permit convergence using approximate
!>                     factorizations or factorizations other than LU. If
!>                     the factorization uses a technique other than
!>                     Gaussian elimination, the guarantees in
!>                     err_bnds_norm and err_bnds_comp may no longer be
!>                     trustworthy.
!>
!>       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
!>            will attempt to find a solution with small componentwise
!>            relative error in the double-precision algorithm.  Positive
!>            is true, 0.0 is false.
!>         Default: 1.0 (attempt componentwise convergence)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION 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 zgerfsx.f.

414*
415* -- LAPACK computational routine --
416* -- LAPACK is a software package provided by Univ. of Tennessee, --
417* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
418*
419* .. Scalar Arguments ..
420 CHARACTER TRANS, EQUED
421 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
422 $ N_ERR_BNDS
423 DOUBLE PRECISION RCOND
424* ..
425* .. Array Arguments ..
426 INTEGER IPIV( * )
427 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
428 $ X( LDX , * ), WORK( * )
429 DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ),
430 $ ERR_BNDS_NORM( NRHS, * ),
431 $ ERR_BNDS_COMP( NRHS, * ), RWORK( * )
432* ..
433*
434* ==================================================================
435*
436* .. Parameters ..
437 DOUBLE PRECISION ZERO, ONE
438 parameter( zero = 0.0d+0, one = 1.0d+0 )
439 DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
440 DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
441 DOUBLE PRECISION DZTHRESH_DEFAULT
442 parameter( itref_default = 1.0d+0 )
443 parameter( ithresh_default = 10.0d+0 )
444 parameter( componentwise_default = 1.0d+0 )
445 parameter( rthresh_default = 0.5d+0 )
446 parameter( dzthresh_default = 0.25d+0 )
447 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
448 $ LA_LINRX_CWISE_I
449 parameter( la_linrx_itref_i = 1,
450 $ la_linrx_ithresh_i = 2 )
451 parameter( la_linrx_cwise_i = 3 )
452 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
453 $ LA_LINRX_RCOND_I
454 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
455 parameter( la_linrx_rcond_i = 3 )
456* ..
457* .. Local Scalars ..
458 CHARACTER(1) NORM
459 LOGICAL ROWEQU, COLEQU, NOTRAN
460 INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE
461 INTEGER N_NORMS
462 DOUBLE PRECISION ANORM, RCOND_TMP
463 DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
464 LOGICAL IGNORE_CWISE
465 INTEGER ITHRESH
466 DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH
467* ..
468* .. External Subroutines ..
469 EXTERNAL xerbla, zgecon, zla_gerfsx_extended
470* ..
471* .. Intrinsic Functions ..
472 INTRINSIC max, sqrt, transfer
473* ..
474* .. External Functions ..
475 EXTERNAL lsame, ilatrans, ilaprec
476 EXTERNAL dlamch, zlange, zla_gercond_x, zla_gercond_c
477 DOUBLE PRECISION DLAMCH, ZLANGE, ZLA_GERCOND_X, ZLA_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.0d+0 ) THEN
490 params( la_linrx_itref_i ) = itref_default
491 ELSE
492 ref_type = params( la_linrx_itref_i )
493 END IF
494 END IF
495*
496* Set default parameters.
497*
498 illrcond_thresh = dble( n ) * dlamch( 'Epsilon' )
499 ithresh = int( ithresh_default )
500 rthresh = rthresh_default
501 unstable_thresh = dzthresh_default
502 ignore_cwise = componentwise_default .EQ. 0.0d+0
503*
504 IF ( nparams.GE.la_linrx_ithresh_i ) THEN
505 IF ( params( la_linrx_ithresh_i ).LT.0.0d+0 ) THEN
506 params(la_linrx_ithresh_i) = ithresh
507 ELSE
508 ithresh = int( params( la_linrx_ithresh_i ) )
509 END IF
510 END IF
511 IF ( nparams.GE.la_linrx_cwise_i ) THEN
512 IF ( params( la_linrx_cwise_i ).LT.0.0d+0 ) THEN
513 IF ( ignore_cwise ) THEN
514 params( la_linrx_cwise_i ) = 0.0d+0
515 ELSE
516 params( la_linrx_cwise_i ) = 1.0d+0
517 END IF
518 ELSE
519 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+0
520 END IF
521 END IF
522 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 ) THEN
523 n_norms = 0
524 ELSE IF ( ignore_cwise ) THEN
525 n_norms = 1
526 ELSE
527 n_norms = 2
528 END IF
529*
530 notran = lsame( trans, 'N' )
531 rowequ = lsame( equed, 'R' ) .OR. lsame( equed, 'B' )
532 colequ = lsame( equed, 'C' ) .OR. lsame( equed, 'B' )
533*
534* Test input parameters.
535*
536 IF( trans_type.EQ.-1 ) THEN
537 info = -1
538 ELSE IF( .NOT.rowequ .AND. .NOT.colequ .AND.
539 $ .NOT.lsame( equed, 'N' ) ) THEN
540 info = -2
541 ELSE IF( n.LT.0 ) THEN
542 info = -3
543 ELSE IF( nrhs.LT.0 ) THEN
544 info = -4
545 ELSE IF( lda.LT.max( 1, n ) ) THEN
546 info = -6
547 ELSE IF( ldaf.LT.max( 1, n ) ) THEN
548 info = -8
549 ELSE IF( ldb.LT.max( 1, n ) ) THEN
550 info = -13
551 ELSE IF( ldx.LT.max( 1, n ) ) THEN
552 info = -15
553 END IF
554 IF( info.NE.0 ) THEN
555 CALL xerbla( 'ZGERFSX', -info )
556 RETURN
557 END IF
558*
559* Quick return if possible.
560*
561 IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
562 rcond = 1.0d+0
563 DO j = 1, nrhs
564 berr( j ) = 0.0d+0
565 IF ( n_err_bnds .GE. 1 ) THEN
566 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
567 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
568 END IF
569 IF ( n_err_bnds .GE. 2 ) THEN
570 err_bnds_norm( j, la_linrx_err_i ) = 0.0d+0
571 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
572 END IF
573 IF ( n_err_bnds .GE. 3 ) THEN
574 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0d+0
575 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
576 END IF
577 END DO
578 RETURN
579 END IF
580*
581* Default to failure.
582*
583 rcond = 0.0d+0
584 DO j = 1, nrhs
585 berr( j ) = 1.0d+0
586 IF ( n_err_bnds .GE. 1 ) THEN
587 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
588 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
589 END IF
590 IF ( n_err_bnds .GE. 2 ) THEN
591 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
592 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
593 END IF
594 IF ( n_err_bnds .GE. 3 ) THEN
595 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
596 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
597 END IF
598 END DO
599*
600* Compute the norm of A and the reciprocal of the condition
601* number of A.
602*
603 IF( notran ) THEN
604 norm = 'I'
605 ELSE
606 norm = '1'
607 END IF
608 anorm = zlange( norm, n, n, a, lda, rwork )
609 CALL zgecon( 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( 'E' )
616
617 IF ( notran ) THEN
618 CALL zla_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 zla_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.0d+0, sqrt( dble( n ) ) ) * dlamch( '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 = zla_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 = zla_gercond_c( trans, n, a, lda, af, ldaf, ipiv,
646 $ r, .true., info, work, rwork )
647 ELSE
648 rcond_tmp = zla_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.0d+0 )
657 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0d+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.0d+0
663 err_bnds_norm( j, la_linrx_trust_i ) = 0.0d+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.0d+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( dlamch( 'Epsilon' ) )
690 DO j = 1, nrhs
691 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
692 $ THEN
693 rcond_tmp = zla_gercond_x( trans, n, a, lda, af, ldaf,
694 $ ipiv, x(1,j), info, work, rwork )
695 ELSE
696 rcond_tmp = 0.0d+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.0d+0 )
703 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0d+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.0d+0
709 err_bnds_comp( j, la_linrx_trust_i ) = 0.0d+0
710 IF ( params( la_linrx_cwise_i ) .EQ. 1.0d+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.0d+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 ZGERFSX
730*
ilaprec
integer function ilaprec(prec)
ILAPREC
Definition ilaprec.f:58
ilatrans
integer function ilatrans(trans)
ILATRANS
Definition ilatrans.f:58
zlange
double precision function zlange(norm, m, n, a, lda, work)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlange.f:115
zla_gerfsx_extended
subroutine zla_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)
ZLA_GERFSX_EXTENDED
Definition zla_gerfsx_extended.f:396
zla_gercond_c
double precision function zla_gercond_c(trans, n, a, lda, af, ldaf, ipiv, c, capply, info, work, rwork)
ZLA_GERCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for general matrices.
Definition zla_gercond_c.f:143
zla_gercond_x
double precision function zla_gercond_x(trans, n, a, lda, af, ldaf, ipiv, x, info, work, rwork)
ZLA_GERCOND_X computes the infinity norm condition number of op(A)*diag(x) for general matrices.
Definition zla_gercond_x.f:136
zgecon
subroutine zgecon(norm, n, a, lda, anorm, rcond, work, rwork, info)
ZGECON
Definition zgecon.f:124

◆ zgerq2()

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

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

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

Purpose:
!>
!> ZGERQ2 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 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 zgerq2.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*16 A( LDA, * ), TAU( * ), WORK( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 COMPLEX*16 ONE
139 parameter( one = ( 1.0d+0, 0.0d+0 ) )
140* ..
141* .. Local Scalars ..
142 INTEGER I, K
143 COMPLEX*16 ALPHA
144* ..
145* .. External Subroutines ..
146 EXTERNAL xerbla, zlacgv, zlarf, zlarfg
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( 'ZGERQ2', -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 zlacgv( n-k+i, a( m-k+i, 1 ), lda )
176 alpha = a( m-k+i, n-k+i )
177 CALL zlarfg( n-k+i, alpha, a( m-k+i, 1 ), lda, tau( i ) )
178*
179* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
180*
181 a( m-k+i, n-k+i ) = one
182 CALL zlarf( 'Right', m-k+i-1, n-k+i, a( m-k+i, 1 ), lda,
183 $ tau( i ), a, lda, work )
184 a( m-k+i, n-k+i ) = alpha
185 CALL zlacgv( n-k+i-1, a( m-k+i, 1 ), lda )
186 10 CONTINUE
187 RETURN
188*
189* End of ZGERQ2
190*

◆ zgerqf()

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

ZGERQF

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

Purpose:
!>
!> ZGERQF 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          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 zgerqf.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*16 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 xerbla, zgerq2, zlarfb, zlarft
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, 'ZGERQF', ' ', 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( 'ZGERQF', -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, 'ZGERQF', ' ', 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, 'ZGERQF', ' ', 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 zgerq2( 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 zlarft( '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 zlarfb( '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 zgerq2( mu, nu, a, lda, tau, work, iinfo )
280*
281 work( 1 ) = iws
282 RETURN
283*
284* End of ZGERQF
285*
zgerq2
subroutine zgerq2(m, n, a, lda, tau, work, info)
ZGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition zgerq2.f:123

◆ zgesvj()

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

ZGESVJ

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

Purpose:
!>
!> ZGESVJ 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=DLAMCH('E').
!>          = 'C': Analogous to JOBU='U', except that user can control the
!>                 level of numerical orthogonality of the computed left
!>                 singular vectors. TOL can be set to TOL = CTOL*EPS, where
!>                 CTOL is given on input in the array WORK.
!>                 No CTOL smaller than ONE is allowed. CTOL greater
!>                 than 1 / EPS is meaningless. The option 'C'
!>                 can be used if M*EPS is satisfactory orthogonality
!>                 of the computed left singular vectors, so CTOL=M could
!>                 save few sweeps of Jacobi rotations.
!>                 See the descriptions of A and WORK(1).
!>          = 'N': The matrix U is not computed. However, see the
!>                 description of A.
!>
[in]JOBV
!>          JOBV is CHARACTER*1
!>          Specifies whether to compute the right singular vectors, that
!>          is, the matrix V:
!>          = 'V' 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/DLAMCH('E') > M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the input matrix A.
!>          M >= N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit,
!>          If JOBU = 'U' .OR. JOBU = 'C':
!>                 If INFO = 0 :
!>                 RANKA orthonormal columns of U are returned in the
!>                 leading RANKA columns of the array A. Here RANKA <= N
!>                 is the number of computed singular values of A that are
!>                 above the underflow threshold DLAMCH('S'). The singular
!>                 vectors corresponding to underflowed or zero singular
!>                 values are not computed. The value of RANKA is returned
!>                 in the array 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 ZGESVJ 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 ZGESVJ did not converge in the given number
!>                 of iterations (sweeps).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]SVA
!>          SVA is DOUBLE PRECISION array, dimension (N)
!>          On exit,
!>          If INFO = 0 :
!>          depending on the value SCALE = 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 ZGESVJ 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 ZGESVJ
!>          is applied to the first MV rows of V. See the description of JOBV.
!>
[in,out]V
!>          V is COMPLEX*16 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*16 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 DOUBLE PRECISION 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=DLAMCH('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 ZGESVJ 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:  ZGESVJ 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 zgesvj.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*16 A( LDA, * ), V( LDV, * ), CWORK( LWORK )
363 DOUBLE PRECISION RWORK( LRWORK ), SVA( N )
364* ..
365*
366* =====================================================================
367*
368* .. Local Parameters ..
369 DOUBLE PRECISION ZERO, HALF, ONE
370 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0)
371 COMPLEX*16 CZERO, CONE
372 parameter( czero = (0.0d0, 0.0d0), cone = (1.0d0, 0.0d0) )
373 INTEGER NSWEEP
374 parameter( nsweep = 30 )
375* ..
376* .. Local Scalars ..
377 COMPLEX*16 AAPQ, OMPQ
378 DOUBLE PRECISION 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, dble, sign, sqrt
391* ..
392* .. External Functions ..
393* ..
394* from BLAS
395 DOUBLE PRECISION DZNRM2
396 COMPLEX*16 ZDOTC
397 EXTERNAL zdotc, dznrm2
398 INTEGER IDAMAX
399 EXTERNAL idamax
400* from LAPACK
401 DOUBLE PRECISION DLAMCH
402 EXTERNAL dlamch
403 LOGICAL LSAME
404 EXTERNAL lsame
405* ..
406* .. External Subroutines ..
407* ..
408* from BLAS
409 EXTERNAL zcopy, zrot, zdscal, zswap, zaxpy
410* from LAPACK
411 EXTERNAL dlascl, zlascl, zlaset, zlassq, xerbla
412 EXTERNAL zgsvj0, zgsvj1
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( 'ZGESVJ', -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( dble( m ) )
481 ELSE
482 ctol = dble( 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 = dlamch( 'Epsilon' )
489 rooteps = sqrt( epsln )
490 sfmin = dlamch( 'SafeMinimum' )
491 rootsfmin = sqrt( sfmin )
492 small = sfmin / epsln
493 big = dlamch( 'Overflow' )
494* BIG = ONE / SFMIN
495 rootbig = one / rootsfmin
496* LARGE = BIG / SQRT( DBLE( M*N ) )
497 bigtheta = one / rooteps
498*
499 tol = ctol*epsln
500 roottol = sqrt( tol )
501*
502 IF( dble( m )*epsln.GE.one ) THEN
503 info = -4
504 CALL xerbla( 'ZGESVJ', -info )
505 RETURN
506 END IF
507*
508* Initialize the right singular vector matrix.
509*
510 IF( rsvec ) THEN
511 mvl = n
512 CALL zlaset( '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( dble( m )*dble( 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 zlassq( m-p+1, a( p, p ), 1, aapp, aaqq )
537 IF( aapp.GT.big ) THEN
538 info = -6
539 CALL xerbla( 'ZGESVJ', -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 zlassq( p, a( 1, p ), 1, aapp, aaqq )
562 IF( aapp.GT.big ) THEN
563 info = -6
564 CALL xerbla( 'ZGESVJ', -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 zlassq( m, a( 1, p ), 1, aapp, aaqq )
587 IF( aapp.GT.big ) THEN
588 info = -6
589 CALL xerbla( 'ZGESVJ', -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 zlaset( '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 zlascl( '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 / dble( 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( dble(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( dble( 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 dlascl( '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 zlascl( 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 ZGESVJ is used as a computational routine in the preconditioned
703* Jacobi SVD algorithm ZGEJSV. 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 zgsvj0( 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 zgsvj0( 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 zgsvj1( 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 zgsvj0( 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 zgsvj0( 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 zgsvj1( 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 zgsvj0( 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 zgsvj0( 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 zgsvj1( 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 zgsvj0( 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 = idamax( n-p+1, sva( p ), 1 ) + p - 1
838 IF( p.NE.q ) THEN
839 CALL zswap( m, a( 1, p ), 1, a( 1, q ), 1 )
840 IF( rsvec )CALL zswap( 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 DZNRM2(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, DZNRM2 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 = DZNRM2( M, A(1,p), 1 )".
863*
864 IF( ( sva( p ).LT.rootbig ) .AND.
865 $ ( sva( p ).GT.rootsfmin ) ) THEN
866 sva( p ) = dznrm2( m, a( 1, p ), 1 )
867 ELSE
868 temp1 = zero
869 aapp = one
870 CALL zlassq( 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 = ( zdotc( m, a( 1, p ), 1,
893 $ a( 1, q ), 1 ) / aaqq ) / aapp
894 ELSE
895 CALL zcopy( m, a( 1, p ), 1,
896 $ cwork(n+1), 1 )
897 CALL zlascl( 'G', 0, 0, aapp, one,
898 $ m, 1, cwork(n+1), lda, ierr )
899 aapq = zdotc( 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 = ( zdotc( m, a( 1, p ), 1,
906 $ a( 1, q ), 1 ) / aapp ) / aaqq
907 ELSE
908 CALL zcopy( m, a( 1, q ), 1,
909 $ cwork(n+1), 1 )
910 CALL zlascl( 'G', 0, 0, aaqq,
911 $ one, m, 1,
912 $ cwork(n+1), lda, ierr )
913 aapq = zdotc( m, a(1, p ), 1,
914 $ cwork(n+1), 1 ) / aapp
915 END IF
916 END IF
917*
918
919* AAPQ = AAPQ * CONJG( CWORK(p) ) * CWORK(q)
920 aapq1 = -abs(aapq)
921 mxaapq = max( mxaapq, -aapq1 )
922*
923* TO rotate or NOT to rotate, THAT is the question ...
924*
925 IF( abs( aapq1 ).GT.tol ) THEN
926 ompq = aapq / abs(aapq)
927*
928* .. rotate
929*[RTD] ROTATED = ROTATED + ONE
930*
931 IF( ir1.EQ.0 ) THEN
932 notrot = 0
933 pskipped = 0
934 iswrot = iswrot + 1
935 END IF
936*
937 IF( rotok ) THEN
938*
939 aqoap = aaqq / aapp
940 apoaq = aapp / aaqq
941 theta = -half*abs( aqoap-apoaq )/aapq1
942*
943 IF( abs( theta ).GT.bigtheta ) THEN
944*
945 t = half / theta
946 cs = one
947
948 CALL zrot( m, a(1,p), 1, a(1,q), 1,
949 $ cs, conjg(ompq)*t )
950 IF ( rsvec ) THEN
951 CALL zrot( mvl, v(1,p), 1,
952 $ v(1,q), 1, cs, conjg(ompq)*t )
953 END IF
954
955 sva( q ) = aaqq*sqrt( max( zero,
956 $ one+t*apoaq*aapq1 ) )
957 aapp = aapp*sqrt( max( zero,
958 $ one-t*aqoap*aapq1 ) )
959 mxsinj = max( mxsinj, abs( t ) )
960*
961 ELSE
962*
963* .. choose correct signum for THETA and rotate
964*
965 thsign = -sign( one, aapq1 )
966 t = one / ( theta+thsign*
967 $ sqrt( one+theta*theta ) )
968 cs = sqrt( one / ( one+t*t ) )
969 sn = t*cs
970*
971 mxsinj = max( mxsinj, abs( sn ) )
972 sva( q ) = aaqq*sqrt( max( zero,
973 $ one+t*apoaq*aapq1 ) )
974 aapp = aapp*sqrt( max( zero,
975 $ one-t*aqoap*aapq1 ) )
976*
977 CALL zrot( m, a(1,p), 1, a(1,q), 1,
978 $ cs, conjg(ompq)*sn )
979 IF ( rsvec ) THEN
980 CALL zrot( mvl, v(1,p), 1,
981 $ v(1,q), 1, cs, conjg(ompq)*sn )
982 END IF
983 END IF
984 cwork(p) = -cwork(q) * ompq
985*
986 ELSE
987* .. have to use modified Gram-Schmidt like transformation
988 CALL zcopy( m, a( 1, p ), 1,
989 $ cwork(n+1), 1 )
990 CALL zlascl( 'G', 0, 0, aapp, one, m,
991 $ 1, cwork(n+1), lda,
992 $ ierr )
993 CALL zlascl( 'G', 0, 0, aaqq, one, m,
994 $ 1, a( 1, q ), lda, ierr )
995 CALL zaxpy( m, -aapq, cwork(n+1), 1,
996 $ a( 1, q ), 1 )
997 CALL zlascl( 'G', 0, 0, one, aaqq, m,
998 $ 1, a( 1, q ), lda, ierr )
999 sva( q ) = aaqq*sqrt( max( zero,
1000 $ one-aapq1*aapq1 ) )
1001 mxsinj = max( mxsinj, sfmin )
1002 END IF
1003* END IF ROTOK THEN ... ELSE
1004*
1005* In the case of cancellation in updating SVA(q), SVA(p)
1006* recompute SVA(q), SVA(p).
1007*
1008 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
1009 $ THEN
1010 IF( ( aaqq.LT.rootbig ) .AND.
1011 $ ( aaqq.GT.rootsfmin ) ) THEN
1012 sva( q ) = dznrm2( m, a( 1, q ), 1 )
1013 ELSE
1014 t = zero
1015 aaqq = one
1016 CALL zlassq( m, a( 1, q ), 1, t,
1017 $ aaqq )
1018 sva( q ) = t*sqrt( aaqq )
1019 END IF
1020 END IF
1021 IF( ( aapp / aapp0 ).LE.rooteps ) THEN
1022 IF( ( aapp.LT.rootbig ) .AND.
1023 $ ( aapp.GT.rootsfmin ) ) THEN
1024 aapp = dznrm2( m, a( 1, p ), 1 )
1025 ELSE
1026 t = zero
1027 aapp = one
1028 CALL zlassq( m, a( 1, p ), 1, t,
1029 $ aapp )
1030 aapp = t*sqrt( aapp )
1031 END IF
1032 sva( p ) = aapp
1033 END IF
1034*
1035 ELSE
1036* A(:,p) and A(:,q) already numerically orthogonal
1037 IF( ir1.EQ.0 )notrot = notrot + 1
1038*[RTD] SKIPPED = SKIPPED + 1
1039 pskipped = pskipped + 1
1040 END IF
1041 ELSE
1042* A(:,q) is zero column
1043 IF( ir1.EQ.0 )notrot = notrot + 1
1044 pskipped = pskipped + 1
1045 END IF
1046*
1047 IF( ( i.LE.swband ) .AND.
1048 $ ( pskipped.GT.rowskip ) ) THEN
1049 IF( ir1.EQ.0 )aapp = -aapp
1050 notrot = 0
1051 GO TO 2103
1052 END IF
1053*
1054 2002 CONTINUE
1055* END q-LOOP
1056*
1057 2103 CONTINUE
1058* bailed out of q-loop
1059*
1060 sva( p ) = aapp
1061*
1062 ELSE
1063 sva( p ) = aapp
1064 IF( ( ir1.EQ.0 ) .AND. ( aapp.EQ.zero ) )
1065 $ notrot = notrot + min( igl+kbl-1, n ) - p
1066 END IF
1067*
1068 2001 CONTINUE
1069* end of the p-loop
1070* end of doing the block ( ibr, ibr )
1071 1002 CONTINUE
1072* end of ir1-loop
1073*
1074* ... go to the off diagonal blocks
1075*
1076 igl = ( ibr-1 )*kbl + 1
1077*
1078 DO 2010 jbc = ibr + 1, nbl
1079*
1080 jgl = ( jbc-1 )*kbl + 1
1081*
1082* doing the block at ( ibr, jbc )
1083*
1084 ijblsk = 0
1085 DO 2100 p = igl, min( igl+kbl-1, n )
1086*
1087 aapp = sva( p )
1088 IF( aapp.GT.zero ) THEN
1089*
1090 pskipped = 0
1091*
1092 DO 2200 q = jgl, min( jgl+kbl-1, n )
1093*
1094 aaqq = sva( q )
1095 IF( aaqq.GT.zero ) THEN
1096 aapp0 = aapp
1097*
1098* .. M x 2 Jacobi SVD ..
1099*
1100* Safe Gram matrix computation
1101*
1102 IF( aaqq.GE.one ) THEN
1103 IF( aapp.GE.aaqq ) THEN
1104 rotok = ( small*aapp ).LE.aaqq
1105 ELSE
1106 rotok = ( small*aaqq ).LE.aapp
1107 END IF
1108 IF( aapp.LT.( big / aaqq ) ) THEN
1109 aapq = ( zdotc( m, a( 1, p ), 1,
1110 $ a( 1, q ), 1 ) / aaqq ) / aapp
1111 ELSE
1112 CALL zcopy( m, a( 1, p ), 1,
1113 $ cwork(n+1), 1 )
1114 CALL zlascl( 'G', 0, 0, aapp,
1115 $ one, m, 1,
1116 $ cwork(n+1), lda, ierr )
1117 aapq = zdotc( m, cwork(n+1), 1,
1118 $ a( 1, q ), 1 ) / aaqq
1119 END IF
1120 ELSE
1121 IF( aapp.GE.aaqq ) THEN
1122 rotok = aapp.LE.( aaqq / small )
1123 ELSE
1124 rotok = aaqq.LE.( aapp / small )
1125 END IF
1126 IF( aapp.GT.( small / aaqq ) ) THEN
1127 aapq = ( zdotc( m, a( 1, p ), 1,
1128 $ a( 1, q ), 1 ) / max(aaqq,aapp) )
1129 $ / min(aaqq,aapp)
1130 ELSE
1131 CALL zcopy( m, a( 1, q ), 1,
1132 $ cwork(n+1), 1 )
1133 CALL zlascl( 'G', 0, 0, aaqq,
1134 $ one, m, 1,
1135 $ cwork(n+1), lda, ierr )
1136 aapq = zdotc( m, a( 1, p ), 1,
1137 $ cwork(n+1), 1 ) / aapp
1138 END IF
1139 END IF
1140*
1141
1142* AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q)
1143 aapq1 = -abs(aapq)
1144 mxaapq = max( mxaapq, -aapq1 )
1145*
1146* TO rotate or NOT to rotate, THAT is the question ...
1147*
1148 IF( abs( aapq1 ).GT.tol ) THEN
1149 ompq = aapq / abs(aapq)
1150 notrot = 0
1151*[RTD] ROTATED = ROTATED + 1
1152 pskipped = 0
1153 iswrot = iswrot + 1
1154*
1155 IF( rotok ) THEN
1156*
1157 aqoap = aaqq / aapp
1158 apoaq = aapp / aaqq
1159 theta = -half*abs( aqoap-apoaq )/ aapq1
1160 IF( aaqq.GT.aapp0 )theta = -theta
1161*
1162 IF( abs( theta ).GT.bigtheta ) THEN
1163 t = half / theta
1164 cs = one
1165 CALL zrot( m, a(1,p), 1, a(1,q), 1,
1166 $ cs, conjg(ompq)*t )
1167 IF( rsvec ) THEN
1168 CALL zrot( mvl, v(1,p), 1,
1169 $ v(1,q), 1, cs, conjg(ompq)*t )
1170 END IF
1171 sva( q ) = aaqq*sqrt( max( zero,
1172 $ one+t*apoaq*aapq1 ) )
1173 aapp = aapp*sqrt( max( zero,
1174 $ one-t*aqoap*aapq1 ) )
1175 mxsinj = max( mxsinj, abs( t ) )
1176 ELSE
1177*
1178* .. choose correct signum for THETA and rotate
1179*
1180 thsign = -sign( one, aapq1 )
1181 IF( aaqq.GT.aapp0 )thsign = -thsign
1182 t = one / ( theta+thsign*
1183 $ sqrt( one+theta*theta ) )
1184 cs = sqrt( one / ( one+t*t ) )
1185 sn = t*cs
1186 mxsinj = max( mxsinj, abs( sn ) )
1187 sva( q ) = aaqq*sqrt( max( zero,
1188 $ one+t*apoaq*aapq1 ) )
1189 aapp = aapp*sqrt( max( zero,
1190 $ one-t*aqoap*aapq1 ) )
1191*
1192 CALL zrot( m, a(1,p), 1, a(1,q), 1,
1193 $ cs, conjg(ompq)*sn )
1194 IF( rsvec ) THEN
1195 CALL zrot( mvl, v(1,p), 1,
1196 $ v(1,q), 1, cs, conjg(ompq)*sn )
1197 END IF
1198 END IF
1199 cwork(p) = -cwork(q) * ompq
1200*
1201 ELSE
1202* .. have to use modified Gram-Schmidt like transformation
1203 IF( aapp.GT.aaqq ) THEN
1204 CALL zcopy( m, a( 1, p ), 1,
1205 $ cwork(n+1), 1 )
1206 CALL zlascl( 'G', 0, 0, aapp, one,
1207 $ m, 1, cwork(n+1),lda,
1208 $ ierr )
1209 CALL zlascl( 'G', 0, 0, aaqq, one,
1210 $ m, 1, a( 1, q ), lda,
1211 $ ierr )
1212 CALL zaxpy( m, -aapq, cwork(n+1),
1213 $ 1, a( 1, q ), 1 )
1214 CALL zlascl( 'G', 0, 0, one, aaqq,
1215 $ m, 1, a( 1, q ), lda,
1216 $ ierr )
1217 sva( q ) = aaqq*sqrt( max( zero,
1218 $ one-aapq1*aapq1 ) )
1219 mxsinj = max( mxsinj, sfmin )
1220 ELSE
1221 CALL zcopy( m, a( 1, q ), 1,
1222 $ cwork(n+1), 1 )
1223 CALL zlascl( 'G', 0, 0, aaqq, one,
1224 $ m, 1, cwork(n+1),lda,
1225 $ ierr )
1226 CALL zlascl( 'G', 0, 0, aapp, one,
1227 $ m, 1, a( 1, p ), lda,
1228 $ ierr )
1229 CALL zaxpy( m, -conjg(aapq),
1230 $ cwork(n+1), 1, a( 1, p ), 1 )
1231 CALL zlascl( 'G', 0, 0, one, aapp,
1232 $ m, 1, a( 1, p ), lda,
1233 $ ierr )
1234 sva( p ) = aapp*sqrt( max( zero,
1235 $ one-aapq1*aapq1 ) )
1236 mxsinj = max( mxsinj, sfmin )
1237 END IF
1238 END IF
1239* END IF ROTOK THEN ... ELSE
1240*
1241* In the case of cancellation in updating SVA(q), SVA(p)
1242* .. recompute SVA(q), SVA(p)
1243 IF( ( sva( q ) / aaqq )**2.LE.rooteps )
1244 $ THEN
1245 IF( ( aaqq.LT.rootbig ) .AND.
1246 $ ( aaqq.GT.rootsfmin ) ) THEN
1247 sva( q ) = dznrm2( m, a( 1, q ), 1)
1248 ELSE
1249 t = zero
1250 aaqq = one
1251 CALL zlassq( m, a( 1, q ), 1, t,
1252 $ aaqq )
1253 sva( q ) = t*sqrt( aaqq )
1254 END IF
1255 END IF
1256 IF( ( aapp / aapp0 )**2.LE.rooteps ) THEN
1257 IF( ( aapp.LT.rootbig ) .AND.
1258 $ ( aapp.GT.rootsfmin ) ) THEN
1259 aapp = dznrm2( m, a( 1, p ), 1 )
1260 ELSE
1261 t = zero
1262 aapp = one
1263 CALL zlassq( m, a( 1, p ), 1, t,
1264 $ aapp )
1265 aapp = t*sqrt( aapp )
1266 END IF
1267 sva( p ) = aapp
1268 END IF
1269* end of OK rotation
1270 ELSE
1271 notrot = notrot + 1
1272*[RTD] SKIPPED = SKIPPED + 1
1273 pskipped = pskipped + 1
1274 ijblsk = ijblsk + 1
1275 END IF
1276 ELSE
1277 notrot = notrot + 1
1278 pskipped = pskipped + 1
1279 ijblsk = ijblsk + 1
1280 END IF
1281*
1282 IF( ( i.LE.swband ) .AND. ( ijblsk.GE.blskip ) )
1283 $ THEN
1284 sva( p ) = aapp
1285 notrot = 0
1286 GO TO 2011
1287 END IF
1288 IF( ( i.LE.swband ) .AND.
1289 $ ( pskipped.GT.rowskip ) ) THEN
1290 aapp = -aapp
1291 notrot = 0
1292 GO TO 2203
1293 END IF
1294*
1295 2200 CONTINUE
1296* end of the q-loop
1297 2203 CONTINUE
1298*
1299 sva( p ) = aapp
1300*
1301 ELSE
1302*
1303 IF( aapp.EQ.zero )notrot = notrot +
1304 $ min( jgl+kbl-1, n ) - jgl + 1
1305 IF( aapp.LT.zero )notrot = 0
1306*
1307 END IF
1308*
1309 2100 CONTINUE
1310* end of the p-loop
1311 2010 CONTINUE
1312* end of the jbc-loop
1313 2011 CONTINUE
1314*2011 bailed out of the jbc-loop
1315 DO 2012 p = igl, min( igl+kbl-1, n )
1316 sva( p ) = abs( sva( p ) )
1317 2012 CONTINUE
1318***
1319 2000 CONTINUE
1320*2000 :: end of the ibr-loop
1321*
1322* .. update SVA(N)
1323 IF( ( sva( n ).LT.rootbig ) .AND. ( sva( n ).GT.rootsfmin ) )
1324 $ THEN
1325 sva( n ) = dznrm2( m, a( 1, n ), 1 )
1326 ELSE
1327 t = zero
1328 aapp = one
1329 CALL zlassq( m, a( 1, n ), 1, t, aapp )
1330 sva( n ) = t*sqrt( aapp )
1331 END IF
1332*
1333* Additional steering devices
1334*
1335 IF( ( i.LT.swband ) .AND. ( ( mxaapq.LE.roottol ) .OR.
1336 $ ( iswrot.LE.n ) ) )swband = i
1337*
1338 IF( ( i.GT.swband+1 ) .AND. ( mxaapq.LT.sqrt( dble( n ) )*
1339 $ tol ) .AND. ( dble( n )*mxaapq*mxsinj.LT.tol ) ) THEN
1340 GO TO 1994
1341 END IF
1342*
1343 IF( notrot.GE.emptsw )GO TO 1994
1344*
1345 1993 CONTINUE
1346* end i=1:NSWEEP loop
1347*
1348* #:( Reaching this point means that the procedure has not converged.
1349 info = nsweep - 1
1350 GO TO 1995
1351*
1352 1994 CONTINUE
1353* #:) Reaching this point means numerical convergence after the i-th
1354* sweep.
1355*
1356 info = 0
1357* #:) INFO = 0 confirms successful iterations.
1358 1995 CONTINUE
1359*
1360* Sort the singular values and find how many are above
1361* the underflow threshold.
1362*
1363 n2 = 0
1364 n4 = 0
1365 DO 5991 p = 1, n - 1
1366 q = idamax( n-p+1, sva( p ), 1 ) + p - 1
1367 IF( p.NE.q ) THEN
1368 temp1 = sva( p )
1369 sva( p ) = sva( q )
1370 sva( q ) = temp1
1371 CALL zswap( m, a( 1, p ), 1, a( 1, q ), 1 )
1372 IF( rsvec )CALL zswap( mvl, v( 1, p ), 1, v( 1, q ), 1 )
1373 END IF
1374 IF( sva( p ).NE.zero ) THEN
1375 n4 = n4 + 1
1376 IF( sva( p )*skl.GT.sfmin )n2 = n2 + 1
1377 END IF
1378 5991 CONTINUE
1379 IF( sva( n ).NE.zero ) THEN
1380 n4 = n4 + 1
1381 IF( sva( n )*skl.GT.sfmin )n2 = n2 + 1
1382 END IF
1383*
1384* Normalize the left singular vectors.
1385*
1386 IF( lsvec .OR. uctol ) THEN
1387 DO 1998 p = 1, n4
1388* CALL ZDSCAL( M, ONE / SVA( p ), A( 1, p ), 1 )
1389 CALL zlascl( 'G',0,0, sva(p), one, m, 1, a(1,p), m, ierr )
1390 1998 CONTINUE
1391 END IF
1392*
1393* Scale the product of Jacobi rotations.
1394*
1395 IF( rsvec ) THEN
1396 DO 2399 p = 1, n
1397 temp1 = one / dznrm2( mvl, v( 1, p ), 1 )
1398 CALL zdscal( mvl, temp1, v( 1, p ), 1 )
1399 2399 CONTINUE
1400 END IF
1401*
1402* Undo scaling, if necessary (and possible).
1403 IF( ( ( skl.GT.one ) .AND. ( sva( 1 ).LT.( big / skl ) ) )
1404 $ .OR. ( ( skl.LT.one ) .AND. ( sva( max( n2, 1 ) ) .GT.
1405 $ ( sfmin / skl ) ) ) ) THEN
1406 DO 2400 p = 1, n
1407 sva( p ) = skl*sva( p )
1408 2400 CONTINUE
1409 skl = one
1410 END IF
1411*
1412 rwork( 1 ) = skl
1413* The singular values of A are SKL*SVA(1:N). If SKL.NE.ONE
1414* then some of the singular values may overflow or underflow and
1415* the spectrum is given in this factored representation.
1416*
1417 rwork( 2 ) = dble( n4 )
1418* N4 is the number of computed nonzero singular values of A.
1419*
1420 rwork( 3 ) = dble( n2 )
1421* N2 is the number of singular values of A greater than SFMIN.
1422* If N2<N, SVA(N2:N) contains ZEROS and/or denormalized numbers
1423* that may carry some information.
1424*
1425 rwork( 4 ) = dble( i )
1426* i is the index of the last sweep before declaring convergence.
1427*
1428 rwork( 5 ) = mxaapq
1429* MXAAPQ is the largest absolute value of scaled pivots in the
1430* last sweep
1431*
1432 rwork( 6 ) = mxsinj
1433* MXSINJ is the largest absolute value of the sines of Jacobi angles
1434* in the last sweep
1435*
1436 RETURN
1437* ..
1438* .. END OF ZGESVJ
1439* ..
zlassq
subroutine zlassq(n, x, incx, scl, sumsq)
ZLASSQ updates a sum of squares represented in scaled form.
Definition zlassq.f90:137
dlascl
subroutine dlascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition dlascl.f:143
zlascl
subroutine zlascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition zlascl.f:143
zrot
subroutine zrot(n, cx, incx, cy, incy, c, s)
ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
Definition zrot.f:103
zlaset
subroutine zlaset(uplo, m, n, alpha, beta, a, lda)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition zlaset.f:106
zgsvj1
subroutine zgsvj1(jobv, m, n, n1, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
ZGSVJ1 pre-processor for the routine zgesvj, applies Jacobi rotations targeting only particular pivot...
Definition zgsvj1.f:236
zgsvj0
subroutine zgsvj0(jobv, m, n, a, lda, d, sva, mv, v, ldv, eps, sfmin, tol, nsweep, work, lwork, info)
ZGSVJ0 pre-processor for the routine zgesvj.
Definition zgsvj0.f:218
zdotc
complex *16 function zdotc(n, zx, incx, zy, incy)
ZDOTC
Definition zdotc.f:83

◆ zgetf2()

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

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

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

Purpose:
!>
!> ZGETF2 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*16 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 zgetf2.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*16 A( LDA, * )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 COMPLEX*16 ONE, ZERO
125 parameter( one = ( 1.0d+0, 0.0d+0 ),
126 $ zero = ( 0.0d+0, 0.0d+0 ) )
127* ..
128* .. Local Scalars ..
129 DOUBLE PRECISION SFMIN
130 INTEGER I, J, JP
131* ..
132* .. External Functions ..
133 DOUBLE PRECISION DLAMCH
134 INTEGER IZAMAX
135 EXTERNAL dlamch, izamax
136* ..
137* .. External Subroutines ..
138 EXTERNAL xerbla, zgeru, zscal, zswap
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( 'ZGETF2', -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 = dlamch('S')
168*
169 DO 10 j = 1, min( m, n )
170*
171* Find pivot and test for singularity.
172*
173 jp = j - 1 + izamax( 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 zswap( 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 zscal( 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 zgeru( 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 ZGETF2
210*
zscal
subroutine zscal(n, za, zx, incx)
ZSCAL
Definition zscal.f:78
zgeru
subroutine zgeru(m, n, alpha, x, incx, y, incy, a, lda)
ZGERU
Definition zgeru.f:130

◆ zgetrf()

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

ZGETRF

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

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

◆ zgetrf2()

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

ZGETRF2

Purpose:
!>
!> ZGETRF2 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*16 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 zgetrf2.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*16 A( LDA, * )
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 COMPLEX*16 ONE, ZERO
130 parameter( one = ( 1.0d+0, 0.0d+0 ),
131 $ zero = ( 0.0d+0, 0.0d+0 ) )
132* ..
133* .. Local Scalars ..
134 DOUBLE PRECISION SFMIN
135 COMPLEX*16 TEMP
136 INTEGER I, IINFO, N1, N2
137* ..
138* .. External Functions ..
139 DOUBLE PRECISION DLAMCH
140 INTEGER IZAMAX
141 EXTERNAL dlamch, izamax
142* ..
143* .. External Subroutines ..
144 EXTERNAL zgemm, zscal, zlaswp, ztrsm, 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( 'ZGETRF2', -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 = dlamch('S')
188*
189* Find pivot and test for singularity
190*
191 i = izamax( 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 zscal( 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 zgetrf2( 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 zlaswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 )
238*
239* Solve A12
240*
241 CALL ztrsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,
242 $ a( 1, n1+1 ), lda )
243*
244* Update A22
245*
246 CALL zgemm( '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 zgetrf2( 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 zlaswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 )
265*
266 END IF
267 RETURN
268*
269* End of ZGETRF2
270*

◆ zgetri()

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

ZGETRI

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

Purpose:
!>
!> ZGETRI computes the inverse of a matrix using the LU factorization
!> computed by ZGETRF.
!>
!> 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*16 array, dimension (LDA,N)
!>          On entry, the factors L and U from the factorization
!>          A = P*L*U as computed by ZGETRF.
!>          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 ZGETRF; for 1<=i<=N, row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[out]WORK
!>          WORK is COMPLEX*16 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 zgetri.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*16 A( LDA, * ), WORK( * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 COMPLEX*16 ZERO, ONE
131 parameter( zero = ( 0.0d+0, 0.0d+0 ),
132 $ one = ( 1.0d+0, 0.0d+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 xerbla, zgemm, zgemv, zswap, ztrsm, ztrtri
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, 'ZGETRI', ' ', 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( 'ZGETRI', -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 ZTRTRI, then U is singular,
178* and the inverse is not computed.
179*
180 CALL ztrtri( '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, 'ZGETRI', ' ', 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 zgemv( '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 zgemm( '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 ztrsm( '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 zswap( n, a( 1, j ), 1, a( 1, jp ), 1 )
252 60 CONTINUE
253*
254 work( 1 ) = iws
255 RETURN
256*
257* End of ZGETRI
258*
ztrtri
subroutine ztrtri(uplo, diag, n, a, lda, info)
ZTRTRI
Definition ztrtri.f:109

◆ zgetrs()

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

ZGETRS

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

Purpose:
!>
!> ZGETRS 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 ZGETRF.
!>
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*16 array, dimension (LDA,N)
!>          The factors L and U from the factorization A = P*L*U
!>          as computed by ZGETRF.
!>
[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 ZGETRF; for 1<=i<=N, row i of the
!>          matrix was interchanged with row IPIV(i).
!>
[in,out]B
!>          B is COMPLEX*16 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 zgetrs.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*16 A( LDA, * ), B( LDB, * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 COMPLEX*16 ONE
139 parameter( one = ( 1.0d+0, 0.0d+0 ) )
140* ..
141* .. Local Scalars ..
142 LOGICAL NOTRAN
143* ..
144* .. External Functions ..
145 LOGICAL LSAME
146 EXTERNAL lsame
147* ..
148* .. External Subroutines ..
149 EXTERNAL xerbla, zlaswp, ztrsm
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( 'ZGETRS', -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 zlaswp( nrhs, b, ldb, 1, n, ipiv, 1 )
189*
190* Solve L*X = B, overwriting B with X.
191*
192 CALL ztrsm( '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 ztrsm( '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 ztrsm( '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 ztrsm( 'Left', 'Lower', trans, 'Unit', n, nrhs, one, a,
211 $ lda, b, ldb )
212*
213* Apply row interchanges to the solution vectors.
214*
215 CALL zlaswp( nrhs, b, ldb, 1, n, ipiv, -1 )
216 END IF
217*
218 RETURN
219*
220* End of ZGETRS
221*

◆ zhgeqz()

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

ZHGEQZ

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

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

◆ zla_geamv()

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

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

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

Purpose:
!>
!> ZLA_GEAMV  performs one of the matrix-vector operations
!>
!>         y := alpha*abs(A)*abs(x) + beta*abs(y),
!>    or   y := alpha*abs(A)**T*abs(x) + beta*abs(y),
!>
!> where alpha and beta are scalars, x and y are vectors and A is an
!> m by n matrix.
!>
!> This function is primarily used in calculating error bounds.
!> To protect against underflow during evaluation, components in
!> the resulting vector are perturbed away from zero by (N+1)
!> times the underflow threshold.  To prevent unnecessarily large
!> errors for block-structure embedded in general matrices,
!>  zero components are not perturbed.  A zero
!> entry is considered  if all multiplications involved
!> in computing that entry have at least one zero multiplicand.
!>
Parameters
[in]TRANS
!>          TRANS is INTEGER
!>           On entry, TRANS specifies the operation to be performed as
!>           follows:
!>
!>             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)
!>             BLAS_TRANS         y := alpha*abs(A**T)*abs(x) + beta*abs(y)
!>             BLAS_CONJ_TRANS    y := alpha*abs(A**T)*abs(x) + beta*abs(y)
!>
!>           Unchanged on exit.
!>
[in]M
!>          M is INTEGER
!>           On entry, M specifies the number of rows of the matrix A.
!>           M must be at least zero.
!>           Unchanged on exit.
!>
[in]N
!>          N is INTEGER
!>           On entry, N specifies the number of columns of the matrix A.
!>           N must be at least zero.
!>           Unchanged on exit.
!>
[in]ALPHA
!>          ALPHA is DOUBLE PRECISION
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]A
!>          A is COMPLEX*16 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*16 array, dimension at least
!>           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
!>           and at least
!>           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
!>           Before entry, the incremented array X must contain the
!>           vector x.
!>           Unchanged on exit.
!>
[in]INCX
!>          INCX is INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           X. INCX must not be zero.
!>           Unchanged on exit.
!>
[in]BETA
!>          BETA is DOUBLE PRECISION
!>           On entry, BETA specifies the scalar beta. When BETA is
!>           supplied as zero then Y need not be set on input.
!>           Unchanged on exit.
!>
[in,out]Y
!>          Y is DOUBLE PRECISION array, dimension
!>           ( 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 zla_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 DOUBLE PRECISION ALPHA, BETA
182 INTEGER INCX, INCY, LDA, M, N
183 INTEGER TRANS
184* ..
185* .. Array Arguments ..
186 COMPLEX*16 A( LDA, * ), X( * )
187 DOUBLE PRECISION Y( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 COMPLEX*16 ONE, ZERO
194 parameter( one = 1.0d+0, zero = 0.0d+0 )
195* ..
196* .. Local Scalars ..
197 LOGICAL SYMB_ZERO
198 DOUBLE PRECISION TEMP, SAFE1
199 INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY
200 COMPLEX*16 CDUM
201* ..
202* .. External Subroutines ..
203 EXTERNAL xerbla, dlamch
204 DOUBLE PRECISION DLAMCH
205* ..
206* .. External Functions ..
207 EXTERNAL ilatrans
208 INTEGER ILATRANS
209* ..
210* .. Intrinsic Functions ..
211 INTRINSIC max, abs, real, dimag, sign
212* ..
213* .. Statement Functions ..
214 DOUBLE PRECISION CABS1
215* ..
216* .. Statement Function Definitions ..
217 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( 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( 'ZLA_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 = dlamch( '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.0d+0 ) THEN
288 symb_zero = .true.
289 y( iy ) = 0.0d+0
290 ELSE IF ( y( iy ) .EQ. 0.0d+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.0d+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.0d+0 ) THEN
314 symb_zero = .true.
315 y( iy ) = 0.0d+0
316 ELSE IF ( y( iy ) .EQ. 0.0d+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.0d+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.0d+0 ) THEN
342 symb_zero = .true.
343 y( iy ) = 0.0d+0
344 ELSE IF ( y( iy ) .EQ. 0.0d+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.0d+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.0d+0 ) THEN
370 symb_zero = .true.
371 y( iy ) = 0.0d+0
372 ELSE IF ( y( iy ) .EQ. 0.0d+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.0d+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 ZLA_GEAMV
402*

◆ zla_gercond_c()

double precision function zla_gercond_c ( character trans,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
double precision, dimension( * ) c,
logical capply,
integer info,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork )

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

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

Purpose:
!>
!>    ZLA_GERCOND_C computes the infinity norm condition number of
!>    op(A) * inv(diag(C)) where C is a DOUBLE PRECISION 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*16 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*16 array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by ZGETRF.
!>
[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 ZGETRF; row i of the matrix was interchanged
!>     with row IPIV(i).
!>
[in]C
!>          C is DOUBLE PRECISION 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*16 array, dimension (2*N).
!>     Workspace.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N).
!>     Workspace.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 140 of file zla_gercond_c.f.

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

◆ zla_gercond_x()

double precision function zla_gercond_x ( character trans,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldaf, * ) af,
integer ldaf,
integer, dimension( * ) ipiv,
complex*16, dimension( * ) x,
integer info,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork )

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

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

Purpose:
!>
!>    ZLA_GERCOND_X computes the infinity norm condition number of
!>    op(A) * diag(X) where X is a COMPLEX*16 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*16 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*16 array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by ZGETRF.
!>
[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 ZGETRF; row i of the matrix was interchanged
!>     with row IPIV(i).
!>
[in]X
!>          X is COMPLEX*16 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*16 array, dimension (2*N).
!>     Workspace.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N).
!>     Workspace.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 133 of file zla_gercond_x.f.

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

◆ zla_gerfsx_extended()

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

ZLA_GERFSX_EXTENDED

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

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

Definition at line 390 of file zla_gerfsx_extended.f.

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

◆ zla_gerpvgrw()

double precision function zla_gerpvgrw ( integer n,
integer ncols,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldaf, * ) af,
integer ldaf )

ZLA_GERPVGRW multiplies a square real matrix by a complex matrix.

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

Purpose:
!>
!>
!> ZLA_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*16 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*16 array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by ZGETRF.
!>
[in]LDAF
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 98 of file zla_gerpvgrw.f.

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

◆ zlaqz0()

recursive subroutine zlaqz0 ( 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*16, dimension( lda, * ), intent(inout) a,
integer, intent(in) lda,
complex*16, dimension( ldb, * ), intent(inout) b,
integer, intent(in) ldb,
complex*16, dimension( * ), intent(inout) alpha,
complex*16, dimension( * ), intent(inout) beta,
complex*16, dimension( ldq, * ), intent(inout) q,
integer, intent(in) ldq,
complex*16, dimension( ldz, * ), intent(inout) z,
integer, intent(in) ldz,
complex*16, dimension( * ), intent(inout) work,
integer, intent(in) lwork,
double precision, dimension( * ), intent(out) rwork,
integer, intent(in) rec,
integer, intent(out) info )

ZLAQZ0

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

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

◆ zlaqz1()

subroutine zlaqz1 ( 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*16, dimension( lda, * ) a,
integer, intent(in) lda,
complex*16, dimension( ldb, * ) b,
integer, intent(in) ldb,
integer, intent(in) nq,
integer, intent(in) qstart,
complex*16, dimension( ldq, * ) q,
integer, intent(in) ldq,
integer, intent(in) nz,
integer, intent(in) zstart,
complex*16, dimension( ldz, * ) z,
integer, intent(in) ldz )

ZLAQZ1

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

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

◆ zlaqz2()

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

ZLAQZ2

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

Purpose:
!>
!> ZLAQZ2 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*16 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*16 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*16 array, dimension (LDQ, N)
!>
[in]LDQ
!>          LDQ is INTEGER
!>
[in,out]Z
!>          Z is COMPLEX*16 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*16 array, dimension (N)
!>          Each scalar alpha defining an eigenvalue
!>          of GNEP.
!>
[out]BETA
!>          BETA is COMPLEX*16 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*16 array, dimension (LDQC, NW)
!>
[in]LDQC
!>          LDQC is INTEGER
!>
[in,out]ZC
!>          ZC is COMPLEX*16 array, dimension (LDZC, NW)
!>
[in]LDZC
!>          LDZ is INTEGER
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  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 DOUBLE PRECISION 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
!>
Author
Thijs Steel, KU Leuven
Date
May 2020

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

◆ zlaqz3()

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

ZLAQZ3

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

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

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

◆ zlaunhr_col_getrfnp()

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

ZLAUNHR_COL_GETRFNP

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

Purpose:
!>
!> ZLAUNHR_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 ZUNHR_COL. In ZUNHR_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 ZLAUNHR_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*16 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*16 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 zlaunhr_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*16 A( LDA, * ), D( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 COMPLEX*16 CONE
163 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
164* ..
165* .. Local Scalars ..
166 INTEGER IINFO, J, JB, NB
167* ..
168* .. External Subroutines ..
169 EXTERNAL zgemm, zlaunhr_col_getrfnp2, ztrsm, 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( 'ZLAUNHR_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, 'ZLAUNHR_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 zlaunhr_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 zlaunhr_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 ztrsm( '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 zgemm( '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 ZLAUNHR_COL_GETRFNP
244*
zlaunhr_col_getrfnp2
recursive subroutine zlaunhr_col_getrfnp2(m, n, a, lda, d, info)
ZLAUNHR_COL_GETRFNP2
Definition zlaunhr_col_getrfnp2.f:167

◆ zlaunhr_col_getrfnp2()

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

ZLAUNHR_COL_GETRFNP2

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

Purpose:
!>
!> ZLAUNHR_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 ZUNHR_COL. In ZUNHR_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].
!>
!> ZLAUNHR_COL_GETRFNP2 is called to factorize a block by the blocked
!> routine ZLAUNHR_COL_GETRFNP, which uses blocked code calling
!> Level 3 BLAS to update the submatrix. However, ZLAUNHR_COL_GETRFNP2
!> is self-sufficient and can be used without ZLAUNHR_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*16 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*16 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 zlaunhr_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*16 A( LDA, * ), D( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 DOUBLE PRECISION ONE
184 parameter( one = 1.0d+0 )
185 COMPLEX*16 CONE
186 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
187* ..
188* .. Local Scalars ..
189 DOUBLE PRECISION SFMIN
190 INTEGER I, IINFO, N1, N2
191 COMPLEX*16 Z
192* ..
193* .. External Functions ..
194 DOUBLE PRECISION DLAMCH
195 EXTERNAL dlamch
196* ..
197* .. External Subroutines ..
198 EXTERNAL zgemm, zscal, ztrsm, xerbla
199* ..
200* .. Intrinsic Functions ..
201 INTRINSIC abs, dble, dcmplx, dimag, dsign, max, min
202* ..
203* .. Statement Functions ..
204 DOUBLE PRECISION CABS1
205* ..
206* .. Statement Function definitions ..
207 cabs1( z ) = abs( dble( z ) ) + abs( dimag( 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( 'ZLAUNHR_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 ) = dcmplx( -dsign( one, dble( 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 ) = dcmplx( -dsign( one, dble( 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 = dlamch('S')
262*
263* Construct the subdiagonal elements of L
264*
265 IF( cabs1( a( 1, 1 ) ) .GE. sfmin ) THEN
266 CALL zscal( 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 zlaunhr_col_getrfnp2( n1, n1, a, lda, d, iinfo )
284*
285* Solve for B21
286*
287 CALL ztrsm( 'R', 'U', 'N', 'N', m-n1, n1, cone, a, lda,
288 $ a( n1+1, 1 ), lda )
289*
290* Solve for B12
291*
292 CALL ztrsm( '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 zgemm( '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 zlaunhr_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 ZLAUNHR_COL_GETRFNP2
310*

◆ ztgevc()

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

ZTGEVC

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

Purpose:
!>
!> ZTGEVC 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 ZGGHRD + ZHGEQZ.
!>
!> 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*16 array, dimension (LDS,N)
!>          The upper triangular matrix S from a generalized Schur
!>          factorization, as computed by ZHGEQZ.
!>
[in]LDS
!>          LDS is INTEGER
!>          The leading dimension of array S.  LDS >= max(1,N).
!>
[in]P
!>          P is COMPLEX*16 array, dimension (LDP,N)
!>          The upper triangular matrix P from a generalized Schur
!>          factorization, as computed by ZHGEQZ.  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*16 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 ZHGEQZ).
!>          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*16 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 ZHGEQZ).
!>          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*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 217 of file ztgevc.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 DOUBLE PRECISION RWORK( * )
231 COMPLEX*16 P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
232 $ VR( LDVR, * ), WORK( * )
233* ..
234*
235*
236* =====================================================================
237*
238* .. Parameters ..
239 DOUBLE PRECISION ZERO, ONE
240 parameter( zero = 0.0d+0, one = 1.0d+0 )
241 COMPLEX*16 CZERO, CONE
242 parameter( czero = ( 0.0d+0, 0.0d+0 ),
243 $ cone = ( 1.0d+0, 0.0d+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 DOUBLE PRECISION ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG,
251 $ BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA,
252 $ SCALE, SMALL, TEMP, ULP, XMAX
253 COMPLEX*16 BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X
254* ..
255* .. External Functions ..
256 LOGICAL LSAME
257 DOUBLE PRECISION DLAMCH
258 COMPLEX*16 ZLADIV
259 EXTERNAL lsame, dlamch, zladiv
260* ..
261* .. External Subroutines ..
262 EXTERNAL dlabad, xerbla, zgemv
263* ..
264* .. Intrinsic Functions ..
265 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, min
266* ..
267* .. Statement Functions ..
268 DOUBLE PRECISION ABS1
269* ..
270* .. Statement Function definitions ..
271 abs1( x ) = abs( dble( x ) ) + abs( dimag( 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( 'ZTGEVC', -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( dimag( 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( 'ZTGEVC', -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 = dlamch( 'Safe minimum' )
369 big = one / safmin
370 CALL dlabad( safmin, big )
371 ulp = dlamch( 'Epsilon' )*dlamch( '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( dble( 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( dble( p( je, je ) ) )*bscale, safmin )
433 salpha = ( temp*s( je, je ) )*ascale
434 sbeta = ( temp*dble( 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 + dconjg( s( jr, j ) )*work( jr )
502 sumb = sumb + dconjg( p( jr, j ) )*work( jr )
503 80 CONTINUE
504 sum = acoeff*suma - dconjg( 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 = dconjg( acoeff*s( j, j )-bcoeff*p( j, j ) )
511 IF( abs1( d ).LE.dmin )
512 $ d = dcmplx( 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 ) = zladiv( -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 zgemv( '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( dble( 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( dble( p( je, je ) ) )*bscale, safmin )
599 salpha = ( temp*s( je, je ) )*ascale
600 sbeta = ( temp*dble( 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 = dcmplx( 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 ) = zladiv( -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 zgemv( '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 ZTGEVC
733*

◆ ztgexc()

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

ZTGEXC

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

Purpose:
!>
!> ZTGEXC 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*16 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*16 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*16 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*16 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 ztgexc.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*16 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 xerbla, ztgex2
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( 'ZTGEXC', -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 ztgex2( 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 ztgex2( 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 ZTGEXC
296*
ztgex2
subroutine ztgex2(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, j1, info)
ZTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an unitary equiva...
Definition ztgex2.f:190