OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
complex16
LAPACK Testing » Eigenvalue and Singular value

Functions

subroutine zbdt01 (m, n, kd, a, lda, q, ldq, d, e, pt, ldpt, work, rwork, resid)
 ZBDT01
subroutine zbdt02 (m, n, b, ldb, c, ldc, u, ldu, work, rwork, resid)
 ZBDT02
subroutine zbdt03 (uplo, n, kd, d, e, u, ldu, s, vt, ldvt, work, resid)
 ZBDT03
subroutine zchkbb (nsizes, mval, nval, nwdths, kk, ntypes, dotype, nrhs, iseed, thresh, nounit, a, lda, ab, ldab, bd, be, q, ldq, p, ldp, c, ldc, cc, work, lwork, rwork, result, info)
 ZCHKBB
subroutine zchkbd (nsizes, mval, nval, ntypes, dotype, nrhs, iseed, thresh, a, lda, bd, be, s1, s2, x, ldx, y, z, q, ldq, pt, ldpt, u, vt, work, lwork, rwork, nout, info)
 ZCHKBD
subroutine zchkbk (nin, nout)
 ZCHKBK
subroutine zchkbl (nin, nout)
 ZCHKBL
subroutine zchkec (thresh, tsterr, nin, nout)
 ZCHKEC
program zchkee
 ZCHKEE
subroutine zchkgg (nsizes, nn, ntypes, dotype, iseed, thresh, tstdif, thrshn, nounit, a, lda, b, h, t, s1, s2, p1, p2, u, ldu, v, q, z, alpha1, beta1, alpha3, beta3, evectl, evectr, work, lwork, rwork, llwork, result, info)
 ZCHKGG
subroutine zchkgk (nin, nout)
 ZCHKGK
subroutine zchkgl (nin, nout)
 ZCHKGL
subroutine zchkhb (nsizes, nn, nwdths, kk, ntypes, dotype, iseed, thresh, nounit, a, lda, sd, se, u, ldu, work, lwork, rwork, result, info)
 ZCHKHB
subroutine zchkhb2stg (nsizes, nn, nwdths, kk, ntypes, dotype, iseed, thresh, nounit, a, lda, sd, se, d1, d2, d3, u, ldu, work, lwork, rwork, result, info)
 ZCHKHB2STG
subroutine zchkhs (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, h, t1, t2, u, ldu, z, uz, w1, w3, evectl, evectr, evecty, evectx, uu, tau, work, nwork, rwork, iwork, select, result, info)
 ZCHKHS
subroutine zchkst (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, ap, sd, se, d1, d2, d3, d4, d5, wa1, wa2, wa3, wr, u, ldu, v, vp, tau, z, work, lwork, rwork, lrwork, iwork, liwork, result, info)
 ZCHKST
subroutine zchkst2stg (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, ap, sd, se, d1, d2, d3, d4, d5, wa1, wa2, wa3, wr, u, ldu, v, vp, tau, z, work, lwork, rwork, lrwork, iwork, liwork, result, info)
 ZCHKST2STG
subroutine zckcsd (nm, mval, pval, qval, nmats, iseed, thresh, mmax, x, xf, u1, u2, v1t, v2t, theta, iwork, work, rwork, nin, nout, info)
 ZCKCSD
subroutine zckglm (nn, nval, mval, pval, nmats, iseed, thresh, nmax, a, af, b, bf, x, work, rwork, nin, nout, info)
 ZCKGLM
subroutine zckgqr (nm, mval, np, pval, nn, nval, nmats, iseed, thresh, nmax, a, af, aq, ar, taua, b, bf, bz, bt, bwk, taub, work, rwork, nin, nout, info)
 ZCKGQR
subroutine zckgsv (nm, mval, pval, nval, nmats, iseed, thresh, nmax, a, af, b, bf, u, v, q, alpha, beta, r, iwork, work, rwork, nin, nout, info)
 ZCKGSV
subroutine zcklse (nn, mval, pval, nval, nmats, iseed, thresh, nmax, a, af, b, bf, x, work, rwork, nin, nout, info)
 ZCKLSE
subroutine zcsdts (m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, theta, iwork, work, lwork, rwork, result)
 ZCSDTS
subroutine zdrges (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, alpha, beta, work, lwork, rwork, result, bwork, info)
 ZDRGES
subroutine zdrges3 (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, alpha, beta, work, lwork, rwork, result, bwork, info)
 ZDRGES3
subroutine zdrgev (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, qe, ldqe, alpha, beta, alpha1, beta1, work, lwork, rwork, result, info)
 ZDRGEV
subroutine zdrgev3 (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, qe, ldqe, alpha, beta, alpha1, beta1, work, lwork, rwork, result, info)
 ZDRGEV3
subroutine zdrgsx (nsize, ncmax, thresh, nin, nout, a, lda, b, ai, bi, z, q, alpha, beta, c, ldc, s, work, lwork, rwork, iwork, liwork, bwork, info)
 ZDRGSX
subroutine zdrgvx (nsize, thresh, nin, nout, a, lda, b, ai, bi, alpha, beta, vl, vr, ilo, ihi, lscale, rscale, s, dtru, dif, diftru, work, lwork, rwork, iwork, liwork, result, bwork, info)
 ZDRGVX
subroutine zdrvbd (nsizes, mm, nn, ntypes, dotype, iseed, thresh, a, lda, u, ldu, vt, ldvt, asav, usav, vtsav, s, ssav, e, work, lwork, rwork, iwork, nounit, info)
 ZDRVBD
subroutine zdrves (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, h, ht, w, wt, vs, ldvs, result, work, nwork, rwork, iwork, bwork, info)
 ZDRVES
subroutine zdrvev (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre, result, work, nwork, rwork, iwork, info)
 ZDRVEV
subroutine zdrvsg (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, ldb, d, z, ldz, ab, bb, ap, bp, work, nwork, rwork, lrwork, iwork, liwork, result, info)
 ZDRVSG
subroutine zdrvsg2stg (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, ldb, d, d2, z, ldz, ab, bb, ap, bp, work, nwork, rwork, lrwork, iwork, liwork, result, info)
 ZDRVSG2STG
subroutine zdrvst (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, d1, d2, d3, wa1, wa2, wa3, u, ldu, v, tau, z, work, lwork, rwork, lrwork, iwork, liwork, result, info)
 ZDRVST
subroutine zdrvst2stg (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, d1, d2, d3, wa1, wa2, wa3, u, ldu, v, tau, z, work, lwork, rwork, lrwork, iwork, liwork, result, info)
 ZDRVST2STG
subroutine zdrvsx (nsizes, nn, ntypes, dotype, iseed, thresh, niunit, nounit, a, lda, h, ht, w, wt, wtmp, vs, ldvs, vs1, result, work, lwork, rwork, bwork, info)
 ZDRVSX
subroutine zdrvvx (nsizes, nn, ntypes, dotype, iseed, thresh, niunit, nounit, a, lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein, scale, scale1, result, work, nwork, rwork, info)
 ZDRVVX
subroutine zerrbd (path, nunit)
 ZERRBD
subroutine zerrec (path, nunit)
 ZERREC
subroutine zerred (path, nunit)
 ZERRED
subroutine zerrgg (path, nunit)
 ZERRGG
subroutine zerrhs (path, nunit)
 ZERRHS
subroutine zerrst (path, nunit)
 ZERRST
subroutine zget02 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 ZGET02
subroutine zget10 (m, n, a, lda, b, ldb, work, rwork, result)
 ZGET10
subroutine zget22 (transa, transe, transw, n, a, lda, e, lde, w, work, rwork, result)
 ZGET22
subroutine zget23 (comp, isrt, balanc, jtype, thresh, iseed, nounit, n, a, lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein, scale, scale1, result, work, lwork, rwork, info)
 ZGET23
subroutine zget24 (comp, jtype, thresh, iseed, nounit, n, a, lda, h, ht, w, wt, wtmp, vs, ldvs, vs1, rcdein, rcdvin, nslct, islct, isrt, result, work, lwork, rwork, bwork, info)
 ZGET24
subroutine zget35 (rmax, lmax, ninfo, knt, nin)
 ZGET35
subroutine zget36 (rmax, lmax, ninfo, knt, nin)
 ZGET36
subroutine zget37 (rmax, lmax, ninfo, knt, nin)
 ZGET37
subroutine zget38 (rmax, lmax, ninfo, knt, nin)
 ZGET38
subroutine zget51 (itype, n, a, lda, b, ldb, u, ldu, v, ldv, work, rwork, result)
 ZGET51
subroutine zget52 (left, n, a, lda, b, ldb, e, lde, alpha, beta, work, rwork, result)
 ZGET52
subroutine zget54 (n, a, lda, b, ldb, s, lds, t, ldt, u, ldu, v, ldv, work, result)
 ZGET54
subroutine zglmts (n, m, p, a, af, lda, b, bf, ldb, d, df, x, u, work, lwork, rwork, result)
 ZGLMTS
subroutine zgqrts (n, m, p, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
 ZGQRTS
subroutine zgrqts (m, p, n, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
 ZGRQTS
subroutine zgsvts3 (m, p, n, a, af, lda, b, bf, ldb, u, ldu, v, ldv, q, ldq, alpha, beta, r, ldr, iwork, work, lwork, rwork, result)
 ZGSVTS3
subroutine zhbt21 (uplo, n, ka, ks, a, lda, d, e, u, ldu, work, rwork, result)
 ZHBT21
subroutine zhet21 (itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
 ZHET21
subroutine zhet22 (itype, uplo, n, m, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
 ZHET22
subroutine zhpt21 (itype, uplo, n, kband, ap, d, e, u, ldu, vp, tau, work, rwork, result)
 ZHPT21
subroutine zhst01 (n, ilo, ihi, a, lda, h, ldh, q, ldq, work, lwork, rwork, result)
 ZHST01
subroutine zlarfy (uplo, n, v, incv, tau, c, ldc, work)
 ZLARFY
subroutine zlarhs (path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
 ZLARHS
subroutine zlatm4 (itype, n, nz1, nz2, rsign, amagn, rcond, triang, idist, iseed, a, lda)
 ZLATM4
logical function zlctes (z, d)
 ZLCTES
logical function zlctsx (alpha, beta)
 ZLCTSX
subroutine zlsets (m, p, n, a, af, lda, b, bf, ldb, c, cf, d, df, x, work, lwork, rwork, result)
 ZLSETS
subroutine zsbmv (uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
 ZSBMV
subroutine zsgt01 (itype, uplo, n, m, a, lda, b, ldb, z, ldz, d, work, rwork, result)
 ZSGT01
logical function zslect (z)
 ZSLECT
subroutine zstt21 (n, kband, ad, ae, sd, se, u, ldu, work, rwork, result)
 ZSTT21
subroutine zstt22 (n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, rwork, result)
 ZSTT22
subroutine zunt01 (rowcol, m, n, u, ldu, work, lwork, rwork, resid)
 ZUNT01
subroutine zunt03 (rc, mu, mv, n, k, u, ldu, v, ldv, work, lwork, rwork, result, info)
 ZUNT03

Detailed Description

This is the group of complex16 LAPACK TESTING EIG routines.

Function Documentation

◆ zbdt01()

subroutine zbdt01 ( integer m,
integer n,
integer kd,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldq, * ) q,
integer ldq,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldpt, * ) pt,
integer ldpt,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision resid )

ZBDT01

Purpose:
!>
!> ZBDT01 reconstructs a general matrix A from its bidiagonal form
!>    A = Q * B * P**H
!> where Q (m by min(m,n)) and P**H (min(m,n) by n) are unitary
!> matrices and B is bidiagonal.
!>
!> The test ratio to test the reduction is
!>    RESID = norm(A - Q * B * P**H) / ( n * norm(A) * EPS )
!> where EPS is the machine precision.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrices A and Q.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and P**H.
!>
[in]KD
!>          KD is INTEGER
!>          If KD = 0, B is diagonal and the array E is not referenced.
!>          If KD = 1, the reduction was performed by xGEBRD; B is upper
!>          bidiagonal if M >= N, and lower bidiagonal if M < N.
!>          If KD = -1, the reduction was performed by xGBBRD; B is
!>          always upper bidiagonal.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m by n matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          The m by min(m,n) unitary matrix Q in the reduction
!>          A = Q * B * P**H.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,M).
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (min(M,N)-1)
!>          The superdiagonal elements of the bidiagonal matrix B if
!>          m >= n, or the subdiagonal elements of B if m < n.
!>
[in]PT
!>          PT is COMPLEX*16 array, dimension (LDPT,N)
!>          The min(m,n) by n unitary matrix P**H in the reduction
!>          A = Q * B * P**H.
!>
[in]LDPT
!>          LDPT is INTEGER
!>          The leading dimension of the array PT.
!>          LDPT >= max(1,min(M,N)).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (M+N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The test ratio:
!>          norm(A - Q * B * P**H) / ( n * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 145 of file zbdt01.f.

147*
148* -- LAPACK test 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 KD, LDA, LDPT, LDQ, M, N
154 DOUBLE PRECISION RESID
155* ..
156* .. Array Arguments ..
157 DOUBLE PRECISION D( * ), E( * ), RWORK( * )
158 COMPLEX*16 A( LDA, * ), PT( LDPT, * ), Q( LDQ, * ),
159 $ 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, J
170 DOUBLE PRECISION ANORM, EPS
171* ..
172* .. External Functions ..
173 DOUBLE PRECISION DLAMCH, DZASUM, ZLANGE
174 EXTERNAL dlamch, dzasum, zlange
175* ..
176* .. External Subroutines ..
177 EXTERNAL zcopy, zgemv
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC dble, dcmplx, max, min
181* ..
182* .. Executable Statements ..
183*
184* Quick return if possible
185*
186 IF( m.LE.0 .OR. n.LE.0 ) THEN
187 resid = zero
188 RETURN
189 END IF
190*
191* Compute A - Q * B * P**H one column at a time.
192*
193 resid = zero
194 IF( kd.NE.0 ) THEN
195*
196* B is bidiagonal.
197*
198 IF( kd.NE.0 .AND. m.GE.n ) THEN
199*
200* B is upper bidiagonal and M >= N.
201*
202 DO 20 j = 1, n
203 CALL zcopy( m, a( 1, j ), 1, work, 1 )
204 DO 10 i = 1, n - 1
205 work( m+i ) = d( i )*pt( i, j ) + e( i )*pt( i+1, j )
206 10 CONTINUE
207 work( m+n ) = d( n )*pt( n, j )
208 CALL zgemv( 'No transpose', m, n, -dcmplx( one ), q, ldq,
209 $ work( m+1 ), 1, dcmplx( one ), work, 1 )
210 resid = max( resid, dzasum( m, work, 1 ) )
211 20 CONTINUE
212 ELSE IF( kd.LT.0 ) THEN
213*
214* B is upper bidiagonal and M < N.
215*
216 DO 40 j = 1, n
217 CALL zcopy( m, a( 1, j ), 1, work, 1 )
218 DO 30 i = 1, m - 1
219 work( m+i ) = d( i )*pt( i, j ) + e( i )*pt( i+1, j )
220 30 CONTINUE
221 work( m+m ) = d( m )*pt( m, j )
222 CALL zgemv( 'No transpose', m, m, -dcmplx( one ), q, ldq,
223 $ work( m+1 ), 1, dcmplx( one ), work, 1 )
224 resid = max( resid, dzasum( m, work, 1 ) )
225 40 CONTINUE
226 ELSE
227*
228* B is lower bidiagonal.
229*
230 DO 60 j = 1, n
231 CALL zcopy( m, a( 1, j ), 1, work, 1 )
232 work( m+1 ) = d( 1 )*pt( 1, j )
233 DO 50 i = 2, m
234 work( m+i ) = e( i-1 )*pt( i-1, j ) +
235 $ d( i )*pt( i, j )
236 50 CONTINUE
237 CALL zgemv( 'No transpose', m, m, -dcmplx( one ), q, ldq,
238 $ work( m+1 ), 1, dcmplx( one ), work, 1 )
239 resid = max( resid, dzasum( m, work, 1 ) )
240 60 CONTINUE
241 END IF
242 ELSE
243*
244* B is diagonal.
245*
246 IF( m.GE.n ) THEN
247 DO 80 j = 1, n
248 CALL zcopy( m, a( 1, j ), 1, work, 1 )
249 DO 70 i = 1, n
250 work( m+i ) = d( i )*pt( i, j )
251 70 CONTINUE
252 CALL zgemv( 'No transpose', m, n, -dcmplx( one ), q, ldq,
253 $ work( m+1 ), 1, dcmplx( one ), work, 1 )
254 resid = max( resid, dzasum( m, work, 1 ) )
255 80 CONTINUE
256 ELSE
257 DO 100 j = 1, n
258 CALL zcopy( m, a( 1, j ), 1, work, 1 )
259 DO 90 i = 1, m
260 work( m+i ) = d( i )*pt( i, j )
261 90 CONTINUE
262 CALL zgemv( 'No transpose', m, m, -dcmplx( one ), q, ldq,
263 $ work( m+1 ), 1, dcmplx( one ), work, 1 )
264 resid = max( resid, dzasum( m, work, 1 ) )
265 100 CONTINUE
266 END IF
267 END IF
268*
269* Compute norm(A - Q * B * P**H) / ( n * norm(A) * EPS )
270*
271 anorm = zlange( '1', m, n, a, lda, rwork )
272 eps = dlamch( 'Precision' )
273*
274 IF( anorm.LE.zero ) THEN
275 IF( resid.NE.zero )
276 $ resid = one / eps
277 ELSE
278 IF( anorm.GE.resid ) THEN
279 resid = ( resid / anorm ) / ( dble( n )*eps )
280 ELSE
281 IF( anorm.LT.one ) THEN
282 resid = ( min( resid, dble( n )*anorm ) / anorm ) /
283 $ ( dble( n )*eps )
284 ELSE
285 resid = min( resid / anorm, dble( n ) ) /
286 $ ( dble( n )*eps )
287 END IF
288 END IF
289 END IF
290*
291 RETURN
292*
293* End of ZBDT01
294*
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
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
zgemv
subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
ZGEMV
Definition zgemv.f:158
dzasum
double precision function dzasum(n, zx, incx)
DZASUM
Definition dzasum.f:72
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ zbdt02()

subroutine zbdt02 ( integer m,
integer n,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision resid )

ZBDT02

Purpose:
!>
!> ZBDT02 tests the change of basis C = U**H * B by computing the
!> residual
!>
!>    RESID = norm(B - U * C) / ( max(m,n) * norm(B) * EPS ),
!>
!> where B and C are M by N matrices, U is an M by M orthogonal matrix,
!> and EPS is the machine precision.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrices B and C and the order of
!>          the matrix Q.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices B and C.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          The m by n matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!>
[in]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>          The m by n matrix C, assumed to contain U**H * B.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,M).
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU,M)
!>          The m by m orthogonal matrix U.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (M)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          RESID = norm(B - U * C) / ( max(m,n) * norm(B) * EPS ),
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 118 of file zbdt02.f.

120*
121* -- LAPACK test routine --
122* -- LAPACK is a software package provided by Univ. of Tennessee, --
123* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124*
125* .. Scalar Arguments ..
126 INTEGER LDB, LDC, LDU, M, N
127 DOUBLE PRECISION RESID
128* ..
129* .. Array Arguments ..
130 DOUBLE PRECISION RWORK( * )
131 COMPLEX*16 B( LDB, * ), C( LDC, * ), U( LDU, * ),
132 $ WORK( * )
133* ..
134*
135* ======================================================================
136*
137* .. Parameters ..
138 DOUBLE PRECISION ZERO, ONE
139 parameter( zero = 0.0d+0, one = 1.0d+0 )
140* ..
141* .. Local Scalars ..
142 INTEGER J
143 DOUBLE PRECISION BNORM, EPS, REALMN
144* ..
145* .. External Functions ..
146 DOUBLE PRECISION DLAMCH, DZASUM, ZLANGE
147 EXTERNAL dlamch, dzasum, zlange
148* ..
149* .. External Subroutines ..
150 EXTERNAL zcopy, zgemv
151* ..
152* .. Intrinsic Functions ..
153 INTRINSIC dble, dcmplx, max, min
154* ..
155* .. Executable Statements ..
156*
157* Quick return if possible
158*
159 resid = zero
160 IF( m.LE.0 .OR. n.LE.0 )
161 $ RETURN
162 realmn = dble( max( m, n ) )
163 eps = dlamch( 'Precision' )
164*
165* Compute norm(B - U * C)
166*
167 DO 10 j = 1, n
168 CALL zcopy( m, b( 1, j ), 1, work, 1 )
169 CALL zgemv( 'No transpose', m, m, -dcmplx( one ), u, ldu,
170 $ c( 1, j ), 1, dcmplx( one ), work, 1 )
171 resid = max( resid, dzasum( m, work, 1 ) )
172 10 CONTINUE
173*
174* Compute norm of B.
175*
176 bnorm = zlange( '1', m, n, b, ldb, rwork )
177*
178 IF( bnorm.LE.zero ) THEN
179 IF( resid.NE.zero )
180 $ resid = one / eps
181 ELSE
182 IF( bnorm.GE.resid ) THEN
183 resid = ( resid / bnorm ) / ( realmn*eps )
184 ELSE
185 IF( bnorm.LT.one ) THEN
186 resid = ( min( resid, realmn*bnorm ) / bnorm ) /
187 $ ( realmn*eps )
188 ELSE
189 resid = min( resid / bnorm, realmn ) / ( realmn*eps )
190 END IF
191 END IF
192 END IF
193 RETURN
194*
195* End of ZBDT02
196*

◆ zbdt03()

subroutine zbdt03 ( character uplo,
integer n,
integer kd,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldu, * ) u,
integer ldu,
double precision, dimension( * ) s,
complex*16, dimension( ldvt, * ) vt,
integer ldvt,
complex*16, dimension( * ) work,
double precision resid )

ZBDT03

Purpose:
!>
!> ZBDT03 reconstructs a bidiagonal matrix B from its SVD:
!>    S = U' * B * V
!> where U and V are orthogonal matrices and S is diagonal.
!>
!> The test ratio to test the singular value decomposition is
!>    RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS )
!> where VT = V' and EPS is the machine precision.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix B is upper or lower bidiagonal.
!>          = 'U':  Upper bidiagonal
!>          = 'L':  Lower bidiagonal
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix B.
!>
[in]KD
!>          KD is INTEGER
!>          The bandwidth of the bidiagonal matrix B.  If KD = 1, the
!>          matrix B is bidiagonal, and if KD = 0, B is diagonal and E is
!>          not referenced.  If KD is greater than 1, it is assumed to be
!>          1, and if KD is less than 0, it is assumed to be 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the bidiagonal matrix B.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) superdiagonal elements of the bidiagonal matrix B
!>          if UPLO = 'U', or the (n-1) subdiagonal elements of B if
!>          UPLO = 'L'.
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU,N)
!>          The n by n orthogonal matrix U in the reduction B = U'*A*P.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,N)
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (N)
!>          The singular values from the SVD of B, sorted in decreasing
!>          order.
!>
[in]VT
!>          VT is COMPLEX*16 array, dimension (LDVT,N)
!>          The n by n orthogonal matrix V' in the reduction
!>          B = U * S * V'.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The test ratio:  norm(B - U * S * V') / ( n * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 133 of file zbdt03.f.

135*
136* -- LAPACK test routine --
137* -- LAPACK is a software package provided by Univ. of Tennessee, --
138* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
139*
140* .. Scalar Arguments ..
141 CHARACTER UPLO
142 INTEGER KD, LDU, LDVT, N
143 DOUBLE PRECISION RESID
144* ..
145* .. Array Arguments ..
146 DOUBLE PRECISION D( * ), E( * ), S( * )
147 COMPLEX*16 U( LDU, * ), VT( LDVT, * ), WORK( * )
148* ..
149*
150* ======================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d+0, one = 1.0d+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER I, J
158 DOUBLE PRECISION BNORM, EPS
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 INTEGER IDAMAX
163 DOUBLE PRECISION DLAMCH, DZASUM
164 EXTERNAL lsame, idamax, dlamch, dzasum
165* ..
166* .. External Subroutines ..
167 EXTERNAL zgemv
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, dble, dcmplx, max, min
171* ..
172* .. Executable Statements ..
173*
174* Quick return if possible
175*
176 resid = zero
177 IF( n.LE.0 )
178 $ RETURN
179*
180* Compute B - U * S * V' one column at a time.
181*
182 bnorm = zero
183 IF( kd.GE.1 ) THEN
184*
185* B is bidiagonal.
186*
187 IF( lsame( uplo, 'U' ) ) THEN
188*
189* B is upper bidiagonal.
190*
191 DO 20 j = 1, n
192 DO 10 i = 1, n
193 work( n+i ) = s( i )*vt( i, j )
194 10 CONTINUE
195 CALL zgemv( 'No transpose', n, n, -dcmplx( one ), u, ldu,
196 $ work( n+1 ), 1, dcmplx( zero ), work, 1 )
197 work( j ) = work( j ) + d( j )
198 IF( j.GT.1 ) THEN
199 work( j-1 ) = work( j-1 ) + e( j-1 )
200 bnorm = max( bnorm, abs( d( j ) )+abs( e( j-1 ) ) )
201 ELSE
202 bnorm = max( bnorm, abs( d( j ) ) )
203 END IF
204 resid = max( resid, dzasum( n, work, 1 ) )
205 20 CONTINUE
206 ELSE
207*
208* B is lower bidiagonal.
209*
210 DO 40 j = 1, n
211 DO 30 i = 1, n
212 work( n+i ) = s( i )*vt( i, j )
213 30 CONTINUE
214 CALL zgemv( 'No transpose', n, n, -dcmplx( one ), u, ldu,
215 $ work( n+1 ), 1, dcmplx( zero ), work, 1 )
216 work( j ) = work( j ) + d( j )
217 IF( j.LT.n ) THEN
218 work( j+1 ) = work( j+1 ) + e( j )
219 bnorm = max( bnorm, abs( d( j ) )+abs( e( j ) ) )
220 ELSE
221 bnorm = max( bnorm, abs( d( j ) ) )
222 END IF
223 resid = max( resid, dzasum( n, work, 1 ) )
224 40 CONTINUE
225 END IF
226 ELSE
227*
228* B is diagonal.
229*
230 DO 60 j = 1, n
231 DO 50 i = 1, n
232 work( n+i ) = s( i )*vt( i, j )
233 50 CONTINUE
234 CALL zgemv( 'No transpose', n, n, -dcmplx( one ), u, ldu,
235 $ work( n+1 ), 1, dcmplx( zero ), work, 1 )
236 work( j ) = work( j ) + d( j )
237 resid = max( resid, dzasum( n, work, 1 ) )
238 60 CONTINUE
239 j = idamax( n, d, 1 )
240 bnorm = abs( d( j ) )
241 END IF
242*
243* Compute norm(B - U * S * V') / ( n * norm(B) * EPS )
244*
245 eps = dlamch( 'Precision' )
246*
247 IF( bnorm.LE.zero ) THEN
248 IF( resid.NE.zero )
249 $ resid = one / eps
250 ELSE
251 IF( bnorm.GE.resid ) THEN
252 resid = ( resid / bnorm ) / ( dble( n )*eps )
253 ELSE
254 IF( bnorm.LT.one ) THEN
255 resid = ( min( resid, dble( n )*bnorm ) / bnorm ) /
256 $ ( dble( n )*eps )
257 ELSE
258 resid = min( resid / bnorm, dble( n ) ) /
259 $ ( dble( n )*eps )
260 END IF
261 END IF
262 END IF
263*
264 RETURN
265*
266* End of ZBDT03
267*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71

◆ zchkbb()

subroutine zchkbb ( integer nsizes,
integer, dimension( * ) mval,
integer, dimension( * ) nval,
integer nwdths,
integer, dimension( * ) kk,
integer ntypes,
logical, dimension( * ) dotype,
integer nrhs,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( * ) bd,
double precision, dimension( * ) be,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldp, * ) p,
integer ldp,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( ldc, * ) cc,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result,
integer info )

ZCHKBB

Purpose:
!>
!> ZCHKBB tests the reduction of a general complex rectangular band
!> matrix to real bidiagonal form.
!>
!> ZGBBRD factors a general band matrix A as  Q B P* , where * means
!> conjugate transpose, B is upper bidiagonal, and Q and P are unitary;
!> ZGBBRD can also overwrite a given matrix C with Q* C .
!>
!> For each pair of matrix dimensions (M,N) and each selected matrix
!> type, an M by N matrix A and an M by NRHS matrix C are generated.
!> The problem dimensions are as follows
!>    A:          M x N
!>    Q:          M x M
!>    P:          N x N
!>    B:          min(M,N) x min(M,N)
!>    C:          M x NRHS
!>
!> For each generated matrix, 4 tests are performed:
!>
!> (1)   | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
!>
!> (2)   | I - Q' Q | / ( M ulp )
!>
!> (3)   | I - PT PT' | / ( N ulp )
!>
!> (4)   | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C.
!>
!> The  are specified by a logical array DOTYPE( 1:NTYPES );
!> if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!> Currently, the list of possible types is:
!>
!> The possible matrix types are
!>
!> (1)  The zero matrix.
!> (2)  The identity matrix.
!>
!> (3)  A diagonal matrix with evenly spaced entries
!>      1, ..., ULP  and random signs.
!>      (ULP = (first number larger than 1) - 1 )
!> (4)  A diagonal matrix with geometrically spaced entries
!>      1, ..., ULP  and random signs.
!> (5)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>      and random signs.
!>
!> (6)  Same as (3), but multiplied by SQRT( overflow threshold )
!> (7)  Same as (3), but multiplied by SQRT( underflow threshold )
!>
!> (8)  A matrix of the form  U D V, where U and V are orthogonal and
!>      D has evenly spaced entries 1, ..., ULP with random signs
!>      on the diagonal.
!>
!> (9)  A matrix of the form  U D V, where U and V are orthogonal and
!>      D has geometrically spaced entries 1, ..., ULP with random
!>      signs on the diagonal.
!>
!> (10) A matrix of the form  U D V, where U and V are orthogonal and
!>      D has  entries 1, ULP,..., ULP with random
!>      signs on the diagonal.
!>
!> (11) Same as (8), but multiplied by SQRT( overflow threshold )
!> (12) Same as (8), but multiplied by SQRT( underflow threshold )
!>
!> (13) Rectangular matrix with random entries chosen from (-1,1).
!> (14) Same as (13), but multiplied by SQRT( overflow threshold )
!> (15) Same as (13), but multiplied by SQRT( underflow threshold )
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of values of M and N contained in the vectors
!>          MVAL and NVAL.  The matrix sizes are used in pairs (M,N).
!>          If NSIZES is zero, ZCHKBB does nothing.  NSIZES must be at
!>          least zero.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NSIZES)
!>          The values of the matrix row dimension M.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NSIZES)
!>          The values of the matrix column dimension N.
!>
[in]NWDTHS
!>          NWDTHS is INTEGER
!>          The number of bandwidths to use.  If it is zero,
!>          ZCHKBB does nothing.  It must be at least zero.
!>
[in]KK
!>          KK is INTEGER array, dimension (NWDTHS)
!>          An array containing the bandwidths to be used for the band
!>          matrices.  The values must be at least zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZCHKBB
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns in the  matrix C.
!>          If NRHS = 0, then the operations on the right-hand side will
!>          not be tested. NRHS must be at least 0.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZCHKBB to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension
!>                            (LDA, max(NN))
!>          Used to hold the matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least max( NN ).
!>
[out]AB
!>          AB is DOUBLE PRECISION array, dimension (LDAB, max(NN))
!>          Used to hold A in band storage format.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of AB.  It must be at least 2 (not 1!)
!>          and at least max( KK )+1.
!>
[out]BD
!>          BD is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the diagonal of the bidiagonal matrix computed
!>          by ZGBBRD.
!>
[out]BE
!>          BE is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the off-diagonal of the bidiagonal matrix
!>          computed by ZGBBRD.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ, max(NN))
!>          Used to hold the unitary matrix Q computed by ZGBBRD.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of Q.  It must be at least 1
!>          and at least max( NN ).
!>
[out]P
!>          P is COMPLEX*16 array, dimension (LDP, max(NN))
!>          Used to hold the unitary matrix P computed by ZGBBRD.
!>
[in]LDP
!>          LDP is INTEGER
!>          The leading dimension of P.  It must be at least 1
!>          and at least max( NN ).
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC, max(NN))
!>          Used to hold the matrix C updated by ZGBBRD.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of U.  It must be at least 1
!>          and at least max( NN ).
!>
[out]CC
!>          CC is COMPLEX*16 array, dimension (LDC, max(NN))
!>          Used to hold a copy of the matrix C.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          max( LDA+1, max(NN)+1 )*max(NN).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far.
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 357 of file zchkbb.f.

361*
362* -- LAPACK test routine (input) --
363* -- LAPACK is a software package provided by Univ. of Tennessee, --
364* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
365*
366* .. Scalar Arguments ..
367 INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT,
368 $ NRHS, NSIZES, NTYPES, NWDTHS
369 DOUBLE PRECISION THRESH
370* ..
371* .. Array Arguments ..
372 LOGICAL DOTYPE( * )
373 INTEGER ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * )
374 DOUBLE PRECISION BD( * ), BE( * ), RESULT( * ), RWORK( * )
375 COMPLEX*16 A( LDA, * ), AB( LDAB, * ), C( LDC, * ),
376 $ CC( LDC, * ), P( LDP, * ), Q( LDQ, * ),
377 $ WORK( * )
378* ..
379*
380* =====================================================================
381*
382* .. Parameters ..
383 COMPLEX*16 CZERO, CONE
384 parameter( czero = ( 0.0d+0, 0.0d+0 ),
385 $ cone = ( 1.0d+0, 0.0d+0 ) )
386 DOUBLE PRECISION ZERO, ONE
387 parameter( zero = 0.0d+0, one = 1.0d+0 )
388 INTEGER MAXTYP
389 parameter( maxtyp = 15 )
390* ..
391* .. Local Scalars ..
392 LOGICAL BADMM, BADNN, BADNNB
393 INTEGER I, IINFO, IMODE, ITYPE, J, JCOL, JR, JSIZE,
394 $ JTYPE, JWIDTH, K, KL, KMAX, KU, M, MMAX, MNMAX,
395 $ MNMIN, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
396 $ NTESTT
397 DOUBLE PRECISION AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, ULP,
398 $ ULPINV, UNFL
399* ..
400* .. Local Arrays ..
401 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
402 $ KMODE( MAXTYP ), KTYPE( MAXTYP )
403* ..
404* .. External Functions ..
405 DOUBLE PRECISION DLAMCH
406 EXTERNAL dlamch
407* ..
408* .. External Subroutines ..
409 EXTERNAL dlahd2, dlasum, xerbla, zbdt01, zbdt02, zgbbrd,
410 $ zlacpy, zlaset, zlatmr, zlatms, zunt01
411* ..
412* .. Intrinsic Functions ..
413 INTRINSIC abs, dble, max, min, sqrt
414* ..
415* .. Data statements ..
416 DATA ktype / 1, 2, 5*4, 5*6, 3*9 /
417 DATA kmagn / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3 /
418 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
419 $ 0, 0 /
420* ..
421* .. Executable Statements ..
422*
423* Check for errors
424*
425 ntestt = 0
426 info = 0
427*
428* Important constants
429*
430 badmm = .false.
431 badnn = .false.
432 mmax = 1
433 nmax = 1
434 mnmax = 1
435 DO 10 j = 1, nsizes
436 mmax = max( mmax, mval( j ) )
437 IF( mval( j ).LT.0 )
438 $ badmm = .true.
439 nmax = max( nmax, nval( j ) )
440 IF( nval( j ).LT.0 )
441 $ badnn = .true.
442 mnmax = max( mnmax, min( mval( j ), nval( j ) ) )
443 10 CONTINUE
444*
445 badnnb = .false.
446 kmax = 0
447 DO 20 j = 1, nwdths
448 kmax = max( kmax, kk( j ) )
449 IF( kk( j ).LT.0 )
450 $ badnnb = .true.
451 20 CONTINUE
452*
453* Check for errors
454*
455 IF( nsizes.LT.0 ) THEN
456 info = -1
457 ELSE IF( badmm ) THEN
458 info = -2
459 ELSE IF( badnn ) THEN
460 info = -3
461 ELSE IF( nwdths.LT.0 ) THEN
462 info = -4
463 ELSE IF( badnnb ) THEN
464 info = -5
465 ELSE IF( ntypes.LT.0 ) THEN
466 info = -6
467 ELSE IF( nrhs.LT.0 ) THEN
468 info = -8
469 ELSE IF( lda.LT.nmax ) THEN
470 info = -13
471 ELSE IF( ldab.LT.2*kmax+1 ) THEN
472 info = -15
473 ELSE IF( ldq.LT.nmax ) THEN
474 info = -19
475 ELSE IF( ldp.LT.nmax ) THEN
476 info = -21
477 ELSE IF( ldc.LT.nmax ) THEN
478 info = -23
479 ELSE IF( ( max( lda, nmax )+1 )*nmax.GT.lwork ) THEN
480 info = -26
481 END IF
482*
483 IF( info.NE.0 ) THEN
484 CALL xerbla( 'ZCHKBB', -info )
485 RETURN
486 END IF
487*
488* Quick return if possible
489*
490 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
491 $ RETURN
492*
493* More Important constants
494*
495 unfl = dlamch( 'Safe minimum' )
496 ovfl = one / unfl
497 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
498 ulpinv = one / ulp
499 rtunfl = sqrt( unfl )
500 rtovfl = sqrt( ovfl )
501*
502* Loop over sizes, widths, types
503*
504 nerrs = 0
505 nmats = 0
506*
507 DO 160 jsize = 1, nsizes
508 m = mval( jsize )
509 n = nval( jsize )
510 mnmin = min( m, n )
511 amninv = one / dble( max( 1, m, n ) )
512*
513 DO 150 jwidth = 1, nwdths
514 k = kk( jwidth )
515 IF( k.GE.m .AND. k.GE.n )
516 $ GO TO 150
517 kl = max( 0, min( m-1, k ) )
518 ku = max( 0, min( n-1, k ) )
519*
520 IF( nsizes.NE.1 ) THEN
521 mtypes = min( maxtyp, ntypes )
522 ELSE
523 mtypes = min( maxtyp+1, ntypes )
524 END IF
525*
526 DO 140 jtype = 1, mtypes
527 IF( .NOT.dotype( jtype ) )
528 $ GO TO 140
529 nmats = nmats + 1
530 ntest = 0
531*
532 DO 30 j = 1, 4
533 ioldsd( j ) = iseed( j )
534 30 CONTINUE
535*
536* Compute "A".
537*
538* Control parameters:
539*
540* KMAGN KMODE KTYPE
541* =1 O(1) clustered 1 zero
542* =2 large clustered 2 identity
543* =3 small exponential (none)
544* =4 arithmetic diagonal, (w/ singular values)
545* =5 random log (none)
546* =6 random nonhermitian, w/ singular values
547* =7 (none)
548* =8 (none)
549* =9 random nonhermitian
550*
551 IF( mtypes.GT.maxtyp )
552 $ GO TO 90
553*
554 itype = ktype( jtype )
555 imode = kmode( jtype )
556*
557* Compute norm
558*
559 GO TO ( 40, 50, 60 )kmagn( jtype )
560*
561 40 CONTINUE
562 anorm = one
563 GO TO 70
564*
565 50 CONTINUE
566 anorm = ( rtovfl*ulp )*amninv
567 GO TO 70
568*
569 60 CONTINUE
570 anorm = rtunfl*max( m, n )*ulpinv
571 GO TO 70
572*
573 70 CONTINUE
574*
575 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
576 CALL zlaset( 'Full', ldab, n, czero, czero, ab, ldab )
577 iinfo = 0
578 cond = ulpinv
579*
580* Special Matrices -- Identity & Jordan block
581*
582* Zero
583*
584 IF( itype.EQ.1 ) THEN
585 iinfo = 0
586*
587 ELSE IF( itype.EQ.2 ) THEN
588*
589* Identity
590*
591 DO 80 jcol = 1, n
592 a( jcol, jcol ) = anorm
593 80 CONTINUE
594*
595 ELSE IF( itype.EQ.4 ) THEN
596*
597* Diagonal Matrix, singular values specified
598*
599 CALL zlatms( m, n, 'S', iseed, 'N', rwork, imode,
600 $ cond, anorm, 0, 0, 'N', a, lda, work,
601 $ iinfo )
602*
603 ELSE IF( itype.EQ.6 ) THEN
604*
605* Nonhermitian, singular values specified
606*
607 CALL zlatms( m, n, 'S', iseed, 'N', rwork, imode,
608 $ cond, anorm, kl, ku, 'N', a, lda, work,
609 $ iinfo )
610*
611 ELSE IF( itype.EQ.9 ) THEN
612*
613* Nonhermitian, random entries
614*
615 CALL zlatmr( m, n, 'S', iseed, 'N', work, 6, one,
616 $ cone, 'T', 'N', work( n+1 ), 1, one,
617 $ work( 2*n+1 ), 1, one, 'N', idumma, kl,
618 $ ku, zero, anorm, 'N', a, lda, idumma,
619 $ iinfo )
620*
621 ELSE
622*
623 iinfo = 1
624 END IF
625*
626* Generate Right-Hand Side
627*
628 CALL zlatmr( m, nrhs, 'S', iseed, 'N', work, 6, one,
629 $ cone, 'T', 'N', work( m+1 ), 1, one,
630 $ work( 2*m+1 ), 1, one, 'N', idumma, m, nrhs,
631 $ zero, one, 'NO', c, ldc, idumma, iinfo )
632*
633 IF( iinfo.NE.0 ) THEN
634 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n,
635 $ jtype, ioldsd
636 info = abs( iinfo )
637 RETURN
638 END IF
639*
640 90 CONTINUE
641*
642* Copy A to band storage.
643*
644 DO 110 j = 1, n
645 DO 100 i = max( 1, j-ku ), min( m, j+kl )
646 ab( ku+1+i-j, j ) = a( i, j )
647 100 CONTINUE
648 110 CONTINUE
649*
650* Copy C
651*
652 CALL zlacpy( 'Full', m, nrhs, c, ldc, cc, ldc )
653*
654* Call ZGBBRD to compute B, Q and P, and to update C.
655*
656 CALL zgbbrd( 'B', m, n, nrhs, kl, ku, ab, ldab, bd, be,
657 $ q, ldq, p, ldp, cc, ldc, work, rwork,
658 $ iinfo )
659*
660 IF( iinfo.NE.0 ) THEN
661 WRITE( nounit, fmt = 9999 )'ZGBBRD', iinfo, n, jtype,
662 $ ioldsd
663 info = abs( iinfo )
664 IF( iinfo.LT.0 ) THEN
665 RETURN
666 ELSE
667 result( 1 ) = ulpinv
668 GO TO 120
669 END IF
670 END IF
671*
672* Test 1: Check the decomposition A := Q * B * P'
673* 2: Check the orthogonality of Q
674* 3: Check the orthogonality of P
675* 4: Check the computation of Q' * C
676*
677 CALL zbdt01( m, n, -1, a, lda, q, ldq, bd, be, p, ldp,
678 $ work, rwork, result( 1 ) )
679 CALL zunt01( 'Columns', m, m, q, ldq, work, lwork, rwork,
680 $ result( 2 ) )
681 CALL zunt01( 'Rows', n, n, p, ldp, work, lwork, rwork,
682 $ result( 3 ) )
683 CALL zbdt02( m, nrhs, c, ldc, cc, ldc, q, ldq, work,
684 $ rwork, result( 4 ) )
685*
686* End of Loop -- Check for RESULT(j) > THRESH
687*
688 ntest = 4
689 120 CONTINUE
690 ntestt = ntestt + ntest
691*
692* Print out tests which fail.
693*
694 DO 130 jr = 1, ntest
695 IF( result( jr ).GE.thresh ) THEN
696 IF( nerrs.EQ.0 )
697 $ CALL dlahd2( nounit, 'ZBB' )
698 nerrs = nerrs + 1
699 WRITE( nounit, fmt = 9998 )m, n, k, ioldsd, jtype,
700 $ jr, result( jr )
701 END IF
702 130 CONTINUE
703*
704 140 CONTINUE
705 150 CONTINUE
706 160 CONTINUE
707*
708* Summary
709*
710 CALL dlasum( 'ZBB', nounit, nerrs, ntestt )
711 RETURN
712*
713 9999 FORMAT( ' ZCHKBB: ', a, ' returned INFO=', i5, '.', / 9x, 'M=',
714 $ i5, ' N=', i5, ' K=', i5, ', JTYPE=', i5, ', ISEED=(',
715 $ 3( i5, ',' ), i5, ')' )
716 9998 FORMAT( ' M =', i4, ' N=', i4, ', K=', i3, ', seed=',
717 $ 4( i4, ',' ), ' type ', i2, ', test(', i2, ')=', g10.3 )
718*
719* End of ZCHKBB
720*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
zgbbrd
subroutine zgbbrd(vect, m, n, ncc, kl, ku, ab, ldab, d, e, q, ldq, pt, ldpt, c, ldc, work, rwork, info)
ZGBBRD
Definition zgbbrd.f:193
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
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
zbdt01
subroutine zbdt01(m, n, kd, a, lda, q, ldq, d, e, pt, ldpt, work, rwork, resid)
ZBDT01
Definition zbdt01.f:147
zbdt02
subroutine zbdt02(m, n, b, ldb, c, ldc, u, ldu, work, rwork, resid)
ZBDT02
Definition zbdt02.f:120
zunt01
subroutine zunt01(rowcol, m, n, u, ldu, work, lwork, rwork, resid)
ZUNT01
Definition zunt01.f:126
zlatmr
subroutine zlatmr(m, n, dist, iseed, sym, d, mode, cond, dmax, rsign, grade, dl, model, condl, dr, moder, condr, pivtng, ipivot, kl, ku, sparse, anorm, pack, a, lda, iwork, info)
ZLATMR
Definition zlatmr.f:490
zlatms
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
Definition zlatms.f:332
dlasum
subroutine dlasum(type, iounit, ie, nrun)
DLASUM
Definition dlasum.f:43
dlahd2
subroutine dlahd2(iounit, path)
DLAHD2
Definition dlahd2.f:65

◆ zchkbd()

subroutine zchkbd ( integer nsizes,
integer, dimension( * ) mval,
integer, dimension( * ) nval,
integer ntypes,
logical, dimension( * ) dotype,
integer nrhs,
integer, dimension( 4 ) iseed,
double precision thresh,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) bd,
double precision, dimension( * ) be,
double precision, dimension( * ) s1,
double precision, dimension( * ) s2,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldx, * ) y,
complex*16, dimension( ldx, * ) z,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldpt, * ) pt,
integer ldpt,
complex*16, dimension( ldpt, * ) u,
complex*16, dimension( ldpt, * ) vt,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer nout,
integer info )

ZCHKBD

Purpose:
!>
!> ZCHKBD checks the singular value decomposition (SVD) routines.
!>
!> ZGEBRD reduces a complex general m by n matrix A to real upper or
!> lower bidiagonal form by an orthogonal transformation: Q' * A * P = B
!> (or A = Q * B * P').  The matrix B is upper bidiagonal if m >= n
!> and lower bidiagonal if m < n.
!>
!> ZUNGBR generates the orthogonal matrices Q and P' from ZGEBRD.
!> Note that Q and P are not necessarily square.
!>
!> ZBDSQR computes the singular value decomposition of the bidiagonal
!> matrix B as B = U S V'.  It is called three times to compute
!>    1)  B = U S1 V', where S1 is the diagonal matrix of singular
!>        values and the columns of the matrices U and V are the left
!>        and right singular vectors, respectively, of B.
!>    2)  Same as 1), but the singular values are stored in S2 and the
!>        singular vectors are not computed.
!>    3)  A = (UQ) S (P'V'), the SVD of the original matrix A.
!> In addition, ZBDSQR has an option to apply the left orthogonal matrix
!> U to a matrix X, useful in least squares applications.
!>
!> For each pair of matrix dimensions (M,N) and each selected matrix
!> type, an M by N matrix A and an M by NRHS matrix X are generated.
!> The problem dimensions are as follows
!>    A:          M x N
!>    Q:          M x min(M,N) (but M x M if NRHS > 0)
!>    P:          min(M,N) x N
!>    B:          min(M,N) x min(M,N)
!>    U, V:       min(M,N) x min(M,N)
!>    S1, S2      diagonal, order min(M,N)
!>    X:          M x NRHS
!>
!> For each generated matrix, 14 tests are performed:
!>
!> Test ZGEBRD and ZUNGBR
!>
!> (1)   | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
!>
!> (2)   | I - Q' Q | / ( M ulp )
!>
!> (3)   | I - PT PT' | / ( N ulp )
!>
!> Test ZBDSQR on bidiagonal matrix B
!>
!> (4)   | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
!>
!> (5)   | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X
!>                                                  and   Z = U' Y.
!> (6)   | I - U' U | / ( min(M,N) ulp )
!>
!> (7)   | I - VT VT' | / ( min(M,N) ulp )
!>
!> (8)   S1 contains min(M,N) nonnegative values in decreasing order.
!>       (Return 0 if true, 1/ULP if false.)
!>
!> (9)   0 if the true singular values of B are within THRESH of
!>       those in S1.  2*THRESH if they are not.  (Tested using
!>       DSVDCH)
!>
!> (10)  | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
!>                                   computing U and V.
!>
!> Test ZBDSQR on matrix A
!>
!> (11)  | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp )
!>
!> (12)  | X - (QU) Z | / ( |X| max(M,k) ulp )
!>
!> (13)  | I - (QU)'(QU) | / ( M ulp )
!>
!> (14)  | I - (VT PT) (PT'VT') | / ( N ulp )
!>
!> The possible matrix types are
!>
!> (1)  The zero matrix.
!> (2)  The identity matrix.
!>
!> (3)  A diagonal matrix with evenly spaced entries
!>      1, ..., ULP  and random signs.
!>      (ULP = (first number larger than 1) - 1 )
!> (4)  A diagonal matrix with geometrically spaced entries
!>      1, ..., ULP  and random signs.
!> (5)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>      and random signs.
!>
!> (6)  Same as (3), but multiplied by SQRT( overflow threshold )
!> (7)  Same as (3), but multiplied by SQRT( underflow threshold )
!>
!> (8)  A matrix of the form  U D V, where U and V are orthogonal and
!>      D has evenly spaced entries 1, ..., ULP with random signs
!>      on the diagonal.
!>
!> (9)  A matrix of the form  U D V, where U and V are orthogonal and
!>      D has geometrically spaced entries 1, ..., ULP with random
!>      signs on the diagonal.
!>
!> (10) A matrix of the form  U D V, where U and V are orthogonal and
!>      D has  entries 1, ULP,..., ULP with random
!>      signs on the diagonal.
!>
!> (11) Same as (8), but multiplied by SQRT( overflow threshold )
!> (12) Same as (8), but multiplied by SQRT( underflow threshold )
!>
!> (13) Rectangular matrix with random entries chosen from (-1,1).
!> (14) Same as (13), but multiplied by SQRT( overflow threshold )
!> (15) Same as (13), but multiplied by SQRT( underflow threshold )
!>
!> Special case:
!> (16) A bidiagonal matrix with random entries chosen from a
!>      logarithmic distribution on [ulp^2,ulp^(-2)]  (I.e., each
!>      entry is  e^x, where x is chosen uniformly on
!>      [ 2 log(ulp), -2 log(ulp) ] .)  For *this* type:
!>      (a) ZGEBRD is not called to reduce it to bidiagonal form.
!>      (b) the bidiagonal is  min(M,N) x min(M,N); if M<N, the
!>          matrix will be lower bidiagonal, otherwise upper.
!>      (c) only tests 5--8 and 14 are performed.
!>
!> A subset of the full set of matrix types may be selected through
!> the logical array DOTYPE.
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of values of M and N contained in the vectors
!>          MVAL and NVAL.  The matrix sizes are used in pairs (M,N).
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NM)
!>          The values of the matrix column dimension N.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZCHKBD
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrices are in A and B.
!>          This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix
!>          of type j will be generated.  If NTYPES is smaller than the
!>          maximum number of types defined (PARAMETER MAXTYP), then
!>          types NTYPES+1 through MAXTYP will not be generated.  If
!>          NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through
!>          DOTYPE(NTYPES) will be ignored.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns in the  matrices X, Y,
!>          and Z, used in testing ZBDSQR.  If NRHS = 0, then the
!>          operations on the right-hand side will not be tested.
!>          NRHS must be at least 0.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The values of ISEED are changed on exit, and can be
!>          used in the next call to ZCHKBD to continue the same random
!>          number sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.  Note that the
!>          expected value of the test ratios is O(1), so THRESH should
!>          be a reasonably small multiple of 1, e.g., 10 or 100.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,NMAX)
!>          where NMAX is the maximum value of N in NVAL.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,MMAX),
!>          where MMAX is the maximum value of M in MVAL.
!>
[out]BD
!>          BD is DOUBLE PRECISION array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]BE
!>          BE is DOUBLE PRECISION array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]S1
!>          S1 is DOUBLE PRECISION array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]S2
!>          S2 is DOUBLE PRECISION array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the arrays X, Y, and Z.
!>          LDX >= max(1,MMAX).
!>
[out]Y
!>          Y is COMPLEX*16 array, dimension (LDX,NRHS)
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension (LDX,NRHS)
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,MMAX)
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,MMAX).
!>
[out]PT
!>          PT is COMPLEX*16 array, dimension (LDPT,NMAX)
!>
[in]LDPT
!>          LDPT is INTEGER
!>          The leading dimension of the arrays PT, U, and V.
!>          LDPT >= max(1, max(min(MVAL(j),NVAL(j)))).
!>
[out]U
!>          U is COMPLEX*16 array, dimension
!>                      (LDPT,max(min(MVAL(j),NVAL(j))))
!>
[out]VT
!>          VT is COMPLEX*16 array, dimension
!>                      (LDPT,max(min(MVAL(j),NVAL(j))))
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          3(M+N) and  M(M + max(M,N,k) + 1) + N*min(M,N)  for all
!>          pairs  (M,N)=(MM(j),NN(j))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (5*max(min(M,N)))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some MM(j) < 0
!>           -3: Some NN(j) < 0
!>           -4: NTYPES < 0
!>           -6: NRHS  < 0
!>           -8: THRESH < 0
!>          -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
!>          -17: LDB < 1 or LDB < MMAX.
!>          -21: LDQ < 1 or LDQ < MMAX.
!>          -23: LDP < 1 or LDP < MNMAX.
!>          -27: LWORK too small.
!>          If  ZLATMR, CLATMS, ZGEBRD, ZUNGBR, or ZBDSQR,
!>              returns an error code, the
!>              absolute value of it is returned.
!>
!>-----------------------------------------------------------------------
!>
!>     Some Local Variables and Parameters:
!>     ---- ----- --------- --- ----------
!>
!>     ZERO, ONE       Real 0 and 1.
!>     MAXTYP          The number of types defined.
!>     NTEST           The number of tests performed, or which can
!>                     be performed so far, for the current matrix.
!>     MMAX            Largest value in NN.
!>     NMAX            Largest value in NN.
!>     MNMIN           min(MM(j), NN(j)) (the dimension of the bidiagonal
!>                     matrix.)
!>     MNMAX           The maximum value of MNMIN for j=1,...,NSIZES.
!>     NFAIL           The number of tests which have exceeded THRESH
!>     COND, IMODE     Values to be passed to the matrix generators.
!>     ANORM           Norm of A; passed to matrix generators.
!>
!>     OVFL, UNFL      Overflow and underflow thresholds.
!>     RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>     ULP, ULPINV     Finest relative precision and its inverse.
!>
!>             The following four arrays decode JTYPE:
!>     KTYPE(j)        The general type (1-10) for type .
!>     KMODE(j)        The MODE value to be passed to the matrix
!>                     generator for type .
!>     KMAGN(j)        The order of magnitude ( O(1),
!>                     O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 411 of file zchkbd.f.

415*
416* -- LAPACK test routine --
417* -- LAPACK is a software package provided by Univ. of Tennessee, --
418* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
419*
420* .. Scalar Arguments ..
421 INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS,
422 $ NSIZES, NTYPES
423 DOUBLE PRECISION THRESH
424* ..
425* .. Array Arguments ..
426 LOGICAL DOTYPE( * )
427 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * )
428 DOUBLE PRECISION BD( * ), BE( * ), RWORK( * ), S1( * ), S2( * )
429 COMPLEX*16 A( LDA, * ), PT( LDPT, * ), Q( LDQ, * ),
430 $ U( LDPT, * ), VT( LDPT, * ), WORK( * ),
431 $ X( LDX, * ), Y( LDX, * ), Z( LDX, * )
432* ..
433*
434* ======================================================================
435*
436* .. Parameters ..
437 DOUBLE PRECISION ZERO, ONE, TWO, HALF
438 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
439 $ half = 0.5d0 )
440 COMPLEX*16 CZERO, CONE
441 parameter( czero = ( 0.0d+0, 0.0d+0 ),
442 $ cone = ( 1.0d+0, 0.0d+0 ) )
443 INTEGER MAXTYP
444 parameter( maxtyp = 16 )
445* ..
446* .. Local Scalars ..
447 LOGICAL BADMM, BADNN, BIDIAG
448 CHARACTER UPLO
449 CHARACTER*3 PATH
450 INTEGER I, IINFO, IMODE, ITYPE, J, JCOL, JSIZE, JTYPE,
451 $ LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN, MQ,
452 $ MTYPES, N, NFAIL, NMAX, NTEST
453 DOUBLE PRECISION AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
454 $ TEMP1, TEMP2, ULP, ULPINV, UNFL
455* ..
456* .. Local Arrays ..
457 INTEGER IOLDSD( 4 ), IWORK( 1 ), KMAGN( MAXTYP ),
458 $ KMODE( MAXTYP ), KTYPE( MAXTYP )
459 DOUBLE PRECISION DUMMA( 1 ), RESULT( 14 )
460* ..
461* .. External Functions ..
462 DOUBLE PRECISION DLAMCH, DLARND
463 EXTERNAL dlamch, dlarnd
464* ..
465* .. External Subroutines ..
466 EXTERNAL alasum, dcopy, dlabad, dlahd2, dsvdch, xerbla,
467 $ zbdsqr, zbdt01, zbdt02, zbdt03, zgebrd, zgemm,
468 $ zlacpy, zlaset, zlatmr, zlatms, zungbr, zunt01
469* ..
470* .. Intrinsic Functions ..
471 INTRINSIC abs, exp, int, log, max, min, sqrt
472* ..
473* .. Scalars in Common ..
474 LOGICAL LERR, OK
475 CHARACTER*32 SRNAMT
476 INTEGER INFOT, NUNIT
477* ..
478* .. Common blocks ..
479 COMMON / infoc / infot, nunit, ok, lerr
480 COMMON / srnamc / srnamt
481* ..
482* .. Data statements ..
483 DATA ktype / 1, 2, 5*4, 5*6, 3*9, 10 /
484 DATA kmagn / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 /
485 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
486 $ 0, 0, 0 /
487* ..
488* .. Executable Statements ..
489*
490* Check for errors
491*
492 info = 0
493*
494 badmm = .false.
495 badnn = .false.
496 mmax = 1
497 nmax = 1
498 mnmax = 1
499 minwrk = 1
500 DO 10 j = 1, nsizes
501 mmax = max( mmax, mval( j ) )
502 IF( mval( j ).LT.0 )
503 $ badmm = .true.
504 nmax = max( nmax, nval( j ) )
505 IF( nval( j ).LT.0 )
506 $ badnn = .true.
507 mnmax = max( mnmax, min( mval( j ), nval( j ) ) )
508 minwrk = max( minwrk, 3*( mval( j )+nval( j ) ),
509 $ mval( j )*( mval( j )+max( mval( j ), nval( j ),
510 $ nrhs )+1 )+nval( j )*min( nval( j ), mval( j ) ) )
511 10 CONTINUE
512*
513* Check for errors
514*
515 IF( nsizes.LT.0 ) THEN
516 info = -1
517 ELSE IF( badmm ) THEN
518 info = -2
519 ELSE IF( badnn ) THEN
520 info = -3
521 ELSE IF( ntypes.LT.0 ) THEN
522 info = -4
523 ELSE IF( nrhs.LT.0 ) THEN
524 info = -6
525 ELSE IF( lda.LT.mmax ) THEN
526 info = -11
527 ELSE IF( ldx.LT.mmax ) THEN
528 info = -17
529 ELSE IF( ldq.LT.mmax ) THEN
530 info = -21
531 ELSE IF( ldpt.LT.mnmax ) THEN
532 info = -23
533 ELSE IF( minwrk.GT.lwork ) THEN
534 info = -27
535 END IF
536*
537 IF( info.NE.0 ) THEN
538 CALL xerbla( 'ZCHKBD', -info )
539 RETURN
540 END IF
541*
542* Initialize constants
543*
544 path( 1: 1 ) = 'Zomplex precision'
545 path( 2: 3 ) = 'BD'
546 nfail = 0
547 ntest = 0
548 unfl = dlamch( 'Safe minimum' )
549 ovfl = dlamch( 'Overflow' )
550 CALL dlabad( unfl, ovfl )
551 ulp = dlamch( 'Precision' )
552 ulpinv = one / ulp
553 log2ui = int( log( ulpinv ) / log( two ) )
554 rtunfl = sqrt( unfl )
555 rtovfl = sqrt( ovfl )
556 infot = 0
557*
558* Loop over sizes, types
559*
560 DO 180 jsize = 1, nsizes
561 m = mval( jsize )
562 n = nval( jsize )
563 mnmin = min( m, n )
564 amninv = one / max( m, n, 1 )
565*
566 IF( nsizes.NE.1 ) THEN
567 mtypes = min( maxtyp, ntypes )
568 ELSE
569 mtypes = min( maxtyp+1, ntypes )
570 END IF
571*
572 DO 170 jtype = 1, mtypes
573 IF( .NOT.dotype( jtype ) )
574 $ GO TO 170
575*
576 DO 20 j = 1, 4
577 ioldsd( j ) = iseed( j )
578 20 CONTINUE
579*
580 DO 30 j = 1, 14
581 result( j ) = -one
582 30 CONTINUE
583*
584 uplo = ' '
585*
586* Compute "A"
587*
588* Control parameters:
589*
590* KMAGN KMODE KTYPE
591* =1 O(1) clustered 1 zero
592* =2 large clustered 2 identity
593* =3 small exponential (none)
594* =4 arithmetic diagonal, (w/ eigenvalues)
595* =5 random symmetric, w/ eigenvalues
596* =6 nonsymmetric, w/ singular values
597* =7 random diagonal
598* =8 random symmetric
599* =9 random nonsymmetric
600* =10 random bidiagonal (log. distrib.)
601*
602 IF( mtypes.GT.maxtyp )
603 $ GO TO 100
604*
605 itype = ktype( jtype )
606 imode = kmode( jtype )
607*
608* Compute norm
609*
610 GO TO ( 40, 50, 60 )kmagn( jtype )
611*
612 40 CONTINUE
613 anorm = one
614 GO TO 70
615*
616 50 CONTINUE
617 anorm = ( rtovfl*ulp )*amninv
618 GO TO 70
619*
620 60 CONTINUE
621 anorm = rtunfl*max( m, n )*ulpinv
622 GO TO 70
623*
624 70 CONTINUE
625*
626 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
627 iinfo = 0
628 cond = ulpinv
629*
630 bidiag = .false.
631 IF( itype.EQ.1 ) THEN
632*
633* Zero matrix
634*
635 iinfo = 0
636*
637 ELSE IF( itype.EQ.2 ) THEN
638*
639* Identity
640*
641 DO 80 jcol = 1, mnmin
642 a( jcol, jcol ) = anorm
643 80 CONTINUE
644*
645 ELSE IF( itype.EQ.4 ) THEN
646*
647* Diagonal Matrix, [Eigen]values Specified
648*
649 CALL zlatms( mnmin, mnmin, 'S', iseed, 'N', rwork, imode,
650 $ cond, anorm, 0, 0, 'N', a, lda, work,
651 $ iinfo )
652*
653 ELSE IF( itype.EQ.5 ) THEN
654*
655* Symmetric, eigenvalues specified
656*
657 CALL zlatms( mnmin, mnmin, 'S', iseed, 'S', rwork, imode,
658 $ cond, anorm, m, n, 'N', a, lda, work,
659 $ iinfo )
660*
661 ELSE IF( itype.EQ.6 ) THEN
662*
663* Nonsymmetric, singular values specified
664*
665 CALL zlatms( m, n, 'S', iseed, 'N', rwork, imode, cond,
666 $ anorm, m, n, 'N', a, lda, work, iinfo )
667*
668 ELSE IF( itype.EQ.7 ) THEN
669*
670* Diagonal, random entries
671*
672 CALL zlatmr( mnmin, mnmin, 'S', iseed, 'N', work, 6, one,
673 $ cone, 'T', 'N', work( mnmin+1 ), 1, one,
674 $ work( 2*mnmin+1 ), 1, one, 'N', iwork, 0, 0,
675 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
676*
677 ELSE IF( itype.EQ.8 ) THEN
678*
679* Symmetric, random entries
680*
681 CALL zlatmr( mnmin, mnmin, 'S', iseed, 'S', work, 6, one,
682 $ cone, 'T', 'N', work( mnmin+1 ), 1, one,
683 $ work( m+mnmin+1 ), 1, one, 'N', iwork, m, n,
684 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
685*
686 ELSE IF( itype.EQ.9 ) THEN
687*
688* Nonsymmetric, random entries
689*
690 CALL zlatmr( m, n, 'S', iseed, 'N', work, 6, one, cone,
691 $ 'T', 'N', work( mnmin+1 ), 1, one,
692 $ work( m+mnmin+1 ), 1, one, 'N', iwork, m, n,
693 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
694*
695 ELSE IF( itype.EQ.10 ) THEN
696*
697* Bidiagonal, random entries
698*
699 temp1 = -two*log( ulp )
700 DO 90 j = 1, mnmin
701 bd( j ) = exp( temp1*dlarnd( 2, iseed ) )
702 IF( j.LT.mnmin )
703 $ be( j ) = exp( temp1*dlarnd( 2, iseed ) )
704 90 CONTINUE
705*
706 iinfo = 0
707 bidiag = .true.
708 IF( m.GE.n ) THEN
709 uplo = 'U'
710 ELSE
711 uplo = 'L'
712 END IF
713 ELSE
714 iinfo = 1
715 END IF
716*
717 IF( iinfo.EQ.0 ) THEN
718*
719* Generate Right-Hand Side
720*
721 IF( bidiag ) THEN
722 CALL zlatmr( mnmin, nrhs, 'S', iseed, 'N', work, 6,
723 $ one, cone, 'T', 'N', work( mnmin+1 ), 1,
724 $ one, work( 2*mnmin+1 ), 1, one, 'N',
725 $ iwork, mnmin, nrhs, zero, one, 'NO', y,
726 $ ldx, iwork, iinfo )
727 ELSE
728 CALL zlatmr( m, nrhs, 'S', iseed, 'N', work, 6, one,
729 $ cone, 'T', 'N', work( m+1 ), 1, one,
730 $ work( 2*m+1 ), 1, one, 'N', iwork, m,
731 $ nrhs, zero, one, 'NO', x, ldx, iwork,
732 $ iinfo )
733 END IF
734 END IF
735*
736* Error Exit
737*
738 IF( iinfo.NE.0 ) THEN
739 WRITE( nout, fmt = 9998 )'Generator', iinfo, m, n,
740 $ jtype, ioldsd
741 info = abs( iinfo )
742 RETURN
743 END IF
744*
745 100 CONTINUE
746*
747* Call ZGEBRD and ZUNGBR to compute B, Q, and P, do tests.
748*
749 IF( .NOT.bidiag ) THEN
750*
751* Compute transformations to reduce A to bidiagonal form:
752* B := Q' * A * P.
753*
754 CALL zlacpy( ' ', m, n, a, lda, q, ldq )
755 CALL zgebrd( m, n, q, ldq, bd, be, work, work( mnmin+1 ),
756 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
757*
758* Check error code from ZGEBRD.
759*
760 IF( iinfo.NE.0 ) THEN
761 WRITE( nout, fmt = 9998 )'ZGEBRD', iinfo, m, n,
762 $ jtype, ioldsd
763 info = abs( iinfo )
764 RETURN
765 END IF
766*
767 CALL zlacpy( ' ', m, n, q, ldq, pt, ldpt )
768 IF( m.GE.n ) THEN
769 uplo = 'U'
770 ELSE
771 uplo = 'L'
772 END IF
773*
774* Generate Q
775*
776 mq = m
777 IF( nrhs.LE.0 )
778 $ mq = mnmin
779 CALL zungbr( 'Q', m, mq, n, q, ldq, work,
780 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
781*
782* Check error code from ZUNGBR.
783*
784 IF( iinfo.NE.0 ) THEN
785 WRITE( nout, fmt = 9998 )'ZUNGBR(Q)', iinfo, m, n,
786 $ jtype, ioldsd
787 info = abs( iinfo )
788 RETURN
789 END IF
790*
791* Generate P'
792*
793 CALL zungbr( 'P', mnmin, n, m, pt, ldpt, work( mnmin+1 ),
794 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
795*
796* Check error code from ZUNGBR.
797*
798 IF( iinfo.NE.0 ) THEN
799 WRITE( nout, fmt = 9998 )'ZUNGBR(P)', iinfo, m, n,
800 $ jtype, ioldsd
801 info = abs( iinfo )
802 RETURN
803 END IF
804*
805* Apply Q' to an M by NRHS matrix X: Y := Q' * X.
806*
807 CALL zgemm( 'Conjugate transpose', 'No transpose', m,
808 $ nrhs, m, cone, q, ldq, x, ldx, czero, y,
809 $ ldx )
810*
811* Test 1: Check the decomposition A := Q * B * PT
812* 2: Check the orthogonality of Q
813* 3: Check the orthogonality of PT
814*
815 CALL zbdt01( m, n, 1, a, lda, q, ldq, bd, be, pt, ldpt,
816 $ work, rwork, result( 1 ) )
817 CALL zunt01( 'Columns', m, mq, q, ldq, work, lwork,
818 $ rwork, result( 2 ) )
819 CALL zunt01( 'Rows', mnmin, n, pt, ldpt, work, lwork,
820 $ rwork, result( 3 ) )
821 END IF
822*
823* Use ZBDSQR to form the SVD of the bidiagonal matrix B:
824* B := U * S1 * VT, and compute Z = U' * Y.
825*
826 CALL dcopy( mnmin, bd, 1, s1, 1 )
827 IF( mnmin.GT.0 )
828 $ CALL dcopy( mnmin-1, be, 1, rwork, 1 )
829 CALL zlacpy( ' ', m, nrhs, y, ldx, z, ldx )
830 CALL zlaset( 'Full', mnmin, mnmin, czero, cone, u, ldpt )
831 CALL zlaset( 'Full', mnmin, mnmin, czero, cone, vt, ldpt )
832*
833 CALL zbdsqr( uplo, mnmin, mnmin, mnmin, nrhs, s1, rwork, vt,
834 $ ldpt, u, ldpt, z, ldx, rwork( mnmin+1 ),
835 $ iinfo )
836*
837* Check error code from ZBDSQR.
838*
839 IF( iinfo.NE.0 ) THEN
840 WRITE( nout, fmt = 9998 )'ZBDSQR(vects)', iinfo, m, n,
841 $ jtype, ioldsd
842 info = abs( iinfo )
843 IF( iinfo.LT.0 ) THEN
844 RETURN
845 ELSE
846 result( 4 ) = ulpinv
847 GO TO 150
848 END IF
849 END IF
850*
851* Use ZBDSQR to compute only the singular values of the
852* bidiagonal matrix B; U, VT, and Z should not be modified.
853*
854 CALL dcopy( mnmin, bd, 1, s2, 1 )
855 IF( mnmin.GT.0 )
856 $ CALL dcopy( mnmin-1, be, 1, rwork, 1 )
857*
858 CALL zbdsqr( uplo, mnmin, 0, 0, 0, s2, rwork, vt, ldpt, u,
859 $ ldpt, z, ldx, rwork( mnmin+1 ), iinfo )
860*
861* Check error code from ZBDSQR.
862*
863 IF( iinfo.NE.0 ) THEN
864 WRITE( nout, fmt = 9998 )'ZBDSQR(values)', iinfo, m, n,
865 $ jtype, ioldsd
866 info = abs( iinfo )
867 IF( iinfo.LT.0 ) THEN
868 RETURN
869 ELSE
870 result( 9 ) = ulpinv
871 GO TO 150
872 END IF
873 END IF
874*
875* Test 4: Check the decomposition B := U * S1 * VT
876* 5: Check the computation Z := U' * Y
877* 6: Check the orthogonality of U
878* 7: Check the orthogonality of VT
879*
880 CALL zbdt03( uplo, mnmin, 1, bd, be, u, ldpt, s1, vt, ldpt,
881 $ work, result( 4 ) )
882 CALL zbdt02( mnmin, nrhs, y, ldx, z, ldx, u, ldpt, work,
883 $ rwork, result( 5 ) )
884 CALL zunt01( 'Columns', mnmin, mnmin, u, ldpt, work, lwork,
885 $ rwork, result( 6 ) )
886 CALL zunt01( 'Rows', mnmin, mnmin, vt, ldpt, work, lwork,
887 $ rwork, result( 7 ) )
888*
889* Test 8: Check that the singular values are sorted in
890* non-increasing order and are non-negative
891*
892 result( 8 ) = zero
893 DO 110 i = 1, mnmin - 1
894 IF( s1( i ).LT.s1( i+1 ) )
895 $ result( 8 ) = ulpinv
896 IF( s1( i ).LT.zero )
897 $ result( 8 ) = ulpinv
898 110 CONTINUE
899 IF( mnmin.GE.1 ) THEN
900 IF( s1( mnmin ).LT.zero )
901 $ result( 8 ) = ulpinv
902 END IF
903*
904* Test 9: Compare ZBDSQR with and without singular vectors
905*
906 temp2 = zero
907*
908 DO 120 j = 1, mnmin
909 temp1 = abs( s1( j )-s2( j ) ) /
910 $ max( sqrt( unfl )*max( s1( 1 ), one ),
911 $ ulp*max( abs( s1( j ) ), abs( s2( j ) ) ) )
912 temp2 = max( temp1, temp2 )
913 120 CONTINUE
914*
915 result( 9 ) = temp2
916*
917* Test 10: Sturm sequence test of singular values
918* Go up by factors of two until it succeeds
919*
920 temp1 = thresh*( half-ulp )
921*
922 DO 130 j = 0, log2ui
923 CALL dsvdch( mnmin, bd, be, s1, temp1, iinfo )
924 IF( iinfo.EQ.0 )
925 $ GO TO 140
926 temp1 = temp1*two
927 130 CONTINUE
928*
929 140 CONTINUE
930 result( 10 ) = temp1
931*
932* Use ZBDSQR to form the decomposition A := (QU) S (VT PT)
933* from the bidiagonal form A := Q B PT.
934*
935 IF( .NOT.bidiag ) THEN
936 CALL dcopy( mnmin, bd, 1, s2, 1 )
937 IF( mnmin.GT.0 )
938 $ CALL dcopy( mnmin-1, be, 1, rwork, 1 )
939*
940 CALL zbdsqr( uplo, mnmin, n, m, nrhs, s2, rwork, pt,
941 $ ldpt, q, ldq, y, ldx, rwork( mnmin+1 ),
942 $ iinfo )
943*
944* Test 11: Check the decomposition A := Q*U * S2 * VT*PT
945* 12: Check the computation Z := U' * Q' * X
946* 13: Check the orthogonality of Q*U
947* 14: Check the orthogonality of VT*PT
948*
949 CALL zbdt01( m, n, 0, a, lda, q, ldq, s2, dumma, pt,
950 $ ldpt, work, rwork, result( 11 ) )
951 CALL zbdt02( m, nrhs, x, ldx, y, ldx, q, ldq, work,
952 $ rwork, result( 12 ) )
953 CALL zunt01( 'Columns', m, mq, q, ldq, work, lwork,
954 $ rwork, result( 13 ) )
955 CALL zunt01( 'Rows', mnmin, n, pt, ldpt, work, lwork,
956 $ rwork, result( 14 ) )
957 END IF
958*
959* End of Loop -- Check for RESULT(j) > THRESH
960*
961 150 CONTINUE
962 DO 160 j = 1, 14
963 IF( result( j ).GE.thresh ) THEN
964 IF( nfail.EQ.0 )
965 $ CALL dlahd2( nout, path )
966 WRITE( nout, fmt = 9999 )m, n, jtype, ioldsd, j,
967 $ result( j )
968 nfail = nfail + 1
969 END IF
970 160 CONTINUE
971 IF( .NOT.bidiag ) THEN
972 ntest = ntest + 14
973 ELSE
974 ntest = ntest + 5
975 END IF
976*
977 170 CONTINUE
978 180 CONTINUE
979*
980* Summary
981*
982 CALL alasum( path, nout, nfail, ntest, 0 )
983*
984 RETURN
985*
986* End of ZCHKBD
987*
988 9999 FORMAT( ' M=', i5, ', N=', i5, ', type ', i2, ', seed=',
989 $ 4( i4, ',' ), ' test(', i2, ')=', g11.4 )
990 9998 FORMAT( ' ZCHKBD: ', a, ' returned INFO=', i6, '.', / 9x, 'M=',
991 $ i6, ', N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ),
992 $ i5, ')' )
993*
dlabad
subroutine dlabad(small, large)
DLABAD
Definition dlabad.f:74
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
zungbr
subroutine zungbr(vect, m, n, k, a, lda, tau, work, lwork, info)
ZUNGBR
Definition zungbr.f:157
zgebrd
subroutine zgebrd(m, n, a, lda, d, e, tauq, taup, work, lwork, info)
ZGEBRD
Definition zgebrd.f:205
zbdsqr
subroutine zbdsqr(uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, rwork, info)
ZBDSQR
Definition zbdsqr.f:222
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187
zbdt03
subroutine zbdt03(uplo, n, kd, d, e, u, ldu, s, vt, ldvt, work, resid)
ZBDT03
Definition zbdt03.f:135
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82
dsvdch
subroutine dsvdch(n, s, e, svd, tol, info)
DSVDCH
Definition dsvdch.f:97
dlarnd
double precision function dlarnd(idist, iseed)
DLARND
Definition dlarnd.f:73

◆ zchkbk()

subroutine zchkbk ( integer nin,
integer nout )

ZCHKBK

Purpose:
!>
!> ZCHKBK tests ZGEBAK, a routine for backward transformation of
!> the computed right or left eigenvectors if the original matrix
!> was preprocessed by balance subroutine ZGEBAL.
!>
Parameters
[in]NIN
!>          NIN is INTEGER
!>          The logical unit number for input.  NIN > 0.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The logical unit number for output.  NOUT > 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zchkbk.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 INTEGER NIN, NOUT
62* ..
63*
64* ======================================================================
65*
66* .. Parameters ..
67 INTEGER LDE
68 parameter( lde = 20 )
69 DOUBLE PRECISION ZERO
70 parameter( zero = 0.0d0 )
71* ..
72* .. Local Scalars ..
73 INTEGER I, IHI, ILO, INFO, J, KNT, N, NINFO
74 DOUBLE PRECISION EPS, RMAX, SAFMIN, VMAX, X
75 COMPLEX*16 CDUM
76* ..
77* .. Local Arrays ..
78 INTEGER LMAX( 2 )
79 DOUBLE PRECISION SCALE( LDE )
80 COMPLEX*16 E( LDE, LDE ), EIN( LDE, LDE )
81* ..
82* .. External Functions ..
83 DOUBLE PRECISION DLAMCH
84 EXTERNAL dlamch
85* ..
86* .. External Subroutines ..
87 EXTERNAL zgebak
88* ..
89* .. Intrinsic Functions ..
90 INTRINSIC abs, dble, dimag, max
91* ..
92* .. Statement Functions ..
93 DOUBLE PRECISION CABS1
94* ..
95* .. Statement Function definitions ..
96 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
97* ..
98* .. Executable Statements ..
99*
100 lmax( 1 ) = 0
101 lmax( 2 ) = 0
102 ninfo = 0
103 knt = 0
104 rmax = zero
105 eps = dlamch( 'E' )
106 safmin = dlamch( 'S' )
107*
108 10 CONTINUE
109*
110 READ( nin, fmt = * )n, ilo, ihi
111 IF( n.EQ.0 )
112 $ GO TO 60
113*
114 READ( nin, fmt = * )( scale( i ), i = 1, n )
115 DO 20 i = 1, n
116 READ( nin, fmt = * )( e( i, j ), j = 1, n )
117 20 CONTINUE
118*
119 DO 30 i = 1, n
120 READ( nin, fmt = * )( ein( i, j ), j = 1, n )
121 30 CONTINUE
122*
123 knt = knt + 1
124 CALL zgebak( 'B', 'R', n, ilo, ihi, scale, n, e, lde, info )
125*
126 IF( info.NE.0 ) THEN
127 ninfo = ninfo + 1
128 lmax( 1 ) = knt
129 END IF
130*
131 vmax = zero
132 DO 50 i = 1, n
133 DO 40 j = 1, n
134 x = cabs1( e( i, j )-ein( i, j ) ) / eps
135 IF( cabs1( e( i, j ) ).GT.safmin )
136 $ x = x / cabs1( e( i, j ) )
137 vmax = max( vmax, x )
138 40 CONTINUE
139 50 CONTINUE
140*
141 IF( vmax.GT.rmax ) THEN
142 lmax( 2 ) = knt
143 rmax = vmax
144 END IF
145*
146 GO TO 10
147*
148 60 CONTINUE
149*
150 WRITE( nout, fmt = 9999 )
151 9999 FORMAT( 1x, '.. test output of ZGEBAK .. ' )
152*
153 WRITE( nout, fmt = 9998 )rmax
154 9998 FORMAT( 1x, 'value of largest test error = ', d12.3 )
155 WRITE( nout, fmt = 9997 )lmax( 1 )
156 9997 FORMAT( 1x, 'example number where info is not zero = ', i4 )
157 WRITE( nout, fmt = 9996 )lmax( 2 )
158 9996 FORMAT( 1x, 'example number having largest error = ', i4 )
159 WRITE( nout, fmt = 9995 )ninfo
160 9995 FORMAT( 1x, 'number of examples where info is not 0 = ', i4 )
161 WRITE( nout, fmt = 9994 )knt
162 9994 FORMAT( 1x, 'total number of examples tested = ', i4 )
163*
164 RETURN
165*
166* End of ZCHKBK
167*
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2942
zgebak
subroutine zgebak(job, side, n, ilo, ihi, scale, m, v, ldv, info)
ZGEBAK
Definition zgebak.f:131

◆ zchkbl()

subroutine zchkbl ( integer nin,
integer nout )

ZCHKBL

Purpose:
!>
!> ZCHKBL tests ZGEBAL, a routine for balancing a general complex
!> matrix and isolating some of its eigenvalues.
!>
Parameters
[in]NIN
!>          NIN is INTEGER
!>          The logical unit number for input.  NIN > 0.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The logical unit number for output.  NOUT > 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 53 of file zchkbl.f.

54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 INTEGER NIN, NOUT
61* ..
62*
63* ======================================================================
64*
65* .. Parameters ..
66 INTEGER LDA
67 parameter( lda = 20 )
68 DOUBLE PRECISION ZERO
69 parameter( zero = 0.0d+0 )
70* ..
71* .. Local Scalars ..
72 INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
73 $ NINFO
74 DOUBLE PRECISION ANORM, MEPS, RMAX, SFMIN, TEMP, VMAX
75 COMPLEX*16 CDUM
76* ..
77* .. Local Arrays ..
78 INTEGER LMAX( 3 )
79 DOUBLE PRECISION DUMMY( 1 ), SCALE( LDA ), SCALIN( LDA )
80 COMPLEX*16 A( LDA, LDA ), AIN( LDA, LDA )
81* ..
82* .. External Functions ..
83 DOUBLE PRECISION DLAMCH, ZLANGE
84 EXTERNAL dlamch, zlange
85* ..
86* .. External Subroutines ..
87 EXTERNAL zgebal
88* ..
89* .. Intrinsic Functions ..
90 INTRINSIC abs, dble, dimag, max
91* ..
92* .. Statement Functions ..
93 DOUBLE PRECISION CABS1
94* ..
95* .. Statement Function definitions ..
96 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
97* ..
98* .. Executable Statements ..
99*
100 lmax( 1 ) = 0
101 lmax( 2 ) = 0
102 lmax( 3 ) = 0
103 ninfo = 0
104 knt = 0
105 rmax = zero
106 vmax = zero
107 sfmin = dlamch( 'S' )
108 meps = dlamch( 'E' )
109*
110 10 CONTINUE
111*
112 READ( nin, fmt = * )n
113 IF( n.EQ.0 )
114 $ GO TO 70
115 DO 20 i = 1, n
116 READ( nin, fmt = * )( a( i, j ), j = 1, n )
117 20 CONTINUE
118*
119 READ( nin, fmt = * )iloin, ihiin
120 DO 30 i = 1, n
121 READ( nin, fmt = * )( ain( i, j ), j = 1, n )
122 30 CONTINUE
123 READ( nin, fmt = * )( scalin( i ), i = 1, n )
124*
125 anorm = zlange( 'M', n, n, a, lda, dummy )
126 knt = knt + 1
127 CALL zgebal( 'B', n, a, lda, ilo, ihi, scale, info )
128*
129 IF( info.NE.0 ) THEN
130 ninfo = ninfo + 1
131 lmax( 1 ) = knt
132 END IF
133*
134 IF( ilo.NE.iloin .OR. ihi.NE.ihiin ) THEN
135 ninfo = ninfo + 1
136 lmax( 2 ) = knt
137 END IF
138*
139 DO 50 i = 1, n
140 DO 40 j = 1, n
141 temp = max( cabs1( a( i, j ) ), cabs1( ain( i, j ) ) )
142 temp = max( temp, sfmin )
143 vmax = max( vmax, cabs1( a( i, j )-ain( i, j ) ) / temp )
144 40 CONTINUE
145 50 CONTINUE
146*
147 DO 60 i = 1, n
148 temp = max( scale( i ), scalin( i ) )
149 temp = max( temp, sfmin )
150 vmax = max( vmax, abs( scale( i )-scalin( i ) ) / temp )
151 60 CONTINUE
152*
153 IF( vmax.GT.rmax ) THEN
154 lmax( 3 ) = knt
155 rmax = vmax
156 END IF
157*
158 GO TO 10
159*
160 70 CONTINUE
161*
162 WRITE( nout, fmt = 9999 )
163 9999 FORMAT( 1x, '.. test output of ZGEBAL .. ' )
164*
165 WRITE( nout, fmt = 9998 )rmax
166 9998 FORMAT( 1x, 'value of largest test error = ', d12.3 )
167 WRITE( nout, fmt = 9997 )lmax( 1 )
168 9997 FORMAT( 1x, 'example number where info is not zero = ', i4 )
169 WRITE( nout, fmt = 9996 )lmax( 2 )
170 9996 FORMAT( 1x, 'example number where ILO or IHI wrong = ', i4 )
171 WRITE( nout, fmt = 9995 )lmax( 3 )
172 9995 FORMAT( 1x, 'example number having largest error = ', i4 )
173 WRITE( nout, fmt = 9994 )ninfo
174 9994 FORMAT( 1x, 'number of examples where info is not 0 = ', i4 )
175 WRITE( nout, fmt = 9993 )knt
176 9993 FORMAT( 1x, 'total number of examples tested = ', i4 )
177*
178 RETURN
179*
180* End of ZCHKBL
181*
zgebal
subroutine zgebal(job, n, a, lda, ilo, ihi, scale, info)
ZGEBAL
Definition zgebal.f:162

◆ zchkec()

subroutine zchkec ( double precision thresh,
logical tsterr,
integer nin,
integer nout )

ZCHKEC

Purpose:
!>
!> ZCHKEC tests eigen- condition estimation routines
!>        ZTRSYL, CTREXC, CTRSNA, CTRSEN
!>
!> In all cases, the routine runs through a fixed set of numerical
!> examples, subjects them to various tests, and compares the test
!> results to a threshold THRESH. In addition, ZTRSNA and CTRSEN are
!> tested by reading in precomputed examples from a file (on input unit
!> NIN).  Output is written to output unit NOUT.
!>
Parameters
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          Threshold for residual tests.  A computed test ratio passes
!>          the threshold if it is less than THRESH.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NIN
!>          NIN is INTEGER
!>          The logical unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The logical unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 74 of file zchkec.f.

75*
76* -- LAPACK test routine --
77* -- LAPACK is a software package provided by Univ. of Tennessee, --
78* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
79*
80* .. Scalar Arguments ..
81 LOGICAL TSTERR
82 INTEGER NIN, NOUT
83 DOUBLE PRECISION THRESH
84* ..
85*
86* =====================================================================
87*
88* .. Local Scalars ..
89 LOGICAL OK
90 CHARACTER*3 PATH
91 INTEGER KTREXC, KTRSEN, KTRSNA, KTRSYL, LTREXC, LTRSYL,
92 $ NTESTS, NTREXC, NTRSYL
93 DOUBLE PRECISION EPS, RTREXC, RTRSYL, SFMIN
94* ..
95* .. Local Arrays ..
96 INTEGER LTRSEN( 3 ), LTRSNA( 3 ), NTRSEN( 3 ),
97 $ NTRSNA( 3 )
98 DOUBLE PRECISION RTRSEN( 3 ), RTRSNA( 3 )
99* ..
100* .. External Subroutines ..
101 EXTERNAL zerrec, zget35, zget36, zget37, zget38
102* ..
103* .. External Functions ..
104 DOUBLE PRECISION DLAMCH
105 EXTERNAL dlamch
106* ..
107* .. Executable Statements ..
108*
109 path( 1: 1 ) = 'Zomplex precision'
110 path( 2: 3 ) = 'EC'
111 eps = dlamch( 'P' )
112 sfmin = dlamch( 'S' )
113 WRITE( nout, fmt = 9994 )
114 WRITE( nout, fmt = 9993 )eps, sfmin
115 WRITE( nout, fmt = 9992 )thresh
116*
117* Test error exits if TSTERR is .TRUE.
118*
119 IF( tsterr )
120 $ CALL zerrec( path, nout )
121*
122 ok = .true.
123 CALL zget35( rtrsyl, ltrsyl, ntrsyl, ktrsyl, nin )
124 IF( rtrsyl.GT.thresh ) THEN
125 ok = .false.
126 WRITE( nout, fmt = 9999 )rtrsyl, ltrsyl, ntrsyl, ktrsyl
127 END IF
128*
129 CALL zget36( rtrexc, ltrexc, ntrexc, ktrexc, nin )
130 IF( rtrexc.GT.thresh .OR. ntrexc.GT.0 ) THEN
131 ok = .false.
132 WRITE( nout, fmt = 9998 )rtrexc, ltrexc, ntrexc, ktrexc
133 END IF
134*
135 CALL zget37( rtrsna, ltrsna, ntrsna, ktrsna, nin )
136 IF( rtrsna( 1 ).GT.thresh .OR. rtrsna( 2 ).GT.thresh .OR.
137 $ ntrsna( 1 ).NE.0 .OR. ntrsna( 2 ).NE.0 .OR. ntrsna( 3 ).NE.0 )
138 $ THEN
139 ok = .false.
140 WRITE( nout, fmt = 9997 )rtrsna, ltrsna, ntrsna, ktrsna
141 END IF
142*
143 CALL zget38( rtrsen, ltrsen, ntrsen, ktrsen, nin )
144 IF( rtrsen( 1 ).GT.thresh .OR. rtrsen( 2 ).GT.thresh .OR.
145 $ ntrsen( 1 ).NE.0 .OR. ntrsen( 2 ).NE.0 .OR. ntrsen( 3 ).NE.0 )
146 $ THEN
147 ok = .false.
148 WRITE( nout, fmt = 9996 )rtrsen, ltrsen, ntrsen, ktrsen
149 END IF
150*
151 ntests = ktrsyl + ktrexc + ktrsna + ktrsen
152 IF( ok )
153 $ WRITE( nout, fmt = 9995 )path, ntests
154*
155 9999 FORMAT( ' Error in ZTRSYL: RMAX =', d12.3, / ' LMAX = ', i8,
156 $ ' NINFO=', i8, ' KNT=', i8 )
157 9998 FORMAT( ' Error in ZTREXC: RMAX =', d12.3, / ' LMAX = ', i8,
158 $ ' NINFO=', i8, ' KNT=', i8 )
159 9997 FORMAT( ' Error in ZTRSNA: RMAX =', 3d12.3, / ' LMAX = ', 3i8,
160 $ ' NINFO=', 3i8, ' KNT=', i8 )
161 9996 FORMAT( ' Error in ZTRSEN: RMAX =', 3d12.3, / ' LMAX = ', 3i8,
162 $ ' NINFO=', 3i8, ' KNT=', i8 )
163 9995 FORMAT( / 1x, 'All tests for ', a3,
164 $ ' routines passed the threshold ( ', i6, ' tests run)' )
165 9994 FORMAT( ' Tests of the Nonsymmetric eigenproblem condition',
166 $ ' estimation routines', / ' ZTRSYL, ZTREXC, ZTRSNA, ZTRSEN',
167 $ / )
168 9993 FORMAT( ' Relative machine precision (EPS) = ', d16.6,
169 $ / ' Safe minimum (SFMIN) = ', d16.6, / )
170 9992 FORMAT( ' Routines pass computational tests if test ratio is ',
171 $ 'less than', f8.2, / / )
172 RETURN
173*
174* End of ZCHKEC
175*
zget37
subroutine zget37(rmax, lmax, ninfo, knt, nin)
ZGET37
Definition zget37.f:90
zerrec
subroutine zerrec(path, nunit)
ZERREC
Definition zerrec.f:56
zget38
subroutine zget38(rmax, lmax, ninfo, knt, nin)
ZGET38
Definition zget38.f:91
zget35
subroutine zget35(rmax, lmax, ninfo, knt, nin)
ZGET35
Definition zget35.f:84
zget36
subroutine zget36(rmax, lmax, ninfo, knt, nin)
ZGET36
Definition zget36.f:85

◆ zchkee()

program zchkee

ZCHKEE

Purpose:
!>
!> ZCHKEE tests the COMPLEX*16 LAPACK subroutines for the matrix
!> eigenvalue problem.  The test paths in this version are
!>
!> NEP (Nonsymmetric Eigenvalue Problem):
!>     Test ZGEHRD, ZUNGHR, ZHSEQR, ZTREVC, ZHSEIN, and ZUNMHR
!>
!> SEP (Hermitian Eigenvalue Problem):
!>     Test ZHETRD, ZUNGTR, ZSTEQR, ZSTERF, ZSTEIN, ZSTEDC,
!>     and drivers ZHEEV(X), ZHBEV(X), ZHPEV(X),
!>                 ZHEEVD,   ZHBEVD,   ZHPEVD
!>
!> SVD (Singular Value Decomposition):
!>     Test ZGEBRD, ZUNGBR, and ZBDSQR
!>     and the drivers ZGESVD, ZGESDD
!>
!> ZEV (Nonsymmetric Eigenvalue/eigenvector Driver):
!>     Test ZGEEV
!>
!> ZES (Nonsymmetric Schur form Driver):
!>     Test ZGEES
!>
!> ZVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver):
!>     Test ZGEEVX
!>
!> ZSX (Nonsymmetric Schur form Expert Driver):
!>     Test ZGEESX
!>
!> ZGG (Generalized Nonsymmetric Eigenvalue Problem):
!>     Test ZGGHD3, ZGGBAL, ZGGBAK, ZHGEQZ, and ZTGEVC
!>
!> ZGS (Generalized Nonsymmetric Schur form Driver):
!>     Test ZGGES
!>
!> ZGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver):
!>     Test ZGGEV
!>
!> ZGX (Generalized Nonsymmetric Schur form Expert Driver):
!>     Test ZGGESX
!>
!> ZXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver):
!>     Test ZGGEVX
!>
!> ZSG (Hermitian Generalized Eigenvalue Problem):
!>     Test ZHEGST, ZHEGV, ZHEGVD, ZHEGVX, ZHPGST, ZHPGV, ZHPGVD,
!>     ZHPGVX, ZHBGST, ZHBGV, ZHBGVD, and ZHBGVX
!>
!> ZHB (Hermitian Band Eigenvalue Problem):
!>     Test ZHBTRD
!>
!> ZBB (Band Singular Value Decomposition):
!>     Test ZGBBRD
!>
!> ZEC (Eigencondition estimation):
!>     Test ZTRSYL, ZTREXC, ZTRSNA, and ZTRSEN
!>
!> ZBL (Balancing a general matrix)
!>     Test ZGEBAL
!>
!> ZBK (Back transformation on a balanced matrix)
!>     Test ZGEBAK
!>
!> ZGL (Balancing a matrix pair)
!>     Test ZGGBAL
!>
!> ZGK (Back transformation on a matrix pair)
!>     Test ZGGBAK
!>
!> GLM (Generalized Linear Regression Model):
!>     Tests ZGGGLM
!>
!> GQR (Generalized QR and RQ factorizations):
!>     Tests ZGGQRF and ZGGRQF
!>
!> GSV (Generalized Singular Value Decomposition):
!>     Tests ZGGSVD, ZGGSVP, ZTGSJA, ZLAGS2, ZLAPLL, and ZLAPMT
!>
!> CSD (CS decomposition):
!>     Tests ZUNCSD
!>
!> LSE (Constrained Linear Least Squares):
!>     Tests ZGGLSE
!>
!> Each test path has a different set of inputs, but the data sets for
!> the driver routines xEV, xES, xVX, and xSX can be concatenated in a
!> single input file.  The first line of input should contain one of the
!> 3-character path names in columns 1-3.  The number of remaining lines
!> depends on what is found on the first line.
!>
!> The number of matrix types used in testing is often controllable from
!> the input file.  The number of matrix types for each path, and the
!> test routine that describes them, is as follows:
!>
!> Path name(s)  Types    Test routine
!>
!> ZHS or NEP      21     ZCHKHS
!> ZST or SEP      21     ZCHKST (routines)
!>                 18     ZDRVST (drivers)
!> ZBD or SVD      16     ZCHKBD (routines)
!>                  5     ZDRVBD (drivers)
!> ZEV             21     ZDRVEV
!> ZES             21     ZDRVES
!> ZVX             21     ZDRVVX
!> ZSX             21     ZDRVSX
!> ZGG             26     ZCHKGG (routines)
!> ZGS             26     ZDRGES
!> ZGX              5     ZDRGSX
!> ZGV             26     ZDRGEV
!> ZXV              2     ZDRGVX
!> ZSG             21     ZDRVSG
!> ZHB             15     ZCHKHB
!> ZBB             15     ZCHKBB
!> ZEC              -     ZCHKEC
!> ZBL              -     ZCHKBL
!> ZBK              -     ZCHKBK
!> ZGL              -     ZCHKGL
!> ZGK              -     ZCHKGK
!> GLM              8     ZCKGLM
!> GQR              8     ZCKGQR
!> GSV              8     ZCKGSV
!> CSD              3     ZCKCSD
!> LSE              8     ZCKLSE
!>
!>-----------------------------------------------------------------------
!>
!> NEP input file:
!>
!> line 2:  NN, INTEGER
!>          Number of values of N.
!>
!> line 3:  NVAL, INTEGER array, dimension (NN)
!>          The values for the matrix dimension N.
!>
!> line 4:  NPARMS, INTEGER
!>          Number of values of the parameters NB, NBMIN, NX, NS, and
!>          MAXB.
!>
!> line 5:  NBVAL, INTEGER array, dimension (NPARMS)
!>          The values for the blocksize NB.
!>
!> line 6:  NBMIN, INTEGER array, dimension (NPARMS)
!>          The values for the minimum blocksize NBMIN.
!>
!> line 7:  NXVAL, INTEGER array, dimension (NPARMS)
!>          The values for the crossover point NX.
!>
!> line 8:  INMIN, INTEGER array, dimension (NPARMS)
!>          LAHQR vs TTQRE crossover point, >= 11
!>
!> line 9:  INWIN, INTEGER array, dimension (NPARMS)
!>          recommended deflation window size
!>
!> line 10: INIBL, INTEGER array, dimension (NPARMS)
!>          nibble crossover point
!>
!> line 11:  ISHFTS, INTEGER array, dimension (NPARMS)
!>          number of simultaneous shifts)
!>
!> line 12:  IACC22, INTEGER array, dimension (NPARMS)
!>          select structured matrix multiply: 0, 1 or 2)
!>
!> line 13: THRESH
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.  To have all of the test
!>          ratios printed, use THRESH = 0.0 .
!>
!> line 14: NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 14 was 2:
!>
!> line 15: INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 15-EOF:  The remaining lines occur in sets of 1 or 2 and allow
!>          the user to specify the matrix types.  Each line contains
!>          a 3-character path name in columns 1-3, and the number
!>          of matrix types must be the first nonblank item in columns
!>          4-80.  If the number of matrix types is at least 1 but is
!>          less than the maximum number of possible types, a second
!>          line will be read to get the numbers of the matrix types to
!>          be used.  For example,
!> NEP 21
!>          requests all of the matrix types for the nonsymmetric
!>          eigenvalue problem, while
!> NEP  4
!> 9 10 11 12
!>          requests only matrices of type 9, 10, 11, and 12.
!>
!>          The valid 3-character path names are 'NEP' or 'ZHS' for the
!>          nonsymmetric eigenvalue routines.
!>
!>-----------------------------------------------------------------------
!>
!> SEP or ZSG input file:
!>
!> line 2:  NN, INTEGER
!>          Number of values of N.
!>
!> line 3:  NVAL, INTEGER array, dimension (NN)
!>          The values for the matrix dimension N.
!>
!> line 4:  NPARMS, INTEGER
!>          Number of values of the parameters NB, NBMIN, and NX.
!>
!> line 5:  NBVAL, INTEGER array, dimension (NPARMS)
!>          The values for the blocksize NB.
!>
!> line 6:  NBMIN, INTEGER array, dimension (NPARMS)
!>          The values for the minimum blocksize NBMIN.
!>
!> line 7:  NXVAL, INTEGER array, dimension (NPARMS)
!>          The values for the crossover point NX.
!>
!> line 8:  THRESH
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> line 9:  TSTCHK, LOGICAL
!>          Flag indicating whether or not to test the LAPACK routines.
!>
!> line 10: TSTDRV, LOGICAL
!>          Flag indicating whether or not to test the driver routines.
!>
!> line 11: TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits for
!>          the LAPACK routines and driver routines.
!>
!> line 12: NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 12 was 2:
!>
!> line 13: INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 13-EOF:  Lines specifying matrix types, as for NEP.
!>          The valid 3-character path names are 'SEP' or 'ZST' for the
!>          Hermitian eigenvalue routines and driver routines, and
!>          'ZSG' for the routines for the Hermitian generalized
!>          eigenvalue problem.
!>
!>-----------------------------------------------------------------------
!>
!> SVD input file:
!>
!> line 2:  NN, INTEGER
!>          Number of values of M and N.
!>
!> line 3:  MVAL, INTEGER array, dimension (NN)
!>          The values for the matrix row dimension M.
!>
!> line 4:  NVAL, INTEGER array, dimension (NN)
!>          The values for the matrix column dimension N.
!>
!> line 5:  NPARMS, INTEGER
!>          Number of values of the parameter NB, NBMIN, NX, and NRHS.
!>
!> line 6:  NBVAL, INTEGER array, dimension (NPARMS)
!>          The values for the blocksize NB.
!>
!> line 7:  NBMIN, INTEGER array, dimension (NPARMS)
!>          The values for the minimum blocksize NBMIN.
!>
!> line 8:  NXVAL, INTEGER array, dimension (NPARMS)
!>          The values for the crossover point NX.
!>
!> line 9:  NSVAL, INTEGER array, dimension (NPARMS)
!>          The values for the number of right hand sides NRHS.
!>
!> line 10: THRESH
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> line 11: TSTCHK, LOGICAL
!>          Flag indicating whether or not to test the LAPACK routines.
!>
!> line 12: TSTDRV, LOGICAL
!>          Flag indicating whether or not to test the driver routines.
!>
!> line 13: TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits for
!>          the LAPACK routines and driver routines.
!>
!> line 14: NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 14 was 2:
!>
!> line 15: INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 15-EOF:  Lines specifying matrix types, as for NEP.
!>          The 3-character path names are 'SVD' or 'ZBD' for both the
!>          SVD routines and the SVD driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> ZEV and ZES data files:
!>
!> line 1:  'ZEV' or 'ZES' in columns 1 to 3.
!>
!> line 2:  NSIZES, INTEGER
!>          Number of sizes of matrices to use. Should be at least 0
!>          and at most 20. If NSIZES = 0, no testing is done
!>          (although the remaining  3 lines are still read).
!>
!> line 3:  NN, INTEGER array, dimension(NSIZES)
!>          Dimensions of matrices to be tested.
!>
!> line 4:  NB, NBMIN, NX, NS, NBCOL, INTEGERs
!>          These integer parameters determine how blocking is done
!>          (see ILAENV for details)
!>          NB     : block size
!>          NBMIN  : minimum block size
!>          NX     : minimum dimension for blocking
!>          NS     : number of shifts in xHSEQR
!>          NBCOL  : minimum column dimension for blocking
!>
!> line 5:  THRESH, REAL
!>          The test threshold against which computed residuals are
!>          compared. Should generally be in the range from 10. to 20.
!>          If it is 0., all test case data will be printed.
!>
!> line 6:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 6 was 2:
!>
!> line 7:  INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 8 and following:  Lines specifying matrix types, as for NEP.
!>          The 3-character path name is 'ZEV' to test CGEEV, or
!>          'ZES' to test CGEES.
!>
!>-----------------------------------------------------------------------
!>
!> The ZVX data has two parts. The first part is identical to ZEV,
!> and the second part consists of test matrices with precomputed
!> solutions.
!>
!> line 1:  'ZVX' in columns 1-3.
!>
!> line 2:  NSIZES, INTEGER
!>          If NSIZES = 0, no testing of randomly generated examples
!>          is done, but any precomputed examples are tested.
!>
!> line 3:  NN, INTEGER array, dimension(NSIZES)
!>
!> line 4:  NB, NBMIN, NX, NS, NBCOL, INTEGERs
!>
!> line 5:  THRESH, REAL
!>
!> line 6:  NEWSD, INTEGER
!>
!> If line 6 was 2:
!>
!> line 7:  INTEGER array, dimension (4)
!>
!> lines 8 and following: The first line contains 'ZVX' in columns 1-3
!>          followed by the number of matrix types, possibly with
!>          a second line to specify certain matrix types.
!>          If the number of matrix types = 0, no testing of randomly
!>          generated examples is done, but any precomputed examples
!>          are tested.
!>
!> remaining lines : Each matrix is stored on 1+N+N**2 lines, where N is
!>          its dimension. The first line contains the dimension N and
!>          ISRT (two integers). ISRT indicates whether the last N lines
!>          are sorted by increasing real part of the eigenvalue
!>          (ISRT=0) or by increasing imaginary part (ISRT=1). The next
!>          N**2 lines contain the matrix rowwise, one entry per line.
!>          The last N lines correspond to each eigenvalue. Each of
!>          these last N lines contains 4 real values: the real part of
!>          the eigenvalues, the imaginary part of the eigenvalue, the
!>          reciprocal condition number of the eigenvalues, and the
!>          reciprocal condition number of the vector eigenvector. The
!>          end of data is indicated by dimension N=0. Even if no data
!>          is to be tested, there must be at least one line containing
!>          N=0.
!>
!>-----------------------------------------------------------------------
!>
!> The ZSX data is like ZVX. The first part is identical to ZEV, and the
!> second part consists of test matrices with precomputed solutions.
!>
!> line 1:  'ZSX' in columns 1-3.
!>
!> line 2:  NSIZES, INTEGER
!>          If NSIZES = 0, no testing of randomly generated examples
!>          is done, but any precomputed examples are tested.
!>
!> line 3:  NN, INTEGER array, dimension(NSIZES)
!>
!> line 4:  NB, NBMIN, NX, NS, NBCOL, INTEGERs
!>
!> line 5:  THRESH, REAL
!>
!> line 6:  NEWSD, INTEGER
!>
!> If line 6 was 2:
!>
!> line 7:  INTEGER array, dimension (4)
!>
!> lines 8 and following: The first line contains 'ZSX' in columns 1-3
!>          followed by the number of matrix types, possibly with
!>          a second line to specify certain matrix types.
!>          If the number of matrix types = 0, no testing of randomly
!>          generated examples is done, but any precomputed examples
!>          are tested.
!>
!> remaining lines : Each matrix is stored on 3+N**2 lines, where N is
!>          its dimension. The first line contains the dimension N, the
!>          dimension M of an invariant subspace, and ISRT. The second
!>          line contains M integers, identifying the eigenvalues in the
!>          invariant subspace (by their position in a list of
!>          eigenvalues ordered by increasing real part (if ISRT=0) or
!>          by increasing imaginary part (if ISRT=1)). The next N**2
!>          lines contain the matrix rowwise. The last line contains the
!>          reciprocal condition number for the average of the selected
!>          eigenvalues, and the reciprocal condition number for the
!>          corresponding right invariant subspace. The end of data in
!>          indicated by a line containing N=0, M=0, and ISRT = 0.  Even
!>          if no data is to be tested, there must be at least one line
!>          containing N=0, M=0 and ISRT=0.
!>
!>-----------------------------------------------------------------------
!>
!> ZGG input file:
!>
!> line 2:  NN, INTEGER
!>          Number of values of N.
!>
!> line 3:  NVAL, INTEGER array, dimension (NN)
!>          The values for the matrix dimension N.
!>
!> line 4:  NPARMS, INTEGER
!>          Number of values of the parameters NB, NBMIN, NBCOL, NS, and
!>          MAXB.
!>
!> line 5:  NBVAL, INTEGER array, dimension (NPARMS)
!>          The values for the blocksize NB.
!>
!> line 6:  NBMIN, INTEGER array, dimension (NPARMS)
!>          The values for NBMIN, the minimum row dimension for blocks.
!>
!> line 7:  NSVAL, INTEGER array, dimension (NPARMS)
!>          The values for the number of shifts.
!>
!> line 8:  MXBVAL, INTEGER array, dimension (NPARMS)
!>          The values for MAXB, used in determining minimum blocksize.
!>
!> line 9:  IACC22, INTEGER array, dimension (NPARMS)
!>          select structured matrix multiply: 1 or 2)
!>
!> line 10: NBCOL, INTEGER array, dimension (NPARMS)
!>          The values for NBCOL, the minimum column dimension for
!>          blocks.
!>
!> line 11: THRESH
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> line 12: TSTCHK, LOGICAL
!>          Flag indicating whether or not to test the LAPACK routines.
!>
!> line 13: TSTDRV, LOGICAL
!>          Flag indicating whether or not to test the driver routines.
!>
!> line 14: TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits for
!>          the LAPACK routines and driver routines.
!>
!> line 15: NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 15 was 2:
!>
!> line 16: INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 17-EOF:  Lines specifying matrix types, as for NEP.
!>          The 3-character path name is 'ZGG' for the generalized
!>          eigenvalue problem routines and driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> ZGS and ZGV input files:
!>
!> line 1:  'ZGS' or 'ZGV' in columns 1 to 3.
!>
!> line 2:  NN, INTEGER
!>          Number of values of N.
!>
!> line 3:  NVAL, INTEGER array, dimension(NN)
!>          Dimensions of matrices to be tested.
!>
!> line 4:  NB, NBMIN, NX, NS, NBCOL, INTEGERs
!>          These integer parameters determine how blocking is done
!>          (see ILAENV for details)
!>          NB     : block size
!>          NBMIN  : minimum block size
!>          NX     : minimum dimension for blocking
!>          NS     : number of shifts in xHGEQR
!>          NBCOL  : minimum column dimension for blocking
!>
!> line 5:  THRESH, REAL
!>          The test threshold against which computed residuals are
!>          compared. Should generally be in the range from 10. to 20.
!>          If it is 0., all test case data will be printed.
!>
!> line 6:  TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits.
!>
!> line 7:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 17 was 2:
!>
!> line 7:  INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 7-EOF:  Lines specifying matrix types, as for NEP.
!>          The 3-character path name is 'ZGS' for the generalized
!>          eigenvalue problem routines and driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> ZGX input file:
!> line 1:  'ZGX' in columns 1 to 3.
!>
!> line 2:  N, INTEGER
!>          Value of N.
!>
!> line 3:  NB, NBMIN, NX, NS, NBCOL, INTEGERs
!>          These integer parameters determine how blocking is done
!>          (see ILAENV for details)
!>          NB     : block size
!>          NBMIN  : minimum block size
!>          NX     : minimum dimension for blocking
!>          NS     : number of shifts in xHGEQR
!>          NBCOL  : minimum column dimension for blocking
!>
!> line 4:  THRESH, REAL
!>          The test threshold against which computed residuals are
!>          compared. Should generally be in the range from 10. to 20.
!>          Information will be printed about each test for which the
!>          test ratio is greater than or equal to the threshold.
!>
!> line 5:  TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits for
!>          the LAPACK routines and driver routines.
!>
!> line 6:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 6 was 2:
!>
!> line 7: INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> If line 2 was 0:
!>
!> line 7-EOF: Precomputed examples are tested.
!>
!> remaining lines : Each example is stored on 3+2*N*N lines, where N is
!>          its dimension. The first line contains the dimension (a
!>          single integer).  The next line contains an integer k such
!>          that only the last k eigenvalues will be selected and appear
!>          in the leading diagonal blocks of $A$ and $B$. The next N*N
!>          lines contain the matrix A, one element per line. The next N*N
!>          lines contain the matrix B. The last line contains the
!>          reciprocal of the eigenvalue cluster condition number and the
!>          reciprocal of the deflating subspace (associated with the
!>          selected eigencluster) condition number.  The end of data is
!>          indicated by dimension N=0.  Even if no data is to be tested,
!>          there must be at least one line containing N=0.
!>
!>-----------------------------------------------------------------------
!>
!> ZXV input files:
!> line 1:  'ZXV' in columns 1 to 3.
!>
!> line 2:  N, INTEGER
!>          Value of N.
!>
!> line 3:  NB, NBMIN, NX, NS, NBCOL, INTEGERs
!>          These integer parameters determine how blocking is done
!>          (see ILAENV for details)
!>          NB     : block size
!>          NBMIN  : minimum block size
!>          NX     : minimum dimension for blocking
!>          NS     : number of shifts in xHGEQR
!>          NBCOL  : minimum column dimension for blocking
!>
!> line 4:  THRESH, REAL
!>          The test threshold against which computed residuals are
!>          compared. Should generally be in the range from 10. to 20.
!>          Information will be printed about each test for which the
!>          test ratio is greater than or equal to the threshold.
!>
!> line 5:  TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits for
!>          the LAPACK routines and driver routines.
!>
!> line 6:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 6 was 2:
!>
!> line 7: INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> If line 2 was 0:
!>
!> line 7-EOF: Precomputed examples are tested.
!>
!> remaining lines : Each example is stored on 3+2*N*N lines, where N is
!>          its dimension. The first line contains the dimension (a
!>          single integer). The next N*N lines contain the matrix A, one
!>          element per line. The next N*N lines contain the matrix B.
!>          The next line contains the reciprocals of the eigenvalue
!>          condition numbers.  The last line contains the reciprocals of
!>          the eigenvector condition numbers.  The end of data is
!>          indicated by dimension N=0.  Even if no data is to be tested,
!>          there must be at least one line containing N=0.
!>
!>-----------------------------------------------------------------------
!>
!> ZHB input file:
!>
!> line 2:  NN, INTEGER
!>          Number of values of N.
!>
!> line 3:  NVAL, INTEGER array, dimension (NN)
!>          The values for the matrix dimension N.
!>
!> line 4:  NK, INTEGER
!>          Number of values of K.
!>
!> line 5:  KVAL, INTEGER array, dimension (NK)
!>          The values for the matrix dimension K.
!>
!> line 6:  THRESH
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> line 7:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 7 was 2:
!>
!> line 8:  INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 8-EOF:  Lines specifying matrix types, as for NEP.
!>          The 3-character path name is 'ZHB'.
!>
!>-----------------------------------------------------------------------
!>
!> ZBB input file:
!>
!> line 2:  NN, INTEGER
!>          Number of values of M and N.
!>
!> line 3:  MVAL, INTEGER array, dimension (NN)
!>          The values for the matrix row dimension M.
!>
!> line 4:  NVAL, INTEGER array, dimension (NN)
!>          The values for the matrix column dimension N.
!>
!> line 4:  NK, INTEGER
!>          Number of values of K.
!>
!> line 5:  KVAL, INTEGER array, dimension (NK)
!>          The values for the matrix bandwidth K.
!>
!> line 6:  NPARMS, INTEGER
!>          Number of values of the parameter NRHS
!>
!> line 7:  NSVAL, INTEGER array, dimension (NPARMS)
!>          The values for the number of right hand sides NRHS.
!>
!> line 8:  THRESH
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> line 9:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 9 was 2:
!>
!> line 10: INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 10-EOF:  Lines specifying matrix types, as for SVD.
!>          The 3-character path name is 'ZBB'.
!>
!>-----------------------------------------------------------------------
!>
!> ZEC input file:
!>
!> line  2: THRESH, REAL
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> lines  3-EOF:
!>
!> Input for testing the eigencondition routines consists of a set of
!> specially constructed test cases and their solutions.  The data
!> format is not intended to be modified by the user.
!>
!>-----------------------------------------------------------------------
!>
!> ZBL and ZBK input files:
!>
!> line 1:  'ZBL' in columns 1-3 to test CGEBAL, or 'ZBK' in
!>          columns 1-3 to test CGEBAK.
!>
!> The remaining lines consist of specially constructed test cases.
!>
!>-----------------------------------------------------------------------
!>
!> ZGL and ZGK input files:
!>
!> line 1:  'ZGL' in columns 1-3 to test ZGGBAL, or 'ZGK' in
!>          columns 1-3 to test ZGGBAK.
!>
!> The remaining lines consist of specially constructed test cases.
!>
!>-----------------------------------------------------------------------
!>
!> GLM data file:
!>
!> line 1:  'GLM' in columns 1 to 3.
!>
!> line 2:  NN, INTEGER
!>          Number of values of M, P, and N.
!>
!> line 3:  MVAL, INTEGER array, dimension(NN)
!>          Values of M (row dimension).
!>
!> line 4:  PVAL, INTEGER array, dimension(NN)
!>          Values of P (row dimension).
!>
!> line 5:  NVAL, INTEGER array, dimension(NN)
!>          Values of N (column dimension), note M <= N <= M+P.
!>
!> line 6:  THRESH, REAL
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> line 7:  TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits for
!>          the LAPACK routines and driver routines.
!>
!> line 8:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 8 was 2:
!>
!> line 9:  INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 9-EOF:  Lines specifying matrix types, as for NEP.
!>          The 3-character path name is 'GLM' for the generalized
!>          linear regression model routines.
!>
!>-----------------------------------------------------------------------
!>
!> GQR data file:
!>
!> line 1:  'GQR' in columns 1 to 3.
!>
!> line 2:  NN, INTEGER
!>          Number of values of M, P, and N.
!>
!> line 3:  MVAL, INTEGER array, dimension(NN)
!>          Values of M.
!>
!> line 4:  PVAL, INTEGER array, dimension(NN)
!>          Values of P.
!>
!> line 5:  NVAL, INTEGER array, dimension(NN)
!>          Values of N.
!>
!> line 6:  THRESH, REAL
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> line 7:  TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits for
!>          the LAPACK routines and driver routines.
!>
!> line 8:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 8 was 2:
!>
!> line 9:  INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 9-EOF:  Lines specifying matrix types, as for NEP.
!>          The 3-character path name is 'GQR' for the generalized
!>          QR and RQ routines.
!>
!>-----------------------------------------------------------------------
!>
!> GSV data file:
!>
!> line 1:  'GSV' in columns 1 to 3.
!>
!> line 2:  NN, INTEGER
!>          Number of values of M, P, and N.
!>
!> line 3:  MVAL, INTEGER array, dimension(NN)
!>          Values of M (row dimension).
!>
!> line 4:  PVAL, INTEGER array, dimension(NN)
!>          Values of P (row dimension).
!>
!> line 5:  NVAL, INTEGER array, dimension(NN)
!>          Values of N (column dimension).
!>
!> line 6:  THRESH, REAL
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> line 7:  TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits for
!>          the LAPACK routines and driver routines.
!>
!> line 8:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 8 was 2:
!>
!> line 9:  INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 9-EOF:  Lines specifying matrix types, as for NEP.
!>          The 3-character path name is 'GSV' for the generalized
!>          SVD routines.
!>
!>-----------------------------------------------------------------------
!>
!> CSD data file:
!>
!> line 1:  'CSD' in columns 1 to 3.
!>
!> line 2:  NM, INTEGER
!>          Number of values of M, P, and N.
!>
!> line 3:  MVAL, INTEGER array, dimension(NM)
!>          Values of M (row and column dimension of orthogonal matrix).
!>
!> line 4:  PVAL, INTEGER array, dimension(NM)
!>          Values of P (row dimension of top-left block).
!>
!> line 5:  NVAL, INTEGER array, dimension(NM)
!>          Values of N (column dimension of top-left block).
!>
!> line 6:  THRESH, REAL
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> line 7:  TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits for
!>          the LAPACK routines and driver routines.
!>
!> line 8:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 8 was 2:
!>
!> line 9:  INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 9-EOF:  Lines specifying matrix types, as for NEP.
!>          The 3-character path name is 'CSD' for the CSD routine.
!>
!>-----------------------------------------------------------------------
!>
!> LSE data file:
!>
!> line 1:  'LSE' in columns 1 to 3.
!>
!> line 2:  NN, INTEGER
!>          Number of values of M, P, and N.
!>
!> line 3:  MVAL, INTEGER array, dimension(NN)
!>          Values of M.
!>
!> line 4:  PVAL, INTEGER array, dimension(NN)
!>          Values of P.
!>
!> line 5:  NVAL, INTEGER array, dimension(NN)
!>          Values of N, note P <= N <= P+M.
!>
!> line 6:  THRESH, REAL
!>          Threshold value for the test ratios.  Information will be
!>          printed about each test for which the test ratio is greater
!>          than or equal to the threshold.
!>
!> line 7:  TSTERR, LOGICAL
!>          Flag indicating whether or not to test the error exits for
!>          the LAPACK routines and driver routines.
!>
!> line 8:  NEWSD, INTEGER
!>          A code indicating how to set the random number seed.
!>          = 0:  Set the seed to a default value before each run
!>          = 1:  Initialize the seed to a default value only before the
!>                first run
!>          = 2:  Like 1, but use the seed values on the next line
!>
!> If line 8 was 2:
!>
!> line 9:  INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 9-EOF:  Lines specifying matrix types, as for NEP.
!>          The 3-character path name is 'GSV' for the generalized
!>          SVD routines.
!>
!>-----------------------------------------------------------------------
!>
!> NMAX is currently set to 132 and must be at least 12 for some of the
!> precomputed examples, and LWORK = NMAX*(5*NMAX+20) in the parameter
!> statements below.  For SVD, we assume NRHS may be as big as N.  The
!> parameter NEED is set to 14 to allow for 14 N-by-N matrices for ZGG.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 1033 of file zchkee.F.

◆ zchkgg()

subroutine zchkgg ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
logical tstdif,
double precision thrshn,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) b,
complex*16, dimension( lda, * ) h,
complex*16, dimension( lda, * ) t,
complex*16, dimension( lda, * ) s1,
complex*16, dimension( lda, * ) s2,
complex*16, dimension( lda, * ) p1,
complex*16, dimension( lda, * ) p2,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldu, * ) v,
complex*16, dimension( ldu, * ) q,
complex*16, dimension( ldu, * ) z,
complex*16, dimension( * ) alpha1,
complex*16, dimension( * ) beta1,
complex*16, dimension( * ) alpha3,
complex*16, dimension( * ) beta3,
complex*16, dimension( ldu, * ) evectl,
complex*16, dimension( ldu, * ) evectr,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
logical, dimension( * ) llwork,
double precision, dimension( 15 ) result,
integer info )

ZCHKGG

Purpose:
!>
!> ZCHKGG  checks the nonsymmetric generalized eigenvalue problem
!> routines.
!>                                H          H        H
!> ZGGHRD factors A and B as U H V  and U T V , where   means conjugate
!> transpose, H is hessenberg, T is triangular and U and V are unitary.
!>
!>                                 H          H
!> ZHGEQZ factors H and T as  Q S Z  and Q P Z , where P and S are upper
!> triangular and Q and Z are unitary.  It also computes the generalized
!> eigenvalues (alpha(1),beta(1)),...,(alpha(n),beta(n)), where
!> alpha(j)=S(j,j) and beta(j)=P(j,j) -- thus, w(j) = alpha(j)/beta(j)
!> is a root of the generalized eigenvalue problem
!>
!>     det( A - w(j) B ) = 0
!>
!> and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
!> problem
!>
!>     det( m(j) A - B ) = 0
!>
!> ZTGEVC computes the matrix L of left eigenvectors and the matrix R
!> of right eigenvectors for the matrix pair ( S, P ).  In the
!> description below,  l and r are left and right eigenvectors
!> corresponding to the generalized eigenvalues (alpha,beta).
!>
!> When ZCHKGG is called, a number of matrix  () and a
!> number of matrix  are specified.  For each size ()
!> and each type of matrix, one matrix will be generated and used
!> to test the nonsymmetric eigenroutines.  For each matrix, 13
!> tests will be performed.  The first twelve  should be
!> small -- O(1).  They will be compared with the threshold THRESH:
!>
!>                  H
!> (1)   | A - U H V  | / ( |A| n ulp )
!>
!>                  H
!> (2)   | B - U T V  | / ( |B| n ulp )
!>
!>               H
!> (3)   | I - UU  | / ( n ulp )
!>
!>               H
!> (4)   | I - VV  | / ( n ulp )
!>
!>                  H
!> (5)   | H - Q S Z  | / ( |H| n ulp )
!>
!>                  H
!> (6)   | T - Q P Z  | / ( |T| n ulp )
!>
!>               H
!> (7)   | I - QQ  | / ( n ulp )
!>
!>               H
!> (8)   | I - ZZ  | / ( n ulp )
!>
!> (9)   max over all left eigenvalue/-vector pairs (beta/alpha,l) of
!>                           H
!>       | (beta A - alpha B) l | / ( ulp max( |beta A|, |alpha B| ) )
!>
!> (10)  max over all left eigenvalue/-vector pairs (beta/alpha,l') of
!>                           H
!>       | (beta H - alpha T) l' | / ( ulp max( |beta H|, |alpha T| ) )
!>
!>       where the eigenvectors l' are the result of passing Q to
!>       DTGEVC and back transforming (JOB='B').
!>
!> (11)  max over all right eigenvalue/-vector pairs (beta/alpha,r) of
!>
!>       | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
!>
!> (12)  max over all right eigenvalue/-vector pairs (beta/alpha,r') of
!>
!>       | (beta H - alpha T) r' | / ( ulp max( |beta H|, |alpha T| ) )
!>
!>       where the eigenvectors r' are the result of passing Z to
!>       DTGEVC and back transforming (JOB='B').
!>
!> The last three test ratios will usually be small, but there is no
!> mathematical requirement that they be so.  They are therefore
!> compared with THRESH only if TSTDIF is .TRUE.
!>
!> (13)  | S(Q,Z computed) - S(Q,Z not computed) | / ( |S| ulp )
!>
!> (14)  | P(Q,Z computed) - P(Q,Z not computed) | / ( |P| ulp )
!>
!> (15)  max( |alpha(Q,Z computed) - alpha(Q,Z not computed)|/|S| ,
!>            |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp
!>
!> In addition, the normalization of L and R are checked, and compared
!> with the threshold THRSHN.
!>
!> Test Matrices
!> ---- --------
!>
!> The sizes of the test matrices are specified by an array
!> NN(1:NSIZES); the value of each element NN(j) specifies one size.
!> The  are specified by a logical array DOTYPE( 1:NTYPES ); if
!> DOTYPE(j) is .TRUE., then matrix type  will be generated.
!> Currently, the list of possible types is:
!>
!> (1)  ( 0, 0 )         (a pair of zero matrices)
!>
!> (2)  ( I, 0 )         (an identity and a zero matrix)
!>
!> (3)  ( 0, I )         (an identity and a zero matrix)
!>
!> (4)  ( I, I )         (a pair of identity matrices)
!>
!>         t   t
!> (5)  ( J , J  )       (a pair of transposed Jordan blocks)
!>
!>                                     t                ( I   0  )
!> (6)  ( X, Y )         where  X = ( J   0  )  and Y = (      t )
!>                                  ( 0   I  )          ( 0   J  )
!>                       and I is a k x k identity and J a (k+1)x(k+1)
!>                       Jordan block; k=(N-1)/2
!>
!> (7)  ( D, I )         where D is P*D1, P is a random unitary diagonal
!>                       matrix (i.e., with random magnitude 1 entries
!>                       on the diagonal), and D1=diag( 0, 1,..., N-1 )
!>                       (i.e., a diagonal matrix with D1(1,1)=0,
!>                       D1(2,2)=1, ..., D1(N,N)=N-1.)
!> (8)  ( I, D )
!>
!> (9)  ( big*D, small*I ) where  is near overflow and small=1/big
!>
!> (10) ( small*D, big*I )
!>
!> (11) ( big*I, small*D )
!>
!> (12) ( small*I, big*D )
!>
!> (13) ( big*D, big*I )
!>
!> (14) ( small*D, small*I )
!>
!> (15) ( D1, D2 )        where D1=P*diag( 0, 0, 1, ..., N-3, 0 ) and
!>                        D2=Q*diag( 0, N-3, N-4,..., 1, 0, 0 ), and
!>                        P and Q are random unitary diagonal matrices.
!>           t   t
!> (16) U ( J , J ) V     where U and V are random unitary matrices.
!>
!> (17) U ( T1, T2 ) V    where T1 and T2 are upper triangular matrices
!>                        with random O(1) entries above the diagonal
!>                        and diagonal entries diag(T1) =
!>                        P*( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
!>                        Q*( 0, N-3, N-4,..., 1, 0, 0 )
!>
!> (18) U ( T1, T2 ) V    diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
!>                        s = machine precision.
!>
!> (19) U ( T1, T2 ) V    diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
!>
!>                                                        N-5
!> (20) U ( T1, T2 ) V    diag(T1)=( 0, 0, 1, 1, a, ..., a   =s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
!>
!> (21) U ( T1, T2 ) V    diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
!>                        where r1,..., r(N-4) are random.
!>
!> (22) U ( big*T1, small*T2 ) V   diag(T1) = P*( 0, 0, 1, ..., N-3, 0 )
!>                                 diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (23) U ( small*T1, big*T2 ) V   diag(T1) = P*( 0, 0, 1, ..., N-3, 0 )
!>                                 diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (24) U ( small*T1, small*T2 ) V diag(T1) = P*( 0, 0, 1, ..., N-3, 0 )
!>                                 diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (25) U ( big*T1, big*T2 ) V     diag(T1) = P*( 0, 0, 1, ..., N-3, 0 )
!>                                 diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (26) U ( T1, T2 ) V     where T1 and T2 are random upper-triangular
!>                         matrices.
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZCHKGG does nothing.  It must be at least zero.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZCHKGG
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZCHKGG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]TSTDIF
!>          TSTDIF is LOGICAL
!>          Specifies whether test ratios 13-15 will be computed and
!>          compared with THRESH.
!>          = .FALSE.: Only test ratios 1-12 will be computed and tested.
!>                     Ratios 13-15 will be set to zero.
!>          = .TRUE.:  All the test ratios 1-15 will be computed and
!>                     tested.
!>
[in]THRSHN
!>          THRSHN is DOUBLE PRECISION
!>          Threshold for reporting eigenvector normalization error.
!>          If the normalization of any eigenvector differs from 1 by
!>          more than THRSHN*ulp, then a special error message will be
!>          printed.  (This is handled separately from the other tests,
!>          since only a compiler or programming error should cause an
!>          error message, at least if THRSHN is at least 5--10.)
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA, max(NN))
!>          Used to hold the original A matrix.  Used as input only
!>          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
!>          DOTYPE(MAXTYP+1)=.TRUE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, B, H, T, S1, P1, S2, and P2.
!>          It must be at least 1 and at least max( NN ).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDA, max(NN))
!>          Used to hold the original B matrix.  Used as input only
!>          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
!>          DOTYPE(MAXTYP+1)=.TRUE.
!>
[out]H
!>          H is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The upper Hessenberg matrix computed from A by ZGGHRD.
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by ZGGHRD.
!>
[out]S1
!>          S1 is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The Schur (upper triangular) matrix computed from H by ZHGEQZ
!>          when Q and Z are also computed.
!>
[out]S2
!>          S2 is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The Schur (upper triangular) matrix computed from H by ZHGEQZ
!>          when Q and Z are not computed.
!>
[out]P1
!>          P1 is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from T by ZHGEQZ
!>          when Q and Z are also computed.
!>
[out]P2
!>          P2 is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from T by ZHGEQZ
!>          when Q and Z are not computed.
!>
[out]U
!>          U is COMPLEX*16 array, dimension (LDU, max(NN))
!>          The (left) unitary matrix computed by ZGGHRD.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U, V, Q, Z, EVECTL, and EVEZTR.  It
!>          must be at least 1 and at least max( NN ).
!>
[out]V
!>          V is COMPLEX*16 array, dimension (LDU, max(NN))
!>          The (right) unitary matrix computed by ZGGHRD.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDU, max(NN))
!>          The (left) unitary matrix computed by ZHGEQZ.
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension (LDU, max(NN))
!>          The (left) unitary matrix computed by ZHGEQZ.
!>
[out]ALPHA1
!>          ALPHA1 is COMPLEX*16 array, dimension (max(NN))
!>
[out]BETA1
!>          BETA1 is COMPLEX*16 array, dimension (max(NN))
!>          The generalized eigenvalues of (A,B) computed by ZHGEQZ
!>          when Q, Z, and the full Schur matrices are computed.
!>
[out]ALPHA3
!>          ALPHA3 is COMPLEX*16 array, dimension (max(NN))
!>
[out]BETA3
!>          BETA3 is COMPLEX*16 array, dimension (max(NN))
!>          The generalized eigenvalues of (A,B) computed by ZHGEQZ
!>          when neither Q, Z, nor the Schur matrices are computed.
!>
[out]EVECTL
!>          EVECTL is COMPLEX*16 array, dimension (LDU, max(NN))
!>          The (lower triangular) left eigenvector matrix for the
!>          matrices in S1 and P1.
!>
[out]EVECTR
!>          EVECTR is COMPLEX*16 array, dimension (LDU, max(NN))
!>          The (upper triangular) right eigenvector matrix for the
!>          matrices in S1 and P1.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          max( 4*N, 2 * N**2, 1 ), for all N=NN(j).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*max(NN))
!>
[out]LLWORK
!>          LLWORK is LOGICAL array, dimension (max(NN))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (15)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  A routine returned an error code.  INFO is the
!>                absolute value of the INFO value returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 498 of file zchkgg.f.

503*
504* -- LAPACK test routine --
505* -- LAPACK is a software package provided by Univ. of Tennessee, --
506* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
507*
508* .. Scalar Arguments ..
509 LOGICAL TSTDIF
510 INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES
511 DOUBLE PRECISION THRESH, THRSHN
512* ..
513* .. Array Arguments ..
514 LOGICAL DOTYPE( * ), LLWORK( * )
515 INTEGER ISEED( 4 ), NN( * )
516 DOUBLE PRECISION RESULT( 15 ), RWORK( * )
517 COMPLEX*16 A( LDA, * ), ALPHA1( * ), ALPHA3( * ),
518 $ B( LDA, * ), BETA1( * ), BETA3( * ),
519 $ EVECTL( LDU, * ), EVECTR( LDU, * ),
520 $ H( LDA, * ), P1( LDA, * ), P2( LDA, * ),
521 $ Q( LDU, * ), S1( LDA, * ), S2( LDA, * ),
522 $ T( LDA, * ), U( LDU, * ), V( LDU, * ),
523 $ WORK( * ), Z( LDU, * )
524* ..
525*
526* =====================================================================
527*
528* .. Parameters ..
529 DOUBLE PRECISION ZERO, ONE
530 parameter( zero = 0.0d+0, one = 1.0d+0 )
531 COMPLEX*16 CZERO, CONE
532 parameter( czero = ( 0.0d+0, 0.0d+0 ),
533 $ cone = ( 1.0d+0, 0.0d+0 ) )
534 INTEGER MAXTYP
535 parameter( maxtyp = 26 )
536* ..
537* .. Local Scalars ..
538 LOGICAL BADNN
539 INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
540 $ LWKOPT, MTYPES, N, N1, NERRS, NMATS, NMAX,
541 $ NTEST, NTESTT
542 DOUBLE PRECISION ANORM, BNORM, SAFMAX, SAFMIN, TEMP1, TEMP2,
543 $ ULP, ULPINV
544 COMPLEX*16 CTEMP
545* ..
546* .. Local Arrays ..
547 LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP )
548 INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
549 $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
550 $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
551 $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
552 $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
553 DOUBLE PRECISION DUMMA( 4 ), RMAGN( 0: 3 )
554 COMPLEX*16 CDUMMA( 4 )
555* ..
556* .. External Functions ..
557 DOUBLE PRECISION DLAMCH, ZLANGE
558 COMPLEX*16 ZLARND
559 EXTERNAL dlamch, zlange, zlarnd
560* ..
561* .. External Subroutines ..
562 EXTERNAL dlabad, dlasum, xerbla, zgeqr2, zget51, zget52,
563 $ zgghrd, zhgeqz, zlacpy, zlarfg, zlaset, zlatm4,
564 $ ztgevc, zunm2r
565* ..
566* .. Intrinsic Functions ..
567 INTRINSIC abs, dble, dconjg, max, min, sign
568* ..
569* .. Data statements ..
570 DATA kclass / 15*1, 10*2, 1*3 /
571 DATA kz1 / 0, 1, 2, 1, 3, 3 /
572 DATA kz2 / 0, 0, 1, 2, 1, 1 /
573 DATA kadd / 0, 0, 0, 0, 3, 2 /
574 DATA katype / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
575 $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
576 DATA kbtype / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
577 $ 1, 1, -4, 2, -4, 8*8, 0 /
578 DATA kazero / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
579 $ 4*5, 4*3, 1 /
580 DATA kbzero / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
581 $ 4*6, 4*4, 1 /
582 DATA kamagn / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
583 $ 2, 1 /
584 DATA kbmagn / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
585 $ 2, 1 /
586 DATA ktrian / 16*0, 10*1 /
587 DATA lasign / 6*.false., .true., .false., 2*.true.,
588 $ 2*.false., 3*.true., .false., .true.,
589 $ 3*.false., 5*.true., .false. /
590 DATA lbsign / 7*.false., .true., 2*.false.,
591 $ 2*.true., 2*.false., .true., .false., .true.,
592 $ 9*.false. /
593* ..
594* .. Executable Statements ..
595*
596* Check for errors
597*
598 info = 0
599*
600 badnn = .false.
601 nmax = 1
602 DO 10 j = 1, nsizes
603 nmax = max( nmax, nn( j ) )
604 IF( nn( j ).LT.0 )
605 $ badnn = .true.
606 10 CONTINUE
607*
608 lwkopt = max( 2*nmax*nmax, 4*nmax, 1 )
609*
610* Check for errors
611*
612 IF( nsizes.LT.0 ) THEN
613 info = -1
614 ELSE IF( badnn ) THEN
615 info = -2
616 ELSE IF( ntypes.LT.0 ) THEN
617 info = -3
618 ELSE IF( thresh.LT.zero ) THEN
619 info = -6
620 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
621 info = -10
622 ELSE IF( ldu.LE.1 .OR. ldu.LT.nmax ) THEN
623 info = -19
624 ELSE IF( lwkopt.GT.lwork ) THEN
625 info = -30
626 END IF
627*
628 IF( info.NE.0 ) THEN
629 CALL xerbla( 'ZCHKGG', -info )
630 RETURN
631 END IF
632*
633* Quick return if possible
634*
635 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
636 $ RETURN
637*
638 safmin = dlamch( 'Safe minimum' )
639 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
640 safmin = safmin / ulp
641 safmax = one / safmin
642 CALL dlabad( safmin, safmax )
643 ulpinv = one / ulp
644*
645* The values RMAGN(2:3) depend on N, see below.
646*
647 rmagn( 0 ) = zero
648 rmagn( 1 ) = one
649*
650* Loop over sizes, types
651*
652 ntestt = 0
653 nerrs = 0
654 nmats = 0
655*
656 DO 240 jsize = 1, nsizes
657 n = nn( jsize )
658 n1 = max( 1, n )
659 rmagn( 2 ) = safmax*ulp / dble( n1 )
660 rmagn( 3 ) = safmin*ulpinv*n1
661*
662 IF( nsizes.NE.1 ) THEN
663 mtypes = min( maxtyp, ntypes )
664 ELSE
665 mtypes = min( maxtyp+1, ntypes )
666 END IF
667*
668 DO 230 jtype = 1, mtypes
669 IF( .NOT.dotype( jtype ) )
670 $ GO TO 230
671 nmats = nmats + 1
672 ntest = 0
673*
674* Save ISEED in case of an error.
675*
676 DO 20 j = 1, 4
677 ioldsd( j ) = iseed( j )
678 20 CONTINUE
679*
680* Initialize RESULT
681*
682 DO 30 j = 1, 15
683 result( j ) = zero
684 30 CONTINUE
685*
686* Compute A and B
687*
688* Description of control parameters:
689*
690* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
691* =3 means random.
692* KATYPE: the "type" to be passed to ZLATM4 for computing A.
693* KAZERO: the pattern of zeros on the diagonal for A:
694* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
695* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
696* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
697* non-zero entries.)
698* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
699* =2: large, =3: small.
700* LASIGN: .TRUE. if the diagonal elements of A are to be
701* multiplied by a random magnitude 1 number.
702* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B.
703* KTRIAN: =0: don't fill in the upper triangle, =1: do.
704* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
705* RMAGN: used to implement KAMAGN and KBMAGN.
706*
707 IF( mtypes.GT.maxtyp )
708 $ GO TO 110
709 iinfo = 0
710 IF( kclass( jtype ).LT.3 ) THEN
711*
712* Generate A (w/o rotation)
713*
714 IF( abs( katype( jtype ) ).EQ.3 ) THEN
715 in = 2*( ( n-1 ) / 2 ) + 1
716 IF( in.NE.n )
717 $ CALL zlaset( 'Full', n, n, czero, czero, a, lda )
718 ELSE
719 in = n
720 END IF
721 CALL zlatm4( katype( jtype ), in, kz1( kazero( jtype ) ),
722 $ kz2( kazero( jtype ) ), lasign( jtype ),
723 $ rmagn( kamagn( jtype ) ), ulp,
724 $ rmagn( ktrian( jtype )*kamagn( jtype ) ), 4,
725 $ iseed, a, lda )
726 iadd = kadd( kazero( jtype ) )
727 IF( iadd.GT.0 .AND. iadd.LE.n )
728 $ a( iadd, iadd ) = rmagn( kamagn( jtype ) )
729*
730* Generate B (w/o rotation)
731*
732 IF( abs( kbtype( jtype ) ).EQ.3 ) THEN
733 in = 2*( ( n-1 ) / 2 ) + 1
734 IF( in.NE.n )
735 $ CALL zlaset( 'Full', n, n, czero, czero, b, lda )
736 ELSE
737 in = n
738 END IF
739 CALL zlatm4( kbtype( jtype ), in, kz1( kbzero( jtype ) ),
740 $ kz2( kbzero( jtype ) ), lbsign( jtype ),
741 $ rmagn( kbmagn( jtype ) ), one,
742 $ rmagn( ktrian( jtype )*kbmagn( jtype ) ), 4,
743 $ iseed, b, lda )
744 iadd = kadd( kbzero( jtype ) )
745 IF( iadd.NE.0 )
746 $ b( iadd, iadd ) = rmagn( kbmagn( jtype ) )
747*
748 IF( kclass( jtype ).EQ.2 .AND. n.GT.0 ) THEN
749*
750* Include rotations
751*
752* Generate U, V as Householder transformations times a
753* diagonal matrix. (Note that ZLARFG makes U(j,j) and
754* V(j,j) real.)
755*
756 DO 50 jc = 1, n - 1
757 DO 40 jr = jc, n
758 u( jr, jc ) = zlarnd( 3, iseed )
759 v( jr, jc ) = zlarnd( 3, iseed )
760 40 CONTINUE
761 CALL zlarfg( n+1-jc, u( jc, jc ), u( jc+1, jc ), 1,
762 $ work( jc ) )
763 work( 2*n+jc ) = sign( one, dble( u( jc, jc ) ) )
764 u( jc, jc ) = cone
765 CALL zlarfg( n+1-jc, v( jc, jc ), v( jc+1, jc ), 1,
766 $ work( n+jc ) )
767 work( 3*n+jc ) = sign( one, dble( v( jc, jc ) ) )
768 v( jc, jc ) = cone
769 50 CONTINUE
770 ctemp = zlarnd( 3, iseed )
771 u( n, n ) = cone
772 work( n ) = czero
773 work( 3*n ) = ctemp / abs( ctemp )
774 ctemp = zlarnd( 3, iseed )
775 v( n, n ) = cone
776 work( 2*n ) = czero
777 work( 4*n ) = ctemp / abs( ctemp )
778*
779* Apply the diagonal matrices
780*
781 DO 70 jc = 1, n
782 DO 60 jr = 1, n
783 a( jr, jc ) = work( 2*n+jr )*
784 $ dconjg( work( 3*n+jc ) )*
785 $ a( jr, jc )
786 b( jr, jc ) = work( 2*n+jr )*
787 $ dconjg( work( 3*n+jc ) )*
788 $ b( jr, jc )
789 60 CONTINUE
790 70 CONTINUE
791 CALL zunm2r( 'L', 'N', n, n, n-1, u, ldu, work, a,
792 $ lda, work( 2*n+1 ), iinfo )
793 IF( iinfo.NE.0 )
794 $ GO TO 100
795 CALL zunm2r( 'R', 'C', n, n, n-1, v, ldu, work( n+1 ),
796 $ a, lda, work( 2*n+1 ), iinfo )
797 IF( iinfo.NE.0 )
798 $ GO TO 100
799 CALL zunm2r( 'L', 'N', n, n, n-1, u, ldu, work, b,
800 $ lda, work( 2*n+1 ), iinfo )
801 IF( iinfo.NE.0 )
802 $ GO TO 100
803 CALL zunm2r( 'R', 'C', n, n, n-1, v, ldu, work( n+1 ),
804 $ b, lda, work( 2*n+1 ), iinfo )
805 IF( iinfo.NE.0 )
806 $ GO TO 100
807 END IF
808 ELSE
809*
810* Random matrices
811*
812 DO 90 jc = 1, n
813 DO 80 jr = 1, n
814 a( jr, jc ) = rmagn( kamagn( jtype ) )*
815 $ zlarnd( 4, iseed )
816 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
817 $ zlarnd( 4, iseed )
818 80 CONTINUE
819 90 CONTINUE
820 END IF
821*
822 anorm = zlange( '1', n, n, a, lda, rwork )
823 bnorm = zlange( '1', n, n, b, lda, rwork )
824*
825 100 CONTINUE
826*
827 IF( iinfo.NE.0 ) THEN
828 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
829 $ ioldsd
830 info = abs( iinfo )
831 RETURN
832 END IF
833*
834 110 CONTINUE
835*
836* Call ZGEQR2, ZUNM2R, and ZGGHRD to compute H, T, U, and V
837*
838 CALL zlacpy( ' ', n, n, a, lda, h, lda )
839 CALL zlacpy( ' ', n, n, b, lda, t, lda )
840 ntest = 1
841 result( 1 ) = ulpinv
842*
843 CALL zgeqr2( n, n, t, lda, work, work( n+1 ), iinfo )
844 IF( iinfo.NE.0 ) THEN
845 WRITE( nounit, fmt = 9999 )'ZGEQR2', iinfo, n, jtype,
846 $ ioldsd
847 info = abs( iinfo )
848 GO TO 210
849 END IF
850*
851 CALL zunm2r( 'L', 'C', n, n, n, t, lda, work, h, lda,
852 $ work( n+1 ), iinfo )
853 IF( iinfo.NE.0 ) THEN
854 WRITE( nounit, fmt = 9999 )'ZUNM2R', iinfo, n, jtype,
855 $ ioldsd
856 info = abs( iinfo )
857 GO TO 210
858 END IF
859*
860 CALL zlaset( 'Full', n, n, czero, cone, u, ldu )
861 CALL zunm2r( 'R', 'N', n, n, n, t, lda, work, u, ldu,
862 $ work( n+1 ), iinfo )
863 IF( iinfo.NE.0 ) THEN
864 WRITE( nounit, fmt = 9999 )'ZUNM2R', iinfo, n, jtype,
865 $ ioldsd
866 info = abs( iinfo )
867 GO TO 210
868 END IF
869*
870 CALL zgghrd( 'V', 'I', n, 1, n, h, lda, t, lda, u, ldu, v,
871 $ ldu, iinfo )
872 IF( iinfo.NE.0 ) THEN
873 WRITE( nounit, fmt = 9999 )'ZGGHRD', iinfo, n, jtype,
874 $ ioldsd
875 info = abs( iinfo )
876 GO TO 210
877 END IF
878 ntest = 4
879*
880* Do tests 1--4
881*
882 CALL zget51( 1, n, a, lda, h, lda, u, ldu, v, ldu, work,
883 $ rwork, result( 1 ) )
884 CALL zget51( 1, n, b, lda, t, lda, u, ldu, v, ldu, work,
885 $ rwork, result( 2 ) )
886 CALL zget51( 3, n, b, lda, t, lda, u, ldu, u, ldu, work,
887 $ rwork, result( 3 ) )
888 CALL zget51( 3, n, b, lda, t, lda, v, ldu, v, ldu, work,
889 $ rwork, result( 4 ) )
890*
891* Call ZHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests.
892*
893* Compute T1 and UZ
894*
895* Eigenvalues only
896*
897 CALL zlacpy( ' ', n, n, h, lda, s2, lda )
898 CALL zlacpy( ' ', n, n, t, lda, p2, lda )
899 ntest = 5
900 result( 5 ) = ulpinv
901*
902 CALL zhgeqz( 'E', 'N', 'N', n, 1, n, s2, lda, p2, lda,
903 $ alpha3, beta3, q, ldu, z, ldu, work, lwork,
904 $ rwork, iinfo )
905 IF( iinfo.NE.0 ) THEN
906 WRITE( nounit, fmt = 9999 )'ZHGEQZ(E)', iinfo, n, jtype,
907 $ ioldsd
908 info = abs( iinfo )
909 GO TO 210
910 END IF
911*
912* Eigenvalues and Full Schur Form
913*
914 CALL zlacpy( ' ', n, n, h, lda, s2, lda )
915 CALL zlacpy( ' ', n, n, t, lda, p2, lda )
916*
917 CALL zhgeqz( 'S', 'N', 'N', n, 1, n, s2, lda, p2, lda,
918 $ alpha1, beta1, q, ldu, z, ldu, work, lwork,
919 $ rwork, iinfo )
920 IF( iinfo.NE.0 ) THEN
921 WRITE( nounit, fmt = 9999 )'ZHGEQZ(S)', iinfo, n, jtype,
922 $ ioldsd
923 info = abs( iinfo )
924 GO TO 210
925 END IF
926*
927* Eigenvalues, Schur Form, and Schur Vectors
928*
929 CALL zlacpy( ' ', n, n, h, lda, s1, lda )
930 CALL zlacpy( ' ', n, n, t, lda, p1, lda )
931*
932 CALL zhgeqz( 'S', 'I', 'I', n, 1, n, s1, lda, p1, lda,
933 $ alpha1, beta1, q, ldu, z, ldu, work, lwork,
934 $ rwork, iinfo )
935 IF( iinfo.NE.0 ) THEN
936 WRITE( nounit, fmt = 9999 )'ZHGEQZ(V)', iinfo, n, jtype,
937 $ ioldsd
938 info = abs( iinfo )
939 GO TO 210
940 END IF
941*
942 ntest = 8
943*
944* Do Tests 5--8
945*
946 CALL zget51( 1, n, h, lda, s1, lda, q, ldu, z, ldu, work,
947 $ rwork, result( 5 ) )
948 CALL zget51( 1, n, t, lda, p1, lda, q, ldu, z, ldu, work,
949 $ rwork, result( 6 ) )
950 CALL zget51( 3, n, t, lda, p1, lda, q, ldu, q, ldu, work,
951 $ rwork, result( 7 ) )
952 CALL zget51( 3, n, t, lda, p1, lda, z, ldu, z, ldu, work,
953 $ rwork, result( 8 ) )
954*
955* Compute the Left and Right Eigenvectors of (S1,P1)
956*
957* 9: Compute the left eigenvector Matrix without
958* back transforming:
959*
960 ntest = 9
961 result( 9 ) = ulpinv
962*
963* To test "SELECT" option, compute half of the eigenvectors
964* in one call, and half in another
965*
966 i1 = n / 2
967 DO 120 j = 1, i1
968 llwork( j ) = .true.
969 120 CONTINUE
970 DO 130 j = i1 + 1, n
971 llwork( j ) = .false.
972 130 CONTINUE
973*
974 CALL ztgevc( 'L', 'S', llwork, n, s1, lda, p1, lda, evectl,
975 $ ldu, cdumma, ldu, n, in, work, rwork, iinfo )
976 IF( iinfo.NE.0 ) THEN
977 WRITE( nounit, fmt = 9999 )'ZTGEVC(L,S1)', iinfo, n,
978 $ jtype, ioldsd
979 info = abs( iinfo )
980 GO TO 210
981 END IF
982*
983 i1 = in
984 DO 140 j = 1, i1
985 llwork( j ) = .false.
986 140 CONTINUE
987 DO 150 j = i1 + 1, n
988 llwork( j ) = .true.
989 150 CONTINUE
990*
991 CALL ztgevc( 'L', 'S', llwork, n, s1, lda, p1, lda,
992 $ evectl( 1, i1+1 ), ldu, cdumma, ldu, n, in,
993 $ work, rwork, iinfo )
994 IF( iinfo.NE.0 ) THEN
995 WRITE( nounit, fmt = 9999 )'ZTGEVC(L,S2)', iinfo, n,
996 $ jtype, ioldsd
997 info = abs( iinfo )
998 GO TO 210
999 END IF
1000*
1001 CALL zget52( .true., n, s1, lda, p1, lda, evectl, ldu,
1002 $ alpha1, beta1, work, rwork, dumma( 1 ) )
1003 result( 9 ) = dumma( 1 )
1004 IF( dumma( 2 ).GT.thrshn ) THEN
1005 WRITE( nounit, fmt = 9998 )'Left', 'ZTGEVC(HOWMNY=S)',
1006 $ dumma( 2 ), n, jtype, ioldsd
1007 END IF
1008*
1009* 10: Compute the left eigenvector Matrix with
1010* back transforming:
1011*
1012 ntest = 10
1013 result( 10 ) = ulpinv
1014 CALL zlacpy( 'F', n, n, q, ldu, evectl, ldu )
1015 CALL ztgevc( 'L', 'B', llwork, n, s1, lda, p1, lda, evectl,
1016 $ ldu, cdumma, ldu, n, in, work, rwork, iinfo )
1017 IF( iinfo.NE.0 ) THEN
1018 WRITE( nounit, fmt = 9999 )'ZTGEVC(L,B)', iinfo, n,
1019 $ jtype, ioldsd
1020 info = abs( iinfo )
1021 GO TO 210
1022 END IF
1023*
1024 CALL zget52( .true., n, h, lda, t, lda, evectl, ldu, alpha1,
1025 $ beta1, work, rwork, dumma( 1 ) )
1026 result( 10 ) = dumma( 1 )
1027 IF( dumma( 2 ).GT.thrshn ) THEN
1028 WRITE( nounit, fmt = 9998 )'Left', 'ZTGEVC(HOWMNY=B)',
1029 $ dumma( 2 ), n, jtype, ioldsd
1030 END IF
1031*
1032* 11: Compute the right eigenvector Matrix without
1033* back transforming:
1034*
1035 ntest = 11
1036 result( 11 ) = ulpinv
1037*
1038* To test "SELECT" option, compute half of the eigenvectors
1039* in one call, and half in another
1040*
1041 i1 = n / 2
1042 DO 160 j = 1, i1
1043 llwork( j ) = .true.
1044 160 CONTINUE
1045 DO 170 j = i1 + 1, n
1046 llwork( j ) = .false.
1047 170 CONTINUE
1048*
1049 CALL ztgevc( 'R', 'S', llwork, n, s1, lda, p1, lda, cdumma,
1050 $ ldu, evectr, ldu, n, in, work, rwork, iinfo )
1051 IF( iinfo.NE.0 ) THEN
1052 WRITE( nounit, fmt = 9999 )'ZTGEVC(R,S1)', iinfo, n,
1053 $ jtype, ioldsd
1054 info = abs( iinfo )
1055 GO TO 210
1056 END IF
1057*
1058 i1 = in
1059 DO 180 j = 1, i1
1060 llwork( j ) = .false.
1061 180 CONTINUE
1062 DO 190 j = i1 + 1, n
1063 llwork( j ) = .true.
1064 190 CONTINUE
1065*
1066 CALL ztgevc( 'R', 'S', llwork, n, s1, lda, p1, lda, cdumma,
1067 $ ldu, evectr( 1, i1+1 ), ldu, n, in, work,
1068 $ rwork, iinfo )
1069 IF( iinfo.NE.0 ) THEN
1070 WRITE( nounit, fmt = 9999 )'ZTGEVC(R,S2)', iinfo, n,
1071 $ jtype, ioldsd
1072 info = abs( iinfo )
1073 GO TO 210
1074 END IF
1075*
1076 CALL zget52( .false., n, s1, lda, p1, lda, evectr, ldu,
1077 $ alpha1, beta1, work, rwork, dumma( 1 ) )
1078 result( 11 ) = dumma( 1 )
1079 IF( dumma( 2 ).GT.thresh ) THEN
1080 WRITE( nounit, fmt = 9998 )'Right', 'ZTGEVC(HOWMNY=S)',
1081 $ dumma( 2 ), n, jtype, ioldsd
1082 END IF
1083*
1084* 12: Compute the right eigenvector Matrix with
1085* back transforming:
1086*
1087 ntest = 12
1088 result( 12 ) = ulpinv
1089 CALL zlacpy( 'F', n, n, z, ldu, evectr, ldu )
1090 CALL ztgevc( 'R', 'B', llwork, n, s1, lda, p1, lda, cdumma,
1091 $ ldu, evectr, ldu, n, in, work, rwork, iinfo )
1092 IF( iinfo.NE.0 ) THEN
1093 WRITE( nounit, fmt = 9999 )'ZTGEVC(R,B)', iinfo, n,
1094 $ jtype, ioldsd
1095 info = abs( iinfo )
1096 GO TO 210
1097 END IF
1098*
1099 CALL zget52( .false., n, h, lda, t, lda, evectr, ldu,
1100 $ alpha1, beta1, work, rwork, dumma( 1 ) )
1101 result( 12 ) = dumma( 1 )
1102 IF( dumma( 2 ).GT.thresh ) THEN
1103 WRITE( nounit, fmt = 9998 )'Right', 'ZTGEVC(HOWMNY=B)',
1104 $ dumma( 2 ), n, jtype, ioldsd
1105 END IF
1106*
1107* Tests 13--15 are done only on request
1108*
1109 IF( tstdif ) THEN
1110*
1111* Do Tests 13--14
1112*
1113 CALL zget51( 2, n, s1, lda, s2, lda, q, ldu, z, ldu,
1114 $ work, rwork, result( 13 ) )
1115 CALL zget51( 2, n, p1, lda, p2, lda, q, ldu, z, ldu,
1116 $ work, rwork, result( 14 ) )
1117*
1118* Do Test 15
1119*
1120 temp1 = zero
1121 temp2 = zero
1122 DO 200 j = 1, n
1123 temp1 = max( temp1, abs( alpha1( j )-alpha3( j ) ) )
1124 temp2 = max( temp2, abs( beta1( j )-beta3( j ) ) )
1125 200 CONTINUE
1126*
1127 temp1 = temp1 / max( safmin, ulp*max( temp1, anorm ) )
1128 temp2 = temp2 / max( safmin, ulp*max( temp2, bnorm ) )
1129 result( 15 ) = max( temp1, temp2 )
1130 ntest = 15
1131 ELSE
1132 result( 13 ) = zero
1133 result( 14 ) = zero
1134 result( 15 ) = zero
1135 ntest = 12
1136 END IF
1137*
1138* End of Loop -- Check for RESULT(j) > THRESH
1139*
1140 210 CONTINUE
1141*
1142 ntestt = ntestt + ntest
1143*
1144* Print out tests which fail.
1145*
1146 DO 220 jr = 1, ntest
1147 IF( result( jr ).GE.thresh ) THEN
1148*
1149* If this is the first test to fail,
1150* print a header to the data file.
1151*
1152 IF( nerrs.EQ.0 ) THEN
1153 WRITE( nounit, fmt = 9997 )'ZGG'
1154*
1155* Matrix types
1156*
1157 WRITE( nounit, fmt = 9996 )
1158 WRITE( nounit, fmt = 9995 )
1159 WRITE( nounit, fmt = 9994 )'Unitary'
1160*
1161* Tests performed
1162*
1163 WRITE( nounit, fmt = 9993 )'unitary', '*',
1164 $ 'conjugate transpose', ( '*', j = 1, 10 )
1165*
1166 END IF
1167 nerrs = nerrs + 1
1168 IF( result( jr ).LT.10000.0d0 ) THEN
1169 WRITE( nounit, fmt = 9992 )n, jtype, ioldsd, jr,
1170 $ result( jr )
1171 ELSE
1172 WRITE( nounit, fmt = 9991 )n, jtype, ioldsd, jr,
1173 $ result( jr )
1174 END IF
1175 END IF
1176 220 CONTINUE
1177*
1178 230 CONTINUE
1179 240 CONTINUE
1180*
1181* Summary
1182*
1183 CALL dlasum( 'ZGG', nounit, nerrs, ntestt )
1184 RETURN
1185*
1186 9999 FORMAT( ' ZCHKGG: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1187 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1188*
1189 9998 FORMAT( ' ZCHKGG: ', a, ' Eigenvectors from ', a, ' incorrectly ',
1190 $ 'normalized.', / ' Bits of error=', 0p, g10.3, ',', 9x,
1191 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5,
1192 $ ')' )
1193*
1194 9997 FORMAT( 1x, a3, ' -- Complex Generalized eigenvalue problem' )
1195*
1196 9996 FORMAT( ' Matrix types (see ZCHKGG for details): ' )
1197*
1198 9995 FORMAT( ' Special Matrices:', 23x,
1199 $ '(J''=transposed Jordan block)',
1200 $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
1201 $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
1202 $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
1203 $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
1204 $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
1205 $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
1206 9994 FORMAT( ' Matrices Rotated by Random ', a, ' Matrices U, V:',
1207 $ / ' 16=Transposed Jordan Blocks 19=geometric ',
1208 $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
1209 $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
1210 $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
1211 $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
1212 $ '23=(small,large) 24=(small,small) 25=(large,large)',
1213 $ / ' 26=random O(1) matrices.' )
1214*
1215 9993 FORMAT( / ' Tests performed: (H is Hessenberg, S is Schur, B, ',
1216 $ 'T, P are triangular,', / 20x, 'U, V, Q, and Z are ', a,
1217 $ ', l and r are the', / 20x,
1218 $ 'appropriate left and right eigenvectors, resp., a is',
1219 $ / 20x, 'alpha, b is beta, and ', a, ' means ', a, '.)',
1220 $ / ' 1 = | A - U H V', a,
1221 $ ' | / ( |A| n ulp ) 2 = | B - U T V', a,
1222 $ ' | / ( |B| n ulp )', / ' 3 = | I - UU', a,
1223 $ ' | / ( n ulp ) 4 = | I - VV', a,
1224 $ ' | / ( n ulp )', / ' 5 = | H - Q S Z', a,
1225 $ ' | / ( |H| n ulp )', 6x, '6 = | T - Q P Z', a,
1226 $ ' | / ( |T| n ulp )', / ' 7 = | I - QQ', a,
1227 $ ' | / ( n ulp ) 8 = | I - ZZ', a,
1228 $ ' | / ( n ulp )', / ' 9 = max | ( b S - a P )', a,
1229 $ ' l | / const. 10 = max | ( b H - a T )', a,
1230 $ ' l | / const.', /
1231 $ ' 11= max | ( b S - a P ) r | / const. 12 = max | ( b H',
1232 $ ' - a T ) r | / const.', / 1x )
1233*
1234 9992 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
1235 $ 4( i4, ',' ), ' result ', i2, ' is', 0p, f8.2 )
1236 9991 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
1237 $ 4( i4, ',' ), ' result ', i2, ' is', 1p, d10.3 )
1238*
1239* End of ZCHKGG
1240*
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
ztgevc
subroutine ztgevc(side, howmny, select, n, s, lds, p, ldp, vl, ldvl, vr, ldvr, mm, m, work, rwork, info)
ZTGEVC
Definition ztgevc.f:219
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
zlarfg
subroutine zlarfg(n, alpha, x, incx, tau)
ZLARFG generates an elementary reflector (Householder matrix).
Definition zlarfg.f:106
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
zgghrd
subroutine zgghrd(compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, info)
ZGGHRD
Definition zgghrd.f:204
zget51
subroutine zget51(itype, n, a, lda, b, ldb, u, ldu, v, ldv, work, rwork, result)
ZGET51
Definition zget51.f:155
zget52
subroutine zget52(left, n, a, lda, b, ldb, e, lde, alpha, beta, work, rwork, result)
ZGET52
Definition zget52.f:162
zlatm4
subroutine zlatm4(itype, n, nz1, nz2, rsign, amagn, rcond, triang, idist, iseed, a, lda)
ZLATM4
Definition zlatm4.f:171
zlarnd
complex *16 function zlarnd(idist, iseed)
ZLARND
Definition zlarnd.f:75
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ zchkgk()

subroutine zchkgk ( integer nin,
integer nout )

ZCHKGK

Purpose:
!>
!> ZCHKGK tests ZGGBAK, a routine for backward balancing  of
!> a matrix pair (A, B).
!>
Parameters
[in]NIN
!>          NIN is INTEGER
!>          The logical unit number for input.  NIN > 0.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The logical unit number for output.  NOUT > 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 53 of file zchkgk.f.

54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 INTEGER NIN, NOUT
61* ..
62*
63* =====================================================================
64*
65* .. Parameters ..
66 INTEGER LDA, LDB, LDVL, LDVR
67 parameter( lda = 50, ldb = 50, ldvl = 50, ldvr = 50 )
68 INTEGER LDE, LDF, LDWORK, LRWORK
69 parameter( lde = 50, ldf = 50, ldwork = 50,
70 $ lrwork = 6*50 )
71 DOUBLE PRECISION ZERO
72 parameter( zero = 0.0d+0 )
73 COMPLEX*16 CZERO, CONE
74 parameter( czero = ( 0.0d+0, 0.0d+0 ),
75 $ cone = ( 1.0d+0, 0.0d+0 ) )
76* ..
77* .. Local Scalars ..
78 INTEGER I, IHI, ILO, INFO, J, KNT, M, N, NINFO
79 DOUBLE PRECISION ANORM, BNORM, EPS, RMAX, VMAX
80 COMPLEX*16 CDUM
81* ..
82* .. Local Arrays ..
83 INTEGER LMAX( 4 )
84 DOUBLE PRECISION LSCALE( LDA ), RSCALE( LDA ), RWORK( LRWORK )
85 COMPLEX*16 A( LDA, LDA ), AF( LDA, LDA ), B( LDB, LDB ),
86 $ BF( LDB, LDB ), E( LDE, LDE ), F( LDF, LDF ),
87 $ VL( LDVL, LDVL ), VLF( LDVL, LDVL ),
88 $ VR( LDVR, LDVR ), VRF( LDVR, LDVR ),
89 $ WORK( LDWORK, LDWORK )
90* ..
91* .. External Functions ..
92 DOUBLE PRECISION DLAMCH, ZLANGE
93 EXTERNAL dlamch, zlange
94* ..
95* .. External Subroutines ..
96 EXTERNAL zgemm, zggbak, zggbal, zlacpy
97* ..
98* .. Intrinsic Functions ..
99 INTRINSIC abs, dble, dimag, max
100* ..
101* .. Statement Functions ..
102 DOUBLE PRECISION CABS1
103* ..
104* .. Statement Function definitions ..
105 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
106* ..
107* .. Executable Statements ..
108*
109 lmax( 1 ) = 0
110 lmax( 2 ) = 0
111 lmax( 3 ) = 0
112 lmax( 4 ) = 0
113 ninfo = 0
114 knt = 0
115 rmax = zero
116*
117 eps = dlamch( 'Precision' )
118*
119 10 CONTINUE
120 READ( nin, fmt = * )n, m
121 IF( n.EQ.0 )
122 $ GO TO 100
123*
124 DO 20 i = 1, n
125 READ( nin, fmt = * )( a( i, j ), j = 1, n )
126 20 CONTINUE
127*
128 DO 30 i = 1, n
129 READ( nin, fmt = * )( b( i, j ), j = 1, n )
130 30 CONTINUE
131*
132 DO 40 i = 1, n
133 READ( nin, fmt = * )( vl( i, j ), j = 1, m )
134 40 CONTINUE
135*
136 DO 50 i = 1, n
137 READ( nin, fmt = * )( vr( i, j ), j = 1, m )
138 50 CONTINUE
139*
140 knt = knt + 1
141*
142 anorm = zlange( 'M', n, n, a, lda, rwork )
143 bnorm = zlange( 'M', n, n, b, ldb, rwork )
144*
145 CALL zlacpy( 'FULL', n, n, a, lda, af, lda )
146 CALL zlacpy( 'FULL', n, n, b, ldb, bf, ldb )
147*
148 CALL zggbal( 'B', n, a, lda, b, ldb, ilo, ihi, lscale, rscale,
149 $ rwork, info )
150 IF( info.NE.0 ) THEN
151 ninfo = ninfo + 1
152 lmax( 1 ) = knt
153 END IF
154*
155 CALL zlacpy( 'FULL', n, m, vl, ldvl, vlf, ldvl )
156 CALL zlacpy( 'FULL', n, m, vr, ldvr, vrf, ldvr )
157*
158 CALL zggbak( 'B', 'L', n, ilo, ihi, lscale, rscale, m, vl, ldvl,
159 $ info )
160 IF( info.NE.0 ) THEN
161 ninfo = ninfo + 1
162 lmax( 2 ) = knt
163 END IF
164*
165 CALL zggbak( 'B', 'R', n, ilo, ihi, lscale, rscale, m, vr, ldvr,
166 $ info )
167 IF( info.NE.0 ) THEN
168 ninfo = ninfo + 1
169 lmax( 3 ) = knt
170 END IF
171*
172* Test of ZGGBAK
173*
174* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
175* where tilde(A) denotes the transformed matrix.
176*
177 CALL zgemm( 'N', 'N', n, m, n, cone, af, lda, vr, ldvr, czero,
178 $ work, ldwork )
179 CALL zgemm( 'C', 'N', m, m, n, cone, vl, ldvl, work, ldwork,
180 $ czero, e, lde )
181*
182 CALL zgemm( 'N', 'N', n, m, n, cone, a, lda, vrf, ldvr, czero,
183 $ work, ldwork )
184 CALL zgemm( 'C', 'N', m, m, n, cone, vlf, ldvl, work, ldwork,
185 $ czero, f, ldf )
186*
187 vmax = zero
188 DO 70 j = 1, m
189 DO 60 i = 1, m
190 vmax = max( vmax, cabs1( e( i, j )-f( i, j ) ) )
191 60 CONTINUE
192 70 CONTINUE
193 vmax = vmax / ( eps*max( anorm, bnorm ) )
194 IF( vmax.GT.rmax ) THEN
195 lmax( 4 ) = knt
196 rmax = vmax
197 END IF
198*
199* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR
200*
201 CALL zgemm( 'N', 'N', n, m, n, cone, bf, ldb, vr, ldvr, czero,
202 $ work, ldwork )
203 CALL zgemm( 'C', 'N', m, m, n, cone, vl, ldvl, work, ldwork,
204 $ czero, e, lde )
205*
206 CALL zgemm( 'n', 'n', n, m, n, cone, b, ldb, vrf, ldvr, czero,
207 $ work, ldwork )
208 CALL zgemm( 'C', 'N', m, m, n, cone, vlf, ldvl, work, ldwork,
209 $ czero, f, ldf )
210*
211 vmax = zero
212 DO 90 j = 1, m
213 DO 80 i = 1, m
214 vmax = max( vmax, cabs1( e( i, j )-f( i, j ) ) )
215 80 CONTINUE
216 90 CONTINUE
217 vmax = vmax / ( eps*max( anorm, bnorm ) )
218 IF( vmax.GT.rmax ) THEN
219 lmax( 4 ) = knt
220 rmax = vmax
221 END IF
222*
223 GO TO 10
224*
225 100 CONTINUE
226*
227 WRITE( nout, fmt = 9999 )
228 9999 FORMAT( 1x, '.. test output of ZGGBAK .. ' )
229*
230 WRITE( nout, fmt = 9998 )rmax
231 9998 FORMAT( ' value of largest test error =', d12.3 )
232 WRITE( nout, fmt = 9997 )lmax( 1 )
233 9997 FORMAT( ' example number where ZGGBAL info is not 0 =', i4 )
234 WRITE( nout, fmt = 9996 )lmax( 2 )
235 9996 FORMAT( ' example number where ZGGBAK(L) info is not 0 =', i4 )
236 WRITE( nout, fmt = 9995 )lmax( 3 )
237 9995 FORMAT( ' example number where ZGGBAK(R) info is not 0 =', i4 )
238 WRITE( nout, fmt = 9994 )lmax( 4 )
239 9994 FORMAT( ' example number having largest error =', i4 )
240 WRITE( nout, fmt = 9992 )ninfo
241 9992 FORMAT( ' number of examples where info is not 0 =', i4 )
242 WRITE( nout, fmt = 9991 )knt
243 9991 FORMAT( ' total number of examples tested =', i4 )
244*
245 RETURN
246*
247* End of ZCHKGK
248*
zggbak
subroutine zggbak(job, side, n, ilo, ihi, lscale, rscale, m, v, ldv, info)
ZGGBAK
Definition zggbak.f:148
zggbal
subroutine zggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, work, info)
ZGGBAL
Definition zggbal.f:177

◆ zchkgl()

subroutine zchkgl ( integer nin,
integer nout )

ZCHKGL

Purpose:
!>
!> ZCHKGL tests ZGGBAL, a routine for balancing a matrix pair (A, B).
!>
Parameters
[in]NIN
!>          NIN is INTEGER
!>          The logical unit number for input.  NIN > 0.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The logical unit number for output.  NOUT > 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 52 of file zchkgl.f.

53*
54* -- LAPACK test routine --
55* -- LAPACK is a software package provided by Univ. of Tennessee, --
56* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
57*
58* .. Scalar Arguments ..
59 INTEGER NIN, NOUT
60* ..
61*
62* =====================================================================
63*
64* .. Parameters ..
65 INTEGER LDA, LDB, LWORK
66 parameter( lda = 20, ldb = 20, lwork = 6*lda )
67 DOUBLE PRECISION ZERO
68 parameter( zero = 0.0d+0 )
69* ..
70* .. Local Scalars ..
71 INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
72 $ NINFO
73 DOUBLE PRECISION ANORM, BNORM, EPS, RMAX, VMAX
74* ..
75* .. Local Arrays ..
76 INTEGER LMAX( 3 )
77 DOUBLE PRECISION LSCALE( LDA ), LSCLIN( LDA ), RSCALE( LDA ),
78 $ RSCLIN( LDA ), WORK( LWORK )
79 COMPLEX*16 A( LDA, LDA ), AIN( LDA, LDA ), B( LDB, LDB ),
80 $ BIN( LDB, LDB )
81* ..
82* .. External Functions ..
83 DOUBLE PRECISION DLAMCH, ZLANGE
84 EXTERNAL dlamch, zlange
85* ..
86* .. External Subroutines ..
87 EXTERNAL zggbal
88* ..
89* .. Intrinsic Functions ..
90 INTRINSIC abs, max
91* ..
92* .. Executable Statements ..
93*
94 lmax( 1 ) = 0
95 lmax( 2 ) = 0
96 lmax( 3 ) = 0
97 ninfo = 0
98 knt = 0
99 rmax = zero
100*
101 eps = dlamch( 'Precision' )
102*
103 10 CONTINUE
104*
105 READ( nin, fmt = * )n
106 IF( n.EQ.0 )
107 $ GO TO 90
108 DO 20 i = 1, n
109 READ( nin, fmt = * )( a( i, j ), j = 1, n )
110 20 CONTINUE
111*
112 DO 30 i = 1, n
113 READ( nin, fmt = * )( b( i, j ), j = 1, n )
114 30 CONTINUE
115*
116 READ( nin, fmt = * )iloin, ihiin
117 DO 40 i = 1, n
118 READ( nin, fmt = * )( ain( i, j ), j = 1, n )
119 40 CONTINUE
120 DO 50 i = 1, n
121 READ( nin, fmt = * )( bin( i, j ), j = 1, n )
122 50 CONTINUE
123*
124 READ( nin, fmt = * )( lsclin( i ), i = 1, n )
125 READ( nin, fmt = * )( rsclin( i ), i = 1, n )
126*
127 anorm = zlange( 'M', n, n, a, lda, work )
128 bnorm = zlange( 'M', n, n, b, ldb, work )
129*
130 knt = knt + 1
131*
132 CALL zggbal( 'B', n, a, lda, b, ldb, ilo, ihi, lscale, rscale,
133 $ work, info )
134*
135 IF( info.NE.0 ) THEN
136 ninfo = ninfo + 1
137 lmax( 1 ) = knt
138 END IF
139*
140 IF( ilo.NE.iloin .OR. ihi.NE.ihiin ) THEN
141 ninfo = ninfo + 1
142 lmax( 2 ) = knt
143 END IF
144*
145 vmax = zero
146 DO 70 i = 1, n
147 DO 60 j = 1, n
148 vmax = max( vmax, abs( a( i, j )-ain( i, j ) ) )
149 vmax = max( vmax, abs( b( i, j )-bin( i, j ) ) )
150 60 CONTINUE
151 70 CONTINUE
152*
153 DO 80 i = 1, n
154 vmax = max( vmax, abs( lscale( i )-lsclin( i ) ) )
155 vmax = max( vmax, abs( rscale( i )-rsclin( i ) ) )
156 80 CONTINUE
157*
158 vmax = vmax / ( eps*max( anorm, bnorm ) )
159*
160 IF( vmax.GT.rmax ) THEN
161 lmax( 3 ) = knt
162 rmax = vmax
163 END IF
164*
165 GO TO 10
166*
167 90 CONTINUE
168*
169 WRITE( nout, fmt = 9999 )
170 9999 FORMAT( ' .. test output of ZGGBAL .. ' )
171*
172 WRITE( nout, fmt = 9998 )rmax
173 9998 FORMAT( ' ratio of largest test error = ', d12.3 )
174 WRITE( nout, fmt = 9997 )lmax( 1 )
175 9997 FORMAT( ' example number where info is not zero = ', i4 )
176 WRITE( nout, fmt = 9996 )lmax( 2 )
177 9996 FORMAT( ' example number where ILO or IHI is wrong = ', i4 )
178 WRITE( nout, fmt = 9995 )lmax( 3 )
179 9995 FORMAT( ' example number having largest error = ', i4 )
180 WRITE( nout, fmt = 9994 )ninfo
181 9994 FORMAT( ' number of examples where info is not 0 = ', i4 )
182 WRITE( nout, fmt = 9993 )knt
183 9993 FORMAT( ' total number of examples tested = ', i4 )
184*
185 RETURN
186*
187* End of ZCHKGL
188*

◆ zchkhb()

subroutine zchkhb ( integer nsizes,
integer, dimension( * ) nn,
integer nwdths,
integer, dimension( * ) kk,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) sd,
double precision, dimension( * ) se,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result,
integer info )

ZCHKHB

Purpose:
!>
!> ZCHKHB tests the reduction of a Hermitian band matrix to tridiagonal
!> from, used with the Hermitian eigenvalue problem.
!>
!> ZHBTRD factors a Hermitian band matrix A as  U S U* , where * means
!> conjugate transpose, S is symmetric tridiagonal, and U is unitary.
!> ZHBTRD can use either just the lower or just the upper triangle
!> of A; ZCHKHB checks both cases.
!>
!> When ZCHKHB is called, a number of matrix  (), a number
!> of bandwidths (), and a number of matrix  are
!> specified.  For each size (), each bandwidth () less than or
!> equal to , and each type of matrix, one matrix will be generated
!> and used to test the hermitian banded reduction routine.  For each
!> matrix, a number of tests will be performed:
!>
!> (1)     | A - V S V* | / ( |A| n ulp )  computed by ZHBTRD with
!>                                         UPLO='U'
!>
!> (2)     | I - UU* | / ( n ulp )
!>
!> (3)     | A - V S V* | / ( |A| n ulp )  computed by ZHBTRD with
!>                                         UPLO='L'
!>
!> (4)     | I - UU* | / ( n ulp )
!>
!> The  are specified by an array NN(1:NSIZES); the value of
!> each element NN(j) specifies one size.
!> The  are specified by a logical array DOTYPE( 1:NTYPES );
!> if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!> Currently, the list of possible types is:
!>
!> (1)  The zero matrix.
!> (2)  The identity matrix.
!>
!> (3)  A diagonal matrix with evenly spaced entries
!>      1, ..., ULP  and random signs.
!>      (ULP = (first number larger than 1) - 1 )
!> (4)  A diagonal matrix with geometrically spaced entries
!>      1, ..., ULP  and random signs.
!> (5)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>      and random signs.
!>
!> (6)  Same as (4), but multiplied by SQRT( overflow threshold )
!> (7)  Same as (4), but multiplied by SQRT( underflow threshold )
!>
!> (8)  A matrix of the form  U* D U, where U is unitary and
!>      D has evenly spaced entries 1, ..., ULP with random signs
!>      on the diagonal.
!>
!> (9)  A matrix of the form  U* D U, where U is unitary and
!>      D has geometrically spaced entries 1, ..., ULP with random
!>      signs on the diagonal.
!>
!> (10) A matrix of the form  U* D U, where U is unitary and
!>      D has  entries 1, ULP,..., ULP with random
!>      signs on the diagonal.
!>
!> (11) Same as (8), but multiplied by SQRT( overflow threshold )
!> (12) Same as (8), but multiplied by SQRT( underflow threshold )
!>
!> (13) Hermitian matrix with random entries chosen from (-1,1).
!> (14) Same as (13), but multiplied by SQRT( overflow threshold )
!> (15) Same as (13), but multiplied by SQRT( underflow threshold )
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZCHKHB does nothing.  It must be at least zero.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>
[in]NWDTHS
!>          NWDTHS is INTEGER
!>          The number of bandwidths to use.  If it is zero,
!>          ZCHKHB does nothing.  It must be at least zero.
!>
[in]KK
!>          KK is INTEGER array, dimension (NWDTHS)
!>          An array containing the bandwidths to be used for the band
!>          matrices.  The values must be at least zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZCHKHB
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZCHKHB to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension
!>                            (LDA, max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 2 (not 1!)
!>          and at least max( KK )+1.
!>
[out]SD
!>          SD is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the diagonal of the tridiagonal matrix computed
!>          by ZHBTRD.
!>
[out]SE
!>          SE is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the off-diagonal of the tridiagonal matrix
!>          computed by ZHBTRD.
!>
[out]U
!>          U is COMPLEX*16 array, dimension (LDU, max(NN))
!>          Used to hold the unitary matrix computed by ZHBTRD.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  It must be at least 1
!>          and at least max( NN ).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          max( LDA+1, max(NN)+1 )*max(NN).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far.
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 295 of file zchkhb.f.

298*
299* -- LAPACK test routine --
300* -- LAPACK is a software package provided by Univ. of Tennessee, --
301* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
302*
303* .. Scalar Arguments ..
304 INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES,
305 $ NWDTHS
306 DOUBLE PRECISION THRESH
307* ..
308* .. Array Arguments ..
309 LOGICAL DOTYPE( * )
310 INTEGER ISEED( 4 ), KK( * ), NN( * )
311 DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * )
312 COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * )
313* ..
314*
315* =====================================================================
316*
317* .. Parameters ..
318 COMPLEX*16 CZERO, CONE
319 parameter( czero = ( 0.0d+0, 0.0d+0 ),
320 $ cone = ( 1.0d+0, 0.0d+0 ) )
321 DOUBLE PRECISION ZERO, ONE, TWO, TEN
322 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
323 $ ten = 10.0d+0 )
324 DOUBLE PRECISION HALF
325 parameter( half = one / two )
326 INTEGER MAXTYP
327 parameter( maxtyp = 15 )
328* ..
329* .. Local Scalars ..
330 LOGICAL BADNN, BADNNB
331 INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE,
332 $ JTYPE, JWIDTH, K, KMAX, MTYPES, N, NERRS,
333 $ NMATS, NMAX, NTEST, NTESTT
334 DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
335 $ TEMP1, ULP, ULPINV, UNFL
336* ..
337* .. Local Arrays ..
338 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
339 $ KMODE( MAXTYP ), KTYPE( MAXTYP )
340* ..
341* .. External Functions ..
342 DOUBLE PRECISION DLAMCH
343 EXTERNAL dlamch
344* ..
345* .. External Subroutines ..
346 EXTERNAL dlasum, xerbla, zhbt21, zhbtrd, zlacpy, zlaset,
347 $ zlatmr, zlatms
348* ..
349* .. Intrinsic Functions ..
350 INTRINSIC abs, dble, dconjg, max, min, sqrt
351* ..
352* .. Data statements ..
353 DATA ktype / 1, 2, 5*4, 5*5, 3*8 /
354 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
355 $ 2, 3 /
356 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
357 $ 0, 0 /
358* ..
359* .. Executable Statements ..
360*
361* Check for errors
362*
363 ntestt = 0
364 info = 0
365*
366* Important constants
367*
368 badnn = .false.
369 nmax = 1
370 DO 10 j = 1, nsizes
371 nmax = max( nmax, nn( j ) )
372 IF( nn( j ).LT.0 )
373 $ badnn = .true.
374 10 CONTINUE
375*
376 badnnb = .false.
377 kmax = 0
378 DO 20 j = 1, nsizes
379 kmax = max( kmax, kk( j ) )
380 IF( kk( j ).LT.0 )
381 $ badnnb = .true.
382 20 CONTINUE
383 kmax = min( nmax-1, kmax )
384*
385* Check for errors
386*
387 IF( nsizes.LT.0 ) THEN
388 info = -1
389 ELSE IF( badnn ) THEN
390 info = -2
391 ELSE IF( nwdths.LT.0 ) THEN
392 info = -3
393 ELSE IF( badnnb ) THEN
394 info = -4
395 ELSE IF( ntypes.LT.0 ) THEN
396 info = -5
397 ELSE IF( lda.LT.kmax+1 ) THEN
398 info = -11
399 ELSE IF( ldu.LT.nmax ) THEN
400 info = -15
401 ELSE IF( ( max( lda, nmax )+1 )*nmax.GT.lwork ) THEN
402 info = -17
403 END IF
404*
405 IF( info.NE.0 ) THEN
406 CALL xerbla( 'ZCHKHB', -info )
407 RETURN
408 END IF
409*
410* Quick return if possible
411*
412 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
413 $ RETURN
414*
415* More Important constants
416*
417 unfl = dlamch( 'Safe minimum' )
418 ovfl = one / unfl
419 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
420 ulpinv = one / ulp
421 rtunfl = sqrt( unfl )
422 rtovfl = sqrt( ovfl )
423*
424* Loop over sizes, types
425*
426 nerrs = 0
427 nmats = 0
428*
429 DO 190 jsize = 1, nsizes
430 n = nn( jsize )
431 aninv = one / dble( max( 1, n ) )
432*
433 DO 180 jwidth = 1, nwdths
434 k = kk( jwidth )
435 IF( k.GT.n )
436 $ GO TO 180
437 k = max( 0, min( n-1, k ) )
438*
439 IF( nsizes.NE.1 ) THEN
440 mtypes = min( maxtyp, ntypes )
441 ELSE
442 mtypes = min( maxtyp+1, ntypes )
443 END IF
444*
445 DO 170 jtype = 1, mtypes
446 IF( .NOT.dotype( jtype ) )
447 $ GO TO 170
448 nmats = nmats + 1
449 ntest = 0
450*
451 DO 30 j = 1, 4
452 ioldsd( j ) = iseed( j )
453 30 CONTINUE
454*
455* Compute "A".
456* Store as "Upper"; later, we will copy to other format.
457*
458* Control parameters:
459*
460* KMAGN KMODE KTYPE
461* =1 O(1) clustered 1 zero
462* =2 large clustered 2 identity
463* =3 small exponential (none)
464* =4 arithmetic diagonal, (w/ eigenvalues)
465* =5 random log hermitian, w/ eigenvalues
466* =6 random (none)
467* =7 random diagonal
468* =8 random hermitian
469* =9 positive definite
470* =10 diagonally dominant tridiagonal
471*
472 IF( mtypes.GT.maxtyp )
473 $ GO TO 100
474*
475 itype = ktype( jtype )
476 imode = kmode( jtype )
477*
478* Compute norm
479*
480 GO TO ( 40, 50, 60 )kmagn( jtype )
481*
482 40 CONTINUE
483 anorm = one
484 GO TO 70
485*
486 50 CONTINUE
487 anorm = ( rtovfl*ulp )*aninv
488 GO TO 70
489*
490 60 CONTINUE
491 anorm = rtunfl*n*ulpinv
492 GO TO 70
493*
494 70 CONTINUE
495*
496 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
497 iinfo = 0
498 IF( jtype.LE.15 ) THEN
499 cond = ulpinv
500 ELSE
501 cond = ulpinv*aninv / ten
502 END IF
503*
504* Special Matrices -- Identity & Jordan block
505*
506* Zero
507*
508 IF( itype.EQ.1 ) THEN
509 iinfo = 0
510*
511 ELSE IF( itype.EQ.2 ) THEN
512*
513* Identity
514*
515 DO 80 jcol = 1, n
516 a( k+1, jcol ) = anorm
517 80 CONTINUE
518*
519 ELSE IF( itype.EQ.4 ) THEN
520*
521* Diagonal Matrix, [Eigen]values Specified
522*
523 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode,
524 $ cond, anorm, 0, 0, 'Q', a( k+1, 1 ), lda,
525 $ work, iinfo )
526*
527 ELSE IF( itype.EQ.5 ) THEN
528*
529* Hermitian, eigenvalues specified
530*
531 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode,
532 $ cond, anorm, k, k, 'Q', a, lda, work,
533 $ iinfo )
534*
535 ELSE IF( itype.EQ.7 ) THEN
536*
537* Diagonal, random eigenvalues
538*
539 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one,
540 $ cone, 'T', 'N', work( n+1 ), 1, one,
541 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
542 $ zero, anorm, 'Q', a( k+1, 1 ), lda,
543 $ idumma, iinfo )
544*
545 ELSE IF( itype.EQ.8 ) THEN
546*
547* Hermitian, random eigenvalues
548*
549 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one,
550 $ cone, 'T', 'N', work( n+1 ), 1, one,
551 $ work( 2*n+1 ), 1, one, 'N', idumma, k, k,
552 $ zero, anorm, 'Q', a, lda, idumma, iinfo )
553*
554 ELSE IF( itype.EQ.9 ) THEN
555*
556* Positive definite, eigenvalues specified.
557*
558 CALL zlatms( n, n, 'S', iseed, 'P', rwork, imode,
559 $ cond, anorm, k, k, 'Q', a, lda,
560 $ work( n+1 ), iinfo )
561*
562 ELSE IF( itype.EQ.10 ) THEN
563*
564* Positive definite tridiagonal, eigenvalues specified.
565*
566 IF( n.GT.1 )
567 $ k = max( 1, k )
568 CALL zlatms( n, n, 'S', iseed, 'P', rwork, imode,
569 $ cond, anorm, 1, 1, 'Q', a( k, 1 ), lda,
570 $ work, iinfo )
571 DO 90 i = 2, n
572 temp1 = abs( a( k, i ) ) /
573 $ sqrt( abs( a( k+1, i-1 )*a( k+1, i ) ) )
574 IF( temp1.GT.half ) THEN
575 a( k, i ) = half*sqrt( abs( a( k+1,
576 $ i-1 )*a( k+1, i ) ) )
577 END IF
578 90 CONTINUE
579*
580 ELSE
581*
582 iinfo = 1
583 END IF
584*
585 IF( iinfo.NE.0 ) THEN
586 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n,
587 $ jtype, ioldsd
588 info = abs( iinfo )
589 RETURN
590 END IF
591*
592 100 CONTINUE
593*
594* Call ZHBTRD to compute S and U from upper triangle.
595*
596 CALL zlacpy( ' ', k+1, n, a, lda, work, lda )
597*
598 ntest = 1
599 CALL zhbtrd( 'V', 'U', n, k, work, lda, sd, se, u, ldu,
600 $ work( lda*n+1 ), iinfo )
601*
602 IF( iinfo.NE.0 ) THEN
603 WRITE( nounit, fmt = 9999 )'ZHBTRD(U)', iinfo, n,
604 $ jtype, ioldsd
605 info = abs( iinfo )
606 IF( iinfo.LT.0 ) THEN
607 RETURN
608 ELSE
609 result( 1 ) = ulpinv
610 GO TO 150
611 END IF
612 END IF
613*
614* Do tests 1 and 2
615*
616 CALL zhbt21( 'Upper', n, k, 1, a, lda, sd, se, u, ldu,
617 $ work, rwork, result( 1 ) )
618*
619* Convert A from Upper-Triangle-Only storage to
620* Lower-Triangle-Only storage.
621*
622 DO 120 jc = 1, n
623 DO 110 jr = 0, min( k, n-jc )
624 a( jr+1, jc ) = dconjg( a( k+1-jr, jc+jr ) )
625 110 CONTINUE
626 120 CONTINUE
627 DO 140 jc = n + 1 - k, n
628 DO 130 jr = min( k, n-jc ) + 1, k
629 a( jr+1, jc ) = zero
630 130 CONTINUE
631 140 CONTINUE
632*
633* Call ZHBTRD to compute S and U from lower triangle
634*
635 CALL zlacpy( ' ', k+1, n, a, lda, work, lda )
636*
637 ntest = 3
638 CALL zhbtrd( 'V', 'L', n, k, work, lda, sd, se, u, ldu,
639 $ work( lda*n+1 ), iinfo )
640*
641 IF( iinfo.NE.0 ) THEN
642 WRITE( nounit, fmt = 9999 )'ZHBTRD(L)', iinfo, n,
643 $ jtype, ioldsd
644 info = abs( iinfo )
645 IF( iinfo.LT.0 ) THEN
646 RETURN
647 ELSE
648 result( 3 ) = ulpinv
649 GO TO 150
650 END IF
651 END IF
652 ntest = 4
653*
654* Do tests 3 and 4
655*
656 CALL zhbt21( 'Lower', n, k, 1, a, lda, sd, se, u, ldu,
657 $ work, rwork, result( 3 ) )
658*
659* End of Loop -- Check for RESULT(j) > THRESH
660*
661 150 CONTINUE
662 ntestt = ntestt + ntest
663*
664* Print out tests which fail.
665*
666 DO 160 jr = 1, ntest
667 IF( result( jr ).GE.thresh ) THEN
668*
669* If this is the first test to fail,
670* print a header to the data file.
671*
672 IF( nerrs.EQ.0 ) THEN
673 WRITE( nounit, fmt = 9998 )'ZHB'
674 WRITE( nounit, fmt = 9997 )
675 WRITE( nounit, fmt = 9996 )
676 WRITE( nounit, fmt = 9995 )'Hermitian'
677 WRITE( nounit, fmt = 9994 )'unitary', '*',
678 $ 'conjugate transpose', ( '*', j = 1, 4 )
679 END IF
680 nerrs = nerrs + 1
681 WRITE( nounit, fmt = 9993 )n, k, ioldsd, jtype,
682 $ jr, result( jr )
683 END IF
684 160 CONTINUE
685*
686 170 CONTINUE
687 180 CONTINUE
688 190 CONTINUE
689*
690* Summary
691*
692 CALL dlasum( 'ZHB', nounit, nerrs, ntestt )
693 RETURN
694*
695 9999 FORMAT( ' ZCHKHB: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
696 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
697 9998 FORMAT( / 1x, a3,
698 $ ' -- Complex Hermitian Banded Tridiagonal Reduction Routines'
699 $ )
700 9997 FORMAT( ' Matrix types (see DCHK23 for details): ' )
701*
702 9996 FORMAT( / ' Special Matrices:',
703 $ / ' 1=Zero matrix. ',
704 $ ' 5=Diagonal: clustered entries.',
705 $ / ' 2=Identity matrix. ',
706 $ ' 6=Diagonal: large, evenly spaced.',
707 $ / ' 3=Diagonal: evenly spaced entries. ',
708 $ ' 7=Diagonal: small, evenly spaced.',
709 $ / ' 4=Diagonal: geometr. spaced entries.' )
710 9995 FORMAT( ' Dense ', a, ' Banded Matrices:',
711 $ / ' 8=Evenly spaced eigenvals. ',
712 $ ' 12=Small, evenly spaced eigenvals.',
713 $ / ' 9=Geometrically spaced eigenvals. ',
714 $ ' 13=Matrix with random O(1) entries.',
715 $ / ' 10=Clustered eigenvalues. ',
716 $ ' 14=Matrix with large random entries.',
717 $ / ' 11=Large, evenly spaced eigenvals. ',
718 $ ' 15=Matrix with small random entries.' )
719*
720 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', a, ',',
721 $ / 20x, a, ' means ', a, '.', / ' UPLO=''U'':',
722 $ / ' 1= | A - U S U', a1, ' | / ( |A| n ulp ) ',
723 $ ' 2= | I - U U', a1, ' | / ( n ulp )', / ' UPLO=''L'':',
724 $ / ' 3= | A - U S U', a1, ' | / ( |A| n ulp ) ',
725 $ ' 4= | I - U U', a1, ' | / ( n ulp )' )
726 9993 FORMAT( ' N=', i5, ', K=', i4, ', seed=', 4( i4, ',' ), ' type ',
727 $ i2, ', test(', i2, ')=', g10.3 )
728*
729* End of ZCHKHB
730*
zhbtrd
subroutine zhbtrd(vect, uplo, n, kd, ab, ldab, d, e, q, ldq, work, info)
ZHBTRD
Definition zhbtrd.f:163
zhbt21
subroutine zhbt21(uplo, n, ka, ks, a, lda, d, e, u, ldu, work, rwork, result)
ZHBT21
Definition zhbt21.f:152

◆ zchkhb2stg()

subroutine zchkhb2stg ( integer nsizes,
integer, dimension( * ) nn,
integer nwdths,
integer, dimension( * ) kk,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) sd,
double precision, dimension( * ) se,
double precision, dimension( * ) d1,
double precision, dimension( * ) d2,
double precision, dimension( * ) d3,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result,
integer info )

ZCHKHB2STG

Purpose:
!>
!> ZCHKHB2STG tests the reduction of a Hermitian band matrix to tridiagonal
!> from, used with the Hermitian eigenvalue problem.
!>
!> ZHBTRD factors a Hermitian band matrix A as  U S U* , where * means
!> conjugate transpose, S is symmetric tridiagonal, and U is unitary.
!> ZHBTRD can use either just the lower or just the upper triangle
!> of A; ZCHKHB2STG checks both cases.
!>
!> ZHETRD_HB2ST factors a Hermitian band matrix A as  U S U* ,
!> where * means conjugate transpose, S is symmetric tridiagonal, and U is
!> unitary. ZHETRD_HB2ST can use either just the lower or just
!> the upper triangle of A; ZCHKHB2STG checks both cases.
!>
!> DSTEQR factors S as  Z D1 Z'.
!> D1 is the matrix of eigenvalues computed when Z is not computed
!> and from the S resulting of DSBTRD  (used as reference for DSYTRD_SB2ST)
!> D2 is the matrix of eigenvalues computed when Z is not computed
!> and from the S resulting of DSYTRD_SB2ST .
!> D3 is the matrix of eigenvalues computed when Z is not computed
!> and from the S resulting of DSYTRD_SB2ST .
!>
!> When ZCHKHB2STG is called, a number of matrix  (), a number
!> of bandwidths (), and a number of matrix  are
!> specified.  For each size (), each bandwidth () less than or
!> equal to , and each type of matrix, one matrix will be generated
!> and used to test the hermitian banded reduction routine.  For each
!> matrix, a number of tests will be performed:
!>
!> (1)     | A - V S V* | / ( |A| n ulp )  computed by ZHBTRD with
!>                                         UPLO='U'
!>
!> (2)     | I - UU* | / ( n ulp )
!>
!> (3)     | A - V S V* | / ( |A| n ulp )  computed by ZHBTRD with
!>                                         UPLO='L'
!>
!> (4)     | I - UU* | / ( n ulp )
!>
!> (5)     | D1 - D2 | / ( |D1| ulp )      where D1 is computed by
!>                                         DSBTRD with UPLO='U' and
!>                                         D2 is computed by
!>                                         ZHETRD_HB2ST with UPLO='U'
!>
!> (6)     | D1 - D3 | / ( |D1| ulp )      where D1 is computed by
!>                                         DSBTRD with UPLO='U' and
!>                                         D3 is computed by
!>                                         ZHETRD_HB2ST with UPLO='L'
!>
!> The  are specified by an array NN(1:NSIZES); the value of
!> each element NN(j) specifies one size.
!> The  are specified by a logical array DOTYPE( 1:NTYPES );
!> if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!> Currently, the list of possible types is:
!>
!> (1)  The zero matrix.
!> (2)  The identity matrix.
!>
!> (3)  A diagonal matrix with evenly spaced entries
!>      1, ..., ULP  and random signs.
!>      (ULP = (first number larger than 1) - 1 )
!> (4)  A diagonal matrix with geometrically spaced entries
!>      1, ..., ULP  and random signs.
!> (5)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>      and random signs.
!>
!> (6)  Same as (4), but multiplied by SQRT( overflow threshold )
!> (7)  Same as (4), but multiplied by SQRT( underflow threshold )
!>
!> (8)  A matrix of the form  U* D U, where U is unitary and
!>      D has evenly spaced entries 1, ..., ULP with random signs
!>      on the diagonal.
!>
!> (9)  A matrix of the form  U* D U, where U is unitary and
!>      D has geometrically spaced entries 1, ..., ULP with random
!>      signs on the diagonal.
!>
!> (10) A matrix of the form  U* D U, where U is unitary and
!>      D has  entries 1, ULP,..., ULP with random
!>      signs on the diagonal.
!>
!> (11) Same as (8), but multiplied by SQRT( overflow threshold )
!> (12) Same as (8), but multiplied by SQRT( underflow threshold )
!>
!> (13) Hermitian matrix with random entries chosen from (-1,1).
!> (14) Same as (13), but multiplied by SQRT( overflow threshold )
!> (15) Same as (13), but multiplied by SQRT( underflow threshold )
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZCHKHB2STG does nothing.  It must be at least zero.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>
[in]NWDTHS
!>          NWDTHS is INTEGER
!>          The number of bandwidths to use.  If it is zero,
!>          ZCHKHB2STG does nothing.  It must be at least zero.
!>
[in]KK
!>          KK is INTEGER array, dimension (NWDTHS)
!>          An array containing the bandwidths to be used for the band
!>          matrices.  The values must be at least zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZCHKHB2STG
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZCHKHB2STG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension
!>                            (LDA, max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 2 (not 1!)
!>          and at least max( KK )+1.
!>
[out]SD
!>          SD is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the diagonal of the tridiagonal matrix computed
!>          by ZHBTRD.
!>
[out]SE
!>          SE is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the off-diagonal of the tridiagonal matrix
!>          computed by ZHBTRD.
!>
[out]D1
!>          D1 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]D2
!>          D2 is DOUBLE PRECISION array, dimension (max(NN))
!>
*>
[out]D3
!>          D3 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]U
!>          U is COMPLEX*16 array, dimension (LDU, max(NN))
!>          Used to hold the unitary matrix computed by ZHBTRD.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  It must be at least 1
!>          and at least max( NN ).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          max( LDA+1, max(NN)+1 )*max(NN).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far.
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 334 of file zchkhb2stg.f.

338*
339* -- LAPACK test routine --
340* -- LAPACK is a software package provided by Univ. of Tennessee, --
341* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
342*
343* .. Scalar Arguments ..
344 INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES,
345 $ NWDTHS
346 DOUBLE PRECISION THRESH
347* ..
348* .. Array Arguments ..
349 LOGICAL DOTYPE( * )
350 INTEGER ISEED( 4 ), KK( * ), NN( * )
351 DOUBLE PRECISION RESULT( * ), RWORK( * ), SD( * ), SE( * ),
352 $ D1( * ), D2( * ), D3( * )
353 COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * )
354* ..
355*
356* =====================================================================
357*
358* .. Parameters ..
359 COMPLEX*16 CZERO, CONE
360 parameter( czero = ( 0.0d+0, 0.0d+0 ),
361 $ cone = ( 1.0d+0, 0.0d+0 ) )
362 DOUBLE PRECISION ZERO, ONE, TWO, TEN
363 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
364 $ ten = 10.0d+0 )
365 DOUBLE PRECISION HALF
366 parameter( half = one / two )
367 INTEGER MAXTYP
368 parameter( maxtyp = 15 )
369* ..
370* .. Local Scalars ..
371 LOGICAL BADNN, BADNNB
372 INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE,
373 $ JTYPE, JWIDTH, K, KMAX, LH, LW, MTYPES, N,
374 $ NERRS, NMATS, NMAX, NTEST, NTESTT
375 DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
376 $ TEMP1, TEMP2, TEMP3, TEMP4, ULP, ULPINV, UNFL
377* ..
378* .. Local Arrays ..
379 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
380 $ KMODE( MAXTYP ), KTYPE( MAXTYP )
381* ..
382* .. External Functions ..
383 DOUBLE PRECISION DLAMCH
384 EXTERNAL dlamch
385* ..
386* .. External Subroutines ..
387 EXTERNAL dlasum, xerbla, zhbt21, zhbtrd, zlacpy, zlaset,
388 $ zlatmr, zlatms, zhetrd_hb2st, zsteqr
389* ..
390* .. Intrinsic Functions ..
391 INTRINSIC abs, dble, dconjg, max, min, sqrt
392* ..
393* .. Data statements ..
394 DATA ktype / 1, 2, 5*4, 5*5, 3*8 /
395 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
396 $ 2, 3 /
397 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
398 $ 0, 0 /
399* ..
400* .. Executable Statements ..
401*
402* Check for errors
403*
404 ntestt = 0
405 info = 0
406*
407* Important constants
408*
409 badnn = .false.
410 nmax = 1
411 DO 10 j = 1, nsizes
412 nmax = max( nmax, nn( j ) )
413 IF( nn( j ).LT.0 )
414 $ badnn = .true.
415 10 CONTINUE
416*
417 badnnb = .false.
418 kmax = 0
419 DO 20 j = 1, nsizes
420 kmax = max( kmax, kk( j ) )
421 IF( kk( j ).LT.0 )
422 $ badnnb = .true.
423 20 CONTINUE
424 kmax = min( nmax-1, kmax )
425*
426* Check for errors
427*
428 IF( nsizes.LT.0 ) THEN
429 info = -1
430 ELSE IF( badnn ) THEN
431 info = -2
432 ELSE IF( nwdths.LT.0 ) THEN
433 info = -3
434 ELSE IF( badnnb ) THEN
435 info = -4
436 ELSE IF( ntypes.LT.0 ) THEN
437 info = -5
438 ELSE IF( lda.LT.kmax+1 ) THEN
439 info = -11
440 ELSE IF( ldu.LT.nmax ) THEN
441 info = -15
442 ELSE IF( ( max( lda, nmax )+1 )*nmax.GT.lwork ) THEN
443 info = -17
444 END IF
445*
446 IF( info.NE.0 ) THEN
447 CALL xerbla( 'ZCHKHB2STG', -info )
448 RETURN
449 END IF
450*
451* Quick return if possible
452*
453 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
454 $ RETURN
455*
456* More Important constants
457*
458 unfl = dlamch( 'Safe minimum' )
459 ovfl = one / unfl
460 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
461 ulpinv = one / ulp
462 rtunfl = sqrt( unfl )
463 rtovfl = sqrt( ovfl )
464*
465* Loop over sizes, types
466*
467 nerrs = 0
468 nmats = 0
469*
470 DO 190 jsize = 1, nsizes
471 n = nn( jsize )
472 aninv = one / dble( max( 1, n ) )
473*
474 DO 180 jwidth = 1, nwdths
475 k = kk( jwidth )
476 IF( k.GT.n )
477 $ GO TO 180
478 k = max( 0, min( n-1, k ) )
479*
480 IF( nsizes.NE.1 ) THEN
481 mtypes = min( maxtyp, ntypes )
482 ELSE
483 mtypes = min( maxtyp+1, ntypes )
484 END IF
485*
486 DO 170 jtype = 1, mtypes
487 IF( .NOT.dotype( jtype ) )
488 $ GO TO 170
489 nmats = nmats + 1
490 ntest = 0
491*
492 DO 30 j = 1, 4
493 ioldsd( j ) = iseed( j )
494 30 CONTINUE
495*
496* Compute "A".
497* Store as "Upper"; later, we will copy to other format.
498*
499* Control parameters:
500*
501* KMAGN KMODE KTYPE
502* =1 O(1) clustered 1 zero
503* =2 large clustered 2 identity
504* =3 small exponential (none)
505* =4 arithmetic diagonal, (w/ eigenvalues)
506* =5 random log hermitian, w/ eigenvalues
507* =6 random (none)
508* =7 random diagonal
509* =8 random hermitian
510* =9 positive definite
511* =10 diagonally dominant tridiagonal
512*
513 IF( mtypes.GT.maxtyp )
514 $ GO TO 100
515*
516 itype = ktype( jtype )
517 imode = kmode( jtype )
518*
519* Compute norm
520*
521 GO TO ( 40, 50, 60 )kmagn( jtype )
522*
523 40 CONTINUE
524 anorm = one
525 GO TO 70
526*
527 50 CONTINUE
528 anorm = ( rtovfl*ulp )*aninv
529 GO TO 70
530*
531 60 CONTINUE
532 anorm = rtunfl*n*ulpinv
533 GO TO 70
534*
535 70 CONTINUE
536*
537 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
538 iinfo = 0
539 IF( jtype.LE.15 ) THEN
540 cond = ulpinv
541 ELSE
542 cond = ulpinv*aninv / ten
543 END IF
544*
545* Special Matrices -- Identity & Jordan block
546*
547* Zero
548*
549 IF( itype.EQ.1 ) THEN
550 iinfo = 0
551*
552 ELSE IF( itype.EQ.2 ) THEN
553*
554* Identity
555*
556 DO 80 jcol = 1, n
557 a( k+1, jcol ) = anorm
558 80 CONTINUE
559*
560 ELSE IF( itype.EQ.4 ) THEN
561*
562* Diagonal Matrix, [Eigen]values Specified
563*
564 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode,
565 $ cond, anorm, 0, 0, 'Q', a( k+1, 1 ), lda,
566 $ work, iinfo )
567*
568 ELSE IF( itype.EQ.5 ) THEN
569*
570* Hermitian, eigenvalues specified
571*
572 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode,
573 $ cond, anorm, k, k, 'Q', a, lda, work,
574 $ iinfo )
575*
576 ELSE IF( itype.EQ.7 ) THEN
577*
578* Diagonal, random eigenvalues
579*
580 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one,
581 $ cone, 'T', 'N', work( n+1 ), 1, one,
582 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
583 $ zero, anorm, 'Q', a( k+1, 1 ), lda,
584 $ idumma, iinfo )
585*
586 ELSE IF( itype.EQ.8 ) THEN
587*
588* Hermitian, random eigenvalues
589*
590 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one,
591 $ cone, 'T', 'N', work( n+1 ), 1, one,
592 $ work( 2*n+1 ), 1, one, 'N', idumma, k, k,
593 $ zero, anorm, 'Q', a, lda, idumma, iinfo )
594*
595 ELSE IF( itype.EQ.9 ) THEN
596*
597* Positive definite, eigenvalues specified.
598*
599 CALL zlatms( n, n, 'S', iseed, 'P', rwork, imode,
600 $ cond, anorm, k, k, 'Q', a, lda,
601 $ work( n+1 ), iinfo )
602*
603 ELSE IF( itype.EQ.10 ) THEN
604*
605* Positive definite tridiagonal, eigenvalues specified.
606*
607 IF( n.GT.1 )
608 $ k = max( 1, k )
609 CALL zlatms( n, n, 'S', iseed, 'P', rwork, imode,
610 $ cond, anorm, 1, 1, 'Q', a( k, 1 ), lda,
611 $ work, iinfo )
612 DO 90 i = 2, n
613 temp1 = abs( a( k, i ) ) /
614 $ sqrt( abs( a( k+1, i-1 )*a( k+1, i ) ) )
615 IF( temp1.GT.half ) THEN
616 a( k, i ) = half*sqrt( abs( a( k+1,
617 $ i-1 )*a( k+1, i ) ) )
618 END IF
619 90 CONTINUE
620*
621 ELSE
622*
623 iinfo = 1
624 END IF
625*
626 IF( iinfo.NE.0 ) THEN
627 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n,
628 $ jtype, ioldsd
629 info = abs( iinfo )
630 RETURN
631 END IF
632*
633 100 CONTINUE
634*
635* Call ZHBTRD to compute S and U from upper triangle.
636*
637 CALL zlacpy( ' ', k+1, n, a, lda, work, lda )
638*
639 ntest = 1
640 CALL zhbtrd( 'V', 'U', n, k, work, lda, sd, se, u, ldu,
641 $ work( lda*n+1 ), iinfo )
642*
643 IF( iinfo.NE.0 ) THEN
644 WRITE( nounit, fmt = 9999 )'ZHBTRD(U)', iinfo, n,
645 $ jtype, ioldsd
646 info = abs( iinfo )
647 IF( iinfo.LT.0 ) THEN
648 RETURN
649 ELSE
650 result( 1 ) = ulpinv
651 GO TO 150
652 END IF
653 END IF
654*
655* Do tests 1 and 2
656*
657 CALL zhbt21( 'Upper', n, k, 1, a, lda, sd, se, u, ldu,
658 $ work, rwork, result( 1 ) )
659*
660* Before converting A into lower for DSBTRD, run DSYTRD_SB2ST
661* otherwise matrix A will be converted to lower and then need
662* to be converted back to upper in order to run the upper case
663* ofDSYTRD_SB2ST
664*
665* Compute D1 the eigenvalues resulting from the tridiagonal
666* form using the DSBTRD and used as reference to compare
667* with the DSYTRD_SB2ST routine
668*
669* Compute D1 from the DSBTRD and used as reference for the
670* DSYTRD_SB2ST
671*
672 CALL dcopy( n, sd, 1, d1, 1 )
673 IF( n.GT.0 )
674 $ CALL dcopy( n-1, se, 1, rwork, 1 )
675*
676 CALL zsteqr( 'N', n, d1, rwork, work, ldu,
677 $ rwork( n+1 ), iinfo )
678 IF( iinfo.NE.0 ) THEN
679 WRITE( nounit, fmt = 9999 )'ZSTEQR(N)', iinfo, n,
680 $ jtype, ioldsd
681 info = abs( iinfo )
682 IF( iinfo.LT.0 ) THEN
683 RETURN
684 ELSE
685 result( 5 ) = ulpinv
686 GO TO 150
687 END IF
688 END IF
689*
690* DSYTRD_SB2ST Upper case is used to compute D2.
691* Note to set SD and SE to zero to be sure not reusing
692* the one from above. Compare it with D1 computed
693* using the DSBTRD.
694*
695 CALL dlaset( 'Full', n, 1, zero, zero, sd, n )
696 CALL dlaset( 'Full', n, 1, zero, zero, se, n )
697 CALL zlacpy( ' ', k+1, n, a, lda, u, ldu )
698 lh = max(1, 4*n)
699 lw = lwork - lh
700 CALL zhetrd_hb2st( 'N', 'N', "U", n, k, u, ldu, sd, se,
701 $ work, lh, work( lh+1 ), lw, iinfo )
702*
703* Compute D2 from the DSYTRD_SB2ST Upper case
704*
705 CALL dcopy( n, sd, 1, d2, 1 )
706 IF( n.GT.0 )
707 $ CALL dcopy( n-1, se, 1, rwork, 1 )
708*
709 CALL zsteqr( 'N', n, d2, rwork, work, ldu,
710 $ rwork( n+1 ), iinfo )
711 IF( iinfo.NE.0 ) THEN
712 WRITE( nounit, fmt = 9999 )'ZSTEQR(N)', iinfo, n,
713 $ jtype, ioldsd
714 info = abs( iinfo )
715 IF( iinfo.LT.0 ) THEN
716 RETURN
717 ELSE
718 result( 5 ) = ulpinv
719 GO TO 150
720 END IF
721 END IF
722*
723* Convert A from Upper-Triangle-Only storage to
724* Lower-Triangle-Only storage.
725*
726 DO 120 jc = 1, n
727 DO 110 jr = 0, min( k, n-jc )
728 a( jr+1, jc ) = dconjg( a( k+1-jr, jc+jr ) )
729 110 CONTINUE
730 120 CONTINUE
731 DO 140 jc = n + 1 - k, n
732 DO 130 jr = min( k, n-jc ) + 1, k
733 a( jr+1, jc ) = zero
734 130 CONTINUE
735 140 CONTINUE
736*
737* Call ZHBTRD to compute S and U from lower triangle
738*
739 CALL zlacpy( ' ', k+1, n, a, lda, work, lda )
740*
741 ntest = 3
742 CALL zhbtrd( 'V', 'L', n, k, work, lda, sd, se, u, ldu,
743 $ work( lda*n+1 ), iinfo )
744*
745 IF( iinfo.NE.0 ) THEN
746 WRITE( nounit, fmt = 9999 )'ZHBTRD(L)', iinfo, n,
747 $ jtype, ioldsd
748 info = abs( iinfo )
749 IF( iinfo.LT.0 ) THEN
750 RETURN
751 ELSE
752 result( 3 ) = ulpinv
753 GO TO 150
754 END IF
755 END IF
756 ntest = 4
757*
758* Do tests 3 and 4
759*
760 CALL zhbt21( 'Lower', n, k, 1, a, lda, sd, se, u, ldu,
761 $ work, rwork, result( 3 ) )
762*
763* DSYTRD_SB2ST Lower case is used to compute D3.
764* Note to set SD and SE to zero to be sure not reusing
765* the one from above. Compare it with D1 computed
766* using the DSBTRD.
767*
768 CALL dlaset( 'Full', n, 1, zero, zero, sd, n )
769 CALL dlaset( 'Full', n, 1, zero, zero, se, n )
770 CALL zlacpy( ' ', k+1, n, a, lda, u, ldu )
771 lh = max(1, 4*n)
772 lw = lwork - lh
773 CALL zhetrd_hb2st( 'N', 'N', "L", n, k, u, ldu, sd, se,
774 $ work, lh, work( lh+1 ), lw, iinfo )
775*
776* Compute D3 from the 2-stage Upper case
777*
778 CALL dcopy( n, sd, 1, d3, 1 )
779 IF( n.GT.0 )
780 $ CALL dcopy( n-1, se, 1, rwork, 1 )
781*
782 CALL zsteqr( 'N', n, d3, rwork, work, ldu,
783 $ rwork( n+1 ), iinfo )
784 IF( iinfo.NE.0 ) THEN
785 WRITE( nounit, fmt = 9999 )'ZSTEQR(N)', iinfo, n,
786 $ jtype, ioldsd
787 info = abs( iinfo )
788 IF( iinfo.LT.0 ) THEN
789 RETURN
790 ELSE
791 result( 6 ) = ulpinv
792 GO TO 150
793 END IF
794 END IF
795*
796*
797* Do Tests 3 and 4 which are similar to 11 and 12 but with the
798* D1 computed using the standard 1-stage reduction as reference
799*
800 ntest = 6
801 temp1 = zero
802 temp2 = zero
803 temp3 = zero
804 temp4 = zero
805*
806 DO 151 j = 1, n
807 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
808 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
809 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
810 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
811 151 CONTINUE
812*
813 result(5) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
814 result(6) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
815*
816* End of Loop -- Check for RESULT(j) > THRESH
817*
818 150 CONTINUE
819 ntestt = ntestt + ntest
820*
821* Print out tests which fail.
822*
823 DO 160 jr = 1, ntest
824 IF( result( jr ).GE.thresh ) THEN
825*
826* If this is the first test to fail,
827* print a header to the data file.
828*
829 IF( nerrs.EQ.0 ) THEN
830 WRITE( nounit, fmt = 9998 )'ZHB'
831 WRITE( nounit, fmt = 9997 )
832 WRITE( nounit, fmt = 9996 )
833 WRITE( nounit, fmt = 9995 )'Hermitian'
834 WRITE( nounit, fmt = 9994 )'unitary', '*',
835 $ 'conjugate transpose', ( '*', j = 1, 6 )
836 END IF
837 nerrs = nerrs + 1
838 WRITE( nounit, fmt = 9993 )n, k, ioldsd, jtype,
839 $ jr, result( jr )
840 END IF
841 160 CONTINUE
842*
843 170 CONTINUE
844 180 CONTINUE
845 190 CONTINUE
846*
847* Summary
848*
849 CALL dlasum( 'ZHB', nounit, nerrs, ntestt )
850 RETURN
851*
852 9999 FORMAT( ' ZCHKHB2STG: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
853 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
854 9998 FORMAT( / 1x, a3,
855 $ ' -- Complex Hermitian Banded Tridiagonal Reduction Routines'
856 $ )
857 9997 FORMAT( ' Matrix types (see DCHK23 for details): ' )
858*
859 9996 FORMAT( / ' Special Matrices:',
860 $ / ' 1=Zero matrix. ',
861 $ ' 5=Diagonal: clustered entries.',
862 $ / ' 2=Identity matrix. ',
863 $ ' 6=Diagonal: large, evenly spaced.',
864 $ / ' 3=Diagonal: evenly spaced entries. ',
865 $ ' 7=Diagonal: small, evenly spaced.',
866 $ / ' 4=Diagonal: geometr. spaced entries.' )
867 9995 FORMAT( ' Dense ', a, ' Banded Matrices:',
868 $ / ' 8=Evenly spaced eigenvals. ',
869 $ ' 12=Small, evenly spaced eigenvals.',
870 $ / ' 9=Geometrically spaced eigenvals. ',
871 $ ' 13=Matrix with random O(1) entries.',
872 $ / ' 10=Clustered eigenvalues. ',
873 $ ' 14=Matrix with large random entries.',
874 $ / ' 11=Large, evenly spaced eigenvals. ',
875 $ ' 15=Matrix with small random entries.' )
876*
877 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', a, ',',
878 $ / 20x, a, ' means ', a, '.', / ' UPLO=''U'':',
879 $ / ' 1= | A - U S U', a1, ' | / ( |A| n ulp ) ',
880 $ ' 2= | I - U U', a1, ' | / ( n ulp )', / ' UPLO=''L'':',
881 $ / ' 3= | A - U S U', a1, ' | / ( |A| n ulp ) ',
882 $ ' 4= | I - U U', a1, ' | / ( n ulp )' / ' Eig check:',
883 $ /' 5= | D1 - D2', '', ' | / ( |D1| ulp ) ',
884 $ ' 6= | D1 - D3', '', ' | / ( |D1| ulp ) ' )
885 9993 FORMAT( ' N=', i5, ', K=', i4, ', seed=', 4( i4, ',' ), ' type ',
886 $ i2, ', test(', i2, ')=', g10.3 )
887*
888* End of ZCHKHB2STG
889*
dlaset
subroutine dlaset(uplo, m, n, alpha, beta, a, lda)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition dlaset.f:110
zhetrd_hb2st
subroutine zhetrd_hb2st(stage1, vect, uplo, n, kd, ab, ldab, d, e, hous, lhous, work, lwork, info)
ZHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric tridiagonal form T
Definition zhetrd_hb2st.F:230
zsteqr
subroutine zsteqr(compz, n, d, e, z, ldz, work, info)
ZSTEQR
Definition zsteqr.f:132

◆ zchkhs()

subroutine zchkhs ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) h,
complex*16, dimension( lda, * ) t1,
complex*16, dimension( lda, * ) t2,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldu, * ) z,
complex*16, dimension( ldu, * ) uz,
complex*16, dimension( * ) w1,
complex*16, dimension( * ) w3,
complex*16, dimension( ldu, * ) evectl,
complex*16, dimension( ldu, * ) evectr,
complex*16, dimension( ldu, * ) evecty,
complex*16, dimension( ldu, * ) evectx,
complex*16, dimension( ldu, * ) uu,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
integer nwork,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
logical, dimension( * ) select,
double precision, dimension( 14 ) result,
integer info )

ZCHKHS

Purpose:
!>
!>    ZCHKHS  checks the nonsymmetric eigenvalue problem routines.
!>
!>            ZGEHRD factors A as  U H U' , where ' means conjugate
!>            transpose, H is hessenberg, and U is unitary.
!>
!>            ZUNGHR generates the unitary matrix U.
!>
!>            ZUNMHR multiplies a matrix by the unitary matrix U.
!>
!>            ZHSEQR factors H as  Z T Z' , where Z is unitary and T
!>            is upper triangular.  It also computes the eigenvalues,
!>            w(1), ..., w(n); we define a diagonal matrix W whose
!>            (diagonal) entries are the eigenvalues.
!>
!>            ZTREVC computes the left eigenvector matrix L and the
!>            right eigenvector matrix R for the matrix T.  The
!>            columns of L are the complex conjugates of the left
!>            eigenvectors of T.  The columns of R are the right
!>            eigenvectors of T.  L is lower triangular, and R is
!>            upper triangular.
!>
!>            ZHSEIN computes the left eigenvector matrix Y and the
!>            right eigenvector matrix X for the matrix H.  The
!>            columns of Y are the complex conjugates of the left
!>            eigenvectors of H.  The columns of X are the right
!>            eigenvectors of H.  Y is lower triangular, and X is
!>            upper triangular.
!>
!>    When ZCHKHS is called, a number of matrix  () and a
!>    number of matrix  are specified.  For each size ()
!>    and each type of matrix, one matrix will be generated and used
!>    to test the nonsymmetric eigenroutines.  For each matrix, 14
!>    tests will be performed:
!>
!>    (1)     | A - U H U**H | / ( |A| n ulp )
!>
!>    (2)     | I - UU**H | / ( n ulp )
!>
!>    (3)     | H - Z T Z**H | / ( |H| n ulp )
!>
!>    (4)     | I - ZZ**H | / ( n ulp )
!>
!>    (5)     | A - UZ H (UZ)**H | / ( |A| n ulp )
!>
!>    (6)     | I - UZ (UZ)**H | / ( n ulp )
!>
!>    (7)     | T(Z computed) - T(Z not computed) | / ( |T| ulp )
!>
!>    (8)     | W(Z computed) - W(Z not computed) | / ( |W| ulp )
!>
!>    (9)     | TR - RW | / ( |T| |R| ulp )
!>
!>    (10)    | L**H T - W**H L | / ( |T| |L| ulp )
!>
!>    (11)    | HX - XW | / ( |H| |X| ulp )
!>
!>    (12)    | Y**H H - W**H Y | / ( |H| |Y| ulp )
!>
!>    (13)    | AX - XW | / ( |A| |X| ulp )
!>
!>    (14)    | Y**H A - W**H Y | / ( |A| |Y| ulp )
!>
!>    The  are specified by an array NN(1:NSIZES); the value of
!>    each element NN(j) specifies one size.
!>    The  are specified by a logical array DOTYPE( 1:NTYPES );
!>    if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!>    Currently, the list of possible types is:
!>
!>    (1)  The zero matrix.
!>    (2)  The identity matrix.
!>    (3)  A (transposed) Jordan block, with 1's on the diagonal.
!>
!>    (4)  A diagonal matrix with evenly spaced entries
!>         1, ..., ULP  and random complex angles.
!>         (ULP = (first number larger than 1) - 1 )
!>    (5)  A diagonal matrix with geometrically spaced entries
!>         1, ..., ULP  and random complex angles.
!>    (6)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>         and random complex angles.
!>
!>    (7)  Same as (4), but multiplied by SQRT( overflow threshold )
!>    (8)  Same as (4), but multiplied by SQRT( underflow threshold )
!>
!>    (9)  A matrix of the form  U' T U, where U is unitary and
!>         T has evenly spaced entries 1, ..., ULP with random complex
!>         angles on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (10) A matrix of the form  U' T U, where U is unitary and
!>         T has geometrically spaced entries 1, ..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (11) A matrix of the form  U' T U, where U is unitary and
!>         T has  entries 1, ULP,..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (12) A matrix of the form  U' T U, where U is unitary and
!>         T has complex eigenvalues randomly chosen from
!>         ULP < |z| < 1   and random O(1) entries in the upper
!>         triangle.
!>
!>    (13) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
!>         with random complex angles on the diagonal and random O(1)
!>         entries in the upper triangle.
!>
!>    (14) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has geometrically spaced entries
!>         1, ..., ULP with random complex angles on the diagonal
!>         and random O(1) entries in the upper triangle.
!>
!>    (15) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has  entries 1, ULP,..., ULP
!>         with random complex angles on the diagonal and random O(1)
!>         entries in the upper triangle.
!>
!>    (16) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has complex eigenvalues randomly chosen
!>         from   ULP < |z| < 1   and random O(1) entries in the upper
!>         triangle.
!>
!>    (17) Same as (16), but multiplied by SQRT( overflow threshold )
!>    (18) Same as (16), but multiplied by SQRT( underflow threshold )
!>
!>    (19) Nonsymmetric matrix with random entries chosen from |z| < 1
!>    (20) Same as (19), but multiplied by SQRT( overflow threshold )
!>    (21) Same as (19), but multiplied by SQRT( underflow threshold )
!> 
!>  NSIZES - INTEGER
!>           The number of sizes of matrices to use.  If it is zero,
!>           ZCHKHS does nothing.  It must be at least zero.
!>           Not modified.
!>
!>  NN     - INTEGER array, dimension (NSIZES)
!>           An array containing the sizes to be used for the matrices.
!>           Zero values will be skipped.  The values must be at least
!>           zero.
!>           Not modified.
!>
!>  NTYPES - INTEGER
!>           The number of elements in DOTYPE.   If it is zero, ZCHKHS
!>           does nothing.  It must be at least zero.  If it is MAXTYP+1
!>           and NSIZES is 1, then an additional type, MAXTYP+1 is
!>           defined, which is to use whatever matrix is in A.  This
!>           is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>           DOTYPE(MAXTYP+1) is .TRUE. .
!>           Not modified.
!>
!>  DOTYPE - LOGICAL array, dimension (NTYPES)
!>           If DOTYPE(j) is .TRUE., then for each size in NN a
!>           matrix of that size and of type j will be generated.
!>           If NTYPES is smaller than the maximum number of types
!>           defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>           MAXTYP will not be generated.  If NTYPES is larger
!>           than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>           will be ignored.
!>           Not modified.
!>
!>  ISEED  - INTEGER array, dimension (4)
!>           On entry ISEED specifies the seed of the random number
!>           generator. The array elements should be between 0 and 4095;
!>           if not they will be reduced mod 4096.  Also, ISEED(4) must
!>           be odd.  The random number generator uses a linear
!>           congruential sequence limited to small integers, and so
!>           should produce machine independent random numbers. The
!>           values of ISEED are changed on exit, and can be used in the
!>           next call to ZCHKHS to continue the same random number
!>           sequence.
!>           Modified.
!>
!>  THRESH - DOUBLE PRECISION
!>           A test will count as  if the , computed as
!>           described above, exceeds THRESH.  Note that the error
!>           is scaled to be O(1), so THRESH should be a reasonably
!>           small multiple of 1, e.g., 10 or 100.  In particular,
!>           it should not depend on the precision (single vs. double)
!>           or the size of the matrix.  It must be at least zero.
!>           Not modified.
!>
!>  NOUNIT - INTEGER
!>           The FORTRAN unit number for printing out error messages
!>           (e.g., if a routine returns IINFO not equal to 0.)
!>           Not modified.
!>
!>  A      - COMPLEX*16 array, dimension (LDA,max(NN))
!>           Used to hold the matrix whose eigenvalues are to be
!>           computed.  On exit, A contains the last matrix actually
!>           used.
!>           Modified.
!>
!>  LDA    - INTEGER
!>           The leading dimension of A, H, T1 and T2.  It must be at
!>           least 1 and at least max( NN ).
!>           Not modified.
!>
!>  H      - COMPLEX*16 array, dimension (LDA,max(NN))
!>           The upper hessenberg matrix computed by ZGEHRD.  On exit,
!>           H contains the Hessenberg form of the matrix in A.
!>           Modified.
!>
!>  T1     - COMPLEX*16 array, dimension (LDA,max(NN))
!>           The Schur (=) matrix computed by ZHSEQR
!>           if Z is computed.  On exit, T1 contains the Schur form of
!>           the matrix in A.
!>           Modified.
!>
!>  T2     - COMPLEX*16 array, dimension (LDA,max(NN))
!>           The Schur matrix computed by ZHSEQR when Z is not computed.
!>           This should be identical to T1.
!>           Modified.
!>
!>  LDU    - INTEGER
!>           The leading dimension of U, Z, UZ and UU.  It must be at
!>           least 1 and at least max( NN ).
!>           Not modified.
!>
!>  U      - COMPLEX*16 array, dimension (LDU,max(NN))
!>           The unitary matrix computed by ZGEHRD.
!>           Modified.
!>
!>  Z      - COMPLEX*16 array, dimension (LDU,max(NN))
!>           The unitary matrix computed by ZHSEQR.
!>           Modified.
!>
!>  UZ     - COMPLEX*16 array, dimension (LDU,max(NN))
!>           The product of U times Z.
!>           Modified.
!>
!>  W1     - COMPLEX*16 array, dimension (max(NN))
!>           The eigenvalues of A, as computed by a full Schur
!>           decomposition H = Z T Z'.  On exit, W1 contains the
!>           eigenvalues of the matrix in A.
!>           Modified.
!>
!>  W3     - COMPLEX*16 array, dimension (max(NN))
!>           The eigenvalues of A, as computed by a partial Schur
!>           decomposition (Z not computed, T only computed as much
!>           as is necessary for determining eigenvalues).  On exit,
!>           W3 contains the eigenvalues of the matrix in A, possibly
!>           perturbed by ZHSEIN.
!>           Modified.
!>
!>  EVECTL - COMPLEX*16 array, dimension (LDU,max(NN))
!>           The conjugate transpose of the (upper triangular) left
!>           eigenvector matrix for the matrix in T1.
!>           Modified.
!>
!>  EVEZTR - COMPLEX*16 array, dimension (LDU,max(NN))
!>           The (upper triangular) right eigenvector matrix for the
!>           matrix in T1.
!>           Modified.
!>
!>  EVECTY - COMPLEX*16 array, dimension (LDU,max(NN))
!>           The conjugate transpose of the left eigenvector matrix
!>           for the matrix in H.
!>           Modified.
!>
!>  EVECTX - COMPLEX*16 array, dimension (LDU,max(NN))
!>           The right eigenvector matrix for the matrix in H.
!>           Modified.
!>
!>  UU     - COMPLEX*16 array, dimension (LDU,max(NN))
!>           Details of the unitary matrix computed by ZGEHRD.
!>           Modified.
!>
!>  TAU    - COMPLEX*16 array, dimension (max(NN))
!>           Further details of the unitary matrix computed by ZGEHRD.
!>           Modified.
!>
!>  WORK   - COMPLEX*16 array, dimension (NWORK)
!>           Workspace.
!>           Modified.
!>
!>  NWORK  - INTEGER
!>           The number of entries in WORK.  NWORK >= 4*NN(j)*NN(j) + 2.
!>
!>  RWORK  - DOUBLE PRECISION array, dimension (max(NN))
!>           Workspace.  Could be equivalenced to IWORK, but not SELECT.
!>           Modified.
!>
!>  IWORK  - INTEGER array, dimension (max(NN))
!>           Workspace.
!>           Modified.
!>
!>  SELECT - LOGICAL array, dimension (max(NN))
!>           Workspace.  Could be equivalenced to IWORK, but not RWORK.
!>           Modified.
!>
!>  RESULT - DOUBLE PRECISION array, dimension (14)
!>           The values computed by the fourteen tests described above.
!>           The values are currently limited to 1/ulp, to avoid
!>           overflow.
!>           Modified.
!>
!>  INFO   - INTEGER
!>           If 0, then everything ran OK.
!>            -1: NSIZES < 0
!>            -2: Some NN(j) < 0
!>            -3: NTYPES < 0
!>            -6: THRESH < 0
!>            -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>           -14: LDU < 1 or LDU < NMAX.
!>           -26: NWORK too small.
!>           If  ZLATMR, CLATMS, or CLATME returns an error code, the
!>               absolute value of it is returned.
!>           If 1, then ZHSEQR could not find all the shifts.
!>           If 2, then the EISPACK code (for small blocks) failed.
!>           If >2, then 30*N iterations were not enough to find an
!>               eigenvalue or to decompose the problem.
!>           Modified.
!>
!>-----------------------------------------------------------------------
!>
!>     Some Local Variables and Parameters:
!>     ---- ----- --------- --- ----------
!>
!>     ZERO, ONE       Real 0 and 1.
!>     MAXTYP          The number of types defined.
!>     MTEST           The number of tests defined: care must be taken
!>                     that (1) the size of RESULT, (2) the number of
!>                     tests actually performed, and (3) MTEST agree.
!>     NTEST           The number of tests performed on this matrix
!>                     so far.  This should be less than MTEST, and
!>                     equal to it by the last test.  It will be less
!>                     if any of the routines being tested indicates
!>                     that it could not compute the matrices that
!>                     would be tested.
!>     NMAX            Largest value in NN.
!>     NMATS           The number of matrices generated so far.
!>     NERRS           The number of tests which have exceeded THRESH
!>                     so far (computed by DLAFTS).
!>     COND, CONDS,
!>     IMODE           Values to be passed to the matrix generators.
!>     ANORM           Norm of A; passed to matrix generators.
!>
!>     OVFL, UNFL      Overflow and underflow thresholds.
!>     ULP, ULPINV     Finest relative precision and its inverse.
!>     RTOVFL, RTUNFL,
!>     RTULP, RTULPI   Square roots of the previous 4 values.
!>
!>             The following four arrays decode JTYPE:
!>     KTYPE(j)        The general type (1-10) for type .
!>     KMODE(j)        The MODE value to be passed to the matrix
!>                     generator for type .
!>     KMAGN(j)        The order of magnitude ( O(1),
!>                     O(overflow^(1/2) ), O(underflow^(1/2) )
!>     KCONDS(j)       Selects whether CONDS is to be 1 or
!>                     1/sqrt(ulp).  (0 means irrelevant.)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 407 of file zchkhs.f.

412*
413* -- LAPACK test routine --
414* -- LAPACK is a software package provided by Univ. of Tennessee, --
415* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
416*
417* .. Scalar Arguments ..
418 INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK
419 DOUBLE PRECISION THRESH
420* ..
421* .. Array Arguments ..
422 LOGICAL DOTYPE( * ), SELECT( * )
423 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
424 DOUBLE PRECISION RESULT( 14 ), RWORK( * )
425 COMPLEX*16 A( LDA, * ), EVECTL( LDU, * ),
426 $ EVECTR( LDU, * ), EVECTX( LDU, * ),
427 $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ),
428 $ T2( LDA, * ), TAU( * ), U( LDU, * ),
429 $ UU( LDU, * ), UZ( LDU, * ), W1( * ), W3( * ),
430 $ WORK( * ), Z( LDU, * )
431* ..
432*
433* =====================================================================
434*
435* .. Parameters ..
436 DOUBLE PRECISION ZERO, ONE
437 parameter( zero = 0.0d+0, one = 1.0d+0 )
438 COMPLEX*16 CZERO, CONE
439 parameter( czero = ( 0.0d+0, 0.0d+0 ),
440 $ cone = ( 1.0d+0, 0.0d+0 ) )
441 INTEGER MAXTYP
442 parameter( maxtyp = 21 )
443* ..
444* .. Local Scalars ..
445 LOGICAL BADNN, MATCH
446 INTEGER I, IHI, IINFO, ILO, IMODE, IN, ITYPE, J, JCOL,
447 $ JJ, JSIZE, JTYPE, K, MTYPES, N, N1, NERRS,
448 $ NMATS, NMAX, NTEST, NTESTT
449 DOUBLE PRECISION ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP,
450 $ RTULPI, RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL
451* ..
452* .. Local Arrays ..
453 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
454 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
455 $ KTYPE( MAXTYP )
456 DOUBLE PRECISION DUMMA( 4 )
457 COMPLEX*16 CDUMMA( 4 )
458* ..
459* .. External Functions ..
460 DOUBLE PRECISION DLAMCH
461 EXTERNAL dlamch
462* ..
463* .. External Subroutines ..
464 EXTERNAL dlabad, dlafts, dlasum, xerbla, zcopy, zgehrd,
465 $ zgemm, zget10, zget22, zhsein, zhseqr, zhst01,
466 $ zlacpy, zlaset, zlatme, zlatmr, zlatms, ztrevc,
467 $ zunghr, zunmhr
468* ..
469* .. Intrinsic Functions ..
470 INTRINSIC abs, dble, max, min, sqrt
471* ..
472* .. Data statements ..
473 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
474 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
475 $ 3, 1, 2, 3 /
476 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
477 $ 1, 5, 5, 5, 4, 3, 1 /
478 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
479* ..
480* .. Executable Statements ..
481*
482* Check for errors
483*
484 ntestt = 0
485 info = 0
486*
487 badnn = .false.
488 nmax = 0
489 DO 10 j = 1, nsizes
490 nmax = max( nmax, nn( j ) )
491 IF( nn( j ).LT.0 )
492 $ badnn = .true.
493 10 CONTINUE
494*
495* Check for errors
496*
497 IF( nsizes.LT.0 ) THEN
498 info = -1
499 ELSE IF( badnn ) THEN
500 info = -2
501 ELSE IF( ntypes.LT.0 ) THEN
502 info = -3
503 ELSE IF( thresh.LT.zero ) THEN
504 info = -6
505 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
506 info = -9
507 ELSE IF( ldu.LE.1 .OR. ldu.LT.nmax ) THEN
508 info = -14
509 ELSE IF( 4*nmax*nmax+2.GT.nwork ) THEN
510 info = -26
511 END IF
512*
513 IF( info.NE.0 ) THEN
514 CALL xerbla( 'ZCHKHS', -info )
515 RETURN
516 END IF
517*
518* Quick return if possible
519*
520 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
521 $ RETURN
522*
523* More important constants
524*
525 unfl = dlamch( 'Safe minimum' )
526 ovfl = dlamch( 'Overflow' )
527 CALL dlabad( unfl, ovfl )
528 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
529 ulpinv = one / ulp
530 rtunfl = sqrt( unfl )
531 rtovfl = sqrt( ovfl )
532 rtulp = sqrt( ulp )
533 rtulpi = one / rtulp
534*
535* Loop over sizes, types
536*
537 nerrs = 0
538 nmats = 0
539*
540 DO 260 jsize = 1, nsizes
541 n = nn( jsize )
542 IF( n.EQ.0 )
543 $ GO TO 260
544 n1 = max( 1, n )
545 aninv = one / dble( n1 )
546*
547 IF( nsizes.NE.1 ) THEN
548 mtypes = min( maxtyp, ntypes )
549 ELSE
550 mtypes = min( maxtyp+1, ntypes )
551 END IF
552*
553 DO 250 jtype = 1, mtypes
554 IF( .NOT.dotype( jtype ) )
555 $ GO TO 250
556 nmats = nmats + 1
557 ntest = 0
558*
559* Save ISEED in case of an error.
560*
561 DO 20 j = 1, 4
562 ioldsd( j ) = iseed( j )
563 20 CONTINUE
564*
565* Initialize RESULT
566*
567 DO 30 j = 1, 14
568 result( j ) = zero
569 30 CONTINUE
570*
571* Compute "A"
572*
573* Control parameters:
574*
575* KMAGN KCONDS KMODE KTYPE
576* =1 O(1) 1 clustered 1 zero
577* =2 large large clustered 2 identity
578* =3 small exponential Jordan
579* =4 arithmetic diagonal, (w/ eigenvalues)
580* =5 random log hermitian, w/ eigenvalues
581* =6 random general, w/ eigenvalues
582* =7 random diagonal
583* =8 random hermitian
584* =9 random general
585* =10 random triangular
586*
587 IF( mtypes.GT.maxtyp )
588 $ GO TO 100
589*
590 itype = ktype( jtype )
591 imode = kmode( jtype )
592*
593* Compute norm
594*
595 GO TO ( 40, 50, 60 )kmagn( jtype )
596*
597 40 CONTINUE
598 anorm = one
599 GO TO 70
600*
601 50 CONTINUE
602 anorm = ( rtovfl*ulp )*aninv
603 GO TO 70
604*
605 60 CONTINUE
606 anorm = rtunfl*n*ulpinv
607 GO TO 70
608*
609 70 CONTINUE
610*
611 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
612 iinfo = 0
613 cond = ulpinv
614*
615* Special Matrices
616*
617 IF( itype.EQ.1 ) THEN
618*
619* Zero
620*
621 iinfo = 0
622 ELSE IF( itype.EQ.2 ) THEN
623*
624* Identity
625*
626 DO 80 jcol = 1, n
627 a( jcol, jcol ) = anorm
628 80 CONTINUE
629*
630 ELSE IF( itype.EQ.3 ) THEN
631*
632* Jordan Block
633*
634 DO 90 jcol = 1, n
635 a( jcol, jcol ) = anorm
636 IF( jcol.GT.1 )
637 $ a( jcol, jcol-1 ) = one
638 90 CONTINUE
639*
640 ELSE IF( itype.EQ.4 ) THEN
641*
642* Diagonal Matrix, [Eigen]values Specified
643*
644 CALL zlatmr( n, n, 'D', iseed, 'N', work, imode, cond,
645 $ cone, 'T', 'N', work( n+1 ), 1, one,
646 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
647 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
648*
649 ELSE IF( itype.EQ.5 ) THEN
650*
651* Hermitian, eigenvalues specified
652*
653 CALL zlatms( n, n, 'D', iseed, 'H', rwork, imode, cond,
654 $ anorm, n, n, 'N', a, lda, work, iinfo )
655*
656 ELSE IF( itype.EQ.6 ) THEN
657*
658* General, eigenvalues specified
659*
660 IF( kconds( jtype ).EQ.1 ) THEN
661 conds = one
662 ELSE IF( kconds( jtype ).EQ.2 ) THEN
663 conds = rtulpi
664 ELSE
665 conds = zero
666 END IF
667*
668 CALL zlatme( n, 'D', iseed, work, imode, cond, cone,
669 $ 'T', 'T', 'T', rwork, 4, conds, n, n, anorm,
670 $ a, lda, work( n+1 ), iinfo )
671*
672 ELSE IF( itype.EQ.7 ) THEN
673*
674* Diagonal, random eigenvalues
675*
676 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
677 $ 'T', 'N', work( n+1 ), 1, one,
678 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
679 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
680*
681 ELSE IF( itype.EQ.8 ) THEN
682*
683* Hermitian, random eigenvalues
684*
685 CALL zlatmr( n, n, 'D', iseed, 'H', work, 6, one, cone,
686 $ 'T', 'N', work( n+1 ), 1, one,
687 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
688 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
689*
690 ELSE IF( itype.EQ.9 ) THEN
691*
692* General, random eigenvalues
693*
694 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
695 $ 'T', 'N', work( n+1 ), 1, one,
696 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
697 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
698*
699 ELSE IF( itype.EQ.10 ) THEN
700*
701* Triangular, random eigenvalues
702*
703 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
704 $ 'T', 'N', work( n+1 ), 1, one,
705 $ work( 2*n+1 ), 1, one, 'N', idumma, n, 0,
706 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
707*
708 ELSE
709*
710 iinfo = 1
711 END IF
712*
713 IF( iinfo.NE.0 ) THEN
714 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
715 $ ioldsd
716 info = abs( iinfo )
717 RETURN
718 END IF
719*
720 100 CONTINUE
721*
722* Call ZGEHRD to compute H and U, do tests.
723*
724 CALL zlacpy( ' ', n, n, a, lda, h, lda )
725 ntest = 1
726*
727 ilo = 1
728 ihi = n
729*
730 CALL zgehrd( n, ilo, ihi, h, lda, work, work( n+1 ),
731 $ nwork-n, iinfo )
732*
733 IF( iinfo.NE.0 ) THEN
734 result( 1 ) = ulpinv
735 WRITE( nounit, fmt = 9999 )'ZGEHRD', iinfo, n, jtype,
736 $ ioldsd
737 info = abs( iinfo )
738 GO TO 240
739 END IF
740*
741 DO 120 j = 1, n - 1
742 uu( j+1, j ) = czero
743 DO 110 i = j + 2, n
744 u( i, j ) = h( i, j )
745 uu( i, j ) = h( i, j )
746 h( i, j ) = czero
747 110 CONTINUE
748 120 CONTINUE
749 CALL zcopy( n-1, work, 1, tau, 1 )
750 CALL zunghr( n, ilo, ihi, u, ldu, work, work( n+1 ),
751 $ nwork-n, iinfo )
752 ntest = 2
753*
754 CALL zhst01( n, ilo, ihi, a, lda, h, lda, u, ldu, work,
755 $ nwork, rwork, result( 1 ) )
756*
757* Call ZHSEQR to compute T1, T2 and Z, do tests.
758*
759* Eigenvalues only (W3)
760*
761 CALL zlacpy( ' ', n, n, h, lda, t2, lda )
762 ntest = 3
763 result( 3 ) = ulpinv
764*
765 CALL zhseqr( 'E', 'N', n, ilo, ihi, t2, lda, w3, uz, ldu,
766 $ work, nwork, iinfo )
767 IF( iinfo.NE.0 ) THEN
768 WRITE( nounit, fmt = 9999 )'ZHSEQR(E)', iinfo, n, jtype,
769 $ ioldsd
770 IF( iinfo.LE.n+2 ) THEN
771 info = abs( iinfo )
772 GO TO 240
773 END IF
774 END IF
775*
776* Eigenvalues (W1) and Full Schur Form (T2)
777*
778 CALL zlacpy( ' ', n, n, h, lda, t2, lda )
779*
780 CALL zhseqr( 'S', 'N', n, ilo, ihi, t2, lda, w1, uz, ldu,
781 $ work, nwork, iinfo )
782 IF( iinfo.NE.0 .AND. iinfo.LE.n+2 ) THEN
783 WRITE( nounit, fmt = 9999 )'ZHSEQR(S)', iinfo, n, jtype,
784 $ ioldsd
785 info = abs( iinfo )
786 GO TO 240
787 END IF
788*
789* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ)
790*
791 CALL zlacpy( ' ', n, n, h, lda, t1, lda )
792 CALL zlacpy( ' ', n, n, u, ldu, uz, ldu )
793*
794 CALL zhseqr( 'S', 'V', n, ilo, ihi, t1, lda, w1, uz, ldu,
795 $ work, nwork, iinfo )
796 IF( iinfo.NE.0 .AND. iinfo.LE.n+2 ) THEN
797 WRITE( nounit, fmt = 9999 )'ZHSEQR(V)', iinfo, n, jtype,
798 $ ioldsd
799 info = abs( iinfo )
800 GO TO 240
801 END IF
802*
803* Compute Z = U' UZ
804*
805 CALL zgemm( 'C', 'N', n, n, n, cone, u, ldu, uz, ldu, czero,
806 $ z, ldu )
807 ntest = 8
808*
809* Do Tests 3: | H - Z T Z' | / ( |H| n ulp )
810* and 4: | I - Z Z' | / ( n ulp )
811*
812 CALL zhst01( n, ilo, ihi, h, lda, t1, lda, z, ldu, work,
813 $ nwork, rwork, result( 3 ) )
814*
815* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )
816* and 6: | I - UZ (UZ)' | / ( n ulp )
817*
818 CALL zhst01( n, ilo, ihi, a, lda, t1, lda, uz, ldu, work,
819 $ nwork, rwork, result( 5 ) )
820*
821* Do Test 7: | T2 - T1 | / ( |T| n ulp )
822*
823 CALL zget10( n, n, t2, lda, t1, lda, work, rwork,
824 $ result( 7 ) )
825*
826* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp )
827*
828 temp1 = zero
829 temp2 = zero
830 DO 130 j = 1, n
831 temp1 = max( temp1, abs( w1( j ) ), abs( w3( j ) ) )
832 temp2 = max( temp2, abs( w1( j )-w3( j ) ) )
833 130 CONTINUE
834*
835 result( 8 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
836*
837* Compute the Left and Right Eigenvectors of T
838*
839* Compute the Right eigenvector Matrix:
840*
841 ntest = 9
842 result( 9 ) = ulpinv
843*
844* Select every other eigenvector
845*
846 DO 140 j = 1, n
847 SELECT( j ) = .false.
848 140 CONTINUE
849 DO 150 j = 1, n, 2
850 SELECT( j ) = .true.
851 150 CONTINUE
852 CALL ztrevc( 'Right', 'All', SELECT, n, t1, lda, cdumma,
853 $ ldu, evectr, ldu, n, in, work, rwork, iinfo )
854 IF( iinfo.NE.0 ) THEN
855 WRITE( nounit, fmt = 9999 )'ZTREVC(R,A)', iinfo, n,
856 $ jtype, ioldsd
857 info = abs( iinfo )
858 GO TO 240
859 END IF
860*
861* Test 9: | TR - RW | / ( |T| |R| ulp )
862*
863 CALL zget22( 'N', 'N', 'N', n, t1, lda, evectr, ldu, w1,
864 $ work, rwork, dumma( 1 ) )
865 result( 9 ) = dumma( 1 )
866 IF( dumma( 2 ).GT.thresh ) THEN
867 WRITE( nounit, fmt = 9998 )'Right', 'ZTREVC',
868 $ dumma( 2 ), n, jtype, ioldsd
869 END IF
870*
871* Compute selected right eigenvectors and confirm that
872* they agree with previous right eigenvectors
873*
874 CALL ztrevc( 'Right', 'Some', SELECT, n, t1, lda, cdumma,
875 $ ldu, evectl, ldu, n, in, work, rwork, iinfo )
876 IF( iinfo.NE.0 ) THEN
877 WRITE( nounit, fmt = 9999 )'ZTREVC(R,S)', iinfo, n,
878 $ jtype, ioldsd
879 info = abs( iinfo )
880 GO TO 240
881 END IF
882*
883 k = 1
884 match = .true.
885 DO 170 j = 1, n
886 IF( SELECT( j ) ) THEN
887 DO 160 jj = 1, n
888 IF( evectr( jj, j ).NE.evectl( jj, k ) ) THEN
889 match = .false.
890 GO TO 180
891 END IF
892 160 CONTINUE
893 k = k + 1
894 END IF
895 170 CONTINUE
896 180 CONTINUE
897 IF( .NOT.match )
898 $ WRITE( nounit, fmt = 9997 )'Right', 'ZTREVC', n, jtype,
899 $ ioldsd
900*
901* Compute the Left eigenvector Matrix:
902*
903 ntest = 10
904 result( 10 ) = ulpinv
905 CALL ztrevc( 'Left', 'All', SELECT, n, t1, lda, evectl, ldu,
906 $ cdumma, ldu, n, in, work, rwork, iinfo )
907 IF( iinfo.NE.0 ) THEN
908 WRITE( nounit, fmt = 9999 )'ZTREVC(L,A)', iinfo, n,
909 $ jtype, ioldsd
910 info = abs( iinfo )
911 GO TO 240
912 END IF
913*
914* Test 10: | LT - WL | / ( |T| |L| ulp )
915*
916 CALL zget22( 'C', 'N', 'C', n, t1, lda, evectl, ldu, w1,
917 $ work, rwork, dumma( 3 ) )
918 result( 10 ) = dumma( 3 )
919 IF( dumma( 4 ).GT.thresh ) THEN
920 WRITE( nounit, fmt = 9998 )'Left', 'ZTREVC', dumma( 4 ),
921 $ n, jtype, ioldsd
922 END IF
923*
924* Compute selected left eigenvectors and confirm that
925* they agree with previous left eigenvectors
926*
927 CALL ztrevc( 'Left', 'Some', SELECT, n, t1, lda, evectr,
928 $ ldu, cdumma, ldu, n, in, work, rwork, iinfo )
929 IF( iinfo.NE.0 ) THEN
930 WRITE( nounit, fmt = 9999 )'ZTREVC(L,S)', iinfo, n,
931 $ jtype, ioldsd
932 info = abs( iinfo )
933 GO TO 240
934 END IF
935*
936 k = 1
937 match = .true.
938 DO 200 j = 1, n
939 IF( SELECT( j ) ) THEN
940 DO 190 jj = 1, n
941 IF( evectl( jj, j ).NE.evectr( jj, k ) ) THEN
942 match = .false.
943 GO TO 210
944 END IF
945 190 CONTINUE
946 k = k + 1
947 END IF
948 200 CONTINUE
949 210 CONTINUE
950 IF( .NOT.match )
951 $ WRITE( nounit, fmt = 9997 )'Left', 'ZTREVC', n, jtype,
952 $ ioldsd
953*
954* Call ZHSEIN for Right eigenvectors of H, do test 11
955*
956 ntest = 11
957 result( 11 ) = ulpinv
958 DO 220 j = 1, n
959 SELECT( j ) = .true.
960 220 CONTINUE
961*
962 CALL zhsein( 'Right', 'Qr', 'Ninitv', SELECT, n, h, lda, w3,
963 $ cdumma, ldu, evectx, ldu, n1, in, work, rwork,
964 $ iwork, iwork, iinfo )
965 IF( iinfo.NE.0 ) THEN
966 WRITE( nounit, fmt = 9999 )'ZHSEIN(R)', iinfo, n, jtype,
967 $ ioldsd
968 info = abs( iinfo )
969 IF( iinfo.LT.0 )
970 $ GO TO 240
971 ELSE
972*
973* Test 11: | HX - XW | / ( |H| |X| ulp )
974*
975* (from inverse iteration)
976*
977 CALL zget22( 'N', 'N', 'N', n, h, lda, evectx, ldu, w3,
978 $ work, rwork, dumma( 1 ) )
979 IF( dumma( 1 ).LT.ulpinv )
980 $ result( 11 ) = dumma( 1 )*aninv
981 IF( dumma( 2 ).GT.thresh ) THEN
982 WRITE( nounit, fmt = 9998 )'Right', 'ZHSEIN',
983 $ dumma( 2 ), n, jtype, ioldsd
984 END IF
985 END IF
986*
987* Call ZHSEIN for Left eigenvectors of H, do test 12
988*
989 ntest = 12
990 result( 12 ) = ulpinv
991 DO 230 j = 1, n
992 SELECT( j ) = .true.
993 230 CONTINUE
994*
995 CALL zhsein( 'Left', 'Qr', 'Ninitv', SELECT, n, h, lda, w3,
996 $ evecty, ldu, cdumma, ldu, n1, in, work, rwork,
997 $ iwork, iwork, iinfo )
998 IF( iinfo.NE.0 ) THEN
999 WRITE( nounit, fmt = 9999 )'ZHSEIN(L)', iinfo, n, jtype,
1000 $ ioldsd
1001 info = abs( iinfo )
1002 IF( iinfo.LT.0 )
1003 $ GO TO 240
1004 ELSE
1005*
1006* Test 12: | YH - WY | / ( |H| |Y| ulp )
1007*
1008* (from inverse iteration)
1009*
1010 CALL zget22( 'C', 'N', 'C', n, h, lda, evecty, ldu, w3,
1011 $ work, rwork, dumma( 3 ) )
1012 IF( dumma( 3 ).LT.ulpinv )
1013 $ result( 12 ) = dumma( 3 )*aninv
1014 IF( dumma( 4 ).GT.thresh ) THEN
1015 WRITE( nounit, fmt = 9998 )'Left', 'ZHSEIN',
1016 $ dumma( 4 ), n, jtype, ioldsd
1017 END IF
1018 END IF
1019*
1020* Call ZUNMHR for Right eigenvectors of A, do test 13
1021*
1022 ntest = 13
1023 result( 13 ) = ulpinv
1024*
1025 CALL zunmhr( 'Left', 'No transpose', n, n, ilo, ihi, uu,
1026 $ ldu, tau, evectx, ldu, work, nwork, iinfo )
1027 IF( iinfo.NE.0 ) THEN
1028 WRITE( nounit, fmt = 9999 )'ZUNMHR(L)', iinfo, n, jtype,
1029 $ ioldsd
1030 info = abs( iinfo )
1031 IF( iinfo.LT.0 )
1032 $ GO TO 240
1033 ELSE
1034*
1035* Test 13: | AX - XW | / ( |A| |X| ulp )
1036*
1037* (from inverse iteration)
1038*
1039 CALL zget22( 'N', 'N', 'N', n, a, lda, evectx, ldu, w3,
1040 $ work, rwork, dumma( 1 ) )
1041 IF( dumma( 1 ).LT.ulpinv )
1042 $ result( 13 ) = dumma( 1 )*aninv
1043 END IF
1044*
1045* Call ZUNMHR for Left eigenvectors of A, do test 14
1046*
1047 ntest = 14
1048 result( 14 ) = ulpinv
1049*
1050 CALL zunmhr( 'Left', 'No transpose', n, n, ilo, ihi, uu,
1051 $ ldu, tau, evecty, ldu, work, nwork, iinfo )
1052 IF( iinfo.NE.0 ) THEN
1053 WRITE( nounit, fmt = 9999 )'ZUNMHR(L)', iinfo, n, jtype,
1054 $ ioldsd
1055 info = abs( iinfo )
1056 IF( iinfo.LT.0 )
1057 $ GO TO 240
1058 ELSE
1059*
1060* Test 14: | YA - WY | / ( |A| |Y| ulp )
1061*
1062* (from inverse iteration)
1063*
1064 CALL zget22( 'C', 'N', 'C', n, a, lda, evecty, ldu, w3,
1065 $ work, rwork, dumma( 3 ) )
1066 IF( dumma( 3 ).LT.ulpinv )
1067 $ result( 14 ) = dumma( 3 )*aninv
1068 END IF
1069*
1070* End of Loop -- Check for RESULT(j) > THRESH
1071*
1072 240 CONTINUE
1073*
1074 ntestt = ntestt + ntest
1075 CALL dlafts( 'ZHS', n, n, jtype, ntest, result, ioldsd,
1076 $ thresh, nounit, nerrs )
1077*
1078 250 CONTINUE
1079 260 CONTINUE
1080*
1081* Summary
1082*
1083 CALL dlasum( 'ZHS', nounit, nerrs, ntestt )
1084*
1085 RETURN
1086*
1087 9999 FORMAT( ' ZCHKHS: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1088 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1089 9998 FORMAT( ' ZCHKHS: ', a, ' Eigenvectors from ', a, ' incorrectly ',
1090 $ 'normalized.', / ' Bits of error=', 0p, g10.3, ',', 9x,
1091 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5,
1092 $ ')' )
1093 9997 FORMAT( ' ZCHKHS: Selected ', a, ' Eigenvectors from ', a,
1094 $ ' do not match other eigenvectors ', 9x, 'N=', i6,
1095 $ ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1096*
1097* End of ZCHKHS
1098*
zgehrd
subroutine zgehrd(n, ilo, ihi, a, lda, tau, work, lwork, info)
ZGEHRD
Definition zgehrd.f:167
ztrevc
subroutine ztrevc(side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, rwork, info)
ZTREVC
Definition ztrevc.f:218
zhseqr
subroutine zhseqr(job, compz, n, ilo, ihi, h, ldh, w, z, ldz, work, lwork, info)
ZHSEQR
Definition zhseqr.f:299
zhsein
subroutine zhsein(side, eigsrc, initv, select, n, h, ldh, w, vl, ldvl, vr, ldvr, mm, m, work, rwork, ifaill, ifailr, info)
ZHSEIN
Definition zhsein.f:245
zunghr
subroutine zunghr(n, ilo, ihi, a, lda, tau, work, lwork, info)
ZUNGHR
Definition zunghr.f:126
zunmhr
subroutine zunmhr(side, trans, m, n, ilo, ihi, a, lda, tau, c, ldc, work, lwork, info)
ZUNMHR
Definition zunmhr.f:178
zget10
subroutine zget10(m, n, a, lda, b, ldb, work, rwork, result)
ZGET10
Definition zget10.f:99
zhst01
subroutine zhst01(n, ilo, ihi, a, lda, h, ldh, q, ldq, work, lwork, rwork, result)
ZHST01
Definition zhst01.f:140
zget22
subroutine zget22(transa, transe, transw, n, a, lda, e, lde, w, work, rwork, result)
ZGET22
Definition zget22.f:144
zlatme
subroutine zlatme(n, dist, iseed, d, mode, cond, dmax, rsign, upper, sim, ds, modes, conds, kl, ku, anorm, a, lda, work, info)
ZLATME
Definition zlatme.f:301
dlafts
subroutine dlafts(type, m, n, imat, ntests, result, iseed, thresh, iounit, ie)
DLAFTS
Definition dlafts.f:99

◆ zchkst()

subroutine zchkst ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) ap,
double precision, dimension( * ) sd,
double precision, dimension( * ) se,
double precision, dimension( * ) d1,
double precision, dimension( * ) d2,
double precision, dimension( * ) d3,
double precision, dimension( * ) d4,
double precision, dimension( * ) d5,
double precision, dimension( * ) wa1,
double precision, dimension( * ) wa2,
double precision, dimension( * ) wa3,
double precision, dimension( * ) wr,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldu, * ) v,
complex*16, dimension( * ) vp,
complex*16, dimension( * ) tau,
complex*16, dimension( ldu, * ) z,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer lrwork,
integer, dimension( * ) iwork,
integer liwork,
double precision, dimension( * ) result,
integer info )

ZCHKST

Purpose:
!>
!> ZCHKST  checks the Hermitian eigenvalue problem routines.
!>
!>    ZHETRD factors A as  U S U* , where * means conjugate transpose,
!>    S is real symmetric tridiagonal, and U is unitary.
!>    ZHETRD can use either just the lower or just the upper triangle
!>    of A; ZCHKST checks both cases.
!>    U is represented as a product of Householder
!>    transformations, whose vectors are stored in the first
!>    n-1 columns of V, and whose scale factors are in TAU.
!>
!>    ZHPTRD does the same as ZHETRD, except that A and V are stored
!>    in  format.
!>
!>    ZUNGTR constructs the matrix U from the contents of V and TAU.
!>
!>    ZUPGTR constructs the matrix U from the contents of VP and TAU.
!>
!>    ZSTEQR factors S as  Z D1 Z* , where Z is the unitary
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal.  D2 is the matrix of
!>    eigenvalues computed when Z is not computed.
!>
!>    DSTERF computes D3, the matrix of eigenvalues, by the
!>    PWK method, which does not yield eigenvectors.
!>
!>    ZPTEQR factors S as  Z4 D4 Z4* , for a
!>    Hermitian positive definite tridiagonal matrix.
!>    D5 is the matrix of eigenvalues computed when Z is not
!>    computed.
!>
!>    DSTEBZ computes selected eigenvalues.  WA1, WA2, and
!>    WA3 will denote eigenvalues computed to high
!>    absolute accuracy, with different range options.
!>    WR will denote eigenvalues computed to high relative
!>    accuracy.
!>
!>    ZSTEIN computes Y, the eigenvectors of S, given the
!>    eigenvalues.
!>
!>    ZSTEDC factors S as Z D1 Z* , where Z is the unitary
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal ('I' option). It may also
!>    update an input unitary matrix, usually the output
!>    from ZHETRD/ZUNGTR or ZHPTRD/ZUPGTR ('V' option). It may
!>    also just compute eigenvalues ('N' option).
!>
!>    ZSTEMR factors S as Z D1 Z* , where Z is the unitary
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal ('I' option).  ZSTEMR
!>    uses the Relatively Robust Representation whenever possible.
!>
!> When ZCHKST is called, a number of matrix  () and a
!> number of matrix  are specified.  For each size ()
!> and each type of matrix, one matrix will be generated and used
!> to test the Hermitian eigenroutines.  For each matrix, a number
!> of tests will be performed:
!>
!> (1)     | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='U', ... )
!>
!> (2)     | I - UV* | / ( n ulp )        ZUNGTR( UPLO='U', ... )
!>
!> (3)     | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='L', ... )
!>
!> (4)     | I - UV* | / ( n ulp )        ZUNGTR( UPLO='L', ... )
!>
!> (5-8)   Same as 1-4, but for ZHPTRD and ZUPGTR.
!>
!> (9)     | S - Z D Z* | / ( |S| n ulp ) ZSTEQR('V',...)
!>
!> (10)    | I - ZZ* | / ( n ulp )        ZSTEQR('V',...)
!>
!> (11)    | D1 - D2 | / ( |D1| ulp )        ZSTEQR('N',...)
!>
!> (12)    | D1 - D3 | / ( |D1| ulp )        DSTERF
!>
!> (13)    0 if the true eigenvalues (computed by sturm count)
!>         of S are within THRESH of
!>         those in D1.  2*THRESH if they are not.  (Tested using
!>         DSTECH)
!>
!> For S positive definite,
!>
!> (14)    | S - Z4 D4 Z4* | / ( |S| n ulp ) ZPTEQR('V',...)
!>
!> (15)    | I - Z4 Z4* | / ( n ulp )        ZPTEQR('V',...)
!>
!> (16)    | D4 - D5 | / ( 100 |D4| ulp )       ZPTEQR('N',...)
!>
!> When S is also diagonally dominant by the factor gamma < 1,
!>
!> (17)    max | D4(i) - WR(i) | / ( |D4(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              DSTEBZ( 'A', 'E', ...)
!>
!> (18)    | WA1 - D3 | / ( |D3| ulp )          DSTEBZ( 'A', 'E', ...)
!>
!> (19)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>                                              DSTEBZ( 'I', 'E', ...)
!>
!> (20)    | S - Y WA1 Y* | / ( |S| n ulp )  DSTEBZ, ZSTEIN
!>
!> (21)    | I - Y Y* | / ( n ulp )          DSTEBZ, ZSTEIN
!>
!> (22)    | S - Z D Z* | / ( |S| n ulp )    ZSTEDC('I')
!>
!> (23)    | I - ZZ* | / ( n ulp )           ZSTEDC('I')
!>
!> (24)    | S - Z D Z* | / ( |S| n ulp )    ZSTEDC('V')
!>
!> (25)    | I - ZZ* | / ( n ulp )           ZSTEDC('V')
!>
!> (26)    | D1 - D2 | / ( |D1| ulp )           ZSTEDC('V') and
!>                                              ZSTEDC('N')
!>
!> Test 27 is disabled at the moment because ZSTEMR does not
!> guarantee high relatvie accuracy.
!>
!> (27)    max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              ZSTEMR('V', 'A')
!>
!> (28)    max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              ZSTEMR('V', 'I')
!>
!> Tests 29 through 34 are disable at present because ZSTEMR
!> does not handle partial spectrum requests.
!>
!> (29)    | S - Z D Z* | / ( |S| n ulp )    ZSTEMR('V', 'I')
!>
!> (30)    | I - ZZ* | / ( n ulp )           ZSTEMR('V', 'I')
!>
!> (31)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         ZSTEMR('N', 'I') vs. CSTEMR('V', 'I')
!>
!> (32)    | S - Z D Z* | / ( |S| n ulp )    ZSTEMR('V', 'V')
!>
!> (33)    | I - ZZ* | / ( n ulp )           ZSTEMR('V', 'V')
!>
!> (34)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         ZSTEMR('N', 'V') vs. CSTEMR('V', 'V')
!>
!> (35)    | S - Z D Z* | / ( |S| n ulp )    ZSTEMR('V', 'A')
!>
!> (36)    | I - ZZ* | / ( n ulp )           ZSTEMR('V', 'A')
!>
!> (37)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         ZSTEMR('N', 'A') vs. CSTEMR('V', 'A')
!>
!> The  are specified by an array NN(1:NSIZES); the value of
!> each element NN(j) specifies one size.
!> The  are specified by a logical array DOTYPE( 1:NTYPES );
!> if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!> Currently, the list of possible types is:
!>
!> (1)  The zero matrix.
!> (2)  The identity matrix.
!>
!> (3)  A diagonal matrix with evenly spaced entries
!>      1, ..., ULP  and random signs.
!>      (ULP = (first number larger than 1) - 1 )
!> (4)  A diagonal matrix with geometrically spaced entries
!>      1, ..., ULP  and random signs.
!> (5)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>      and random signs.
!>
!> (6)  Same as (4), but multiplied by SQRT( overflow threshold )
!> (7)  Same as (4), but multiplied by SQRT( underflow threshold )
!>
!> (8)  A matrix of the form  U* D U, where U is unitary and
!>      D has evenly spaced entries 1, ..., ULP with random signs
!>      on the diagonal.
!>
!> (9)  A matrix of the form  U* D U, where U is unitary and
!>      D has geometrically spaced entries 1, ..., ULP with random
!>      signs on the diagonal.
!>
!> (10) A matrix of the form  U* D U, where U is unitary and
!>      D has  entries 1, ULP,..., ULP with random
!>      signs on the diagonal.
!>
!> (11) Same as (8), but multiplied by SQRT( overflow threshold )
!> (12) Same as (8), but multiplied by SQRT( underflow threshold )
!>
!> (13) Hermitian matrix with random entries chosen from (-1,1).
!> (14) Same as (13), but multiplied by SQRT( overflow threshold )
!> (15) Same as (13), but multiplied by SQRT( underflow threshold )
!> (16) Same as (8), but diagonal elements are all positive.
!> (17) Same as (9), but diagonal elements are all positive.
!> (18) Same as (10), but diagonal elements are all positive.
!> (19) Same as (16), but multiplied by SQRT( overflow threshold )
!> (20) Same as (16), but multiplied by SQRT( underflow threshold )
!> (21) A diagonally dominant tridiagonal matrix with geometrically
!>      spaced diagonal entries 1, ..., ULP.
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZCHKST does nothing.  It must be at least zero.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZCHKST
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZCHKST to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is COMPLEX*16 array of
!>                                  dimension ( LDA , max(NN) )
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( NN ).
!>
[out]AP
!>          AP is COMPLEX*16 array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix A stored in packed format.
!>
[out]SD
!>          SD is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The diagonal of the tridiagonal matrix computed by ZHETRD.
!>          On exit, SD and SE contain the tridiagonal form of the
!>          matrix in A.
!>
[out]SE
!>          SE is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The off-diagonal of the tridiagonal matrix computed by
!>          ZHETRD.  On exit, SD and SE contain the tridiagonal form of
!>          the matrix in A.
!>
[out]D1
!>          D1 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by ZSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>
[out]D2
!>          D2 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by ZSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>
[out]D3
!>          D3 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>
[out]D4
!>          D4 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by ZPTEQR(V).
!>          ZPTEQR factors S as  Z4 D4 Z4*
!>          On exit, the eigenvalues in D4 correspond with the matrix in A.
!>
[out]D5
!>          D5 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by ZPTEQR(N)
!>          when Z is not computed. On exit, the
!>          eigenvalues in D4 correspond with the matrix in A.
!>
[out]WA1
!>          WA1 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>
[out]WA2
!>          WA2 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>          Choose random values for IL and IU, and ask for the
!>          IL-th through IU-th eigenvalues.
!>
[out]WA3
!>          WA3 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>          Determine the values VL and VU of the IL-th and IU-th
!>          eigenvalues and ask for all eigenvalues in this range.
!>
[out]WR
!>          WR is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different options.
!>          as computed by DSTEBZ.
!>
[out]U
!>          U is COMPLEX*16 array of
!>                             dimension( LDU, max(NN) ).
!>          The unitary matrix computed by ZHETRD + ZUNGTR.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U, Z, and V.  It must be at least 1
!>          and at least max( NN ).
!>
[out]V
!>          V is COMPLEX*16 array of
!>                             dimension( LDU, max(NN) ).
!>          The Housholder vectors computed by ZHETRD in reducing A to
!>          tridiagonal form.  The vectors computed with UPLO='U' are
!>          in the upper triangle, and the vectors computed with UPLO='L'
!>          are in the lower triangle.  (As described in ZHETRD, the
!>          sub- and superdiagonal are not set to 1, although the
!>          true Householder vector has a 1 in that position.  The
!>          routines that use V, such as ZUNGTR, set those entries to
!>          1 before using them, and then restore them later.)
!>
[out]VP
!>          VP is COMPLEX*16 array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix V stored in packed format.
!>
[out]TAU
!>          TAU is COMPLEX*16 array of
!>                             dimension( max(NN) )
!>          The Householder factors computed by ZHETRD in reducing A
!>          to tridiagonal form.
!>
[out]Z
!>          Z is COMPLEX*16 array of
!>                             dimension( LDU, max(NN) ).
!>          The unitary matrix of eigenvectors computed by ZSTEQR,
!>          ZPTEQR, and ZSTEIN.
!>
[out]WORK
!>          WORK is COMPLEX*16 array of
!>                      dimension( LWORK )
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2
!>          where Nmax = max( NN(j), 2 ) and lg = log base 2.
!>
[out]IWORK
!>          IWORK is INTEGER array,
!>          Workspace.
!>
[out]LIWORK
!>          LIWORK is INTEGER
!>          The number of entries in IWORK.  This must be at least
!>                  6 + 6*Nmax + 5 * Nmax * lg Nmax
!>          where Nmax = max( NN(j), 2 ) and lg = log base 2.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array
!>
[in]LRWORK
!>          LRWORK is INTEGER
!>          The number of entries in LRWORK (dimension( ??? )
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (26)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -23: LDU < 1 or LDU < NMAX.
!>          -29: LWORK too small.
!>          If  ZLATMR, CLATMS, ZHETRD, ZUNGTR, ZSTEQR, DSTERF,
!>              or ZUNMC2 returns an error code, the
!>              absolute value of it is returned.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NBLOCK          Blocksize as returned by ENVIR.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far.
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 599 of file zchkst.f.

604*
605* -- LAPACK test routine --
606* -- LAPACK is a software package provided by Univ. of Tennessee, --
607* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
608*
609* .. Scalar Arguments ..
610 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
611 $ NSIZES, NTYPES
612 DOUBLE PRECISION THRESH
613* ..
614* .. Array Arguments ..
615 LOGICAL DOTYPE( * )
616 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
617 DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
618 $ RESULT( * ), RWORK( * ), SD( * ), SE( * ),
619 $ WA1( * ), WA2( * ), WA3( * ), WR( * )
620 COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ),
621 $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * )
622* ..
623*
624* =====================================================================
625*
626* .. Parameters ..
627 DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN
628 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
629 $ eight = 8.0d0, ten = 10.0d0, hun = 100.0d0 )
630 COMPLEX*16 CZERO, CONE
631 parameter( czero = ( 0.0d+0, 0.0d+0 ),
632 $ cone = ( 1.0d+0, 0.0d+0 ) )
633 DOUBLE PRECISION HALF
634 parameter( half = one / two )
635 INTEGER MAXTYP
636 parameter( maxtyp = 21 )
637 LOGICAL CRANGE
638 parameter( crange = .false. )
639 LOGICAL CREL
640 parameter( crel = .false. )
641* ..
642* .. Local Scalars ..
643 LOGICAL BADNN, TRYRAC
644 INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP,
645 $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN,
646 $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3,
647 $ MTYPES, N, NAP, NBLOCK, NERRS, NMATS, NMAX,
648 $ NSPLIT, NTEST, NTESTT
649 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
650 $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP,
651 $ ULPINV, UNFL, VL, VU
652* ..
653* .. Local Arrays ..
654 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
655 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
656 $ KTYPE( MAXTYP )
657 DOUBLE PRECISION DUMMA( 1 )
658* ..
659* .. External Functions ..
660 INTEGER ILAENV
661 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
662 EXTERNAL ilaenv, dlamch, dlarnd, dsxt1
663* ..
664* .. External Subroutines ..
665 EXTERNAL dcopy, dlabad, dlasum, dstebz, dstech, dsterf,
666 $ xerbla, zcopy, zhet21, zhetrd, zhpt21, zhptrd,
667 $ zlacpy, zlaset, zlatmr, zlatms, zpteqr, zstedc,
668 $ zstemr, zstein, zsteqr, zstt21, zstt22, zungtr,
669 $ zupgtr
670* ..
671* .. Intrinsic Functions ..
672 INTRINSIC abs, dble, dconjg, int, log, max, min, sqrt
673* ..
674* .. Data statements ..
675 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
676 $ 8, 8, 9, 9, 9, 9, 9, 10 /
677 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
678 $ 2, 3, 1, 1, 1, 2, 3, 1 /
679 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
680 $ 0, 0, 4, 3, 1, 4, 4, 3 /
681* ..
682* .. Executable Statements ..
683*
684* Keep ftnchek happy
685 idumma( 1 ) = 1
686*
687* Check for errors
688*
689 ntestt = 0
690 info = 0
691*
692* Important constants
693*
694 badnn = .false.
695 tryrac = .true.
696 nmax = 1
697 DO 10 j = 1, nsizes
698 nmax = max( nmax, nn( j ) )
699 IF( nn( j ).LT.0 )
700 $ badnn = .true.
701 10 CONTINUE
702*
703 nblock = ilaenv( 1, 'ZHETRD', 'L', nmax, -1, -1, -1 )
704 nblock = min( nmax, max( 1, nblock ) )
705*
706* Check for errors
707*
708 IF( nsizes.LT.0 ) THEN
709 info = -1
710 ELSE IF( badnn ) THEN
711 info = -2
712 ELSE IF( ntypes.LT.0 ) THEN
713 info = -3
714 ELSE IF( lda.LT.nmax ) THEN
715 info = -9
716 ELSE IF( ldu.LT.nmax ) THEN
717 info = -23
718 ELSE IF( 2*max( 2, nmax )**2.GT.lwork ) THEN
719 info = -29
720 END IF
721*
722 IF( info.NE.0 ) THEN
723 CALL xerbla( 'ZCHKST', -info )
724 RETURN
725 END IF
726*
727* Quick return if possible
728*
729 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
730 $ RETURN
731*
732* More Important constants
733*
734 unfl = dlamch( 'Safe minimum' )
735 ovfl = one / unfl
736 CALL dlabad( unfl, ovfl )
737 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
738 ulpinv = one / ulp
739 log2ui = int( log( ulpinv ) / log( two ) )
740 rtunfl = sqrt( unfl )
741 rtovfl = sqrt( ovfl )
742*
743* Loop over sizes, types
744*
745 DO 20 i = 1, 4
746 iseed2( i ) = iseed( i )
747 20 CONTINUE
748 nerrs = 0
749 nmats = 0
750*
751 DO 310 jsize = 1, nsizes
752 n = nn( jsize )
753 IF( n.GT.0 ) THEN
754 lgn = int( log( dble( n ) ) / log( two ) )
755 IF( 2**lgn.LT.n )
756 $ lgn = lgn + 1
757 IF( 2**lgn.LT.n )
758 $ lgn = lgn + 1
759 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
760 lrwedc = 1 + 3*n + 2*n*lgn + 4*n**2
761 liwedc = 6 + 6*n + 5*n*lgn
762 ELSE
763 lwedc = 8
764 lrwedc = 7
765 liwedc = 12
766 END IF
767 nap = ( n*( n+1 ) ) / 2
768 aninv = one / dble( max( 1, n ) )
769*
770 IF( nsizes.NE.1 ) THEN
771 mtypes = min( maxtyp, ntypes )
772 ELSE
773 mtypes = min( maxtyp+1, ntypes )
774 END IF
775*
776 DO 300 jtype = 1, mtypes
777 IF( .NOT.dotype( jtype ) )
778 $ GO TO 300
779 nmats = nmats + 1
780 ntest = 0
781*
782 DO 30 j = 1, 4
783 ioldsd( j ) = iseed( j )
784 30 CONTINUE
785*
786* Compute "A"
787*
788* Control parameters:
789*
790* KMAGN KMODE KTYPE
791* =1 O(1) clustered 1 zero
792* =2 large clustered 2 identity
793* =3 small exponential (none)
794* =4 arithmetic diagonal, (w/ eigenvalues)
795* =5 random log Hermitian, w/ eigenvalues
796* =6 random (none)
797* =7 random diagonal
798* =8 random Hermitian
799* =9 positive definite
800* =10 diagonally dominant tridiagonal
801*
802 IF( mtypes.GT.maxtyp )
803 $ GO TO 100
804*
805 itype = ktype( jtype )
806 imode = kmode( jtype )
807*
808* Compute norm
809*
810 GO TO ( 40, 50, 60 )kmagn( jtype )
811*
812 40 CONTINUE
813 anorm = one
814 GO TO 70
815*
816 50 CONTINUE
817 anorm = ( rtovfl*ulp )*aninv
818 GO TO 70
819*
820 60 CONTINUE
821 anorm = rtunfl*n*ulpinv
822 GO TO 70
823*
824 70 CONTINUE
825*
826 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
827 iinfo = 0
828 IF( jtype.LE.15 ) THEN
829 cond = ulpinv
830 ELSE
831 cond = ulpinv*aninv / ten
832 END IF
833*
834* Special Matrices -- Identity & Jordan block
835*
836* Zero
837*
838 IF( itype.EQ.1 ) THEN
839 iinfo = 0
840*
841 ELSE IF( itype.EQ.2 ) THEN
842*
843* Identity
844*
845 DO 80 jc = 1, n
846 a( jc, jc ) = anorm
847 80 CONTINUE
848*
849 ELSE IF( itype.EQ.4 ) THEN
850*
851* Diagonal Matrix, [Eigen]values Specified
852*
853 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
854 $ anorm, 0, 0, 'N', a, lda, work, iinfo )
855*
856*
857 ELSE IF( itype.EQ.5 ) THEN
858*
859* Hermitian, eigenvalues specified
860*
861 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
862 $ anorm, n, n, 'N', a, lda, work, iinfo )
863*
864 ELSE IF( itype.EQ.7 ) THEN
865*
866* Diagonal, random eigenvalues
867*
868 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
869 $ 'T', 'N', work( n+1 ), 1, one,
870 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
871 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
872*
873 ELSE IF( itype.EQ.8 ) THEN
874*
875* Hermitian, random eigenvalues
876*
877 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
878 $ 'T', 'N', work( n+1 ), 1, one,
879 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
880 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
881*
882 ELSE IF( itype.EQ.9 ) THEN
883*
884* Positive definite, eigenvalues specified.
885*
886 CALL zlatms( n, n, 'S', iseed, 'P', rwork, imode, cond,
887 $ anorm, n, n, 'N', a, lda, work, iinfo )
888*
889 ELSE IF( itype.EQ.10 ) THEN
890*
891* Positive definite tridiagonal, eigenvalues specified.
892*
893 CALL zlatms( n, n, 'S', iseed, 'P', rwork, imode, cond,
894 $ anorm, 1, 1, 'N', a, lda, work, iinfo )
895 DO 90 i = 2, n
896 temp1 = abs( a( i-1, i ) )
897 temp2 = sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
898 IF( temp1.GT.half*temp2 ) THEN
899 a( i-1, i ) = a( i-1, i )*
900 $ ( half*temp2 / ( unfl+temp1 ) )
901 a( i, i-1 ) = dconjg( a( i-1, i ) )
902 END IF
903 90 CONTINUE
904*
905 ELSE
906*
907 iinfo = 1
908 END IF
909*
910 IF( iinfo.NE.0 ) THEN
911 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
912 $ ioldsd
913 info = abs( iinfo )
914 RETURN
915 END IF
916*
917 100 CONTINUE
918*
919* Call ZHETRD and ZUNGTR to compute S and U from
920* upper triangle.
921*
922 CALL zlacpy( 'U', n, n, a, lda, v, ldu )
923*
924 ntest = 1
925 CALL zhetrd( 'U', n, v, ldu, sd, se, tau, work, lwork,
926 $ iinfo )
927*
928 IF( iinfo.NE.0 ) THEN
929 WRITE( nounit, fmt = 9999 )'ZHETRD(U)', iinfo, n, jtype,
930 $ ioldsd
931 info = abs( iinfo )
932 IF( iinfo.LT.0 ) THEN
933 RETURN
934 ELSE
935 result( 1 ) = ulpinv
936 GO TO 280
937 END IF
938 END IF
939*
940 CALL zlacpy( 'U', n, n, v, ldu, u, ldu )
941*
942 ntest = 2
943 CALL zungtr( 'U', n, u, ldu, tau, work, lwork, iinfo )
944 IF( iinfo.NE.0 ) THEN
945 WRITE( nounit, fmt = 9999 )'ZUNGTR(U)', iinfo, n, jtype,
946 $ ioldsd
947 info = abs( iinfo )
948 IF( iinfo.LT.0 ) THEN
949 RETURN
950 ELSE
951 result( 2 ) = ulpinv
952 GO TO 280
953 END IF
954 END IF
955*
956* Do tests 1 and 2
957*
958 CALL zhet21( 2, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
959 $ ldu, tau, work, rwork, result( 1 ) )
960 CALL zhet21( 3, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
961 $ ldu, tau, work, rwork, result( 2 ) )
962*
963* Call ZHETRD and ZUNGTR to compute S and U from
964* lower triangle, do tests.
965*
966 CALL zlacpy( 'L', n, n, a, lda, v, ldu )
967*
968 ntest = 3
969 CALL zhetrd( 'L', n, v, ldu, sd, se, tau, work, lwork,
970 $ iinfo )
971*
972 IF( iinfo.NE.0 ) THEN
973 WRITE( nounit, fmt = 9999 )'ZHETRD(L)', iinfo, n, jtype,
974 $ ioldsd
975 info = abs( iinfo )
976 IF( iinfo.LT.0 ) THEN
977 RETURN
978 ELSE
979 result( 3 ) = ulpinv
980 GO TO 280
981 END IF
982 END IF
983*
984 CALL zlacpy( 'L', n, n, v, ldu, u, ldu )
985*
986 ntest = 4
987 CALL zungtr( 'L', n, u, ldu, tau, work, lwork, iinfo )
988 IF( iinfo.NE.0 ) THEN
989 WRITE( nounit, fmt = 9999 )'ZUNGTR(L)', iinfo, n, jtype,
990 $ ioldsd
991 info = abs( iinfo )
992 IF( iinfo.LT.0 ) THEN
993 RETURN
994 ELSE
995 result( 4 ) = ulpinv
996 GO TO 280
997 END IF
998 END IF
999*
1000 CALL zhet21( 2, 'Lower', n, 1, a, lda, sd, se, u, ldu, v,
1001 $ ldu, tau, work, rwork, result( 3 ) )
1002 CALL zhet21( 3, 'Lower', n, 1, a, lda, sd, se, u, ldu, v,
1003 $ ldu, tau, work, rwork, result( 4 ) )
1004*
1005* Store the upper triangle of A in AP
1006*
1007 i = 0
1008 DO 120 jc = 1, n
1009 DO 110 jr = 1, jc
1010 i = i + 1
1011 ap( i ) = a( jr, jc )
1012 110 CONTINUE
1013 120 CONTINUE
1014*
1015* Call ZHPTRD and ZUPGTR to compute S and U from AP
1016*
1017 CALL zcopy( nap, ap, 1, vp, 1 )
1018*
1019 ntest = 5
1020 CALL zhptrd( 'U', n, vp, sd, se, tau, iinfo )
1021*
1022 IF( iinfo.NE.0 ) THEN
1023 WRITE( nounit, fmt = 9999 )'ZHPTRD(U)', iinfo, n, jtype,
1024 $ ioldsd
1025 info = abs( iinfo )
1026 IF( iinfo.LT.0 ) THEN
1027 RETURN
1028 ELSE
1029 result( 5 ) = ulpinv
1030 GO TO 280
1031 END IF
1032 END IF
1033*
1034 ntest = 6
1035 CALL zupgtr( 'U', n, vp, tau, u, ldu, work, iinfo )
1036 IF( iinfo.NE.0 ) THEN
1037 WRITE( nounit, fmt = 9999 )'ZUPGTR(U)', iinfo, n, jtype,
1038 $ ioldsd
1039 info = abs( iinfo )
1040 IF( iinfo.LT.0 ) THEN
1041 RETURN
1042 ELSE
1043 result( 6 ) = ulpinv
1044 GO TO 280
1045 END IF
1046 END IF
1047*
1048* Do tests 5 and 6
1049*
1050 CALL zhpt21( 2, 'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1051 $ work, rwork, result( 5 ) )
1052 CALL zhpt21( 3, 'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1053 $ work, rwork, result( 6 ) )
1054*
1055* Store the lower triangle of A in AP
1056*
1057 i = 0
1058 DO 140 jc = 1, n
1059 DO 130 jr = jc, n
1060 i = i + 1
1061 ap( i ) = a( jr, jc )
1062 130 CONTINUE
1063 140 CONTINUE
1064*
1065* Call ZHPTRD and ZUPGTR to compute S and U from AP
1066*
1067 CALL zcopy( nap, ap, 1, vp, 1 )
1068*
1069 ntest = 7
1070 CALL zhptrd( 'L', n, vp, sd, se, tau, iinfo )
1071*
1072 IF( iinfo.NE.0 ) THEN
1073 WRITE( nounit, fmt = 9999 )'ZHPTRD(L)', iinfo, n, jtype,
1074 $ ioldsd
1075 info = abs( iinfo )
1076 IF( iinfo.LT.0 ) THEN
1077 RETURN
1078 ELSE
1079 result( 7 ) = ulpinv
1080 GO TO 280
1081 END IF
1082 END IF
1083*
1084 ntest = 8
1085 CALL zupgtr( 'L', n, vp, tau, u, ldu, work, iinfo )
1086 IF( iinfo.NE.0 ) THEN
1087 WRITE( nounit, fmt = 9999 )'ZUPGTR(L)', iinfo, n, jtype,
1088 $ ioldsd
1089 info = abs( iinfo )
1090 IF( iinfo.LT.0 ) THEN
1091 RETURN
1092 ELSE
1093 result( 8 ) = ulpinv
1094 GO TO 280
1095 END IF
1096 END IF
1097*
1098 CALL zhpt21( 2, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1099 $ work, rwork, result( 7 ) )
1100 CALL zhpt21( 3, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1101 $ work, rwork, result( 8 ) )
1102*
1103* Call ZSTEQR to compute D1, D2, and Z, do tests.
1104*
1105* Compute D1 and Z
1106*
1107 CALL dcopy( n, sd, 1, d1, 1 )
1108 IF( n.GT.0 )
1109 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1110 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1111*
1112 ntest = 9
1113 CALL zsteqr( 'V', n, d1, rwork, z, ldu, rwork( n+1 ),
1114 $ iinfo )
1115 IF( iinfo.NE.0 ) THEN
1116 WRITE( nounit, fmt = 9999 )'ZSTEQR(V)', iinfo, n, jtype,
1117 $ ioldsd
1118 info = abs( iinfo )
1119 IF( iinfo.LT.0 ) THEN
1120 RETURN
1121 ELSE
1122 result( 9 ) = ulpinv
1123 GO TO 280
1124 END IF
1125 END IF
1126*
1127* Compute D2
1128*
1129 CALL dcopy( n, sd, 1, d2, 1 )
1130 IF( n.GT.0 )
1131 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1132*
1133 ntest = 11
1134 CALL zsteqr( 'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1135 $ iinfo )
1136 IF( iinfo.NE.0 ) THEN
1137 WRITE( nounit, fmt = 9999 )'ZSTEQR(N)', iinfo, n, jtype,
1138 $ ioldsd
1139 info = abs( iinfo )
1140 IF( iinfo.LT.0 ) THEN
1141 RETURN
1142 ELSE
1143 result( 11 ) = ulpinv
1144 GO TO 280
1145 END IF
1146 END IF
1147*
1148* Compute D3 (using PWK method)
1149*
1150 CALL dcopy( n, sd, 1, d3, 1 )
1151 IF( n.GT.0 )
1152 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1153*
1154 ntest = 12
1155 CALL dsterf( n, d3, rwork, iinfo )
1156 IF( iinfo.NE.0 ) THEN
1157 WRITE( nounit, fmt = 9999 )'DSTERF', iinfo, n, jtype,
1158 $ ioldsd
1159 info = abs( iinfo )
1160 IF( iinfo.LT.0 ) THEN
1161 RETURN
1162 ELSE
1163 result( 12 ) = ulpinv
1164 GO TO 280
1165 END IF
1166 END IF
1167*
1168* Do Tests 9 and 10
1169*
1170 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1171 $ result( 9 ) )
1172*
1173* Do Tests 11 and 12
1174*
1175 temp1 = zero
1176 temp2 = zero
1177 temp3 = zero
1178 temp4 = zero
1179*
1180 DO 150 j = 1, n
1181 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1182 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1183 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1184 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1185 150 CONTINUE
1186*
1187 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1188 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1189*
1190* Do Test 13 -- Sturm Sequence Test of Eigenvalues
1191* Go up by factors of two until it succeeds
1192*
1193 ntest = 13
1194 temp1 = thresh*( half-ulp )
1195*
1196 DO 160 j = 0, log2ui
1197 CALL dstech( n, sd, se, d1, temp1, rwork, iinfo )
1198 IF( iinfo.EQ.0 )
1199 $ GO TO 170
1200 temp1 = temp1*two
1201 160 CONTINUE
1202*
1203 170 CONTINUE
1204 result( 13 ) = temp1
1205*
1206* For positive definite matrices ( JTYPE.GT.15 ) call ZPTEQR
1207* and do tests 14, 15, and 16 .
1208*
1209 IF( jtype.GT.15 ) THEN
1210*
1211* Compute D4 and Z4
1212*
1213 CALL dcopy( n, sd, 1, d4, 1 )
1214 IF( n.GT.0 )
1215 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1216 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1217*
1218 ntest = 14
1219 CALL zpteqr( 'V', n, d4, rwork, z, ldu, rwork( n+1 ),
1220 $ iinfo )
1221 IF( iinfo.NE.0 ) THEN
1222 WRITE( nounit, fmt = 9999 )'ZPTEQR(V)', iinfo, n,
1223 $ jtype, ioldsd
1224 info = abs( iinfo )
1225 IF( iinfo.LT.0 ) THEN
1226 RETURN
1227 ELSE
1228 result( 14 ) = ulpinv
1229 GO TO 280
1230 END IF
1231 END IF
1232*
1233* Do Tests 14 and 15
1234*
1235 CALL zstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1236 $ rwork, result( 14 ) )
1237*
1238* Compute D5
1239*
1240 CALL dcopy( n, sd, 1, d5, 1 )
1241 IF( n.GT.0 )
1242 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1243*
1244 ntest = 16
1245 CALL zpteqr( 'N', n, d5, rwork, z, ldu, rwork( n+1 ),
1246 $ iinfo )
1247 IF( iinfo.NE.0 ) THEN
1248 WRITE( nounit, fmt = 9999 )'ZPTEQR(N)', iinfo, n,
1249 $ jtype, ioldsd
1250 info = abs( iinfo )
1251 IF( iinfo.LT.0 ) THEN
1252 RETURN
1253 ELSE
1254 result( 16 ) = ulpinv
1255 GO TO 280
1256 END IF
1257 END IF
1258*
1259* Do Test 16
1260*
1261 temp1 = zero
1262 temp2 = zero
1263 DO 180 j = 1, n
1264 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1265 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1266 180 CONTINUE
1267*
1268 result( 16 ) = temp2 / max( unfl,
1269 $ hun*ulp*max( temp1, temp2 ) )
1270 ELSE
1271 result( 14 ) = zero
1272 result( 15 ) = zero
1273 result( 16 ) = zero
1274 END IF
1275*
1276* Call DSTEBZ with different options and do tests 17-18.
1277*
1278* If S is positive definite and diagonally dominant,
1279* ask for all eigenvalues with high relative accuracy.
1280*
1281 vl = zero
1282 vu = zero
1283 il = 0
1284 iu = 0
1285 IF( jtype.EQ.21 ) THEN
1286 ntest = 17
1287 abstol = unfl + unfl
1288 CALL dstebz( 'A', 'E', n, vl, vu, il, iu, abstol, sd, se,
1289 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1290 $ rwork, iwork( 2*n+1 ), iinfo )
1291 IF( iinfo.NE.0 ) THEN
1292 WRITE( nounit, fmt = 9999 )'DSTEBZ(A,rel)', iinfo, n,
1293 $ jtype, ioldsd
1294 info = abs( iinfo )
1295 IF( iinfo.LT.0 ) THEN
1296 RETURN
1297 ELSE
1298 result( 17 ) = ulpinv
1299 GO TO 280
1300 END IF
1301 END IF
1302*
1303* Do test 17
1304*
1305 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1306 $ ( one-half )**4
1307*
1308 temp1 = zero
1309 DO 190 j = 1, n
1310 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1311 $ ( abstol+abs( d4( j ) ) ) )
1312 190 CONTINUE
1313*
1314 result( 17 ) = temp1 / temp2
1315 ELSE
1316 result( 17 ) = zero
1317 END IF
1318*
1319* Now ask for all eigenvalues with high absolute accuracy.
1320*
1321 ntest = 18
1322 abstol = unfl + unfl
1323 CALL dstebz( 'A', 'E', n, vl, vu, il, iu, abstol, sd, se, m,
1324 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1325 $ iwork( 2*n+1 ), iinfo )
1326 IF( iinfo.NE.0 ) THEN
1327 WRITE( nounit, fmt = 9999 )'DSTEBZ(A)', iinfo, n, jtype,
1328 $ ioldsd
1329 info = abs( iinfo )
1330 IF( iinfo.LT.0 ) THEN
1331 RETURN
1332 ELSE
1333 result( 18 ) = ulpinv
1334 GO TO 280
1335 END IF
1336 END IF
1337*
1338* Do test 18
1339*
1340 temp1 = zero
1341 temp2 = zero
1342 DO 200 j = 1, n
1343 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1344 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1345 200 CONTINUE
1346*
1347 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1348*
1349* Choose random values for IL and IU, and ask for the
1350* IL-th through IU-th eigenvalues.
1351*
1352 ntest = 19
1353 IF( n.LE.1 ) THEN
1354 il = 1
1355 iu = n
1356 ELSE
1357 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1358 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1359 IF( iu.LT.il ) THEN
1360 itemp = iu
1361 iu = il
1362 il = itemp
1363 END IF
1364 END IF
1365*
1366 CALL dstebz( 'I', 'E', n, vl, vu, il, iu, abstol, sd, se,
1367 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1368 $ rwork, iwork( 2*n+1 ), iinfo )
1369 IF( iinfo.NE.0 ) THEN
1370 WRITE( nounit, fmt = 9999 )'DSTEBZ(I)', iinfo, n, jtype,
1371 $ ioldsd
1372 info = abs( iinfo )
1373 IF( iinfo.LT.0 ) THEN
1374 RETURN
1375 ELSE
1376 result( 19 ) = ulpinv
1377 GO TO 280
1378 END IF
1379 END IF
1380*
1381* Determine the values VL and VU of the IL-th and IU-th
1382* eigenvalues and ask for all eigenvalues in this range.
1383*
1384 IF( n.GT.0 ) THEN
1385 IF( il.NE.1 ) THEN
1386 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1387 $ ulp*anorm, two*rtunfl )
1388 ELSE
1389 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1390 $ ulp*anorm, two*rtunfl )
1391 END IF
1392 IF( iu.NE.n ) THEN
1393 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1394 $ ulp*anorm, two*rtunfl )
1395 ELSE
1396 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1397 $ ulp*anorm, two*rtunfl )
1398 END IF
1399 ELSE
1400 vl = zero
1401 vu = one
1402 END IF
1403*
1404 CALL dstebz( 'V', 'E', n, vl, vu, il, iu, abstol, sd, se,
1405 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1406 $ rwork, iwork( 2*n+1 ), iinfo )
1407 IF( iinfo.NE.0 ) THEN
1408 WRITE( nounit, fmt = 9999 )'DSTEBZ(V)', iinfo, n, jtype,
1409 $ ioldsd
1410 info = abs( iinfo )
1411 IF( iinfo.LT.0 ) THEN
1412 RETURN
1413 ELSE
1414 result( 19 ) = ulpinv
1415 GO TO 280
1416 END IF
1417 END IF
1418*
1419 IF( m3.EQ.0 .AND. n.NE.0 ) THEN
1420 result( 19 ) = ulpinv
1421 GO TO 280
1422 END IF
1423*
1424* Do test 19
1425*
1426 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1427 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1428 IF( n.GT.0 ) THEN
1429 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1430 ELSE
1431 temp3 = zero
1432 END IF
1433*
1434 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1435*
1436* Call ZSTEIN to compute eigenvectors corresponding to
1437* eigenvalues in WA1. (First call DSTEBZ again, to make sure
1438* it returns these eigenvalues in the correct order.)
1439*
1440 ntest = 21
1441 CALL dstebz( 'A', 'B', n, vl, vu, il, iu, abstol, sd, se, m,
1442 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1443 $ iwork( 2*n+1 ), iinfo )
1444 IF( iinfo.NE.0 ) THEN
1445 WRITE( nounit, fmt = 9999 )'DSTEBZ(A,B)', iinfo, n,
1446 $ jtype, ioldsd
1447 info = abs( iinfo )
1448 IF( iinfo.LT.0 ) THEN
1449 RETURN
1450 ELSE
1451 result( 20 ) = ulpinv
1452 result( 21 ) = ulpinv
1453 GO TO 280
1454 END IF
1455 END IF
1456*
1457 CALL zstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1458 $ ldu, rwork, iwork( 2*n+1 ), iwork( 3*n+1 ),
1459 $ iinfo )
1460 IF( iinfo.NE.0 ) THEN
1461 WRITE( nounit, fmt = 9999 )'ZSTEIN', iinfo, n, jtype,
1462 $ ioldsd
1463 info = abs( iinfo )
1464 IF( iinfo.LT.0 ) THEN
1465 RETURN
1466 ELSE
1467 result( 20 ) = ulpinv
1468 result( 21 ) = ulpinv
1469 GO TO 280
1470 END IF
1471 END IF
1472*
1473* Do tests 20 and 21
1474*
1475 CALL zstt21( n, 0, sd, se, wa1, dumma, z, ldu, work, rwork,
1476 $ result( 20 ) )
1477*
1478* Call ZSTEDC(I) to compute D1 and Z, do tests.
1479*
1480* Compute D1 and Z
1481*
1482 inde = 1
1483 indrwk = inde + n
1484 CALL dcopy( n, sd, 1, d1, 1 )
1485 IF( n.GT.0 )
1486 $ CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1487 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1488*
1489 ntest = 22
1490 CALL zstedc( 'I', n, d1, rwork( inde ), z, ldu, work, lwedc,
1491 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1492 IF( iinfo.NE.0 ) THEN
1493 WRITE( nounit, fmt = 9999 )'ZSTEDC(I)', iinfo, n, jtype,
1494 $ ioldsd
1495 info = abs( iinfo )
1496 IF( iinfo.LT.0 ) THEN
1497 RETURN
1498 ELSE
1499 result( 22 ) = ulpinv
1500 GO TO 280
1501 END IF
1502 END IF
1503*
1504* Do Tests 22 and 23
1505*
1506 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1507 $ result( 22 ) )
1508*
1509* Call ZSTEDC(V) to compute D1 and Z, do tests.
1510*
1511* Compute D1 and Z
1512*
1513 CALL dcopy( n, sd, 1, d1, 1 )
1514 IF( n.GT.0 )
1515 $ CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1516 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1517*
1518 ntest = 24
1519 CALL zstedc( 'V', n, d1, rwork( inde ), z, ldu, work, lwedc,
1520 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1521 IF( iinfo.NE.0 ) THEN
1522 WRITE( nounit, fmt = 9999 )'ZSTEDC(V)', iinfo, n, jtype,
1523 $ ioldsd
1524 info = abs( iinfo )
1525 IF( iinfo.LT.0 ) THEN
1526 RETURN
1527 ELSE
1528 result( 24 ) = ulpinv
1529 GO TO 280
1530 END IF
1531 END IF
1532*
1533* Do Tests 24 and 25
1534*
1535 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1536 $ result( 24 ) )
1537*
1538* Call ZSTEDC(N) to compute D2, do tests.
1539*
1540* Compute D2
1541*
1542 CALL dcopy( n, sd, 1, d2, 1 )
1543 IF( n.GT.0 )
1544 $ CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1545 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1546*
1547 ntest = 26
1548 CALL zstedc( 'N', n, d2, rwork( inde ), z, ldu, work, lwedc,
1549 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1550 IF( iinfo.NE.0 ) THEN
1551 WRITE( nounit, fmt = 9999 )'ZSTEDC(N)', iinfo, n, jtype,
1552 $ ioldsd
1553 info = abs( iinfo )
1554 IF( iinfo.LT.0 ) THEN
1555 RETURN
1556 ELSE
1557 result( 26 ) = ulpinv
1558 GO TO 280
1559 END IF
1560 END IF
1561*
1562* Do Test 26
1563*
1564 temp1 = zero
1565 temp2 = zero
1566*
1567 DO 210 j = 1, n
1568 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1569 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1570 210 CONTINUE
1571*
1572 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1573*
1574* Only test ZSTEMR if IEEE compliant
1575*
1576 IF( ilaenv( 10, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1577 $ ilaenv( 11, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
1578*
1579* Call ZSTEMR, do test 27 (relative eigenvalue accuracy)
1580*
1581* If S is positive definite and diagonally dominant,
1582* ask for all eigenvalues with high relative accuracy.
1583*
1584 vl = zero
1585 vu = zero
1586 il = 0
1587 iu = 0
1588 IF( jtype.EQ.21 .AND. crel ) THEN
1589 ntest = 27
1590 abstol = unfl + unfl
1591 CALL zstemr( 'V', 'A', n, sd, se, vl, vu, il, iu,
1592 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1593 $ rwork, lrwork, iwork( 2*n+1 ), lwork-2*n,
1594 $ iinfo )
1595 IF( iinfo.NE.0 ) THEN
1596 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,A,rel)',
1597 $ iinfo, n, jtype, ioldsd
1598 info = abs( iinfo )
1599 IF( iinfo.LT.0 ) THEN
1600 RETURN
1601 ELSE
1602 result( 27 ) = ulpinv
1603 GO TO 270
1604 END IF
1605 END IF
1606*
1607* Do test 27
1608*
1609 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1610 $ ( one-half )**4
1611*
1612 temp1 = zero
1613 DO 220 j = 1, n
1614 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1615 $ ( abstol+abs( d4( j ) ) ) )
1616 220 CONTINUE
1617*
1618 result( 27 ) = temp1 / temp2
1619*
1620 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1621 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1622 IF( iu.LT.il ) THEN
1623 itemp = iu
1624 iu = il
1625 il = itemp
1626 END IF
1627*
1628 IF( crange ) THEN
1629 ntest = 28
1630 abstol = unfl + unfl
1631 CALL zstemr( 'V', 'I', n, sd, se, vl, vu, il, iu,
1632 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1633 $ rwork, lrwork, iwork( 2*n+1 ),
1634 $ lwork-2*n, iinfo )
1635*
1636 IF( iinfo.NE.0 ) THEN
1637 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,I,rel)',
1638 $ iinfo, n, jtype, ioldsd
1639 info = abs( iinfo )
1640 IF( iinfo.LT.0 ) THEN
1641 RETURN
1642 ELSE
1643 result( 28 ) = ulpinv
1644 GO TO 270
1645 END IF
1646 END IF
1647*
1648*
1649* Do test 28
1650*
1651 temp2 = two*( two*n-one )*ulp*
1652 $ ( one+eight*half**2 ) / ( one-half )**4
1653*
1654 temp1 = zero
1655 DO 230 j = il, iu
1656 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1657 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1658 230 CONTINUE
1659*
1660 result( 28 ) = temp1 / temp2
1661 ELSE
1662 result( 28 ) = zero
1663 END IF
1664 ELSE
1665 result( 27 ) = zero
1666 result( 28 ) = zero
1667 END IF
1668*
1669* Call ZSTEMR(V,I) to compute D1 and Z, do tests.
1670*
1671* Compute D1 and Z
1672*
1673 CALL dcopy( n, sd, 1, d5, 1 )
1674 IF( n.GT.0 )
1675 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1676 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1677*
1678 IF( crange ) THEN
1679 ntest = 29
1680 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1681 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1682 IF( iu.LT.il ) THEN
1683 itemp = iu
1684 iu = il
1685 il = itemp
1686 END IF
1687 CALL zstemr( 'V', 'I', n, d5, rwork, vl, vu, il, iu,
1688 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1689 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1690 $ liwork-2*n, iinfo )
1691 IF( iinfo.NE.0 ) THEN
1692 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,I)', iinfo,
1693 $ n, jtype, ioldsd
1694 info = abs( iinfo )
1695 IF( iinfo.LT.0 ) THEN
1696 RETURN
1697 ELSE
1698 result( 29 ) = ulpinv
1699 GO TO 280
1700 END IF
1701 END IF
1702*
1703* Do Tests 29 and 30
1704*
1705*
1706* Call ZSTEMR to compute D2, do tests.
1707*
1708* Compute D2
1709*
1710 CALL dcopy( n, sd, 1, d5, 1 )
1711 IF( n.GT.0 )
1712 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1713*
1714 ntest = 31
1715 CALL zstemr( 'N', 'I', n, d5, rwork, vl, vu, il, iu,
1716 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1717 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1718 $ liwork-2*n, iinfo )
1719 IF( iinfo.NE.0 ) THEN
1720 WRITE( nounit, fmt = 9999 )'ZSTEMR(N,I)', iinfo,
1721 $ n, jtype, ioldsd
1722 info = abs( iinfo )
1723 IF( iinfo.LT.0 ) THEN
1724 RETURN
1725 ELSE
1726 result( 31 ) = ulpinv
1727 GO TO 280
1728 END IF
1729 END IF
1730*
1731* Do Test 31
1732*
1733 temp1 = zero
1734 temp2 = zero
1735*
1736 DO 240 j = 1, iu - il + 1
1737 temp1 = max( temp1, abs( d1( j ) ),
1738 $ abs( d2( j ) ) )
1739 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1740 240 CONTINUE
1741*
1742 result( 31 ) = temp2 / max( unfl,
1743 $ ulp*max( temp1, temp2 ) )
1744*
1745*
1746* Call ZSTEMR(V,V) to compute D1 and Z, do tests.
1747*
1748* Compute D1 and Z
1749*
1750 CALL dcopy( n, sd, 1, d5, 1 )
1751 IF( n.GT.0 )
1752 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1753 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1754*
1755 ntest = 32
1756*
1757 IF( n.GT.0 ) THEN
1758 IF( il.NE.1 ) THEN
1759 vl = d2( il ) - max( half*
1760 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1761 $ two*rtunfl )
1762 ELSE
1763 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1764 $ ulp*anorm, two*rtunfl )
1765 END IF
1766 IF( iu.NE.n ) THEN
1767 vu = d2( iu ) + max( half*
1768 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1769 $ two*rtunfl )
1770 ELSE
1771 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1772 $ ulp*anorm, two*rtunfl )
1773 END IF
1774 ELSE
1775 vl = zero
1776 vu = one
1777 END IF
1778*
1779 CALL zstemr( 'V', 'V', n, d5, rwork, vl, vu, il, iu,
1780 $ m, d1, z, ldu, m, iwork( 1 ), tryrac,
1781 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1782 $ liwork-2*n, iinfo )
1783 IF( iinfo.NE.0 ) THEN
1784 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,V)', iinfo,
1785 $ n, jtype, ioldsd
1786 info = abs( iinfo )
1787 IF( iinfo.LT.0 ) THEN
1788 RETURN
1789 ELSE
1790 result( 32 ) = ulpinv
1791 GO TO 280
1792 END IF
1793 END IF
1794*
1795* Do Tests 32 and 33
1796*
1797 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1798 $ m, rwork, result( 32 ) )
1799*
1800* Call ZSTEMR to compute D2, do tests.
1801*
1802* Compute D2
1803*
1804 CALL dcopy( n, sd, 1, d5, 1 )
1805 IF( n.GT.0 )
1806 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1807*
1808 ntest = 34
1809 CALL zstemr( 'N', 'V', n, d5, rwork, vl, vu, il, iu,
1810 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1811 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1812 $ liwork-2*n, iinfo )
1813 IF( iinfo.NE.0 ) THEN
1814 WRITE( nounit, fmt = 9999 )'ZSTEMR(N,V)', iinfo,
1815 $ n, jtype, ioldsd
1816 info = abs( iinfo )
1817 IF( iinfo.LT.0 ) THEN
1818 RETURN
1819 ELSE
1820 result( 34 ) = ulpinv
1821 GO TO 280
1822 END IF
1823 END IF
1824*
1825* Do Test 34
1826*
1827 temp1 = zero
1828 temp2 = zero
1829*
1830 DO 250 j = 1, iu - il + 1
1831 temp1 = max( temp1, abs( d1( j ) ),
1832 $ abs( d2( j ) ) )
1833 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1834 250 CONTINUE
1835*
1836 result( 34 ) = temp2 / max( unfl,
1837 $ ulp*max( temp1, temp2 ) )
1838 ELSE
1839 result( 29 ) = zero
1840 result( 30 ) = zero
1841 result( 31 ) = zero
1842 result( 32 ) = zero
1843 result( 33 ) = zero
1844 result( 34 ) = zero
1845 END IF
1846*
1847*
1848* Call ZSTEMR(V,A) to compute D1 and Z, do tests.
1849*
1850* Compute D1 and Z
1851*
1852 CALL dcopy( n, sd, 1, d5, 1 )
1853 IF( n.GT.0 )
1854 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1855*
1856 ntest = 35
1857*
1858 CALL zstemr( 'V', 'A', n, d5, rwork, vl, vu, il, iu,
1859 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1860 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1861 $ liwork-2*n, iinfo )
1862 IF( iinfo.NE.0 ) THEN
1863 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,A)', iinfo, n,
1864 $ jtype, ioldsd
1865 info = abs( iinfo )
1866 IF( iinfo.LT.0 ) THEN
1867 RETURN
1868 ELSE
1869 result( 35 ) = ulpinv
1870 GO TO 280
1871 END IF
1872 END IF
1873*
1874* Do Tests 35 and 36
1875*
1876 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1877 $ rwork, result( 35 ) )
1878*
1879* Call ZSTEMR to compute D2, do tests.
1880*
1881* Compute D2
1882*
1883 CALL dcopy( n, sd, 1, d5, 1 )
1884 IF( n.GT.0 )
1885 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1886*
1887 ntest = 37
1888 CALL zstemr( 'N', 'A', n, d5, rwork, vl, vu, il, iu,
1889 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1890 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1891 $ liwork-2*n, iinfo )
1892 IF( iinfo.NE.0 ) THEN
1893 WRITE( nounit, fmt = 9999 )'ZSTEMR(N,A)', iinfo, n,
1894 $ jtype, ioldsd
1895 info = abs( iinfo )
1896 IF( iinfo.LT.0 ) THEN
1897 RETURN
1898 ELSE
1899 result( 37 ) = ulpinv
1900 GO TO 280
1901 END IF
1902 END IF
1903*
1904* Do Test 34
1905*
1906 temp1 = zero
1907 temp2 = zero
1908*
1909 DO 260 j = 1, n
1910 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1911 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1912 260 CONTINUE
1913*
1914 result( 37 ) = temp2 / max( unfl,
1915 $ ulp*max( temp1, temp2 ) )
1916 END IF
1917 270 CONTINUE
1918 280 CONTINUE
1919 ntestt = ntestt + ntest
1920*
1921* End of Loop -- Check for RESULT(j) > THRESH
1922*
1923*
1924* Print out tests which fail.
1925*
1926 DO 290 jr = 1, ntest
1927 IF( result( jr ).GE.thresh ) THEN
1928*
1929* If this is the first test to fail,
1930* print a header to the data file.
1931*
1932 IF( nerrs.EQ.0 ) THEN
1933 WRITE( nounit, fmt = 9998 )'ZST'
1934 WRITE( nounit, fmt = 9997 )
1935 WRITE( nounit, fmt = 9996 )
1936 WRITE( nounit, fmt = 9995 )'Hermitian'
1937 WRITE( nounit, fmt = 9994 )
1938*
1939* Tests performed
1940*
1941 WRITE( nounit, fmt = 9987 )
1942 END IF
1943 nerrs = nerrs + 1
1944 IF( result( jr ).LT.10000.0d0 ) THEN
1945 WRITE( nounit, fmt = 9989 )n, jtype, ioldsd, jr,
1946 $ result( jr )
1947 ELSE
1948 WRITE( nounit, fmt = 9988 )n, jtype, ioldsd, jr,
1949 $ result( jr )
1950 END IF
1951 END IF
1952 290 CONTINUE
1953 300 CONTINUE
1954 310 CONTINUE
1955*
1956* Summary
1957*
1958 CALL dlasum( 'ZST', nounit, nerrs, ntestt )
1959 RETURN
1960*
1961 9999 FORMAT( ' ZCHKST: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1962 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1963*
1964 9998 FORMAT( / 1x, a3, ' -- Complex Hermitian eigenvalue problem' )
1965 9997 FORMAT( ' Matrix types (see ZCHKST for details): ' )
1966*
1967 9996 FORMAT( / ' Special Matrices:',
1968 $ / ' 1=Zero matrix. ',
1969 $ ' 5=Diagonal: clustered entries.',
1970 $ / ' 2=Identity matrix. ',
1971 $ ' 6=Diagonal: large, evenly spaced.',
1972 $ / ' 3=Diagonal: evenly spaced entries. ',
1973 $ ' 7=Diagonal: small, evenly spaced.',
1974 $ / ' 4=Diagonal: geometr. spaced entries.' )
1975 9995 FORMAT( ' Dense ', a, ' Matrices:',
1976 $ / ' 8=Evenly spaced eigenvals. ',
1977 $ ' 12=Small, evenly spaced eigenvals.',
1978 $ / ' 9=Geometrically spaced eigenvals. ',
1979 $ ' 13=Matrix with random O(1) entries.',
1980 $ / ' 10=Clustered eigenvalues. ',
1981 $ ' 14=Matrix with large random entries.',
1982 $ / ' 11=Large, evenly spaced eigenvals. ',
1983 $ ' 15=Matrix with small random entries.' )
1984 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues',
1985 $ / ' 17=Positive definite, geometrically spaced eigenvlaues',
1986 $ / ' 18=Positive definite, clustered eigenvalues',
1987 $ / ' 19=Positive definite, small evenly spaced eigenvalues',
1988 $ / ' 20=Positive definite, large evenly spaced eigenvalues',
1989 $ / ' 21=Diagonally dominant tridiagonal, geometrically',
1990 $ ' spaced eigenvalues' )
1991*
1992 9989 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
1993 $ 4( i4, ',' ), ' result ', i3, ' is', 0p, f8.2 )
1994 9988 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
1995 $ 4( i4, ',' ), ' result ', i3, ' is', 1p, d10.3 )
1996*
1997 9987 FORMAT( / 'Test performed: see ZCHKST for details.', / )
1998* End of ZCHKST
1999*
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
dstebz
subroutine dstebz(range, order, n, vl, vu, il, iu, abstol, d, e, m, nsplit, w, iblock, isplit, work, iwork, info)
DSTEBZ
Definition dstebz.f:273
dsterf
subroutine dsterf(n, d, e, info)
DSTERF
Definition dsterf.f:86
zhetrd
subroutine zhetrd(uplo, n, a, lda, d, e, tau, work, lwork, info)
ZHETRD
Definition zhetrd.f:192
zupgtr
subroutine zupgtr(uplo, n, ap, tau, q, ldq, work, info)
ZUPGTR
Definition zupgtr.f:114
zstein
subroutine zstein(n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
ZSTEIN
Definition zstein.f:182
zstemr
subroutine zstemr(jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
ZSTEMR
Definition zstemr.f:338
zungtr
subroutine zungtr(uplo, n, a, lda, tau, work, lwork, info)
ZUNGTR
Definition zungtr.f:123
zstedc
subroutine zstedc(compz, n, d, e, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZSTEDC
Definition zstedc.f:212
zhptrd
subroutine zhptrd(uplo, n, ap, d, e, tau, info)
ZHPTRD
Definition zhptrd.f:151
zpteqr
subroutine zpteqr(compz, n, d, e, z, ldz, work, info)
ZPTEQR
Definition zpteqr.f:145
zhet21
subroutine zhet21(itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
ZHET21
Definition zhet21.f:214
zstt22
subroutine zstt22(n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, rwork, result)
ZSTT22
Definition zstt22.f:145
zhpt21
subroutine zhpt21(itype, uplo, n, kband, ap, d, e, u, ldu, vp, tau, work, rwork, result)
ZHPT21
Definition zhpt21.f:228
zstt21
subroutine zstt21(n, kband, ad, ae, sd, se, u, ldu, work, rwork, result)
ZSTT21
Definition zstt21.f:133
dstech
subroutine dstech(n, a, b, eig, tol, work, info)
DSTECH
Definition dstech.f:101
dsxt1
double precision function dsxt1(ijob, d1, n1, d2, n2, abstol, ulp, unfl)
DSXT1
Definition dsxt1.f:106

◆ zchkst2stg()

subroutine zchkst2stg ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) ap,
double precision, dimension( * ) sd,
double precision, dimension( * ) se,
double precision, dimension( * ) d1,
double precision, dimension( * ) d2,
double precision, dimension( * ) d3,
double precision, dimension( * ) d4,
double precision, dimension( * ) d5,
double precision, dimension( * ) wa1,
double precision, dimension( * ) wa2,
double precision, dimension( * ) wa3,
double precision, dimension( * ) wr,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldu, * ) v,
complex*16, dimension( * ) vp,
complex*16, dimension( * ) tau,
complex*16, dimension( ldu, * ) z,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer lrwork,
integer, dimension( * ) iwork,
integer liwork,
double precision, dimension( * ) result,
integer info )

ZCHKST2STG

Purpose:
!>
!> ZCHKST2STG  checks the Hermitian eigenvalue problem routines
!> using the 2-stage reduction techniques. Since the generation
!> of Q or the vectors is not available in this release, we only 
!> compare the eigenvalue resulting when using the 2-stage to the 
!> one considered as reference using the standard 1-stage reduction
!> ZHETRD. For that, we call the standard ZHETRD and compute D1 using 
!> DSTEQR, then we call the 2-stage ZHETRD_2STAGE with Upper and Lower
!> and we compute D2 and D3 using DSTEQR and then we replaced tests
!> 3 and 4 by tests 11 and 12. test 1 and 2 remain to verify that 
!> the 1-stage results are OK and can be trusted.
!> This testing routine will converge to the ZCHKST in the next 
!> release when vectors and generation of Q will be implemented.
!>
!>    ZHETRD factors A as  U S U* , where * means conjugate transpose,
!>    S is real symmetric tridiagonal, and U is unitary.
!>    ZHETRD can use either just the lower or just the upper triangle
!>    of A; ZCHKST2STG checks both cases.
!>    U is represented as a product of Householder
!>    transformations, whose vectors are stored in the first
!>    n-1 columns of V, and whose scale factors are in TAU.
!>
!>    ZHPTRD does the same as ZHETRD, except that A and V are stored
!>    in  format.
!>
!>    ZUNGTR constructs the matrix U from the contents of V and TAU.
!>
!>    ZUPGTR constructs the matrix U from the contents of VP and TAU.
!>
!>    ZSTEQR factors S as  Z D1 Z* , where Z is the unitary
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal.  D2 is the matrix of
!>    eigenvalues computed when Z is not computed.
!>
!>    DSTERF computes D3, the matrix of eigenvalues, by the
!>    PWK method, which does not yield eigenvectors.
!>
!>    ZPTEQR factors S as  Z4 D4 Z4* , for a
!>    Hermitian positive definite tridiagonal matrix.
!>    D5 is the matrix of eigenvalues computed when Z is not
!>    computed.
!>
!>    DSTEBZ computes selected eigenvalues.  WA1, WA2, and
!>    WA3 will denote eigenvalues computed to high
!>    absolute accuracy, with different range options.
!>    WR will denote eigenvalues computed to high relative
!>    accuracy.
!>
!>    ZSTEIN computes Y, the eigenvectors of S, given the
!>    eigenvalues.
!>
!>    ZSTEDC factors S as Z D1 Z* , where Z is the unitary
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal ('I' option). It may also
!>    update an input unitary matrix, usually the output
!>    from ZHETRD/ZUNGTR or ZHPTRD/ZUPGTR ('V' option). It may
!>    also just compute eigenvalues ('N' option).
!>
!>    ZSTEMR factors S as Z D1 Z* , where Z is the unitary
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal ('I' option).  ZSTEMR
!>    uses the Relatively Robust Representation whenever possible.
!>
!> When ZCHKST2STG is called, a number of matrix  () and a
!> number of matrix  are specified.  For each size ()
!> and each type of matrix, one matrix will be generated and used
!> to test the Hermitian eigenroutines.  For each matrix, a number
!> of tests will be performed:
!>
!> (1)     | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='U', ... )
!>
!> (2)     | I - UV* | / ( n ulp )        ZUNGTR( UPLO='U', ... )
!>
!> (3)     | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='L', ... )
!>         replaced by | D1 - D2 | / ( |D1| ulp ) where D1 is the 
!>         eigenvalue matrix computed using S and D2 is the 
!>         eigenvalue matrix computed using S_2stage the output of
!>         ZHETRD_2STAGE(, ,....). D1 and D2 are computed 
!>         via DSTEQR('N',...) 
!>
!> (4)     | I - UV* | / ( n ulp )        ZUNGTR( UPLO='L', ... )
!>         replaced by | D1 - D3 | / ( |D1| ulp ) where D1 is the 
!>         eigenvalue matrix computed using S and D3 is the 
!>         eigenvalue matrix computed using S_2stage the output of
!>         ZHETRD_2STAGE(, ,....). D1 and D3 are computed 
!>         via DSTEQR('N',...)  
!>
!> (5-8)   Same as 1-4, but for ZHPTRD and ZUPGTR.
!>
!> (9)     | S - Z D Z* | / ( |S| n ulp ) ZSTEQR('V',...)
!>
!> (10)    | I - ZZ* | / ( n ulp )        ZSTEQR('V',...)
!>
!> (11)    | D1 - D2 | / ( |D1| ulp )        ZSTEQR('N',...)
!>
!> (12)    | D1 - D3 | / ( |D1| ulp )        DSTERF
!>
!> (13)    0 if the true eigenvalues (computed by sturm count)
!>         of S are within THRESH of
!>         those in D1.  2*THRESH if they are not.  (Tested using
!>         DSTECH)
!>
!> For S positive definite,
!>
!> (14)    | S - Z4 D4 Z4* | / ( |S| n ulp ) ZPTEQR('V',...)
!>
!> (15)    | I - Z4 Z4* | / ( n ulp )        ZPTEQR('V',...)
!>
!> (16)    | D4 - D5 | / ( 100 |D4| ulp )       ZPTEQR('N',...)
!>
!> When S is also diagonally dominant by the factor gamma < 1,
!>
!> (17)    max | D4(i) - WR(i) | / ( |D4(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              DSTEBZ( 'A', 'E', ...)
!>
!> (18)    | WA1 - D3 | / ( |D3| ulp )          DSTEBZ( 'A', 'E', ...)
!>
!> (19)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>                                              DSTEBZ( 'I', 'E', ...)
!>
!> (20)    | S - Y WA1 Y* | / ( |S| n ulp )  DSTEBZ, ZSTEIN
!>
!> (21)    | I - Y Y* | / ( n ulp )          DSTEBZ, ZSTEIN
!>
!> (22)    | S - Z D Z* | / ( |S| n ulp )    ZSTEDC('I')
!>
!> (23)    | I - ZZ* | / ( n ulp )           ZSTEDC('I')
!>
!> (24)    | S - Z D Z* | / ( |S| n ulp )    ZSTEDC('V')
!>
!> (25)    | I - ZZ* | / ( n ulp )           ZSTEDC('V')
!>
!> (26)    | D1 - D2 | / ( |D1| ulp )           ZSTEDC('V') and
!>                                              ZSTEDC('N')
!>
!> Test 27 is disabled at the moment because ZSTEMR does not
!> guarantee high relatvie accuracy.
!>
!> (27)    max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              ZSTEMR('V', 'A')
!>
!> (28)    max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              ZSTEMR('V', 'I')
!>
!> Tests 29 through 34 are disable at present because ZSTEMR
!> does not handle partial spectrum requests.
!>
!> (29)    | S - Z D Z* | / ( |S| n ulp )    ZSTEMR('V', 'I')
!>
!> (30)    | I - ZZ* | / ( n ulp )           ZSTEMR('V', 'I')
!>
!> (31)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         ZSTEMR('N', 'I') vs. CSTEMR('V', 'I')
!>
!> (32)    | S - Z D Z* | / ( |S| n ulp )    ZSTEMR('V', 'V')
!>
!> (33)    | I - ZZ* | / ( n ulp )           ZSTEMR('V', 'V')
!>
!> (34)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         ZSTEMR('N', 'V') vs. CSTEMR('V', 'V')
!>
!> (35)    | S - Z D Z* | / ( |S| n ulp )    ZSTEMR('V', 'A')
!>
!> (36)    | I - ZZ* | / ( n ulp )           ZSTEMR('V', 'A')
!>
!> (37)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         ZSTEMR('N', 'A') vs. CSTEMR('V', 'A')
!>
!> The  are specified by an array NN(1:NSIZES); the value of
!> each element NN(j) specifies one size.
!> The  are specified by a logical array DOTYPE( 1:NTYPES );
!> if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!> Currently, the list of possible types is:
!>
!> (1)  The zero matrix.
!> (2)  The identity matrix.
!>
!> (3)  A diagonal matrix with evenly spaced entries
!>      1, ..., ULP  and random signs.
!>      (ULP = (first number larger than 1) - 1 )
!> (4)  A diagonal matrix with geometrically spaced entries
!>      1, ..., ULP  and random signs.
!> (5)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>      and random signs.
!>
!> (6)  Same as (4), but multiplied by SQRT( overflow threshold )
!> (7)  Same as (4), but multiplied by SQRT( underflow threshold )
!>
!> (8)  A matrix of the form  U* D U, where U is unitary and
!>      D has evenly spaced entries 1, ..., ULP with random signs
!>      on the diagonal.
!>
!> (9)  A matrix of the form  U* D U, where U is unitary and
!>      D has geometrically spaced entries 1, ..., ULP with random
!>      signs on the diagonal.
!>
!> (10) A matrix of the form  U* D U, where U is unitary and
!>      D has  entries 1, ULP,..., ULP with random
!>      signs on the diagonal.
!>
!> (11) Same as (8), but multiplied by SQRT( overflow threshold )
!> (12) Same as (8), but multiplied by SQRT( underflow threshold )
!>
!> (13) Hermitian matrix with random entries chosen from (-1,1).
!> (14) Same as (13), but multiplied by SQRT( overflow threshold )
!> (15) Same as (13), but multiplied by SQRT( underflow threshold )
!> (16) Same as (8), but diagonal elements are all positive.
!> (17) Same as (9), but diagonal elements are all positive.
!> (18) Same as (10), but diagonal elements are all positive.
!> (19) Same as (16), but multiplied by SQRT( overflow threshold )
!> (20) Same as (16), but multiplied by SQRT( underflow threshold )
!> (21) A diagonally dominant tridiagonal matrix with geometrically
!>      spaced diagonal entries 1, ..., ULP.
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZCHKST2STG does nothing.  It must be at least zero.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZCHKST2STG
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZCHKST2STG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is COMPLEX*16 array of
!>                                  dimension ( LDA , max(NN) )
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( NN ).
!>
[out]AP
!>          AP is COMPLEX*16 array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix A stored in packed format.
!>
[out]SD
!>          SD is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The diagonal of the tridiagonal matrix computed by ZHETRD.
!>          On exit, SD and SE contain the tridiagonal form of the
!>          matrix in A.
!>
[out]SE
!>          SE is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The off-diagonal of the tridiagonal matrix computed by
!>          ZHETRD.  On exit, SD and SE contain the tridiagonal form of
!>          the matrix in A.
!>
[out]D1
!>          D1 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by ZSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>
[out]D2
!>          D2 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by ZSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>
[out]D3
!>          D3 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>
[out]D4
!>          D4 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by ZPTEQR(V).
!>          ZPTEQR factors S as  Z4 D4 Z4*
!>          On exit, the eigenvalues in D4 correspond with the matrix in A.
!>
[out]D5
!>          D5 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by ZPTEQR(N)
!>          when Z is not computed. On exit, the
!>          eigenvalues in D4 correspond with the matrix in A.
!>
[out]WA1
!>          WA1 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>
[out]WA2
!>          WA2 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>          Choose random values for IL and IU, and ask for the
!>          IL-th through IU-th eigenvalues.
!>
[out]WA3
!>          WA3 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>          Determine the values VL and VU of the IL-th and IU-th
!>          eigenvalues and ask for all eigenvalues in this range.
!>
[out]WR
!>          WR is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different options.
!>          as computed by DSTEBZ.
!>
[out]U
!>          U is COMPLEX*16 array of
!>                             dimension( LDU, max(NN) ).
!>          The unitary matrix computed by ZHETRD + ZUNGTR.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U, Z, and V.  It must be at least 1
!>          and at least max( NN ).
!>
[out]V
!>          V is COMPLEX*16 array of
!>                             dimension( LDU, max(NN) ).
!>          The Housholder vectors computed by ZHETRD in reducing A to
!>          tridiagonal form.  The vectors computed with UPLO='U' are
!>          in the upper triangle, and the vectors computed with UPLO='L'
!>          are in the lower triangle.  (As described in ZHETRD, the
!>          sub- and superdiagonal are not set to 1, although the
!>          true Householder vector has a 1 in that position.  The
!>          routines that use V, such as ZUNGTR, set those entries to
!>          1 before using them, and then restore them later.)
!>
[out]VP
!>          VP is COMPLEX*16 array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix V stored in packed format.
!>
[out]TAU
!>          TAU is COMPLEX*16 array of
!>                             dimension( max(NN) )
!>          The Householder factors computed by ZHETRD in reducing A
!>          to tridiagonal form.
!>
[out]Z
!>          Z is COMPLEX*16 array of
!>                             dimension( LDU, max(NN) ).
!>          The unitary matrix of eigenvectors computed by ZSTEQR,
!>          ZPTEQR, and ZSTEIN.
!>
[out]WORK
!>          WORK is COMPLEX*16 array of
!>                      dimension( LWORK )
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2
!>          where Nmax = max( NN(j), 2 ) and lg = log base 2.
!>
[out]IWORK
!>          IWORK is INTEGER array,
!>          Workspace.
!>
[out]LIWORK
!>          LIWORK is INTEGER
!>          The number of entries in IWORK.  This must be at least
!>                  6 + 6*Nmax + 5 * Nmax * lg Nmax
!>          where Nmax = max( NN(j), 2 ) and lg = log base 2.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array
!>
[in]LRWORK
!>          LRWORK is INTEGER
!>          The number of entries in LRWORK (dimension( ??? )
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (26)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -23: LDU < 1 or LDU < NMAX.
!>          -29: LWORK too small.
!>          If  ZLATMR, CLATMS, ZHETRD, ZUNGTR, ZSTEQR, DSTERF,
!>              or ZUNMC2 returns an error code, the
!>              absolute value of it is returned.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NBLOCK          Blocksize as returned by ENVIR.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far.
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 620 of file zchkst2stg.f.

625*
626* -- LAPACK test routine --
627* -- LAPACK is a software package provided by Univ. of Tennessee, --
628* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
629*
630* .. Scalar Arguments ..
631 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
632 $ NSIZES, NTYPES
633 DOUBLE PRECISION THRESH
634* ..
635* .. Array Arguments ..
636 LOGICAL DOTYPE( * )
637 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
638 DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
639 $ RESULT( * ), RWORK( * ), SD( * ), SE( * ),
640 $ WA1( * ), WA2( * ), WA3( * ), WR( * )
641 COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ),
642 $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * )
643* ..
644*
645* =====================================================================
646*
647* .. Parameters ..
648 DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN
649 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
650 $ eight = 8.0d0, ten = 10.0d0, hun = 100.0d0 )
651 COMPLEX*16 CZERO, CONE
652 parameter( czero = ( 0.0d+0, 0.0d+0 ),
653 $ cone = ( 1.0d+0, 0.0d+0 ) )
654 DOUBLE PRECISION HALF
655 parameter( half = one / two )
656 INTEGER MAXTYP
657 parameter( maxtyp = 21 )
658 LOGICAL CRANGE
659 parameter( crange = .false. )
660 LOGICAL CREL
661 parameter( crel = .false. )
662* ..
663* .. Local Scalars ..
664 LOGICAL BADNN, TRYRAC
665 INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP,
666 $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN,
667 $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3,
668 $ MTYPES, N, NAP, NBLOCK, NERRS, NMATS, NMAX,
669 $ NSPLIT, NTEST, NTESTT, LH, LW
670 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
671 $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP,
672 $ ULPINV, UNFL, VL, VU
673* ..
674* .. Local Arrays ..
675 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
676 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
677 $ KTYPE( MAXTYP )
678 DOUBLE PRECISION DUMMA( 1 )
679* ..
680* .. External Functions ..
681 INTEGER ILAENV
682 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
683 EXTERNAL ilaenv, dlamch, dlarnd, dsxt1
684* ..
685* .. External Subroutines ..
686 EXTERNAL dcopy, dlabad, dlasum, dstebz, dstech, dsterf,
687 $ xerbla, zcopy, zhet21, zhetrd, zhpt21, zhptrd,
688 $ zlacpy, zlaset, zlatmr, zlatms, zpteqr, zstedc,
689 $ zstemr, zstein, zsteqr, zstt21, zstt22, zungtr,
690 $ zupgtr, zhetrd_2stage, dlaset
691* ..
692* .. Intrinsic Functions ..
693 INTRINSIC abs, dble, dconjg, int, log, max, min, sqrt
694* ..
695* .. Data statements ..
696 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
697 $ 8, 8, 9, 9, 9, 9, 9, 10 /
698 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
699 $ 2, 3, 1, 1, 1, 2, 3, 1 /
700 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
701 $ 0, 0, 4, 3, 1, 4, 4, 3 /
702* ..
703* .. Executable Statements ..
704*
705* Keep ftnchek happy
706 idumma( 1 ) = 1
707*
708* Check for errors
709*
710 ntestt = 0
711 info = 0
712*
713* Important constants
714*
715 badnn = .false.
716 tryrac = .true.
717 nmax = 1
718 DO 10 j = 1, nsizes
719 nmax = max( nmax, nn( j ) )
720 IF( nn( j ).LT.0 )
721 $ badnn = .true.
722 10 CONTINUE
723*
724 nblock = ilaenv( 1, 'ZHETRD', 'L', nmax, -1, -1, -1 )
725 nblock = min( nmax, max( 1, nblock ) )
726*
727* Check for errors
728*
729 IF( nsizes.LT.0 ) THEN
730 info = -1
731 ELSE IF( badnn ) THEN
732 info = -2
733 ELSE IF( ntypes.LT.0 ) THEN
734 info = -3
735 ELSE IF( lda.LT.nmax ) THEN
736 info = -9
737 ELSE IF( ldu.LT.nmax ) THEN
738 info = -23
739 ELSE IF( 2*max( 2, nmax )**2.GT.lwork ) THEN
740 info = -29
741 END IF
742*
743 IF( info.NE.0 ) THEN
744 CALL xerbla( 'ZCHKST2STG', -info )
745 RETURN
746 END IF
747*
748* Quick return if possible
749*
750 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
751 $ RETURN
752*
753* More Important constants
754*
755 unfl = dlamch( 'Safe minimum' )
756 ovfl = one / unfl
757 CALL dlabad( unfl, ovfl )
758 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
759 ulpinv = one / ulp
760 log2ui = int( log( ulpinv ) / log( two ) )
761 rtunfl = sqrt( unfl )
762 rtovfl = sqrt( ovfl )
763*
764* Loop over sizes, types
765*
766 DO 20 i = 1, 4
767 iseed2( i ) = iseed( i )
768 20 CONTINUE
769 nerrs = 0
770 nmats = 0
771*
772 DO 310 jsize = 1, nsizes
773 n = nn( jsize )
774 IF( n.GT.0 ) THEN
775 lgn = int( log( dble( n ) ) / log( two ) )
776 IF( 2**lgn.LT.n )
777 $ lgn = lgn + 1
778 IF( 2**lgn.LT.n )
779 $ lgn = lgn + 1
780 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
781 lrwedc = 1 + 3*n + 2*n*lgn + 4*n**2
782 liwedc = 6 + 6*n + 5*n*lgn
783 ELSE
784 lwedc = 8
785 lrwedc = 7
786 liwedc = 12
787 END IF
788 nap = ( n*( n+1 ) ) / 2
789 aninv = one / dble( max( 1, n ) )
790*
791 IF( nsizes.NE.1 ) THEN
792 mtypes = min( maxtyp, ntypes )
793 ELSE
794 mtypes = min( maxtyp+1, ntypes )
795 END IF
796*
797 DO 300 jtype = 1, mtypes
798 IF( .NOT.dotype( jtype ) )
799 $ GO TO 300
800 nmats = nmats + 1
801 ntest = 0
802*
803 DO 30 j = 1, 4
804 ioldsd( j ) = iseed( j )
805 30 CONTINUE
806*
807* Compute "A"
808*
809* Control parameters:
810*
811* KMAGN KMODE KTYPE
812* =1 O(1) clustered 1 zero
813* =2 large clustered 2 identity
814* =3 small exponential (none)
815* =4 arithmetic diagonal, (w/ eigenvalues)
816* =5 random log Hermitian, w/ eigenvalues
817* =6 random (none)
818* =7 random diagonal
819* =8 random Hermitian
820* =9 positive definite
821* =10 diagonally dominant tridiagonal
822*
823 IF( mtypes.GT.maxtyp )
824 $ GO TO 100
825*
826 itype = ktype( jtype )
827 imode = kmode( jtype )
828*
829* Compute norm
830*
831 GO TO ( 40, 50, 60 )kmagn( jtype )
832*
833 40 CONTINUE
834 anorm = one
835 GO TO 70
836*
837 50 CONTINUE
838 anorm = ( rtovfl*ulp )*aninv
839 GO TO 70
840*
841 60 CONTINUE
842 anorm = rtunfl*n*ulpinv
843 GO TO 70
844*
845 70 CONTINUE
846*
847 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
848 iinfo = 0
849 IF( jtype.LE.15 ) THEN
850 cond = ulpinv
851 ELSE
852 cond = ulpinv*aninv / ten
853 END IF
854*
855* Special Matrices -- Identity & Jordan block
856*
857* Zero
858*
859 IF( itype.EQ.1 ) THEN
860 iinfo = 0
861*
862 ELSE IF( itype.EQ.2 ) THEN
863*
864* Identity
865*
866 DO 80 jc = 1, n
867 a( jc, jc ) = anorm
868 80 CONTINUE
869*
870 ELSE IF( itype.EQ.4 ) THEN
871*
872* Diagonal Matrix, [Eigen]values Specified
873*
874 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
875 $ anorm, 0, 0, 'N', a, lda, work, iinfo )
876*
877*
878 ELSE IF( itype.EQ.5 ) THEN
879*
880* Hermitian, eigenvalues specified
881*
882 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
883 $ anorm, n, n, 'N', a, lda, work, iinfo )
884*
885 ELSE IF( itype.EQ.7 ) THEN
886*
887* Diagonal, random eigenvalues
888*
889 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
890 $ 'T', 'N', work( n+1 ), 1, one,
891 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
892 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
893*
894 ELSE IF( itype.EQ.8 ) THEN
895*
896* Hermitian, random eigenvalues
897*
898 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
899 $ 'T', 'N', work( n+1 ), 1, one,
900 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
901 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
902*
903 ELSE IF( itype.EQ.9 ) THEN
904*
905* Positive definite, eigenvalues specified.
906*
907 CALL zlatms( n, n, 'S', iseed, 'P', rwork, imode, cond,
908 $ anorm, n, n, 'N', a, lda, work, iinfo )
909*
910 ELSE IF( itype.EQ.10 ) THEN
911*
912* Positive definite tridiagonal, eigenvalues specified.
913*
914 CALL zlatms( n, n, 'S', iseed, 'P', rwork, imode, cond,
915 $ anorm, 1, 1, 'N', a, lda, work, iinfo )
916 DO 90 i = 2, n
917 temp1 = abs( a( i-1, i ) )
918 temp2 = sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
919 IF( temp1.GT.half*temp2 ) THEN
920 a( i-1, i ) = a( i-1, i )*
921 $ ( half*temp2 / ( unfl+temp1 ) )
922 a( i, i-1 ) = dconjg( a( i-1, i ) )
923 END IF
924 90 CONTINUE
925*
926 ELSE
927*
928 iinfo = 1
929 END IF
930*
931 IF( iinfo.NE.0 ) THEN
932 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
933 $ ioldsd
934 info = abs( iinfo )
935 RETURN
936 END IF
937*
938 100 CONTINUE
939*
940* Call ZHETRD and ZUNGTR to compute S and U from
941* upper triangle.
942*
943 CALL zlacpy( 'U', n, n, a, lda, v, ldu )
944*
945 ntest = 1
946 CALL zhetrd( 'U', n, v, ldu, sd, se, tau, work, lwork,
947 $ iinfo )
948*
949 IF( iinfo.NE.0 ) THEN
950 WRITE( nounit, fmt = 9999 )'ZHETRD(U)', iinfo, n, jtype,
951 $ ioldsd
952 info = abs( iinfo )
953 IF( iinfo.LT.0 ) THEN
954 RETURN
955 ELSE
956 result( 1 ) = ulpinv
957 GO TO 280
958 END IF
959 END IF
960*
961 CALL zlacpy( 'U', n, n, v, ldu, u, ldu )
962*
963 ntest = 2
964 CALL zungtr( 'U', n, u, ldu, tau, work, lwork, iinfo )
965 IF( iinfo.NE.0 ) THEN
966 WRITE( nounit, fmt = 9999 )'ZUNGTR(U)', iinfo, n, jtype,
967 $ ioldsd
968 info = abs( iinfo )
969 IF( iinfo.LT.0 ) THEN
970 RETURN
971 ELSE
972 result( 2 ) = ulpinv
973 GO TO 280
974 END IF
975 END IF
976*
977* Do tests 1 and 2
978*
979 CALL zhet21( 2, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
980 $ ldu, tau, work, rwork, result( 1 ) )
981 CALL zhet21( 3, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
982 $ ldu, tau, work, rwork, result( 2 ) )
983*
984* Compute D1 the eigenvalues resulting from the tridiagonal
985* form using the standard 1-stage algorithm and use it as a
986* reference to compare with the 2-stage technique
987*
988* Compute D1 from the 1-stage and used as reference for the
989* 2-stage
990*
991 CALL dcopy( n, sd, 1, d1, 1 )
992 IF( n.GT.0 )
993 $ CALL dcopy( n-1, se, 1, rwork, 1 )
994*
995 CALL zsteqr( 'N', n, d1, rwork, work, ldu, rwork( n+1 ),
996 $ iinfo )
997 IF( iinfo.NE.0 ) THEN
998 WRITE( nounit, fmt = 9999 )'ZSTEQR(N)', iinfo, n, jtype,
999 $ ioldsd
1000 info = abs( iinfo )
1001 IF( iinfo.LT.0 ) THEN
1002 RETURN
1003 ELSE
1004 result( 3 ) = ulpinv
1005 GO TO 280
1006 END IF
1007 END IF
1008*
1009* 2-STAGE TRD Upper case is used to compute D2.
1010* Note to set SD and SE to zero to be sure not reusing
1011* the one from above. Compare it with D1 computed
1012* using the 1-stage.
1013*
1014 CALL dlaset( 'Full', n, 1, zero, zero, sd, n )
1015 CALL dlaset( 'Full', n, 1, zero, zero, se, n )
1016 CALL zlacpy( 'U', n, n, a, lda, v, ldu )
1017 lh = max(1, 4*n)
1018 lw = lwork - lh
1019 CALL zhetrd_2stage( 'N', "U", n, v, ldu, sd, se, tau,
1020 $ work, lh, work( lh+1 ), lw, iinfo )
1021*
1022* Compute D2 from the 2-stage Upper case
1023*
1024 CALL dcopy( n, sd, 1, d2, 1 )
1025 IF( n.GT.0 )
1026 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1027*
1028 ntest = 3
1029 CALL zsteqr( 'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1030 $ iinfo )
1031 IF( iinfo.NE.0 ) THEN
1032 WRITE( nounit, fmt = 9999 )'ZSTEQR(N)', iinfo, n, jtype,
1033 $ ioldsd
1034 info = abs( iinfo )
1035 IF( iinfo.LT.0 ) THEN
1036 RETURN
1037 ELSE
1038 result( 3 ) = ulpinv
1039 GO TO 280
1040 END IF
1041 END IF
1042*
1043* 2-STAGE TRD Lower case is used to compute D3.
1044* Note to set SD and SE to zero to be sure not reusing
1045* the one from above. Compare it with D1 computed
1046* using the 1-stage.
1047*
1048 CALL dlaset( 'Full', n, 1, zero, zero, sd, n )
1049 CALL dlaset( 'Full', n, 1, zero, zero, se, n )
1050 CALL zlacpy( 'L', n, n, a, lda, v, ldu )
1051 CALL zhetrd_2stage( 'N', "L", n, v, ldu, sd, se, tau,
1052 $ work, lh, work( lh+1 ), lw, iinfo )
1053*
1054* Compute D3 from the 2-stage Upper case
1055*
1056 CALL dcopy( n, sd, 1, d3, 1 )
1057 IF( n.GT.0 )
1058 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1059*
1060 ntest = 4
1061 CALL zsteqr( 'N', n, d3, rwork, work, ldu, rwork( n+1 ),
1062 $ iinfo )
1063 IF( iinfo.NE.0 ) THEN
1064 WRITE( nounit, fmt = 9999 )'ZSTEQR(N)', iinfo, n, jtype,
1065 $ ioldsd
1066 info = abs( iinfo )
1067 IF( iinfo.LT.0 ) THEN
1068 RETURN
1069 ELSE
1070 result( 4 ) = ulpinv
1071 GO TO 280
1072 END IF
1073 END IF
1074*
1075* Do Tests 3 and 4 which are similar to 11 and 12 but with the
1076* D1 computed using the standard 1-stage reduction as reference
1077*
1078 ntest = 4
1079 temp1 = zero
1080 temp2 = zero
1081 temp3 = zero
1082 temp4 = zero
1083*
1084 DO 151 j = 1, n
1085 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1086 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1087 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1088 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1089 151 CONTINUE
1090*
1091 result( 3 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1092 result( 4 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1093*
1094* Store the upper triangle of A in AP
1095*
1096 i = 0
1097 DO 120 jc = 1, n
1098 DO 110 jr = 1, jc
1099 i = i + 1
1100 ap( i ) = a( jr, jc )
1101 110 CONTINUE
1102 120 CONTINUE
1103*
1104* Call ZHPTRD and ZUPGTR to compute S and U from AP
1105*
1106 CALL zcopy( nap, ap, 1, vp, 1 )
1107*
1108 ntest = 5
1109 CALL zhptrd( 'U', n, vp, sd, se, tau, iinfo )
1110*
1111 IF( iinfo.NE.0 ) THEN
1112 WRITE( nounit, fmt = 9999 )'ZHPTRD(U)', iinfo, n, jtype,
1113 $ ioldsd
1114 info = abs( iinfo )
1115 IF( iinfo.LT.0 ) THEN
1116 RETURN
1117 ELSE
1118 result( 5 ) = ulpinv
1119 GO TO 280
1120 END IF
1121 END IF
1122*
1123 ntest = 6
1124 CALL zupgtr( 'U', n, vp, tau, u, ldu, work, iinfo )
1125 IF( iinfo.NE.0 ) THEN
1126 WRITE( nounit, fmt = 9999 )'ZUPGTR(U)', iinfo, n, jtype,
1127 $ ioldsd
1128 info = abs( iinfo )
1129 IF( iinfo.LT.0 ) THEN
1130 RETURN
1131 ELSE
1132 result( 6 ) = ulpinv
1133 GO TO 280
1134 END IF
1135 END IF
1136*
1137* Do tests 5 and 6
1138*
1139 CALL zhpt21( 2, 'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1140 $ work, rwork, result( 5 ) )
1141 CALL zhpt21( 3, 'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1142 $ work, rwork, result( 6 ) )
1143*
1144* Store the lower triangle of A in AP
1145*
1146 i = 0
1147 DO 140 jc = 1, n
1148 DO 130 jr = jc, n
1149 i = i + 1
1150 ap( i ) = a( jr, jc )
1151 130 CONTINUE
1152 140 CONTINUE
1153*
1154* Call ZHPTRD and ZUPGTR to compute S and U from AP
1155*
1156 CALL zcopy( nap, ap, 1, vp, 1 )
1157*
1158 ntest = 7
1159 CALL zhptrd( 'L', n, vp, sd, se, tau, iinfo )
1160*
1161 IF( iinfo.NE.0 ) THEN
1162 WRITE( nounit, fmt = 9999 )'ZHPTRD(L)', iinfo, n, jtype,
1163 $ ioldsd
1164 info = abs( iinfo )
1165 IF( iinfo.LT.0 ) THEN
1166 RETURN
1167 ELSE
1168 result( 7 ) = ulpinv
1169 GO TO 280
1170 END IF
1171 END IF
1172*
1173 ntest = 8
1174 CALL zupgtr( 'L', n, vp, tau, u, ldu, work, iinfo )
1175 IF( iinfo.NE.0 ) THEN
1176 WRITE( nounit, fmt = 9999 )'ZUPGTR(L)', iinfo, n, jtype,
1177 $ ioldsd
1178 info = abs( iinfo )
1179 IF( iinfo.LT.0 ) THEN
1180 RETURN
1181 ELSE
1182 result( 8 ) = ulpinv
1183 GO TO 280
1184 END IF
1185 END IF
1186*
1187 CALL zhpt21( 2, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1188 $ work, rwork, result( 7 ) )
1189 CALL zhpt21( 3, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1190 $ work, rwork, result( 8 ) )
1191*
1192* Call ZSTEQR to compute D1, D2, and Z, do tests.
1193*
1194* Compute D1 and Z
1195*
1196 CALL dcopy( n, sd, 1, d1, 1 )
1197 IF( n.GT.0 )
1198 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1199 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1200*
1201 ntest = 9
1202 CALL zsteqr( 'V', n, d1, rwork, z, ldu, rwork( n+1 ),
1203 $ iinfo )
1204 IF( iinfo.NE.0 ) THEN
1205 WRITE( nounit, fmt = 9999 )'ZSTEQR(V)', iinfo, n, jtype,
1206 $ ioldsd
1207 info = abs( iinfo )
1208 IF( iinfo.LT.0 ) THEN
1209 RETURN
1210 ELSE
1211 result( 9 ) = ulpinv
1212 GO TO 280
1213 END IF
1214 END IF
1215*
1216* Compute D2
1217*
1218 CALL dcopy( n, sd, 1, d2, 1 )
1219 IF( n.GT.0 )
1220 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1221*
1222 ntest = 11
1223 CALL zsteqr( 'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1224 $ iinfo )
1225 IF( iinfo.NE.0 ) THEN
1226 WRITE( nounit, fmt = 9999 )'ZSTEQR(N)', iinfo, n, jtype,
1227 $ ioldsd
1228 info = abs( iinfo )
1229 IF( iinfo.LT.0 ) THEN
1230 RETURN
1231 ELSE
1232 result( 11 ) = ulpinv
1233 GO TO 280
1234 END IF
1235 END IF
1236*
1237* Compute D3 (using PWK method)
1238*
1239 CALL dcopy( n, sd, 1, d3, 1 )
1240 IF( n.GT.0 )
1241 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1242*
1243 ntest = 12
1244 CALL dsterf( n, d3, rwork, iinfo )
1245 IF( iinfo.NE.0 ) THEN
1246 WRITE( nounit, fmt = 9999 )'DSTERF', iinfo, n, jtype,
1247 $ ioldsd
1248 info = abs( iinfo )
1249 IF( iinfo.LT.0 ) THEN
1250 RETURN
1251 ELSE
1252 result( 12 ) = ulpinv
1253 GO TO 280
1254 END IF
1255 END IF
1256*
1257* Do Tests 9 and 10
1258*
1259 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1260 $ result( 9 ) )
1261*
1262* Do Tests 11 and 12
1263*
1264 temp1 = zero
1265 temp2 = zero
1266 temp3 = zero
1267 temp4 = zero
1268*
1269 DO 150 j = 1, n
1270 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1271 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1272 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1273 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1274 150 CONTINUE
1275*
1276 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1277 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1278*
1279* Do Test 13 -- Sturm Sequence Test of Eigenvalues
1280* Go up by factors of two until it succeeds
1281*
1282 ntest = 13
1283 temp1 = thresh*( half-ulp )
1284*
1285 DO 160 j = 0, log2ui
1286 CALL dstech( n, sd, se, d1, temp1, rwork, iinfo )
1287 IF( iinfo.EQ.0 )
1288 $ GO TO 170
1289 temp1 = temp1*two
1290 160 CONTINUE
1291*
1292 170 CONTINUE
1293 result( 13 ) = temp1
1294*
1295* For positive definite matrices ( JTYPE.GT.15 ) call ZPTEQR
1296* and do tests 14, 15, and 16 .
1297*
1298 IF( jtype.GT.15 ) THEN
1299*
1300* Compute D4 and Z4
1301*
1302 CALL dcopy( n, sd, 1, d4, 1 )
1303 IF( n.GT.0 )
1304 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1305 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1306*
1307 ntest = 14
1308 CALL zpteqr( 'V', n, d4, rwork, z, ldu, rwork( n+1 ),
1309 $ iinfo )
1310 IF( iinfo.NE.0 ) THEN
1311 WRITE( nounit, fmt = 9999 )'ZPTEQR(V)', iinfo, n,
1312 $ jtype, ioldsd
1313 info = abs( iinfo )
1314 IF( iinfo.LT.0 ) THEN
1315 RETURN
1316 ELSE
1317 result( 14 ) = ulpinv
1318 GO TO 280
1319 END IF
1320 END IF
1321*
1322* Do Tests 14 and 15
1323*
1324 CALL zstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1325 $ rwork, result( 14 ) )
1326*
1327* Compute D5
1328*
1329 CALL dcopy( n, sd, 1, d5, 1 )
1330 IF( n.GT.0 )
1331 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1332*
1333 ntest = 16
1334 CALL zpteqr( 'N', n, d5, rwork, z, ldu, rwork( n+1 ),
1335 $ iinfo )
1336 IF( iinfo.NE.0 ) THEN
1337 WRITE( nounit, fmt = 9999 )'ZPTEQR(N)', iinfo, n,
1338 $ jtype, ioldsd
1339 info = abs( iinfo )
1340 IF( iinfo.LT.0 ) THEN
1341 RETURN
1342 ELSE
1343 result( 16 ) = ulpinv
1344 GO TO 280
1345 END IF
1346 END IF
1347*
1348* Do Test 16
1349*
1350 temp1 = zero
1351 temp2 = zero
1352 DO 180 j = 1, n
1353 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1354 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1355 180 CONTINUE
1356*
1357 result( 16 ) = temp2 / max( unfl,
1358 $ hun*ulp*max( temp1, temp2 ) )
1359 ELSE
1360 result( 14 ) = zero
1361 result( 15 ) = zero
1362 result( 16 ) = zero
1363 END IF
1364*
1365* Call DSTEBZ with different options and do tests 17-18.
1366*
1367* If S is positive definite and diagonally dominant,
1368* ask for all eigenvalues with high relative accuracy.
1369*
1370 vl = zero
1371 vu = zero
1372 il = 0
1373 iu = 0
1374 IF( jtype.EQ.21 ) THEN
1375 ntest = 17
1376 abstol = unfl + unfl
1377 CALL dstebz( 'A', 'E', n, vl, vu, il, iu, abstol, sd, se,
1378 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1379 $ rwork, iwork( 2*n+1 ), iinfo )
1380 IF( iinfo.NE.0 ) THEN
1381 WRITE( nounit, fmt = 9999 )'DSTEBZ(A,rel)', iinfo, n,
1382 $ jtype, ioldsd
1383 info = abs( iinfo )
1384 IF( iinfo.LT.0 ) THEN
1385 RETURN
1386 ELSE
1387 result( 17 ) = ulpinv
1388 GO TO 280
1389 END IF
1390 END IF
1391*
1392* Do test 17
1393*
1394 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1395 $ ( one-half )**4
1396*
1397 temp1 = zero
1398 DO 190 j = 1, n
1399 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1400 $ ( abstol+abs( d4( j ) ) ) )
1401 190 CONTINUE
1402*
1403 result( 17 ) = temp1 / temp2
1404 ELSE
1405 result( 17 ) = zero
1406 END IF
1407*
1408* Now ask for all eigenvalues with high absolute accuracy.
1409*
1410 ntest = 18
1411 abstol = unfl + unfl
1412 CALL dstebz( 'A', 'E', n, vl, vu, il, iu, abstol, sd, se, m,
1413 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1414 $ iwork( 2*n+1 ), iinfo )
1415 IF( iinfo.NE.0 ) THEN
1416 WRITE( nounit, fmt = 9999 )'DSTEBZ(A)', iinfo, n, jtype,
1417 $ ioldsd
1418 info = abs( iinfo )
1419 IF( iinfo.LT.0 ) THEN
1420 RETURN
1421 ELSE
1422 result( 18 ) = ulpinv
1423 GO TO 280
1424 END IF
1425 END IF
1426*
1427* Do test 18
1428*
1429 temp1 = zero
1430 temp2 = zero
1431 DO 200 j = 1, n
1432 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1433 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1434 200 CONTINUE
1435*
1436 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1437*
1438* Choose random values for IL and IU, and ask for the
1439* IL-th through IU-th eigenvalues.
1440*
1441 ntest = 19
1442 IF( n.LE.1 ) THEN
1443 il = 1
1444 iu = n
1445 ELSE
1446 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1447 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1448 IF( iu.LT.il ) THEN
1449 itemp = iu
1450 iu = il
1451 il = itemp
1452 END IF
1453 END IF
1454*
1455 CALL dstebz( 'I', 'E', n, vl, vu, il, iu, abstol, sd, se,
1456 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1457 $ rwork, iwork( 2*n+1 ), iinfo )
1458 IF( iinfo.NE.0 ) THEN
1459 WRITE( nounit, fmt = 9999 )'DSTEBZ(I)', iinfo, n, jtype,
1460 $ ioldsd
1461 info = abs( iinfo )
1462 IF( iinfo.LT.0 ) THEN
1463 RETURN
1464 ELSE
1465 result( 19 ) = ulpinv
1466 GO TO 280
1467 END IF
1468 END IF
1469*
1470* Determine the values VL and VU of the IL-th and IU-th
1471* eigenvalues and ask for all eigenvalues in this range.
1472*
1473 IF( n.GT.0 ) THEN
1474 IF( il.NE.1 ) THEN
1475 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1476 $ ulp*anorm, two*rtunfl )
1477 ELSE
1478 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1479 $ ulp*anorm, two*rtunfl )
1480 END IF
1481 IF( iu.NE.n ) THEN
1482 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1483 $ ulp*anorm, two*rtunfl )
1484 ELSE
1485 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1486 $ ulp*anorm, two*rtunfl )
1487 END IF
1488 ELSE
1489 vl = zero
1490 vu = one
1491 END IF
1492*
1493 CALL dstebz( 'V', 'E', n, vl, vu, il, iu, abstol, sd, se,
1494 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1495 $ rwork, iwork( 2*n+1 ), iinfo )
1496 IF( iinfo.NE.0 ) THEN
1497 WRITE( nounit, fmt = 9999 )'DSTEBZ(V)', iinfo, n, jtype,
1498 $ ioldsd
1499 info = abs( iinfo )
1500 IF( iinfo.LT.0 ) THEN
1501 RETURN
1502 ELSE
1503 result( 19 ) = ulpinv
1504 GO TO 280
1505 END IF
1506 END IF
1507*
1508 IF( m3.EQ.0 .AND. n.NE.0 ) THEN
1509 result( 19 ) = ulpinv
1510 GO TO 280
1511 END IF
1512*
1513* Do test 19
1514*
1515 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1516 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1517 IF( n.GT.0 ) THEN
1518 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1519 ELSE
1520 temp3 = zero
1521 END IF
1522*
1523 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1524*
1525* Call ZSTEIN to compute eigenvectors corresponding to
1526* eigenvalues in WA1. (First call DSTEBZ again, to make sure
1527* it returns these eigenvalues in the correct order.)
1528*
1529 ntest = 21
1530 CALL dstebz( 'A', 'B', n, vl, vu, il, iu, abstol, sd, se, m,
1531 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1532 $ iwork( 2*n+1 ), iinfo )
1533 IF( iinfo.NE.0 ) THEN
1534 WRITE( nounit, fmt = 9999 )'DSTEBZ(A,B)', iinfo, n,
1535 $ jtype, ioldsd
1536 info = abs( iinfo )
1537 IF( iinfo.LT.0 ) THEN
1538 RETURN
1539 ELSE
1540 result( 20 ) = ulpinv
1541 result( 21 ) = ulpinv
1542 GO TO 280
1543 END IF
1544 END IF
1545*
1546 CALL zstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1547 $ ldu, rwork, iwork( 2*n+1 ), iwork( 3*n+1 ),
1548 $ iinfo )
1549 IF( iinfo.NE.0 ) THEN
1550 WRITE( nounit, fmt = 9999 )'ZSTEIN', iinfo, n, jtype,
1551 $ ioldsd
1552 info = abs( iinfo )
1553 IF( iinfo.LT.0 ) THEN
1554 RETURN
1555 ELSE
1556 result( 20 ) = ulpinv
1557 result( 21 ) = ulpinv
1558 GO TO 280
1559 END IF
1560 END IF
1561*
1562* Do tests 20 and 21
1563*
1564 CALL zstt21( n, 0, sd, se, wa1, dumma, z, ldu, work, rwork,
1565 $ result( 20 ) )
1566*
1567* Call ZSTEDC(I) to compute D1 and Z, do tests.
1568*
1569* Compute D1 and Z
1570*
1571 inde = 1
1572 indrwk = inde + n
1573 CALL dcopy( n, sd, 1, d1, 1 )
1574 IF( n.GT.0 )
1575 $ CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1576 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1577*
1578 ntest = 22
1579 CALL zstedc( 'I', n, d1, rwork( inde ), z, ldu, work, lwedc,
1580 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1581 IF( iinfo.NE.0 ) THEN
1582 WRITE( nounit, fmt = 9999 )'ZSTEDC(I)', iinfo, n, jtype,
1583 $ ioldsd
1584 info = abs( iinfo )
1585 IF( iinfo.LT.0 ) THEN
1586 RETURN
1587 ELSE
1588 result( 22 ) = ulpinv
1589 GO TO 280
1590 END IF
1591 END IF
1592*
1593* Do Tests 22 and 23
1594*
1595 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1596 $ result( 22 ) )
1597*
1598* Call ZSTEDC(V) to compute D1 and Z, do tests.
1599*
1600* Compute D1 and Z
1601*
1602 CALL dcopy( n, sd, 1, d1, 1 )
1603 IF( n.GT.0 )
1604 $ CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1605 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1606*
1607 ntest = 24
1608 CALL zstedc( 'V', n, d1, rwork( inde ), z, ldu, work, lwedc,
1609 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1610 IF( iinfo.NE.0 ) THEN
1611 WRITE( nounit, fmt = 9999 )'ZSTEDC(V)', iinfo, n, jtype,
1612 $ ioldsd
1613 info = abs( iinfo )
1614 IF( iinfo.LT.0 ) THEN
1615 RETURN
1616 ELSE
1617 result( 24 ) = ulpinv
1618 GO TO 280
1619 END IF
1620 END IF
1621*
1622* Do Tests 24 and 25
1623*
1624 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1625 $ result( 24 ) )
1626*
1627* Call ZSTEDC(N) to compute D2, do tests.
1628*
1629* Compute D2
1630*
1631 CALL dcopy( n, sd, 1, d2, 1 )
1632 IF( n.GT.0 )
1633 $ CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1634 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1635*
1636 ntest = 26
1637 CALL zstedc( 'N', n, d2, rwork( inde ), z, ldu, work, lwedc,
1638 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1639 IF( iinfo.NE.0 ) THEN
1640 WRITE( nounit, fmt = 9999 )'ZSTEDC(N)', iinfo, n, jtype,
1641 $ ioldsd
1642 info = abs( iinfo )
1643 IF( iinfo.LT.0 ) THEN
1644 RETURN
1645 ELSE
1646 result( 26 ) = ulpinv
1647 GO TO 280
1648 END IF
1649 END IF
1650*
1651* Do Test 26
1652*
1653 temp1 = zero
1654 temp2 = zero
1655*
1656 DO 210 j = 1, n
1657 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1658 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1659 210 CONTINUE
1660*
1661 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1662*
1663* Only test ZSTEMR if IEEE compliant
1664*
1665 IF( ilaenv( 10, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1666 $ ilaenv( 11, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
1667*
1668* Call ZSTEMR, do test 27 (relative eigenvalue accuracy)
1669*
1670* If S is positive definite and diagonally dominant,
1671* ask for all eigenvalues with high relative accuracy.
1672*
1673 vl = zero
1674 vu = zero
1675 il = 0
1676 iu = 0
1677 IF( jtype.EQ.21 .AND. crel ) THEN
1678 ntest = 27
1679 abstol = unfl + unfl
1680 CALL zstemr( 'V', 'A', n, sd, se, vl, vu, il, iu,
1681 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1682 $ rwork, lrwork, iwork( 2*n+1 ), lwork-2*n,
1683 $ iinfo )
1684 IF( iinfo.NE.0 ) THEN
1685 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,A,rel)',
1686 $ iinfo, n, jtype, ioldsd
1687 info = abs( iinfo )
1688 IF( iinfo.LT.0 ) THEN
1689 RETURN
1690 ELSE
1691 result( 27 ) = ulpinv
1692 GO TO 270
1693 END IF
1694 END IF
1695*
1696* Do test 27
1697*
1698 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1699 $ ( one-half )**4
1700*
1701 temp1 = zero
1702 DO 220 j = 1, n
1703 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1704 $ ( abstol+abs( d4( j ) ) ) )
1705 220 CONTINUE
1706*
1707 result( 27 ) = temp1 / temp2
1708*
1709 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1710 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1711 IF( iu.LT.il ) THEN
1712 itemp = iu
1713 iu = il
1714 il = itemp
1715 END IF
1716*
1717 IF( crange ) THEN
1718 ntest = 28
1719 abstol = unfl + unfl
1720 CALL zstemr( 'V', 'I', n, sd, se, vl, vu, il, iu,
1721 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1722 $ rwork, lrwork, iwork( 2*n+1 ),
1723 $ lwork-2*n, iinfo )
1724*
1725 IF( iinfo.NE.0 ) THEN
1726 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,I,rel)',
1727 $ iinfo, n, jtype, ioldsd
1728 info = abs( iinfo )
1729 IF( iinfo.LT.0 ) THEN
1730 RETURN
1731 ELSE
1732 result( 28 ) = ulpinv
1733 GO TO 270
1734 END IF
1735 END IF
1736*
1737* Do test 28
1738*
1739 temp2 = two*( two*n-one )*ulp*
1740 $ ( one+eight*half**2 ) / ( one-half )**4
1741*
1742 temp1 = zero
1743 DO 230 j = il, iu
1744 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1745 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1746 230 CONTINUE
1747*
1748 result( 28 ) = temp1 / temp2
1749 ELSE
1750 result( 28 ) = zero
1751 END IF
1752 ELSE
1753 result( 27 ) = zero
1754 result( 28 ) = zero
1755 END IF
1756*
1757* Call ZSTEMR(V,I) to compute D1 and Z, do tests.
1758*
1759* Compute D1 and Z
1760*
1761 CALL dcopy( n, sd, 1, d5, 1 )
1762 IF( n.GT.0 )
1763 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1764 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1765*
1766 IF( crange ) THEN
1767 ntest = 29
1768 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1769 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1770 IF( iu.LT.il ) THEN
1771 itemp = iu
1772 iu = il
1773 il = itemp
1774 END IF
1775 CALL zstemr( 'V', 'I', n, d5, rwork, vl, vu, il, iu,
1776 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1777 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1778 $ liwork-2*n, iinfo )
1779 IF( iinfo.NE.0 ) THEN
1780 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,I)', iinfo,
1781 $ n, jtype, ioldsd
1782 info = abs( iinfo )
1783 IF( iinfo.LT.0 ) THEN
1784 RETURN
1785 ELSE
1786 result( 29 ) = ulpinv
1787 GO TO 280
1788 END IF
1789 END IF
1790*
1791* Do Tests 29 and 30
1792*
1793* Call ZSTEMR to compute D2, do tests.
1794*
1795* Compute D2
1796*
1797 CALL dcopy( n, sd, 1, d5, 1 )
1798 IF( n.GT.0 )
1799 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1800*
1801 ntest = 31
1802 CALL zstemr( 'N', 'I', n, d5, rwork, vl, vu, il, iu,
1803 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1804 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1805 $ liwork-2*n, iinfo )
1806 IF( iinfo.NE.0 ) THEN
1807 WRITE( nounit, fmt = 9999 )'ZSTEMR(N,I)', iinfo,
1808 $ n, jtype, ioldsd
1809 info = abs( iinfo )
1810 IF( iinfo.LT.0 ) THEN
1811 RETURN
1812 ELSE
1813 result( 31 ) = ulpinv
1814 GO TO 280
1815 END IF
1816 END IF
1817*
1818* Do Test 31
1819*
1820 temp1 = zero
1821 temp2 = zero
1822*
1823 DO 240 j = 1, iu - il + 1
1824 temp1 = max( temp1, abs( d1( j ) ),
1825 $ abs( d2( j ) ) )
1826 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1827 240 CONTINUE
1828*
1829 result( 31 ) = temp2 / max( unfl,
1830 $ ulp*max( temp1, temp2 ) )
1831*
1832* Call ZSTEMR(V,V) to compute D1 and Z, do tests.
1833*
1834* Compute D1 and Z
1835*
1836 CALL dcopy( n, sd, 1, d5, 1 )
1837 IF( n.GT.0 )
1838 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1839 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1840*
1841 ntest = 32
1842*
1843 IF( n.GT.0 ) THEN
1844 IF( il.NE.1 ) THEN
1845 vl = d2( il ) - max( half*
1846 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1847 $ two*rtunfl )
1848 ELSE
1849 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1850 $ ulp*anorm, two*rtunfl )
1851 END IF
1852 IF( iu.NE.n ) THEN
1853 vu = d2( iu ) + max( half*
1854 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1855 $ two*rtunfl )
1856 ELSE
1857 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1858 $ ulp*anorm, two*rtunfl )
1859 END IF
1860 ELSE
1861 vl = zero
1862 vu = one
1863 END IF
1864*
1865 CALL zstemr( 'V', 'V', n, d5, rwork, vl, vu, il, iu,
1866 $ m, d1, z, ldu, m, iwork( 1 ), tryrac,
1867 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1868 $ liwork-2*n, iinfo )
1869 IF( iinfo.NE.0 ) THEN
1870 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,V)', iinfo,
1871 $ n, jtype, ioldsd
1872 info = abs( iinfo )
1873 IF( iinfo.LT.0 ) THEN
1874 RETURN
1875 ELSE
1876 result( 32 ) = ulpinv
1877 GO TO 280
1878 END IF
1879 END IF
1880*
1881* Do Tests 32 and 33
1882*
1883 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1884 $ m, rwork, result( 32 ) )
1885*
1886* Call ZSTEMR to compute D2, do tests.
1887*
1888* Compute D2
1889*
1890 CALL dcopy( n, sd, 1, d5, 1 )
1891 IF( n.GT.0 )
1892 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1893*
1894 ntest = 34
1895 CALL zstemr( 'N', 'V', n, d5, rwork, vl, vu, il, iu,
1896 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1897 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1898 $ liwork-2*n, iinfo )
1899 IF( iinfo.NE.0 ) THEN
1900 WRITE( nounit, fmt = 9999 )'ZSTEMR(N,V)', iinfo,
1901 $ n, jtype, ioldsd
1902 info = abs( iinfo )
1903 IF( iinfo.LT.0 ) THEN
1904 RETURN
1905 ELSE
1906 result( 34 ) = ulpinv
1907 GO TO 280
1908 END IF
1909 END IF
1910*
1911* Do Test 34
1912*
1913 temp1 = zero
1914 temp2 = zero
1915*
1916 DO 250 j = 1, iu - il + 1
1917 temp1 = max( temp1, abs( d1( j ) ),
1918 $ abs( d2( j ) ) )
1919 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1920 250 CONTINUE
1921*
1922 result( 34 ) = temp2 / max( unfl,
1923 $ ulp*max( temp1, temp2 ) )
1924 ELSE
1925 result( 29 ) = zero
1926 result( 30 ) = zero
1927 result( 31 ) = zero
1928 result( 32 ) = zero
1929 result( 33 ) = zero
1930 result( 34 ) = zero
1931 END IF
1932*
1933* Call ZSTEMR(V,A) to compute D1 and Z, do tests.
1934*
1935* Compute D1 and Z
1936*
1937 CALL dcopy( n, sd, 1, d5, 1 )
1938 IF( n.GT.0 )
1939 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1940*
1941 ntest = 35
1942*
1943 CALL zstemr( 'V', 'A', n, d5, rwork, vl, vu, il, iu,
1944 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1945 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1946 $ liwork-2*n, iinfo )
1947 IF( iinfo.NE.0 ) THEN
1948 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,A)', iinfo, n,
1949 $ jtype, ioldsd
1950 info = abs( iinfo )
1951 IF( iinfo.LT.0 ) THEN
1952 RETURN
1953 ELSE
1954 result( 35 ) = ulpinv
1955 GO TO 280
1956 END IF
1957 END IF
1958*
1959* Do Tests 35 and 36
1960*
1961 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1962 $ rwork, result( 35 ) )
1963*
1964* Call ZSTEMR to compute D2, do tests.
1965*
1966* Compute D2
1967*
1968 CALL dcopy( n, sd, 1, d5, 1 )
1969 IF( n.GT.0 )
1970 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1971*
1972 ntest = 37
1973 CALL zstemr( 'N', 'A', n, d5, rwork, vl, vu, il, iu,
1974 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1975 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1976 $ liwork-2*n, iinfo )
1977 IF( iinfo.NE.0 ) THEN
1978 WRITE( nounit, fmt = 9999 )'ZSTEMR(N,A)', iinfo, n,
1979 $ jtype, ioldsd
1980 info = abs( iinfo )
1981 IF( iinfo.LT.0 ) THEN
1982 RETURN
1983 ELSE
1984 result( 37 ) = ulpinv
1985 GO TO 280
1986 END IF
1987 END IF
1988*
1989* Do Test 37
1990*
1991 temp1 = zero
1992 temp2 = zero
1993*
1994 DO 260 j = 1, n
1995 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1996 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1997 260 CONTINUE
1998*
1999 result( 37 ) = temp2 / max( unfl,
2000 $ ulp*max( temp1, temp2 ) )
2001 END IF
2002 270 CONTINUE
2003 280 CONTINUE
2004 ntestt = ntestt + ntest
2005*
2006* End of Loop -- Check for RESULT(j) > THRESH
2007*
2008* Print out tests which fail.
2009*
2010 DO 290 jr = 1, ntest
2011 IF( result( jr ).GE.thresh ) THEN
2012*
2013* If this is the first test to fail,
2014* print a header to the data file.
2015*
2016 IF( nerrs.EQ.0 ) THEN
2017 WRITE( nounit, fmt = 9998 )'ZST'
2018 WRITE( nounit, fmt = 9997 )
2019 WRITE( nounit, fmt = 9996 )
2020 WRITE( nounit, fmt = 9995 )'Hermitian'
2021 WRITE( nounit, fmt = 9994 )
2022*
2023* Tests performed
2024*
2025 WRITE( nounit, fmt = 9987 )
2026 END IF
2027 nerrs = nerrs + 1
2028 IF( result( jr ).LT.10000.0d0 ) THEN
2029 WRITE( nounit, fmt = 9989 )n, jtype, ioldsd, jr,
2030 $ result( jr )
2031 ELSE
2032 WRITE( nounit, fmt = 9988 )n, jtype, ioldsd, jr,
2033 $ result( jr )
2034 END IF
2035 END IF
2036 290 CONTINUE
2037 300 CONTINUE
2038 310 CONTINUE
2039*
2040* Summary
2041*
2042 CALL dlasum( 'ZST', nounit, nerrs, ntestt )
2043 RETURN
2044*
2045 9999 FORMAT( ' ZCHKST2STG: ', a, ' returned INFO=', i6, '.', / 9x,
2046 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2047*
2048 9998 FORMAT( / 1x, a3, ' -- Complex Hermitian eigenvalue problem' )
2049 9997 FORMAT( ' Matrix types (see ZCHKST2STG for details): ' )
2050*
2051 9996 FORMAT( / ' Special Matrices:',
2052 $ / ' 1=Zero matrix. ',
2053 $ ' 5=Diagonal: clustered entries.',
2054 $ / ' 2=Identity matrix. ',
2055 $ ' 6=Diagonal: large, evenly spaced.',
2056 $ / ' 3=Diagonal: evenly spaced entries. ',
2057 $ ' 7=Diagonal: small, evenly spaced.',
2058 $ / ' 4=Diagonal: geometr. spaced entries.' )
2059 9995 FORMAT( ' Dense ', a, ' Matrices:',
2060 $ / ' 8=Evenly spaced eigenvals. ',
2061 $ ' 12=Small, evenly spaced eigenvals.',
2062 $ / ' 9=Geometrically spaced eigenvals. ',
2063 $ ' 13=Matrix with random O(1) entries.',
2064 $ / ' 10=Clustered eigenvalues. ',
2065 $ ' 14=Matrix with large random entries.',
2066 $ / ' 11=Large, evenly spaced eigenvals. ',
2067 $ ' 15=Matrix with small random entries.' )
2068 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues',
2069 $ / ' 17=Positive definite, geometrically spaced eigenvlaues',
2070 $ / ' 18=Positive definite, clustered eigenvalues',
2071 $ / ' 19=Positive definite, small evenly spaced eigenvalues',
2072 $ / ' 20=Positive definite, large evenly spaced eigenvalues',
2073 $ / ' 21=Diagonally dominant tridiagonal, geometrically',
2074 $ ' spaced eigenvalues' )
2075*
2076 9989 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
2077 $ 4( i4, ',' ), ' result ', i3, ' is', 0p, f8.2 )
2078 9988 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
2079 $ 4( i4, ',' ), ' result ', i3, ' is', 1p, d10.3 )
2080*
2081 9987 FORMAT( / 'Test performed: see ZCHKST2STG for details.', / )
2082*
2083* End of ZCHKST2STG
2084*
zhetrd_2stage
subroutine zhetrd_2stage(vect, uplo, n, a, lda, d, e, tau, hous2, lhous2, work, lwork, info)
ZHETRD_2STAGE
Definition zhetrd_2stage.f:224

◆ zckcsd()

subroutine zckcsd ( integer nm,
integer, dimension( * ) mval,
integer, dimension( * ) pval,
integer, dimension( * ) qval,
integer nmats,
integer, dimension( 4 ) iseed,
double precision thresh,
integer mmax,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xf,
complex*16, dimension( * ) u1,
complex*16, dimension( * ) u2,
complex*16, dimension( * ) v1t,
complex*16, dimension( * ) v2t,
double precision, dimension( * ) theta,
integer, dimension( * ) iwork,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nin,
integer nout,
integer info )

ZCKCSD

Purpose:
!>
!> ZCKCSD tests ZUNCSD:
!>        the CSD for an M-by-M unitary matrix X partitioned as
!>        [ X11 X12; X21 X22 ]. X11 is P-by-Q.
!>
Parameters
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]PVAL
!>          PVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension P.
!>
[in]QVAL
!>          QVAL is INTEGER array, dimension (NM)
!>          The values of the matrix column dimension Q.
!>
[in]NMATS
!>          NMATS is INTEGER
!>          The number of matrix types to be tested for each combination
!>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
!>          number of matrix types), then all the different types are
!>          generated for testing.  If NMATS < NTYPES, another input line
!>          is read to get the numbers of the matrix types to be used.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator.  The array
!>          elements should be between 0 and 4095, otherwise they will be
!>          reduced mod 4096, and ISEED(4) must be odd.
!>          On exit, the next seed in the random number sequence after
!>          all the test matrices have been generated.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]MMAX
!>          MMAX is INTEGER
!>          The maximum value permitted for M, used in dimensioning the
!>          work arrays.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (MMAX*MMAX)
!>
[out]XF
!>          XF is COMPLEX*16 array, dimension (MMAX*MMAX)
!>
[out]U1
!>          U1 is COMPLEX*16 array, dimension (MMAX*MMAX)
!>
[out]U2
!>          U2 is COMPLEX*16 array, dimension (MMAX*MMAX)
!>
[out]V1T
!>          V1T is COMPLEX*16 array, dimension (MMAX*MMAX)
!>
[out]V2T
!>          V2T is COMPLEX*16 array, dimension (MMAX*MMAX)
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (MMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (MMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array
!>
[in]NIN
!>          NIN is INTEGER
!>          The unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0 :  successful exit
!>          > 0 :  If ZLAROR returns an error code, the absolute value
!>                 of it is returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 181 of file zckcsd.f.

184*
185* -- LAPACK test routine --
186* -- LAPACK is a software package provided by Univ. of Tennessee, --
187* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
188*
189* .. Scalar Arguments ..
190 INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT
191 DOUBLE PRECISION THRESH
192* ..
193* .. Array Arguments ..
194 INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), PVAL( * ),
195 $ QVAL( * )
196 DOUBLE PRECISION RWORK( * ), THETA( * )
197 COMPLEX*16 U1( * ), U2( * ), V1T( * ), V2T( * ),
198 $ WORK( * ), X( * ), XF( * )
199* ..
200*
201* =====================================================================
202*
203* .. Parameters ..
204 INTEGER NTESTS
205 parameter( ntests = 15 )
206 INTEGER NTYPES
207 parameter( ntypes = 4 )
208 DOUBLE PRECISION GAPDIGIT, ORTH, REALONE, REALZERO, TEN
209 parameter( gapdigit = 18.0d0, orth = 1.0d-12,
210 $ realone = 1.0d0, realzero = 0.0d0,
211 $ ten = 10.0d0 )
212 COMPLEX*16 ONE, ZERO
213 parameter( one = (1.0d0,0.0d0), zero = (0.0d0,0.0d0) )
214 DOUBLE PRECISION PIOVER2
215 parameter( piover2 = 1.57079632679489661923132169163975144210d0 )
216* ..
217* .. Local Scalars ..
218 LOGICAL FIRSTT
219 CHARACTER*3 PATH
220 INTEGER I, IINFO, IM, IMAT, J, LDU1, LDU2, LDV1T,
221 $ LDV2T, LDX, LWORK, M, NFAIL, NRUN, NT, P, Q, R
222* ..
223* .. Local Arrays ..
224 LOGICAL DOTYPE( NTYPES )
225 DOUBLE PRECISION RESULT( NTESTS )
226* ..
227* .. External Subroutines ..
228 EXTERNAL alahdg, alareq, alasum, zcsdts, zlacsg, zlaror,
229 $ zlaset, zdrot
230* ..
231* .. Intrinsic Functions ..
232 INTRINSIC abs, min
233* ..
234* .. External Functions ..
235 DOUBLE PRECISION DLARAN, DLARND
236 EXTERNAL dlaran, dlarnd
237* ..
238* .. Executable Statements ..
239*
240* Initialize constants and the random number seed.
241*
242 path( 1: 3 ) = 'CSD'
243 info = 0
244 nrun = 0
245 nfail = 0
246 firstt = .true.
247 CALL alareq( path, nmats, dotype, ntypes, nin, nout )
248 ldx = mmax
249 ldu1 = mmax
250 ldu2 = mmax
251 ldv1t = mmax
252 ldv2t = mmax
253 lwork = mmax*mmax
254*
255* Do for each value of M in MVAL.
256*
257 DO 30 im = 1, nm
258 m = mval( im )
259 p = pval( im )
260 q = qval( im )
261*
262 DO 20 imat = 1, ntypes
263*
264* Do the tests only if DOTYPE( IMAT ) is true.
265*
266 IF( .NOT.dotype( imat ) )
267 $ GO TO 20
268*
269* Generate X
270*
271 IF( imat.EQ.1 ) THEN
272 CALL zlaror( 'L', 'I', m, m, x, ldx, iseed, work, iinfo )
273 IF( m .NE. 0 .AND. iinfo .NE. 0 ) THEN
274 WRITE( nout, fmt = 9999 ) m, iinfo
275 info = abs( iinfo )
276 GO TO 20
277 END IF
278 ELSE IF( imat.EQ.2 ) THEN
279 r = min( p, m-p, q, m-q )
280 DO i = 1, r
281 theta(i) = piover2 * dlarnd( 1, iseed )
282 END DO
283 CALL zlacsg( m, p, q, theta, iseed, x, ldx, work )
284 DO i = 1, m
285 DO j = 1, m
286 x(i+(j-1)*ldx) = x(i+(j-1)*ldx) +
287 $ orth*dlarnd(2,iseed)
288 END DO
289 END DO
290 ELSE IF( imat.EQ.3 ) THEN
291 r = min( p, m-p, q, m-q )
292 DO i = 1, r+1
293 theta(i) = ten**(-dlarnd(1,iseed)*gapdigit)
294 END DO
295 DO i = 2, r+1
296 theta(i) = theta(i-1) + theta(i)
297 END DO
298 DO i = 1, r
299 theta(i) = piover2 * theta(i) / theta(r+1)
300 END DO
301 CALL zlacsg( m, p, q, theta, iseed, x, ldx, work )
302 ELSE
303 CALL zlaset( 'F', m, m, zero, one, x, ldx )
304 DO i = 1, m
305 j = int( dlaran( iseed ) * m ) + 1
306 IF( j .NE. i ) THEN
307 CALL zdrot( m, x(1+(i-1)*ldx), 1, x(1+(j-1)*ldx),
308 $ 1, realzero, realone )
309 END IF
310 END DO
311 END IF
312*
313 nt = 15
314*
315 CALL zcsdts( m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t,
316 $ ldv1t, v2t, ldv2t, theta, iwork, work, lwork,
317 $ rwork, result )
318*
319* Print information about the tests that did not
320* pass the threshold.
321*
322 DO 10 i = 1, nt
323 IF( result( i ).GE.thresh ) THEN
324 IF( nfail.EQ.0 .AND. firstt ) THEN
325 firstt = .false.
326 CALL alahdg( nout, path )
327 END IF
328 WRITE( nout, fmt = 9998 )m, p, q, imat, i,
329 $ result( i )
330 nfail = nfail + 1
331 END IF
332 10 CONTINUE
333 nrun = nrun + nt
334 20 CONTINUE
335 30 CONTINUE
336*
337* Print a summary of the results.
338*
339 CALL alasum( path, nout, nfail, nrun, 0 )
340*
341 9999 FORMAT( ' ZLAROR in ZCKCSD: M = ', i5, ', INFO = ', i15 )
342 9998 FORMAT( ' M=', i4, ' P=', i4, ', Q=', i4, ', type ', i2,
343 $ ', test ', i2, ', ratio=', g13.6 )
344 RETURN
345*
346* End of ZCKCSD
347*
alahdg
subroutine alahdg(iounit, path)
ALAHDG
Definition alahdg.f:62
alareq
subroutine alareq(path, nmats, dotype, ntypes, nin, nout)
ALAREQ
Definition alareq.f:90
zdrot
subroutine zdrot(n, zx, incx, zy, incy, c, s)
ZDROT
Definition zdrot.f:98
zcsdts
subroutine zcsdts(m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, theta, iwork, work, lwork, rwork, result)
ZCSDTS
Definition zcsdts.f:229
zlaror
subroutine zlaror(side, init, m, n, a, lda, iseed, x, info)
ZLAROR
Definition zlaror.f:158
dlaran
double precision function dlaran(iseed)
DLARAN
Definition dlaran.f:67
zlacsg
subroutine zlacsg(m, p, q, theta, iseed, x, ldx, work)
Definition zckcsd.f:353

◆ zckglm()

subroutine zckglm ( integer nn,
integer, dimension( * ) nval,
integer, dimension( * ) mval,
integer, dimension( * ) pval,
integer nmats,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) af,
complex*16, dimension( * ) b,
complex*16, dimension( * ) bf,
complex*16, dimension( * ) x,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nin,
integer nout,
integer info )

ZCKGLM

Purpose:
!>
!> ZCKGLM tests ZGGGLM - subroutine for solving generalized linear
!>                       model problem.
!>
Parameters
[in]NN
!>          NN is INTEGER
!>          The number of values of N, M and P contained in the vectors
!>          NVAL, MVAL and PVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix row dimension N.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension M.
!>
[in]PVAL
!>          PVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension P.
!>
[in]NMATS
!>          NMATS is INTEGER
!>          The number of matrix types to be tested for each combination
!>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
!>          number of matrix types), then all the different types are
!>          generated for testing.  If NMATS < NTYPES, another input line
!>          is read to get the numbers of the matrix types to be used.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator.  The array
!>          elements should be between 0 and 4095, otherwise they will be
!>          reduced mod 4096, and ISEED(4) must be odd.
!>          On exit, the next seed in the random number sequence after
!>          all the test matrices have been generated.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESID >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (4*NMAX)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[in]NIN
!>          NIN is INTEGER
!>          The unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0 :  successful exit
!>          > 0 :  If ZLATMS returns an error code, the absolute value
!>                 of it is returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 165 of file zckglm.f.

168*
169* -- LAPACK test 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, NIN, NMATS, NMAX, NN, NOUT
175 DOUBLE PRECISION THRESH
176* ..
177* .. Array Arguments ..
178 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
179 DOUBLE PRECISION RWORK( * )
180 COMPLEX*16 A( * ), AF( * ), B( * ), BF( * ), WORK( * ),
181 $ X( * )
182* ..
183*
184* =====================================================================
185*
186* .. Parameters ..
187 INTEGER NTYPES
188 parameter( ntypes = 8 )
189* ..
190* .. Local Scalars ..
191 LOGICAL FIRSTT
192 CHARACTER DISTA, DISTB, TYPE
193 CHARACTER*3 PATH
194 INTEGER I, IINFO, IK, IMAT, KLA, KLB, KUA, KUB, LDA,
195 $ LDB, LWORK, M, MODEA, MODEB, N, NFAIL, NRUN, P
196 DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB, RESID
197* ..
198* .. Local Arrays ..
199 LOGICAL DOTYPE( NTYPES )
200* ..
201* .. External Functions ..
202 COMPLEX*16 ZLARND
203 EXTERNAL zlarnd
204* ..
205* .. External Subroutines ..
206 EXTERNAL alahdg, alareq, alasum, dlatb9, zglmts, zlatms
207* ..
208* .. Intrinsic Functions ..
209 INTRINSIC abs
210* ..
211* .. Executable Statements ..
212*
213* Initialize constants.
214*
215 path( 1: 3 ) = 'GLM'
216 info = 0
217 nrun = 0
218 nfail = 0
219 firstt = .true.
220 CALL alareq( path, nmats, dotype, ntypes, nin, nout )
221 lda = nmax
222 ldb = nmax
223 lwork = nmax*nmax
224*
225* Check for valid input values.
226*
227 DO 10 ik = 1, nn
228 m = mval( ik )
229 p = pval( ik )
230 n = nval( ik )
231 IF( m.GT.n .OR. n.GT.m+p ) THEN
232 IF( firstt ) THEN
233 WRITE( nout, fmt = * )
234 firstt = .false.
235 END IF
236 WRITE( nout, fmt = 9997 )m, p, n
237 END IF
238 10 CONTINUE
239 firstt = .true.
240*
241* Do for each value of M in MVAL.
242*
243 DO 40 ik = 1, nn
244 m = mval( ik )
245 p = pval( ik )
246 n = nval( ik )
247 IF( m.GT.n .OR. n.GT.m+p )
248 $ GO TO 40
249*
250 DO 30 imat = 1, ntypes
251*
252* Do the tests only if DOTYPE( IMAT ) is true.
253*
254 IF( .NOT.dotype( imat ) )
255 $ GO TO 30
256*
257* Set up parameters with DLATB9 and generate test
258* matrices A and B with ZLATMS.
259*
260 CALL dlatb9( path, imat, m, p, n, TYPE, KLA, KUA, KLB, KUB,
261 $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
262 $ DISTA, DISTB )
263*
264 CALL zlatms( n, m, dista, iseed, TYPE, RWORK, MODEA, CNDNMA,
265 $ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
266 $ IINFO )
267 IF( iinfo.NE.0 ) THEN
268 WRITE( nout, fmt = 9999 )iinfo
269 info = abs( iinfo )
270 GO TO 30
271 END IF
272*
273 CALL zlatms( n, p, distb, iseed, TYPE, RWORK, MODEB, CNDNMB,
274 $ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
275 $ IINFO )
276 IF( iinfo.NE.0 ) THEN
277 WRITE( nout, fmt = 9999 )iinfo
278 info = abs( iinfo )
279 GO TO 30
280 END IF
281*
282* Generate random left hand side vector of GLM
283*
284 DO 20 i = 1, n
285 x( i ) = zlarnd( 2, iseed )
286 20 CONTINUE
287*
288 CALL zglmts( n, m, p, a, af, lda, b, bf, ldb, x,
289 $ x( nmax+1 ), x( 2*nmax+1 ), x( 3*nmax+1 ),
290 $ work, lwork, rwork, resid )
291*
292* Print information about the tests that did not
293* pass the threshold.
294*
295 IF( resid.GE.thresh ) THEN
296 IF( nfail.EQ.0 .AND. firstt ) THEN
297 firstt = .false.
298 CALL alahdg( nout, path )
299 END IF
300 WRITE( nout, fmt = 9998 )n, m, p, imat, 1, resid
301 nfail = nfail + 1
302 END IF
303 nrun = nrun + 1
304*
305 30 CONTINUE
306 40 CONTINUE
307*
308* Print a summary of the results.
309*
310 CALL alasum( path, nout, nfail, nrun, 0 )
311*
312 9999 FORMAT( ' ZLATMS in ZCKGLM INFO = ', i5 )
313 9998 FORMAT( ' N=', i4, ' M=', i4, ', P=', i4, ', type ', i2,
314 $ ', test ', i2, ', ratio=', g13.6 )
315 9997 FORMAT( ' *** Invalid input for GLM: M = ', i6, ', P = ', i6,
316 $ ', N = ', i6, ';', / ' must satisfy M <= N <= M+P ',
317 $ '(this set of values will be skipped)' )
318 RETURN
319*
320* End of ZCKGLM
321*
zglmts
subroutine zglmts(n, m, p, a, af, lda, b, bf, ldb, d, df, x, u, work, lwork, rwork, result)
ZGLMTS
Definition zglmts.f:146
dlatb9
subroutine dlatb9(path, imat, m, p, n, type, kla, kua, klb, kub, anorm, bnorm, modea, modeb, cndnma, cndnmb, dista, distb)
DLATB9
Definition dlatb9.f:170

◆ zckgqr()

subroutine zckgqr ( integer nm,
integer, dimension( * ) mval,
integer np,
integer, dimension( * ) pval,
integer nn,
integer, dimension( * ) nval,
integer nmats,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) af,
complex*16, dimension( * ) aq,
complex*16, dimension( * ) ar,
complex*16, dimension( * ) taua,
complex*16, dimension( * ) b,
complex*16, dimension( * ) bf,
complex*16, dimension( * ) bz,
complex*16, dimension( * ) bt,
complex*16, dimension( * ) bwk,
complex*16, dimension( * ) taub,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nin,
integer nout,
integer info )

ZCKGQR

Purpose:
!>
!> ZCKGQR tests
!> ZGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B,
!> ZGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B.
!>
Parameters
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row(column) dimension M.
!>
[in]NP
!>          NP is INTEGER
!>          The number of values of P contained in the vector PVAL.
!>
[in]PVAL
!>          PVAL is INTEGER array, dimension (NP)
!>          The values of the matrix row(column) dimension P.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column(row) dimension N.
!>
[in]NMATS
!>          NMATS is INTEGER
!>          The number of matrix types to be tested for each combination
!>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
!>          number of matrix types), then all the different types are
!>          generated for testing.  If NMATS < NTYPES, another input line
!>          is read to get the numbers of the matrix types to be used.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator.  The array
!>          elements should be between 0 and 4095, otherwise they will be
!>          reduced mod 4096, and ISEED(4) must be odd.
!>          On exit, the next seed in the random number sequence after
!>          all the test matrices have been generated.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AR
!>          AR is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]TAUA
!>          TAUA is COMPLEX*16 array, dimension (NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]BZ
!>          BZ is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]BT
!>          BT is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]BWK
!>          BWK is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]TAUB
!>          TAUB is COMPLEX*16 array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
!>
[in]NIN
!>          NIN is INTEGER
!>          The unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0 :  successful exit
!>          > 0 :  If ZLATMS returns an error code, the absolute value
!>                 of it is returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 208 of file zckgqr.f.

211*
212* -- LAPACK test routine --
213* -- LAPACK is a software package provided by Univ. of Tennessee, --
214* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
215*
216* .. Scalar Arguments ..
217 INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP
218 DOUBLE PRECISION THRESH
219* ..
220* .. Array Arguments ..
221 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
222 DOUBLE PRECISION RWORK( * )
223 COMPLEX*16 A( * ), AF( * ), AQ( * ), AR( * ), B( * ),
224 $ BF( * ), BT( * ), BWK( * ), BZ( * ), TAUA( * ),
225 $ TAUB( * ), WORK( * )
226* ..
227*
228* =====================================================================
229*
230* .. Parameters ..
231 INTEGER NTESTS
232 parameter( ntests = 7 )
233 INTEGER NTYPES
234 parameter( ntypes = 8 )
235* ..
236* .. Local Scalars ..
237 LOGICAL FIRSTT
238 CHARACTER DISTA, DISTB, TYPE
239 CHARACTER*3 PATH
240 INTEGER I, IINFO, IM, IMAT, IN, IP, KLA, KLB, KUA, KUB,
241 $ LDA, LDB, LWORK, M, MODEA, MODEB, N, NFAIL,
242 $ NRUN, NT, P
243 DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
244* ..
245* .. Local Arrays ..
246 LOGICAL DOTYPE( NTYPES )
247 DOUBLE PRECISION RESULT( NTESTS )
248* ..
249* .. External Subroutines ..
250 EXTERNAL alahdg, alareq, alasum, dlatb9, zgqrts, zgrqts,
251 $ zlatms
252* ..
253* .. Intrinsic Functions ..
254 INTRINSIC abs
255* ..
256* .. Executable Statements ..
257*
258* Initialize constants.
259*
260 path( 1: 3 ) = 'GQR'
261 info = 0
262 nrun = 0
263 nfail = 0
264 firstt = .true.
265 CALL alareq( path, nmats, dotype, ntypes, nin, nout )
266 lda = nmax
267 ldb = nmax
268 lwork = nmax*nmax
269*
270* Do for each value of M in MVAL.
271*
272 DO 60 im = 1, nm
273 m = mval( im )
274*
275* Do for each value of P in PVAL.
276*
277 DO 50 ip = 1, np
278 p = pval( ip )
279*
280* Do for each value of N in NVAL.
281*
282 DO 40 in = 1, nn
283 n = nval( in )
284*
285 DO 30 imat = 1, ntypes
286*
287* Do the tests only if DOTYPE( IMAT ) is true.
288*
289 IF( .NOT.dotype( imat ) )
290 $ GO TO 30
291*
292* Test ZGGRQF
293*
294* Set up parameters with DLATB9 and generate test
295* matrices A and B with ZLATMS.
296*
297 CALL dlatb9( 'GRQ', imat, m, p, n, TYPE, KLA, KUA,
298 $ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
299 $ CNDNMA, CNDNMB, DISTA, DISTB )
300*
301 CALL zlatms( m, n, dista, iseed, TYPE, RWORK, MODEA,
302 $ CNDNMA, ANORM, KLA, KUA, 'No packing', A,
303 $ LDA, WORK, IINFO )
304 IF( iinfo.NE.0 ) THEN
305 WRITE( nout, fmt = 9999 )iinfo
306 info = abs( iinfo )
307 GO TO 30
308 END IF
309*
310 CALL zlatms( p, n, distb, iseed, TYPE, RWORK, MODEB,
311 $ CNDNMB, BNORM, KLB, KUB, 'No packing', B,
312 $ LDB, WORK, IINFO )
313 IF( iinfo.NE.0 ) THEN
314 WRITE( nout, fmt = 9999 )iinfo
315 info = abs( iinfo )
316 GO TO 30
317 END IF
318*
319 nt = 4
320*
321 CALL zgrqts( m, p, n, a, af, aq, ar, lda, taua, b, bf,
322 $ bz, bt, bwk, ldb, taub, work, lwork,
323 $ rwork, result )
324*
325* Print information about the tests that did not
326* pass the threshold.
327*
328 DO 10 i = 1, nt
329 IF( result( i ).GE.thresh ) THEN
330 IF( nfail.EQ.0 .AND. firstt ) THEN
331 firstt = .false.
332 CALL alahdg( nout, 'GRQ' )
333 END IF
334 WRITE( nout, fmt = 9998 )m, p, n, imat, i,
335 $ result( i )
336 nfail = nfail + 1
337 END IF
338 10 CONTINUE
339 nrun = nrun + nt
340*
341* Test ZGGQRF
342*
343* Set up parameters with DLATB9 and generate test
344* matrices A and B with ZLATMS.
345*
346 CALL dlatb9( 'GQR', imat, m, p, n, TYPE, KLA, KUA,
347 $ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
348 $ CNDNMA, CNDNMB, DISTA, DISTB )
349*
350 CALL zlatms( n, m, dista, iseed, TYPE, RWORK, MODEA,
351 $ CNDNMA, ANORM, KLA, KUA, 'No packing', A,
352 $ LDA, WORK, IINFO )
353 IF( iinfo.NE.0 ) THEN
354 WRITE( nout, fmt = 9999 )iinfo
355 info = abs( iinfo )
356 GO TO 30
357 END IF
358*
359 CALL zlatms( n, p, distb, iseed, TYPE, RWORK, MODEA,
360 $ CNDNMA, BNORM, KLB, KUB, 'No packing', B,
361 $ LDB, WORK, IINFO )
362 IF( iinfo.NE.0 ) THEN
363 WRITE( nout, fmt = 9999 )iinfo
364 info = abs( iinfo )
365 GO TO 30
366 END IF
367*
368 nt = 4
369*
370 CALL zgqrts( n, m, p, a, af, aq, ar, lda, taua, b, bf,
371 $ bz, bt, bwk, ldb, taub, work, lwork,
372 $ rwork, result )
373*
374* Print information about the tests that did not
375* pass the threshold.
376*
377 DO 20 i = 1, nt
378 IF( result( i ).GE.thresh ) THEN
379 IF( nfail.EQ.0 .AND. firstt ) THEN
380 firstt = .false.
381 CALL alahdg( nout, path )
382 END IF
383 WRITE( nout, fmt = 9997 )n, m, p, imat, i,
384 $ result( i )
385 nfail = nfail + 1
386 END IF
387 20 CONTINUE
388 nrun = nrun + nt
389*
390 30 CONTINUE
391 40 CONTINUE
392 50 CONTINUE
393 60 CONTINUE
394*
395* Print a summary of the results.
396*
397 CALL alasum( path, nout, nfail, nrun, 0 )
398*
399 9999 FORMAT( ' ZLATMS in ZCKGQR: INFO = ', i5 )
400 9998 FORMAT( ' M=', i4, ' P=', i4, ', N=', i4, ', type ', i2,
401 $ ', test ', i2, ', ratio=', g13.6 )
402 9997 FORMAT( ' N=', i4, ' M=', i4, ', P=', i4, ', type ', i2,
403 $ ', test ', i2, ', ratio=', g13.6 )
404 RETURN
405*
406* End of ZCKGQR
407*
zgrqts
subroutine zgrqts(m, p, n, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
ZGRQTS
Definition zgrqts.f:176
zgqrts
subroutine zgqrts(n, m, p, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
ZGQRTS
Definition zgqrts.f:176

◆ zckgsv()

subroutine zckgsv ( integer nm,
integer, dimension( * ) mval,
integer, dimension( * ) pval,
integer, dimension( * ) nval,
integer nmats,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) af,
complex*16, dimension( * ) b,
complex*16, dimension( * ) bf,
complex*16, dimension( * ) u,
complex*16, dimension( * ) v,
complex*16, dimension( * ) q,
double precision, dimension( * ) alpha,
double precision, dimension( * ) beta,
complex*16, dimension( * ) r,
integer, dimension( * ) iwork,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nin,
integer nout,
integer info )

ZCKGSV

Purpose:
!>
!> ZCKGSV tests ZGGSVD:
!>        the GSVD for M-by-N matrix A and P-by-N matrix B.
!>
Parameters
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]PVAL
!>          PVAL is INTEGER array, dimension (NP)
!>          The values of the matrix row dimension P.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NMATS
!>          NMATS is INTEGER
!>          The number of matrix types to be tested for each combination
!>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
!>          number of matrix types), then all the different types are
!>          generated for testing.  If NMATS < NTYPES, another input line
!>          is read to get the numbers of the matrix types to be used.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator.  The array
!>          elements should be between 0 and 4095, otherwise they will be
!>          reduced mod 4096, and ISEED(4) must be odd.
!>          On exit, the next seed in the random number sequence after
!>          all the test matrices have been generated.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]U
!>          U is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]V
!>          V is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]ALPHA
!>          ALPHA is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]R
!>          R is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
!>
[in]NIN
!>          NIN is INTEGER
!>          The unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0 :  successful exit
!>          > 0 :  If ZLATMS returns an error code, the absolute value
!>                 of it is returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 195 of file zckgsv.f.

198*
199* -- LAPACK test routine --
200* -- LAPACK is a software package provided by Univ. of Tennessee, --
201* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
202*
203* .. Scalar Arguments ..
204 INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT
205 DOUBLE PRECISION THRESH
206* ..
207* .. Array Arguments ..
208 INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * ),
209 $ PVAL( * )
210 DOUBLE PRECISION ALPHA( * ), BETA( * ), RWORK( * )
211 COMPLEX*16 A( * ), AF( * ), B( * ), BF( * ), Q( * ),
212 $ R( * ), U( * ), V( * ), WORK( * )
213* ..
214*
215* =====================================================================
216*
217* .. Parameters ..
218 INTEGER NTESTS
219 parameter( ntests = 12 )
220 INTEGER NTYPES
221 parameter( ntypes = 8 )
222* ..
223* .. Local Scalars ..
224 LOGICAL FIRSTT
225 CHARACTER DISTA, DISTB, TYPE
226 CHARACTER*3 PATH
227 INTEGER I, IINFO, IM, IMAT, KLA, KLB, KUA, KUB, LDA,
228 $ LDB, LDQ, LDR, LDU, LDV, LWORK, M, MODEA,
229 $ MODEB, N, NFAIL, NRUN, NT, P
230 DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
231* ..
232* .. Local Arrays ..
233 LOGICAL DOTYPE( NTYPES )
234 DOUBLE PRECISION RESULT( NTESTS )
235* ..
236* .. External Subroutines ..
237 EXTERNAL alahdg, alareq, alasum, dlatb9, zgsvts3, zlatms
238* ..
239* .. Intrinsic Functions ..
240 INTRINSIC abs
241* ..
242* .. Executable Statements ..
243*
244* Initialize constants and the random number seed.
245*
246 path( 1: 3 ) = 'GSV'
247 info = 0
248 nrun = 0
249 nfail = 0
250 firstt = .true.
251 CALL alareq( path, nmats, dotype, ntypes, nin, nout )
252 lda = nmax
253 ldb = nmax
254 ldu = nmax
255 ldv = nmax
256 ldq = nmax
257 ldr = nmax
258 lwork = nmax*nmax
259*
260* Do for each value of M in MVAL.
261*
262 DO 30 im = 1, nm
263 m = mval( im )
264 p = pval( im )
265 n = nval( im )
266*
267 DO 20 imat = 1, ntypes
268*
269* Do the tests only if DOTYPE( IMAT ) is true.
270*
271 IF( .NOT.dotype( imat ) )
272 $ GO TO 20
273*
274* Set up parameters with DLATB9 and generate test
275* matrices A and B with ZLATMS.
276*
277 CALL dlatb9( path, imat, m, p, n, TYPE, KLA, KUA, KLB, KUB,
278 $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
279 $ DISTA, DISTB )
280*
281* Generate M by N matrix A
282*
283 CALL zlatms( m, n, dista, iseed, TYPE, RWORK, MODEA, CNDNMA,
284 $ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
285 $ IINFO )
286 IF( iinfo.NE.0 ) THEN
287 WRITE( nout, fmt = 9999 )iinfo
288 info = abs( iinfo )
289 GO TO 20
290 END IF
291*
292* Generate P by N matrix B
293*
294 CALL zlatms( p, n, distb, iseed, TYPE, RWORK, MODEB, CNDNMB,
295 $ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
296 $ IINFO )
297 IF( iinfo.NE.0 ) THEN
298 WRITE( nout, fmt = 9999 )iinfo
299 info = abs( iinfo )
300 GO TO 20
301 END IF
302*
303 nt = 6
304*
305 CALL zgsvts3( m, p, n, a, af, lda, b, bf, ldb, u, ldu, v,
306 $ ldv, q, ldq, alpha, beta, r, ldr, iwork, work,
307 $ lwork, rwork, result )
308*
309* Print information about the tests that did not
310* pass the threshold.
311*
312 DO 10 i = 1, nt
313 IF( result( i ).GE.thresh ) THEN
314 IF( nfail.EQ.0 .AND. firstt ) THEN
315 firstt = .false.
316 CALL alahdg( nout, path )
317 END IF
318 WRITE( nout, fmt = 9998 )m, p, n, imat, i,
319 $ result( i )
320 nfail = nfail + 1
321 END IF
322 10 CONTINUE
323 nrun = nrun + nt
324*
325 20 CONTINUE
326 30 CONTINUE
327*
328* Print a summary of the results.
329*
330 CALL alasum( path, nout, nfail, nrun, 0 )
331*
332 9999 FORMAT( ' ZLATMS in ZCKGSV INFO = ', i5 )
333 9998 FORMAT( ' M=', i4, ' P=', i4, ', N=', i4, ', type ', i2,
334 $ ', test ', i2, ', ratio=', g13.6 )
335 RETURN
336*
337* End of ZCKGSV
338*
alpha
#define alpha
Definition eval.h:35
zgsvts3
subroutine zgsvts3(m, p, n, a, af, lda, b, bf, ldb, u, ldu, v, ldv, q, ldq, alpha, beta, r, ldr, iwork, work, lwork, rwork, result)
ZGSVTS3
Definition zgsvts3.f:209

◆ zcklse()

subroutine zcklse ( integer nn,
integer, dimension( * ) mval,
integer, dimension( * ) pval,
integer, dimension( * ) nval,
integer nmats,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) af,
complex*16, dimension( * ) b,
complex*16, dimension( * ) bf,
complex*16, dimension( * ) x,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nin,
integer nout,
integer info )

ZCKLSE

Purpose:
!>
!> ZCKLSE tests ZGGLSE - a subroutine for solving linear equality
!> constrained least square problem (LSE).
!>
Parameters
[in]NN
!>          NN is INTEGER
!>          The number of values of (M,P,N) contained in the vectors
!>          (MVAL, PVAL, NVAL).
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NN)
!>          The values of the matrix row(column) dimension M.
!>
[in]PVAL
!>          PVAL is INTEGER array, dimension (NN)
!>          The values of the matrix row(column) dimension P.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column(row) dimension N.
!>
[in]NMATS
!>          NMATS is INTEGER
!>          The number of matrix types to be tested for each combination
!>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
!>          number of matrix types), then all the different types are
!>          generated for testing.  If NMATS < NTYPES, another input line
!>          is read to get the numbers of the matrix types to be used.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator.  The array
!>          elements should be between 0 and 4095, otherwise they will be
!>          reduced mod 4096, and ISEED(4) must be odd.
!>          On exit, the next seed in the random number sequence after
!>          all the test matrices have been generated.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (5*NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
!>
[in]NIN
!>          NIN is INTEGER
!>          The unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0 :  successful exit
!>          > 0 :  If ZLATMS returns an error code, the absolute value
!>                 of it is returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 165 of file zcklse.f.

168*
169* -- LAPACK test 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, NIN, NMATS, NMAX, NN, NOUT
175 DOUBLE PRECISION THRESH
176* ..
177* .. Array Arguments ..
178 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
179 DOUBLE PRECISION RWORK( * )
180 COMPLEX*16 A( * ), AF( * ), B( * ), BF( * ), WORK( * ),
181 $ X( * )
182* ..
183*
184* =====================================================================
185*
186* .. Parameters ..
187 INTEGER NTESTS
188 parameter( ntests = 7 )
189 INTEGER NTYPES
190 parameter( ntypes = 8 )
191* ..
192* .. Local Scalars ..
193 LOGICAL FIRSTT
194 CHARACTER DISTA, DISTB, TYPE
195 CHARACTER*3 PATH
196 INTEGER I, IINFO, IK, IMAT, KLA, KLB, KUA, KUB, LDA,
197 $ LDB, LWORK, M, MODEA, MODEB, N, NFAIL, NRUN,
198 $ NT, P
199 DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
200* ..
201* .. Local Arrays ..
202 LOGICAL DOTYPE( NTYPES )
203 DOUBLE PRECISION RESULT( NTESTS )
204* ..
205* .. External Subroutines ..
206 EXTERNAL alahdg, alareq, alasum, dlatb9, zlarhs, zlatms,
207 $ zlsets
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC abs, max
211* ..
212* .. Executable Statements ..
213*
214* Initialize constants and the random number seed.
215*
216 path( 1: 3 ) = 'LSE'
217 info = 0
218 nrun = 0
219 nfail = 0
220 firstt = .true.
221 CALL alareq( path, nmats, dotype, ntypes, nin, nout )
222 lda = nmax
223 ldb = nmax
224 lwork = nmax*nmax
225*
226* Check for valid input values.
227*
228 DO 10 ik = 1, nn
229 m = mval( ik )
230 p = pval( ik )
231 n = nval( ik )
232 IF( p.GT.n .OR. n.GT.m+p ) THEN
233 IF( firstt ) THEN
234 WRITE( nout, fmt = * )
235 firstt = .false.
236 END IF
237 WRITE( nout, fmt = 9997 )m, p, n
238 END IF
239 10 CONTINUE
240 firstt = .true.
241*
242* Do for each value of M in MVAL.
243*
244 DO 40 ik = 1, nn
245 m = mval( ik )
246 p = pval( ik )
247 n = nval( ik )
248 IF( p.GT.n .OR. n.GT.m+p )
249 $ GO TO 40
250*
251 DO 30 imat = 1, ntypes
252*
253* Do the tests only if DOTYPE( IMAT ) is true.
254*
255 IF( .NOT.dotype( imat ) )
256 $ GO TO 30
257*
258* Set up parameters with DLATB9 and generate test
259* matrices A and B with ZLATMS.
260*
261 CALL dlatb9( path, imat, m, p, n, TYPE, KLA, KUA, KLB, KUB,
262 $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
263 $ DISTA, DISTB )
264*
265 CALL zlatms( m, n, dista, iseed, TYPE, RWORK, MODEA, CNDNMA,
266 $ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
267 $ IINFO )
268 IF( iinfo.NE.0 ) THEN
269 WRITE( nout, fmt = 9999 )iinfo
270 info = abs( iinfo )
271 GO TO 30
272 END IF
273*
274 CALL zlatms( p, n, distb, iseed, TYPE, RWORK, MODEB, CNDNMB,
275 $ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
276 $ IINFO )
277 IF( iinfo.NE.0 ) THEN
278 WRITE( nout, fmt = 9999 )iinfo
279 info = abs( iinfo )
280 GO TO 30
281 END IF
282*
283* Generate the right-hand sides C and D for the LSE.
284*
285 CALL zlarhs( 'ZGE', 'New solution', 'Upper', 'N', m, n,
286 $ max( m-1, 0 ), max( n-1, 0 ), 1, a, lda,
287 $ x( 4*nmax+1 ), max( n, 1 ), x, max( m, 1 ),
288 $ iseed, iinfo )
289*
290 CALL zlarhs( 'ZGE', 'Computed', 'Upper', 'N', p, n,
291 $ max( p-1, 0 ), max( n-1, 0 ), 1, b, ldb,
292 $ x( 4*nmax+1 ), max( n, 1 ), x( 2*nmax+1 ),
293 $ max( p, 1 ), iseed, iinfo )
294*
295 nt = 2
296*
297 CALL zlsets( m, p, n, a, af, lda, b, bf, ldb, x,
298 $ x( nmax+1 ), x( 2*nmax+1 ), x( 3*nmax+1 ),
299 $ x( 4*nmax+1 ), work, lwork, rwork,
300 $ result( 1 ) )
301*
302* Print information about the tests that did not
303* pass the threshold.
304*
305 DO 20 i = 1, nt
306 IF( result( i ).GE.thresh ) THEN
307 IF( nfail.EQ.0 .AND. firstt ) THEN
308 firstt = .false.
309 CALL alahdg( nout, path )
310 END IF
311 WRITE( nout, fmt = 9998 )m, p, n, imat, i,
312 $ result( i )
313 nfail = nfail + 1
314 END IF
315 20 CONTINUE
316 nrun = nrun + nt
317*
318 30 CONTINUE
319 40 CONTINUE
320*
321* Print a summary of the results.
322*
323 CALL alasum( path, nout, nfail, nrun, 0 )
324*
325 9999 FORMAT( ' ZLATMS in ZCKLSE INFO = ', i5 )
326 9998 FORMAT( ' M=', i4, ' P=', i4, ', N=', i4, ', type ', i2,
327 $ ', test ', i2, ', ratio=', g13.6 )
328 9997 FORMAT( ' *** Invalid input for LSE: M = ', i6, ', P = ', i6,
329 $ ', N = ', i6, ';', / ' must satisfy P <= N <= P+M ',
330 $ '(this set of values will be skipped)' )
331 RETURN
332*
333* End of ZCKLSE
334*
zlarhs
subroutine zlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
ZLARHS
Definition zlarhs.f:208
zlsets
subroutine zlsets(m, p, n, a, af, lda, b, bf, ldb, c, cf, d, df, x, work, lwork, rwork, result)
ZLSETS
Definition zlsets.f:151

◆ zcsdts()

subroutine zcsdts ( integer m,
integer p,
integer q,
complex*16, dimension( ldx, * ) x,
complex*16, dimension( ldx, * ) xf,
integer ldx,
complex*16, dimension( ldu1, * ) u1,
integer ldu1,
complex*16, dimension( ldu2, * ) u2,
integer ldu2,
complex*16, dimension( ldv1t, * ) v1t,
integer ldv1t,
complex*16, dimension( ldv2t, * ) v2t,
integer ldv2t,
double precision, dimension( * ) theta,
integer, dimension( * ) iwork,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( 15 ) result )

ZCSDTS

Purpose:
!>
!> ZCSDTS tests ZUNCSD, which, given an M-by-M partitioned unitary
!> matrix X,
!>              Q  M-Q
!>       X = [ X11 X12 ] P   ,
!>           [ X21 X22 ] M-P
!>
!> computes the CSD
!>
!>       [ U1    ]**T * [ X11 X12 ] * [ V1    ]
!>       [    U2 ]      [ X21 X22 ]   [    V2 ]
!>
!>                             [  I  0  0 |  0  0  0 ]
!>                             [  0  C  0 |  0 -S  0 ]
!>                             [  0  0  0 |  0  0 -I ]
!>                           = [---------------------] = [ D11 D12 ] .
!>                             [  0  0  0 |  I  0  0 ]   [ D21 D22 ]
!>                             [  0  S  0 |  0  C  0 ]
!>                             [  0  0  I |  0  0  0 ]
!>
!> and also SORCSD2BY1, which, given
!>          Q
!>       [ X11 ] P   ,
!>       [ X21 ] M-P
!>
!> computes the 2-by-1 CSD
!>
!>                                     [  I  0  0 ]
!>                                     [  0  C  0 ]
!>                                     [  0  0  0 ]
!>       [ U1    ]**T * [ X11 ] * V1 = [----------] = [ D11 ] ,
!>       [    U2 ]      [ X21 ]        [  0  0  0 ]   [ D21 ]
!>                                     [  0  S  0 ]
!>                                     [  0  0  I ]
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix X.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of rows of the matrix X11.  P >= 0.
!>
[in]Q
!>          Q is INTEGER
!>          The number of columns of the matrix X11.  Q >= 0.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,M)
!>          The M-by-M matrix X.
!>
[out]XF
!>          XF is COMPLEX*16 array, dimension (LDX,M)
!>          Details of the CSD of X, as returned by ZUNCSD;
!>          see ZUNCSD for further details.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the arrays X and XF.
!>          LDX >= max( 1,M ).
!>
[out]U1
!>          U1 is COMPLEX*16 array, dimension(LDU1,P)
!>          The P-by-P unitary matrix U1.
!>
[in]LDU1
!>          LDU1 is INTEGER
!>          The leading dimension of the array U1. LDU >= max(1,P).
!>
[out]U2
!>          U2 is COMPLEX*16 array, dimension(LDU2,M-P)
!>          The (M-P)-by-(M-P) unitary matrix U2.
!>
[in]LDU2
!>          LDU2 is INTEGER
!>          The leading dimension of the array U2. LDU >= max(1,M-P).
!>
[out]V1T
!>          V1T is COMPLEX*16 array, dimension(LDV1T,Q)
!>          The Q-by-Q unitary matrix V1T.
!>
[in]LDV1T
!>          LDV1T is INTEGER
!>          The leading dimension of the array V1T. LDV1T >=
!>          max(1,Q).
!>
[out]V2T
!>          V2T is COMPLEX*16 array, dimension(LDV2T,M-Q)
!>          The (M-Q)-by-(M-Q) unitary matrix V2T.
!>
[in]LDV2T
!>          LDV2T is INTEGER
!>          The leading dimension of the array V2T. LDV2T >=
!>          max(1,M-Q).
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension MIN(P,M-P,Q,M-Q)
!>          The CS values of X; the essentially diagonal matrices C and
!>          S are constructed from THETA; see subroutine ZUNCSD for
!>          details.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (M)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (15)
!>          The test ratios:
!>          First, the 2-by-2 CSD:
!>          RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
!>          RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 )
!>          RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
!>          RESULT(4) = norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 )
!>          RESULT(5) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
!>          RESULT(6) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
!>          RESULT(7) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
!>          RESULT(8) = norm( I - V2T'*V2T ) / ( MAX(1,M-Q)*ULP )
!>          RESULT(9) = 0        if THETA is in increasing order and
!>                               all angles are in [0,pi/2] 

!>                    = ULPINV   otherwise.
!>          Then, the 2-by-1 CSD:
!>          RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
!>          RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
!>          RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
!>          RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
!>          RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
!>          RESULT(15) = 0        if THETA is in increasing order and
!>                                all angles are in [0,pi/2] 

!>                     = ULPINV   otherwise.
!>          ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 226 of file zcsdts.f.

229*
230* -- LAPACK test routine --
231* -- LAPACK is a software package provided by Univ. of Tennessee, --
232* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
233*
234* .. Scalar Arguments ..
235 INTEGER LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q
236* ..
237* .. Array Arguments ..
238 INTEGER IWORK( * )
239 DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * )
240 COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
241 $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
242 $ XF( LDX, * )
243* ..
244*
245* =====================================================================
246*
247* .. Parameters ..
248 DOUBLE PRECISION REALONE, REALZERO
249 parameter( realone = 1.0d0, realzero = 0.0d0 )
250 COMPLEX*16 ZERO, ONE
251 parameter( zero = (0.0d0,0.0d0), one = (1.0d0,0.0d0) )
252 DOUBLE PRECISION PIOVER2
253 parameter( piover2 = 1.57079632679489661923132169163975144210d0 )
254* ..
255* .. Local Scalars ..
256 INTEGER I, INFO, R
257 DOUBLE PRECISION EPS2, RESID, ULP, ULPINV
258* ..
259* .. External Functions ..
260 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHE
261 EXTERNAL dlamch, zlange, zlanhe
262* ..
263* .. External Subroutines ..
264 EXTERNAL zgemm, zherk, zlacpy, zlaset, zuncsd,
265 $ zuncsd2by1
266* ..
267* .. Intrinsic Functions ..
268 INTRINSIC cos, dble, dcmplx, max, min, real, sin
269* ..
270* .. Executable Statements ..
271*
272 ulp = dlamch( 'Precision' )
273 ulpinv = realone / ulp
274*
275* The first half of the routine checks the 2-by-2 CSD
276*
277 CALL zlaset( 'Full', m, m, zero, one, work, ldx )
278 CALL zherk( 'Upper', 'Conjugate transpose', m, m, -realone,
279 $ x, ldx, realone, work, ldx )
280 IF (m.GT.0) THEN
281 eps2 = max( ulp,
282 $ zlange( '1', m, m, work, ldx, rwork ) / dble( m ) )
283 ELSE
284 eps2 = ulp
285 END IF
286 r = min( p, m-p, q, m-q )
287*
288* Copy the matrix X to the array XF.
289*
290 CALL zlacpy( 'Full', m, m, x, ldx, xf, ldx )
291*
292* Compute the CSD
293*
294 CALL zuncsd( 'Y', 'Y', 'Y', 'Y', 'N', 'D', m, p, q, xf(1,1), ldx,
295 $ xf(1,q+1), ldx, xf(p+1,1), ldx, xf(p+1,q+1), ldx,
296 $ theta, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t,
297 $ work, lwork, rwork, 17*(r+2), iwork, info )
298*
299* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
300*
301 CALL zlacpy( 'Full', m, m, x, ldx, xf, ldx )
302*
303 CALL zgemm( 'No transpose', 'Conjugate transpose', p, q, q, one,
304 $ xf, ldx, v1t, ldv1t, zero, work, ldx )
305*
306 CALL zgemm( 'Conjugate transpose', 'No transpose', p, q, p, one,
307 $ u1, ldu1, work, ldx, zero, xf, ldx )
308*
309 DO i = 1, min(p,q)-r
310 xf(i,i) = xf(i,i) - one
311 END DO
312 DO i = 1, r
313 xf(min(p,q)-r+i,min(p,q)-r+i) =
314 $ xf(min(p,q)-r+i,min(p,q)-r+i) - dcmplx( cos(theta(i)),
315 $ 0.0d0 )
316 END DO
317*
318 CALL zgemm( 'No transpose', 'Conjugate transpose', p, m-q, m-q,
319 $ one, xf(1,q+1), ldx, v2t, ldv2t, zero, work, ldx )
320*
321 CALL zgemm( 'Conjugate transpose', 'No transpose', p, m-q, p,
322 $ one, u1, ldu1, work, ldx, zero, xf(1,q+1), ldx )
323*
324 DO i = 1, min(p,m-q)-r
325 xf(p-i+1,m-i+1) = xf(p-i+1,m-i+1) + one
326 END DO
327 DO i = 1, r
328 xf(p-(min(p,m-q)-r)+1-i,m-(min(p,m-q)-r)+1-i) =
329 $ xf(p-(min(p,m-q)-r)+1-i,m-(min(p,m-q)-r)+1-i) +
330 $ dcmplx( sin(theta(r-i+1)), 0.0d0 )
331 END DO
332*
333 CALL zgemm( 'No transpose', 'Conjugate transpose', m-p, q, q, one,
334 $ xf(p+1,1), ldx, v1t, ldv1t, zero, work, ldx )
335*
336 CALL zgemm( 'Conjugate transpose', 'No transpose', m-p, q, m-p,
337 $ one, u2, ldu2, work, ldx, zero, xf(p+1,1), ldx )
338*
339 DO i = 1, min(m-p,q)-r
340 xf(m-i+1,q-i+1) = xf(m-i+1,q-i+1) - one
341 END DO
342 DO i = 1, r
343 xf(m-(min(m-p,q)-r)+1-i,q-(min(m-p,q)-r)+1-i) =
344 $ xf(m-(min(m-p,q)-r)+1-i,q-(min(m-p,q)-r)+1-i) -
345 $ dcmplx( sin(theta(r-i+1)), 0.0d0 )
346 END DO
347*
348 CALL zgemm( 'No transpose', 'Conjugate transpose', m-p, m-q, m-q,
349 $ one, xf(p+1,q+1), ldx, v2t, ldv2t, zero, work, ldx )
350*
351 CALL zgemm( 'Conjugate transpose', 'No transpose', m-p, m-q, m-p,
352 $ one, u2, ldu2, work, ldx, zero, xf(p+1,q+1), ldx )
353*
354 DO i = 1, min(m-p,m-q)-r
355 xf(p+i,q+i) = xf(p+i,q+i) - one
356 END DO
357 DO i = 1, r
358 xf(p+(min(m-p,m-q)-r)+i,q+(min(m-p,m-q)-r)+i) =
359 $ xf(p+(min(m-p,m-q)-r)+i,q+(min(m-p,m-q)-r)+i) -
360 $ dcmplx( cos(theta(i)), 0.0d0 )
361 END DO
362*
363* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
364*
365 resid = zlange( '1', p, q, xf, ldx, rwork )
366 result( 1 ) = ( resid / real(max(1,p,q)) ) / eps2
367*
368* Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
369*
370 resid = zlange( '1', p, m-q, xf(1,q+1), ldx, rwork )
371 result( 2 ) = ( resid / real(max(1,p,m-q)) ) / eps2
372*
373* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
374*
375 resid = zlange( '1', m-p, q, xf(p+1,1), ldx, rwork )
376 result( 3 ) = ( resid / real(max(1,m-p,q)) ) / eps2
377*
378* Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
379*
380 resid = zlange( '1', m-p, m-q, xf(p+1,q+1), ldx, rwork )
381 result( 4 ) = ( resid / real(max(1,m-p,m-q)) ) / eps2
382*
383* Compute I - U1'*U1
384*
385 CALL zlaset( 'Full', p, p, zero, one, work, ldu1 )
386 CALL zherk( 'Upper', 'Conjugate transpose', p, p, -realone,
387 $ u1, ldu1, realone, work, ldu1 )
388*
389* Compute norm( I - U'*U ) / ( MAX(1,P) * ULP ) .
390*
391 resid = zlanhe( '1', 'Upper', p, work, ldu1, rwork )
392 result( 5 ) = ( resid / real(max(1,p)) ) / ulp
393*
394* Compute I - U2'*U2
395*
396 CALL zlaset( 'Full', m-p, m-p, zero, one, work, ldu2 )
397 CALL zherk( 'Upper', 'Conjugate transpose', m-p, m-p, -realone,
398 $ u2, ldu2, realone, work, ldu2 )
399*
400* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
401*
402 resid = zlanhe( '1', 'Upper', m-p, work, ldu2, rwork )
403 result( 6 ) = ( resid / real(max(1,m-p)) ) / ulp
404*
405* Compute I - V1T*V1T'
406*
407 CALL zlaset( 'Full', q, q, zero, one, work, ldv1t )
408 CALL zherk( 'Upper', 'No transpose', q, q, -realone,
409 $ v1t, ldv1t, realone, work, ldv1t )
410*
411* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
412*
413 resid = zlanhe( '1', 'Upper', q, work, ldv1t, rwork )
414 result( 7 ) = ( resid / real(max(1,q)) ) / ulp
415*
416* Compute I - V2T*V2T'
417*
418 CALL zlaset( 'Full', m-q, m-q, zero, one, work, ldv2t )
419 CALL zherk( 'Upper', 'No transpose', m-q, m-q, -realone,
420 $ v2t, ldv2t, realone, work, ldv2t )
421*
422* Compute norm( I - V2T*V2T' ) / ( MAX(1,M-Q) * ULP ) .
423*
424 resid = zlanhe( '1', 'Upper', m-q, work, ldv2t, rwork )
425 result( 8 ) = ( resid / real(max(1,m-q)) ) / ulp
426*
427* Check sorting
428*
429 result( 9 ) = realzero
430 DO i = 1, r
431 IF( theta(i).LT.realzero .OR. theta(i).GT.piover2 ) THEN
432 result( 9 ) = ulpinv
433 END IF
434 IF( i.GT.1) THEN
435 IF ( theta(i).LT.theta(i-1) ) THEN
436 result( 9 ) = ulpinv
437 END IF
438 END IF
439 END DO
440*
441* The second half of the routine checks the 2-by-1 CSD
442*
443 CALL zlaset( 'Full', q, q, zero, one, work, ldx )
444 CALL zherk( 'Upper', 'Conjugate transpose', q, m, -realone,
445 $ x, ldx, realone, work, ldx )
446 IF (m.GT.0) THEN
447 eps2 = max( ulp,
448 $ zlange( '1', q, q, work, ldx, rwork ) / dble( m ) )
449 ELSE
450 eps2 = ulp
451 END IF
452 r = min( p, m-p, q, m-q )
453*
454* Copy the matrix X to the array XF.
455*
456 CALL zlacpy( 'Full', m, m, x, ldx, xf, ldx )
457*
458* Compute the CSD
459*
460 CALL zuncsd2by1( 'Y', 'Y', 'Y', m, p, q, xf(1,1), ldx, xf(p+1,1),
461 $ ldx, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work,
462 $ lwork, rwork, 17*(r+2), iwork, info )
463*
464* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21]
465*
466 CALL zgemm( 'No transpose', 'Conjugate transpose', p, q, q, one,
467 $ x, ldx, v1t, ldv1t, zero, work, ldx )
468*
469 CALL zgemm( 'Conjugate transpose', 'No transpose', p, q, p, one,
470 $ u1, ldu1, work, ldx, zero, x, ldx )
471*
472 DO i = 1, min(p,q)-r
473 x(i,i) = x(i,i) - one
474 END DO
475 DO i = 1, r
476 x(min(p,q)-r+i,min(p,q)-r+i) =
477 $ x(min(p,q)-r+i,min(p,q)-r+i) - dcmplx( cos(theta(i)),
478 $ 0.0d0 )
479 END DO
480*
481 CALL zgemm( 'No transpose', 'Conjugate transpose', m-p, q, q, one,
482 $ x(p+1,1), ldx, v1t, ldv1t, zero, work, ldx )
483*
484 CALL zgemm( 'Conjugate transpose', 'No transpose', m-p, q, m-p,
485 $ one, u2, ldu2, work, ldx, zero, x(p+1,1), ldx )
486*
487 DO i = 1, min(m-p,q)-r
488 x(m-i+1,q-i+1) = x(m-i+1,q-i+1) - one
489 END DO
490 DO i = 1, r
491 x(m-(min(m-p,q)-r)+1-i,q-(min(m-p,q)-r)+1-i) =
492 $ x(m-(min(m-p,q)-r)+1-i,q-(min(m-p,q)-r)+1-i) -
493 $ dcmplx( sin(theta(r-i+1)), 0.0d0 )
494 END DO
495*
496* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
497*
498 resid = zlange( '1', p, q, x, ldx, rwork )
499 result( 10 ) = ( resid / real(max(1,p,q)) ) / eps2
500*
501* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
502*
503 resid = zlange( '1', m-p, q, x(p+1,1), ldx, rwork )
504 result( 11 ) = ( resid / real(max(1,m-p,q)) ) / eps2
505*
506* Compute I - U1'*U1
507*
508 CALL zlaset( 'Full', p, p, zero, one, work, ldu1 )
509 CALL zherk( 'Upper', 'Conjugate transpose', p, p, -realone,
510 $ u1, ldu1, realone, work, ldu1 )
511*
512* Compute norm( I - U'*U ) / ( MAX(1,P) * ULP ) .
513*
514 resid = zlanhe( '1', 'Upper', p, work, ldu1, rwork )
515 result( 12 ) = ( resid / real(max(1,p)) ) / ulp
516*
517* Compute I - U2'*U2
518*
519 CALL zlaset( 'Full', m-p, m-p, zero, one, work, ldu2 )
520 CALL zherk( 'Upper', 'Conjugate transpose', m-p, m-p, -realone,
521 $ u2, ldu2, realone, work, ldu2 )
522*
523* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
524*
525 resid = zlanhe( '1', 'Upper', m-p, work, ldu2, rwork )
526 result( 13 ) = ( resid / real(max(1,m-p)) ) / ulp
527*
528* Compute I - V1T*V1T'
529*
530 CALL zlaset( 'Full', q, q, zero, one, work, ldv1t )
531 CALL zherk( 'Upper', 'No transpose', q, q, -realone,
532 $ v1t, ldv1t, realone, work, ldv1t )
533*
534* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
535*
536 resid = zlanhe( '1', 'Upper', q, work, ldv1t, rwork )
537 result( 14 ) = ( resid / real(max(1,q)) ) / ulp
538*
539* Check sorting
540*
541 result( 15 ) = realzero
542 DO i = 1, r
543 IF( theta(i).LT.realzero .OR. theta(i).GT.piover2 ) THEN
544 result( 15 ) = ulpinv
545 END IF
546 IF( i.GT.1) THEN
547 IF ( theta(i).LT.theta(i-1) ) THEN
548 result( 15 ) = ulpinv
549 END IF
550 END IF
551 END DO
552*
553 RETURN
554*
555* End of ZCSDTS
556*
zlanhe
double precision function zlanhe(norm, uplo, n, a, lda, work)
ZLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanhe.f:124
zuncsd2by1
subroutine zuncsd2by1(jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, rwork, lrwork, iwork, info)
ZUNCSD2BY1
Definition zuncsd2by1.f:256
zuncsd
recursive subroutine zuncsd(jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, work, lwork, rwork, lrwork, iwork, info)
ZUNCSD
Definition zuncsd.f:320
zherk
subroutine zherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
ZHERK
Definition zherk.f:173

◆ zdrges()

subroutine zdrges ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) b,
complex*16, dimension( lda, * ) s,
complex*16, dimension( lda, * ) t,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldq, * ) z,
complex*16, dimension( * ) alpha,
complex*16, dimension( * ) beta,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( 13 ) result,
logical, dimension( * ) bwork,
integer info )

ZDRGES

Purpose:
!>
!> ZDRGES checks the nonsymmetric generalized eigenvalue (Schur form)
!> problem driver ZGGES.
!>
!> ZGGES factors A and B as Q*S*Z'  and Q*T*Z' , where ' means conjugate
!> transpose, S and T are  upper triangular (i.e., in generalized Schur
!> form), and Q and Z are unitary. It also computes the generalized
!> eigenvalues (alpha(j),beta(j)), j=1,...,n.  Thus,
!> w(j) = alpha(j)/beta(j) is a root of the characteristic equation
!>
!>                 det( A - w(j) B ) = 0
!>
!> Optionally it also reorder the eigenvalues so that a selected
!> cluster of eigenvalues appears in the leading diagonal block of the
!> Schur forms.
!>
!> When ZDRGES is called, a number of matrix  () and a
!> number of matrix  are specified.  For each size ()
!> and each TYPE of matrix, a pair of matrices (A, B) will be generated
!> and used for testing. For each matrix pair, the following 13 tests
!> will be performed and compared with the threshold THRESH except
!> the tests (5), (11) and (13).
!>
!>
!> (1)   | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues)
!>
!>
!> (2)   | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues)
!>
!>
!> (3)   | I - QQ' | / ( n ulp ) (no sorting of eigenvalues)
!>
!>
!> (4)   | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues)
!>
!> (5)   if A is in Schur form (i.e. triangular form) (no sorting of
!>       eigenvalues)
!>
!> (6)   if eigenvalues = diagonal elements of the Schur form (S, T),
!>       i.e., test the maximum over j of D(j)  where:
!>
!>                     |alpha(j) - S(j,j)|        |beta(j) - T(j,j)|
!>           D(j) = ------------------------ + -----------------------
!>                  max(|alpha(j)|,|S(j,j)|)   max(|beta(j)|,|T(j,j)|)
!>
!>       (no sorting of eigenvalues)
!>
!> (7)   | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp )
!>       (with sorting of eigenvalues).
!>
!> (8)   | I - QQ' | / ( n ulp ) (with sorting of eigenvalues).
!>
!> (9)   | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues).
!>
!> (10)  if A is in Schur form (i.e. quasi-triangular form)
!>       (with sorting of eigenvalues).
!>
!> (11)  if eigenvalues = diagonal elements of the Schur form (S, T),
!>       i.e. test the maximum over j of D(j)  where:
!>
!>                     |alpha(j) - S(j,j)|        |beta(j) - T(j,j)|
!>           D(j) = ------------------------ + -----------------------
!>                  max(|alpha(j)|,|S(j,j)|)   max(|beta(j)|,|T(j,j)|)
!>
!>       (with sorting of eigenvalues).
!>
!> (12)  if sorting worked and SDIM is the number of eigenvalues
!>       which were CELECTed.
!>
!> Test Matrices
!> =============
!>
!> The sizes of the test matrices are specified by an array
!> NN(1:NSIZES); the value of each element NN(j) specifies one size.
!> The  are specified by a logical array DOTYPE( 1:NTYPES ); if
!> DOTYPE(j) is .TRUE., then matrix type  will be generated.
!> Currently, the list of possible types is:
!>
!> (1)  ( 0, 0 )         (a pair of zero matrices)
!>
!> (2)  ( I, 0 )         (an identity and a zero matrix)
!>
!> (3)  ( 0, I )         (an identity and a zero matrix)
!>
!> (4)  ( I, I )         (a pair of identity matrices)
!>
!>         t   t
!> (5)  ( J , J  )       (a pair of transposed Jordan blocks)
!>
!>                                     t                ( I   0  )
!> (6)  ( X, Y )         where  X = ( J   0  )  and Y = (      t )
!>                                  ( 0   I  )          ( 0   J  )
!>                       and I is a k x k identity and J a (k+1)x(k+1)
!>                       Jordan block; k=(N-1)/2
!>
!> (7)  ( D, I )         where D is diag( 0, 1,..., N-1 ) (a diagonal
!>                       matrix with those diagonal entries.)
!> (8)  ( I, D )
!>
!> (9)  ( big*D, small*I ) where  is near overflow and small=1/big
!>
!> (10) ( small*D, big*I )
!>
!> (11) ( big*I, small*D )
!>
!> (12) ( small*I, big*D )
!>
!> (13) ( big*D, big*I )
!>
!> (14) ( small*D, small*I )
!>
!> (15) ( D1, D2 )        where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
!>                        D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
!>           t   t
!> (16) Q ( J , J ) Z     where Q and Z are random orthogonal matrices.
!>
!> (17) Q ( T1, T2 ) Z    where T1 and T2 are upper triangular matrices
!>                        with random O(1) entries above the diagonal
!>                        and diagonal entries diag(T1) =
!>                        ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
!>                        ( 0, N-3, N-4,..., 1, 0, 0 )
!>
!> (18) Q ( T1, T2 ) Z    diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
!>                        s = machine precision.
!>
!> (19) Q ( T1, T2 ) Z    diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
!>
!>                                                        N-5
!> (20) Q ( T1, T2 ) Z    diag(T1)=( 0, 0, 1, 1, a, ..., a   =s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
!>
!> (21) Q ( T1, T2 ) Z    diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
!>                        where r1,..., r(N-4) are random.
!>
!> (22) Q ( big*T1, small*T2 ) Z    diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (23) Q ( small*T1, big*T2 ) Z    diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (24) Q ( small*T1, small*T2 ) Z  diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (25) Q ( big*T1, big*T2 ) Z      diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (26) Q ( T1, T2 ) Z     where T1 and T2 are random upper-triangular
!>                         matrices.
!>
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          DDRGES does nothing.  NSIZES >= 0.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  NN >= 0.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, DDRGES
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A on input.
!>          This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated. If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096. Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to DDRGES to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error is
!>          scaled to be O(1), so THRESH should be a reasonably small
!>          multiple of 1, e.g., 10 or 100.  In particular, it should
!>          not depend on the precision (single vs. double) or the size
!>          of the matrix.  THRESH >= 0.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension(LDA, max(NN))
!>          Used to hold the original A matrix.  Used as input only
!>          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
!>          DOTYPE(MAXTYP+1)=.TRUE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, B, S, and T.
!>          It must be at least 1 and at least max( NN ).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension(LDA, max(NN))
!>          Used to hold the original B matrix.  Used as input only
!>          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
!>          DOTYPE(MAXTYP+1)=.TRUE.
!>
[out]S
!>          S is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The Schur form matrix computed from A by ZGGES.  On exit, S
!>          contains the Schur form matrix corresponding to the matrix
!>          in A.
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by ZGGES.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ, max(NN))
!>          The (left) orthogonal matrix computed by ZGGES.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of Q and Z. It must
!>          be at least 1 and at least max( NN ).
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension( LDQ, max(NN) )
!>          The (right) orthogonal matrix computed by ZGGES.
!>
[out]ALPHA
!>          ALPHA is COMPLEX*16 array, dimension (max(NN))
!>
[out]BETA
!>          BETA is COMPLEX*16 array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by ZGGES.
!>          ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A
!>          and B.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= 3*N*N.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension ( 8*N )
!>          Real workspace.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (15)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]BWORK
!>          BWORK is LOGICAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  A routine returned an error code.  INFO is the
!>                absolute value of the INFO value returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 378 of file zdrges.f.

381*
382* -- LAPACK test routine --
383* -- LAPACK is a software package provided by Univ. of Tennessee, --
384* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
385*
386* .. Scalar Arguments ..
387 INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
388 DOUBLE PRECISION THRESH
389* ..
390* .. Array Arguments ..
391 LOGICAL BWORK( * ), DOTYPE( * )
392 INTEGER ISEED( 4 ), NN( * )
393 DOUBLE PRECISION RESULT( 13 ), RWORK( * )
394 COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDA, * ),
395 $ BETA( * ), Q( LDQ, * ), S( LDA, * ),
396 $ T( LDA, * ), WORK( * ), Z( LDQ, * )
397* ..
398*
399* =====================================================================
400*
401* .. Parameters ..
402 DOUBLE PRECISION ZERO, ONE
403 parameter( zero = 0.0d+0, one = 1.0d+0 )
404 COMPLEX*16 CZERO, CONE
405 parameter( czero = ( 0.0d+0, 0.0d+0 ),
406 $ cone = ( 1.0d+0, 0.0d+0 ) )
407 INTEGER MAXTYP
408 parameter( maxtyp = 26 )
409* ..
410* .. Local Scalars ..
411 LOGICAL BADNN, ILABAD
412 CHARACTER SORT
413 INTEGER I, IADD, IINFO, IN, ISORT, J, JC, JR, JSIZE,
414 $ JTYPE, KNTEIG, MAXWRK, MINWRK, MTYPES, N, N1,
415 $ NB, NERRS, NMATS, NMAX, NTEST, NTESTT, RSUB,
416 $ SDIM
417 DOUBLE PRECISION SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
418 COMPLEX*16 CTEMP, X
419* ..
420* .. Local Arrays ..
421 LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP )
422 INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
423 $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
424 $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
425 $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
426 $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
427 DOUBLE PRECISION RMAGN( 0: 3 )
428* ..
429* .. External Functions ..
430 LOGICAL ZLCTES
431 INTEGER ILAENV
432 DOUBLE PRECISION DLAMCH
433 COMPLEX*16 ZLARND
434 EXTERNAL zlctes, ilaenv, dlamch, zlarnd
435* ..
436* .. External Subroutines ..
437 EXTERNAL alasvm, dlabad, xerbla, zget51, zget54, zgges,
438 $ zlacpy, zlarfg, zlaset, zlatm4, zunm2r
439* ..
440* .. Intrinsic Functions ..
441 INTRINSIC abs, dble, dconjg, dimag, max, min, sign
442* ..
443* .. Statement Functions ..
444 DOUBLE PRECISION ABS1
445* ..
446* .. Statement Function definitions ..
447 abs1( x ) = abs( dble( x ) ) + abs( dimag( x ) )
448* ..
449* .. Data statements ..
450 DATA kclass / 15*1, 10*2, 1*3 /
451 DATA kz1 / 0, 1, 2, 1, 3, 3 /
452 DATA kz2 / 0, 0, 1, 2, 1, 1 /
453 DATA kadd / 0, 0, 0, 0, 3, 2 /
454 DATA katype / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
455 $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
456 DATA kbtype / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
457 $ 1, 1, -4, 2, -4, 8*8, 0 /
458 DATA kazero / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
459 $ 4*5, 4*3, 1 /
460 DATA kbzero / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
461 $ 4*6, 4*4, 1 /
462 DATA kamagn / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
463 $ 2, 1 /
464 DATA kbmagn / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
465 $ 2, 1 /
466 DATA ktrian / 16*0, 10*1 /
467 DATA lasign / 6*.false., .true., .false., 2*.true.,
468 $ 2*.false., 3*.true., .false., .true.,
469 $ 3*.false., 5*.true., .false. /
470 DATA lbsign / 7*.false., .true., 2*.false.,
471 $ 2*.true., 2*.false., .true., .false., .true.,
472 $ 9*.false. /
473* ..
474* .. Executable Statements ..
475*
476* Check for errors
477*
478 info = 0
479*
480 badnn = .false.
481 nmax = 1
482 DO 10 j = 1, nsizes
483 nmax = max( nmax, nn( j ) )
484 IF( nn( j ).LT.0 )
485 $ badnn = .true.
486 10 CONTINUE
487*
488 IF( nsizes.LT.0 ) THEN
489 info = -1
490 ELSE IF( badnn ) THEN
491 info = -2
492 ELSE IF( ntypes.LT.0 ) THEN
493 info = -3
494 ELSE IF( thresh.LT.zero ) THEN
495 info = -6
496 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
497 info = -9
498 ELSE IF( ldq.LE.1 .OR. ldq.LT.nmax ) THEN
499 info = -14
500 END IF
501*
502* Compute workspace
503* (Note: Comments in the code beginning "Workspace:" describe the
504* minimal amount of workspace needed at that point in the code,
505* as well as the preferred amount for good performance.
506* NB refers to the optimal block size for the immediately
507* following subroutine, as returned by ILAENV.
508*
509 minwrk = 1
510 IF( info.EQ.0 .AND. lwork.GE.1 ) THEN
511 minwrk = 3*nmax*nmax
512 nb = max( 1, ilaenv( 1, 'ZGEQRF', ' ', nmax, nmax, -1, -1 ),
513 $ ilaenv( 1, 'ZUNMQR', 'LC', nmax, nmax, nmax, -1 ),
514 $ ilaenv( 1, 'ZUNGQR', ' ', nmax, nmax, nmax, -1 ) )
515 maxwrk = max( nmax+nmax*nb, 3*nmax*nmax )
516 work( 1 ) = maxwrk
517 END IF
518*
519 IF( lwork.LT.minwrk )
520 $ info = -19
521*
522 IF( info.NE.0 ) THEN
523 CALL xerbla( 'ZDRGES', -info )
524 RETURN
525 END IF
526*
527* Quick return if possible
528*
529 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
530 $ RETURN
531*
532 ulp = dlamch( 'Precision' )
533 safmin = dlamch( 'Safe minimum' )
534 safmin = safmin / ulp
535 safmax = one / safmin
536 CALL dlabad( safmin, safmax )
537 ulpinv = one / ulp
538*
539* The values RMAGN(2:3) depend on N, see below.
540*
541 rmagn( 0 ) = zero
542 rmagn( 1 ) = one
543*
544* Loop over matrix sizes
545*
546 ntestt = 0
547 nerrs = 0
548 nmats = 0
549*
550 DO 190 jsize = 1, nsizes
551 n = nn( jsize )
552 n1 = max( 1, n )
553 rmagn( 2 ) = safmax*ulp / dble( n1 )
554 rmagn( 3 ) = safmin*ulpinv*dble( n1 )
555*
556 IF( nsizes.NE.1 ) THEN
557 mtypes = min( maxtyp, ntypes )
558 ELSE
559 mtypes = min( maxtyp+1, ntypes )
560 END IF
561*
562* Loop over matrix types
563*
564 DO 180 jtype = 1, mtypes
565 IF( .NOT.dotype( jtype ) )
566 $ GO TO 180
567 nmats = nmats + 1
568 ntest = 0
569*
570* Save ISEED in case of an error.
571*
572 DO 20 j = 1, 4
573 ioldsd( j ) = iseed( j )
574 20 CONTINUE
575*
576* Initialize RESULT
577*
578 DO 30 j = 1, 13
579 result( j ) = zero
580 30 CONTINUE
581*
582* Generate test matrices A and B
583*
584* Description of control parameters:
585*
586* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
587* =3 means random.
588* KATYPE: the "type" to be passed to ZLATM4 for computing A.
589* KAZERO: the pattern of zeros on the diagonal for A:
590* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
591* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
592* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
593* non-zero entries.)
594* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
595* =2: large, =3: small.
596* LASIGN: .TRUE. if the diagonal elements of A are to be
597* multiplied by a random magnitude 1 number.
598* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B.
599* KTRIAN: =0: don't fill in the upper triangle, =1: do.
600* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
601* RMAGN: used to implement KAMAGN and KBMAGN.
602*
603 IF( mtypes.GT.maxtyp )
604 $ GO TO 110
605 iinfo = 0
606 IF( kclass( jtype ).LT.3 ) THEN
607*
608* Generate A (w/o rotation)
609*
610 IF( abs( katype( jtype ) ).EQ.3 ) THEN
611 in = 2*( ( n-1 ) / 2 ) + 1
612 IF( in.NE.n )
613 $ CALL zlaset( 'Full', n, n, czero, czero, a, lda )
614 ELSE
615 in = n
616 END IF
617 CALL zlatm4( katype( jtype ), in, kz1( kazero( jtype ) ),
618 $ kz2( kazero( jtype ) ), lasign( jtype ),
619 $ rmagn( kamagn( jtype ) ), ulp,
620 $ rmagn( ktrian( jtype )*kamagn( jtype ) ), 2,
621 $ iseed, a, lda )
622 iadd = kadd( kazero( jtype ) )
623 IF( iadd.GT.0 .AND. iadd.LE.n )
624 $ a( iadd, iadd ) = rmagn( kamagn( jtype ) )
625*
626* Generate B (w/o rotation)
627*
628 IF( abs( kbtype( jtype ) ).EQ.3 ) THEN
629 in = 2*( ( n-1 ) / 2 ) + 1
630 IF( in.NE.n )
631 $ CALL zlaset( 'Full', n, n, czero, czero, b, lda )
632 ELSE
633 in = n
634 END IF
635 CALL zlatm4( kbtype( jtype ), in, kz1( kbzero( jtype ) ),
636 $ kz2( kbzero( jtype ) ), lbsign( jtype ),
637 $ rmagn( kbmagn( jtype ) ), one,
638 $ rmagn( ktrian( jtype )*kbmagn( jtype ) ), 2,
639 $ iseed, b, lda )
640 iadd = kadd( kbzero( jtype ) )
641 IF( iadd.NE.0 .AND. iadd.LE.n )
642 $ b( iadd, iadd ) = rmagn( kbmagn( jtype ) )
643*
644 IF( kclass( jtype ).EQ.2 .AND. n.GT.0 ) THEN
645*
646* Include rotations
647*
648* Generate Q, Z as Householder transformations times
649* a diagonal matrix.
650*
651 DO 50 jc = 1, n - 1
652 DO 40 jr = jc, n
653 q( jr, jc ) = zlarnd( 3, iseed )
654 z( jr, jc ) = zlarnd( 3, iseed )
655 40 CONTINUE
656 CALL zlarfg( n+1-jc, q( jc, jc ), q( jc+1, jc ), 1,
657 $ work( jc ) )
658 work( 2*n+jc ) = sign( one, dble( q( jc, jc ) ) )
659 q( jc, jc ) = cone
660 CALL zlarfg( n+1-jc, z( jc, jc ), z( jc+1, jc ), 1,
661 $ work( n+jc ) )
662 work( 3*n+jc ) = sign( one, dble( z( jc, jc ) ) )
663 z( jc, jc ) = cone
664 50 CONTINUE
665 ctemp = zlarnd( 3, iseed )
666 q( n, n ) = cone
667 work( n ) = czero
668 work( 3*n ) = ctemp / abs( ctemp )
669 ctemp = zlarnd( 3, iseed )
670 z( n, n ) = cone
671 work( 2*n ) = czero
672 work( 4*n ) = ctemp / abs( ctemp )
673*
674* Apply the diagonal matrices
675*
676 DO 70 jc = 1, n
677 DO 60 jr = 1, n
678 a( jr, jc ) = work( 2*n+jr )*
679 $ dconjg( work( 3*n+jc ) )*
680 $ a( jr, jc )
681 b( jr, jc ) = work( 2*n+jr )*
682 $ dconjg( work( 3*n+jc ) )*
683 $ b( jr, jc )
684 60 CONTINUE
685 70 CONTINUE
686 CALL zunm2r( 'L', 'N', n, n, n-1, q, ldq, work, a,
687 $ lda, work( 2*n+1 ), iinfo )
688 IF( iinfo.NE.0 )
689 $ GO TO 100
690 CALL zunm2r( 'R', 'C', n, n, n-1, z, ldq, work( n+1 ),
691 $ a, lda, work( 2*n+1 ), iinfo )
692 IF( iinfo.NE.0 )
693 $ GO TO 100
694 CALL zunm2r( 'L', 'N', n, n, n-1, q, ldq, work, b,
695 $ lda, work( 2*n+1 ), iinfo )
696 IF( iinfo.NE.0 )
697 $ GO TO 100
698 CALL zunm2r( 'R', 'C', n, n, n-1, z, ldq, work( n+1 ),
699 $ b, lda, work( 2*n+1 ), iinfo )
700 IF( iinfo.NE.0 )
701 $ GO TO 100
702 END IF
703 ELSE
704*
705* Random matrices
706*
707 DO 90 jc = 1, n
708 DO 80 jr = 1, n
709 a( jr, jc ) = rmagn( kamagn( jtype ) )*
710 $ zlarnd( 4, iseed )
711 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
712 $ zlarnd( 4, iseed )
713 80 CONTINUE
714 90 CONTINUE
715 END IF
716*
717 100 CONTINUE
718*
719 IF( iinfo.NE.0 ) THEN
720 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
721 $ ioldsd
722 info = abs( iinfo )
723 RETURN
724 END IF
725*
726 110 CONTINUE
727*
728 DO 120 i = 1, 13
729 result( i ) = -one
730 120 CONTINUE
731*
732* Test with and without sorting of eigenvalues
733*
734 DO 150 isort = 0, 1
735 IF( isort.EQ.0 ) THEN
736 sort = 'N'
737 rsub = 0
738 ELSE
739 sort = 'S'
740 rsub = 5
741 END IF
742*
743* Call ZGGES to compute H, T, Q, Z, alpha, and beta.
744*
745 CALL zlacpy( 'Full', n, n, a, lda, s, lda )
746 CALL zlacpy( 'Full', n, n, b, lda, t, lda )
747 ntest = 1 + rsub + isort
748 result( 1+rsub+isort ) = ulpinv
749 CALL zgges( 'V', 'V', sort, zlctes, n, s, lda, t, lda,
750 $ sdim, alpha, beta, q, ldq, z, ldq, work,
751 $ lwork, rwork, bwork, iinfo )
752 IF( iinfo.NE.0 .AND. iinfo.NE.n+2 ) THEN
753 result( 1+rsub+isort ) = ulpinv
754 WRITE( nounit, fmt = 9999 )'ZGGES', iinfo, n, jtype,
755 $ ioldsd
756 info = abs( iinfo )
757 GO TO 160
758 END IF
759*
760 ntest = 4 + rsub
761*
762* Do tests 1--4 (or tests 7--9 when reordering )
763*
764 IF( isort.EQ.0 ) THEN
765 CALL zget51( 1, n, a, lda, s, lda, q, ldq, z, ldq,
766 $ work, rwork, result( 1 ) )
767 CALL zget51( 1, n, b, lda, t, lda, q, ldq, z, ldq,
768 $ work, rwork, result( 2 ) )
769 ELSE
770 CALL zget54( n, a, lda, b, lda, s, lda, t, lda, q,
771 $ ldq, z, ldq, work, result( 2+rsub ) )
772 END IF
773*
774 CALL zget51( 3, n, b, lda, t, lda, q, ldq, q, ldq, work,
775 $ rwork, result( 3+rsub ) )
776 CALL zget51( 3, n, b, lda, t, lda, z, ldq, z, ldq, work,
777 $ rwork, result( 4+rsub ) )
778*
779* Do test 5 and 6 (or Tests 10 and 11 when reordering):
780* check Schur form of A and compare eigenvalues with
781* diagonals.
782*
783 ntest = 6 + rsub
784 temp1 = zero
785*
786 DO 130 j = 1, n
787 ilabad = .false.
788 temp2 = ( abs1( alpha( j )-s( j, j ) ) /
789 $ max( safmin, abs1( alpha( j ) ), abs1( s( j,
790 $ j ) ) )+abs1( beta( j )-t( j, j ) ) /
791 $ max( safmin, abs1( beta( j ) ), abs1( t( j,
792 $ j ) ) ) ) / ulp
793*
794 IF( j.LT.n ) THEN
795 IF( s( j+1, j ).NE.zero ) THEN
796 ilabad = .true.
797 result( 5+rsub ) = ulpinv
798 END IF
799 END IF
800 IF( j.GT.1 ) THEN
801 IF( s( j, j-1 ).NE.zero ) THEN
802 ilabad = .true.
803 result( 5+rsub ) = ulpinv
804 END IF
805 END IF
806 temp1 = max( temp1, temp2 )
807 IF( ilabad ) THEN
808 WRITE( nounit, fmt = 9998 )j, n, jtype, ioldsd
809 END IF
810 130 CONTINUE
811 result( 6+rsub ) = temp1
812*
813 IF( isort.GE.1 ) THEN
814*
815* Do test 12
816*
817 ntest = 12
818 result( 12 ) = zero
819 knteig = 0
820 DO 140 i = 1, n
821 IF( zlctes( alpha( i ), beta( i ) ) )
822 $ knteig = knteig + 1
823 140 CONTINUE
824 IF( sdim.NE.knteig )
825 $ result( 13 ) = ulpinv
826 END IF
827*
828 150 CONTINUE
829*
830* End of Loop -- Check for RESULT(j) > THRESH
831*
832 160 CONTINUE
833*
834 ntestt = ntestt + ntest
835*
836* Print out tests which fail.
837*
838 DO 170 jr = 1, ntest
839 IF( result( jr ).GE.thresh ) THEN
840*
841* If this is the first test to fail,
842* print a header to the data file.
843*
844 IF( nerrs.EQ.0 ) THEN
845 WRITE( nounit, fmt = 9997 )'ZGS'
846*
847* Matrix types
848*
849 WRITE( nounit, fmt = 9996 )
850 WRITE( nounit, fmt = 9995 )
851 WRITE( nounit, fmt = 9994 )'Unitary'
852*
853* Tests performed
854*
855 WRITE( nounit, fmt = 9993 )'unitary', '''',
856 $ 'transpose', ( '''', j = 1, 8 )
857*
858 END IF
859 nerrs = nerrs + 1
860 IF( result( jr ).LT.10000.0d0 ) THEN
861 WRITE( nounit, fmt = 9992 )n, jtype, ioldsd, jr,
862 $ result( jr )
863 ELSE
864 WRITE( nounit, fmt = 9991 )n, jtype, ioldsd, jr,
865 $ result( jr )
866 END IF
867 END IF
868 170 CONTINUE
869*
870 180 CONTINUE
871 190 CONTINUE
872*
873* Summary
874*
875 CALL alasvm( 'ZGS', nounit, nerrs, ntestt, 0 )
876*
877 work( 1 ) = maxwrk
878*
879 RETURN
880*
881 9999 FORMAT( ' ZDRGES: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
882 $ i6, ', JTYPE=', i6, ', ISEED=(', 4( i4, ',' ), i5, ')' )
883*
884 9998 FORMAT( ' ZDRGES: S not in Schur form at eigenvalue ', i6, '.',
885 $ / 9x, 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ),
886 $ i5, ')' )
887*
888 9997 FORMAT( / 1x, a3, ' -- Complex Generalized Schur from problem ',
889 $ 'driver' )
890*
891 9996 FORMAT( ' Matrix types (see ZDRGES for details): ' )
892*
893 9995 FORMAT( ' Special Matrices:', 23x,
894 $ '(J''=transposed Jordan block)',
895 $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
896 $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
897 $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
898 $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
899 $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
900 $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
901 9994 FORMAT( ' Matrices Rotated by Random ', a, ' Matrices U, V:',
902 $ / ' 16=Transposed Jordan Blocks 19=geometric ',
903 $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
904 $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
905 $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
906 $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
907 $ '23=(small,large) 24=(small,small) 25=(large,large)',
908 $ / ' 26=random O(1) matrices.' )
909*
910 9993 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
911 $ 'Q and Z are ', a, ',', / 19x,
912 $ 'l and r are the appropriate left and right', / 19x,
913 $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19x, a,
914 $ ' means ', a, '.)', / ' Without ordering: ',
915 $ / ' 1 = | A - Q S Z', a,
916 $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', a,
917 $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', a,
918 $ ' | / ( n ulp ) 4 = | I - ZZ', a,
919 $ ' | / ( n ulp )', / ' 5 = A is in Schur form S',
920 $ / ' 6 = difference between (alpha,beta)',
921 $ ' and diagonals of (S,T)', / ' With ordering: ',
922 $ / ' 7 = | (A,B) - Q (S,T) Z', a, ' | / ( |(A,B)| n ulp )',
923 $ / ' 8 = | I - QQ', a,
924 $ ' | / ( n ulp ) 9 = | I - ZZ', a,
925 $ ' | / ( n ulp )', / ' 10 = A is in Schur form S',
926 $ / ' 11 = difference between (alpha,beta) and diagonals',
927 $ ' of (S,T)', / ' 12 = SDIM is the correct number of ',
928 $ 'selected eigenvalues', / )
929 9992 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
930 $ 4( i4, ',' ), ' result ', i2, ' is', 0p, f8.2 )
931 9991 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
932 $ 4( i4, ',' ), ' result ', i2, ' is', 1p, d10.3 )
933*
934* End of ZDRGES
935*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
zgges
subroutine zgges(jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb, sdim, alpha, beta, vsl, ldvsl, vsr, ldvsr, work, lwork, rwork, bwork, info)
ZGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE m...
Definition zgges.f:270
zlctes
logical function zlctes(z, d)
ZLCTES
Definition zlctes.f:58
zget54
subroutine zget54(n, a, lda, b, ldb, s, lds, t, ldt, u, ldu, v, ldv, work, result)
ZGET54
Definition zget54.f:156

◆ zdrges3()

subroutine zdrges3 ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) b,
complex*16, dimension( lda, * ) s,
complex*16, dimension( lda, * ) t,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldq, * ) z,
complex*16, dimension( * ) alpha,
complex*16, dimension( * ) beta,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( 13 ) result,
logical, dimension( * ) bwork,
integer info )

ZDRGES3

Purpose:
!>
!> ZDRGES3 checks the nonsymmetric generalized eigenvalue (Schur form)
!> problem driver ZGGES3.
!>
!> ZGGES3 factors A and B as Q*S*Z'  and Q*T*Z' , where ' means conjugate
!> transpose, S and T are  upper triangular (i.e., in generalized Schur
!> form), and Q and Z are unitary. It also computes the generalized
!> eigenvalues (alpha(j),beta(j)), j=1,...,n.  Thus,
!> w(j) = alpha(j)/beta(j) is a root of the characteristic equation
!>
!>                 det( A - w(j) B ) = 0
!>
!> Optionally it also reorder the eigenvalues so that a selected
!> cluster of eigenvalues appears in the leading diagonal block of the
!> Schur forms.
!>
!> When ZDRGES3 is called, a number of matrix  () and a
!> number of matrix  are specified.  For each size ()
!> and each TYPE of matrix, a pair of matrices (A, B) will be generated
!> and used for testing. For each matrix pair, the following 13 tests
!> will be performed and compared with the threshold THRESH except
!> the tests (5), (11) and (13).
!>
!>
!> (1)   | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues)
!>
!>
!> (2)   | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues)
!>
!>
!> (3)   | I - QQ' | / ( n ulp ) (no sorting of eigenvalues)
!>
!>
!> (4)   | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues)
!>
!> (5)   if A is in Schur form (i.e. triangular form) (no sorting of
!>       eigenvalues)
!>
!> (6)   if eigenvalues = diagonal elements of the Schur form (S, T),
!>       i.e., test the maximum over j of D(j)  where:
!>
!>                     |alpha(j) - S(j,j)|        |beta(j) - T(j,j)|
!>           D(j) = ------------------------ + -----------------------
!>                  max(|alpha(j)|,|S(j,j)|)   max(|beta(j)|,|T(j,j)|)
!>
!>       (no sorting of eigenvalues)
!>
!> (7)   | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp )
!>       (with sorting of eigenvalues).
!>
!> (8)   | I - QQ' | / ( n ulp ) (with sorting of eigenvalues).
!>
!> (9)   | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues).
!>
!> (10)  if A is in Schur form (i.e. quasi-triangular form)
!>       (with sorting of eigenvalues).
!>
!> (11)  if eigenvalues = diagonal elements of the Schur form (S, T),
!>       i.e. test the maximum over j of D(j)  where:
!>
!>                     |alpha(j) - S(j,j)|        |beta(j) - T(j,j)|
!>           D(j) = ------------------------ + -----------------------
!>                  max(|alpha(j)|,|S(j,j)|)   max(|beta(j)|,|T(j,j)|)
!>
!>       (with sorting of eigenvalues).
!>
!> (12)  if sorting worked and SDIM is the number of eigenvalues
!>       which were CELECTed.
!>
!> Test Matrices
!> =============
!>
!> The sizes of the test matrices are specified by an array
!> NN(1:NSIZES); the value of each element NN(j) specifies one size.
!> The  are specified by a logical array DOTYPE( 1:NTYPES ); if
!> DOTYPE(j) is .TRUE., then matrix type  will be generated.
!> Currently, the list of possible types is:
!>
!> (1)  ( 0, 0 )         (a pair of zero matrices)
!>
!> (2)  ( I, 0 )         (an identity and a zero matrix)
!>
!> (3)  ( 0, I )         (an identity and a zero matrix)
!>
!> (4)  ( I, I )         (a pair of identity matrices)
!>
!>         t   t
!> (5)  ( J , J  )       (a pair of transposed Jordan blocks)
!>
!>                                     t                ( I   0  )
!> (6)  ( X, Y )         where  X = ( J   0  )  and Y = (      t )
!>                                  ( 0   I  )          ( 0   J  )
!>                       and I is a k x k identity and J a (k+1)x(k+1)
!>                       Jordan block; k=(N-1)/2
!>
!> (7)  ( D, I )         where D is diag( 0, 1,..., N-1 ) (a diagonal
!>                       matrix with those diagonal entries.)
!> (8)  ( I, D )
!>
!> (9)  ( big*D, small*I ) where  is near overflow and small=1/big
!>
!> (10) ( small*D, big*I )
!>
!> (11) ( big*I, small*D )
!>
!> (12) ( small*I, big*D )
!>
!> (13) ( big*D, big*I )
!>
!> (14) ( small*D, small*I )
!>
!> (15) ( D1, D2 )        where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
!>                        D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
!>           t   t
!> (16) Q ( J , J ) Z     where Q and Z are random orthogonal matrices.
!>
!> (17) Q ( T1, T2 ) Z    where T1 and T2 are upper triangular matrices
!>                        with random O(1) entries above the diagonal
!>                        and diagonal entries diag(T1) =
!>                        ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
!>                        ( 0, N-3, N-4,..., 1, 0, 0 )
!>
!> (18) Q ( T1, T2 ) Z    diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
!>                        s = machine precision.
!>
!> (19) Q ( T1, T2 ) Z    diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
!>
!>                                                        N-5
!> (20) Q ( T1, T2 ) Z    diag(T1)=( 0, 0, 1, 1, a, ..., a   =s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
!>
!> (21) Q ( T1, T2 ) Z    diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
!>                        where r1,..., r(N-4) are random.
!>
!> (22) Q ( big*T1, small*T2 ) Z    diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (23) Q ( small*T1, big*T2 ) Z    diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (24) Q ( small*T1, small*T2 ) Z  diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (25) Q ( big*T1, big*T2 ) Z      diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (26) Q ( T1, T2 ) Z     where T1 and T2 are random upper-triangular
!>                         matrices.
!>
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          DDRGES3 does nothing.  NSIZES >= 0.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  NN >= 0.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, DDRGES3
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A on input.
!>          This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated. If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096. Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to DDRGES3 to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error is
!>          scaled to be O(1), so THRESH should be a reasonably small
!>          multiple of 1, e.g., 10 or 100.  In particular, it should
!>          not depend on the precision (single vs. double) or the size
!>          of the matrix.  THRESH >= 0.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension(LDA, max(NN))
!>          Used to hold the original A matrix.  Used as input only
!>          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
!>          DOTYPE(MAXTYP+1)=.TRUE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, B, S, and T.
!>          It must be at least 1 and at least max( NN ).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension(LDA, max(NN))
!>          Used to hold the original B matrix.  Used as input only
!>          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
!>          DOTYPE(MAXTYP+1)=.TRUE.
!>
[out]S
!>          S is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The Schur form matrix computed from A by ZGGES3.  On exit, S
!>          contains the Schur form matrix corresponding to the matrix
!>          in A.
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by ZGGES3.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ, max(NN))
!>          The (left) orthogonal matrix computed by ZGGES3.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of Q and Z. It must
!>          be at least 1 and at least max( NN ).
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension( LDQ, max(NN) )
!>          The (right) orthogonal matrix computed by ZGGES3.
!>
[out]ALPHA
!>          ALPHA is COMPLEX*16 array, dimension (max(NN))
!>
[out]BETA
!>          BETA is COMPLEX*16 array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by ZGGES3.
!>          ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A
!>          and B.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= 3*N*N.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension ( 8*N )
!>          Real workspace.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (15)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]BWORK
!>          BWORK is LOGICAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  A routine returned an error code.  INFO is the
!>                absolute value of the INFO value returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 378 of file zdrges3.f.

382*
383* -- LAPACK test routine --
384* -- LAPACK is a software package provided by Univ. of Tennessee, --
385* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
386*
387* .. Scalar Arguments ..
388 INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
389 DOUBLE PRECISION THRESH
390* ..
391* .. Array Arguments ..
392 LOGICAL BWORK( * ), DOTYPE( * )
393 INTEGER ISEED( 4 ), NN( * )
394 DOUBLE PRECISION RESULT( 13 ), RWORK( * )
395 COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDA, * ),
396 $ BETA( * ), Q( LDQ, * ), S( LDA, * ),
397 $ T( LDA, * ), WORK( * ), Z( LDQ, * )
398* ..
399*
400* =====================================================================
401*
402* .. Parameters ..
403 DOUBLE PRECISION ZERO, ONE
404 parameter( zero = 0.0d+0, one = 1.0d+0 )
405 COMPLEX*16 CZERO, CONE
406 parameter( czero = ( 0.0d+0, 0.0d+0 ),
407 $ cone = ( 1.0d+0, 0.0d+0 ) )
408 INTEGER MAXTYP
409 parameter( maxtyp = 26 )
410* ..
411* .. Local Scalars ..
412 LOGICAL BADNN, ILABAD
413 CHARACTER SORT
414 INTEGER I, IADD, IINFO, IN, ISORT, J, JC, JR, JSIZE,
415 $ JTYPE, KNTEIG, MAXWRK, MINWRK, MTYPES, N, N1,
416 $ NB, NERRS, NMATS, NMAX, NTEST, NTESTT, RSUB,
417 $ SDIM
418 DOUBLE PRECISION SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
419 COMPLEX*16 CTEMP, X
420* ..
421* .. Local Arrays ..
422 LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP )
423 INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
424 $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
425 $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
426 $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
427 $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
428 DOUBLE PRECISION RMAGN( 0: 3 )
429* ..
430* .. External Functions ..
431 LOGICAL ZLCTES
432 INTEGER ILAENV
433 DOUBLE PRECISION DLAMCH
434 COMPLEX*16 ZLARND
435 EXTERNAL zlctes, ilaenv, dlamch, zlarnd
436* ..
437* .. External Subroutines ..
438 EXTERNAL alasvm, dlabad, xerbla, zget51, zget54, zgges3,
439 $ zlacpy, zlarfg, zlaset, zlatm4, zunm2r
440* ..
441* .. Intrinsic Functions ..
442 INTRINSIC abs, dble, dconjg, dimag, max, min, sign
443* ..
444* .. Statement Functions ..
445 DOUBLE PRECISION ABS1
446* ..
447* .. Statement Function definitions ..
448 abs1( x ) = abs( dble( x ) ) + abs( dimag( x ) )
449* ..
450* .. Data statements ..
451 DATA kclass / 15*1, 10*2, 1*3 /
452 DATA kz1 / 0, 1, 2, 1, 3, 3 /
453 DATA kz2 / 0, 0, 1, 2, 1, 1 /
454 DATA kadd / 0, 0, 0, 0, 3, 2 /
455 DATA katype / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
456 $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
457 DATA kbtype / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
458 $ 1, 1, -4, 2, -4, 8*8, 0 /
459 DATA kazero / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
460 $ 4*5, 4*3, 1 /
461 DATA kbzero / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
462 $ 4*6, 4*4, 1 /
463 DATA kamagn / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
464 $ 2, 1 /
465 DATA kbmagn / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
466 $ 2, 1 /
467 DATA ktrian / 16*0, 10*1 /
468 DATA lasign / 6*.false., .true., .false., 2*.true.,
469 $ 2*.false., 3*.true., .false., .true.,
470 $ 3*.false., 5*.true., .false. /
471 DATA lbsign / 7*.false., .true., 2*.false.,
472 $ 2*.true., 2*.false., .true., .false., .true.,
473 $ 9*.false. /
474* ..
475* .. Executable Statements ..
476*
477* Check for errors
478*
479 info = 0
480*
481 badnn = .false.
482 nmax = 1
483 DO 10 j = 1, nsizes
484 nmax = max( nmax, nn( j ) )
485 IF( nn( j ).LT.0 )
486 $ badnn = .true.
487 10 CONTINUE
488*
489 IF( nsizes.LT.0 ) THEN
490 info = -1
491 ELSE IF( badnn ) THEN
492 info = -2
493 ELSE IF( ntypes.LT.0 ) THEN
494 info = -3
495 ELSE IF( thresh.LT.zero ) THEN
496 info = -6
497 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
498 info = -9
499 ELSE IF( ldq.LE.1 .OR. ldq.LT.nmax ) THEN
500 info = -14
501 END IF
502*
503* Compute workspace
504* (Note: Comments in the code beginning "Workspace:" describe the
505* minimal amount of workspace needed at that point in the code,
506* as well as the preferred amount for good performance.
507* NB refers to the optimal block size for the immediately
508* following subroutine, as returned by ILAENV.
509*
510 minwrk = 1
511 IF( info.EQ.0 .AND. lwork.GE.1 ) THEN
512 minwrk = 3*nmax*nmax
513 nb = max( 1, ilaenv( 1, 'ZGEQRF', ' ', nmax, nmax, -1, -1 ),
514 $ ilaenv( 1, 'ZUNMQR', 'LC', nmax, nmax, nmax, -1 ),
515 $ ilaenv( 1, 'ZUNGQR', ' ', nmax, nmax, nmax, -1 ) )
516 maxwrk = max( nmax+nmax*nb, 3*nmax*nmax )
517 work( 1 ) = maxwrk
518 END IF
519*
520 IF( lwork.LT.minwrk )
521 $ info = -19
522*
523 IF( info.NE.0 ) THEN
524 CALL xerbla( 'ZDRGES3', -info )
525 RETURN
526 END IF
527*
528* Quick return if possible
529*
530 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
531 $ RETURN
532*
533 ulp = dlamch( 'Precision' )
534 safmin = dlamch( 'Safe minimum' )
535 safmin = safmin / ulp
536 safmax = one / safmin
537 CALL dlabad( safmin, safmax )
538 ulpinv = one / ulp
539*
540* The values RMAGN(2:3) depend on N, see below.
541*
542 rmagn( 0 ) = zero
543 rmagn( 1 ) = one
544*
545* Loop over matrix sizes
546*
547 ntestt = 0
548 nerrs = 0
549 nmats = 0
550*
551 DO 190 jsize = 1, nsizes
552 n = nn( jsize )
553 n1 = max( 1, n )
554 rmagn( 2 ) = safmax*ulp / dble( n1 )
555 rmagn( 3 ) = safmin*ulpinv*dble( n1 )
556*
557 IF( nsizes.NE.1 ) THEN
558 mtypes = min( maxtyp, ntypes )
559 ELSE
560 mtypes = min( maxtyp+1, ntypes )
561 END IF
562*
563* Loop over matrix types
564*
565 DO 180 jtype = 1, mtypes
566 IF( .NOT.dotype( jtype ) )
567 $ GO TO 180
568 nmats = nmats + 1
569 ntest = 0
570*
571* Save ISEED in case of an error.
572*
573 DO 20 j = 1, 4
574 ioldsd( j ) = iseed( j )
575 20 CONTINUE
576*
577* Initialize RESULT
578*
579 DO 30 j = 1, 13
580 result( j ) = zero
581 30 CONTINUE
582*
583* Generate test matrices A and B
584*
585* Description of control parameters:
586*
587* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
588* =3 means random.
589* KATYPE: the "type" to be passed to ZLATM4 for computing A.
590* KAZERO: the pattern of zeros on the diagonal for A:
591* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
592* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
593* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
594* non-zero entries.)
595* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
596* =2: large, =3: small.
597* LASIGN: .TRUE. if the diagonal elements of A are to be
598* multiplied by a random magnitude 1 number.
599* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B.
600* KTRIAN: =0: don't fill in the upper triangle, =1: do.
601* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
602* RMAGN: used to implement KAMAGN and KBMAGN.
603*
604 IF( mtypes.GT.maxtyp )
605 $ GO TO 110
606 iinfo = 0
607 IF( kclass( jtype ).LT.3 ) THEN
608*
609* Generate A (w/o rotation)
610*
611 IF( abs( katype( jtype ) ).EQ.3 ) THEN
612 in = 2*( ( n-1 ) / 2 ) + 1
613 IF( in.NE.n )
614 $ CALL zlaset( 'Full', n, n, czero, czero, a, lda )
615 ELSE
616 in = n
617 END IF
618 CALL zlatm4( katype( jtype ), in, kz1( kazero( jtype ) ),
619 $ kz2( kazero( jtype ) ), lasign( jtype ),
620 $ rmagn( kamagn( jtype ) ), ulp,
621 $ rmagn( ktrian( jtype )*kamagn( jtype ) ), 2,
622 $ iseed, a, lda )
623 iadd = kadd( kazero( jtype ) )
624 IF( iadd.GT.0 .AND. iadd.LE.n )
625 $ a( iadd, iadd ) = rmagn( kamagn( jtype ) )
626*
627* Generate B (w/o rotation)
628*
629 IF( abs( kbtype( jtype ) ).EQ.3 ) THEN
630 in = 2*( ( n-1 ) / 2 ) + 1
631 IF( in.NE.n )
632 $ CALL zlaset( 'Full', n, n, czero, czero, b, lda )
633 ELSE
634 in = n
635 END IF
636 CALL zlatm4( kbtype( jtype ), in, kz1( kbzero( jtype ) ),
637 $ kz2( kbzero( jtype ) ), lbsign( jtype ),
638 $ rmagn( kbmagn( jtype ) ), one,
639 $ rmagn( ktrian( jtype )*kbmagn( jtype ) ), 2,
640 $ iseed, b, lda )
641 iadd = kadd( kbzero( jtype ) )
642 IF( iadd.NE.0 .AND. iadd.LE.n )
643 $ b( iadd, iadd ) = rmagn( kbmagn( jtype ) )
644*
645 IF( kclass( jtype ).EQ.2 .AND. n.GT.0 ) THEN
646*
647* Include rotations
648*
649* Generate Q, Z as Householder transformations times
650* a diagonal matrix.
651*
652 DO 50 jc = 1, n - 1
653 DO 40 jr = jc, n
654 q( jr, jc ) = zlarnd( 3, iseed )
655 z( jr, jc ) = zlarnd( 3, iseed )
656 40 CONTINUE
657 CALL zlarfg( n+1-jc, q( jc, jc ), q( jc+1, jc ), 1,
658 $ work( jc ) )
659 work( 2*n+jc ) = sign( one, dble( q( jc, jc ) ) )
660 q( jc, jc ) = cone
661 CALL zlarfg( n+1-jc, z( jc, jc ), z( jc+1, jc ), 1,
662 $ work( n+jc ) )
663 work( 3*n+jc ) = sign( one, dble( z( jc, jc ) ) )
664 z( jc, jc ) = cone
665 50 CONTINUE
666 ctemp = zlarnd( 3, iseed )
667 q( n, n ) = cone
668 work( n ) = czero
669 work( 3*n ) = ctemp / abs( ctemp )
670 ctemp = zlarnd( 3, iseed )
671 z( n, n ) = cone
672 work( 2*n ) = czero
673 work( 4*n ) = ctemp / abs( ctemp )
674*
675* Apply the diagonal matrices
676*
677 DO 70 jc = 1, n
678 DO 60 jr = 1, n
679 a( jr, jc ) = work( 2*n+jr )*
680 $ dconjg( work( 3*n+jc ) )*
681 $ a( jr, jc )
682 b( jr, jc ) = work( 2*n+jr )*
683 $ dconjg( work( 3*n+jc ) )*
684 $ b( jr, jc )
685 60 CONTINUE
686 70 CONTINUE
687 CALL zunm2r( 'L', 'N', n, n, n-1, q, ldq, work, a,
688 $ lda, work( 2*n+1 ), iinfo )
689 IF( iinfo.NE.0 )
690 $ GO TO 100
691 CALL zunm2r( 'R', 'C', n, n, n-1, z, ldq, work( n+1 ),
692 $ a, lda, work( 2*n+1 ), iinfo )
693 IF( iinfo.NE.0 )
694 $ GO TO 100
695 CALL zunm2r( 'L', 'N', n, n, n-1, q, ldq, work, b,
696 $ lda, work( 2*n+1 ), iinfo )
697 IF( iinfo.NE.0 )
698 $ GO TO 100
699 CALL zunm2r( 'R', 'C', n, n, n-1, z, ldq, work( n+1 ),
700 $ b, lda, work( 2*n+1 ), iinfo )
701 IF( iinfo.NE.0 )
702 $ GO TO 100
703 END IF
704 ELSE
705*
706* Random matrices
707*
708 DO 90 jc = 1, n
709 DO 80 jr = 1, n
710 a( jr, jc ) = rmagn( kamagn( jtype ) )*
711 $ zlarnd( 4, iseed )
712 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
713 $ zlarnd( 4, iseed )
714 80 CONTINUE
715 90 CONTINUE
716 END IF
717*
718 100 CONTINUE
719*
720 IF( iinfo.NE.0 ) THEN
721 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
722 $ ioldsd
723 info = abs( iinfo )
724 RETURN
725 END IF
726*
727 110 CONTINUE
728*
729 DO 120 i = 1, 13
730 result( i ) = -one
731 120 CONTINUE
732*
733* Test with and without sorting of eigenvalues
734*
735 DO 150 isort = 0, 1
736 IF( isort.EQ.0 ) THEN
737 sort = 'N'
738 rsub = 0
739 ELSE
740 sort = 'S'
741 rsub = 5
742 END IF
743*
744* Call XLAENV to set the parameters used in ZLAQZ0
745*
746 CALL xlaenv( 12, 10 )
747 CALL xlaenv( 13, 12 )
748 CALL xlaenv( 14, 13 )
749 CALL xlaenv( 15, 2 )
750 CALL xlaenv( 17, 10 )
751*
752* Call ZGGES3 to compute H, T, Q, Z, alpha, and beta.
753*
754 CALL zlacpy( 'Full', n, n, a, lda, s, lda )
755 CALL zlacpy( 'Full', n, n, b, lda, t, lda )
756 ntest = 1 + rsub + isort
757 result( 1+rsub+isort ) = ulpinv
758 CALL zgges3( 'V', 'V', sort, zlctes, n, s, lda, t, lda,
759 $ sdim, alpha, beta, q, ldq, z, ldq, work,
760 $ lwork, rwork, bwork, iinfo )
761 IF( iinfo.NE.0 .AND. iinfo.NE.n+2 ) THEN
762 result( 1+rsub+isort ) = ulpinv
763 WRITE( nounit, fmt = 9999 )'ZGGES3', iinfo, n, jtype,
764 $ ioldsd
765 info = abs( iinfo )
766 GO TO 160
767 END IF
768*
769 ntest = 4 + rsub
770*
771* Do tests 1--4 (or tests 7--9 when reordering )
772*
773 IF( isort.EQ.0 ) THEN
774 CALL zget51( 1, n, a, lda, s, lda, q, ldq, z, ldq,
775 $ work, rwork, result( 1 ) )
776 CALL zget51( 1, n, b, lda, t, lda, q, ldq, z, ldq,
777 $ work, rwork, result( 2 ) )
778 ELSE
779 CALL zget54( n, a, lda, b, lda, s, lda, t, lda, q,
780 $ ldq, z, ldq, work, result( 2+rsub ) )
781 END IF
782*
783 CALL zget51( 3, n, b, lda, t, lda, q, ldq, q, ldq, work,
784 $ rwork, result( 3+rsub ) )
785 CALL zget51( 3, n, b, lda, t, lda, z, ldq, z, ldq, work,
786 $ rwork, result( 4+rsub ) )
787*
788* Do test 5 and 6 (or Tests 10 and 11 when reordering):
789* check Schur form of A and compare eigenvalues with
790* diagonals.
791*
792 ntest = 6 + rsub
793 temp1 = zero
794*
795 DO 130 j = 1, n
796 ilabad = .false.
797 temp2 = ( abs1( alpha( j )-s( j, j ) ) /
798 $ max( safmin, abs1( alpha( j ) ), abs1( s( j,
799 $ j ) ) )+abs1( beta( j )-t( j, j ) ) /
800 $ max( safmin, abs1( beta( j ) ), abs1( t( j,
801 $ j ) ) ) ) / ulp
802*
803 IF( j.LT.n ) THEN
804 IF( s( j+1, j ).NE.zero ) THEN
805 ilabad = .true.
806 result( 5+rsub ) = ulpinv
807 END IF
808 END IF
809 IF( j.GT.1 ) THEN
810 IF( s( j, j-1 ).NE.zero ) THEN
811 ilabad = .true.
812 result( 5+rsub ) = ulpinv
813 END IF
814 END IF
815 temp1 = max( temp1, temp2 )
816 IF( ilabad ) THEN
817 WRITE( nounit, fmt = 9998 )j, n, jtype, ioldsd
818 END IF
819 130 CONTINUE
820 result( 6+rsub ) = temp1
821*
822 IF( isort.GE.1 ) THEN
823*
824* Do test 12
825*
826 ntest = 12
827 result( 12 ) = zero
828 knteig = 0
829 DO 140 i = 1, n
830 IF( zlctes( alpha( i ), beta( i ) ) )
831 $ knteig = knteig + 1
832 140 CONTINUE
833 IF( sdim.NE.knteig )
834 $ result( 13 ) = ulpinv
835 END IF
836*
837 150 CONTINUE
838*
839* End of Loop -- Check for RESULT(j) > THRESH
840*
841 160 CONTINUE
842*
843 ntestt = ntestt + ntest
844*
845* Print out tests which fail.
846*
847 DO 170 jr = 1, ntest
848 IF( result( jr ).GE.thresh ) THEN
849*
850* If this is the first test to fail,
851* print a header to the data file.
852*
853 IF( nerrs.EQ.0 ) THEN
854 WRITE( nounit, fmt = 9997 )'ZGS'
855*
856* Matrix types
857*
858 WRITE( nounit, fmt = 9996 )
859 WRITE( nounit, fmt = 9995 )
860 WRITE( nounit, fmt = 9994 )'Unitary'
861*
862* Tests performed
863*
864 WRITE( nounit, fmt = 9993 )'unitary', '''',
865 $ 'transpose', ( '''', j = 1, 8 )
866*
867 END IF
868 nerrs = nerrs + 1
869 IF( result( jr ).LT.10000.0d0 ) THEN
870 WRITE( nounit, fmt = 9992 )n, jtype, ioldsd, jr,
871 $ result( jr )
872 ELSE
873 WRITE( nounit, fmt = 9991 )n, jtype, ioldsd, jr,
874 $ result( jr )
875 END IF
876 END IF
877 170 CONTINUE
878*
879 180 CONTINUE
880 190 CONTINUE
881*
882* Summary
883*
884 CALL alasvm( 'ZGS', nounit, nerrs, ntestt, 0 )
885*
886 work( 1 ) = maxwrk
887*
888 RETURN
889*
890 9999 FORMAT( ' ZDRGES3: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
891 $ i6, ', JTYPE=', i6, ', ISEED=(', 4( i4, ',' ), i5, ')' )
892*
893 9998 FORMAT( ' ZDRGES3: S not in Schur form at eigenvalue ', i6, '.',
894 $ / 9x, 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ),
895 $ i5, ')' )
896*
897 9997 FORMAT( / 1x, a3, ' -- Complex Generalized Schur from problem ',
898 $ 'driver' )
899*
900 9996 FORMAT( ' Matrix types (see ZDRGES3 for details): ' )
901*
902 9995 FORMAT( ' Special Matrices:', 23x,
903 $ '(J''=transposed Jordan block)',
904 $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
905 $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
906 $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
907 $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
908 $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
909 $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
910 9994 FORMAT( ' Matrices Rotated by Random ', a, ' Matrices U, V:',
911 $ / ' 16=Transposed Jordan Blocks 19=geometric ',
912 $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
913 $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
914 $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
915 $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
916 $ '23=(small,large) 24=(small,small) 25=(large,large)',
917 $ / ' 26=random O(1) matrices.' )
918*
919 9993 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
920 $ 'Q and Z are ', a, ',', / 19x,
921 $ 'l and r are the appropriate left and right', / 19x,
922 $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19x, a,
923 $ ' means ', a, '.)', / ' Without ordering: ',
924 $ / ' 1 = | A - Q S Z', a,
925 $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', a,
926 $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', a,
927 $ ' | / ( n ulp ) 4 = | I - ZZ', a,
928 $ ' | / ( n ulp )', / ' 5 = A is in Schur form S',
929 $ / ' 6 = difference between (alpha,beta)',
930 $ ' and diagonals of (S,T)', / ' With ordering: ',
931 $ / ' 7 = | (A,B) - Q (S,T) Z', a, ' | / ( |(A,B)| n ulp )',
932 $ / ' 8 = | I - QQ', a,
933 $ ' | / ( n ulp ) 9 = | I - ZZ', a,
934 $ ' | / ( n ulp )', / ' 10 = A is in Schur form S',
935 $ / ' 11 = difference between (alpha,beta) and diagonals',
936 $ ' of (S,T)', / ' 12 = SDIM is the correct number of ',
937 $ 'selected eigenvalues', / )
938 9992 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
939 $ 4( i4, ',' ), ' result ', i2, ' is', 0p, f8.2 )
940 9991 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
941 $ 4( i4, ',' ), ' result ', i2, ' is', 1p, d10.3 )
942*
943* End of ZDRGES3
944*
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
zgges3
subroutine zgges3(jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb, sdim, alpha, beta, vsl, ldvsl, vsr, ldvsr, work, lwork, rwork, bwork, info)
ZGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition zgges3.f:269

◆ zdrgev()

subroutine zdrgev ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) b,
complex*16, dimension( lda, * ) s,
complex*16, dimension( lda, * ) t,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldq, * ) z,
complex*16, dimension( ldqe, * ) qe,
integer ldqe,
complex*16, dimension( * ) alpha,
complex*16, dimension( * ) beta,
complex*16, dimension( * ) alpha1,
complex*16, dimension( * ) beta1,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result,
integer info )

ZDRGEV

Purpose:
!>
!> ZDRGEV checks the nonsymmetric generalized eigenvalue problem driver
!> routine ZGGEV.
!>
!> ZGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the
!> generalized eigenvalues and, optionally, the left and right
!> eigenvectors.
!>
!> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!> or a ratio  alpha/beta = w, such that A - w*B is singular.  It is
!> usually represented as the pair (alpha,beta), as there is reasonable
!> interpretation for beta=0, and even for both being zero.
!>
!> A right generalized eigenvector corresponding to a generalized
!> eigenvalue  w  for a pair of matrices (A,B) is a vector r  such that
!> (A - wB) * r = 0.  A left generalized eigenvector is a vector l such
!> that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l.
!>
!> When ZDRGEV is called, a number of matrix  () and a
!> number of matrix  are specified.  For each size ()
!> and each type of matrix, a pair of matrices (A, B) will be generated
!> and used for testing.  For each matrix pair, the following tests
!> will be performed and compared with the threshold THRESH.
!>
!> Results from ZGGEV:
!>
!> (1)  max over all left eigenvalue/-vector pairs (alpha/beta,l) of
!>
!>      | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) )
!>
!>      where VL**H is the conjugate-transpose of VL.
!>
!> (2)  | |VL(i)| - 1 | / ulp and whether largest component real
!>
!>      VL(i) denotes the i-th column of VL.
!>
!> (3)  max over all left eigenvalue/-vector pairs (alpha/beta,r) of
!>
!>      | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) )
!>
!> (4)  | |VR(i)| - 1 | / ulp and whether largest component real
!>
!>      VR(i) denotes the i-th column of VR.
!>
!> (5)  W(full) = W(partial)
!>      W(full) denotes the eigenvalues computed when both l and r
!>      are also computed, and W(partial) denotes the eigenvalues
!>      computed when only W, only W and r, or only W and l are
!>      computed.
!>
!> (6)  VL(full) = VL(partial)
!>      VL(full) denotes the left eigenvectors computed when both l
!>      and r are computed, and VL(partial) denotes the result
!>      when only l is computed.
!>
!> (7)  VR(full) = VR(partial)
!>      VR(full) denotes the right eigenvectors computed when both l
!>      and r are also computed, and VR(partial) denotes the result
!>      when only l is computed.
!>
!>
!> Test Matrices
!> ---- --------
!>
!> The sizes of the test matrices are specified by an array
!> NN(1:NSIZES); the value of each element NN(j) specifies one size.
!> The  are specified by a logical array DOTYPE( 1:NTYPES ); if
!> DOTYPE(j) is .TRUE., then matrix type  will be generated.
!> Currently, the list of possible types is:
!>
!> (1)  ( 0, 0 )         (a pair of zero matrices)
!>
!> (2)  ( I, 0 )         (an identity and a zero matrix)
!>
!> (3)  ( 0, I )         (an identity and a zero matrix)
!>
!> (4)  ( I, I )         (a pair of identity matrices)
!>
!>         t   t
!> (5)  ( J , J  )       (a pair of transposed Jordan blocks)
!>
!>                                     t                ( I   0  )
!> (6)  ( X, Y )         where  X = ( J   0  )  and Y = (      t )
!>                                  ( 0   I  )          ( 0   J  )
!>                       and I is a k x k identity and J a (k+1)x(k+1)
!>                       Jordan block; k=(N-1)/2
!>
!> (7)  ( D, I )         where D is diag( 0, 1,..., N-1 ) (a diagonal
!>                       matrix with those diagonal entries.)
!> (8)  ( I, D )
!>
!> (9)  ( big*D, small*I ) where  is near overflow and small=1/big
!>
!> (10) ( small*D, big*I )
!>
!> (11) ( big*I, small*D )
!>
!> (12) ( small*I, big*D )
!>
!> (13) ( big*D, big*I )
!>
!> (14) ( small*D, small*I )
!>
!> (15) ( D1, D2 )        where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
!>                        D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
!>           t   t
!> (16) Q ( J , J ) Z     where Q and Z are random orthogonal matrices.
!>
!> (17) Q ( T1, T2 ) Z    where T1 and T2 are upper triangular matrices
!>                        with random O(1) entries above the diagonal
!>                        and diagonal entries diag(T1) =
!>                        ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
!>                        ( 0, N-3, N-4,..., 1, 0, 0 )
!>
!> (18) Q ( T1, T2 ) Z    diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
!>                        s = machine precision.
!>
!> (19) Q ( T1, T2 ) Z    diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
!>
!>                                                        N-5
!> (20) Q ( T1, T2 ) Z    diag(T1)=( 0, 0, 1, 1, a, ..., a   =s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
!>
!> (21) Q ( T1, T2 ) Z    diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
!>                        where r1,..., r(N-4) are random.
!>
!> (22) Q ( big*T1, small*T2 ) Z    diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (23) Q ( small*T1, big*T2 ) Z    diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (24) Q ( small*T1, small*T2 ) Z  diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (25) Q ( big*T1, big*T2 ) Z      diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (26) Q ( T1, T2 ) Z     where T1 and T2 are random upper-triangular
!>                         matrices.
!>
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZDRGES does nothing.  NSIZES >= 0.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  NN >= 0.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZDRGEV
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated. If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096. Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRGES to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error is
!>          scaled to be O(1), so THRESH should be a reasonably small
!>          multiple of 1, e.g., 10 or 100.  In particular, it should
!>          not depend on the precision (single vs. double) or the size
!>          of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IERR not equal to 0.)
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension(LDA, max(NN))
!>          Used to hold the original A matrix.  Used as input only
!>          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
!>          DOTYPE(MAXTYP+1)=.TRUE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, B, S, and T.
!>          It must be at least 1 and at least max( NN ).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension(LDA, max(NN))
!>          Used to hold the original B matrix.  Used as input only
!>          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
!>          DOTYPE(MAXTYP+1)=.TRUE.
!>
[out]S
!>          S is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The Schur form matrix computed from A by ZGGEV.  On exit, S
!>          contains the Schur form matrix corresponding to the matrix
!>          in A.
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by ZGGEV.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ, max(NN))
!>          The (left) eigenvectors matrix computed by ZGGEV.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of Q and Z. It must
!>          be at least 1 and at least max( NN ).
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension( LDQ, max(NN) )
!>          The (right) orthogonal matrix computed by ZGGEV.
!>
[out]QE
!>          QE is COMPLEX*16 array, dimension( LDQ, max(NN) )
!>          QE holds the computed right or left eigenvectors.
!>
[in]LDQE
!>          LDQE is INTEGER
!>          The leading dimension of QE. LDQE >= max(1,max(NN)).
!>
[out]ALPHA
!>          ALPHA is COMPLEX*16 array, dimension (max(NN))
!>
[out]BETA
!>          BETA is COMPLEX*16 array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by ZGGEV.
!>          ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
!>          generalized eigenvalue of A and B.
!>
[out]ALPHA1
!>          ALPHA1 is COMPLEX*16 array, dimension (max(NN))
!>
[out]BETA1
!>          BETA1 is COMPLEX*16 array, dimension (max(NN))
!>
!>          Like ALPHAR, ALPHAI, BETA, these arrays contain the
!>          eigenvalues of A and B, but those computed when ZGGEV only
!>          computes a partial eigendecomposition, i.e. not the
!>          eigenvalues and left and right eigenvectors.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  LWORK >= N*(N+1)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (8*N)
!>          Real workspace.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  A routine returned an error code.  INFO is the
!>                absolute value of the INFO value returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 395 of file zdrgev.f.

399*
400* -- LAPACK test routine --
401* -- LAPACK is a software package provided by Univ. of Tennessee, --
402* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
403*
404* .. Scalar Arguments ..
405 INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES,
406 $ NTYPES
407 DOUBLE PRECISION THRESH
408* ..
409* .. Array Arguments ..
410 LOGICAL DOTYPE( * )
411 INTEGER ISEED( 4 ), NN( * )
412 DOUBLE PRECISION RESULT( * ), RWORK( * )
413 COMPLEX*16 A( LDA, * ), ALPHA( * ), ALPHA1( * ),
414 $ B( LDA, * ), BETA( * ), BETA1( * ),
415 $ Q( LDQ, * ), QE( LDQE, * ), S( LDA, * ),
416 $ T( LDA, * ), WORK( * ), Z( LDQ, * )
417* ..
418*
419* =====================================================================
420*
421* .. Parameters ..
422 DOUBLE PRECISION ZERO, ONE
423 parameter( zero = 0.0d+0, one = 1.0d+0 )
424 COMPLEX*16 CZERO, CONE
425 parameter( czero = ( 0.0d+0, 0.0d+0 ),
426 $ cone = ( 1.0d+0, 0.0d+0 ) )
427 INTEGER MAXTYP
428 parameter( maxtyp = 26 )
429* ..
430* .. Local Scalars ..
431 LOGICAL BADNN
432 INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE,
433 $ MAXWRK, MINWRK, MTYPES, N, N1, NB, NERRS,
434 $ NMATS, NMAX, NTESTT
435 DOUBLE PRECISION SAFMAX, SAFMIN, ULP, ULPINV
436 COMPLEX*16 CTEMP
437* ..
438* .. Local Arrays ..
439 LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP )
440 INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
441 $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
442 $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
443 $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
444 $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
445 DOUBLE PRECISION RMAGN( 0: 3 )
446* ..
447* .. External Functions ..
448 INTEGER ILAENV
449 DOUBLE PRECISION DLAMCH
450 COMPLEX*16 ZLARND
451 EXTERNAL ilaenv, dlamch, zlarnd
452* ..
453* .. External Subroutines ..
454 EXTERNAL alasvm, dlabad, xerbla, zget52, zggev, zlacpy,
455 $ zlarfg, zlaset, zlatm4, zunm2r
456* ..
457* .. Intrinsic Functions ..
458 INTRINSIC abs, dble, dconjg, max, min, sign
459* ..
460* .. Data statements ..
461 DATA kclass / 15*1, 10*2, 1*3 /
462 DATA kz1 / 0, 1, 2, 1, 3, 3 /
463 DATA kz2 / 0, 0, 1, 2, 1, 1 /
464 DATA kadd / 0, 0, 0, 0, 3, 2 /
465 DATA katype / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
466 $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
467 DATA kbtype / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
468 $ 1, 1, -4, 2, -4, 8*8, 0 /
469 DATA kazero / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
470 $ 4*5, 4*3, 1 /
471 DATA kbzero / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
472 $ 4*6, 4*4, 1 /
473 DATA kamagn / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
474 $ 2, 1 /
475 DATA kbmagn / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
476 $ 2, 1 /
477 DATA ktrian / 16*0, 10*1 /
478 DATA lasign / 6*.false., .true., .false., 2*.true.,
479 $ 2*.false., 3*.true., .false., .true.,
480 $ 3*.false., 5*.true., .false. /
481 DATA lbsign / 7*.false., .true., 2*.false.,
482 $ 2*.true., 2*.false., .true., .false., .true.,
483 $ 9*.false. /
484* ..
485* .. Executable Statements ..
486*
487* Check for errors
488*
489 info = 0
490*
491 badnn = .false.
492 nmax = 1
493 DO 10 j = 1, nsizes
494 nmax = max( nmax, nn( j ) )
495 IF( nn( j ).LT.0 )
496 $ badnn = .true.
497 10 CONTINUE
498*
499 IF( nsizes.LT.0 ) THEN
500 info = -1
501 ELSE IF( badnn ) THEN
502 info = -2
503 ELSE IF( ntypes.LT.0 ) THEN
504 info = -3
505 ELSE IF( thresh.LT.zero ) THEN
506 info = -6
507 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
508 info = -9
509 ELSE IF( ldq.LE.1 .OR. ldq.LT.nmax ) THEN
510 info = -14
511 ELSE IF( ldqe.LE.1 .OR. ldqe.LT.nmax ) THEN
512 info = -17
513 END IF
514*
515* Compute workspace
516* (Note: Comments in the code beginning "Workspace:" describe the
517* minimal amount of workspace needed at that point in the code,
518* as well as the preferred amount for good performance.
519* NB refers to the optimal block size for the immediately
520* following subroutine, as returned by ILAENV.
521*
522 minwrk = 1
523 IF( info.EQ.0 .AND. lwork.GE.1 ) THEN
524 minwrk = nmax*( nmax+1 )
525 nb = max( 1, ilaenv( 1, 'ZGEQRF', ' ', nmax, nmax, -1, -1 ),
526 $ ilaenv( 1, 'ZUNMQR', 'LC', nmax, nmax, nmax, -1 ),
527 $ ilaenv( 1, 'ZUNGQR', ' ', nmax, nmax, nmax, -1 ) )
528 maxwrk = max( 2*nmax, nmax*( nb+1 ), nmax*( nmax+1 ) )
529 work( 1 ) = maxwrk
530 END IF
531*
532 IF( lwork.LT.minwrk )
533 $ info = -23
534*
535 IF( info.NE.0 ) THEN
536 CALL xerbla( 'ZDRGEV', -info )
537 RETURN
538 END IF
539*
540* Quick return if possible
541*
542 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
543 $ RETURN
544*
545 ulp = dlamch( 'Precision' )
546 safmin = dlamch( 'Safe minimum' )
547 safmin = safmin / ulp
548 safmax = one / safmin
549 CALL dlabad( safmin, safmax )
550 ulpinv = one / ulp
551*
552* The values RMAGN(2:3) depend on N, see below.
553*
554 rmagn( 0 ) = zero
555 rmagn( 1 ) = one
556*
557* Loop over sizes, types
558*
559 ntestt = 0
560 nerrs = 0
561 nmats = 0
562*
563 DO 220 jsize = 1, nsizes
564 n = nn( jsize )
565 n1 = max( 1, n )
566 rmagn( 2 ) = safmax*ulp / dble( n1 )
567 rmagn( 3 ) = safmin*ulpinv*n1
568*
569 IF( nsizes.NE.1 ) THEN
570 mtypes = min( maxtyp, ntypes )
571 ELSE
572 mtypes = min( maxtyp+1, ntypes )
573 END IF
574*
575 DO 210 jtype = 1, mtypes
576 IF( .NOT.dotype( jtype ) )
577 $ GO TO 210
578 nmats = nmats + 1
579*
580* Save ISEED in case of an error.
581*
582 DO 20 j = 1, 4
583 ioldsd( j ) = iseed( j )
584 20 CONTINUE
585*
586* Generate test matrices A and B
587*
588* Description of control parameters:
589*
590* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
591* =3 means random.
592* KATYPE: the "type" to be passed to ZLATM4 for computing A.
593* KAZERO: the pattern of zeros on the diagonal for A:
594* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
595* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
596* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
597* non-zero entries.)
598* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
599* =2: large, =3: small.
600* LASIGN: .TRUE. if the diagonal elements of A are to be
601* multiplied by a random magnitude 1 number.
602* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B.
603* KTRIAN: =0: don't fill in the upper triangle, =1: do.
604* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
605* RMAGN: used to implement KAMAGN and KBMAGN.
606*
607 IF( mtypes.GT.maxtyp )
608 $ GO TO 100
609 ierr = 0
610 IF( kclass( jtype ).LT.3 ) THEN
611*
612* Generate A (w/o rotation)
613*
614 IF( abs( katype( jtype ) ).EQ.3 ) THEN
615 in = 2*( ( n-1 ) / 2 ) + 1
616 IF( in.NE.n )
617 $ CALL zlaset( 'Full', n, n, czero, czero, a, lda )
618 ELSE
619 in = n
620 END IF
621 CALL zlatm4( katype( jtype ), in, kz1( kazero( jtype ) ),
622 $ kz2( kazero( jtype ) ), lasign( jtype ),
623 $ rmagn( kamagn( jtype ) ), ulp,
624 $ rmagn( ktrian( jtype )*kamagn( jtype ) ), 2,
625 $ iseed, a, lda )
626 iadd = kadd( kazero( jtype ) )
627 IF( iadd.GT.0 .AND. iadd.LE.n )
628 $ a( iadd, iadd ) = rmagn( kamagn( jtype ) )
629*
630* Generate B (w/o rotation)
631*
632 IF( abs( kbtype( jtype ) ).EQ.3 ) THEN
633 in = 2*( ( n-1 ) / 2 ) + 1
634 IF( in.NE.n )
635 $ CALL zlaset( 'Full', n, n, czero, czero, b, lda )
636 ELSE
637 in = n
638 END IF
639 CALL zlatm4( kbtype( jtype ), in, kz1( kbzero( jtype ) ),
640 $ kz2( kbzero( jtype ) ), lbsign( jtype ),
641 $ rmagn( kbmagn( jtype ) ), one,
642 $ rmagn( ktrian( jtype )*kbmagn( jtype ) ), 2,
643 $ iseed, b, lda )
644 iadd = kadd( kbzero( jtype ) )
645 IF( iadd.NE.0 .AND. iadd.LE.n )
646 $ b( iadd, iadd ) = rmagn( kbmagn( jtype ) )
647*
648 IF( kclass( jtype ).EQ.2 .AND. n.GT.0 ) THEN
649*
650* Include rotations
651*
652* Generate Q, Z as Householder transformations times
653* a diagonal matrix.
654*
655 DO 40 jc = 1, n - 1
656 DO 30 jr = jc, n
657 q( jr, jc ) = zlarnd( 3, iseed )
658 z( jr, jc ) = zlarnd( 3, iseed )
659 30 CONTINUE
660 CALL zlarfg( n+1-jc, q( jc, jc ), q( jc+1, jc ), 1,
661 $ work( jc ) )
662 work( 2*n+jc ) = sign( one, dble( q( jc, jc ) ) )
663 q( jc, jc ) = cone
664 CALL zlarfg( n+1-jc, z( jc, jc ), z( jc+1, jc ), 1,
665 $ work( n+jc ) )
666 work( 3*n+jc ) = sign( one, dble( z( jc, jc ) ) )
667 z( jc, jc ) = cone
668 40 CONTINUE
669 ctemp = zlarnd( 3, iseed )
670 q( n, n ) = cone
671 work( n ) = czero
672 work( 3*n ) = ctemp / abs( ctemp )
673 ctemp = zlarnd( 3, iseed )
674 z( n, n ) = cone
675 work( 2*n ) = czero
676 work( 4*n ) = ctemp / abs( ctemp )
677*
678* Apply the diagonal matrices
679*
680 DO 60 jc = 1, n
681 DO 50 jr = 1, n
682 a( jr, jc ) = work( 2*n+jr )*
683 $ dconjg( work( 3*n+jc ) )*
684 $ a( jr, jc )
685 b( jr, jc ) = work( 2*n+jr )*
686 $ dconjg( work( 3*n+jc ) )*
687 $ b( jr, jc )
688 50 CONTINUE
689 60 CONTINUE
690 CALL zunm2r( 'L', 'N', n, n, n-1, q, ldq, work, a,
691 $ lda, work( 2*n+1 ), ierr )
692 IF( ierr.NE.0 )
693 $ GO TO 90
694 CALL zunm2r( 'R', 'C', n, n, n-1, z, ldq, work( n+1 ),
695 $ a, lda, work( 2*n+1 ), ierr )
696 IF( ierr.NE.0 )
697 $ GO TO 90
698 CALL zunm2r( 'L', 'N', n, n, n-1, q, ldq, work, b,
699 $ lda, work( 2*n+1 ), ierr )
700 IF( ierr.NE.0 )
701 $ GO TO 90
702 CALL zunm2r( 'R', 'C', n, n, n-1, z, ldq, work( n+1 ),
703 $ b, lda, work( 2*n+1 ), ierr )
704 IF( ierr.NE.0 )
705 $ GO TO 90
706 END IF
707 ELSE
708*
709* Random matrices
710*
711 DO 80 jc = 1, n
712 DO 70 jr = 1, n
713 a( jr, jc ) = rmagn( kamagn( jtype ) )*
714 $ zlarnd( 4, iseed )
715 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
716 $ zlarnd( 4, iseed )
717 70 CONTINUE
718 80 CONTINUE
719 END IF
720*
721 90 CONTINUE
722*
723 IF( ierr.NE.0 ) THEN
724 WRITE( nounit, fmt = 9999 )'Generator', ierr, n, jtype,
725 $ ioldsd
726 info = abs( ierr )
727 RETURN
728 END IF
729*
730 100 CONTINUE
731*
732 DO 110 i = 1, 7
733 result( i ) = -one
734 110 CONTINUE
735*
736* Call ZGGEV to compute eigenvalues and eigenvectors.
737*
738 CALL zlacpy( ' ', n, n, a, lda, s, lda )
739 CALL zlacpy( ' ', n, n, b, lda, t, lda )
740 CALL zggev( 'V', 'V', n, s, lda, t, lda, alpha, beta, q,
741 $ ldq, z, ldq, work, lwork, rwork, ierr )
742 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
743 result( 1 ) = ulpinv
744 WRITE( nounit, fmt = 9999 )'ZGGEV1', ierr, n, jtype,
745 $ ioldsd
746 info = abs( ierr )
747 GO TO 190
748 END IF
749*
750* Do the tests (1) and (2)
751*
752 CALL zget52( .true., n, a, lda, b, lda, q, ldq, alpha, beta,
753 $ work, rwork, result( 1 ) )
754 IF( result( 2 ).GT.thresh ) THEN
755 WRITE( nounit, fmt = 9998 )'Left', 'ZGGEV1',
756 $ result( 2 ), n, jtype, ioldsd
757 END IF
758*
759* Do the tests (3) and (4)
760*
761 CALL zget52( .false., n, a, lda, b, lda, z, ldq, alpha,
762 $ beta, work, rwork, result( 3 ) )
763 IF( result( 4 ).GT.thresh ) THEN
764 WRITE( nounit, fmt = 9998 )'Right', 'ZGGEV1',
765 $ result( 4 ), n, jtype, ioldsd
766 END IF
767*
768* Do test (5)
769*
770 CALL zlacpy( ' ', n, n, a, lda, s, lda )
771 CALL zlacpy( ' ', n, n, b, lda, t, lda )
772 CALL zggev( 'N', 'N', n, s, lda, t, lda, alpha1, beta1, q,
773 $ ldq, z, ldq, work, lwork, rwork, ierr )
774 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
775 result( 1 ) = ulpinv
776 WRITE( nounit, fmt = 9999 )'ZGGEV2', ierr, n, jtype,
777 $ ioldsd
778 info = abs( ierr )
779 GO TO 190
780 END IF
781*
782 DO 120 j = 1, n
783 IF( alpha( j ).NE.alpha1( j ) .OR. beta( j ).NE.
784 $ beta1( j ) )result( 5 ) = ulpinv
785 120 CONTINUE
786*
787* Do test (6): Compute eigenvalues and left eigenvectors,
788* and test them
789*
790 CALL zlacpy( ' ', n, n, a, lda, s, lda )
791 CALL zlacpy( ' ', n, n, b, lda, t, lda )
792 CALL zggev( 'V', 'N', n, s, lda, t, lda, alpha1, beta1, qe,
793 $ ldqe, z, ldq, work, lwork, rwork, ierr )
794 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
795 result( 1 ) = ulpinv
796 WRITE( nounit, fmt = 9999 )'ZGGEV3', ierr, n, jtype,
797 $ ioldsd
798 info = abs( ierr )
799 GO TO 190
800 END IF
801*
802 DO 130 j = 1, n
803 IF( alpha( j ).NE.alpha1( j ) .OR. beta( j ).NE.
804 $ beta1( j ) )result( 6 ) = ulpinv
805 130 CONTINUE
806*
807 DO 150 j = 1, n
808 DO 140 jc = 1, n
809 IF( q( j, jc ).NE.qe( j, jc ) )
810 $ result( 6 ) = ulpinv
811 140 CONTINUE
812 150 CONTINUE
813*
814* Do test (7): Compute eigenvalues and right eigenvectors,
815* and test them
816*
817 CALL zlacpy( ' ', n, n, a, lda, s, lda )
818 CALL zlacpy( ' ', n, n, b, lda, t, lda )
819 CALL zggev( 'N', 'V', n, s, lda, t, lda, alpha1, beta1, q,
820 $ ldq, qe, ldqe, work, lwork, rwork, ierr )
821 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
822 result( 1 ) = ulpinv
823 WRITE( nounit, fmt = 9999 )'ZGGEV4', ierr, n, jtype,
824 $ ioldsd
825 info = abs( ierr )
826 GO TO 190
827 END IF
828*
829 DO 160 j = 1, n
830 IF( alpha( j ).NE.alpha1( j ) .OR. beta( j ).NE.
831 $ beta1( j ) )result( 7 ) = ulpinv
832 160 CONTINUE
833*
834 DO 180 j = 1, n
835 DO 170 jc = 1, n
836 IF( z( j, jc ).NE.qe( j, jc ) )
837 $ result( 7 ) = ulpinv
838 170 CONTINUE
839 180 CONTINUE
840*
841* End of Loop -- Check for RESULT(j) > THRESH
842*
843 190 CONTINUE
844*
845 ntestt = ntestt + 7
846*
847* Print out tests which fail.
848*
849 DO 200 jr = 1, 7
850 IF( result( jr ).GE.thresh ) THEN
851*
852* If this is the first test to fail,
853* print a header to the data file.
854*
855 IF( nerrs.EQ.0 ) THEN
856 WRITE( nounit, fmt = 9997 )'ZGV'
857*
858* Matrix types
859*
860 WRITE( nounit, fmt = 9996 )
861 WRITE( nounit, fmt = 9995 )
862 WRITE( nounit, fmt = 9994 )'Orthogonal'
863*
864* Tests performed
865*
866 WRITE( nounit, fmt = 9993 )
867*
868 END IF
869 nerrs = nerrs + 1
870 IF( result( jr ).LT.10000.0d0 ) THEN
871 WRITE( nounit, fmt = 9992 )n, jtype, ioldsd, jr,
872 $ result( jr )
873 ELSE
874 WRITE( nounit, fmt = 9991 )n, jtype, ioldsd, jr,
875 $ result( jr )
876 END IF
877 END IF
878 200 CONTINUE
879*
880 210 CONTINUE
881 220 CONTINUE
882*
883* Summary
884*
885 CALL alasvm( 'ZGV', nounit, nerrs, ntestt, 0 )
886*
887 work( 1 ) = maxwrk
888*
889 RETURN
890*
891 9999 FORMAT( ' ZDRGEV: ', a, ' returned INFO=', i6, '.', / 3x, 'N=',
892 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
893*
894 9998 FORMAT( ' ZDRGEV: ', a, ' Eigenvectors from ', a, ' incorrectly ',
895 $ 'normalized.', / ' Bits of error=', 0p, g10.3, ',', 3x,
896 $ 'N=', i4, ', JTYPE=', i3, ', ISEED=(', 3( i4, ',' ), i5,
897 $ ')' )
898*
899 9997 FORMAT( / 1x, a3, ' -- Complex Generalized eigenvalue problem ',
900 $ 'driver' )
901*
902 9996 FORMAT( ' Matrix types (see ZDRGEV for details): ' )
903*
904 9995 FORMAT( ' Special Matrices:', 23x,
905 $ '(J''=transposed Jordan block)',
906 $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
907 $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
908 $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
909 $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
910 $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
911 $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
912 9994 FORMAT( ' Matrices Rotated by Random ', a, ' Matrices U, V:',
913 $ / ' 16=Transposed Jordan Blocks 19=geometric ',
914 $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
915 $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
916 $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
917 $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
918 $ '23=(small,large) 24=(small,small) 25=(large,large)',
919 $ / ' 26=random O(1) matrices.' )
920*
921 9993 FORMAT( / ' Tests performed: ',
922 $ / ' 1 = max | ( b A - a B )''*l | / const.,',
923 $ / ' 2 = | |VR(i)| - 1 | / ulp,',
924 $ / ' 3 = max | ( b A - a B )*r | / const.',
925 $ / ' 4 = | |VL(i)| - 1 | / ulp,',
926 $ / ' 5 = 0 if W same no matter if r or l computed,',
927 $ / ' 6 = 0 if l same no matter if l computed,',
928 $ / ' 7 = 0 if r same no matter if r computed,', / 1x )
929 9992 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
930 $ 4( i4, ',' ), ' result ', i2, ' is', 0p, f8.2 )
931 9991 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
932 $ 4( i4, ',' ), ' result ', i2, ' is', 1p, d10.3 )
933*
934* End of ZDRGEV
935*
zggev
subroutine zggev(jobvl, jobvr, n, a, lda, b, ldb, alpha, beta, vl, ldvl, vr, ldvr, work, lwork, rwork, info)
ZGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition zggev.f:217

◆ zdrgev3()

subroutine zdrgev3 ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) b,
complex*16, dimension( lda, * ) s,
complex*16, dimension( lda, * ) t,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( ldq, * ) z,
complex*16, dimension( ldqe, * ) qe,
integer ldqe,
complex*16, dimension( * ) alpha,
complex*16, dimension( * ) beta,
complex*16, dimension( * ) alpha1,
complex*16, dimension( * ) beta1,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result,
integer info )

ZDRGEV3

Purpose:
!>
!> ZDRGEV3 checks the nonsymmetric generalized eigenvalue problem driver
!> routine ZGGEV3.
!>
!> ZGGEV3 computes for a pair of n-by-n nonsymmetric matrices (A,B) the
!> generalized eigenvalues and, optionally, the left and right
!> eigenvectors.
!>
!> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!> or a ratio  alpha/beta = w, such that A - w*B is singular.  It is
!> usually represented as the pair (alpha,beta), as there is reasonable
!> interpretation for beta=0, and even for both being zero.
!>
!> A right generalized eigenvector corresponding to a generalized
!> eigenvalue  w  for a pair of matrices (A,B) is a vector r  such that
!> (A - wB) * r = 0.  A left generalized eigenvector is a vector l such
!> that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l.
!>
!> When ZDRGEV3 is called, a number of matrix  () and a
!> number of matrix  are specified.  For each size ()
!> and each type of matrix, a pair of matrices (A, B) will be generated
!> and used for testing.  For each matrix pair, the following tests
!> will be performed and compared with the threshold THRESH.
!>
!> Results from ZGGEV3:
!>
!> (1)  max over all left eigenvalue/-vector pairs (alpha/beta,l) of
!>
!>      | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) )
!>
!>      where VL**H is the conjugate-transpose of VL.
!>
!> (2)  | |VL(i)| - 1 | / ulp and whether largest component real
!>
!>      VL(i) denotes the i-th column of VL.
!>
!> (3)  max over all left eigenvalue/-vector pairs (alpha/beta,r) of
!>
!>      | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) )
!>
!> (4)  | |VR(i)| - 1 | / ulp and whether largest component real
!>
!>      VR(i) denotes the i-th column of VR.
!>
!> (5)  W(full) = W(partial)
!>      W(full) denotes the eigenvalues computed when both l and r
!>      are also computed, and W(partial) denotes the eigenvalues
!>      computed when only W, only W and r, or only W and l are
!>      computed.
!>
!> (6)  VL(full) = VL(partial)
!>      VL(full) denotes the left eigenvectors computed when both l
!>      and r are computed, and VL(partial) denotes the result
!>      when only l is computed.
!>
!> (7)  VR(full) = VR(partial)
!>      VR(full) denotes the right eigenvectors computed when both l
!>      and r are also computed, and VR(partial) denotes the result
!>      when only l is computed.
!>
!>
!> Test Matrices
!> ---- --------
!>
!> The sizes of the test matrices are specified by an array
!> NN(1:NSIZES); the value of each element NN(j) specifies one size.
!> The  are specified by a logical array DOTYPE( 1:NTYPES ); if
!> DOTYPE(j) is .TRUE., then matrix type  will be generated.
!> Currently, the list of possible types is:
!>
!> (1)  ( 0, 0 )         (a pair of zero matrices)
!>
!> (2)  ( I, 0 )         (an identity and a zero matrix)
!>
!> (3)  ( 0, I )         (an identity and a zero matrix)
!>
!> (4)  ( I, I )         (a pair of identity matrices)
!>
!>         t   t
!> (5)  ( J , J  )       (a pair of transposed Jordan blocks)
!>
!>                                     t                ( I   0  )
!> (6)  ( X, Y )         where  X = ( J   0  )  and Y = (      t )
!>                                  ( 0   I  )          ( 0   J  )
!>                       and I is a k x k identity and J a (k+1)x(k+1)
!>                       Jordan block; k=(N-1)/2
!>
!> (7)  ( D, I )         where D is diag( 0, 1,..., N-1 ) (a diagonal
!>                       matrix with those diagonal entries.)
!> (8)  ( I, D )
!>
!> (9)  ( big*D, small*I ) where  is near overflow and small=1/big
!>
!> (10) ( small*D, big*I )
!>
!> (11) ( big*I, small*D )
!>
!> (12) ( small*I, big*D )
!>
!> (13) ( big*D, big*I )
!>
!> (14) ( small*D, small*I )
!>
!> (15) ( D1, D2 )        where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
!>                        D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
!>           t   t
!> (16) Q ( J , J ) Z     where Q and Z are random orthogonal matrices.
!>
!> (17) Q ( T1, T2 ) Z    where T1 and T2 are upper triangular matrices
!>                        with random O(1) entries above the diagonal
!>                        and diagonal entries diag(T1) =
!>                        ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
!>                        ( 0, N-3, N-4,..., 1, 0, 0 )
!>
!> (18) Q ( T1, T2 ) Z    diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
!>                        s = machine precision.
!>
!> (19) Q ( T1, T2 ) Z    diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
!>
!>                                                        N-5
!> (20) Q ( T1, T2 ) Z    diag(T1)=( 0, 0, 1, 1, a, ..., a   =s, 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
!>
!> (21) Q ( T1, T2 ) Z    diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
!>                        diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
!>                        where r1,..., r(N-4) are random.
!>
!> (22) Q ( big*T1, small*T2 ) Z    diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (23) Q ( small*T1, big*T2 ) Z    diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (24) Q ( small*T1, small*T2 ) Z  diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (25) Q ( big*T1, big*T2 ) Z      diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (26) Q ( T1, T2 ) Z     where T1 and T2 are random upper-triangular
!>                         matrices.
!>
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZDRGEV3 does nothing.  NSIZES >= 0.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  NN >= 0.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZDRGEV3
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated. If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096. Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRGES to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error is
!>          scaled to be O(1), so THRESH should be a reasonably small
!>          multiple of 1, e.g., 10 or 100.  In particular, it should
!>          not depend on the precision (single vs. double) or the size
!>          of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IERR not equal to 0.)
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension(LDA, max(NN))
!>          Used to hold the original A matrix.  Used as input only
!>          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
!>          DOTYPE(MAXTYP+1)=.TRUE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, B, S, and T.
!>          It must be at least 1 and at least max( NN ).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension(LDA, max(NN))
!>          Used to hold the original B matrix.  Used as input only
!>          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
!>          DOTYPE(MAXTYP+1)=.TRUE.
!>
[out]S
!>          S is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The Schur form matrix computed from A by ZGGEV3.  On exit, S
!>          contains the Schur form matrix corresponding to the matrix
!>          in A.
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by ZGGEV3.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDQ, max(NN))
!>          The (left) eigenvectors matrix computed by ZGGEV3.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of Q and Z. It must
!>          be at least 1 and at least max( NN ).
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension( LDQ, max(NN) )
!>          The (right) orthogonal matrix computed by ZGGEV3.
!>
[out]QE
!>          QE is COMPLEX*16 array, dimension( LDQ, max(NN) )
!>          QE holds the computed right or left eigenvectors.
!>
[in]LDQE
!>          LDQE is INTEGER
!>          The leading dimension of QE. LDQE >= max(1,max(NN)).
!>
[out]ALPHA
!>          ALPHA is COMPLEX*16 array, dimension (max(NN))
!>
[out]BETA
!>          BETA is COMPLEX*16 array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by ZGGEV3.
!>          ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
!>          generalized eigenvalue of A and B.
!>
[out]ALPHA1
!>          ALPHA1 is COMPLEX*16 array, dimension (max(NN))
!>
[out]BETA1
!>          BETA1 is COMPLEX*16 array, dimension (max(NN))
!>
!>          Like ALPHAR, ALPHAI, BETA, these arrays contain the
!>          eigenvalues of A and B, but those computed when ZGGEV3 only
!>          computes a partial eigendecomposition, i.e. not the
!>          eigenvalues and left and right eigenvectors.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  LWORK >= N*(N+1)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (8*N)
!>          Real workspace.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  A routine returned an error code.  INFO is the
!>                absolute value of the INFO value returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 395 of file zdrgev3.f.

399*
400* -- LAPACK test routine --
401* -- LAPACK is a software package provided by Univ. of Tennessee, --
402* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
403*
404* .. Scalar Arguments ..
405 INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES,
406 $ NTYPES
407 DOUBLE PRECISION THRESH
408* ..
409* .. Array Arguments ..
410 LOGICAL DOTYPE( * )
411 INTEGER ISEED( 4 ), NN( * )
412 DOUBLE PRECISION RESULT( * ), RWORK( * )
413 COMPLEX*16 A( LDA, * ), ALPHA( * ), ALPHA1( * ),
414 $ B( LDA, * ), BETA( * ), BETA1( * ),
415 $ Q( LDQ, * ), QE( LDQE, * ), S( LDA, * ),
416 $ T( LDA, * ), WORK( * ), Z( LDQ, * )
417* ..
418*
419* =====================================================================
420*
421* .. Parameters ..
422 DOUBLE PRECISION ZERO, ONE
423 parameter( zero = 0.0d+0, one = 1.0d+0 )
424 COMPLEX*16 CZERO, CONE
425 parameter( czero = ( 0.0d+0, 0.0d+0 ),
426 $ cone = ( 1.0d+0, 0.0d+0 ) )
427 INTEGER MAXTYP
428 parameter( maxtyp = 26 )
429* ..
430* .. Local Scalars ..
431 LOGICAL BADNN
432 INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE,
433 $ MAXWRK, MINWRK, MTYPES, N, N1, NB, NERRS,
434 $ NMATS, NMAX, NTESTT
435 DOUBLE PRECISION SAFMAX, SAFMIN, ULP, ULPINV
436 COMPLEX*16 CTEMP
437* ..
438* .. Local Arrays ..
439 LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP )
440 INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
441 $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
442 $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
443 $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
444 $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
445 DOUBLE PRECISION RMAGN( 0: 3 )
446* ..
447* .. External Functions ..
448 INTEGER ILAENV
449 DOUBLE PRECISION DLAMCH
450 COMPLEX*16 ZLARND
451 EXTERNAL ilaenv, dlamch, zlarnd
452* ..
453* .. External Subroutines ..
454 EXTERNAL alasvm, dlabad, xerbla, zget52, zggev3, zlacpy,
455 $ zlarfg, zlaset, zlatm4, zunm2r
456* ..
457* .. Intrinsic Functions ..
458 INTRINSIC abs, dble, dconjg, max, min, sign
459* ..
460* .. Data statements ..
461 DATA kclass / 15*1, 10*2, 1*3 /
462 DATA kz1 / 0, 1, 2, 1, 3, 3 /
463 DATA kz2 / 0, 0, 1, 2, 1, 1 /
464 DATA kadd / 0, 0, 0, 0, 3, 2 /
465 DATA katype / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
466 $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
467 DATA kbtype / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
468 $ 1, 1, -4, 2, -4, 8*8, 0 /
469 DATA kazero / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
470 $ 4*5, 4*3, 1 /
471 DATA kbzero / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
472 $ 4*6, 4*4, 1 /
473 DATA kamagn / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
474 $ 2, 1 /
475 DATA kbmagn / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
476 $ 2, 1 /
477 DATA ktrian / 16*0, 10*1 /
478 DATA lasign / 6*.false., .true., .false., 2*.true.,
479 $ 2*.false., 3*.true., .false., .true.,
480 $ 3*.false., 5*.true., .false. /
481 DATA lbsign / 7*.false., .true., 2*.false.,
482 $ 2*.true., 2*.false., .true., .false., .true.,
483 $ 9*.false. /
484* ..
485* .. Executable Statements ..
486*
487* Check for errors
488*
489 info = 0
490*
491 badnn = .false.
492 nmax = 1
493 DO 10 j = 1, nsizes
494 nmax = max( nmax, nn( j ) )
495 IF( nn( j ).LT.0 )
496 $ badnn = .true.
497 10 CONTINUE
498*
499 IF( nsizes.LT.0 ) THEN
500 info = -1
501 ELSE IF( badnn ) THEN
502 info = -2
503 ELSE IF( ntypes.LT.0 ) THEN
504 info = -3
505 ELSE IF( thresh.LT.zero ) THEN
506 info = -6
507 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
508 info = -9
509 ELSE IF( ldq.LE.1 .OR. ldq.LT.nmax ) THEN
510 info = -14
511 ELSE IF( ldqe.LE.1 .OR. ldqe.LT.nmax ) THEN
512 info = -17
513 END IF
514*
515* Compute workspace
516* (Note: Comments in the code beginning "Workspace:" describe the
517* minimal amount of workspace needed at that point in the code,
518* as well as the preferred amount for good performance.
519* NB refers to the optimal block size for the immediately
520* following subroutine, as returned by ILAENV.
521*
522 minwrk = 1
523 IF( info.EQ.0 .AND. lwork.GE.1 ) THEN
524 minwrk = nmax*( nmax+1 )
525 nb = max( 1, ilaenv( 1, 'ZGEQRF', ' ', nmax, nmax, -1, -1 ),
526 $ ilaenv( 1, 'ZUNMQR', 'LC', nmax, nmax, nmax, -1 ),
527 $ ilaenv( 1, 'ZUNGQR', ' ', nmax, nmax, nmax, -1 ) )
528 maxwrk = max( 2*nmax, nmax*( nb+1 ), nmax*( nmax+1 ) )
529 work( 1 ) = maxwrk
530 END IF
531*
532 IF( lwork.LT.minwrk )
533 $ info = -23
534*
535 IF( info.NE.0 ) THEN
536 CALL xerbla( 'ZDRGEV3', -info )
537 RETURN
538 END IF
539*
540* Quick return if possible
541*
542 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
543 $ RETURN
544*
545 ulp = dlamch( 'Precision' )
546 safmin = dlamch( 'Safe minimum' )
547 safmin = safmin / ulp
548 safmax = one / safmin
549 CALL dlabad( safmin, safmax )
550 ulpinv = one / ulp
551*
552* The values RMAGN(2:3) depend on N, see below.
553*
554 rmagn( 0 ) = zero
555 rmagn( 1 ) = one
556*
557* Loop over sizes, types
558*
559 ntestt = 0
560 nerrs = 0
561 nmats = 0
562*
563 DO 220 jsize = 1, nsizes
564 n = nn( jsize )
565 n1 = max( 1, n )
566 rmagn( 2 ) = safmax*ulp / dble( n1 )
567 rmagn( 3 ) = safmin*ulpinv*n1
568*
569 IF( nsizes.NE.1 ) THEN
570 mtypes = min( maxtyp, ntypes )
571 ELSE
572 mtypes = min( maxtyp+1, ntypes )
573 END IF
574*
575 DO 210 jtype = 1, mtypes
576 IF( .NOT.dotype( jtype ) )
577 $ GO TO 210
578 nmats = nmats + 1
579*
580* Save ISEED in case of an error.
581*
582 DO 20 j = 1, 4
583 ioldsd( j ) = iseed( j )
584 20 CONTINUE
585*
586* Generate test matrices A and B
587*
588* Description of control parameters:
589*
590* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
591* =3 means random.
592* KATYPE: the "type" to be passed to ZLATM4 for computing A.
593* KAZERO: the pattern of zeros on the diagonal for A:
594* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
595* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
596* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
597* non-zero entries.)
598* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
599* =2: large, =3: small.
600* LASIGN: .TRUE. if the diagonal elements of A are to be
601* multiplied by a random magnitude 1 number.
602* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B.
603* KTRIAN: =0: don't fill in the upper triangle, =1: do.
604* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
605* RMAGN: used to implement KAMAGN and KBMAGN.
606*
607 IF( mtypes.GT.maxtyp )
608 $ GO TO 100
609 ierr = 0
610 IF( kclass( jtype ).LT.3 ) THEN
611*
612* Generate A (w/o rotation)
613*
614 IF( abs( katype( jtype ) ).EQ.3 ) THEN
615 in = 2*( ( n-1 ) / 2 ) + 1
616 IF( in.NE.n )
617 $ CALL zlaset( 'Full', n, n, czero, czero, a, lda )
618 ELSE
619 in = n
620 END IF
621 CALL zlatm4( katype( jtype ), in, kz1( kazero( jtype ) ),
622 $ kz2( kazero( jtype ) ), lasign( jtype ),
623 $ rmagn( kamagn( jtype ) ), ulp,
624 $ rmagn( ktrian( jtype )*kamagn( jtype ) ), 2,
625 $ iseed, a, lda )
626 iadd = kadd( kazero( jtype ) )
627 IF( iadd.GT.0 .AND. iadd.LE.n )
628 $ a( iadd, iadd ) = rmagn( kamagn( jtype ) )
629*
630* Generate B (w/o rotation)
631*
632 IF( abs( kbtype( jtype ) ).EQ.3 ) THEN
633 in = 2*( ( n-1 ) / 2 ) + 1
634 IF( in.NE.n )
635 $ CALL zlaset( 'Full', n, n, czero, czero, b, lda )
636 ELSE
637 in = n
638 END IF
639 CALL zlatm4( kbtype( jtype ), in, kz1( kbzero( jtype ) ),
640 $ kz2( kbzero( jtype ) ), lbsign( jtype ),
641 $ rmagn( kbmagn( jtype ) ), one,
642 $ rmagn( ktrian( jtype )*kbmagn( jtype ) ), 2,
643 $ iseed, b, lda )
644 iadd = kadd( kbzero( jtype ) )
645 IF( iadd.NE.0 .AND. iadd.LE.n )
646 $ b( iadd, iadd ) = rmagn( kbmagn( jtype ) )
647*
648 IF( kclass( jtype ).EQ.2 .AND. n.GT.0 ) THEN
649*
650* Include rotations
651*
652* Generate Q, Z as Householder transformations times
653* a diagonal matrix.
654*
655 DO 40 jc = 1, n - 1
656 DO 30 jr = jc, n
657 q( jr, jc ) = zlarnd( 3, iseed )
658 z( jr, jc ) = zlarnd( 3, iseed )
659 30 CONTINUE
660 CALL zlarfg( n+1-jc, q( jc, jc ), q( jc+1, jc ), 1,
661 $ work( jc ) )
662 work( 2*n+jc ) = sign( one, dble( q( jc, jc ) ) )
663 q( jc, jc ) = cone
664 CALL zlarfg( n+1-jc, z( jc, jc ), z( jc+1, jc ), 1,
665 $ work( n+jc ) )
666 work( 3*n+jc ) = sign( one, dble( z( jc, jc ) ) )
667 z( jc, jc ) = cone
668 40 CONTINUE
669 ctemp = zlarnd( 3, iseed )
670 q( n, n ) = cone
671 work( n ) = czero
672 work( 3*n ) = ctemp / abs( ctemp )
673 ctemp = zlarnd( 3, iseed )
674 z( n, n ) = cone
675 work( 2*n ) = czero
676 work( 4*n ) = ctemp / abs( ctemp )
677*
678* Apply the diagonal matrices
679*
680 DO 60 jc = 1, n
681 DO 50 jr = 1, n
682 a( jr, jc ) = work( 2*n+jr )*
683 $ dconjg( work( 3*n+jc ) )*
684 $ a( jr, jc )
685 b( jr, jc ) = work( 2*n+jr )*
686 $ dconjg( work( 3*n+jc ) )*
687 $ b( jr, jc )
688 50 CONTINUE
689 60 CONTINUE
690 CALL zunm2r( 'L', 'N', n, n, n-1, q, ldq, work, a,
691 $ lda, work( 2*n+1 ), ierr )
692 IF( ierr.NE.0 )
693 $ GO TO 90
694 CALL zunm2r( 'R', 'C', n, n, n-1, z, ldq, work( n+1 ),
695 $ a, lda, work( 2*n+1 ), ierr )
696 IF( ierr.NE.0 )
697 $ GO TO 90
698 CALL zunm2r( 'L', 'N', n, n, n-1, q, ldq, work, b,
699 $ lda, work( 2*n+1 ), ierr )
700 IF( ierr.NE.0 )
701 $ GO TO 90
702 CALL zunm2r( 'R', 'C', n, n, n-1, z, ldq, work( n+1 ),
703 $ b, lda, work( 2*n+1 ), ierr )
704 IF( ierr.NE.0 )
705 $ GO TO 90
706 END IF
707 ELSE
708*
709* Random matrices
710*
711 DO 80 jc = 1, n
712 DO 70 jr = 1, n
713 a( jr, jc ) = rmagn( kamagn( jtype ) )*
714 $ zlarnd( 4, iseed )
715 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
716 $ zlarnd( 4, iseed )
717 70 CONTINUE
718 80 CONTINUE
719 END IF
720*
721 90 CONTINUE
722*
723 IF( ierr.NE.0 ) THEN
724 WRITE( nounit, fmt = 9999 )'Generator', ierr, n, jtype,
725 $ ioldsd
726 info = abs( ierr )
727 RETURN
728 END IF
729*
730 100 CONTINUE
731*
732 DO 110 i = 1, 7
733 result( i ) = -one
734 110 CONTINUE
735*
736* Call XLAENV to set the parameters used in ZLAQZ0
737*
738 CALL xlaenv( 12, 10 )
739 CALL xlaenv( 13, 12 )
740 CALL xlaenv( 14, 13 )
741 CALL xlaenv( 15, 2 )
742 CALL xlaenv( 17, 10 )
743*
744* Call ZGGEV3 to compute eigenvalues and eigenvectors.
745*
746 CALL zlacpy( ' ', n, n, a, lda, s, lda )
747 CALL zlacpy( ' ', n, n, b, lda, t, lda )
748 CALL zggev3( 'V', 'V', n, s, lda, t, lda, alpha, beta, q,
749 $ ldq, z, ldq, work, lwork, rwork, ierr )
750 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
751 result( 1 ) = ulpinv
752 WRITE( nounit, fmt = 9999 )'ZGGEV31', ierr, n, jtype,
753 $ ioldsd
754 info = abs( ierr )
755 GO TO 190
756 END IF
757*
758* Do the tests (1) and (2)
759*
760 CALL zget52( .true., n, a, lda, b, lda, q, ldq, alpha, beta,
761 $ work, rwork, result( 1 ) )
762 IF( result( 2 ).GT.thresh ) THEN
763 WRITE( nounit, fmt = 9998 )'Left', 'ZGGEV31',
764 $ result( 2 ), n, jtype, ioldsd
765 END IF
766*
767* Do the tests (3) and (4)
768*
769 CALL zget52( .false., n, a, lda, b, lda, z, ldq, alpha,
770 $ beta, work, rwork, result( 3 ) )
771 IF( result( 4 ).GT.thresh ) THEN
772 WRITE( nounit, fmt = 9998 )'Right', 'ZGGEV31',
773 $ result( 4 ), n, jtype, ioldsd
774 END IF
775*
776* Do test (5)
777*
778 CALL zlacpy( ' ', n, n, a, lda, s, lda )
779 CALL zlacpy( ' ', n, n, b, lda, t, lda )
780 CALL zggev3( 'N', 'N', n, s, lda, t, lda, alpha1, beta1, q,
781 $ ldq, z, ldq, work, lwork, rwork, ierr )
782 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
783 result( 1 ) = ulpinv
784 WRITE( nounit, fmt = 9999 )'ZGGEV32', ierr, n, jtype,
785 $ ioldsd
786 info = abs( ierr )
787 GO TO 190
788 END IF
789*
790 DO 120 j = 1, n
791 IF( alpha( j ).NE.alpha1( j ) .OR. beta( j ).NE.
792 $ beta1( j ) )result( 5 ) = ulpinv
793 120 CONTINUE
794*
795* Do test (6): Compute eigenvalues and left eigenvectors,
796* and test them
797*
798 CALL zlacpy( ' ', n, n, a, lda, s, lda )
799 CALL zlacpy( ' ', n, n, b, lda, t, lda )
800 CALL zggev3( 'V', 'N', n, s, lda, t, lda, alpha1, beta1, qe,
801 $ ldqe, z, ldq, work, lwork, rwork, ierr )
802 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
803 result( 1 ) = ulpinv
804 WRITE( nounit, fmt = 9999 )'ZGGEV33', ierr, n, jtype,
805 $ ioldsd
806 info = abs( ierr )
807 GO TO 190
808 END IF
809*
810 DO 130 j = 1, n
811 IF( alpha( j ).NE.alpha1( j ) .OR. beta( j ).NE.
812 $ beta1( j ) )result( 6 ) = ulpinv
813 130 CONTINUE
814*
815 DO 150 j = 1, n
816 DO 140 jc = 1, n
817 IF( q( j, jc ).NE.qe( j, jc ) )
818 $ result( 6 ) = ulpinv
819 140 CONTINUE
820 150 CONTINUE
821*
822* Do test (7): Compute eigenvalues and right eigenvectors,
823* and test them
824*
825 CALL zlacpy( ' ', n, n, a, lda, s, lda )
826 CALL zlacpy( ' ', n, n, b, lda, t, lda )
827 CALL zggev3( 'N', 'V', n, s, lda, t, lda, alpha1, beta1, q,
828 $ ldq, qe, ldqe, work, lwork, rwork, ierr )
829 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
830 result( 1 ) = ulpinv
831 WRITE( nounit, fmt = 9999 )'ZGGEV34', ierr, n, jtype,
832 $ ioldsd
833 info = abs( ierr )
834 GO TO 190
835 END IF
836*
837 DO 160 j = 1, n
838 IF( alpha( j ).NE.alpha1( j ) .OR. beta( j ).NE.
839 $ beta1( j ) )result( 7 ) = ulpinv
840 160 CONTINUE
841*
842 DO 180 j = 1, n
843 DO 170 jc = 1, n
844 IF( z( j, jc ).NE.qe( j, jc ) )
845 $ result( 7 ) = ulpinv
846 170 CONTINUE
847 180 CONTINUE
848*
849* End of Loop -- Check for RESULT(j) > THRESH
850*
851 190 CONTINUE
852*
853 ntestt = ntestt + 7
854*
855* Print out tests which fail.
856*
857 DO 200 jr = 1, 7
858 IF( result( jr ).GE.thresh ) THEN
859*
860* If this is the first test to fail,
861* print a header to the data file.
862*
863 IF( nerrs.EQ.0 ) THEN
864 WRITE( nounit, fmt = 9997 )'ZGV'
865*
866* Matrix types
867*
868 WRITE( nounit, fmt = 9996 )
869 WRITE( nounit, fmt = 9995 )
870 WRITE( nounit, fmt = 9994 )'Orthogonal'
871*
872* Tests performed
873*
874 WRITE( nounit, fmt = 9993 )
875*
876 END IF
877 nerrs = nerrs + 1
878 IF( result( jr ).LT.10000.0d0 ) THEN
879 WRITE( nounit, fmt = 9992 )n, jtype, ioldsd, jr,
880 $ result( jr )
881 ELSE
882 WRITE( nounit, fmt = 9991 )n, jtype, ioldsd, jr,
883 $ result( jr )
884 END IF
885 END IF
886 200 CONTINUE
887*
888 210 CONTINUE
889 220 CONTINUE
890*
891* Summary
892*
893 CALL alasvm( 'ZGV3', nounit, nerrs, ntestt, 0 )
894*
895 work( 1 ) = maxwrk
896*
897 RETURN
898*
899 9999 FORMAT( ' ZDRGEV3: ', a, ' returned INFO=', i6, '.', / 3x, 'N=',
900 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
901*
902 9998 FORMAT( ' ZDRGEV3: ', a, ' Eigenvectors from ', a,
903 $ ' incorrectly normalized.', / ' Bits of error=', 0p, g10.3,
904 $ ',', 3x, 'N=', i4, ', JTYPE=', i3, ', ISEED=(',
905 $ 3( i4, ',' ), i5, ')' )
906*
907 9997 FORMAT( / 1x, a3, ' -- Complex Generalized eigenvalue problem ',
908 $ 'driver' )
909*
910 9996 FORMAT( ' Matrix types (see ZDRGEV3 for details): ' )
911*
912 9995 FORMAT( ' Special Matrices:', 23x,
913 $ '(J''=transposed Jordan block)',
914 $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
915 $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
916 $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
917 $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
918 $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
919 $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
920 9994 FORMAT( ' Matrices Rotated by Random ', a, ' Matrices U, V:',
921 $ / ' 16=Transposed Jordan Blocks 19=geometric ',
922 $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
923 $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
924 $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
925 $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
926 $ '23=(small,large) 24=(small,small) 25=(large,large)',
927 $ / ' 26=random O(1) matrices.' )
928*
929 9993 FORMAT( / ' Tests performed: ',
930 $ / ' 1 = max | ( b A - a B )''*l | / const.,',
931 $ / ' 2 = | |VR(i)| - 1 | / ulp,',
932 $ / ' 3 = max | ( b A - a B )*r | / const.',
933 $ / ' 4 = | |VL(i)| - 1 | / ulp,',
934 $ / ' 5 = 0 if W same no matter if r or l computed,',
935 $ / ' 6 = 0 if l same no matter if l computed,',
936 $ / ' 7 = 0 if r same no matter if r computed,', / 1x )
937 9992 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
938 $ 4( i4, ',' ), ' result ', i2, ' is', 0p, f8.2 )
939 9991 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
940 $ 4( i4, ',' ), ' result ', i2, ' is', 1p, d10.3 )
941*
942* End of ZDRGEV3
943*
zggev3
subroutine zggev3(jobvl, jobvr, n, a, lda, b, ldb, alpha, beta, vl, ldvl, vr, ldvr, work, lwork, rwork, info)
ZGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (...
Definition zggev3.f:216

◆ zdrgsx()

subroutine zdrgsx ( integer nsize,
integer ncmax,
double precision thresh,
integer nin,
integer nout,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) b,
complex*16, dimension( lda, * ) ai,
complex*16, dimension( lda, * ) bi,
complex*16, dimension( lda, * ) z,
complex*16, dimension( lda, * ) q,
complex*16, dimension( * ) alpha,
complex*16, dimension( * ) beta,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) s,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer liwork,
logical, dimension( * ) bwork,
integer info )

ZDRGSX

Purpose:
!>
!> ZDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
!> problem expert driver ZGGESX.
!>
!> ZGGES factors A and B as Q*S*Z'  and Q*T*Z' , where ' means conjugate
!> transpose, S and T are  upper triangular (i.e., in generalized Schur
!> form), and Q and Z are unitary. It also computes the generalized
!> eigenvalues (alpha(j),beta(j)), j=1,...,n.  Thus,
!> w(j) = alpha(j)/beta(j) is a root of the characteristic equation
!>
!>                 det( A - w(j) B ) = 0
!>
!> Optionally it also reorders the eigenvalues so that a selected
!> cluster of eigenvalues appears in the leading diagonal block of the
!> Schur forms; computes a reciprocal condition number for the average
!> of the selected eigenvalues; and computes a reciprocal condition
!> number for the right and left deflating subspaces corresponding to
!> the selected eigenvalues.
!>
!> When ZDRGSX is called with NSIZE > 0, five (5) types of built-in
!> matrix pairs are used to test the routine ZGGESX.
!>
!> When ZDRGSX is called with NSIZE = 0, it reads in test matrix data
!> to test ZGGESX.
!> (need more details on what kind of read-in data are needed).
!>
!> For each matrix pair, the following tests will be performed and
!> compared with the threshold THRESH except for the tests (7) and (9):
!>
!> (1)   | A - Q S Z' | / ( |A| n ulp )
!>
!> (2)   | B - Q T Z' | / ( |B| n ulp )
!>
!> (3)   | I - QQ' | / ( n ulp )
!>
!> (4)   | I - ZZ' | / ( n ulp )
!>
!> (5)   if A is in Schur form (i.e. triangular form)
!>
!> (6)   maximum over j of D(j)  where:
!>
!>                     |alpha(j) - S(j,j)|        |beta(j) - T(j,j)|
!>           D(j) = ------------------------ + -----------------------
!>                  max(|alpha(j)|,|S(j,j)|)   max(|beta(j)|,|T(j,j)|)
!>
!> (7)   if sorting worked and SDIM is the number of eigenvalues
!>       which were selected.
!>
!> (8)   the estimated value DIF does not differ from the true values of
!>       Difu and Difl more than a factor 10*THRESH. If the estimate DIF
!>       equals zero the corresponding true values of Difu and Difl
!>       should be less than EPS*norm(A, B). If the true value of Difu
!>       and Difl equal zero, the estimate DIF should be less than
!>       EPS*norm(A, B).
!>
!> (9)   If INFO = N+3 is returned by ZGGESX, the reordering 
!>       and we check that DIF = PL = PR = 0 and that the true value of
!>       Difu and Difl is < EPS*norm(A, B). We count the events when
!>       INFO=N+3.
!>
!> For read-in test matrices, the same tests are run except that the
!> exact value for DIF (and PL) is input data.  Additionally, there is
!> one more test run for read-in test matrices:
!>
!> (10)  the estimated value PL does not differ from the true value of
!>       PLTRU more than a factor THRESH. If the estimate PL equals
!>       zero the corresponding true value of PLTRU should be less than
!>       EPS*norm(A, B). If the true value of PLTRU equal zero, the
!>       estimate PL should be less than EPS*norm(A, B).
!>
!> Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)
!> matrix pairs are generated and tested. NSIZE should be kept small.
!>
!> SVD (routine ZGESVD) is used for computing the true value of DIF_u
!> and DIF_l when testing the built-in test problems.
!>
!> Built-in Test Matrices
!> ======================
!>
!> All built-in test matrices are the 2 by 2 block of triangular
!> matrices
!>
!>          A = [ A11 A12 ]    and      B = [ B11 B12 ]
!>              [     A22 ]                 [     B22 ]
!>
!> where for different type of A11 and A22 are given as the following.
!> A12 and B12 are chosen so that the generalized Sylvester equation
!>
!>          A11*R - L*A22 = -A12
!>          B11*R - L*B22 = -B12
!>
!> have prescribed solution R and L.
!>
!> Type 1:  A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
!>          B11 = I_m, B22 = I_k
!>          where J_k(a,b) is the k-by-k Jordan block with ``a'' on
!>          diagonal and ``b'' on superdiagonal.
!>
!> Type 2:  A11 = (a_ij) = ( 2(.5-sin(i)) ) and
!>          B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
!>          A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
!>          B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
!>
!> Type 3:  A11, A22 and B11, B22 are chosen as for Type 2, but each
!>          second diagonal block in A_11 and each third diagonal block
!>          in A_22 are made as 2 by 2 blocks.
!>
!> Type 4:  A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
!>             for i=1,...,m,  j=1,...,m and
!>          A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
!>             for i=m+1,...,k,  j=m+1,...,k
!>
!> Type 5:  (A,B) and have potentially close or common eigenvalues and
!>          very large departure from block diagonality A_11 is chosen
!>          as the m x m leading submatrix of A_1:
!>                  |  1  b                            |
!>                  | -b  1                            |
!>                  |        1+d  b                    |
!>                  |         -b 1+d                   |
!>           A_1 =  |                  d  1            |
!>                  |                 -1  d            |
!>                  |                        -d  1     |
!>                  |                        -1 -d     |
!>                  |                               1  |
!>          and A_22 is chosen as the k x k leading submatrix of A_2:
!>                  | -1  b                            |
!>                  | -b -1                            |
!>                  |       1-d  b                     |
!>                  |       -b  1-d                    |
!>           A_2 =  |                 d 1+b            |
!>                  |               -1-b d             |
!>                  |                       -d  1+b    |
!>                  |                      -1+b  -d    |
!>                  |                              1-d |
!>          and matrix B are chosen as identity matrices (see DLATM5).
!>
!>
Parameters
[in]NSIZE
!>          NSIZE is INTEGER
!>          The maximum size of the matrices to use. NSIZE >= 0.
!>          If NSIZE = 0, no built-in tests matrices are used, but
!>          read-in test matrices are used to test DGGESX.
!>
[in]NCMAX
!>          NCMAX is INTEGER
!>          Maximum allowable NMAX for generating Kroneker matrix
!>          in call to ZLAKF2
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  THRESH >= 0.
!>
[in]NIN
!>          NIN is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          Used to store the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually used.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, B, AI, BI, Z and Q,
!>          LDA >= max( 1, NSIZE ). For the read-in test,
!>          LDA >= max( 1, N ), N is the size of the test matrices.
!>
[out]B
!>          B is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          Used to store the matrix whose eigenvalues are to be
!>          computed.  On exit, B contains the last matrix actually used.
!>
[out]AI
!>          AI is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          Copy of A, modified by ZGGESX.
!>
[out]BI
!>          BI is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          Copy of B, modified by ZGGESX.
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          Z holds the left Schur vectors computed by ZGGESX.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          Q holds the right Schur vectors computed by ZGGESX.
!>
[out]ALPHA
!>          ALPHA is COMPLEX*16 array, dimension (NSIZE)
!>
[out]BETA
!>          BETA is COMPLEX*16 array, dimension (NSIZE)
!>
!>          On exit, ALPHA/BETA are the eigenvalues.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC, LDC)
!>          Store the matrix generated by subroutine ZLAKF2, this is the
!>          matrix formed by Kronecker products used for estimating
!>          DIF.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (LDC)
!>          Singular values of C
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= 3*NSIZE*NSIZE/2
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array,
!>                                 dimension (5*NSIZE*NSIZE/2 - 4)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (LIWORK)
!>
[in]LIWORK
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK. LIWORK >= NSIZE + 2.
!>
[out]BWORK
!>          BWORK is LOGICAL array, dimension (NSIZE)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  A routine returned an error code.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 346 of file zdrgsx.f.

349*
350* -- LAPACK test routine --
351* -- LAPACK is a software package provided by Univ. of Tennessee, --
352* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
353*
354* .. Scalar Arguments ..
355 INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN,
356 $ NOUT, NSIZE
357 DOUBLE PRECISION THRESH
358* ..
359* .. Array Arguments ..
360 LOGICAL BWORK( * )
361 INTEGER IWORK( * )
362 DOUBLE PRECISION RWORK( * ), S( * )
363 COMPLEX*16 A( LDA, * ), AI( LDA, * ), ALPHA( * ),
364 $ B( LDA, * ), BETA( * ), BI( LDA, * ),
365 $ C( LDC, * ), Q( LDA, * ), WORK( * ),
366 $ Z( LDA, * )
367* ..
368*
369* =====================================================================
370*
371* .. Parameters ..
372 DOUBLE PRECISION ZERO, ONE, TEN
373 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 1.0d+1 )
374 COMPLEX*16 CZERO
375 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
376* ..
377* .. Local Scalars ..
378 LOGICAL ILABAD
379 CHARACTER SENSE
380 INTEGER BDSPAC, I, IFUNC, J, LINFO, MAXWRK, MINWRK, MM,
381 $ MN2, NERRS, NPTKNT, NTEST, NTESTT, PRTYPE, QBA,
382 $ QBB
383 DOUBLE PRECISION ABNRM, BIGNUM, DIFTRU, PLTRU, SMLNUM, TEMP1,
384 $ TEMP2, THRSH2, ULP, ULPINV, WEIGHT
385 COMPLEX*16 X
386* ..
387* .. Local Arrays ..
388 DOUBLE PRECISION DIFEST( 2 ), PL( 2 ), RESULT( 10 )
389* ..
390* .. External Functions ..
391 LOGICAL ZLCTSX
392 INTEGER ILAENV
393 DOUBLE PRECISION DLAMCH, ZLANGE
394 EXTERNAL zlctsx, ilaenv, dlamch, zlange
395* ..
396* .. External Subroutines ..
397 EXTERNAL alasvm, dlabad, xerbla, zgesvd, zget51, zggesx,
398 $ zlacpy, zlakf2, zlaset, zlatm5
399* ..
400* .. Scalars in Common ..
401 LOGICAL FS
402 INTEGER K, M, MPLUSN, N
403* ..
404* .. Common blocks ..
405 COMMON / mn / m, n, mplusn, k, fs
406* ..
407* .. Intrinsic Functions ..
408 INTRINSIC abs, dble, dimag, max, sqrt
409* ..
410* .. Statement Functions ..
411 DOUBLE PRECISION ABS1
412* ..
413* .. Statement Function definitions ..
414 abs1( x ) = abs( dble( x ) ) + abs( dimag( x ) )
415* ..
416* .. Executable Statements ..
417*
418* Check for errors
419*
420 info = 0
421 IF( nsize.LT.0 ) THEN
422 info = -1
423 ELSE IF( thresh.LT.zero ) THEN
424 info = -2
425 ELSE IF( nin.LE.0 ) THEN
426 info = -3
427 ELSE IF( nout.LE.0 ) THEN
428 info = -4
429 ELSE IF( lda.LT.1 .OR. lda.LT.nsize ) THEN
430 info = -6
431 ELSE IF( ldc.LT.1 .OR. ldc.LT.nsize*nsize / 2 ) THEN
432 info = -15
433 ELSE IF( liwork.LT.nsize+2 ) THEN
434 info = -21
435 END IF
436*
437* Compute workspace
438* (Note: Comments in the code beginning "Workspace:" describe the
439* minimal amount of workspace needed at that point in the code,
440* as well as the preferred amount for good performance.
441* NB refers to the optimal block size for the immediately
442* following subroutine, as returned by ILAENV.)
443*
444 minwrk = 1
445 IF( info.EQ.0 .AND. lwork.GE.1 ) THEN
446 minwrk = 3*nsize*nsize / 2
447*
448* workspace for cggesx
449*
450 maxwrk = nsize*( 1+ilaenv( 1, 'ZGEQRF', ' ', nsize, 1, nsize,
451 $ 0 ) )
452 maxwrk = max( maxwrk, nsize*( 1+ilaenv( 1, 'ZUNGQR', ' ',
453 $ nsize, 1, nsize, -1 ) ) )
454*
455* workspace for zgesvd
456*
457 bdspac = 3*nsize*nsize / 2
458 maxwrk = max( maxwrk, nsize*nsize*
459 $ ( 1+ilaenv( 1, 'ZGEBRD', ' ', nsize*nsize / 2,
460 $ nsize*nsize / 2, -1, -1 ) ) )
461 maxwrk = max( maxwrk, bdspac )
462*
463 maxwrk = max( maxwrk, minwrk )
464*
465 work( 1 ) = maxwrk
466 END IF
467*
468 IF( lwork.LT.minwrk )
469 $ info = -18
470*
471 IF( info.NE.0 ) THEN
472 CALL xerbla( 'ZDRGSX', -info )
473 RETURN
474 END IF
475*
476* Important constants
477*
478 ulp = dlamch( 'P' )
479 ulpinv = one / ulp
480 smlnum = dlamch( 'S' ) / ulp
481 bignum = one / smlnum
482 CALL dlabad( smlnum, bignum )
483 thrsh2 = ten*thresh
484 ntestt = 0
485 nerrs = 0
486*
487* Go to the tests for read-in matrix pairs
488*
489 ifunc = 0
490 IF( nsize.EQ.0 )
491 $ GO TO 70
492*
493* Test the built-in matrix pairs.
494* Loop over different functions (IFUNC) of ZGGESX, types (PRTYPE)
495* of test matrices, different size (M+N)
496*
497 prtype = 0
498 qba = 3
499 qbb = 4
500 weight = sqrt( ulp )
501*
502 DO 60 ifunc = 0, 3
503 DO 50 prtype = 1, 5
504 DO 40 m = 1, nsize - 1
505 DO 30 n = 1, nsize - m
506*
507 weight = one / weight
508 mplusn = m + n
509*
510* Generate test matrices
511*
512 fs = .true.
513 k = 0
514*
515 CALL zlaset( 'Full', mplusn, mplusn, czero, czero, ai,
516 $ lda )
517 CALL zlaset( 'Full', mplusn, mplusn, czero, czero, bi,
518 $ lda )
519*
520 CALL zlatm5( prtype, m, n, ai, lda, ai( m+1, m+1 ),
521 $ lda, ai( 1, m+1 ), lda, bi, lda,
522 $ bi( m+1, m+1 ), lda, bi( 1, m+1 ), lda,
523 $ q, lda, z, lda, weight, qba, qbb )
524*
525* Compute the Schur factorization and swapping the
526* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
527* Swapping is accomplished via the function ZLCTSX
528* which is supplied below.
529*
530 IF( ifunc.EQ.0 ) THEN
531 sense = 'N'
532 ELSE IF( ifunc.EQ.1 ) THEN
533 sense = 'E'
534 ELSE IF( ifunc.EQ.2 ) THEN
535 sense = 'V'
536 ELSE IF( ifunc.EQ.3 ) THEN
537 sense = 'B'
538 END IF
539*
540 CALL zlacpy( 'Full', mplusn, mplusn, ai, lda, a, lda )
541 CALL zlacpy( 'Full', mplusn, mplusn, bi, lda, b, lda )
542*
543 CALL zggesx( 'V', 'V', 'S', zlctsx, sense, mplusn, ai,
544 $ lda, bi, lda, mm, alpha, beta, q, lda, z,
545 $ lda, pl, difest, work, lwork, rwork,
546 $ iwork, liwork, bwork, linfo )
547*
548 IF( linfo.NE.0 .AND. linfo.NE.mplusn+2 ) THEN
549 result( 1 ) = ulpinv
550 WRITE( nout, fmt = 9999 )'ZGGESX', linfo, mplusn,
551 $ prtype
552 info = linfo
553 GO TO 30
554 END IF
555*
556* Compute the norm(A, B)
557*
558 CALL zlacpy( 'Full', mplusn, mplusn, ai, lda, work,
559 $ mplusn )
560 CALL zlacpy( 'Full', mplusn, mplusn, bi, lda,
561 $ work( mplusn*mplusn+1 ), mplusn )
562 abnrm = zlange( 'Fro', mplusn, 2*mplusn, work, mplusn,
563 $ rwork )
564*
565* Do tests (1) to (4)
566*
567 result( 2 ) = zero
568 CALL zget51( 1, mplusn, a, lda, ai, lda, q, lda, z,
569 $ lda, work, rwork, result( 1 ) )
570 CALL zget51( 1, mplusn, b, lda, bi, lda, q, lda, z,
571 $ lda, work, rwork, result( 2 ) )
572 CALL zget51( 3, mplusn, b, lda, bi, lda, q, lda, q,
573 $ lda, work, rwork, result( 3 ) )
574 CALL zget51( 3, mplusn, b, lda, bi, lda, z, lda, z,
575 $ lda, work, rwork, result( 4 ) )
576 ntest = 4
577*
578* Do tests (5) and (6): check Schur form of A and
579* compare eigenvalues with diagonals.
580*
581 temp1 = zero
582 result( 5 ) = zero
583 result( 6 ) = zero
584*
585 DO 10 j = 1, mplusn
586 ilabad = .false.
587 temp2 = ( abs1( alpha( j )-ai( j, j ) ) /
588 $ max( smlnum, abs1( alpha( j ) ),
589 $ abs1( ai( j, j ) ) )+
590 $ abs1( beta( j )-bi( j, j ) ) /
591 $ max( smlnum, abs1( beta( j ) ),
592 $ abs1( bi( j, j ) ) ) ) / ulp
593 IF( j.LT.mplusn ) THEN
594 IF( ai( j+1, j ).NE.zero ) THEN
595 ilabad = .true.
596 result( 5 ) = ulpinv
597 END IF
598 END IF
599 IF( j.GT.1 ) THEN
600 IF( ai( j, j-1 ).NE.zero ) THEN
601 ilabad = .true.
602 result( 5 ) = ulpinv
603 END IF
604 END IF
605 temp1 = max( temp1, temp2 )
606 IF( ilabad ) THEN
607 WRITE( nout, fmt = 9997 )j, mplusn, prtype
608 END IF
609 10 CONTINUE
610 result( 6 ) = temp1
611 ntest = ntest + 2
612*
613* Test (7) (if sorting worked)
614*
615 result( 7 ) = zero
616 IF( linfo.EQ.mplusn+3 ) THEN
617 result( 7 ) = ulpinv
618 ELSE IF( mm.NE.n ) THEN
619 result( 7 ) = ulpinv
620 END IF
621 ntest = ntest + 1
622*
623* Test (8): compare the estimated value DIF and its
624* value. first, compute the exact DIF.
625*
626 result( 8 ) = zero
627 mn2 = mm*( mplusn-mm )*2
628 IF( ifunc.GE.2 .AND. mn2.LE.ncmax*ncmax ) THEN
629*
630* Note: for either following two cases, there are
631* almost same number of test cases fail the test.
632*
633 CALL zlakf2( mm, mplusn-mm, ai, lda,
634 $ ai( mm+1, mm+1 ), bi,
635 $ bi( mm+1, mm+1 ), c, ldc )
636*
637 CALL zgesvd( 'N', 'N', mn2, mn2, c, ldc, s, work,
638 $ 1, work( 2 ), 1, work( 3 ), lwork-2,
639 $ rwork, info )
640 diftru = s( mn2 )
641*
642 IF( difest( 2 ).EQ.zero ) THEN
643 IF( diftru.GT.abnrm*ulp )
644 $ result( 8 ) = ulpinv
645 ELSE IF( diftru.EQ.zero ) THEN
646 IF( difest( 2 ).GT.abnrm*ulp )
647 $ result( 8 ) = ulpinv
648 ELSE IF( ( diftru.GT.thrsh2*difest( 2 ) ) .OR.
649 $ ( diftru*thrsh2.LT.difest( 2 ) ) ) THEN
650 result( 8 ) = max( diftru / difest( 2 ),
651 $ difest( 2 ) / diftru )
652 END IF
653 ntest = ntest + 1
654 END IF
655*
656* Test (9)
657*
658 result( 9 ) = zero
659 IF( linfo.EQ.( mplusn+2 ) ) THEN
660 IF( diftru.GT.abnrm*ulp )
661 $ result( 9 ) = ulpinv
662 IF( ( ifunc.GT.1 ) .AND. ( difest( 2 ).NE.zero ) )
663 $ result( 9 ) = ulpinv
664 IF( ( ifunc.EQ.1 ) .AND. ( pl( 1 ).NE.zero ) )
665 $ result( 9 ) = ulpinv
666 ntest = ntest + 1
667 END IF
668*
669 ntestt = ntestt + ntest
670*
671* Print out tests which fail.
672*
673 DO 20 j = 1, 9
674 IF( result( j ).GE.thresh ) THEN
675*
676* If this is the first test to fail,
677* print a header to the data file.
678*
679 IF( nerrs.EQ.0 ) THEN
680 WRITE( nout, fmt = 9996 )'ZGX'
681*
682* Matrix types
683*
684 WRITE( nout, fmt = 9994 )
685*
686* Tests performed
687*
688 WRITE( nout, fmt = 9993 )'unitary', '''',
689 $ 'transpose', ( '''', i = 1, 4 )
690*
691 END IF
692 nerrs = nerrs + 1
693 IF( result( j ).LT.10000.0d0 ) THEN
694 WRITE( nout, fmt = 9992 )mplusn, prtype,
695 $ weight, m, j, result( j )
696 ELSE
697 WRITE( nout, fmt = 9991 )mplusn, prtype,
698 $ weight, m, j, result( j )
699 END IF
700 END IF
701 20 CONTINUE
702*
703 30 CONTINUE
704 40 CONTINUE
705 50 CONTINUE
706 60 CONTINUE
707*
708 GO TO 150
709*
710 70 CONTINUE
711*
712* Read in data from file to check accuracy of condition estimation
713* Read input data until N=0
714*
715 nptknt = 0
716*
717 80 CONTINUE
718 READ( nin, fmt = *, END = 140 )mplusn
719 IF( mplusn.EQ.0 )
720 $ GO TO 140
721 READ( nin, fmt = *, END = 140 )n
722 DO 90 i = 1, mplusn
723 READ( nin, fmt = * )( ai( i, j ), j = 1, mplusn )
724 90 CONTINUE
725 DO 100 i = 1, mplusn
726 READ( nin, fmt = * )( bi( i, j ), j = 1, mplusn )
727 100 CONTINUE
728 READ( nin, fmt = * )pltru, diftru
729*
730 nptknt = nptknt + 1
731 fs = .true.
732 k = 0
733 m = mplusn - n
734*
735 CALL zlacpy( 'Full', mplusn, mplusn, ai, lda, a, lda )
736 CALL zlacpy( 'Full', mplusn, mplusn, bi, lda, b, lda )
737*
738* Compute the Schur factorization while swapping the
739* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
740*
741 CALL zggesx( 'V', 'V', 'S', zlctsx, 'B', mplusn, ai, lda, bi, lda,
742 $ mm, alpha, beta, q, lda, z, lda, pl, difest, work,
743 $ lwork, rwork, iwork, liwork, bwork, linfo )
744*
745 IF( linfo.NE.0 .AND. linfo.NE.mplusn+2 ) THEN
746 result( 1 ) = ulpinv
747 WRITE( nout, fmt = 9998 )'ZGGESX', linfo, mplusn, nptknt
748 GO TO 130
749 END IF
750*
751* Compute the norm(A, B)
752* (should this be norm of (A,B) or (AI,BI)?)
753*
754 CALL zlacpy( 'Full', mplusn, mplusn, ai, lda, work, mplusn )
755 CALL zlacpy( 'Full', mplusn, mplusn, bi, lda,
756 $ work( mplusn*mplusn+1 ), mplusn )
757 abnrm = zlange( 'Fro', mplusn, 2*mplusn, work, mplusn, rwork )
758*
759* Do tests (1) to (4)
760*
761 CALL zget51( 1, mplusn, a, lda, ai, lda, q, lda, z, lda, work,
762 $ rwork, result( 1 ) )
763 CALL zget51( 1, mplusn, b, lda, bi, lda, q, lda, z, lda, work,
764 $ rwork, result( 2 ) )
765 CALL zget51( 3, mplusn, b, lda, bi, lda, q, lda, q, lda, work,
766 $ rwork, result( 3 ) )
767 CALL zget51( 3, mplusn, b, lda, bi, lda, z, lda, z, lda, work,
768 $ rwork, result( 4 ) )
769*
770* Do tests (5) and (6): check Schur form of A and compare
771* eigenvalues with diagonals.
772*
773 ntest = 6
774 temp1 = zero
775 result( 5 ) = zero
776 result( 6 ) = zero
777*
778 DO 110 j = 1, mplusn
779 ilabad = .false.
780 temp2 = ( abs1( alpha( j )-ai( j, j ) ) /
781 $ max( smlnum, abs1( alpha( j ) ), abs1( ai( j, j ) ) )+
782 $ abs1( beta( j )-bi( j, j ) ) /
783 $ max( smlnum, abs1( beta( j ) ), abs1( bi( j, j ) ) ) )
784 $ / ulp
785 IF( j.LT.mplusn ) THEN
786 IF( ai( j+1, j ).NE.zero ) THEN
787 ilabad = .true.
788 result( 5 ) = ulpinv
789 END IF
790 END IF
791 IF( j.GT.1 ) THEN
792 IF( ai( j, j-1 ).NE.zero ) THEN
793 ilabad = .true.
794 result( 5 ) = ulpinv
795 END IF
796 END IF
797 temp1 = max( temp1, temp2 )
798 IF( ilabad ) THEN
799 WRITE( nout, fmt = 9997 )j, mplusn, nptknt
800 END IF
801 110 CONTINUE
802 result( 6 ) = temp1
803*
804* Test (7) (if sorting worked) <--------- need to be checked.
805*
806 ntest = 7
807 result( 7 ) = zero
808 IF( linfo.EQ.mplusn+3 )
809 $ result( 7 ) = ulpinv
810*
811* Test (8): compare the estimated value of DIF and its true value.
812*
813 ntest = 8
814 result( 8 ) = zero
815 IF( difest( 2 ).EQ.zero ) THEN
816 IF( diftru.GT.abnrm*ulp )
817 $ result( 8 ) = ulpinv
818 ELSE IF( diftru.EQ.zero ) THEN
819 IF( difest( 2 ).GT.abnrm*ulp )
820 $ result( 8 ) = ulpinv
821 ELSE IF( ( diftru.GT.thrsh2*difest( 2 ) ) .OR.
822 $ ( diftru*thrsh2.LT.difest( 2 ) ) ) THEN
823 result( 8 ) = max( diftru / difest( 2 ), difest( 2 ) / diftru )
824 END IF
825*
826* Test (9)
827*
828 ntest = 9
829 result( 9 ) = zero
830 IF( linfo.EQ.( mplusn+2 ) ) THEN
831 IF( diftru.GT.abnrm*ulp )
832 $ result( 9 ) = ulpinv
833 IF( ( ifunc.GT.1 ) .AND. ( difest( 2 ).NE.zero ) )
834 $ result( 9 ) = ulpinv
835 IF( ( ifunc.EQ.1 ) .AND. ( pl( 1 ).NE.zero ) )
836 $ result( 9 ) = ulpinv
837 END IF
838*
839* Test (10): compare the estimated value of PL and it true value.
840*
841 ntest = 10
842 result( 10 ) = zero
843 IF( pl( 1 ).EQ.zero ) THEN
844 IF( pltru.GT.abnrm*ulp )
845 $ result( 10 ) = ulpinv
846 ELSE IF( pltru.EQ.zero ) THEN
847 IF( pl( 1 ).GT.abnrm*ulp )
848 $ result( 10 ) = ulpinv
849 ELSE IF( ( pltru.GT.thresh*pl( 1 ) ) .OR.
850 $ ( pltru*thresh.LT.pl( 1 ) ) ) THEN
851 result( 10 ) = ulpinv
852 END IF
853*
854 ntestt = ntestt + ntest
855*
856* Print out tests which fail.
857*
858 DO 120 j = 1, ntest
859 IF( result( j ).GE.thresh ) THEN
860*
861* If this is the first test to fail,
862* print a header to the data file.
863*
864 IF( nerrs.EQ.0 ) THEN
865 WRITE( nout, fmt = 9996 )'ZGX'
866*
867* Matrix types
868*
869 WRITE( nout, fmt = 9995 )
870*
871* Tests performed
872*
873 WRITE( nout, fmt = 9993 )'unitary', '''', 'transpose',
874 $ ( '''', i = 1, 4 )
875*
876 END IF
877 nerrs = nerrs + 1
878 IF( result( j ).LT.10000.0d0 ) THEN
879 WRITE( nout, fmt = 9990 )nptknt, mplusn, j, result( j )
880 ELSE
881 WRITE( nout, fmt = 9989 )nptknt, mplusn, j, result( j )
882 END IF
883 END IF
884*
885 120 CONTINUE
886*
887 130 CONTINUE
888 GO TO 80
889 140 CONTINUE
890*
891 150 CONTINUE
892*
893* Summary
894*
895 CALL alasvm( 'ZGX', nout, nerrs, ntestt, 0 )
896*
897 work( 1 ) = maxwrk
898*
899 RETURN
900*
901 9999 FORMAT( ' ZDRGSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
902 $ i6, ', JTYPE=', i6, ')' )
903*
904 9998 FORMAT( ' ZDRGSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
905 $ i6, ', Input Example #', i2, ')' )
906*
907 9997 FORMAT( ' ZDRGSX: S not in Schur form at eigenvalue ', i6, '.',
908 $ / 9x, 'N=', i6, ', JTYPE=', i6, ')' )
909*
910 9996 FORMAT( / 1x, a3, ' -- Complex Expert Generalized Schur form',
911 $ ' problem driver' )
912*
913 9995 FORMAT( 'Input Example' )
914*
915 9994 FORMAT( ' Matrix types: ', /
916 $ ' 1: A is a block diagonal matrix of Jordan blocks ',
917 $ 'and B is the identity ', / ' matrix, ',
918 $ / ' 2: A and B are upper triangular matrices, ',
919 $ / ' 3: A and B are as type 2, but each second diagonal ',
920 $ 'block in A_11 and ', /
921 $ ' each third diaongal block in A_22 are 2x2 blocks,',
922 $ / ' 4: A and B are block diagonal matrices, ',
923 $ / ' 5: (A,B) has potentially close or common ',
924 $ 'eigenvalues.', / )
925*
926 9993 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
927 $ 'Q and Z are ', a, ',', / 19x,
928 $ ' a is alpha, b is beta, and ', a, ' means ', a, '.)',
929 $ / ' 1 = | A - Q S Z', a,
930 $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', a,
931 $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', a,
932 $ ' | / ( n ulp ) 4 = | I - ZZ', a,
933 $ ' | / ( n ulp )', / ' 5 = 1/ULP if A is not in ',
934 $ 'Schur form S', / ' 6 = difference between (alpha,beta)',
935 $ ' and diagonals of (S,T)', /
936 $ ' 7 = 1/ULP if SDIM is not the correct number of ',
937 $ 'selected eigenvalues', /
938 $ ' 8 = 1/ULP if DIFEST/DIFTRU > 10*THRESH or ',
939 $ 'DIFTRU/DIFEST > 10*THRESH',
940 $ / ' 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B) ',
941 $ 'when reordering fails', /
942 $ ' 10 = 1/ULP if PLEST/PLTRU > THRESH or ',
943 $ 'PLTRU/PLEST > THRESH', /
944 $ ' ( Test 10 is only for input examples )', / )
945 9992 FORMAT( ' Matrix order=', i2, ', type=', i2, ', a=', d10.3,
946 $ ', order(A_11)=', i2, ', result ', i2, ' is ', 0p, f8.2 )
947 9991 FORMAT( ' Matrix order=', i2, ', type=', i2, ', a=', d10.3,
948 $ ', order(A_11)=', i2, ', result ', i2, ' is ', 0p, d10.3 )
949 9990 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
950 $ ' result ', i2, ' is', 0p, f8.2 )
951 9989 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
952 $ ' result ', i2, ' is', 1p, d10.3 )
953*
954* End of ZDRGSX
955*
zggesx
subroutine zggesx(jobvsl, jobvsr, sort, selctg, sense, n, a, lda, b, ldb, sdim, alpha, beta, vsl, ldvsl, vsr, ldvsr, rconde, rcondv, work, lwork, rwork, iwork, liwork, bwork, info)
ZGGESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition zggesx.f:330
zgesvd
subroutine zgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, info)
ZGESVD computes the singular value decomposition (SVD) for GE matrices
Definition zgesvd.f:214
zlctsx
logical function zlctsx(alpha, beta)
ZLCTSX
Definition zlctsx.f:57
zlatm5
subroutine zlatm5(prtype, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, r, ldr, l, ldl, alpha, qblcka, qblckb)
ZLATM5
Definition zlatm5.f:268
zlakf2
subroutine zlakf2(m, n, a, lda, b, d, e, z, ldz)
ZLAKF2
Definition zlakf2.f:105

◆ zdrgvx()

subroutine zdrgvx ( integer nsize,
double precision thresh,
integer nin,
integer nout,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) b,
complex*16, dimension( lda, * ) ai,
complex*16, dimension( lda, * ) bi,
complex*16, dimension( * ) alpha,
complex*16, dimension( * ) beta,
complex*16, dimension( lda, * ) vl,
complex*16, dimension( lda, * ) vr,
integer ilo,
integer ihi,
double precision, dimension( * ) lscale,
double precision, dimension( * ) rscale,
double precision, dimension( * ) s,
double precision, dimension( * ) dtru,
double precision, dimension( * ) dif,
double precision, dimension( * ) diftru,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer liwork,
double precision, dimension( 4 ) result,
logical, dimension( * ) bwork,
integer info )

ZDRGVX

Purpose:
!>
!> ZDRGVX checks the nonsymmetric generalized eigenvalue problem
!> expert driver ZGGEVX.
!>
!> ZGGEVX computes the generalized eigenvalues, (optionally) the left
!> and/or right eigenvectors, (optionally) computes a balancing
!> transformation to improve the conditioning, and (optionally)
!> reciprocal condition numbers for the eigenvalues and eigenvectors.
!>
!> When ZDRGVX is called with NSIZE > 0, two types of test matrix pairs
!> are generated by the subroutine DLATM6 and test the driver ZGGEVX.
!> The test matrices have the known exact condition numbers for
!> eigenvalues. For the condition numbers of the eigenvectors
!> corresponding the first and last eigenvalues are also know
!> ``exactly'' (see ZLATM6).
!> For each matrix pair, the following tests will be performed and
!> compared with the threshold THRESH.
!>
!> (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
!>
!>    | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
!>
!>     where l**H is the conjugate tranpose of l.
!>
!> (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
!>
!>       | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
!>
!> (3) The condition number S(i) of eigenvalues computed by ZGGEVX
!>     differs less than a factor THRESH from the exact S(i) (see
!>     ZLATM6).
!>
!> (4) DIF(i) computed by ZTGSNA differs less than a factor 10*THRESH
!>     from the exact value (for the 1st and 5th vectors only).
!>
!> Test Matrices
!> =============
!>
!> Two kinds of test matrix pairs
!>          (A, B) = inverse(YH) * (Da, Db) * inverse(X)
!> are used in the tests:
!>
!> 1: Da = 1+a   0    0    0    0    Db = 1   0   0   0   0
!>          0   2+a   0    0    0         0   1   0   0   0
!>          0    0   3+a   0    0         0   0   1   0   0
!>          0    0    0   4+a   0         0   0   0   1   0
!>          0    0    0    0   5+a ,      0   0   0   0   1 , and
!>
!> 2: Da =  1   -1    0    0    0    Db = 1   0   0   0   0
!>          1    1    0    0    0         0   1   0   0   0
!>          0    0    1    0    0         0   0   1   0   0
!>          0    0    0   1+a  1+b        0   0   0   1   0
!>          0    0    0  -1-b  1+a ,      0   0   0   0   1 .
!>
!> In both cases the same inverse(YH) and inverse(X) are used to compute
!> (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
!>
!> YH:  =  1    0   -y    y   -y    X =  1   0  -x  -x   x
!>         0    1   -y    y   -y         0   1   x  -x  -x
!>         0    0    1    0    0         0   0   1   0   0
!>         0    0    0    1    0         0   0   0   1   0
!>         0    0    0    0    1,        0   0   0   0   1 , where
!>
!> a, b, x and y will have all values independently of each other from
!> { sqrt(sqrt(ULP)),  0.1,  1,  10,  1/sqrt(sqrt(ULP)) }.
!>
Parameters
[in]NSIZE
!>          NSIZE is INTEGER
!>          The number of sizes of matrices to use.  NSIZE must be at
!>          least zero. If it is zero, no randomly generated matrices
!>          are tested, but any test matrices read from NIN will be
!>          tested.  If it is not zero, then N = 5.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NIN
!>          NIN is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually used.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, B, AI, BI, Ao, and Bo.
!>          It must be at least 1 and at least NSIZE.
!>
[out]B
!>          B is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, B contains the last matrix actually used.
!>
[out]AI
!>          AI is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          Copy of A, modified by ZGGEVX.
!>
[out]BI
!>          BI is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          Copy of B, modified by ZGGEVX.
!>
[out]ALPHA
!>          ALPHA is COMPLEX*16 array, dimension (NSIZE)
!>
[out]BETA
!>          BETA is COMPLEX*16 array, dimension (NSIZE)
!>
!>          On exit, ALPHA/BETA are the eigenvalues.
!>
[out]VL
!>          VL is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          VL holds the left eigenvectors computed by ZGGEVX.
!>
[out]VR
!>          VR is COMPLEX*16 array, dimension (LDA, NSIZE)
!>          VR holds the right eigenvectors computed by ZGGEVX.
!>
[out]ILO
!>          ILO is INTEGER
!>
[out]IHI
!>          IHI is INTEGER
!>
[out]LSCALE
!>          LSCALE is DOUBLE PRECISION array, dimension (N)
!>
[out]RSCALE
!>          RSCALE is DOUBLE PRECISION array, dimension (N)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (N)
!>
[out]DTRU
!>          DTRU is DOUBLE PRECISION array, dimension (N)
!>
[out]DIF
!>          DIF is DOUBLE PRECISION array, dimension (N)
!>
[out]DIFTRU
!>          DIFTRU is DOUBLE PRECISION array, dimension (N)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          Leading dimension of WORK.  LWORK >= 2*N*N + 2*N
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (6*N)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (LIWORK)
!>
[in]LIWORK
!>          LIWORK is INTEGER
!>          Leading dimension of IWORK.  LIWORK >= N+2.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>
[out]BWORK
!>          BWORK is LOGICAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  A routine returned an error code.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 293 of file zdrgvx.f.

297*
298* -- LAPACK test routine --
299* -- LAPACK is a software package provided by Univ. of Tennessee, --
300* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
301*
302* .. Scalar Arguments ..
303 INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT,
304 $ NSIZE
305 DOUBLE PRECISION THRESH
306* ..
307* .. Array Arguments ..
308 LOGICAL BWORK( * )
309 INTEGER IWORK( * )
310 DOUBLE PRECISION DIF( * ), DIFTRU( * ), DTRU( * ), LSCALE( * ),
311 $ RESULT( 4 ), RSCALE( * ), RWORK( * ), S( * )
312 COMPLEX*16 A( LDA, * ), AI( LDA, * ), ALPHA( * ),
313 $ B( LDA, * ), BETA( * ), BI( LDA, * ),
314 $ VL( LDA, * ), VR( LDA, * ), WORK( * )
315* ..
316*
317* =====================================================================
318*
319* .. Parameters ..
320 DOUBLE PRECISION ZERO, ONE, TEN, TNTH, HALF
321 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 1.0d+1,
322 $ tnth = 1.0d-1, half = 0.5d+0 )
323* ..
324* .. Local Scalars ..
325 INTEGER I, IPTYPE, IWA, IWB, IWX, IWY, J, LINFO,
326 $ MAXWRK, MINWRK, N, NERRS, NMAX, NPTKNT, NTESTT
327 DOUBLE PRECISION ABNORM, ANORM, BNORM, RATIO1, RATIO2, THRSH2,
328 $ ULP, ULPINV
329* ..
330* .. Local Arrays ..
331 COMPLEX*16 WEIGHT( 5 )
332* ..
333* .. External Functions ..
334 INTEGER ILAENV
335 DOUBLE PRECISION DLAMCH, ZLANGE
336 EXTERNAL ilaenv, dlamch, zlange
337* ..
338* .. External Subroutines ..
339 EXTERNAL alasvm, xerbla, zget52, zggevx, zlacpy, zlatm6
340* ..
341* .. Intrinsic Functions ..
342 INTRINSIC abs, dcmplx, max, sqrt
343* ..
344* .. Executable Statements ..
345*
346* Check for errors
347*
348 info = 0
349*
350 nmax = 5
351*
352 IF( nsize.LT.0 ) THEN
353 info = -1
354 ELSE IF( thresh.LT.zero ) THEN
355 info = -2
356 ELSE IF( nin.LE.0 ) THEN
357 info = -3
358 ELSE IF( nout.LE.0 ) THEN
359 info = -4
360 ELSE IF( lda.LT.1 .OR. lda.LT.nmax ) THEN
361 info = -6
362 ELSE IF( liwork.LT.nmax+2 ) THEN
363 info = -26
364 END IF
365*
366* Compute workspace
367* (Note: Comments in the code beginning "Workspace:" describe the
368* minimal amount of workspace needed at that point in the code,
369* as well as the preferred amount for good performance.
370* NB refers to the optimal block size for the immediately
371* following subroutine, as returned by ILAENV.)
372*
373 minwrk = 1
374 IF( info.EQ.0 .AND. lwork.GE.1 ) THEN
375 minwrk = 2*nmax*( nmax+1 )
376 maxwrk = nmax*( 1+ilaenv( 1, 'ZGEQRF', ' ', nmax, 1, nmax,
377 $ 0 ) )
378 maxwrk = max( maxwrk, 2*nmax*( nmax+1 ) )
379 work( 1 ) = maxwrk
380 END IF
381*
382 IF( lwork.LT.minwrk )
383 $ info = -23
384*
385 IF( info.NE.0 ) THEN
386 CALL xerbla( 'ZDRGVX', -info )
387 RETURN
388 END IF
389*
390 n = 5
391 ulp = dlamch( 'P' )
392 ulpinv = one / ulp
393 thrsh2 = ten*thresh
394 nerrs = 0
395 nptknt = 0
396 ntestt = 0
397*
398 IF( nsize.EQ.0 )
399 $ GO TO 90
400*
401* Parameters used for generating test matrices.
402*
403 weight( 1 ) = dcmplx( tnth, zero )
404 weight( 2 ) = dcmplx( half, zero )
405 weight( 3 ) = one
406 weight( 4 ) = one / weight( 2 )
407 weight( 5 ) = one / weight( 1 )
408*
409 DO 80 iptype = 1, 2
410 DO 70 iwa = 1, 5
411 DO 60 iwb = 1, 5
412 DO 50 iwx = 1, 5
413 DO 40 iwy = 1, 5
414*
415* generated a pair of test matrix
416*
417 CALL zlatm6( iptype, 5, a, lda, b, vr, lda, vl,
418 $ lda, weight( iwa ), weight( iwb ),
419 $ weight( iwx ), weight( iwy ), dtru,
420 $ diftru )
421*
422* Compute eigenvalues/eigenvectors of (A, B).
423* Compute eigenvalue/eigenvector condition numbers
424* using computed eigenvectors.
425*
426 CALL zlacpy( 'F', n, n, a, lda, ai, lda )
427 CALL zlacpy( 'F', n, n, b, lda, bi, lda )
428*
429 CALL zggevx( 'N', 'V', 'V', 'B', n, ai, lda, bi,
430 $ lda, alpha, beta, vl, lda, vr, lda,
431 $ ilo, ihi, lscale, rscale, anorm,
432 $ bnorm, s, dif, work, lwork, rwork,
433 $ iwork, bwork, linfo )
434 IF( linfo.NE.0 ) THEN
435 WRITE( nout, fmt = 9999 )'ZGGEVX', linfo, n,
436 $ iptype, iwa, iwb, iwx, iwy
437 GO TO 30
438 END IF
439*
440* Compute the norm(A, B)
441*
442 CALL zlacpy( 'Full', n, n, ai, lda, work, n )
443 CALL zlacpy( 'Full', n, n, bi, lda, work( n*n+1 ),
444 $ n )
445 abnorm = zlange( 'Fro', n, 2*n, work, n, rwork )
446*
447* Tests (1) and (2)
448*
449 result( 1 ) = zero
450 CALL zget52( .true., n, a, lda, b, lda, vl, lda,
451 $ alpha, beta, work, rwork,
452 $ result( 1 ) )
453 IF( result( 2 ).GT.thresh ) THEN
454 WRITE( nout, fmt = 9998 )'Left', 'ZGGEVX',
455 $ result( 2 ), n, iptype, iwa, iwb, iwx, iwy
456 END IF
457*
458 result( 2 ) = zero
459 CALL zget52( .false., n, a, lda, b, lda, vr, lda,
460 $ alpha, beta, work, rwork,
461 $ result( 2 ) )
462 IF( result( 3 ).GT.thresh ) THEN
463 WRITE( nout, fmt = 9998 )'Right', 'ZGGEVX',
464 $ result( 3 ), n, iptype, iwa, iwb, iwx, iwy
465 END IF
466*
467* Test (3)
468*
469 result( 3 ) = zero
470 DO 10 i = 1, n
471 IF( s( i ).EQ.zero ) THEN
472 IF( dtru( i ).GT.abnorm*ulp )
473 $ result( 3 ) = ulpinv
474 ELSE IF( dtru( i ).EQ.zero ) THEN
475 IF( s( i ).GT.abnorm*ulp )
476 $ result( 3 ) = ulpinv
477 ELSE
478 rwork( i ) = max( abs( dtru( i ) / s( i ) ),
479 $ abs( s( i ) / dtru( i ) ) )
480 result( 3 ) = max( result( 3 ), rwork( i ) )
481 END IF
482 10 CONTINUE
483*
484* Test (4)
485*
486 result( 4 ) = zero
487 IF( dif( 1 ).EQ.zero ) THEN
488 IF( diftru( 1 ).GT.abnorm*ulp )
489 $ result( 4 ) = ulpinv
490 ELSE IF( diftru( 1 ).EQ.zero ) THEN
491 IF( dif( 1 ).GT.abnorm*ulp )
492 $ result( 4 ) = ulpinv
493 ELSE IF( dif( 5 ).EQ.zero ) THEN
494 IF( diftru( 5 ).GT.abnorm*ulp )
495 $ result( 4 ) = ulpinv
496 ELSE IF( diftru( 5 ).EQ.zero ) THEN
497 IF( dif( 5 ).GT.abnorm*ulp )
498 $ result( 4 ) = ulpinv
499 ELSE
500 ratio1 = max( abs( diftru( 1 ) / dif( 1 ) ),
501 $ abs( dif( 1 ) / diftru( 1 ) ) )
502 ratio2 = max( abs( diftru( 5 ) / dif( 5 ) ),
503 $ abs( dif( 5 ) / diftru( 5 ) ) )
504 result( 4 ) = max( ratio1, ratio2 )
505 END IF
506*
507 ntestt = ntestt + 4
508*
509* Print out tests which fail.
510*
511 DO 20 j = 1, 4
512 IF( ( result( j ).GE.thrsh2 .AND. j.GE.4 ) .OR.
513 $ ( result( j ).GE.thresh .AND. j.LE.3 ) )
514 $ THEN
515*
516* If this is the first test to fail,
517* print a header to the data file.
518*
519 IF( nerrs.EQ.0 ) THEN
520 WRITE( nout, fmt = 9997 )'ZXV'
521*
522* Print out messages for built-in examples
523*
524* Matrix types
525*
526 WRITE( nout, fmt = 9995 )
527 WRITE( nout, fmt = 9994 )
528 WRITE( nout, fmt = 9993 )
529*
530* Tests performed
531*
532 WRITE( nout, fmt = 9992 )'''',
533 $ 'transpose', ''''
534*
535 END IF
536 nerrs = nerrs + 1
537 IF( result( j ).LT.10000.0d0 ) THEN
538 WRITE( nout, fmt = 9991 )iptype, iwa,
539 $ iwb, iwx, iwy, j, result( j )
540 ELSE
541 WRITE( nout, fmt = 9990 )iptype, iwa,
542 $ iwb, iwx, iwy, j, result( j )
543 END IF
544 END IF
545 20 CONTINUE
546*
547 30 CONTINUE
548*
549 40 CONTINUE
550 50 CONTINUE
551 60 CONTINUE
552 70 CONTINUE
553 80 CONTINUE
554*
555 GO TO 150
556*
557 90 CONTINUE
558*
559* Read in data from file to check accuracy of condition estimation
560* Read input data until N=0
561*
562 READ( nin, fmt = *, END = 150 )n
563 IF( n.EQ.0 )
564 $ GO TO 150
565 DO 100 i = 1, n
566 READ( nin, fmt = * )( a( i, j ), j = 1, n )
567 100 CONTINUE
568 DO 110 i = 1, n
569 READ( nin, fmt = * )( b( i, j ), j = 1, n )
570 110 CONTINUE
571 READ( nin, fmt = * )( dtru( i ), i = 1, n )
572 READ( nin, fmt = * )( diftru( i ), i = 1, n )
573*
574 nptknt = nptknt + 1
575*
576* Compute eigenvalues/eigenvectors of (A, B).
577* Compute eigenvalue/eigenvector condition numbers
578* using computed eigenvectors.
579*
580 CALL zlacpy( 'F', n, n, a, lda, ai, lda )
581 CALL zlacpy( 'F', n, n, b, lda, bi, lda )
582*
583 CALL zggevx( 'N', 'V', 'V', 'B', n, ai, lda, bi, lda, alpha, beta,
584 $ vl, lda, vr, lda, ilo, ihi, lscale, rscale, anorm,
585 $ bnorm, s, dif, work, lwork, rwork, iwork, bwork,
586 $ linfo )
587*
588 IF( linfo.NE.0 ) THEN
589 WRITE( nout, fmt = 9987 )'ZGGEVX', linfo, n, nptknt
590 GO TO 140
591 END IF
592*
593* Compute the norm(A, B)
594*
595 CALL zlacpy( 'Full', n, n, ai, lda, work, n )
596 CALL zlacpy( 'Full', n, n, bi, lda, work( n*n+1 ), n )
597 abnorm = zlange( 'Fro', n, 2*n, work, n, rwork )
598*
599* Tests (1) and (2)
600*
601 result( 1 ) = zero
602 CALL zget52( .true., n, a, lda, b, lda, vl, lda, alpha, beta,
603 $ work, rwork, result( 1 ) )
604 IF( result( 2 ).GT.thresh ) THEN
605 WRITE( nout, fmt = 9986 )'Left', 'ZGGEVX', result( 2 ), n,
606 $ nptknt
607 END IF
608*
609 result( 2 ) = zero
610 CALL zget52( .false., n, a, lda, b, lda, vr, lda, alpha, beta,
611 $ work, rwork, result( 2 ) )
612 IF( result( 3 ).GT.thresh ) THEN
613 WRITE( nout, fmt = 9986 )'Right', 'ZGGEVX', result( 3 ), n,
614 $ nptknt
615 END IF
616*
617* Test (3)
618*
619 result( 3 ) = zero
620 DO 120 i = 1, n
621 IF( s( i ).EQ.zero ) THEN
622 IF( dtru( i ).GT.abnorm*ulp )
623 $ result( 3 ) = ulpinv
624 ELSE IF( dtru( i ).EQ.zero ) THEN
625 IF( s( i ).GT.abnorm*ulp )
626 $ result( 3 ) = ulpinv
627 ELSE
628 rwork( i ) = max( abs( dtru( i ) / s( i ) ),
629 $ abs( s( i ) / dtru( i ) ) )
630 result( 3 ) = max( result( 3 ), rwork( i ) )
631 END IF
632 120 CONTINUE
633*
634* Test (4)
635*
636 result( 4 ) = zero
637 IF( dif( 1 ).EQ.zero ) THEN
638 IF( diftru( 1 ).GT.abnorm*ulp )
639 $ result( 4 ) = ulpinv
640 ELSE IF( diftru( 1 ).EQ.zero ) THEN
641 IF( dif( 1 ).GT.abnorm*ulp )
642 $ result( 4 ) = ulpinv
643 ELSE IF( dif( 5 ).EQ.zero ) THEN
644 IF( diftru( 5 ).GT.abnorm*ulp )
645 $ result( 4 ) = ulpinv
646 ELSE IF( diftru( 5 ).EQ.zero ) THEN
647 IF( dif( 5 ).GT.abnorm*ulp )
648 $ result( 4 ) = ulpinv
649 ELSE
650 ratio1 = max( abs( diftru( 1 ) / dif( 1 ) ),
651 $ abs( dif( 1 ) / diftru( 1 ) ) )
652 ratio2 = max( abs( diftru( 5 ) / dif( 5 ) ),
653 $ abs( dif( 5 ) / diftru( 5 ) ) )
654 result( 4 ) = max( ratio1, ratio2 )
655 END IF
656*
657 ntestt = ntestt + 4
658*
659* Print out tests which fail.
660*
661 DO 130 j = 1, 4
662 IF( result( j ).GE.thrsh2 ) THEN
663*
664* If this is the first test to fail,
665* print a header to the data file.
666*
667 IF( nerrs.EQ.0 ) THEN
668 WRITE( nout, fmt = 9997 )'ZXV'
669*
670* Print out messages for built-in examples
671*
672* Matrix types
673*
674 WRITE( nout, fmt = 9996 )
675*
676* Tests performed
677*
678 WRITE( nout, fmt = 9992 )'''', 'transpose', ''''
679*
680 END IF
681 nerrs = nerrs + 1
682 IF( result( j ).LT.10000.0d0 ) THEN
683 WRITE( nout, fmt = 9989 )nptknt, n, j, result( j )
684 ELSE
685 WRITE( nout, fmt = 9988 )nptknt, n, j, result( j )
686 END IF
687 END IF
688 130 CONTINUE
689*
690 140 CONTINUE
691*
692 GO TO 90
693 150 CONTINUE
694*
695* Summary
696*
697 CALL alasvm( 'ZXV', nout, nerrs, ntestt, 0 )
698*
699 work( 1 ) = maxwrk
700*
701 RETURN
702*
703 9999 FORMAT( ' ZDRGVX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
704 $ i6, ', JTYPE=', i6, ')' )
705*
706 9998 FORMAT( ' ZDRGVX: ', a, ' Eigenvectors from ', a, ' incorrectly ',
707 $ 'normalized.', / ' Bits of error=', 0p, g10.3, ',', 9x,
708 $ 'N=', i6, ', JTYPE=', i6, ', IWA=', i5, ', IWB=', i5,
709 $ ', IWX=', i5, ', IWY=', i5 )
710*
711 9997 FORMAT( / 1x, a3, ' -- Complex Expert Eigenvalue/vector',
712 $ ' problem driver' )
713*
714 9996 FORMAT( 'Input Example' )
715*
716 9995 FORMAT( ' Matrix types: ', / )
717*
718 9994 FORMAT( ' TYPE 1: Da is diagonal, Db is identity, ',
719 $ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
720 $ / ' YH and X are left and right eigenvectors. ', / )
721*
722 9993 FORMAT( ' TYPE 2: Da is quasi-diagonal, Db is identity, ',
723 $ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
724 $ / ' YH and X are left and right eigenvectors. ', / )
725*
726 9992 FORMAT( / ' Tests performed: ', / 4x,
727 $ ' a is alpha, b is beta, l is a left eigenvector, ', / 4x,
728 $ ' r is a right eigenvector and ', a, ' means ', a, '.',
729 $ / ' 1 = max | ( b A - a B )', a, ' l | / const.',
730 $ / ' 2 = max | ( b A - a B ) r | / const.',
731 $ / ' 3 = max ( Sest/Stru, Stru/Sest ) ',
732 $ ' over all eigenvalues', /
733 $ ' 4 = max( DIFest/DIFtru, DIFtru/DIFest ) ',
734 $ ' over the 1st and 5th eigenvectors', / )
735*
736 9991 FORMAT( ' Type=', i2, ',', ' IWA=', i2, ', IWB=', i2, ', IWX=',
737 $ i2, ', IWY=', i2, ', result ', i2, ' is', 0p, f8.2 )
738*
739 9990 FORMAT( ' Type=', i2, ',', ' IWA=', i2, ', IWB=', i2, ', IWX=',
740 $ i2, ', IWY=', i2, ', result ', i2, ' is', 1p, d10.3 )
741*
742 9989 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
743 $ ' result ', i2, ' is', 0p, f8.2 )
744*
745 9988 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
746 $ ' result ', i2, ' is', 1p, d10.3 )
747*
748 9987 FORMAT( ' ZDRGVX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
749 $ i6, ', Input example #', i2, ')' )
750*
751 9986 FORMAT( ' ZDRGVX: ', a, ' Eigenvectors from ', a, ' incorrectly ',
752 $ 'normalized.', / ' Bits of error=', 0p, g10.3, ',', 9x,
753 $ 'N=', i6, ', Input Example #', i2, ')' )
754*
755* End of ZDRGVX
756*
zggevx
subroutine zggevx(balanc, jobvl, jobvr, sense, n, a, lda, b, ldb, alpha, beta, vl, ldvl, vr, ldvr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, lwork, rwork, iwork, bwork, info)
ZGGEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition zggevx.f:374
zlatm6
subroutine zlatm6(type, n, a, lda, b, x, ldx, y, ldy, alpha, beta, wx, wy, s, dif)
ZLATM6
Definition zlatm6.f:174

◆ zdrvbd()

subroutine zdrvbd ( integer nsizes,
integer, dimension( * ) mm,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldvt, * ) vt,
integer ldvt,
complex*16, dimension( lda, * ) asav,
complex*16, dimension( ldu, * ) usav,
complex*16, dimension( ldvt, * ) vtsav,
double precision, dimension( * ) s,
double precision, dimension( * ) ssav,
double precision, dimension( * ) e,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nounit,
integer info )

ZDRVBD

Purpose:
!>
!> ZDRVBD checks the singular value decomposition (SVD) driver ZGESVD,
!> ZGESDD, ZGESVJ, ZGEJSV, ZGESVDX, and ZGESVDQ.
!>
!> ZGESVD and ZGESDD factors A = U diag(S) VT, where U and VT are
!> unitary and diag(S) is diagonal with the entries of the array S on
!> its diagonal. The entries of S are the singular values, nonnegative
!> and stored in decreasing order.  U and VT can be optionally not
!> computed, overwritten on A, or computed partially.
!>
!> A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN.
!> U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N.
!>
!> When ZDRVBD is called, a number of matrix  (M's and N's)
!> and a number of matrix  are specified.  For each size (M,N)
!> and each type of matrix, and for the minimal workspace as well as
!> workspace adequate to permit blocking, an  M x N  matrix  will be
!> generated and used to test the SVD routines.  For each matrix, A will
!> be factored as A = U diag(S) VT and the following 12 tests computed:
!>
!> Test for ZGESVD:
!>
!> (1)   | A - U diag(S) VT | / ( |A| max(M,N) ulp )
!>
!> (2)   | I - U'U | / ( M ulp )
!>
!> (3)   | I - VT VT' | / ( N ulp )
!>
!> (4)   S contains MNMIN nonnegative values in decreasing order.
!>       (Return 0 if true, 1/ULP if false.)
!>
!> (5)   | U - Upartial | / ( M ulp ) where Upartial is a partially
!>       computed U.
!>
!> (6)   | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
!>       computed VT.
!>
!> (7)   | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
!>       vector of singular values from the partial SVD
!>
!> Test for ZGESDD:
!>
!> (8)   | A - U diag(S) VT | / ( |A| max(M,N) ulp )
!>
!> (9)   | I - U'U | / ( M ulp )
!>
!> (10)  | I - VT VT' | / ( N ulp )
!>
!> (11)  S contains MNMIN nonnegative values in decreasing order.
!>       (Return 0 if true, 1/ULP if false.)
!>
!> (12)  | U - Upartial | / ( M ulp ) where Upartial is a partially
!>       computed U.
!>
!> (13)  | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
!>       computed VT.
!>
!> (14)  | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
!>       vector of singular values from the partial SVD
!>
!> Test for ZGESVDQ:
!>
!> (36)  | A - U diag(S) VT | / ( |A| max(M,N) ulp )
!>
!> (37)  | I - U'U | / ( M ulp )
!>
!> (38)  | I - VT VT' | / ( N ulp )
!>
!> (39)  S contains MNMIN nonnegative values in decreasing order.
!>       (Return 0 if true, 1/ULP if false.)
!>
!> Test for ZGESVJ:
!>
!> (15)  | A - U diag(S) VT | / ( |A| max(M,N) ulp )
!>
!> (16)  | I - U'U | / ( M ulp )
!>
!> (17)  | I - VT VT' | / ( N ulp )
!>
!> (18)  S contains MNMIN nonnegative values in decreasing order.
!>       (Return 0 if true, 1/ULP if false.)
!>
!> Test for ZGEJSV:
!>
!> (19)  | A - U diag(S) VT | / ( |A| max(M,N) ulp )
!>
!> (20)  | I - U'U | / ( M ulp )
!>
!> (21)  | I - VT VT' | / ( N ulp )
!>
!> (22)  S contains MNMIN nonnegative values in decreasing order.
!>        (Return 0 if true, 1/ULP if false.)
!>
!> Test for ZGESVDX( 'V', 'V', 'A' )/ZGESVDX( 'N', 'N', 'A' )
!>
!> (23)  | A - U diag(S) VT | / ( |A| max(M,N) ulp )
!>
!> (24)  | I - U'U | / ( M ulp )
!>
!> (25)  | I - VT VT' | / ( N ulp )
!>
!> (26)  S contains MNMIN nonnegative values in decreasing order.
!>       (Return 0 if true, 1/ULP if false.)
!>
!> (27)  | U - Upartial | / ( M ulp ) where Upartial is a partially
!>       computed U.
!>
!> (28)  | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
!>       computed VT.
!>
!> (29)  | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
!>       vector of singular values from the partial SVD
!>
!> Test for ZGESVDX( 'V', 'V', 'I' )
!>
!> (30)  | U' A VT''' - diag(S) | / ( |A| max(M,N) ulp )
!>
!> (31)  | I - U'U | / ( M ulp )
!>
!> (32)  | I - VT VT' | / ( N ulp )
!>
!> Test for ZGESVDX( 'V', 'V', 'V' )
!>
!> (33)   | U' A VT''' - diag(S) | / ( |A| max(M,N) ulp )
!>
!> (34)   | I - U'U | / ( M ulp )
!>
!> (35)   | I - VT VT' | / ( N ulp )
!>
!> The  are specified by the arrays MM(1:NSIZES) and
!> NN(1:NSIZES); the value of each element pair (MM(j),NN(j))
!> specifies one size.  The  are specified by a logical array
!> DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type 
!> will be generated.
!> Currently, the list of possible types is:
!>
!> (1)  The zero matrix.
!> (2)  The identity matrix.
!> (3)  A matrix of the form  U D V, where U and V are unitary and
!>      D has evenly spaced entries 1, ..., ULP with random signs
!>      on the diagonal.
!> (4)  Same as (3), but multiplied by the underflow-threshold / ULP.
!> (5)  Same as (3), but multiplied by the overflow-threshold * ULP.
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZDRVBD does nothing.  It must be at least zero.
!>
[in]MM
!>          MM is INTEGER array, dimension (NSIZES)
!>          An array containing the matrix  to be used.  For
!>          each j=1,...,NSIZES, if MM(j) is zero, then MM(j) and NN(j)
!>          will be ignored.  The MM(j) values must be at least zero.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the matrix  to be used.  For
!>          each j=1,...,NSIZES, if NN(j) is zero, then MM(j) and NN(j)
!>          will be ignored.  The NN(j) values must be at least zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZDRVBD
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrices are in A and B.
!>          This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix
!>          of type j will be generated.  If NTYPES is smaller than the
!>          maximum number of types defined (PARAMETER MAXTYP), then
!>          types NTYPES+1 through MAXTYP will not be generated.  If
!>          NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through
!>          DOTYPE(NTYPES) will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRVBD to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,max(NN))
!>          Used to hold the matrix whose singular values are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( MM ).
!>
[out]U
!>          U is COMPLEX*16 array, dimension (LDU,max(MM))
!>          Used to hold the computed matrix of right singular vectors.
!>          On exit, U contains the last such vectors actually computed.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  It must be at
!>          least 1 and at least max( MM ).
!>
[out]VT
!>          VT is COMPLEX*16 array, dimension (LDVT,max(NN))
!>          Used to hold the computed matrix of left singular vectors.
!>          On exit, VT contains the last such vectors actually computed.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of VT.  It must be at
!>          least 1 and at least max( NN ).
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (LDA,max(NN))
!>          Used to hold a different copy of the matrix whose singular
!>          values are to be computed.  On exit, A contains the last
!>          matrix actually used.
!>
[out]USAV
!>          USAV is COMPLEX*16 array, dimension (LDU,max(MM))
!>          Used to hold a different copy of the computed matrix of
!>          right singular vectors. On exit, USAV contains the last such
!>          vectors actually computed.
!>
[out]VTSAV
!>          VTSAV is COMPLEX*16 array, dimension (LDVT,max(NN))
!>          Used to hold a different copy of the computed matrix of
!>          left singular vectors. On exit, VTSAV contains the last such
!>          vectors actually computed.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (max(min(MM,NN)))
!>          Contains the computed singular values.
!>
[out]SSAV
!>          SSAV is DOUBLE PRECISION array, dimension (max(min(MM,NN)))
!>          Contains another copy of the computed singular values.
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (max(min(MM,NN)))
!>          Workspace for ZGESVD.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          MAX(3*MIN(M,N)+MAX(M,N)**2,5*MIN(M,N),3*MAX(M,N)) for all
!>          pairs  (M,N)=(MM(j),NN(j))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array,
!>                      dimension ( 5*max(max(MM,NN)) )
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension at least 8*min(M,N)
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some MM(j) < 0
!>           -3: Some NN(j) < 0
!>           -4: NTYPES < 0
!>           -7: THRESH < 0
!>          -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
!>          -12: LDU < 1 or LDU < MMAX.
!>          -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ).
!>          -21: LWORK too small.
!>          If  ZLATMS, or ZGESVD returns an error code, the
!>              absolute value of it is returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 397 of file zdrvbd.f.

401*
402* -- LAPACK test routine --
403* -- LAPACK is a software package provided by Univ. of Tennessee, --
404* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
405*
406 IMPLICIT NONE
407*
408* .. Scalar Arguments ..
409 INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUNIT, NSIZES,
410 $ NTYPES
411 DOUBLE PRECISION THRESH
412* ..
413* .. Array Arguments ..
414 LOGICAL DOTYPE( * )
415 INTEGER ISEED( 4 ), IWORK( * ), MM( * ), NN( * )
416 DOUBLE PRECISION E( * ), RWORK( * ), S( * ), SSAV( * )
417 COMPLEX*16 A( LDA, * ), ASAV( LDA, * ), U( LDU, * ),
418 $ USAV( LDU, * ), VT( LDVT, * ),
419 $ VTSAV( LDVT, * ), WORK( * )
420* ..
421*
422* =====================================================================
423*
424* .. Parameters ..
425 DOUBLE PRECISION ZERO, ONE, TWO, HALF
426 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
427 $ half = 0.5d0 )
428 COMPLEX*16 CZERO, CONE
429 parameter( czero = ( 0.0d+0, 0.0d+0 ),
430 $ cone = ( 1.0d+0, 0.0d+0 ) )
431 INTEGER MAXTYP
432 parameter( maxtyp = 5 )
433* ..
434* .. Local Scalars ..
435 LOGICAL BADMM, BADNN
436 CHARACTER JOBQ, JOBU, JOBVT, RANGE
437 INTEGER I, IINFO, IJQ, IJU, IJVT, IL, IU, ITEMP,
438 $ IWSPC, IWTMP, J, JSIZE, JTYPE, LSWORK, M,
439 $ MINWRK, MMAX, MNMAX, MNMIN, MTYPES, N,
440 $ NERRS, NFAIL, NMAX, NS, NSI, NSV, NTEST,
441 $ NTESTF, NTESTT, LRWORK
442 DOUBLE PRECISION ANORM, DIF, DIV, OVFL, RTUNFL, ULP, ULPINV,
443 $ UNFL, VL, VU
444* ..
445* .. Local Scalars for ZGESVDQ ..
446 INTEGER LIWORK, NUMRANK
447* ..
448* .. Local Arrays ..
449 CHARACTER CJOB( 4 ), CJOBR( 3 ), CJOBV( 2 )
450 INTEGER IOLDSD( 4 ), ISEED2( 4 )
451 DOUBLE PRECISION RESULT( 39 )
452* ..
453* .. External Functions ..
454 DOUBLE PRECISION DLAMCH, DLARND
455 EXTERNAL dlamch, dlarnd
456* ..
457* .. External Subroutines ..
458 EXTERNAL alasvm, xerbla, zbdt01, zbdt05, zgesdd,
459 $ zgesvd, zgesvdq, zgesvj, zgejsv, zgesvdx,
460 $ zlacpy, zlaset, zlatms, zunt01, zunt03
461* ..
462* .. Intrinsic Functions ..
463 INTRINSIC abs, dble, max, min
464* ..
465* .. Scalars in Common ..
466 CHARACTER*32 SRNAMT
467* ..
468* .. Common blocks ..
469 COMMON / srnamc / srnamt
470* ..
471* .. Data statements ..
472 DATA cjob / 'N', 'O', 'S', 'A' /
473 DATA cjobr / 'A', 'V', 'I' /
474 DATA cjobv / 'N', 'V' /
475* ..
476* .. Executable Statements ..
477*
478* Check for errors
479*
480 info = 0
481*
482* Important constants
483*
484 nerrs = 0
485 ntestt = 0
486 ntestf = 0
487 badmm = .false.
488 badnn = .false.
489 mmax = 1
490 nmax = 1
491 mnmax = 1
492 minwrk = 1
493 DO 10 j = 1, nsizes
494 mmax = max( mmax, mm( j ) )
495 IF( mm( j ).LT.0 )
496 $ badmm = .true.
497 nmax = max( nmax, nn( j ) )
498 IF( nn( j ).LT.0 )
499 $ badnn = .true.
500 mnmax = max( mnmax, min( mm( j ), nn( j ) ) )
501 minwrk = max( minwrk, max( 3*min( mm( j ),
502 $ nn( j ) )+max( mm( j ), nn( j ) )**2, 5*min( mm( j ),
503 $ nn( j ) ), 3*max( mm( j ), nn( j ) ) ) )
504 10 CONTINUE
505*
506* Check for errors
507*
508 IF( nsizes.LT.0 ) THEN
509 info = -1
510 ELSE IF( badmm ) THEN
511 info = -2
512 ELSE IF( badnn ) THEN
513 info = -3
514 ELSE IF( ntypes.LT.0 ) THEN
515 info = -4
516 ELSE IF( lda.LT.max( 1, mmax ) ) THEN
517 info = -10
518 ELSE IF( ldu.LT.max( 1, mmax ) ) THEN
519 info = -12
520 ELSE IF( ldvt.LT.max( 1, nmax ) ) THEN
521 info = -14
522 ELSE IF( minwrk.GT.lwork ) THEN
523 info = -21
524 END IF
525*
526 IF( info.NE.0 ) THEN
527 CALL xerbla( 'ZDRVBD', -info )
528 RETURN
529 END IF
530*
531* Quick return if nothing to do
532*
533 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
534 $ RETURN
535*
536* More Important constants
537*
538 unfl = dlamch( 'S' )
539 ovfl = one / unfl
540 ulp = dlamch( 'E' )
541 ulpinv = one / ulp
542 rtunfl = sqrt( unfl )
543*
544* Loop over sizes, types
545*
546 nerrs = 0
547*
548 DO 230 jsize = 1, nsizes
549 m = mm( jsize )
550 n = nn( jsize )
551 mnmin = min( m, n )
552*
553 IF( nsizes.NE.1 ) THEN
554 mtypes = min( maxtyp, ntypes )
555 ELSE
556 mtypes = min( maxtyp+1, ntypes )
557 END IF
558*
559 DO 220 jtype = 1, mtypes
560 IF( .NOT.dotype( jtype ) )
561 $ GO TO 220
562 ntest = 0
563*
564 DO 20 j = 1, 4
565 ioldsd( j ) = iseed( j )
566 20 CONTINUE
567*
568* Compute "A"
569*
570 IF( mtypes.GT.maxtyp )
571 $ GO TO 50
572*
573 IF( jtype.EQ.1 ) THEN
574*
575* Zero matrix
576*
577 CALL zlaset( 'Full', m, n, czero, czero, a, lda )
578 DO 30 i = 1, min( m, n )
579 s( i ) = zero
580 30 CONTINUE
581*
582 ELSE IF( jtype.EQ.2 ) THEN
583*
584* Identity matrix
585*
586 CALL zlaset( 'Full', m, n, czero, cone, a, lda )
587 DO 40 i = 1, min( m, n )
588 s( i ) = one
589 40 CONTINUE
590*
591 ELSE
592*
593* (Scaled) random matrix
594*
595 IF( jtype.EQ.3 )
596 $ anorm = one
597 IF( jtype.EQ.4 )
598 $ anorm = unfl / ulp
599 IF( jtype.EQ.5 )
600 $ anorm = ovfl*ulp
601 CALL zlatms( m, n, 'U', iseed, 'N', s, 4, dble( mnmin ),
602 $ anorm, m-1, n-1, 'N', a, lda, work, iinfo )
603 IF( iinfo.NE.0 ) THEN
604 WRITE( nounit, fmt = 9996 )'Generator', iinfo, m, n,
605 $ jtype, ioldsd
606 info = abs( iinfo )
607 RETURN
608 END IF
609 END IF
610*
611 50 CONTINUE
612 CALL zlacpy( 'F', m, n, a, lda, asav, lda )
613*
614* Do for minimal and adequate (for blocking) workspace
615*
616 DO 210 iwspc = 1, 4
617*
618* Test for ZGESVD
619*
620 iwtmp = 2*min( m, n )+max( m, n )
621 lswork = iwtmp + ( iwspc-1 )*( lwork-iwtmp ) / 3
622 lswork = min( lswork, lwork )
623 lswork = max( lswork, 1 )
624 IF( iwspc.EQ.4 )
625 $ lswork = lwork
626*
627 DO 60 j = 1, 35
628 result( j ) = -one
629 60 CONTINUE
630*
631* Factorize A
632*
633 IF( iwspc.GT.1 )
634 $ CALL zlacpy( 'F', m, n, asav, lda, a, lda )
635 srnamt = 'ZGESVD'
636 CALL zgesvd( 'A', 'A', m, n, a, lda, ssav, usav, ldu,
637 $ vtsav, ldvt, work, lswork, rwork, iinfo )
638 IF( iinfo.NE.0 ) THEN
639 WRITE( nounit, fmt = 9995 )'GESVD', iinfo, m, n,
640 $ jtype, lswork, ioldsd
641 info = abs( iinfo )
642 RETURN
643 END IF
644*
645* Do tests 1--4
646*
647 CALL zbdt01( m, n, 0, asav, lda, usav, ldu, ssav, e,
648 $ vtsav, ldvt, work, rwork, result( 1 ) )
649 IF( m.NE.0 .AND. n.NE.0 ) THEN
650 CALL zunt01( 'Columns', mnmin, m, usav, ldu, work,
651 $ lwork, rwork, result( 2 ) )
652 CALL zunt01( 'Rows', mnmin, n, vtsav, ldvt, work,
653 $ lwork, rwork, result( 3 ) )
654 END IF
655 result( 4 ) = 0
656 DO 70 i = 1, mnmin - 1
657 IF( ssav( i ).LT.ssav( i+1 ) )
658 $ result( 4 ) = ulpinv
659 IF( ssav( i ).LT.zero )
660 $ result( 4 ) = ulpinv
661 70 CONTINUE
662 IF( mnmin.GE.1 ) THEN
663 IF( ssav( mnmin ).LT.zero )
664 $ result( 4 ) = ulpinv
665 END IF
666*
667* Do partial SVDs, comparing to SSAV, USAV, and VTSAV
668*
669 result( 5 ) = zero
670 result( 6 ) = zero
671 result( 7 ) = zero
672 DO 100 iju = 0, 3
673 DO 90 ijvt = 0, 3
674 IF( ( iju.EQ.3 .AND. ijvt.EQ.3 ) .OR.
675 $ ( iju.EQ.1 .AND. ijvt.EQ.1 ) )GO TO 90
676 jobu = cjob( iju+1 )
677 jobvt = cjob( ijvt+1 )
678 CALL zlacpy( 'F', m, n, asav, lda, a, lda )
679 srnamt = 'ZGESVD'
680 CALL zgesvd( jobu, jobvt, m, n, a, lda, s, u, ldu,
681 $ vt, ldvt, work, lswork, rwork, iinfo )
682*
683* Compare U
684*
685 dif = zero
686 IF( m.GT.0 .AND. n.GT.0 ) THEN
687 IF( iju.EQ.1 ) THEN
688 CALL zunt03( 'C', m, mnmin, m, mnmin, usav,
689 $ ldu, a, lda, work, lwork, rwork,
690 $ dif, iinfo )
691 ELSE IF( iju.EQ.2 ) THEN
692 CALL zunt03( 'C', m, mnmin, m, mnmin, usav,
693 $ ldu, u, ldu, work, lwork, rwork,
694 $ dif, iinfo )
695 ELSE IF( iju.EQ.3 ) THEN
696 CALL zunt03( 'C', m, m, m, mnmin, usav, ldu,
697 $ u, ldu, work, lwork, rwork, dif,
698 $ iinfo )
699 END IF
700 END IF
701 result( 5 ) = max( result( 5 ), dif )
702*
703* Compare VT
704*
705 dif = zero
706 IF( m.GT.0 .AND. n.GT.0 ) THEN
707 IF( ijvt.EQ.1 ) THEN
708 CALL zunt03( 'R', n, mnmin, n, mnmin, vtsav,
709 $ ldvt, a, lda, work, lwork,
710 $ rwork, dif, iinfo )
711 ELSE IF( ijvt.EQ.2 ) THEN
712 CALL zunt03( 'R', n, mnmin, n, mnmin, vtsav,
713 $ ldvt, vt, ldvt, work, lwork,
714 $ rwork, dif, iinfo )
715 ELSE IF( ijvt.EQ.3 ) THEN
716 CALL zunt03( 'R', n, n, n, mnmin, vtsav,
717 $ ldvt, vt, ldvt, work, lwork,
718 $ rwork, dif, iinfo )
719 END IF
720 END IF
721 result( 6 ) = max( result( 6 ), dif )
722*
723* Compare S
724*
725 dif = zero
726 div = max( dble( mnmin )*ulp*s( 1 ),
727 $ dlamch( 'Safe minimum' ) )
728 DO 80 i = 1, mnmin - 1
729 IF( ssav( i ).LT.ssav( i+1 ) )
730 $ dif = ulpinv
731 IF( ssav( i ).LT.zero )
732 $ dif = ulpinv
733 dif = max( dif, abs( ssav( i )-s( i ) ) / div )
734 80 CONTINUE
735 result( 7 ) = max( result( 7 ), dif )
736 90 CONTINUE
737 100 CONTINUE
738*
739* Test for ZGESDD
740*
741 iwtmp = 2*mnmin*mnmin + 2*mnmin + max( m, n )
742 lswork = iwtmp + ( iwspc-1 )*( lwork-iwtmp ) / 3
743 lswork = min( lswork, lwork )
744 lswork = max( lswork, 1 )
745 IF( iwspc.EQ.4 )
746 $ lswork = lwork
747*
748* Factorize A
749*
750 CALL zlacpy( 'F', m, n, asav, lda, a, lda )
751 srnamt = 'ZGESDD'
752 CALL zgesdd( 'A', m, n, a, lda, ssav, usav, ldu, vtsav,
753 $ ldvt, work, lswork, rwork, iwork, iinfo )
754 IF( iinfo.NE.0 ) THEN
755 WRITE( nounit, fmt = 9995 )'GESDD', iinfo, m, n,
756 $ jtype, lswork, ioldsd
757 info = abs( iinfo )
758 RETURN
759 END IF
760*
761* Do tests 1--4
762*
763 CALL zbdt01( m, n, 0, asav, lda, usav, ldu, ssav, e,
764 $ vtsav, ldvt, work, rwork, result( 8 ) )
765 IF( m.NE.0 .AND. n.NE.0 ) THEN
766 CALL zunt01( 'Columns', mnmin, m, usav, ldu, work,
767 $ lwork, rwork, result( 9 ) )
768 CALL zunt01( 'Rows', mnmin, n, vtsav, ldvt, work,
769 $ lwork, rwork, result( 10 ) )
770 END IF
771 result( 11 ) = 0
772 DO 110 i = 1, mnmin - 1
773 IF( ssav( i ).LT.ssav( i+1 ) )
774 $ result( 11 ) = ulpinv
775 IF( ssav( i ).LT.zero )
776 $ result( 11 ) = ulpinv
777 110 CONTINUE
778 IF( mnmin.GE.1 ) THEN
779 IF( ssav( mnmin ).LT.zero )
780 $ result( 11 ) = ulpinv
781 END IF
782*
783* Do partial SVDs, comparing to SSAV, USAV, and VTSAV
784*
785 result( 12 ) = zero
786 result( 13 ) = zero
787 result( 14 ) = zero
788 DO 130 ijq = 0, 2
789 jobq = cjob( ijq+1 )
790 CALL zlacpy( 'F', m, n, asav, lda, a, lda )
791 srnamt = 'ZGESDD'
792 CALL zgesdd( jobq, m, n, a, lda, s, u, ldu, vt, ldvt,
793 $ work, lswork, rwork, iwork, iinfo )
794*
795* Compare U
796*
797 dif = zero
798 IF( m.GT.0 .AND. n.GT.0 ) THEN
799 IF( ijq.EQ.1 ) THEN
800 IF( m.GE.n ) THEN
801 CALL zunt03( 'C', m, mnmin, m, mnmin, usav,
802 $ ldu, a, lda, work, lwork, rwork,
803 $ dif, iinfo )
804 ELSE
805 CALL zunt03( 'C', m, mnmin, m, mnmin, usav,
806 $ ldu, u, ldu, work, lwork, rwork,
807 $ dif, iinfo )
808 END IF
809 ELSE IF( ijq.EQ.2 ) THEN
810 CALL zunt03( 'C', m, mnmin, m, mnmin, usav, ldu,
811 $ u, ldu, work, lwork, rwork, dif,
812 $ iinfo )
813 END IF
814 END IF
815 result( 12 ) = max( result( 12 ), dif )
816*
817* Compare VT
818*
819 dif = zero
820 IF( m.GT.0 .AND. n.GT.0 ) THEN
821 IF( ijq.EQ.1 ) THEN
822 IF( m.GE.n ) THEN
823 CALL zunt03( 'R', n, mnmin, n, mnmin, vtsav,
824 $ ldvt, vt, ldvt, work, lwork,
825 $ rwork, dif, iinfo )
826 ELSE
827 CALL zunt03( 'R', n, mnmin, n, mnmin, vtsav,
828 $ ldvt, a, lda, work, lwork,
829 $ rwork, dif, iinfo )
830 END IF
831 ELSE IF( ijq.EQ.2 ) THEN
832 CALL zunt03( 'R', n, mnmin, n, mnmin, vtsav,
833 $ ldvt, vt, ldvt, work, lwork, rwork,
834 $ dif, iinfo )
835 END IF
836 END IF
837 result( 13 ) = max( result( 13 ), dif )
838*
839* Compare S
840*
841 dif = zero
842 div = max( dble( mnmin )*ulp*s( 1 ),
843 $ dlamch( 'Safe minimum' ) )
844 DO 120 i = 1, mnmin - 1
845 IF( ssav( i ).LT.ssav( i+1 ) )
846 $ dif = ulpinv
847 IF( ssav( i ).LT.zero )
848 $ dif = ulpinv
849 dif = max( dif, abs( ssav( i )-s( i ) ) / div )
850 120 CONTINUE
851 result( 14 ) = max( result( 14 ), dif )
852 130 CONTINUE
853*
854* Test ZGESVDQ
855* Note: ZGESVDQ only works for M >= N
856*
857 result( 36 ) = zero
858 result( 37 ) = zero
859 result( 38 ) = zero
860 result( 39 ) = zero
861*
862 IF( m.GE.n ) THEN
863 iwtmp = 2*mnmin*mnmin + 2*mnmin + max( m, n )
864 lswork = iwtmp + ( iwspc-1 )*( lwork-iwtmp ) / 3
865 lswork = min( lswork, lwork )
866 lswork = max( lswork, 1 )
867 IF( iwspc.EQ.4 )
868 $ lswork = lwork
869*
870 CALL zlacpy( 'F', m, n, asav, lda, a, lda )
871 srnamt = 'ZGESVDQ'
872*
873 lrwork = max(2, m, 5*n)
874 liwork = max( n, 1 )
875 CALL zgesvdq( 'H', 'N', 'N', 'A', 'A',
876 $ m, n, a, lda, ssav, usav, ldu,
877 $ vtsav, ldvt, numrank, iwork, liwork,
878 $ work, lwork, rwork, lrwork, iinfo )
879*
880 IF( iinfo.NE.0 ) THEN
881 WRITE( nounit, fmt = 9995 )'ZGESVDQ', iinfo, m, n,
882 $ jtype, lswork, ioldsd
883 info = abs( iinfo )
884 RETURN
885 END IF
886*
887* Do tests 36--39
888*
889 CALL zbdt01( m, n, 0, asav, lda, usav, ldu, ssav, e,
890 $ vtsav, ldvt, work, rwork, result( 36 ) )
891 IF( m.NE.0 .AND. n.NE.0 ) THEN
892 CALL zunt01( 'Columns', m, m, usav, ldu, work,
893 $ lwork, rwork, result( 37 ) )
894 CALL zunt01( 'Rows', n, n, vtsav, ldvt, work,
895 $ lwork, rwork, result( 38 ) )
896 END IF
897 result( 39 ) = zero
898 DO 199 i = 1, mnmin - 1
899 IF( ssav( i ).LT.ssav( i+1 ) )
900 $ result( 39 ) = ulpinv
901 IF( ssav( i ).LT.zero )
902 $ result( 39 ) = ulpinv
903 199 CONTINUE
904 IF( mnmin.GE.1 ) THEN
905 IF( ssav( mnmin ).LT.zero )
906 $ result( 39 ) = ulpinv
907 END IF
908 END IF
909*
910* Test ZGESVJ
911* Note: ZGESVJ only works for M >= N
912*
913 result( 15 ) = zero
914 result( 16 ) = zero
915 result( 17 ) = zero
916 result( 18 ) = zero
917*
918 IF( m.GE.n ) THEN
919 iwtmp = 2*mnmin*mnmin + 2*mnmin + max( m, n )
920 lswork = iwtmp + ( iwspc-1 )*( lwork-iwtmp ) / 3
921 lswork = min( lswork, lwork )
922 lswork = max( lswork, 1 )
923 lrwork = max(6,n)
924 IF( iwspc.EQ.4 )
925 $ lswork = lwork
926*
927 CALL zlacpy( 'F', m, n, asav, lda, usav, lda )
928 srnamt = 'ZGESVJ'
929 CALL zgesvj( 'G', 'U', 'V', m, n, usav, lda, ssav,
930 & 0, a, ldvt, work, lwork, rwork,
931 & lrwork, iinfo )
932*
933* ZGESVJ returns V not VH
934*
935 DO j=1,n
936 DO i=1,n
937 vtsav(j,i) = conjg(a(i,j))
938 END DO
939 END DO
940*
941 IF( iinfo.NE.0 ) THEN
942 WRITE( nounit, fmt = 9995 )'GESVJ', iinfo, m, n,
943 $ jtype, lswork, ioldsd
944 info = abs( iinfo )
945 RETURN
946 END IF
947*
948* Do tests 15--18
949*
950 CALL zbdt01( m, n, 0, asav, lda, usav, ldu, ssav, e,
951 $ vtsav, ldvt, work, rwork, result( 15 ) )
952 IF( m.NE.0 .AND. n.NE.0 ) THEN
953 CALL zunt01( 'Columns', m, m, usav, ldu, work,
954 $ lwork, rwork, result( 16 ) )
955 CALL zunt01( 'Rows', n, n, vtsav, ldvt, work,
956 $ lwork, rwork, result( 17 ) )
957 END IF
958 result( 18 ) = zero
959 DO 131 i = 1, mnmin - 1
960 IF( ssav( i ).LT.ssav( i+1 ) )
961 $ result( 18 ) = ulpinv
962 IF( ssav( i ).LT.zero )
963 $ result( 18 ) = ulpinv
964 131 CONTINUE
965 IF( mnmin.GE.1 ) THEN
966 IF( ssav( mnmin ).LT.zero )
967 $ result( 18 ) = ulpinv
968 END IF
969 END IF
970*
971* Test ZGEJSV
972* Note: ZGEJSV only works for M >= N
973*
974 result( 19 ) = zero
975 result( 20 ) = zero
976 result( 21 ) = zero
977 result( 22 ) = zero
978 IF( m.GE.n ) THEN
979 iwtmp = 2*mnmin*mnmin + 2*mnmin + max( m, n )
980 lswork = iwtmp + ( iwspc-1 )*( lwork-iwtmp ) / 3
981 lswork = min( lswork, lwork )
982 lswork = max( lswork, 1 )
983 IF( iwspc.EQ.4 )
984 $ lswork = lwork
985 lrwork = max( 7, n + 2*m)
986*
987 CALL zlacpy( 'F', m, n, asav, lda, vtsav, lda )
988 srnamt = 'ZGEJSV'
989 CALL zgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
990 & m, n, vtsav, lda, ssav, usav, ldu, a, ldvt,
991 & work, lwork, rwork,
992 & lrwork, iwork, iinfo )
993*
994* ZGEJSV returns V not VH
995*
996 DO 133 j=1,n
997 DO 132 i=1,n
998 vtsav(j,i) = conjg(a(i,j))
999 132 END DO
1000 133 END DO
1001*
1002 IF( iinfo.NE.0 ) THEN
1003 WRITE( nounit, fmt = 9995 )'GEJSV', iinfo, m, n,
1004 $ jtype, lswork, ioldsd
1005 info = abs( iinfo )
1006 RETURN
1007 END IF
1008*
1009* Do tests 19--22
1010*
1011 CALL zbdt01( m, n, 0, asav, lda, usav, ldu, ssav, e,
1012 $ vtsav, ldvt, work, rwork, result( 19 ) )
1013 IF( m.NE.0 .AND. n.NE.0 ) THEN
1014 CALL zunt01( 'Columns', m, m, usav, ldu, work,
1015 $ lwork, rwork, result( 20 ) )
1016 CALL zunt01( 'Rows', n, n, vtsav, ldvt, work,
1017 $ lwork, rwork, result( 21 ) )
1018 END IF
1019 result( 22 ) = zero
1020 DO 134 i = 1, mnmin - 1
1021 IF( ssav( i ).LT.ssav( i+1 ) )
1022 $ result( 22 ) = ulpinv
1023 IF( ssav( i ).LT.zero )
1024 $ result( 22 ) = ulpinv
1025 134 CONTINUE
1026 IF( mnmin.GE.1 ) THEN
1027 IF( ssav( mnmin ).LT.zero )
1028 $ result( 22 ) = ulpinv
1029 END IF
1030 END IF
1031*
1032* Test ZGESVDX
1033*
1034* Factorize A
1035*
1036 CALL zlacpy( 'F', m, n, asav, lda, a, lda )
1037 srnamt = 'ZGESVDX'
1038 CALL zgesvdx( 'V', 'V', 'A', m, n, a, lda,
1039 $ vl, vu, il, iu, ns, ssav, usav, ldu,
1040 $ vtsav, ldvt, work, lwork, rwork,
1041 $ iwork, iinfo )
1042 IF( iinfo.NE.0 ) THEN
1043 WRITE( nounit, fmt = 9995 )'GESVDX', iinfo, m, n,
1044 $ jtype, lswork, ioldsd
1045 info = abs( iinfo )
1046 RETURN
1047 END IF
1048*
1049* Do tests 1--4
1050*
1051 result( 23 ) = zero
1052 result( 24 ) = zero
1053 result( 25 ) = zero
1054 CALL zbdt01( m, n, 0, asav, lda, usav, ldu, ssav, e,
1055 $ vtsav, ldvt, work, rwork, result( 23 ) )
1056 IF( m.NE.0 .AND. n.NE.0 ) THEN
1057 CALL zunt01( 'Columns', mnmin, m, usav, ldu, work,
1058 $ lwork, rwork, result( 24 ) )
1059 CALL zunt01( 'Rows', mnmin, n, vtsav, ldvt, work,
1060 $ lwork, rwork, result( 25 ) )
1061 END IF
1062 result( 26 ) = zero
1063 DO 140 i = 1, mnmin - 1
1064 IF( ssav( i ).LT.ssav( i+1 ) )
1065 $ result( 26 ) = ulpinv
1066 IF( ssav( i ).LT.zero )
1067 $ result( 26 ) = ulpinv
1068 140 CONTINUE
1069 IF( mnmin.GE.1 ) THEN
1070 IF( ssav( mnmin ).LT.zero )
1071 $ result( 26 ) = ulpinv
1072 END IF
1073*
1074* Do partial SVDs, comparing to SSAV, USAV, and VTSAV
1075*
1076 result( 27 ) = zero
1077 result( 28 ) = zero
1078 result( 29 ) = zero
1079 DO 170 iju = 0, 1
1080 DO 160 ijvt = 0, 1
1081 IF( ( iju.EQ.0 .AND. ijvt.EQ.0 ) .OR.
1082 $ ( iju.EQ.1 .AND. ijvt.EQ.1 ) ) GO TO 160
1083 jobu = cjobv( iju+1 )
1084 jobvt = cjobv( ijvt+1 )
1085 range = cjobr( 1 )
1086 CALL zlacpy( 'F', m, n, asav, lda, a, lda )
1087 srnamt = 'ZGESVDX'
1088 CALL zgesvdx( jobu, jobvt, 'A', m, n, a, lda,
1089 $ vl, vu, il, iu, ns, ssav, u, ldu,
1090 $ vt, ldvt, work, lwork, rwork,
1091 $ iwork, iinfo )
1092*
1093* Compare U
1094*
1095 dif = zero
1096 IF( m.GT.0 .AND. n.GT.0 ) THEN
1097 IF( iju.EQ.1 ) THEN
1098 CALL zunt03( 'C', m, mnmin, m, mnmin, usav,
1099 $ ldu, u, ldu, work, lwork, rwork,
1100 $ dif, iinfo )
1101 END IF
1102 END IF
1103 result( 27 ) = max( result( 27 ), dif )
1104*
1105* Compare VT
1106*
1107 dif = zero
1108 IF( m.GT.0 .AND. n.GT.0 ) THEN
1109 IF( ijvt.EQ.1 ) THEN
1110 CALL zunt03( 'R', n, mnmin, n, mnmin, vtsav,
1111 $ ldvt, vt, ldvt, work, lwork,
1112 $ rwork, dif, iinfo )
1113 END IF
1114 END IF
1115 result( 28 ) = max( result( 28 ), dif )
1116*
1117* Compare S
1118*
1119 dif = zero
1120 div = max( dble( mnmin )*ulp*s( 1 ),
1121 $ dlamch( 'Safe minimum' ) )
1122 DO 150 i = 1, mnmin - 1
1123 IF( ssav( i ).LT.ssav( i+1 ) )
1124 $ dif = ulpinv
1125 IF( ssav( i ).LT.zero )
1126 $ dif = ulpinv
1127 dif = max( dif, abs( ssav( i )-s( i ) ) / div )
1128 150 CONTINUE
1129 result( 29) = max( result( 29 ), dif )
1130 160 CONTINUE
1131 170 CONTINUE
1132*
1133* Do tests 8--10
1134*
1135 DO 180 i = 1, 4
1136 iseed2( i ) = iseed( i )
1137 180 CONTINUE
1138 IF( mnmin.LE.1 ) THEN
1139 il = 1
1140 iu = max( 1, mnmin )
1141 ELSE
1142 il = 1 + int( ( mnmin-1 )*dlarnd( 1, iseed2 ) )
1143 iu = 1 + int( ( mnmin-1 )*dlarnd( 1, iseed2 ) )
1144 IF( iu.LT.il ) THEN
1145 itemp = iu
1146 iu = il
1147 il = itemp
1148 END IF
1149 END IF
1150 CALL zlacpy( 'F', m, n, asav, lda, a, lda )
1151 srnamt = 'ZGESVDX'
1152 CALL zgesvdx( 'V', 'V', 'I', m, n, a, lda,
1153 $ vl, vu, il, iu, nsi, s, u, ldu,
1154 $ vt, ldvt, work, lwork, rwork,
1155 $ iwork, iinfo )
1156 IF( iinfo.NE.0 ) THEN
1157 WRITE( nounit, fmt = 9995 )'GESVDX', iinfo, m, n,
1158 $ jtype, lswork, ioldsd
1159 info = abs( iinfo )
1160 RETURN
1161 END IF
1162*
1163 result( 30 ) = zero
1164 result( 31 ) = zero
1165 result( 32 ) = zero
1166 CALL zbdt05( m, n, asav, lda, s, nsi, u, ldu,
1167 $ vt, ldvt, work, result( 30 ) )
1168 IF( m.NE.0 .AND. n.NE.0 ) THEN
1169 CALL zunt01( 'Columns', m, nsi, u, ldu, work,
1170 $ lwork, rwork, result( 31 ) )
1171 CALL zunt01( 'Rows', nsi, n, vt, ldvt, work,
1172 $ lwork, rwork, result( 32 ) )
1173 END IF
1174*
1175* Do tests 11--13
1176*
1177 IF( mnmin.GT.0 .AND. nsi.GT.1 ) THEN
1178 IF( il.NE.1 ) THEN
1179 vu = ssav( il ) +
1180 $ max( half*abs( ssav( il )-ssav( il-1 ) ),
1181 $ ulp*anorm, two*rtunfl )
1182 ELSE
1183 vu = ssav( 1 ) +
1184 $ max( half*abs( ssav( ns )-ssav( 1 ) ),
1185 $ ulp*anorm, two*rtunfl )
1186 END IF
1187 IF( iu.NE.ns ) THEN
1188 vl = ssav( iu ) - max( ulp*anorm, two*rtunfl,
1189 $ half*abs( ssav( iu+1 )-ssav( iu ) ) )
1190 ELSE
1191 vl = ssav( ns ) - max( ulp*anorm, two*rtunfl,
1192 $ half*abs( ssav( ns )-ssav( 1 ) ) )
1193 END IF
1194 vl = max( vl,zero )
1195 vu = max( vu,zero )
1196 IF( vl.GE.vu ) vu = max( vu*2, vu+vl+half )
1197 ELSE
1198 vl = zero
1199 vu = one
1200 END IF
1201 CALL zlacpy( 'F', m, n, asav, lda, a, lda )
1202 srnamt = 'ZGESVDX'
1203 CALL zgesvdx( 'V', 'V', 'V', m, n, a, lda,
1204 $ vl, vu, il, iu, nsv, s, u, ldu,
1205 $ vt, ldvt, work, lwork, rwork,
1206 $ iwork, iinfo )
1207 IF( iinfo.NE.0 ) THEN
1208 WRITE( nounit, fmt = 9995 )'GESVDX', iinfo, m, n,
1209 $ jtype, lswork, ioldsd
1210 info = abs( iinfo )
1211 RETURN
1212 END IF
1213*
1214 result( 33 ) = zero
1215 result( 34 ) = zero
1216 result( 35 ) = zero
1217 CALL zbdt05( m, n, asav, lda, s, nsv, u, ldu,
1218 $ vt, ldvt, work, result( 33 ) )
1219 IF( m.NE.0 .AND. n.NE.0 ) THEN
1220 CALL zunt01( 'Columns', m, nsv, u, ldu, work,
1221 $ lwork, rwork, result( 34 ) )
1222 CALL zunt01( 'Rows', nsv, n, vt, ldvt, work,
1223 $ lwork, rwork, result( 35 ) )
1224 END IF
1225*
1226* End of Loop -- Check for RESULT(j) > THRESH
1227*
1228 ntest = 0
1229 nfail = 0
1230 DO 190 j = 1, 39
1231 IF( result( j ).GE.zero )
1232 $ ntest = ntest + 1
1233 IF( result( j ).GE.thresh )
1234 $ nfail = nfail + 1
1235 190 CONTINUE
1236*
1237 IF( nfail.GT.0 )
1238 $ ntestf = ntestf + 1
1239 IF( ntestf.EQ.1 ) THEN
1240 WRITE( nounit, fmt = 9999 )
1241 WRITE( nounit, fmt = 9998 )thresh
1242 ntestf = 2
1243 END IF
1244*
1245 DO 200 j = 1, 39
1246 IF( result( j ).GE.thresh ) THEN
1247 WRITE( nounit, fmt = 9997 )m, n, jtype, iwspc,
1248 $ ioldsd, j, result( j )
1249 END IF
1250 200 CONTINUE
1251*
1252 nerrs = nerrs + nfail
1253 ntestt = ntestt + ntest
1254*
1255 210 CONTINUE
1256*
1257 220 CONTINUE
1258 230 CONTINUE
1259*
1260* Summary
1261*
1262 CALL alasvm( 'ZBD', nounit, nerrs, ntestt, 0 )
1263*
1264 9999 FORMAT( ' SVD -- Complex Singular Value Decomposition Driver ',
1265 $ / ' Matrix types (see ZDRVBD for details):',
1266 $ / / ' 1 = Zero matrix', / ' 2 = Identity matrix',
1267 $ / ' 3 = Evenly spaced singular values near 1',
1268 $ / ' 4 = Evenly spaced singular values near underflow',
1269 $ / ' 5 = Evenly spaced singular values near overflow',
1270 $ / / ' Tests performed: ( A is dense, U and V are unitary,',
1271 $ / 19x, ' S is an array, and Upartial, VTpartial, and',
1272 $ / 19x, ' Spartial are partially computed U, VT and S),', / )
1273 9998 FORMAT( ' Tests performed with Test Threshold = ', f8.2,
1274 $ / ' ZGESVD: ', /
1275 $ ' 1 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
1276 $ / ' 2 = | I - U**T U | / ( M ulp ) ',
1277 $ / ' 3 = | I - VT VT**T | / ( N ulp ) ',
1278 $ / ' 4 = 0 if S contains min(M,N) nonnegative values in',
1279 $ ' decreasing order, else 1/ulp',
1280 $ / ' 5 = | U - Upartial | / ( M ulp )',
1281 $ / ' 6 = | VT - VTpartial | / ( N ulp )',
1282 $ / ' 7 = | S - Spartial | / ( min(M,N) ulp |S| )',
1283 $ / ' ZGESDD: ', /
1284 $ ' 8 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
1285 $ / ' 9 = | I - U**T U | / ( M ulp ) ',
1286 $ / '10 = | I - VT VT**T | / ( N ulp ) ',
1287 $ / '11 = 0 if S contains min(M,N) nonnegative values in',
1288 $ ' decreasing order, else 1/ulp',
1289 $ / '12 = | U - Upartial | / ( M ulp )',
1290 $ / '13 = | VT - VTpartial | / ( N ulp )',
1291 $ / '14 = | S - Spartial | / ( min(M,N) ulp |S| )',
1292 $ / ' ZGESVJ: ', /
1293 $ / '15 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
1294 $ / '16 = | I - U**T U | / ( M ulp ) ',
1295 $ / '17 = | I - VT VT**T | / ( N ulp ) ',
1296 $ / '18 = 0 if S contains min(M,N) nonnegative values in',
1297 $ ' decreasing order, else 1/ulp',
1298 $ / ' ZGESJV: ', /
1299 $ / '19 = | A - U diag(S) VT | / ( |A| max(M,N) ulp )',
1300 $ / '20 = | I - U**T U | / ( M ulp ) ',
1301 $ / '21 = | I - VT VT**T | / ( N ulp ) ',
1302 $ / '22 = 0 if S contains min(M,N) nonnegative values in',
1303 $ ' decreasing order, else 1/ulp',
1304 $ / ' ZGESVDX(V,V,A): ', /
1305 $ '23 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
1306 $ / '24 = | I - U**T U | / ( M ulp ) ',
1307 $ / '25 = | I - VT VT**T | / ( N ulp ) ',
1308 $ / '26 = 0 if S contains min(M,N) nonnegative values in',
1309 $ ' decreasing order, else 1/ulp',
1310 $ / '27 = | U - Upartial | / ( M ulp )',
1311 $ / '28 = | VT - VTpartial | / ( N ulp )',
1312 $ / '29 = | S - Spartial | / ( min(M,N) ulp |S| )',
1313 $ / ' ZGESVDX(V,V,I): ',
1314 $ / '30 = | U**T A VT**T - diag(S) | / ( |A| max(M,N) ulp )',
1315 $ / '31 = | I - U**T U | / ( M ulp ) ',
1316 $ / '32 = | I - VT VT**T | / ( N ulp ) ',
1317 $ / ' ZGESVDX(V,V,V) ',
1318 $ / '33 = | U**T A VT**T - diag(S) | / ( |A| max(M,N) ulp )',
1319 $ / '34 = | I - U**T U | / ( M ulp ) ',
1320 $ / '35 = | I - VT VT**T | / ( N ulp ) ',
1321 $ ' ZGESVDQ(H,N,N,A,A',
1322 $ / '36 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
1323 $ / '37 = | I - U**T U | / ( M ulp ) ',
1324 $ / '38 = | I - VT VT**T | / ( N ulp ) ',
1325 $ / '39 = 0 if S contains min(M,N) nonnegative values in',
1326 $ ' decreasing order, else 1/ulp',
1327 $ / / )
1328 9997 FORMAT( ' M=', i5, ', N=', i5, ', type ', i1, ', IWS=', i1,
1329 $ ', seed=', 4( i4, ',' ), ' test(', i2, ')=', g11.4 )
1330 9996 FORMAT( ' ZDRVBD: ', a, ' returned INFO=', i6, '.', / 9x, 'M=',
1331 $ i6, ', N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ),
1332 $ i5, ')' )
1333 9995 FORMAT( ' ZDRVBD: ', a, ' returned INFO=', i6, '.', / 9x, 'M=',
1334 $ i6, ', N=', i6, ', JTYPE=', i6, ', LSWORK=', i6, / 9x,
1335 $ 'ISEED=(', 3( i5, ',' ), i5, ')' )
1336*
1337 RETURN
1338*
1339* End of ZDRVBD
1340*
zgesvj
subroutine zgesvj(joba, jobu, jobv, m, n, a, lda, sva, mv, v, ldv, cwork, lwork, rwork, lrwork, info)
ZGESVJ
Definition zgesvj.f:351
zgesdd
subroutine zgesdd(jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, iwork, info)
ZGESDD
Definition zgesdd.f:227
zgesvdx
subroutine zgesvdx(jobu, jobvt, range, m, n, a, lda, vl, vu, il, iu, ns, s, u, ldu, vt, ldvt, work, lwork, rwork, iwork, info)
ZGESVDX computes the singular value decomposition (SVD) for GE matrices
Definition zgesvdx.f:270
zgejsv
subroutine zgejsv(joba, jobu, jobv, jobr, jobt, jobp, m, n, a, lda, sva, u, ldu, v, ldv, cwork, lwork, rwork, lrwork, iwork, info)
ZGEJSV
Definition zgejsv.f:569
zgesvdq
subroutine zgesvdq(joba, jobp, jobr, jobu, jobv, m, n, a, lda, s, u, ldu, v, ldv, numrank, iwork, liwork, cwork, lcwork, rwork, lrwork, info)
ZGESVDQ computes the singular value decomposition (SVD) with a QR-Preconditioned QR SVD Method for GE...
Definition zgesvdq.f:413
zunt03
subroutine zunt03(rc, mu, mv, n, k, u, ldu, v, ldv, work, lwork, rwork, result, info)
ZUNT03
Definition zunt03.f:162
zbdt05
subroutine zbdt05(m, n, a, lda, s, ns, u, ldu, vt, ldvt, work, resid)
ZBDT05
Definition zbdt05.f:125

◆ zdrves()

subroutine zdrves ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) h,
complex*16, dimension( lda, * ) ht,
complex*16, dimension( * ) w,
complex*16, dimension( * ) wt,
complex*16, dimension( ldvs, * ) vs,
integer ldvs,
double precision, dimension( 13 ) result,
complex*16, dimension( * ) work,
integer nwork,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
logical, dimension( * ) bwork,
integer info )

ZDRVES

Purpose:
!>
!>    ZDRVES checks the nonsymmetric eigenvalue (Schur form) problem
!>    driver ZGEES.
!>
!>    When ZDRVES is called, a number of matrix  () and a
!>    number of matrix  are specified.  For each size ()
!>    and each type of matrix, one matrix will be generated and used
!>    to test the nonsymmetric eigenroutines.  For each matrix, 13
!>    tests will be performed:
!>
!>    (1)     0 if T is in Schur form, 1/ulp otherwise
!>           (no sorting of eigenvalues)
!>
!>    (2)     | A - VS T VS' | / ( n |A| ulp )
!>
!>      Here VS is the matrix of Schur eigenvectors, and T is in Schur
!>      form  (no sorting of eigenvalues).
!>
!>    (3)     | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
!>
!>    (4)     0     if W are eigenvalues of T
!>            1/ulp otherwise
!>            (no sorting of eigenvalues)
!>
!>    (5)     0     if T(with VS) = T(without VS),
!>            1/ulp otherwise
!>            (no sorting of eigenvalues)
!>
!>    (6)     0     if eigenvalues(with VS) = eigenvalues(without VS),
!>            1/ulp otherwise
!>            (no sorting of eigenvalues)
!>
!>    (7)     0 if T is in Schur form, 1/ulp otherwise
!>            (with sorting of eigenvalues)
!>
!>    (8)     | A - VS T VS' | / ( n |A| ulp )
!>
!>      Here VS is the matrix of Schur eigenvectors, and T is in Schur
!>      form  (with sorting of eigenvalues).
!>
!>    (9)     | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
!>
!>    (10)    0     if W are eigenvalues of T
!>            1/ulp otherwise
!>            (with sorting of eigenvalues)
!>
!>    (11)    0     if T(with VS) = T(without VS),
!>            1/ulp otherwise
!>            (with sorting of eigenvalues)
!>
!>    (12)    0     if eigenvalues(with VS) = eigenvalues(without VS),
!>            1/ulp otherwise
!>            (with sorting of eigenvalues)
!>
!>    (13)    if sorting worked and SDIM is the number of
!>            eigenvalues which were SELECTed
!>
!>    The  are specified by an array NN(1:NSIZES); the value of
!>    each element NN(j) specifies one size.
!>    The  are specified by a logical array DOTYPE( 1:NTYPES );
!>    if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!>    Currently, the list of possible types is:
!>
!>    (1)  The zero matrix.
!>    (2)  The identity matrix.
!>    (3)  A (transposed) Jordan block, with 1's on the diagonal.
!>
!>    (4)  A diagonal matrix with evenly spaced entries
!>         1, ..., ULP  and random complex angles.
!>         (ULP = (first number larger than 1) - 1 )
!>    (5)  A diagonal matrix with geometrically spaced entries
!>         1, ..., ULP  and random complex angles.
!>    (6)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>         and random complex angles.
!>
!>    (7)  Same as (4), but multiplied by a constant near
!>         the overflow threshold
!>    (8)  Same as (4), but multiplied by a constant near
!>         the underflow threshold
!>
!>    (9)  A matrix of the form  U' T U, where U is unitary and
!>         T has evenly spaced entries 1, ..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (10) A matrix of the form  U' T U, where U is unitary and
!>         T has geometrically spaced entries 1, ..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (11) A matrix of the form  U' T U, where U is orthogonal and
!>         T has  entries 1, ULP,..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (12) A matrix of the form  U' T U, where U is unitary and
!>         T has complex eigenvalues randomly chosen from
!>         ULP < |z| < 1   and random O(1) entries in the upper
!>         triangle.
!>
!>    (13) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
!>         with random complex angles on the diagonal and random O(1)
!>         entries in the upper triangle.
!>
!>    (14) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has geometrically spaced entries
!>         1, ..., ULP with random complex angles on the diagonal
!>         and random O(1) entries in the upper triangle.
!>
!>    (15) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has  entries 1, ULP,..., ULP
!>         with random complex angles on the diagonal and random O(1)
!>         entries in the upper triangle.
!>
!>    (16) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has complex eigenvalues randomly chosen
!>         from ULP < |z| < 1 and random O(1) entries in the upper
!>         triangle.
!>
!>    (17) Same as (16), but multiplied by a constant
!>         near the overflow threshold
!>    (18) Same as (16), but multiplied by a constant
!>         near the underflow threshold
!>
!>    (19) Nonsymmetric matrix with random entries chosen from (-1,1).
!>         If N is at least 4, all entries in first two rows and last
!>         row, and first column and last two columns are zero.
!>    (20) Same as (19), but multiplied by a constant
!>         near the overflow threshold
!>    (21) Same as (19), but multiplied by a constant
!>         near the underflow threshold
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZDRVES does nothing.  It must be at least zero.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZDRVES
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRVES to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA, max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually used.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, and H. LDA must be at
!>          least 1 and at least max( NN ).
!>
[out]H
!>          H is COMPLEX*16 array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by ZGEES.
!>
[out]HT
!>          HT is COMPLEX*16 array, dimension (LDA, max(NN))
!>          Yet another copy of the test matrix A, modified by ZGEES.
!>
[out]W
!>          W is COMPLEX*16 array, dimension (max(NN))
!>          The computed eigenvalues of A.
!>
[out]WT
!>          WT is COMPLEX*16 array, dimension (max(NN))
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when ZGEES only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]VS
!>          VS is COMPLEX*16 array, dimension (LDVS, max(NN))
!>          VS holds the computed Schur vectors.
!>
[in]LDVS
!>          LDVS is INTEGER
!>          Leading dimension of VS. Must be at least max(1,max(NN)).
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (13)
!>          The values computed by the 13 tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NWORK)
!>
[in]NWORK
!>          NWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          5*NN(j)+2*NN(j)**2 for all j.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (max(NN))
!>
[out]BWORK
!>          BWORK is LOGICAL array, dimension (max(NN))
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -6: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -15: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ).
!>          -18: NWORK too small.
!>          If  ZLATMR, CLATMS, CLATME or ZGEES returns an error code,
!>              the absolute value of it is returned.
!>
!>-----------------------------------------------------------------------
!>
!>     Some Local Variables and Parameters:
!>     ---- ----- --------- --- ----------
!>     ZERO, ONE       Real 0 and 1.
!>     MAXTYP          The number of types defined.
!>     NMAX            Largest value in NN.
!>     NERRS           The number of tests which have exceeded THRESH
!>     COND, CONDS,
!>     IMODE           Values to be passed to the matrix generators.
!>     ANORM           Norm of A; passed to matrix generators.
!>
!>     OVFL, UNFL      Overflow and underflow thresholds.
!>     ULP, ULPINV     Finest relative precision and its inverse.
!>     RTULP, RTULPI   Square roots of the previous 4 values.
!>             The following four arrays decode JTYPE:
!>     KTYPE(j)        The general type (1-10) for type .
!>     KMODE(j)        The MODE value to be passed to the matrix
!>                     generator for type .
!>     KMAGN(j)        The order of magnitude ( O(1),
!>                     O(overflow^(1/2) ), O(underflow^(1/2) )
!>     KCONDS(j)       Select whether CONDS is to be 1 or
!>                     1/sqrt(ulp).  (0 means irrelevant.)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 375 of file zdrves.f.

378*
379* -- LAPACK test routine --
380* -- LAPACK is a software package provided by Univ. of Tennessee, --
381* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
382*
383* .. Scalar Arguments ..
384 INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK
385 DOUBLE PRECISION THRESH
386* ..
387* .. Array Arguments ..
388 LOGICAL BWORK( * ), DOTYPE( * )
389 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
390 DOUBLE PRECISION RESULT( 13 ), RWORK( * )
391 COMPLEX*16 A( LDA, * ), H( LDA, * ), HT( LDA, * ),
392 $ VS( LDVS, * ), W( * ), WORK( * ), WT( * )
393* ..
394*
395* =====================================================================
396*
397* .. Parameters ..
398 COMPLEX*16 CZERO
399 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
400 COMPLEX*16 CONE
401 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
402 DOUBLE PRECISION ZERO, ONE
403 parameter( zero = 0.0d+0, one = 1.0d+0 )
404 INTEGER MAXTYP
405 parameter( maxtyp = 21 )
406* ..
407* .. Local Scalars ..
408 LOGICAL BADNN
409 CHARACTER SORT
410 CHARACTER*3 PATH
411 INTEGER I, IINFO, IMODE, ISORT, ITYPE, IWK, J, JCOL,
412 $ JSIZE, JTYPE, KNTEIG, LWORK, MTYPES, N, NERRS,
413 $ NFAIL, NMAX, NNWORK, NTEST, NTESTF, NTESTT,
414 $ RSUB, SDIM
415 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
416 $ ULPINV, UNFL
417* ..
418* .. Local Arrays ..
419 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
420 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
421 $ KTYPE( MAXTYP )
422 DOUBLE PRECISION RES( 2 )
423* ..
424* .. Arrays in Common ..
425 LOGICAL SELVAL( 20 )
426 DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
427* ..
428* .. Scalars in Common ..
429 INTEGER SELDIM, SELOPT
430* ..
431* .. Common blocks ..
432 COMMON / sslct / selopt, seldim, selval, selwr, selwi
433* ..
434* .. External Functions ..
435 LOGICAL ZSLECT
436 DOUBLE PRECISION DLAMCH
437 EXTERNAL zslect, dlamch
438* ..
439* .. External Subroutines ..
440 EXTERNAL dlabad, dlasum, xerbla, zgees, zhst01, zlacpy,
441 $ zlaset, zlatme, zlatmr, zlatms
442* ..
443* .. Intrinsic Functions ..
444 INTRINSIC abs, dcmplx, max, min, sqrt
445* ..
446* .. Data statements ..
447 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
448 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
449 $ 3, 1, 2, 3 /
450 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
451 $ 1, 5, 5, 5, 4, 3, 1 /
452 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
453* ..
454* .. Executable Statements ..
455*
456 path( 1: 1 ) = 'Zomplex precision'
457 path( 2: 3 ) = 'ES'
458*
459* Check for errors
460*
461 ntestt = 0
462 ntestf = 0
463 info = 0
464 selopt = 0
465*
466* Important constants
467*
468 badnn = .false.
469 nmax = 0
470 DO 10 j = 1, nsizes
471 nmax = max( nmax, nn( j ) )
472 IF( nn( j ).LT.0 )
473 $ badnn = .true.
474 10 CONTINUE
475*
476* Check for errors
477*
478 IF( nsizes.LT.0 ) THEN
479 info = -1
480 ELSE IF( badnn ) THEN
481 info = -2
482 ELSE IF( ntypes.LT.0 ) THEN
483 info = -3
484 ELSE IF( thresh.LT.zero ) THEN
485 info = -6
486 ELSE IF( nounit.LE.0 ) THEN
487 info = -7
488 ELSE IF( lda.LT.1 .OR. lda.LT.nmax ) THEN
489 info = -9
490 ELSE IF( ldvs.LT.1 .OR. ldvs.LT.nmax ) THEN
491 info = -15
492 ELSE IF( 5*nmax+2*nmax**2.GT.nwork ) THEN
493 info = -18
494 END IF
495*
496 IF( info.NE.0 ) THEN
497 CALL xerbla( 'ZDRVES', -info )
498 RETURN
499 END IF
500*
501* Quick return if nothing to do
502*
503 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
504 $ RETURN
505*
506* More Important constants
507*
508 unfl = dlamch( 'Safe minimum' )
509 ovfl = one / unfl
510 CALL dlabad( unfl, ovfl )
511 ulp = dlamch( 'Precision' )
512 ulpinv = one / ulp
513 rtulp = sqrt( ulp )
514 rtulpi = one / rtulp
515*
516* Loop over sizes, types
517*
518 nerrs = 0
519*
520 DO 240 jsize = 1, nsizes
521 n = nn( jsize )
522 IF( nsizes.NE.1 ) THEN
523 mtypes = min( maxtyp, ntypes )
524 ELSE
525 mtypes = min( maxtyp+1, ntypes )
526 END IF
527*
528 DO 230 jtype = 1, mtypes
529 IF( .NOT.dotype( jtype ) )
530 $ GO TO 230
531*
532* Save ISEED in case of an error.
533*
534 DO 20 j = 1, 4
535 ioldsd( j ) = iseed( j )
536 20 CONTINUE
537*
538* Compute "A"
539*
540* Control parameters:
541*
542* KMAGN KCONDS KMODE KTYPE
543* =1 O(1) 1 clustered 1 zero
544* =2 large large clustered 2 identity
545* =3 small exponential Jordan
546* =4 arithmetic diagonal, (w/ eigenvalues)
547* =5 random log symmetric, w/ eigenvalues
548* =6 random general, w/ eigenvalues
549* =7 random diagonal
550* =8 random symmetric
551* =9 random general
552* =10 random triangular
553*
554 IF( mtypes.GT.maxtyp )
555 $ GO TO 90
556*
557 itype = ktype( jtype )
558 imode = kmode( jtype )
559*
560* Compute norm
561*
562 GO TO ( 30, 40, 50 )kmagn( jtype )
563*
564 30 CONTINUE
565 anorm = one
566 GO TO 60
567*
568 40 CONTINUE
569 anorm = ovfl*ulp
570 GO TO 60
571*
572 50 CONTINUE
573 anorm = unfl*ulpinv
574 GO TO 60
575*
576 60 CONTINUE
577*
578 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
579 iinfo = 0
580 cond = ulpinv
581*
582* Special Matrices -- Identity & Jordan block
583*
584 IF( itype.EQ.1 ) THEN
585*
586* Zero
587*
588 iinfo = 0
589*
590 ELSE IF( itype.EQ.2 ) THEN
591*
592* Identity
593*
594 DO 70 jcol = 1, n
595 a( jcol, jcol ) = dcmplx( anorm )
596 70 CONTINUE
597*
598 ELSE IF( itype.EQ.3 ) THEN
599*
600* Jordan Block
601*
602 DO 80 jcol = 1, n
603 a( jcol, jcol ) = dcmplx( anorm )
604 IF( jcol.GT.1 )
605 $ a( jcol, jcol-1 ) = cone
606 80 CONTINUE
607*
608 ELSE IF( itype.EQ.4 ) THEN
609*
610* Diagonal Matrix, [Eigen]values Specified
611*
612 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
613 $ anorm, 0, 0, 'N', a, lda, work( n+1 ),
614 $ iinfo )
615*
616 ELSE IF( itype.EQ.5 ) THEN
617*
618* Symmetric, eigenvalues specified
619*
620 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
621 $ anorm, n, n, 'N', a, lda, work( n+1 ),
622 $ iinfo )
623*
624 ELSE IF( itype.EQ.6 ) THEN
625*
626* General, eigenvalues specified
627*
628 IF( kconds( jtype ).EQ.1 ) THEN
629 conds = one
630 ELSE IF( kconds( jtype ).EQ.2 ) THEN
631 conds = rtulpi
632 ELSE
633 conds = zero
634 END IF
635*
636 CALL zlatme( n, 'D', iseed, work, imode, cond, cone,
637 $ 'T', 'T', 'T', rwork, 4, conds, n, n, anorm,
638 $ a, lda, work( 2*n+1 ), iinfo )
639*
640 ELSE IF( itype.EQ.7 ) THEN
641*
642* Diagonal, random eigenvalues
643*
644 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
645 $ 'T', 'N', work( n+1 ), 1, one,
646 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
647 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
648*
649 ELSE IF( itype.EQ.8 ) THEN
650*
651* Symmetric, random eigenvalues
652*
653 CALL zlatmr( n, n, 'D', iseed, 'H', work, 6, one, cone,
654 $ 'T', 'N', work( n+1 ), 1, one,
655 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
656 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
657*
658 ELSE IF( itype.EQ.9 ) THEN
659*
660* General, random eigenvalues
661*
662 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
663 $ 'T', 'N', work( n+1 ), 1, one,
664 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
665 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
666 IF( n.GE.4 ) THEN
667 CALL zlaset( 'Full', 2, n, czero, czero, a, lda )
668 CALL zlaset( 'Full', n-3, 1, czero, czero, a( 3, 1 ),
669 $ lda )
670 CALL zlaset( 'Full', n-3, 2, czero, czero,
671 $ a( 3, n-1 ), lda )
672 CALL zlaset( 'Full', 1, n, czero, czero, a( n, 1 ),
673 $ lda )
674 END IF
675*
676 ELSE IF( itype.EQ.10 ) THEN
677*
678* Triangular, random eigenvalues
679*
680 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
681 $ 'T', 'N', work( n+1 ), 1, one,
682 $ work( 2*n+1 ), 1, one, 'N', idumma, n, 0,
683 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
684*
685 ELSE
686*
687 iinfo = 1
688 END IF
689*
690 IF( iinfo.NE.0 ) THEN
691 WRITE( nounit, fmt = 9992 )'Generator', iinfo, n, jtype,
692 $ ioldsd
693 info = abs( iinfo )
694 RETURN
695 END IF
696*
697 90 CONTINUE
698*
699* Test for minimal and generous workspace
700*
701 DO 220 iwk = 1, 2
702 IF( iwk.EQ.1 ) THEN
703 nnwork = 3*n
704 ELSE
705 nnwork = 5*n + 2*n**2
706 END IF
707 nnwork = max( nnwork, 1 )
708*
709* Initialize RESULT
710*
711 DO 100 j = 1, 13
712 result( j ) = -one
713 100 CONTINUE
714*
715* Test with and without sorting of eigenvalues
716*
717 DO 180 isort = 0, 1
718 IF( isort.EQ.0 ) THEN
719 sort = 'N'
720 rsub = 0
721 ELSE
722 sort = 'S'
723 rsub = 6
724 END IF
725*
726* Compute Schur form and Schur vectors, and test them
727*
728 CALL zlacpy( 'F', n, n, a, lda, h, lda )
729 CALL zgees( 'V', sort, zslect, n, h, lda, sdim, w, vs,
730 $ ldvs, work, nnwork, rwork, bwork, iinfo )
731 IF( iinfo.NE.0 ) THEN
732 result( 1+rsub ) = ulpinv
733 WRITE( nounit, fmt = 9992 )'ZGEES1', iinfo, n,
734 $ jtype, ioldsd
735 info = abs( iinfo )
736 GO TO 190
737 END IF
738*
739* Do Test (1) or Test (7)
740*
741 result( 1+rsub ) = zero
742 DO 120 j = 1, n - 1
743 DO 110 i = j + 1, n
744 IF( h( i, j ).NE.zero )
745 $ result( 1+rsub ) = ulpinv
746 110 CONTINUE
747 120 CONTINUE
748*
749* Do Tests (2) and (3) or Tests (8) and (9)
750*
751 lwork = max( 1, 2*n*n )
752 CALL zhst01( n, 1, n, a, lda, h, lda, vs, ldvs, work,
753 $ lwork, rwork, res )
754 result( 2+rsub ) = res( 1 )
755 result( 3+rsub ) = res( 2 )
756*
757* Do Test (4) or Test (10)
758*
759 result( 4+rsub ) = zero
760 DO 130 i = 1, n
761 IF( h( i, i ).NE.w( i ) )
762 $ result( 4+rsub ) = ulpinv
763 130 CONTINUE
764*
765* Do Test (5) or Test (11)
766*
767 CALL zlacpy( 'F', n, n, a, lda, ht, lda )
768 CALL zgees( 'N', sort, zslect, n, ht, lda, sdim, wt,
769 $ vs, ldvs, work, nnwork, rwork, bwork,
770 $ iinfo )
771 IF( iinfo.NE.0 ) THEN
772 result( 5+rsub ) = ulpinv
773 WRITE( nounit, fmt = 9992 )'ZGEES2', iinfo, n,
774 $ jtype, ioldsd
775 info = abs( iinfo )
776 GO TO 190
777 END IF
778*
779 result( 5+rsub ) = zero
780 DO 150 j = 1, n
781 DO 140 i = 1, n
782 IF( h( i, j ).NE.ht( i, j ) )
783 $ result( 5+rsub ) = ulpinv
784 140 CONTINUE
785 150 CONTINUE
786*
787* Do Test (6) or Test (12)
788*
789 result( 6+rsub ) = zero
790 DO 160 i = 1, n
791 IF( w( i ).NE.wt( i ) )
792 $ result( 6+rsub ) = ulpinv
793 160 CONTINUE
794*
795* Do Test (13)
796*
797 IF( isort.EQ.1 ) THEN
798 result( 13 ) = zero
799 knteig = 0
800 DO 170 i = 1, n
801 IF( zslect( w( i ) ) )
802 $ knteig = knteig + 1
803 IF( i.LT.n ) THEN
804 IF( zslect( w( i+1 ) ) .AND.
805 $ ( .NOT.zslect( w( i ) ) ) )result( 13 )
806 $ = ulpinv
807 END IF
808 170 CONTINUE
809 IF( sdim.NE.knteig )
810 $ result( 13 ) = ulpinv
811 END IF
812*
813 180 CONTINUE
814*
815* End of Loop -- Check for RESULT(j) > THRESH
816*
817 190 CONTINUE
818*
819 ntest = 0
820 nfail = 0
821 DO 200 j = 1, 13
822 IF( result( j ).GE.zero )
823 $ ntest = ntest + 1
824 IF( result( j ).GE.thresh )
825 $ nfail = nfail + 1
826 200 CONTINUE
827*
828 IF( nfail.GT.0 )
829 $ ntestf = ntestf + 1
830 IF( ntestf.EQ.1 ) THEN
831 WRITE( nounit, fmt = 9999 )path
832 WRITE( nounit, fmt = 9998 )
833 WRITE( nounit, fmt = 9997 )
834 WRITE( nounit, fmt = 9996 )
835 WRITE( nounit, fmt = 9995 )thresh
836 WRITE( nounit, fmt = 9994 )
837 ntestf = 2
838 END IF
839*
840 DO 210 j = 1, 13
841 IF( result( j ).GE.thresh ) THEN
842 WRITE( nounit, fmt = 9993 )n, iwk, ioldsd, jtype,
843 $ j, result( j )
844 END IF
845 210 CONTINUE
846*
847 nerrs = nerrs + nfail
848 ntestt = ntestt + ntest
849*
850 220 CONTINUE
851 230 CONTINUE
852 240 CONTINUE
853*
854* Summary
855*
856 CALL dlasum( path, nounit, nerrs, ntestt )
857*
858 9999 FORMAT( / 1x, a3, ' -- Complex Schur Form Decomposition Driver',
859 $ / ' Matrix types (see ZDRVES for details): ' )
860*
861 9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
862 $ ' ', ' 5=Diagonal: geometr. spaced entries.',
863 $ / ' 2=Identity matrix. ', ' 6=Diagona',
864 $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
865 $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
866 $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
867 $ 'mall, evenly spaced.' )
868 9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
869 $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
870 $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
871 $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
872 $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
873 $ 'lex ', a6, / ' 12=Well-cond., random complex ', a6, ' ',
874 $ ' 17=Ill-cond., large rand. complx ', a4, / ' 13=Ill-condi',
875 $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
876 $ ' complx ', a4 )
877 9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
878 $ 'with small random entries.', / ' 20=Matrix with large ran',
879 $ 'dom entries. ', / )
880 9995 FORMAT( ' Tests performed with test threshold =', f8.2,
881 $ / ' ( A denotes A on input and T denotes A on output)',
882 $ / / ' 1 = 0 if T in Schur form (no sort), ',
883 $ ' 1/ulp otherwise', /
884 $ ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
885 $ / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ',
886 $ / ' 4 = 0 if W are eigenvalues of T (no sort),',
887 $ ' 1/ulp otherwise', /
888 $ ' 5 = 0 if T same no matter if VS computed (no sort),',
889 $ ' 1/ulp otherwise', /
890 $ ' 6 = 0 if W same no matter if VS computed (no sort)',
891 $ ', 1/ulp otherwise' )
892 9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', ' 1/ulp otherwise',
893 $ / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
894 $ / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
895 $ / ' 10 = 0 if W are eigenvalues of T (sort),',
896 $ ' 1/ulp otherwise', /
897 $ ' 11 = 0 if T same no matter if VS computed (sort),',
898 $ ' 1/ulp otherwise', /
899 $ ' 12 = 0 if W same no matter if VS computed (sort),',
900 $ ' 1/ulp otherwise', /
901 $ ' 13 = 0 if sorting successful, 1/ulp otherwise', / )
902 9993 FORMAT( ' N=', i5, ', IWK=', i2, ', seed=', 4( i4, ',' ),
903 $ ' type ', i2, ', test(', i2, ')=', g10.3 )
904 9992 FORMAT( ' ZDRVES: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
905 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
906*
907 RETURN
908*
909* End of ZDRVES
910*
zgees
subroutine zgees(jobvs, sort, select, n, a, lda, sdim, w, vs, ldvs, work, lwork, rwork, bwork, info)
ZGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE m...
Definition zgees.f:197
zslect
logical function zslect(z)
ZSLECT
Definition zslect.f:56

◆ zdrvev()

subroutine zdrvev ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) h,
complex*16, dimension( * ) w,
complex*16, dimension( * ) w1,
complex*16, dimension( ldvl, * ) vl,
integer ldvl,
complex*16, dimension( ldvr, * ) vr,
integer ldvr,
complex*16, dimension( ldlre, * ) lre,
integer ldlre,
double precision, dimension( 7 ) result,
complex*16, dimension( * ) work,
integer nwork,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer info )

ZDRVEV

Purpose:
!>
!>    ZDRVEV  checks the nonsymmetric eigenvalue problem driver ZGEEV.
!>
!>    When ZDRVEV is called, a number of matrix  () and a
!>    number of matrix  are specified.  For each size ()
!>    and each type of matrix, one matrix will be generated and used
!>    to test the nonsymmetric eigenroutines.  For each matrix, 7
!>    tests will be performed:
!>
!>    (1)     | A * VR - VR * W | / ( n |A| ulp )
!>
!>      Here VR is the matrix of unit right eigenvectors.
!>      W is a diagonal matrix with diagonal entries W(j).
!>
!>    (2)     | A**H * VL - VL * W**H | / ( n |A| ulp )
!>
!>      Here VL is the matrix of unit left eigenvectors, A**H is the
!>      conjugate-transpose of A, and W is as above.
!>
!>    (3)     | |VR(i)| - 1 | / ulp and whether largest component real
!>
!>      VR(i) denotes the i-th column of VR.
!>
!>    (4)     | |VL(i)| - 1 | / ulp and whether largest component real
!>
!>      VL(i) denotes the i-th column of VL.
!>
!>    (5)     W(full) = W(partial)
!>
!>      W(full) denotes the eigenvalues computed when both VR and VL
!>      are also computed, and W(partial) denotes the eigenvalues
!>      computed when only W, only W and VR, or only W and VL are
!>      computed.
!>
!>    (6)     VR(full) = VR(partial)
!>
!>      VR(full) denotes the right eigenvectors computed when both VR
!>      and VL are computed, and VR(partial) denotes the result
!>      when only VR is computed.
!>
!>     (7)     VL(full) = VL(partial)
!>
!>      VL(full) denotes the left eigenvectors computed when both VR
!>      and VL are also computed, and VL(partial) denotes the result
!>      when only VL is computed.
!>
!>    The  are specified by an array NN(1:NSIZES); the value of
!>    each element NN(j) specifies one size.
!>    The  are specified by a logical array DOTYPE( 1:NTYPES );
!>    if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!>    Currently, the list of possible types is:
!>
!>    (1)  The zero matrix.
!>    (2)  The identity matrix.
!>    (3)  A (transposed) Jordan block, with 1's on the diagonal.
!>
!>    (4)  A diagonal matrix with evenly spaced entries
!>         1, ..., ULP  and random complex angles.
!>         (ULP = (first number larger than 1) - 1 )
!>    (5)  A diagonal matrix with geometrically spaced entries
!>         1, ..., ULP  and random complex angles.
!>    (6)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>         and random complex angles.
!>
!>    (7)  Same as (4), but multiplied by a constant near
!>         the overflow threshold
!>    (8)  Same as (4), but multiplied by a constant near
!>         the underflow threshold
!>
!>    (9)  A matrix of the form  U' T U, where U is unitary and
!>         T has evenly spaced entries 1, ..., ULP with random complex
!>         angles on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (10) A matrix of the form  U' T U, where U is unitary and
!>         T has geometrically spaced entries 1, ..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (11) A matrix of the form  U' T U, where U is unitary and
!>         T has  entries 1, ULP,..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (12) A matrix of the form  U' T U, where U is unitary and
!>         T has complex eigenvalues randomly chosen from
!>         ULP < |z| < 1   and random O(1) entries in the upper
!>         triangle.
!>
!>    (13) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
!>         with random complex angles on the diagonal and random O(1)
!>         entries in the upper triangle.
!>
!>    (14) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has geometrically spaced entries
!>         1, ..., ULP with random complex angles on the diagonal
!>         and random O(1) entries in the upper triangle.
!>
!>    (15) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has  entries 1, ULP,..., ULP
!>         with random complex angles on the diagonal and random O(1)
!>         entries in the upper triangle.
!>
!>    (16) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has complex eigenvalues randomly chosen
!>         from ULP < |z| < 1 and random O(1) entries in the upper
!>         triangle.
!>
!>    (17) Same as (16), but multiplied by a constant
!>         near the overflow threshold
!>    (18) Same as (16), but multiplied by a constant
!>         near the underflow threshold
!>
!>    (19) Nonsymmetric matrix with random entries chosen from |z| < 1
!>         If N is at least 4, all entries in first two rows and last
!>         row, and first column and last two columns are zero.
!>    (20) Same as (19), but multiplied by a constant
!>         near the overflow threshold
!>    (21) Same as (19), but multiplied by a constant
!>         near the underflow threshold
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZDRVEV does nothing.  It must be at least zero.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZDRVEV
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRVEV to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA, max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually used.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, and H. LDA must be at
!>          least 1 and at least max(NN).
!>
[out]H
!>          H is COMPLEX*16 array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by ZGEEV.
!>
[out]W
!>          W is COMPLEX*16 array, dimension (max(NN))
!>          The eigenvalues of A. On exit, W are the eigenvalues of
!>          the matrix in A.
!>
[out]W1
!>          W1 is COMPLEX*16 array, dimension (max(NN))
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when ZGEEV only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is COMPLEX*16 array, dimension (LDVL, max(NN))
!>          VL holds the computed left eigenvectors.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          Leading dimension of VL. Must be at least max(1,max(NN)).
!>
[out]VR
!>          VR is COMPLEX*16 array, dimension (LDVR, max(NN))
!>          VR holds the computed right eigenvectors.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          Leading dimension of VR. Must be at least max(1,max(NN)).
!>
[out]LRE
!>          LRE is COMPLEX*16 array, dimension (LDLRE, max(NN))
!>          LRE holds the computed right or left eigenvectors.
!>
[in]LDLRE
!>          LDLRE is INTEGER
!>          Leading dimension of LRE. Must be at least max(1,max(NN)).
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (7)
!>          The values computed by the seven tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NWORK)
!>
[in]NWORK
!>          NWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          5*NN(j)+2*NN(j)**2 for all j.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*max(NN))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (max(NN))
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -6: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -14: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ).
!>          -16: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ).
!>          -18: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ).
!>          -21: NWORK too small.
!>          If  ZLATMR, CLATMS, CLATME or ZGEEV returns an error code,
!>              the absolute value of it is returned.
!>
!>-----------------------------------------------------------------------
!>
!>     Some Local Variables and Parameters:
!>     ---- ----- --------- --- ----------
!>
!>     ZERO, ONE       Real 0 and 1.
!>     MAXTYP          The number of types defined.
!>     NMAX            Largest value in NN.
!>     NERRS           The number of tests which have exceeded THRESH
!>     COND, CONDS,
!>     IMODE           Values to be passed to the matrix generators.
!>     ANORM           Norm of A; passed to matrix generators.
!>
!>     OVFL, UNFL      Overflow and underflow thresholds.
!>     ULP, ULPINV     Finest relative precision and its inverse.
!>     RTULP, RTULPI   Square roots of the previous 4 values.
!>
!>             The following four arrays decode JTYPE:
!>     KTYPE(j)        The general type (1-10) for type .
!>     KMODE(j)        The MODE value to be passed to the matrix
!>                     generator for type .
!>     KMAGN(j)        The order of magnitude ( O(1),
!>                     O(overflow^(1/2) ), O(underflow^(1/2) )
!>     KCONDS(j)       Selectw whether CONDS is to be 1 or
!>                     1/sqrt(ulp).  (0 means irrelevant.)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 387 of file zdrvev.f.

391*
392* -- LAPACK test routine --
393* -- LAPACK is a software package provided by Univ. of Tennessee, --
394* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
395*
396* .. Scalar Arguments ..
397 INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES,
398 $ NTYPES, NWORK
399 DOUBLE PRECISION THRESH
400* ..
401* .. Array Arguments ..
402 LOGICAL DOTYPE( * )
403 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
404 DOUBLE PRECISION RESULT( 7 ), RWORK( * )
405 COMPLEX*16 A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
406 $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ),
407 $ WORK( * )
408* ..
409*
410* =====================================================================
411*
412* .. Parameters ..
413 COMPLEX*16 CZERO
414 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
415 COMPLEX*16 CONE
416 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
417 DOUBLE PRECISION ZERO, ONE
418 parameter( zero = 0.0d+0, one = 1.0d+0 )
419 DOUBLE PRECISION TWO
420 parameter( two = 2.0d+0 )
421 INTEGER MAXTYP
422 parameter( maxtyp = 21 )
423* ..
424* .. Local Scalars ..
425 LOGICAL BADNN
426 CHARACTER*3 PATH
427 INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE,
428 $ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX, NNWORK,
429 $ NTEST, NTESTF, NTESTT
430 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TNRM,
431 $ ULP, ULPINV, UNFL, VMX, VRMX, VTST
432* ..
433* .. Local Arrays ..
434 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
435 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
436 $ KTYPE( MAXTYP )
437 DOUBLE PRECISION RES( 2 )
438 COMPLEX*16 DUM( 1 )
439* ..
440* .. External Functions ..
441 DOUBLE PRECISION DLAMCH, DZNRM2
442 EXTERNAL dlamch, dznrm2
443* ..
444* .. External Subroutines ..
445 EXTERNAL dlabad, dlasum, xerbla, zgeev, zget22, zlacpy,
446 $ zlaset, zlatme, zlatmr, zlatms
447* ..
448* .. Intrinsic Functions ..
449 INTRINSIC abs, dble, dcmplx, dimag, max, min, sqrt
450* ..
451* .. Data statements ..
452 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
453 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
454 $ 3, 1, 2, 3 /
455 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
456 $ 1, 5, 5, 5, 4, 3, 1 /
457 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
458* ..
459* .. Executable Statements ..
460*
461 path( 1: 1 ) = 'Zomplex precision'
462 path( 2: 3 ) = 'EV'
463*
464* Check for errors
465*
466 ntestt = 0
467 ntestf = 0
468 info = 0
469*
470* Important constants
471*
472 badnn = .false.
473 nmax = 0
474 DO 10 j = 1, nsizes
475 nmax = max( nmax, nn( j ) )
476 IF( nn( j ).LT.0 )
477 $ badnn = .true.
478 10 CONTINUE
479*
480* Check for errors
481*
482 IF( nsizes.LT.0 ) THEN
483 info = -1
484 ELSE IF( badnn ) THEN
485 info = -2
486 ELSE IF( ntypes.LT.0 ) THEN
487 info = -3
488 ELSE IF( thresh.LT.zero ) THEN
489 info = -6
490 ELSE IF( nounit.LE.0 ) THEN
491 info = -7
492 ELSE IF( lda.LT.1 .OR. lda.LT.nmax ) THEN
493 info = -9
494 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax ) THEN
495 info = -14
496 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax ) THEN
497 info = -16
498 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax ) THEN
499 info = -28
500 ELSE IF( 5*nmax+2*nmax**2.GT.nwork ) THEN
501 info = -21
502 END IF
503*
504 IF( info.NE.0 ) THEN
505 CALL xerbla( 'ZDRVEV', -info )
506 RETURN
507 END IF
508*
509* Quick return if nothing to do
510*
511 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
512 $ RETURN
513*
514* More Important constants
515*
516 unfl = dlamch( 'Safe minimum' )
517 ovfl = one / unfl
518 CALL dlabad( unfl, ovfl )
519 ulp = dlamch( 'Precision' )
520 ulpinv = one / ulp
521 rtulp = sqrt( ulp )
522 rtulpi = one / rtulp
523*
524* Loop over sizes, types
525*
526 nerrs = 0
527*
528 DO 270 jsize = 1, nsizes
529 n = nn( jsize )
530 IF( nsizes.NE.1 ) THEN
531 mtypes = min( maxtyp, ntypes )
532 ELSE
533 mtypes = min( maxtyp+1, ntypes )
534 END IF
535*
536 DO 260 jtype = 1, mtypes
537 IF( .NOT.dotype( jtype ) )
538 $ GO TO 260
539*
540* Save ISEED in case of an error.
541*
542 DO 20 j = 1, 4
543 ioldsd( j ) = iseed( j )
544 20 CONTINUE
545*
546* Compute "A"
547*
548* Control parameters:
549*
550* KMAGN KCONDS KMODE KTYPE
551* =1 O(1) 1 clustered 1 zero
552* =2 large large clustered 2 identity
553* =3 small exponential Jordan
554* =4 arithmetic diagonal, (w/ eigenvalues)
555* =5 random log symmetric, w/ eigenvalues
556* =6 random general, w/ eigenvalues
557* =7 random diagonal
558* =8 random symmetric
559* =9 random general
560* =10 random triangular
561*
562 IF( mtypes.GT.maxtyp )
563 $ GO TO 90
564*
565 itype = ktype( jtype )
566 imode = kmode( jtype )
567*
568* Compute norm
569*
570 GO TO ( 30, 40, 50 )kmagn( jtype )
571*
572 30 CONTINUE
573 anorm = one
574 GO TO 60
575*
576 40 CONTINUE
577 anorm = ovfl*ulp
578 GO TO 60
579*
580 50 CONTINUE
581 anorm = unfl*ulpinv
582 GO TO 60
583*
584 60 CONTINUE
585*
586 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
587 iinfo = 0
588 cond = ulpinv
589*
590* Special Matrices -- Identity & Jordan block
591*
592* Zero
593*
594 IF( itype.EQ.1 ) THEN
595 iinfo = 0
596*
597 ELSE IF( itype.EQ.2 ) THEN
598*
599* Identity
600*
601 DO 70 jcol = 1, n
602 a( jcol, jcol ) = dcmplx( anorm )
603 70 CONTINUE
604*
605 ELSE IF( itype.EQ.3 ) THEN
606*
607* Jordan Block
608*
609 DO 80 jcol = 1, n
610 a( jcol, jcol ) = dcmplx( anorm )
611 IF( jcol.GT.1 )
612 $ a( jcol, jcol-1 ) = cone
613 80 CONTINUE
614*
615 ELSE IF( itype.EQ.4 ) THEN
616*
617* Diagonal Matrix, [Eigen]values Specified
618*
619 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
620 $ anorm, 0, 0, 'N', a, lda, work( n+1 ),
621 $ iinfo )
622*
623 ELSE IF( itype.EQ.5 ) THEN
624*
625* Hermitian, eigenvalues specified
626*
627 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
628 $ anorm, n, n, 'N', a, lda, work( n+1 ),
629 $ iinfo )
630*
631 ELSE IF( itype.EQ.6 ) THEN
632*
633* General, eigenvalues specified
634*
635 IF( kconds( jtype ).EQ.1 ) THEN
636 conds = one
637 ELSE IF( kconds( jtype ).EQ.2 ) THEN
638 conds = rtulpi
639 ELSE
640 conds = zero
641 END IF
642*
643 CALL zlatme( n, 'D', iseed, work, imode, cond, cone,
644 $ 'T', 'T', 'T', rwork, 4, conds, n, n, anorm,
645 $ a, lda, work( 2*n+1 ), iinfo )
646*
647 ELSE IF( itype.EQ.7 ) THEN
648*
649* Diagonal, random eigenvalues
650*
651 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
652 $ 'T', 'N', work( n+1 ), 1, one,
653 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
654 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
655*
656 ELSE IF( itype.EQ.8 ) THEN
657*
658* Symmetric, random eigenvalues
659*
660 CALL zlatmr( n, n, 'D', iseed, 'H', work, 6, one, cone,
661 $ 'T', 'N', work( n+1 ), 1, one,
662 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
663 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
664*
665 ELSE IF( itype.EQ.9 ) THEN
666*
667* General, random eigenvalues
668*
669 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
670 $ 'T', 'N', work( n+1 ), 1, one,
671 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
672 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
673 IF( n.GE.4 ) THEN
674 CALL zlaset( 'Full', 2, n, czero, czero, a, lda )
675 CALL zlaset( 'Full', n-3, 1, czero, czero, a( 3, 1 ),
676 $ lda )
677 CALL zlaset( 'Full', n-3, 2, czero, czero,
678 $ a( 3, n-1 ), lda )
679 CALL zlaset( 'Full', 1, n, czero, czero, a( n, 1 ),
680 $ lda )
681 END IF
682*
683 ELSE IF( itype.EQ.10 ) THEN
684*
685* Triangular, random eigenvalues
686*
687 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
688 $ 'T', 'N', work( n+1 ), 1, one,
689 $ work( 2*n+1 ), 1, one, 'N', idumma, n, 0,
690 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
691*
692 ELSE
693*
694 iinfo = 1
695 END IF
696*
697 IF( iinfo.NE.0 ) THEN
698 WRITE( nounit, fmt = 9993 )'Generator', iinfo, n, jtype,
699 $ ioldsd
700 info = abs( iinfo )
701 RETURN
702 END IF
703*
704 90 CONTINUE
705*
706* Test for minimal and generous workspace
707*
708 DO 250 iwk = 1, 2
709 IF( iwk.EQ.1 ) THEN
710 nnwork = 2*n
711 ELSE
712 nnwork = 5*n + 2*n**2
713 END IF
714 nnwork = max( nnwork, 1 )
715*
716* Initialize RESULT
717*
718 DO 100 j = 1, 7
719 result( j ) = -one
720 100 CONTINUE
721*
722* Compute eigenvalues and eigenvectors, and test them
723*
724 CALL zlacpy( 'F', n, n, a, lda, h, lda )
725 CALL zgeev( 'V', 'V', n, h, lda, w, vl, ldvl, vr, ldvr,
726 $ work, nnwork, rwork, iinfo )
727 IF( iinfo.NE.0 ) THEN
728 result( 1 ) = ulpinv
729 WRITE( nounit, fmt = 9993 )'ZGEEV1', iinfo, n, jtype,
730 $ ioldsd
731 info = abs( iinfo )
732 GO TO 220
733 END IF
734*
735* Do Test (1)
736*
737 CALL zget22( 'N', 'N', 'N', n, a, lda, vr, ldvr, w, work,
738 $ rwork, res )
739 result( 1 ) = res( 1 )
740*
741* Do Test (2)
742*
743 CALL zget22( 'C', 'N', 'C', n, a, lda, vl, ldvl, w, work,
744 $ rwork, res )
745 result( 2 ) = res( 1 )
746*
747* Do Test (3)
748*
749 DO 120 j = 1, n
750 tnrm = dznrm2( n, vr( 1, j ), 1 )
751 result( 3 ) = max( result( 3 ),
752 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
753 vmx = zero
754 vrmx = zero
755 DO 110 jj = 1, n
756 vtst = abs( vr( jj, j ) )
757 IF( vtst.GT.vmx )
758 $ vmx = vtst
759 IF( dimag( vr( jj, j ) ).EQ.zero .AND.
760 $ abs( dble( vr( jj, j ) ) ).GT.vrmx )
761 $ vrmx = abs( dble( vr( jj, j ) ) )
762 110 CONTINUE
763 IF( vrmx / vmx.LT.one-two*ulp )
764 $ result( 3 ) = ulpinv
765 120 CONTINUE
766*
767* Do Test (4)
768*
769 DO 140 j = 1, n
770 tnrm = dznrm2( n, vl( 1, j ), 1 )
771 result( 4 ) = max( result( 4 ),
772 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
773 vmx = zero
774 vrmx = zero
775 DO 130 jj = 1, n
776 vtst = abs( vl( jj, j ) )
777 IF( vtst.GT.vmx )
778 $ vmx = vtst
779 IF( dimag( vl( jj, j ) ).EQ.zero .AND.
780 $ abs( dble( vl( jj, j ) ) ).GT.vrmx )
781 $ vrmx = abs( dble( vl( jj, j ) ) )
782 130 CONTINUE
783 IF( vrmx / vmx.LT.one-two*ulp )
784 $ result( 4 ) = ulpinv
785 140 CONTINUE
786*
787* Compute eigenvalues only, and test them
788*
789 CALL zlacpy( 'F', n, n, a, lda, h, lda )
790 CALL zgeev( 'N', 'N', n, h, lda, w1, dum, 1, dum, 1,
791 $ work, nnwork, rwork, iinfo )
792 IF( iinfo.NE.0 ) THEN
793 result( 1 ) = ulpinv
794 WRITE( nounit, fmt = 9993 )'ZGEEV2', iinfo, n, jtype,
795 $ ioldsd
796 info = abs( iinfo )
797 GO TO 220
798 END IF
799*
800* Do Test (5)
801*
802 DO 150 j = 1, n
803 IF( w( j ).NE.w1( j ) )
804 $ result( 5 ) = ulpinv
805 150 CONTINUE
806*
807* Compute eigenvalues and right eigenvectors, and test them
808*
809 CALL zlacpy( 'F', n, n, a, lda, h, lda )
810 CALL zgeev( 'N', 'V', n, h, lda, w1, dum, 1, lre, ldlre,
811 $ work, nnwork, rwork, iinfo )
812 IF( iinfo.NE.0 ) THEN
813 result( 1 ) = ulpinv
814 WRITE( nounit, fmt = 9993 )'ZGEEV3', iinfo, n, jtype,
815 $ ioldsd
816 info = abs( iinfo )
817 GO TO 220
818 END IF
819*
820* Do Test (5) again
821*
822 DO 160 j = 1, n
823 IF( w( j ).NE.w1( j ) )
824 $ result( 5 ) = ulpinv
825 160 CONTINUE
826*
827* Do Test (6)
828*
829 DO 180 j = 1, n
830 DO 170 jj = 1, n
831 IF( vr( j, jj ).NE.lre( j, jj ) )
832 $ result( 6 ) = ulpinv
833 170 CONTINUE
834 180 CONTINUE
835*
836* Compute eigenvalues and left eigenvectors, and test them
837*
838 CALL zlacpy( 'F', n, n, a, lda, h, lda )
839 CALL zgeev( 'V', 'N', n, h, lda, w1, lre, ldlre, dum, 1,
840 $ work, nnwork, rwork, iinfo )
841 IF( iinfo.NE.0 ) THEN
842 result( 1 ) = ulpinv
843 WRITE( nounit, fmt = 9993 )'ZGEEV4', iinfo, n, jtype,
844 $ ioldsd
845 info = abs( iinfo )
846 GO TO 220
847 END IF
848*
849* Do Test (5) again
850*
851 DO 190 j = 1, n
852 IF( w( j ).NE.w1( j ) )
853 $ result( 5 ) = ulpinv
854 190 CONTINUE
855*
856* Do Test (7)
857*
858 DO 210 j = 1, n
859 DO 200 jj = 1, n
860 IF( vl( j, jj ).NE.lre( j, jj ) )
861 $ result( 7 ) = ulpinv
862 200 CONTINUE
863 210 CONTINUE
864*
865* End of Loop -- Check for RESULT(j) > THRESH
866*
867 220 CONTINUE
868*
869 ntest = 0
870 nfail = 0
871 DO 230 j = 1, 7
872 IF( result( j ).GE.zero )
873 $ ntest = ntest + 1
874 IF( result( j ).GE.thresh )
875 $ nfail = nfail + 1
876 230 CONTINUE
877*
878 IF( nfail.GT.0 )
879 $ ntestf = ntestf + 1
880 IF( ntestf.EQ.1 ) THEN
881 WRITE( nounit, fmt = 9999 )path
882 WRITE( nounit, fmt = 9998 )
883 WRITE( nounit, fmt = 9997 )
884 WRITE( nounit, fmt = 9996 )
885 WRITE( nounit, fmt = 9995 )thresh
886 ntestf = 2
887 END IF
888*
889 DO 240 j = 1, 7
890 IF( result( j ).GE.thresh ) THEN
891 WRITE( nounit, fmt = 9994 )n, iwk, ioldsd, jtype,
892 $ j, result( j )
893 END IF
894 240 CONTINUE
895*
896 nerrs = nerrs + nfail
897 ntestt = ntestt + ntest
898*
899 250 CONTINUE
900 260 CONTINUE
901 270 CONTINUE
902*
903* Summary
904*
905 CALL dlasum( path, nounit, nerrs, ntestt )
906*
907 9999 FORMAT( / 1x, a3, ' -- Complex Eigenvalue-Eigenvector ',
908 $ 'Decomposition Driver', /
909 $ ' Matrix types (see ZDRVEV for details): ' )
910*
911 9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
912 $ ' ', ' 5=Diagonal: geometr. spaced entries.',
913 $ / ' 2=Identity matrix. ', ' 6=Diagona',
914 $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
915 $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
916 $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
917 $ 'mall, evenly spaced.' )
918 9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
919 $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
920 $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
921 $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
922 $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
923 $ 'lex ', a6, / ' 12=Well-cond., random complex ', a6, ' ',
924 $ ' 17=Ill-cond., large rand. complx ', a4, / ' 13=Ill-condi',
925 $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
926 $ ' complx ', a4 )
927 9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
928 $ 'with small random entries.', / ' 20=Matrix with large ran',
929 $ 'dom entries. ', / )
930 9995 FORMAT( ' Tests performed with test threshold =', f8.2,
931 $ / / ' 1 = | A VR - VR W | / ( n |A| ulp ) ',
932 $ / ' 2 = | conj-trans(A) VL - VL conj-trans(W) | /',
933 $ ' ( n |A| ulp ) ', / ' 3 = | |VR(i)| - 1 | / ulp ',
934 $ / ' 4 = | |VL(i)| - 1 | / ulp ',
935 $ / ' 5 = 0 if W same no matter if VR or VL computed,',
936 $ ' 1/ulp otherwise', /
937 $ ' 6 = 0 if VR same no matter if VL computed,',
938 $ ' 1/ulp otherwise', /
939 $ ' 7 = 0 if VL same no matter if VR computed,',
940 $ ' 1/ulp otherwise', / )
941 9994 FORMAT( ' N=', i5, ', IWK=', i2, ', seed=', 4( i4, ',' ),
942 $ ' type ', i2, ', test(', i2, ')=', g10.3 )
943 9993 FORMAT( ' ZDRVEV: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
944 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
945*
946 RETURN
947*
948* End of ZDRVEV
949*
zgeev
subroutine zgeev(jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr, work, lwork, rwork, info)
ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition zgeev.f:180
dznrm2
real(wp) function dznrm2(n, x, incx)
DZNRM2
Definition dznrm2.f90:90

◆ zdrvsg()

subroutine zdrvsg ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) d,
complex*16, dimension( ldz, * ) z,
integer ldz,
complex*16, dimension( lda, * ) ab,
complex*16, dimension( ldb, * ) bb,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) bp,
complex*16, dimension( * ) work,
integer nwork,
double precision, dimension( * ) rwork,
integer lrwork,
integer, dimension( * ) iwork,
integer liwork,
double precision, dimension( * ) result,
integer info )

ZDRVSG

Purpose:
!>
!>      ZDRVSG checks the complex Hermitian generalized eigenproblem
!>      drivers.
!>
!>              ZHEGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem.
!>
!>              ZHEGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem using a divide and conquer algorithm.
!>
!>              ZHEGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem.
!>
!>              ZHPGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage.
!>
!>              ZHPGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage using a divide and
!>              conquer algorithm.
!>
!>              ZHPGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage.
!>
!>              ZHBGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem.
!>
!>              ZHBGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem using a divide and conquer
!>              algorithm.
!>
!>              ZHBGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem.
!>
!>      When ZDRVSG is called, a number of matrix  () and a
!>      number of matrix  are specified.  For each size ()
!>      and each type of matrix, one matrix A of the given type will be
!>      generated; a random well-conditioned matrix B is also generated
!>      and the pair (A,B) is used to test the drivers.
!>
!>      For each pair (A,B), the following tests are performed:
!>
!>      (1) ZHEGV with ITYPE = 1 and UPLO ='U':
!>
!>              | A Z - B Z D | / ( |A| |Z| n ulp )
!>
!>      (2) as (1) but calling ZHPGV
!>      (3) as (1) but calling ZHBGV
!>      (4) as (1) but with UPLO = 'L'
!>      (5) as (4) but calling ZHPGV
!>      (6) as (4) but calling ZHBGV
!>
!>      (7) ZHEGV with ITYPE = 2 and UPLO ='U':
!>
!>              | A B Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (8) as (7) but calling ZHPGV
!>      (9) as (7) but with UPLO = 'L'
!>      (10) as (9) but calling ZHPGV
!>
!>      (11) ZHEGV with ITYPE = 3 and UPLO ='U':
!>
!>              | B A Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (12) as (11) but calling ZHPGV
!>      (13) as (11) but with UPLO = 'L'
!>      (14) as (13) but calling ZHPGV
!>
!>      ZHEGVD, ZHPGVD and ZHBGVD performed the same 14 tests.
!>
!>      ZHEGVX, ZHPGVX and ZHBGVX performed the above 14 tests with
!>      the parameter RANGE = 'A', 'N' and 'I', respectively.
!>
!>      The  are specified by an array NN(1:NSIZES); the value of
!>      each element NN(j) specifies one size.
!>      The  are specified by a logical array DOTYPE( 1:NTYPES );
!>      if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!>      This type is used for the matrix A which has half-bandwidth KA.
!>      B is generated as a well-conditioned positive definite matrix
!>      with half-bandwidth KB (<= KA).
!>      Currently, the list of possible types for A is:
!>
!>      (1)  The zero matrix.
!>      (2)  The identity matrix.
!>
!>      (3)  A diagonal matrix with evenly spaced entries
!>           1, ..., ULP  and random signs.
!>           (ULP = (first number larger than 1) - 1 )
!>      (4)  A diagonal matrix with geometrically spaced entries
!>           1, ..., ULP  and random signs.
!>      (5)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>           and random signs.
!>
!>      (6)  Same as (4), but multiplied by SQRT( overflow threshold )
!>      (7)  Same as (4), but multiplied by SQRT( underflow threshold )
!>
!>      (8)  A matrix of the form  U* D U, where U is unitary and
!>           D has evenly spaced entries 1, ..., ULP with random signs
!>           on the diagonal.
!>
!>      (9)  A matrix of the form  U* D U, where U is unitary and
!>           D has geometrically spaced entries 1, ..., ULP with random
!>           signs on the diagonal.
!>
!>      (10) A matrix of the form  U* D U, where U is unitary and
!>           D has  entries 1, ULP,..., ULP with random
!>           signs on the diagonal.
!>
!>      (11) Same as (8), but multiplied by SQRT( overflow threshold )
!>      (12) Same as (8), but multiplied by SQRT( underflow threshold )
!>
!>      (13) Hermitian matrix with random entries chosen from (-1,1).
!>      (14) Same as (13), but multiplied by SQRT( overflow threshold )
!>      (15) Same as (13), but multiplied by SQRT( underflow threshold )
!>
!>      (16) Same as (8), but with KA = 1 and KB = 1
!>      (17) Same as (8), but with KA = 2 and KB = 1
!>      (18) Same as (8), but with KA = 2 and KB = 2
!>      (19) Same as (8), but with KA = 3 and KB = 1
!>      (20) Same as (8), but with KA = 3 and KB = 2
!>      (21) Same as (8), but with KA = 3 and KB = 3
!> 
!>  NSIZES  INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZDRVSG does nothing.  It must be at least zero.
!>          Not modified.
!>
!>  NN      INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>          Not modified.
!>
!>  NTYPES  INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZDRVSG
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>          Not modified.
!>
!>  DOTYPE  LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>          Not modified.
!>
!>  ISEED   INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRVSG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       COMPLEX*16 array, dimension (LDA , max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  B       COMPLEX*16 array, dimension (LDB , max(NN))
!>          Used to hold the Hermitian positive definite matrix for
!>          the generailzed problem.
!>          On exit, B contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDB     INTEGER
!>          The leading dimension of B.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  D       DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A. On exit, the eigenvalues in D
!>          correspond with the matrix in A.
!>          Modified.
!>
!>  Z       COMPLEX*16 array, dimension (LDZ, max(NN))
!>          The matrix of eigenvectors.
!>          Modified.
!>
!>  LDZ     INTEGER
!>          The leading dimension of ZZ.  It must be at least 1 and
!>          at least max( NN ).
!>          Not modified.
!>
!>  AB      COMPLEX*16 array, dimension (LDA, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  BB      COMPLEX*16 array, dimension (LDB, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  AP      COMPLEX*16 array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  BP      COMPLEX*16 array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  WORK    COMPLEX*16 array, dimension (NWORK)
!>          Workspace.
!>          Modified.
!>
!>  NWORK   INTEGER
!>          The number of entries in WORK.  This must be at least
!>          2*N + N**2  where  N = max( NN(j), 2 ).
!>          Not modified.
!>
!>  RWORK   DOUBLE PRECISION array, dimension (LRWORK)
!>          Workspace.
!>          Modified.
!>
!>  LRWORK  INTEGER
!>          The number of entries in RWORK.  This must be at least
!>          max( 7*N, 1 + 4*N + 2*N*lg(N) + 3*N**2 ) where
!>          N = max( NN(j) ) and lg( N ) = smallest integer k such
!>          that 2**k >= N .
!>          Not modified.
!>
!>  IWORK   INTEGER array, dimension (LIWORK))
!>          Workspace.
!>          Modified.
!>
!>  LIWORK  INTEGER
!>          The number of entries in IWORK.  This must be at least
!>          2 + 5*max( NN(j) ).
!>          Not modified.
!>
!>  RESULT  DOUBLE PRECISION array, dimension (70)
!>          The values computed by the 70 tests described above.
!>          Modified.
!>
!>  INFO    INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -16: LDZ < 1 or LDZ < NMAX.
!>          -21: NWORK too small.
!>          -23: LRWORK too small.
!>          -25: LIWORK too small.
!>          If  ZLATMR, CLATMS, ZHEGV, ZHPGV, ZHBGV, CHEGVD, CHPGVD,
!>              ZHPGVD, ZHEGVX, CHPGVX, ZHBGVX returns an error code,
!>              the absolute value of it is returned.
!>          Modified.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests that have been run
!>                       on this matrix.
!>       NTESTT          The total number of tests for this call.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far (computed by DLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 366 of file zdrvsg.f.

370*
371* -- LAPACK test routine --
372* -- LAPACK is a software package provided by Univ. of Tennessee, --
373* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
374*
375* .. Scalar Arguments ..
376 INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT,
377 $ NSIZES, NTYPES, NWORK
378 DOUBLE PRECISION THRESH
379* ..
380* .. Array Arguments ..
381 LOGICAL DOTYPE( * )
382 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
383 DOUBLE PRECISION D( * ), RESULT( * ), RWORK( * )
384 COMPLEX*16 A( LDA, * ), AB( LDA, * ), AP( * ),
385 $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ),
386 $ Z( LDZ, * )
387* ..
388*
389* =====================================================================
390*
391* .. Parameters ..
392 DOUBLE PRECISION ZERO, ONE, TEN
393 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 10.0d+0 )
394 COMPLEX*16 CZERO, CONE
395 parameter( czero = ( 0.0d+0, 0.0d+0 ),
396 $ cone = ( 1.0d+0, 0.0d+0 ) )
397 INTEGER MAXTYP
398 parameter( maxtyp = 21 )
399* ..
400* .. Local Scalars ..
401 LOGICAL BADNN
402 CHARACTER UPLO
403 INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
404 $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB,
405 $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
406 $ NTESTT
407 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
408 $ RTUNFL, ULP, ULPINV, UNFL, VL, VU
409* ..
410* .. Local Arrays ..
411 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
412 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
413 $ KTYPE( MAXTYP )
414* ..
415* .. External Functions ..
416 LOGICAL LSAME
417 DOUBLE PRECISION DLAMCH, DLARND
418 EXTERNAL lsame, dlamch, dlarnd
419* ..
420* .. External Subroutines ..
421 EXTERNAL dlabad, dlafts, dlasum, xerbla, zhbgv, zhbgvd,
422 $ zhbgvx, zhegv, zhegvd, zhegvx, zhpgv, zhpgvd,
423 $ zhpgvx, zlacpy, zlaset, zlatmr, zlatms, zsgt01
424* ..
425* .. Intrinsic Functions ..
426 INTRINSIC abs, dble, max, min, sqrt
427* ..
428* .. Data statements ..
429 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 6*9 /
430 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
431 $ 2, 3, 6*1 /
432 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
433 $ 0, 0, 6*4 /
434* ..
435* .. Executable Statements ..
436*
437* 1) Check for errors
438*
439 ntestt = 0
440 info = 0
441*
442 badnn = .false.
443 nmax = 0
444 DO 10 j = 1, nsizes
445 nmax = max( nmax, nn( j ) )
446 IF( nn( j ).LT.0 )
447 $ badnn = .true.
448 10 CONTINUE
449*
450* Check for errors
451*
452 IF( nsizes.LT.0 ) THEN
453 info = -1
454 ELSE IF( badnn ) THEN
455 info = -2
456 ELSE IF( ntypes.LT.0 ) THEN
457 info = -3
458 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
459 info = -9
460 ELSE IF( ldz.LE.1 .OR. ldz.LT.nmax ) THEN
461 info = -16
462 ELSE IF( 2*max( nmax, 2 )**2.GT.nwork ) THEN
463 info = -21
464 ELSE IF( 2*max( nmax, 2 )**2.GT.lrwork ) THEN
465 info = -23
466 ELSE IF( 2*max( nmax, 2 )**2.GT.liwork ) THEN
467 info = -25
468 END IF
469*
470 IF( info.NE.0 ) THEN
471 CALL xerbla( 'ZDRVSG', -info )
472 RETURN
473 END IF
474*
475* Quick return if possible
476*
477 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
478 $ RETURN
479*
480* More Important constants
481*
482 unfl = dlamch( 'Safe minimum' )
483 ovfl = dlamch( 'Overflow' )
484 CALL dlabad( unfl, ovfl )
485 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
486 ulpinv = one / ulp
487 rtunfl = sqrt( unfl )
488 rtovfl = sqrt( ovfl )
489*
490 DO 20 i = 1, 4
491 iseed2( i ) = iseed( i )
492 20 CONTINUE
493*
494* Loop over sizes, types
495*
496 nerrs = 0
497 nmats = 0
498*
499 DO 650 jsize = 1, nsizes
500 n = nn( jsize )
501 aninv = one / dble( max( 1, n ) )
502*
503 IF( nsizes.NE.1 ) THEN
504 mtypes = min( maxtyp, ntypes )
505 ELSE
506 mtypes = min( maxtyp+1, ntypes )
507 END IF
508*
509 ka9 = 0
510 kb9 = 0
511 DO 640 jtype = 1, mtypes
512 IF( .NOT.dotype( jtype ) )
513 $ GO TO 640
514 nmats = nmats + 1
515 ntest = 0
516*
517 DO 30 j = 1, 4
518 ioldsd( j ) = iseed( j )
519 30 CONTINUE
520*
521* 2) Compute "A"
522*
523* Control parameters:
524*
525* KMAGN KMODE KTYPE
526* =1 O(1) clustered 1 zero
527* =2 large clustered 2 identity
528* =3 small exponential (none)
529* =4 arithmetic diagonal, w/ eigenvalues
530* =5 random log hermitian, w/ eigenvalues
531* =6 random (none)
532* =7 random diagonal
533* =8 random hermitian
534* =9 banded, w/ eigenvalues
535*
536 IF( mtypes.GT.maxtyp )
537 $ GO TO 90
538*
539 itype = ktype( jtype )
540 imode = kmode( jtype )
541*
542* Compute norm
543*
544 GO TO ( 40, 50, 60 )kmagn( jtype )
545*
546 40 CONTINUE
547 anorm = one
548 GO TO 70
549*
550 50 CONTINUE
551 anorm = ( rtovfl*ulp )*aninv
552 GO TO 70
553*
554 60 CONTINUE
555 anorm = rtunfl*n*ulpinv
556 GO TO 70
557*
558 70 CONTINUE
559*
560 iinfo = 0
561 cond = ulpinv
562*
563* Special Matrices -- Identity & Jordan block
564*
565 IF( itype.EQ.1 ) THEN
566*
567* Zero
568*
569 ka = 0
570 kb = 0
571 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
572*
573 ELSE IF( itype.EQ.2 ) THEN
574*
575* Identity
576*
577 ka = 0
578 kb = 0
579 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
580 DO 80 jcol = 1, n
581 a( jcol, jcol ) = anorm
582 80 CONTINUE
583*
584 ELSE IF( itype.EQ.4 ) THEN
585*
586* Diagonal Matrix, [Eigen]values Specified
587*
588 ka = 0
589 kb = 0
590 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
591 $ anorm, 0, 0, 'N', a, lda, work, iinfo )
592*
593 ELSE IF( itype.EQ.5 ) THEN
594*
595* Hermitian, eigenvalues specified
596*
597 ka = max( 0, n-1 )
598 kb = ka
599 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
600 $ anorm, n, n, 'N', a, lda, work, iinfo )
601*
602 ELSE IF( itype.EQ.7 ) THEN
603*
604* Diagonal, random eigenvalues
605*
606 ka = 0
607 kb = 0
608 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
609 $ 'T', 'N', work( n+1 ), 1, one,
610 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
611 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
612*
613 ELSE IF( itype.EQ.8 ) THEN
614*
615* Hermitian, random eigenvalues
616*
617 ka = max( 0, n-1 )
618 kb = ka
619 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
620 $ 'T', 'N', work( n+1 ), 1, one,
621 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
622 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
623*
624 ELSE IF( itype.EQ.9 ) THEN
625*
626* Hermitian banded, eigenvalues specified
627*
628* The following values are used for the half-bandwidths:
629*
630* ka = 1 kb = 1
631* ka = 2 kb = 1
632* ka = 2 kb = 2
633* ka = 3 kb = 1
634* ka = 3 kb = 2
635* ka = 3 kb = 3
636*
637 kb9 = kb9 + 1
638 IF( kb9.GT.ka9 ) THEN
639 ka9 = ka9 + 1
640 kb9 = 1
641 END IF
642 ka = max( 0, min( n-1, ka9 ) )
643 kb = max( 0, min( n-1, kb9 ) )
644 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
645 $ anorm, ka, ka, 'N', a, lda, work, iinfo )
646*
647 ELSE
648*
649 iinfo = 1
650 END IF
651*
652 IF( iinfo.NE.0 ) THEN
653 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
654 $ ioldsd
655 info = abs( iinfo )
656 RETURN
657 END IF
658*
659 90 CONTINUE
660*
661 abstol = unfl + unfl
662 IF( n.LE.1 ) THEN
663 il = 1
664 iu = n
665 ELSE
666 il = 1 + ( n-1 )*dlarnd( 1, iseed2 )
667 iu = 1 + ( n-1 )*dlarnd( 1, iseed2 )
668 IF( il.GT.iu ) THEN
669 itemp = il
670 il = iu
671 iu = itemp
672 END IF
673 END IF
674*
675* 3) Call ZHEGV, ZHPGV, ZHBGV, CHEGVD, CHPGVD, CHBGVD,
676* ZHEGVX, ZHPGVX and ZHBGVX, do tests.
677*
678* loop over the three generalized problems
679* IBTYPE = 1: A*x = (lambda)*B*x
680* IBTYPE = 2: A*B*x = (lambda)*x
681* IBTYPE = 3: B*A*x = (lambda)*x
682*
683 DO 630 ibtype = 1, 3
684*
685* loop over the setting UPLO
686*
687 DO 620 ibuplo = 1, 2
688 IF( ibuplo.EQ.1 )
689 $ uplo = 'U'
690 IF( ibuplo.EQ.2 )
691 $ uplo = 'L'
692*
693* Generate random well-conditioned positive definite
694* matrix B, of bandwidth not greater than that of A.
695*
696 CALL zlatms( n, n, 'U', iseed, 'P', rwork, 5, ten,
697 $ one, kb, kb, uplo, b, ldb, work( n+1 ),
698 $ iinfo )
699*
700* Test ZHEGV
701*
702 ntest = ntest + 1
703*
704 CALL zlacpy( ' ', n, n, a, lda, z, ldz )
705 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
706*
707 CALL zhegv( ibtype, 'V', uplo, n, z, ldz, bb, ldb, d,
708 $ work, nwork, rwork, iinfo )
709 IF( iinfo.NE.0 ) THEN
710 WRITE( nounit, fmt = 9999 )'ZHEGV(V,' // uplo //
711 $ ')', iinfo, n, jtype, ioldsd
712 info = abs( iinfo )
713 IF( iinfo.LT.0 ) THEN
714 RETURN
715 ELSE
716 result( ntest ) = ulpinv
717 GO TO 100
718 END IF
719 END IF
720*
721* Do Test
722*
723 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
724 $ ldz, d, work, rwork, result( ntest ) )
725*
726* Test ZHEGVD
727*
728 ntest = ntest + 1
729*
730 CALL zlacpy( ' ', n, n, a, lda, z, ldz )
731 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
732*
733 CALL zhegvd( ibtype, 'V', uplo, n, z, ldz, bb, ldb, d,
734 $ work, nwork, rwork, lrwork, iwork,
735 $ liwork, iinfo )
736 IF( iinfo.NE.0 ) THEN
737 WRITE( nounit, fmt = 9999 )'ZHEGVD(V,' // uplo //
738 $ ')', iinfo, n, jtype, ioldsd
739 info = abs( iinfo )
740 IF( iinfo.LT.0 ) THEN
741 RETURN
742 ELSE
743 result( ntest ) = ulpinv
744 GO TO 100
745 END IF
746 END IF
747*
748* Do Test
749*
750 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
751 $ ldz, d, work, rwork, result( ntest ) )
752*
753* Test ZHEGVX
754*
755 ntest = ntest + 1
756*
757 CALL zlacpy( ' ', n, n, a, lda, ab, lda )
758 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
759*
760 CALL zhegvx( ibtype, 'V', 'A', uplo, n, ab, lda, bb,
761 $ ldb, vl, vu, il, iu, abstol, m, d, z,
762 $ ldz, work, nwork, rwork, iwork( n+1 ),
763 $ iwork, iinfo )
764 IF( iinfo.NE.0 ) THEN
765 WRITE( nounit, fmt = 9999 )'ZHEGVX(V,A' // uplo //
766 $ ')', iinfo, n, jtype, ioldsd
767 info = abs( iinfo )
768 IF( iinfo.LT.0 ) THEN
769 RETURN
770 ELSE
771 result( ntest ) = ulpinv
772 GO TO 100
773 END IF
774 END IF
775*
776* Do Test
777*
778 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
779 $ ldz, d, work, rwork, result( ntest ) )
780*
781 ntest = ntest + 1
782*
783 CALL zlacpy( ' ', n, n, a, lda, ab, lda )
784 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
785*
786* since we do not know the exact eigenvalues of this
787* eigenpair, we just set VL and VU as constants.
788* It is quite possible that there are no eigenvalues
789* in this interval.
790*
791 vl = zero
792 vu = anorm
793 CALL zhegvx( ibtype, 'V', 'V', uplo, n, ab, lda, bb,
794 $ ldb, vl, vu, il, iu, abstol, m, d, z,
795 $ ldz, work, nwork, rwork, iwork( n+1 ),
796 $ iwork, iinfo )
797 IF( iinfo.NE.0 ) THEN
798 WRITE( nounit, fmt = 9999 )'ZHEGVX(V,V,' //
799 $ uplo // ')', iinfo, n, jtype, ioldsd
800 info = abs( iinfo )
801 IF( iinfo.LT.0 ) THEN
802 RETURN
803 ELSE
804 result( ntest ) = ulpinv
805 GO TO 100
806 END IF
807 END IF
808*
809* Do Test
810*
811 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
812 $ ldz, d, work, rwork, result( ntest ) )
813*
814 ntest = ntest + 1
815*
816 CALL zlacpy( ' ', n, n, a, lda, ab, lda )
817 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
818*
819 CALL zhegvx( ibtype, 'V', 'I', uplo, n, ab, lda, bb,
820 $ ldb, vl, vu, il, iu, abstol, m, d, z,
821 $ ldz, work, nwork, rwork, iwork( n+1 ),
822 $ iwork, iinfo )
823 IF( iinfo.NE.0 ) THEN
824 WRITE( nounit, fmt = 9999 )'ZHEGVX(V,I,' //
825 $ uplo // ')', iinfo, n, jtype, ioldsd
826 info = abs( iinfo )
827 IF( iinfo.LT.0 ) THEN
828 RETURN
829 ELSE
830 result( ntest ) = ulpinv
831 GO TO 100
832 END IF
833 END IF
834*
835* Do Test
836*
837 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
838 $ ldz, d, work, rwork, result( ntest ) )
839*
840 100 CONTINUE
841*
842* Test ZHPGV
843*
844 ntest = ntest + 1
845*
846* Copy the matrices into packed storage.
847*
848 IF( lsame( uplo, 'U' ) ) THEN
849 ij = 1
850 DO 120 j = 1, n
851 DO 110 i = 1, j
852 ap( ij ) = a( i, j )
853 bp( ij ) = b( i, j )
854 ij = ij + 1
855 110 CONTINUE
856 120 CONTINUE
857 ELSE
858 ij = 1
859 DO 140 j = 1, n
860 DO 130 i = j, n
861 ap( ij ) = a( i, j )
862 bp( ij ) = b( i, j )
863 ij = ij + 1
864 130 CONTINUE
865 140 CONTINUE
866 END IF
867*
868 CALL zhpgv( ibtype, 'V', uplo, n, ap, bp, d, z, ldz,
869 $ work, rwork, iinfo )
870 IF( iinfo.NE.0 ) THEN
871 WRITE( nounit, fmt = 9999 )'ZHPGV(V,' // uplo //
872 $ ')', iinfo, n, jtype, ioldsd
873 info = abs( iinfo )
874 IF( iinfo.LT.0 ) THEN
875 RETURN
876 ELSE
877 result( ntest ) = ulpinv
878 GO TO 310
879 END IF
880 END IF
881*
882* Do Test
883*
884 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
885 $ ldz, d, work, rwork, result( ntest ) )
886*
887* Test ZHPGVD
888*
889 ntest = ntest + 1
890*
891* Copy the matrices into packed storage.
892*
893 IF( lsame( uplo, 'U' ) ) THEN
894 ij = 1
895 DO 160 j = 1, n
896 DO 150 i = 1, j
897 ap( ij ) = a( i, j )
898 bp( ij ) = b( i, j )
899 ij = ij + 1
900 150 CONTINUE
901 160 CONTINUE
902 ELSE
903 ij = 1
904 DO 180 j = 1, n
905 DO 170 i = j, n
906 ap( ij ) = a( i, j )
907 bp( ij ) = b( i, j )
908 ij = ij + 1
909 170 CONTINUE
910 180 CONTINUE
911 END IF
912*
913 CALL zhpgvd( ibtype, 'V', uplo, n, ap, bp, d, z, ldz,
914 $ work, nwork, rwork, lrwork, iwork,
915 $ liwork, iinfo )
916 IF( iinfo.NE.0 ) THEN
917 WRITE( nounit, fmt = 9999 )'ZHPGVD(V,' // uplo //
918 $ ')', iinfo, n, jtype, ioldsd
919 info = abs( iinfo )
920 IF( iinfo.LT.0 ) THEN
921 RETURN
922 ELSE
923 result( ntest ) = ulpinv
924 GO TO 310
925 END IF
926 END IF
927*
928* Do Test
929*
930 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
931 $ ldz, d, work, rwork, result( ntest ) )
932*
933* Test ZHPGVX
934*
935 ntest = ntest + 1
936*
937* Copy the matrices into packed storage.
938*
939 IF( lsame( uplo, 'U' ) ) THEN
940 ij = 1
941 DO 200 j = 1, n
942 DO 190 i = 1, j
943 ap( ij ) = a( i, j )
944 bp( ij ) = b( i, j )
945 ij = ij + 1
946 190 CONTINUE
947 200 CONTINUE
948 ELSE
949 ij = 1
950 DO 220 j = 1, n
951 DO 210 i = j, n
952 ap( ij ) = a( i, j )
953 bp( ij ) = b( i, j )
954 ij = ij + 1
955 210 CONTINUE
956 220 CONTINUE
957 END IF
958*
959 CALL zhpgvx( ibtype, 'V', 'A', uplo, n, ap, bp, vl,
960 $ vu, il, iu, abstol, m, d, z, ldz, work,
961 $ rwork, iwork( n+1 ), iwork, info )
962 IF( iinfo.NE.0 ) THEN
963 WRITE( nounit, fmt = 9999 )'ZHPGVX(V,A' // uplo //
964 $ ')', iinfo, n, jtype, ioldsd
965 info = abs( iinfo )
966 IF( iinfo.LT.0 ) THEN
967 RETURN
968 ELSE
969 result( ntest ) = ulpinv
970 GO TO 310
971 END IF
972 END IF
973*
974* Do Test
975*
976 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
977 $ ldz, d, work, rwork, result( ntest ) )
978*
979 ntest = ntest + 1
980*
981* Copy the matrices into packed storage.
982*
983 IF( lsame( uplo, 'U' ) ) THEN
984 ij = 1
985 DO 240 j = 1, n
986 DO 230 i = 1, j
987 ap( ij ) = a( i, j )
988 bp( ij ) = b( i, j )
989 ij = ij + 1
990 230 CONTINUE
991 240 CONTINUE
992 ELSE
993 ij = 1
994 DO 260 j = 1, n
995 DO 250 i = j, n
996 ap( ij ) = a( i, j )
997 bp( ij ) = b( i, j )
998 ij = ij + 1
999 250 CONTINUE
1000 260 CONTINUE
1001 END IF
1002*
1003 vl = zero
1004 vu = anorm
1005 CALL zhpgvx( ibtype, 'V', 'V', uplo, n, ap, bp, vl,
1006 $ vu, il, iu, abstol, m, d, z, ldz, work,
1007 $ rwork, iwork( n+1 ), iwork, info )
1008 IF( iinfo.NE.0 ) THEN
1009 WRITE( nounit, fmt = 9999 )'ZHPGVX(V,V' // uplo //
1010 $ ')', iinfo, n, jtype, ioldsd
1011 info = abs( iinfo )
1012 IF( iinfo.LT.0 ) THEN
1013 RETURN
1014 ELSE
1015 result( ntest ) = ulpinv
1016 GO TO 310
1017 END IF
1018 END IF
1019*
1020* Do Test
1021*
1022 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1023 $ ldz, d, work, rwork, result( ntest ) )
1024*
1025 ntest = ntest + 1
1026*
1027* Copy the matrices into packed storage.
1028*
1029 IF( lsame( uplo, 'U' ) ) THEN
1030 ij = 1
1031 DO 280 j = 1, n
1032 DO 270 i = 1, j
1033 ap( ij ) = a( i, j )
1034 bp( ij ) = b( i, j )
1035 ij = ij + 1
1036 270 CONTINUE
1037 280 CONTINUE
1038 ELSE
1039 ij = 1
1040 DO 300 j = 1, n
1041 DO 290 i = j, n
1042 ap( ij ) = a( i, j )
1043 bp( ij ) = b( i, j )
1044 ij = ij + 1
1045 290 CONTINUE
1046 300 CONTINUE
1047 END IF
1048*
1049 CALL zhpgvx( ibtype, 'V', 'I', uplo, n, ap, bp, vl,
1050 $ vu, il, iu, abstol, m, d, z, ldz, work,
1051 $ rwork, iwork( n+1 ), iwork, info )
1052 IF( iinfo.NE.0 ) THEN
1053 WRITE( nounit, fmt = 9999 )'ZHPGVX(V,I' // uplo //
1054 $ ')', iinfo, n, jtype, ioldsd
1055 info = abs( iinfo )
1056 IF( iinfo.LT.0 ) THEN
1057 RETURN
1058 ELSE
1059 result( ntest ) = ulpinv
1060 GO TO 310
1061 END IF
1062 END IF
1063*
1064* Do Test
1065*
1066 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1067 $ ldz, d, work, rwork, result( ntest ) )
1068*
1069 310 CONTINUE
1070*
1071 IF( ibtype.EQ.1 ) THEN
1072*
1073* TEST ZHBGV
1074*
1075 ntest = ntest + 1
1076*
1077* Copy the matrices into band storage.
1078*
1079 IF( lsame( uplo, 'U' ) ) THEN
1080 DO 340 j = 1, n
1081 DO 320 i = max( 1, j-ka ), j
1082 ab( ka+1+i-j, j ) = a( i, j )
1083 320 CONTINUE
1084 DO 330 i = max( 1, j-kb ), j
1085 bb( kb+1+i-j, j ) = b( i, j )
1086 330 CONTINUE
1087 340 CONTINUE
1088 ELSE
1089 DO 370 j = 1, n
1090 DO 350 i = j, min( n, j+ka )
1091 ab( 1+i-j, j ) = a( i, j )
1092 350 CONTINUE
1093 DO 360 i = j, min( n, j+kb )
1094 bb( 1+i-j, j ) = b( i, j )
1095 360 CONTINUE
1096 370 CONTINUE
1097 END IF
1098*
1099 CALL zhbgv( 'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1100 $ d, z, ldz, work, rwork, iinfo )
1101 IF( iinfo.NE.0 ) THEN
1102 WRITE( nounit, fmt = 9999 )'ZHBGV(V,' //
1103 $ uplo // ')', iinfo, n, jtype, ioldsd
1104 info = abs( iinfo )
1105 IF( iinfo.LT.0 ) THEN
1106 RETURN
1107 ELSE
1108 result( ntest ) = ulpinv
1109 GO TO 620
1110 END IF
1111 END IF
1112*
1113* Do Test
1114*
1115 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1116 $ ldz, d, work, rwork, result( ntest ) )
1117*
1118* TEST ZHBGVD
1119*
1120 ntest = ntest + 1
1121*
1122* Copy the matrices into band storage.
1123*
1124 IF( lsame( uplo, 'U' ) ) THEN
1125 DO 400 j = 1, n
1126 DO 380 i = max( 1, j-ka ), j
1127 ab( ka+1+i-j, j ) = a( i, j )
1128 380 CONTINUE
1129 DO 390 i = max( 1, j-kb ), j
1130 bb( kb+1+i-j, j ) = b( i, j )
1131 390 CONTINUE
1132 400 CONTINUE
1133 ELSE
1134 DO 430 j = 1, n
1135 DO 410 i = j, min( n, j+ka )
1136 ab( 1+i-j, j ) = a( i, j )
1137 410 CONTINUE
1138 DO 420 i = j, min( n, j+kb )
1139 bb( 1+i-j, j ) = b( i, j )
1140 420 CONTINUE
1141 430 CONTINUE
1142 END IF
1143*
1144 CALL zhbgvd( 'V', uplo, n, ka, kb, ab, lda, bb,
1145 $ ldb, d, z, ldz, work, nwork, rwork,
1146 $ lrwork, iwork, liwork, iinfo )
1147 IF( iinfo.NE.0 ) THEN
1148 WRITE( nounit, fmt = 9999 )'ZHBGVD(V,' //
1149 $ uplo // ')', iinfo, n, jtype, ioldsd
1150 info = abs( iinfo )
1151 IF( iinfo.LT.0 ) THEN
1152 RETURN
1153 ELSE
1154 result( ntest ) = ulpinv
1155 GO TO 620
1156 END IF
1157 END IF
1158*
1159* Do Test
1160*
1161 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1162 $ ldz, d, work, rwork, result( ntest ) )
1163*
1164* Test ZHBGVX
1165*
1166 ntest = ntest + 1
1167*
1168* Copy the matrices into band storage.
1169*
1170 IF( lsame( uplo, 'U' ) ) THEN
1171 DO 460 j = 1, n
1172 DO 440 i = max( 1, j-ka ), j
1173 ab( ka+1+i-j, j ) = a( i, j )
1174 440 CONTINUE
1175 DO 450 i = max( 1, j-kb ), j
1176 bb( kb+1+i-j, j ) = b( i, j )
1177 450 CONTINUE
1178 460 CONTINUE
1179 ELSE
1180 DO 490 j = 1, n
1181 DO 470 i = j, min( n, j+ka )
1182 ab( 1+i-j, j ) = a( i, j )
1183 470 CONTINUE
1184 DO 480 i = j, min( n, j+kb )
1185 bb( 1+i-j, j ) = b( i, j )
1186 480 CONTINUE
1187 490 CONTINUE
1188 END IF
1189*
1190 CALL zhbgvx( 'V', 'A', uplo, n, ka, kb, ab, lda,
1191 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1192 $ iu, abstol, m, d, z, ldz, work, rwork,
1193 $ iwork( n+1 ), iwork, iinfo )
1194 IF( iinfo.NE.0 ) THEN
1195 WRITE( nounit, fmt = 9999 )'ZHBGVX(V,A' //
1196 $ uplo // ')', iinfo, n, jtype, ioldsd
1197 info = abs( iinfo )
1198 IF( iinfo.LT.0 ) THEN
1199 RETURN
1200 ELSE
1201 result( ntest ) = ulpinv
1202 GO TO 620
1203 END IF
1204 END IF
1205*
1206* Do Test
1207*
1208 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1209 $ ldz, d, work, rwork, result( ntest ) )
1210*
1211 ntest = ntest + 1
1212*
1213* Copy the matrices into band storage.
1214*
1215 IF( lsame( uplo, 'U' ) ) THEN
1216 DO 520 j = 1, n
1217 DO 500 i = max( 1, j-ka ), j
1218 ab( ka+1+i-j, j ) = a( i, j )
1219 500 CONTINUE
1220 DO 510 i = max( 1, j-kb ), j
1221 bb( kb+1+i-j, j ) = b( i, j )
1222 510 CONTINUE
1223 520 CONTINUE
1224 ELSE
1225 DO 550 j = 1, n
1226 DO 530 i = j, min( n, j+ka )
1227 ab( 1+i-j, j ) = a( i, j )
1228 530 CONTINUE
1229 DO 540 i = j, min( n, j+kb )
1230 bb( 1+i-j, j ) = b( i, j )
1231 540 CONTINUE
1232 550 CONTINUE
1233 END IF
1234*
1235 vl = zero
1236 vu = anorm
1237 CALL zhbgvx( 'V', 'V', uplo, n, ka, kb, ab, lda,
1238 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1239 $ iu, abstol, m, d, z, ldz, work, rwork,
1240 $ iwork( n+1 ), iwork, iinfo )
1241 IF( iinfo.NE.0 ) THEN
1242 WRITE( nounit, fmt = 9999 )'ZHBGVX(V,V' //
1243 $ uplo // ')', iinfo, n, jtype, ioldsd
1244 info = abs( iinfo )
1245 IF( iinfo.LT.0 ) THEN
1246 RETURN
1247 ELSE
1248 result( ntest ) = ulpinv
1249 GO TO 620
1250 END IF
1251 END IF
1252*
1253* Do Test
1254*
1255 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1256 $ ldz, d, work, rwork, result( ntest ) )
1257*
1258 ntest = ntest + 1
1259*
1260* Copy the matrices into band storage.
1261*
1262 IF( lsame( uplo, 'U' ) ) THEN
1263 DO 580 j = 1, n
1264 DO 560 i = max( 1, j-ka ), j
1265 ab( ka+1+i-j, j ) = a( i, j )
1266 560 CONTINUE
1267 DO 570 i = max( 1, j-kb ), j
1268 bb( kb+1+i-j, j ) = b( i, j )
1269 570 CONTINUE
1270 580 CONTINUE
1271 ELSE
1272 DO 610 j = 1, n
1273 DO 590 i = j, min( n, j+ka )
1274 ab( 1+i-j, j ) = a( i, j )
1275 590 CONTINUE
1276 DO 600 i = j, min( n, j+kb )
1277 bb( 1+i-j, j ) = b( i, j )
1278 600 CONTINUE
1279 610 CONTINUE
1280 END IF
1281*
1282 CALL zhbgvx( 'V', 'I', uplo, n, ka, kb, ab, lda,
1283 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1284 $ iu, abstol, m, d, z, ldz, work, rwork,
1285 $ iwork( n+1 ), iwork, iinfo )
1286 IF( iinfo.NE.0 ) THEN
1287 WRITE( nounit, fmt = 9999 )'ZHBGVX(V,I' //
1288 $ uplo // ')', iinfo, n, jtype, ioldsd
1289 info = abs( iinfo )
1290 IF( iinfo.LT.0 ) THEN
1291 RETURN
1292 ELSE
1293 result( ntest ) = ulpinv
1294 GO TO 620
1295 END IF
1296 END IF
1297*
1298* Do Test
1299*
1300 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1301 $ ldz, d, work, rwork, result( ntest ) )
1302*
1303 END IF
1304*
1305 620 CONTINUE
1306 630 CONTINUE
1307*
1308* End of Loop -- Check for RESULT(j) > THRESH
1309*
1310 ntestt = ntestt + ntest
1311 CALL dlafts( 'ZSG', n, n, jtype, ntest, result, ioldsd,
1312 $ thresh, nounit, nerrs )
1313 640 CONTINUE
1314 650 CONTINUE
1315*
1316* Summary
1317*
1318 CALL dlasum( 'ZSG', nounit, nerrs, ntestt )
1319*
1320 RETURN
1321*
1322 9999 FORMAT( ' ZDRVSG: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1323 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1324*
1325* End of ZDRVSG
1326*
zhegvd
subroutine zhegvd(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHEGVD
Definition zhegvd.f:249
zhegvx
subroutine zhegvx(itype, jobz, range, uplo, n, a, lda, b, ldb, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, rwork, iwork, ifail, info)
ZHEGVX
Definition zhegvx.f:307
zhegv
subroutine zhegv(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, info)
ZHEGV
Definition zhegv.f:181
zhbgvx
subroutine zhbgvx(jobz, range, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq, vl, vu, il, iu, abstol, m, w, z, ldz, work, rwork, iwork, ifail, info)
ZHBGVX
Definition zhbgvx.f:300
zhbgvd
subroutine zhbgvd(jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHBGVD
Definition zhbgvd.f:252
zhpgvd
subroutine zhpgvd(itype, jobz, uplo, n, ap, bp, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHPGVD
Definition zhpgvd.f:231
zhbgv
subroutine zhbgv(jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, ldz, work, rwork, info)
ZHBGV
Definition zhbgv.f:183
zhpgvx
subroutine zhpgvx(itype, jobz, range, uplo, n, ap, bp, vl, vu, il, iu, abstol, m, w, z, ldz, work, rwork, iwork, ifail, info)
ZHPGVX
Definition zhpgvx.f:277
zhpgv
subroutine zhpgv(itype, jobz, uplo, n, ap, bp, w, z, ldz, work, rwork, info)
ZHPGV
Definition zhpgv.f:165
zsgt01
subroutine zsgt01(itype, uplo, n, m, a, lda, b, ldb, z, ldz, d, work, rwork, result)
ZSGT01
Definition zsgt01.f:152

◆ zdrvsg2stg()

subroutine zdrvsg2stg ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) d,
double precision, dimension( * ) d2,
complex*16, dimension( ldz, * ) z,
integer ldz,
complex*16, dimension( lda, * ) ab,
complex*16, dimension( ldb, * ) bb,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) bp,
complex*16, dimension( * ) work,
integer nwork,
double precision, dimension( * ) rwork,
integer lrwork,
integer, dimension( * ) iwork,
integer liwork,
double precision, dimension( * ) result,
integer info )

ZDRVSG2STG

Purpose:
!>
!>      ZDRVSG2STG checks the complex Hermitian generalized eigenproblem
!>      drivers.
!>
!>              ZHEGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem.
!>
!>              ZHEGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem using a divide and conquer algorithm.
!>
!>              ZHEGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem.
!>
!>              ZHPGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage.
!>
!>              ZHPGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage using a divide and
!>              conquer algorithm.
!>
!>              ZHPGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage.
!>
!>              ZHBGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem.
!>
!>              ZHBGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem using a divide and conquer
!>              algorithm.
!>
!>              ZHBGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem.
!>
!>      When ZDRVSG2STG is called, a number of matrix  () and a
!>      number of matrix  are specified.  For each size ()
!>      and each type of matrix, one matrix A of the given type will be
!>      generated; a random well-conditioned matrix B is also generated
!>      and the pair (A,B) is used to test the drivers.
!>
!>      For each pair (A,B), the following tests are performed:
!>
!>      (1) ZHEGV with ITYPE = 1 and UPLO ='U':
!>
!>              | A Z - B Z D | / ( |A| |Z| n ulp )
!>              | D - D2 | / ( |D| ulp )   where D is computed by
!>                                         ZHEGV and  D2 is computed by
!>                                         ZHEGV_2STAGE. This test is
!>                                         only performed for DSYGV
!>
!>      (2) as (1) but calling ZHPGV
!>      (3) as (1) but calling ZHBGV
!>      (4) as (1) but with UPLO = 'L'
!>      (5) as (4) but calling ZHPGV
!>      (6) as (4) but calling ZHBGV
!>
!>      (7) ZHEGV with ITYPE = 2 and UPLO ='U':
!>
!>              | A B Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (8) as (7) but calling ZHPGV
!>      (9) as (7) but with UPLO = 'L'
!>      (10) as (9) but calling ZHPGV
!>
!>      (11) ZHEGV with ITYPE = 3 and UPLO ='U':
!>
!>              | B A Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (12) as (11) but calling ZHPGV
!>      (13) as (11) but with UPLO = 'L'
!>      (14) as (13) but calling ZHPGV
!>
!>      ZHEGVD, ZHPGVD and ZHBGVD performed the same 14 tests.
!>
!>      ZHEGVX, ZHPGVX and ZHBGVX performed the above 14 tests with
!>      the parameter RANGE = 'A', 'N' and 'I', respectively.
!>
!>      The  are specified by an array NN(1:NSIZES); the value of
!>      each element NN(j) specifies one size.
!>      The  are specified by a logical array DOTYPE( 1:NTYPES );
!>      if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!>      This type is used for the matrix A which has half-bandwidth KA.
!>      B is generated as a well-conditioned positive definite matrix
!>      with half-bandwidth KB (<= KA).
!>      Currently, the list of possible types for A is:
!>
!>      (1)  The zero matrix.
!>      (2)  The identity matrix.
!>
!>      (3)  A diagonal matrix with evenly spaced entries
!>           1, ..., ULP  and random signs.
!>           (ULP = (first number larger than 1) - 1 )
!>      (4)  A diagonal matrix with geometrically spaced entries
!>           1, ..., ULP  and random signs.
!>      (5)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>           and random signs.
!>
!>      (6)  Same as (4), but multiplied by SQRT( overflow threshold )
!>      (7)  Same as (4), but multiplied by SQRT( underflow threshold )
!>
!>      (8)  A matrix of the form  U* D U, where U is unitary and
!>           D has evenly spaced entries 1, ..., ULP with random signs
!>           on the diagonal.
!>
!>      (9)  A matrix of the form  U* D U, where U is unitary and
!>           D has geometrically spaced entries 1, ..., ULP with random
!>           signs on the diagonal.
!>
!>      (10) A matrix of the form  U* D U, where U is unitary and
!>           D has  entries 1, ULP,..., ULP with random
!>           signs on the diagonal.
!>
!>      (11) Same as (8), but multiplied by SQRT( overflow threshold )
!>      (12) Same as (8), but multiplied by SQRT( underflow threshold )
!>
!>      (13) Hermitian matrix with random entries chosen from (-1,1).
!>      (14) Same as (13), but multiplied by SQRT( overflow threshold )
!>      (15) Same as (13), but multiplied by SQRT( underflow threshold )
!>
!>      (16) Same as (8), but with KA = 1 and KB = 1
!>      (17) Same as (8), but with KA = 2 and KB = 1
!>      (18) Same as (8), but with KA = 2 and KB = 2
!>      (19) Same as (8), but with KA = 3 and KB = 1
!>      (20) Same as (8), but with KA = 3 and KB = 2
!>      (21) Same as (8), but with KA = 3 and KB = 3
!> 
!>  NSIZES  INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZDRVSG2STG does nothing.  It must be at least zero.
!>          Not modified.
!>
!>  NN      INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>          Not modified.
!>
!>  NTYPES  INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZDRVSG2STG
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>          Not modified.
!>
!>  DOTYPE  LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>          Not modified.
!>
!>  ISEED   INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRVSG2STG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       COMPLEX*16 array, dimension (LDA , max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  B       COMPLEX*16 array, dimension (LDB , max(NN))
!>          Used to hold the Hermitian positive definite matrix for
!>          the generailzed problem.
!>          On exit, B contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDB     INTEGER
!>          The leading dimension of B.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  D       DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A. On exit, the eigenvalues in D
!>          correspond with the matrix in A.
!>          Modified.
!>
!>  Z       COMPLEX*16 array, dimension (LDZ, max(NN))
!>          The matrix of eigenvectors.
!>          Modified.
!>
!>  LDZ     INTEGER
!>          The leading dimension of ZZ.  It must be at least 1 and
!>          at least max( NN ).
!>          Not modified.
!>
!>  AB      COMPLEX*16 array, dimension (LDA, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  BB      COMPLEX*16 array, dimension (LDB, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  AP      COMPLEX*16 array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  BP      COMPLEX*16 array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  WORK    COMPLEX*16 array, dimension (NWORK)
!>          Workspace.
!>          Modified.
!>
!>  NWORK   INTEGER
!>          The number of entries in WORK.  This must be at least
!>          2*N + N**2  where  N = max( NN(j), 2 ).
!>          Not modified.
!>
!>  RWORK   DOUBLE PRECISION array, dimension (LRWORK)
!>          Workspace.
!>          Modified.
!>
!>  LRWORK  INTEGER
!>          The number of entries in RWORK.  This must be at least
!>          max( 7*N, 1 + 4*N + 2*N*lg(N) + 3*N**2 ) where
!>          N = max( NN(j) ) and lg( N ) = smallest integer k such
!>          that 2**k >= N .
!>          Not modified.
!>
!>  IWORK   INTEGER array, dimension (LIWORK))
!>          Workspace.
!>          Modified.
!>
!>  LIWORK  INTEGER
!>          The number of entries in IWORK.  This must be at least
!>          2 + 5*max( NN(j) ).
!>          Not modified.
!>
!>  RESULT  DOUBLE PRECISION array, dimension (70)
!>          The values computed by the 70 tests described above.
!>          Modified.
!>
!>  INFO    INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -16: LDZ < 1 or LDZ < NMAX.
!>          -21: NWORK too small.
!>          -23: LRWORK too small.
!>          -25: LIWORK too small.
!>          If  ZLATMR, CLATMS, ZHEGV, ZHPGV, ZHBGV, CHEGVD, CHPGVD,
!>              ZHPGVD, ZHEGVX, CHPGVX, ZHBGVX returns an error code,
!>              the absolute value of it is returned.
!>          Modified.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests that have been run
!>                       on this matrix.
!>       NTESTT          The total number of tests for this call.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far (computed by DLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 372 of file zdrvsg2stg.f.

376*
377 IMPLICIT NONE
378*
379* -- LAPACK test routine --
380* -- LAPACK is a software package provided by Univ. of Tennessee, --
381* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
382*
383* .. Scalar Arguments ..
384 INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT,
385 $ NSIZES, NTYPES, NWORK
386 DOUBLE PRECISION THRESH
387* ..
388* .. Array Arguments ..
389 LOGICAL DOTYPE( * )
390 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
391 DOUBLE PRECISION D( * ), D2( * ), RESULT( * ), RWORK( * )
392 COMPLEX*16 A( LDA, * ), AB( LDA, * ), AP( * ),
393 $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ),
394 $ Z( LDZ, * )
395* ..
396*
397* =====================================================================
398*
399* .. Parameters ..
400 DOUBLE PRECISION ZERO, ONE, TEN
401 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 10.0d+0 )
402 COMPLEX*16 CZERO, CONE
403 parameter( czero = ( 0.0d+0, 0.0d+0 ),
404 $ cone = ( 1.0d+0, 0.0d+0 ) )
405 INTEGER MAXTYP
406 parameter( maxtyp = 21 )
407* ..
408* .. Local Scalars ..
409 LOGICAL BADNN
410 CHARACTER UPLO
411 INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
412 $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB,
413 $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
414 $ NTESTT
415 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
416 $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2
417* ..
418* .. Local Arrays ..
419 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
420 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
421 $ KTYPE( MAXTYP )
422* ..
423* .. External Functions ..
424 LOGICAL LSAME
425 DOUBLE PRECISION DLAMCH, DLARND
426 EXTERNAL lsame, dlamch, dlarnd
427* ..
428* .. External Subroutines ..
429 EXTERNAL dlabad, dlafts, dlasum, xerbla, zhbgv, zhbgvd,
430 $ zhbgvx, zhegv, zhegvd, zhegvx, zhpgv, zhpgvd,
431 $ zhpgvx, zlacpy, zlaset, zlatmr, zlatms, zsgt01,
432 $ zhegv_2stage
433* ..
434* .. Intrinsic Functions ..
435 INTRINSIC abs, dble, max, min, sqrt
436* ..
437* .. Data statements ..
438 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 6*9 /
439 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
440 $ 2, 3, 6*1 /
441 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
442 $ 0, 0, 6*4 /
443* ..
444* .. Executable Statements ..
445*
446* 1) Check for errors
447*
448 ntestt = 0
449 info = 0
450*
451 badnn = .false.
452 nmax = 0
453 DO 10 j = 1, nsizes
454 nmax = max( nmax, nn( j ) )
455 IF( nn( j ).LT.0 )
456 $ badnn = .true.
457 10 CONTINUE
458*
459* Check for errors
460*
461 IF( nsizes.LT.0 ) THEN
462 info = -1
463 ELSE IF( badnn ) THEN
464 info = -2
465 ELSE IF( ntypes.LT.0 ) THEN
466 info = -3
467 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
468 info = -9
469 ELSE IF( ldz.LE.1 .OR. ldz.LT.nmax ) THEN
470 info = -16
471 ELSE IF( 2*max( nmax, 2 )**2.GT.nwork ) THEN
472 info = -21
473 ELSE IF( 2*max( nmax, 2 )**2.GT.lrwork ) THEN
474 info = -23
475 ELSE IF( 2*max( nmax, 2 )**2.GT.liwork ) THEN
476 info = -25
477 END IF
478*
479 IF( info.NE.0 ) THEN
480 CALL xerbla( 'ZDRVSG2STG', -info )
481 RETURN
482 END IF
483*
484* Quick return if possible
485*
486 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
487 $ RETURN
488*
489* More Important constants
490*
491 unfl = dlamch( 'Safe minimum' )
492 ovfl = dlamch( 'Overflow' )
493 CALL dlabad( unfl, ovfl )
494 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
495 ulpinv = one / ulp
496 rtunfl = sqrt( unfl )
497 rtovfl = sqrt( ovfl )
498*
499 DO 20 i = 1, 4
500 iseed2( i ) = iseed( i )
501 20 CONTINUE
502*
503* Loop over sizes, types
504*
505 nerrs = 0
506 nmats = 0
507*
508 DO 650 jsize = 1, nsizes
509 n = nn( jsize )
510 aninv = one / dble( max( 1, n ) )
511*
512 IF( nsizes.NE.1 ) THEN
513 mtypes = min( maxtyp, ntypes )
514 ELSE
515 mtypes = min( maxtyp+1, ntypes )
516 END IF
517*
518 ka9 = 0
519 kb9 = 0
520 DO 640 jtype = 1, mtypes
521 IF( .NOT.dotype( jtype ) )
522 $ GO TO 640
523 nmats = nmats + 1
524 ntest = 0
525*
526 DO 30 j = 1, 4
527 ioldsd( j ) = iseed( j )
528 30 CONTINUE
529*
530* 2) Compute "A"
531*
532* Control parameters:
533*
534* KMAGN KMODE KTYPE
535* =1 O(1) clustered 1 zero
536* =2 large clustered 2 identity
537* =3 small exponential (none)
538* =4 arithmetic diagonal, w/ eigenvalues
539* =5 random log hermitian, w/ eigenvalues
540* =6 random (none)
541* =7 random diagonal
542* =8 random hermitian
543* =9 banded, w/ eigenvalues
544*
545 IF( mtypes.GT.maxtyp )
546 $ GO TO 90
547*
548 itype = ktype( jtype )
549 imode = kmode( jtype )
550*
551* Compute norm
552*
553 GO TO ( 40, 50, 60 )kmagn( jtype )
554*
555 40 CONTINUE
556 anorm = one
557 GO TO 70
558*
559 50 CONTINUE
560 anorm = ( rtovfl*ulp )*aninv
561 GO TO 70
562*
563 60 CONTINUE
564 anorm = rtunfl*n*ulpinv
565 GO TO 70
566*
567 70 CONTINUE
568*
569 iinfo = 0
570 cond = ulpinv
571*
572* Special Matrices -- Identity & Jordan block
573*
574 IF( itype.EQ.1 ) THEN
575*
576* Zero
577*
578 ka = 0
579 kb = 0
580 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
581*
582 ELSE IF( itype.EQ.2 ) THEN
583*
584* Identity
585*
586 ka = 0
587 kb = 0
588 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
589 DO 80 jcol = 1, n
590 a( jcol, jcol ) = anorm
591 80 CONTINUE
592*
593 ELSE IF( itype.EQ.4 ) THEN
594*
595* Diagonal Matrix, [Eigen]values Specified
596*
597 ka = 0
598 kb = 0
599 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
600 $ anorm, 0, 0, 'N', a, lda, work, iinfo )
601*
602 ELSE IF( itype.EQ.5 ) THEN
603*
604* Hermitian, eigenvalues specified
605*
606 ka = max( 0, n-1 )
607 kb = ka
608 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
609 $ anorm, n, n, 'N', a, lda, work, iinfo )
610*
611 ELSE IF( itype.EQ.7 ) THEN
612*
613* Diagonal, random eigenvalues
614*
615 ka = 0
616 kb = 0
617 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
618 $ 'T', 'N', work( n+1 ), 1, one,
619 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
620 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
621*
622 ELSE IF( itype.EQ.8 ) THEN
623*
624* Hermitian, random eigenvalues
625*
626 ka = max( 0, n-1 )
627 kb = ka
628 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
629 $ 'T', 'N', work( n+1 ), 1, one,
630 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
631 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
632*
633 ELSE IF( itype.EQ.9 ) THEN
634*
635* Hermitian banded, eigenvalues specified
636*
637* The following values are used for the half-bandwidths:
638*
639* ka = 1 kb = 1
640* ka = 2 kb = 1
641* ka = 2 kb = 2
642* ka = 3 kb = 1
643* ka = 3 kb = 2
644* ka = 3 kb = 3
645*
646 kb9 = kb9 + 1
647 IF( kb9.GT.ka9 ) THEN
648 ka9 = ka9 + 1
649 kb9 = 1
650 END IF
651 ka = max( 0, min( n-1, ka9 ) )
652 kb = max( 0, min( n-1, kb9 ) )
653 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
654 $ anorm, ka, ka, 'N', a, lda, work, iinfo )
655*
656 ELSE
657*
658 iinfo = 1
659 END IF
660*
661 IF( iinfo.NE.0 ) THEN
662 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
663 $ ioldsd
664 info = abs( iinfo )
665 RETURN
666 END IF
667*
668 90 CONTINUE
669*
670 abstol = unfl + unfl
671 IF( n.LE.1 ) THEN
672 il = 1
673 iu = n
674 ELSE
675 il = 1 + int( ( n-1 )*dlarnd( 1, iseed2 ) )
676 iu = 1 + int( ( n-1 )*dlarnd( 1, iseed2 ) )
677 IF( il.GT.iu ) THEN
678 itemp = il
679 il = iu
680 iu = itemp
681 END IF
682 END IF
683*
684* 3) Call ZHEGV, ZHPGV, ZHBGV, CHEGVD, CHPGVD, CHBGVD,
685* ZHEGVX, ZHPGVX and ZHBGVX, do tests.
686*
687* loop over the three generalized problems
688* IBTYPE = 1: A*x = (lambda)*B*x
689* IBTYPE = 2: A*B*x = (lambda)*x
690* IBTYPE = 3: B*A*x = (lambda)*x
691*
692 DO 630 ibtype = 1, 3
693*
694* loop over the setting UPLO
695*
696 DO 620 ibuplo = 1, 2
697 IF( ibuplo.EQ.1 )
698 $ uplo = 'U'
699 IF( ibuplo.EQ.2 )
700 $ uplo = 'L'
701*
702* Generate random well-conditioned positive definite
703* matrix B, of bandwidth not greater than that of A.
704*
705 CALL zlatms( n, n, 'U', iseed, 'P', rwork, 5, ten,
706 $ one, kb, kb, uplo, b, ldb, work( n+1 ),
707 $ iinfo )
708*
709* Test ZHEGV
710*
711 ntest = ntest + 1
712*
713 CALL zlacpy( ' ', n, n, a, lda, z, ldz )
714 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
715*
716 CALL zhegv( ibtype, 'V', uplo, n, z, ldz, bb, ldb, d,
717 $ work, nwork, rwork, iinfo )
718 IF( iinfo.NE.0 ) THEN
719 WRITE( nounit, fmt = 9999 )'ZHEGV(V,' // uplo //
720 $ ')', iinfo, n, jtype, ioldsd
721 info = abs( iinfo )
722 IF( iinfo.LT.0 ) THEN
723 RETURN
724 ELSE
725 result( ntest ) = ulpinv
726 GO TO 100
727 END IF
728 END IF
729*
730* Do Test
731*
732 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
733 $ ldz, d, work, rwork, result( ntest ) )
734*
735* Test ZHEGV_2STAGE
736*
737 ntest = ntest + 1
738*
739 CALL zlacpy( ' ', n, n, a, lda, z, ldz )
740 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
741*
742 CALL zhegv_2stage( ibtype, 'N', uplo, n, z, ldz,
743 $ bb, ldb, d2, work, nwork, rwork,
744 $ iinfo )
745 IF( iinfo.NE.0 ) THEN
746 WRITE( nounit, fmt = 9999 )
747 $ 'ZHEGV_2STAGE(V,' // uplo //
748 $ ')', iinfo, n, jtype, ioldsd
749 info = abs( iinfo )
750 IF( iinfo.LT.0 ) THEN
751 RETURN
752 ELSE
753 result( ntest ) = ulpinv
754 GO TO 100
755 END IF
756 END IF
757*
758* Do Test
759*
760C CALL ZSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
761C $ LDZ, D, WORK, RWORK, RESULT( NTEST ) )
762*
763* Do Tests | D1 - D2 | / ( |D1| ulp )
764* D1 computed using the standard 1-stage reduction as reference
765* D2 computed using the 2-stage reduction
766*
767 temp1 = zero
768 temp2 = zero
769 DO 151 j = 1, n
770 temp1 = max( temp1, abs( d( j ) ),
771 $ abs( d2( j ) ) )
772 temp2 = max( temp2, abs( d( j )-d2( j ) ) )
773 151 CONTINUE
774*
775 result( ntest ) = temp2 /
776 $ max( unfl, ulp*max( temp1, temp2 ) )
777*
778* Test ZHEGVD
779*
780 ntest = ntest + 1
781*
782 CALL zlacpy( ' ', n, n, a, lda, z, ldz )
783 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
784*
785 CALL zhegvd( ibtype, 'V', uplo, n, z, ldz, bb, ldb, d,
786 $ work, nwork, rwork, lrwork, iwork,
787 $ liwork, iinfo )
788 IF( iinfo.NE.0 ) THEN
789 WRITE( nounit, fmt = 9999 )'ZHEGVD(V,' // uplo //
790 $ ')', iinfo, n, jtype, ioldsd
791 info = abs( iinfo )
792 IF( iinfo.LT.0 ) THEN
793 RETURN
794 ELSE
795 result( ntest ) = ulpinv
796 GO TO 100
797 END IF
798 END IF
799*
800* Do Test
801*
802 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
803 $ ldz, d, work, rwork, result( ntest ) )
804*
805* Test ZHEGVX
806*
807 ntest = ntest + 1
808*
809 CALL zlacpy( ' ', n, n, a, lda, ab, lda )
810 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
811*
812 CALL zhegvx( ibtype, 'V', 'A', uplo, n, ab, lda, bb,
813 $ ldb, vl, vu, il, iu, abstol, m, d, z,
814 $ ldz, work, nwork, rwork, iwork( n+1 ),
815 $ iwork, iinfo )
816 IF( iinfo.NE.0 ) THEN
817 WRITE( nounit, fmt = 9999 )'ZHEGVX(V,A' // uplo //
818 $ ')', iinfo, n, jtype, ioldsd
819 info = abs( iinfo )
820 IF( iinfo.LT.0 ) THEN
821 RETURN
822 ELSE
823 result( ntest ) = ulpinv
824 GO TO 100
825 END IF
826 END IF
827*
828* Do Test
829*
830 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
831 $ ldz, d, work, rwork, result( ntest ) )
832*
833 ntest = ntest + 1
834*
835 CALL zlacpy( ' ', n, n, a, lda, ab, lda )
836 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
837*
838* since we do not know the exact eigenvalues of this
839* eigenpair, we just set VL and VU as constants.
840* It is quite possible that there are no eigenvalues
841* in this interval.
842*
843 vl = zero
844 vu = anorm
845 CALL zhegvx( ibtype, 'V', 'V', uplo, n, ab, lda, bb,
846 $ ldb, vl, vu, il, iu, abstol, m, d, z,
847 $ ldz, work, nwork, rwork, iwork( n+1 ),
848 $ iwork, iinfo )
849 IF( iinfo.NE.0 ) THEN
850 WRITE( nounit, fmt = 9999 )'ZHEGVX(V,V,' //
851 $ uplo // ')', iinfo, n, jtype, ioldsd
852 info = abs( iinfo )
853 IF( iinfo.LT.0 ) THEN
854 RETURN
855 ELSE
856 result( ntest ) = ulpinv
857 GO TO 100
858 END IF
859 END IF
860*
861* Do Test
862*
863 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
864 $ ldz, d, work, rwork, result( ntest ) )
865*
866 ntest = ntest + 1
867*
868 CALL zlacpy( ' ', n, n, a, lda, ab, lda )
869 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
870*
871 CALL zhegvx( ibtype, 'V', 'I', uplo, n, ab, lda, bb,
872 $ ldb, vl, vu, il, iu, abstol, m, d, z,
873 $ ldz, work, nwork, rwork, iwork( n+1 ),
874 $ iwork, iinfo )
875 IF( iinfo.NE.0 ) THEN
876 WRITE( nounit, fmt = 9999 )'ZHEGVX(V,I,' //
877 $ uplo // ')', iinfo, n, jtype, ioldsd
878 info = abs( iinfo )
879 IF( iinfo.LT.0 ) THEN
880 RETURN
881 ELSE
882 result( ntest ) = ulpinv
883 GO TO 100
884 END IF
885 END IF
886*
887* Do Test
888*
889 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
890 $ ldz, d, work, rwork, result( ntest ) )
891*
892 100 CONTINUE
893*
894* Test ZHPGV
895*
896 ntest = ntest + 1
897*
898* Copy the matrices into packed storage.
899*
900 IF( lsame( uplo, 'U' ) ) THEN
901 ij = 1
902 DO 120 j = 1, n
903 DO 110 i = 1, j
904 ap( ij ) = a( i, j )
905 bp( ij ) = b( i, j )
906 ij = ij + 1
907 110 CONTINUE
908 120 CONTINUE
909 ELSE
910 ij = 1
911 DO 140 j = 1, n
912 DO 130 i = j, n
913 ap( ij ) = a( i, j )
914 bp( ij ) = b( i, j )
915 ij = ij + 1
916 130 CONTINUE
917 140 CONTINUE
918 END IF
919*
920 CALL zhpgv( ibtype, 'V', uplo, n, ap, bp, d, z, ldz,
921 $ work, rwork, iinfo )
922 IF( iinfo.NE.0 ) THEN
923 WRITE( nounit, fmt = 9999 )'ZHPGV(V,' // uplo //
924 $ ')', iinfo, n, jtype, ioldsd
925 info = abs( iinfo )
926 IF( iinfo.LT.0 ) THEN
927 RETURN
928 ELSE
929 result( ntest ) = ulpinv
930 GO TO 310
931 END IF
932 END IF
933*
934* Do Test
935*
936 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
937 $ ldz, d, work, rwork, result( ntest ) )
938*
939* Test ZHPGVD
940*
941 ntest = ntest + 1
942*
943* Copy the matrices into packed storage.
944*
945 IF( lsame( uplo, 'U' ) ) THEN
946 ij = 1
947 DO 160 j = 1, n
948 DO 150 i = 1, j
949 ap( ij ) = a( i, j )
950 bp( ij ) = b( i, j )
951 ij = ij + 1
952 150 CONTINUE
953 160 CONTINUE
954 ELSE
955 ij = 1
956 DO 180 j = 1, n
957 DO 170 i = j, n
958 ap( ij ) = a( i, j )
959 bp( ij ) = b( i, j )
960 ij = ij + 1
961 170 CONTINUE
962 180 CONTINUE
963 END IF
964*
965 CALL zhpgvd( ibtype, 'V', uplo, n, ap, bp, d, z, ldz,
966 $ work, nwork, rwork, lrwork, iwork,
967 $ liwork, iinfo )
968 IF( iinfo.NE.0 ) THEN
969 WRITE( nounit, fmt = 9999 )'ZHPGVD(V,' // uplo //
970 $ ')', iinfo, n, jtype, ioldsd
971 info = abs( iinfo )
972 IF( iinfo.LT.0 ) THEN
973 RETURN
974 ELSE
975 result( ntest ) = ulpinv
976 GO TO 310
977 END IF
978 END IF
979*
980* Do Test
981*
982 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
983 $ ldz, d, work, rwork, result( ntest ) )
984*
985* Test ZHPGVX
986*
987 ntest = ntest + 1
988*
989* Copy the matrices into packed storage.
990*
991 IF( lsame( uplo, 'U' ) ) THEN
992 ij = 1
993 DO 200 j = 1, n
994 DO 190 i = 1, j
995 ap( ij ) = a( i, j )
996 bp( ij ) = b( i, j )
997 ij = ij + 1
998 190 CONTINUE
999 200 CONTINUE
1000 ELSE
1001 ij = 1
1002 DO 220 j = 1, n
1003 DO 210 i = j, n
1004 ap( ij ) = a( i, j )
1005 bp( ij ) = b( i, j )
1006 ij = ij + 1
1007 210 CONTINUE
1008 220 CONTINUE
1009 END IF
1010*
1011 CALL zhpgvx( ibtype, 'V', 'A', uplo, n, ap, bp, vl,
1012 $ vu, il, iu, abstol, m, d, z, ldz, work,
1013 $ rwork, iwork( n+1 ), iwork, info )
1014 IF( iinfo.NE.0 ) THEN
1015 WRITE( nounit, fmt = 9999 )'ZHPGVX(V,A' // uplo //
1016 $ ')', iinfo, n, jtype, ioldsd
1017 info = abs( iinfo )
1018 IF( iinfo.LT.0 ) THEN
1019 RETURN
1020 ELSE
1021 result( ntest ) = ulpinv
1022 GO TO 310
1023 END IF
1024 END IF
1025*
1026* Do Test
1027*
1028 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1029 $ ldz, d, work, rwork, result( ntest ) )
1030*
1031 ntest = ntest + 1
1032*
1033* Copy the matrices into packed storage.
1034*
1035 IF( lsame( uplo, 'U' ) ) THEN
1036 ij = 1
1037 DO 240 j = 1, n
1038 DO 230 i = 1, j
1039 ap( ij ) = a( i, j )
1040 bp( ij ) = b( i, j )
1041 ij = ij + 1
1042 230 CONTINUE
1043 240 CONTINUE
1044 ELSE
1045 ij = 1
1046 DO 260 j = 1, n
1047 DO 250 i = j, n
1048 ap( ij ) = a( i, j )
1049 bp( ij ) = b( i, j )
1050 ij = ij + 1
1051 250 CONTINUE
1052 260 CONTINUE
1053 END IF
1054*
1055 vl = zero
1056 vu = anorm
1057 CALL zhpgvx( ibtype, 'V', 'V', uplo, n, ap, bp, vl,
1058 $ vu, il, iu, abstol, m, d, z, ldz, work,
1059 $ rwork, iwork( n+1 ), iwork, info )
1060 IF( iinfo.NE.0 ) THEN
1061 WRITE( nounit, fmt = 9999 )'ZHPGVX(V,V' // uplo //
1062 $ ')', iinfo, n, jtype, ioldsd
1063 info = abs( iinfo )
1064 IF( iinfo.LT.0 ) THEN
1065 RETURN
1066 ELSE
1067 result( ntest ) = ulpinv
1068 GO TO 310
1069 END IF
1070 END IF
1071*
1072* Do Test
1073*
1074 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1075 $ ldz, d, work, rwork, result( ntest ) )
1076*
1077 ntest = ntest + 1
1078*
1079* Copy the matrices into packed storage.
1080*
1081 IF( lsame( uplo, 'U' ) ) THEN
1082 ij = 1
1083 DO 280 j = 1, n
1084 DO 270 i = 1, j
1085 ap( ij ) = a( i, j )
1086 bp( ij ) = b( i, j )
1087 ij = ij + 1
1088 270 CONTINUE
1089 280 CONTINUE
1090 ELSE
1091 ij = 1
1092 DO 300 j = 1, n
1093 DO 290 i = j, n
1094 ap( ij ) = a( i, j )
1095 bp( ij ) = b( i, j )
1096 ij = ij + 1
1097 290 CONTINUE
1098 300 CONTINUE
1099 END IF
1100*
1101 CALL zhpgvx( ibtype, 'V', 'I', uplo, n, ap, bp, vl,
1102 $ vu, il, iu, abstol, m, d, z, ldz, work,
1103 $ rwork, iwork( n+1 ), iwork, info )
1104 IF( iinfo.NE.0 ) THEN
1105 WRITE( nounit, fmt = 9999 )'ZHPGVX(V,I' // uplo //
1106 $ ')', iinfo, n, jtype, ioldsd
1107 info = abs( iinfo )
1108 IF( iinfo.LT.0 ) THEN
1109 RETURN
1110 ELSE
1111 result( ntest ) = ulpinv
1112 GO TO 310
1113 END IF
1114 END IF
1115*
1116* Do Test
1117*
1118 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1119 $ ldz, d, work, rwork, result( ntest ) )
1120*
1121 310 CONTINUE
1122*
1123 IF( ibtype.EQ.1 ) THEN
1124*
1125* TEST ZHBGV
1126*
1127 ntest = ntest + 1
1128*
1129* Copy the matrices into band storage.
1130*
1131 IF( lsame( uplo, 'U' ) ) THEN
1132 DO 340 j = 1, n
1133 DO 320 i = max( 1, j-ka ), j
1134 ab( ka+1+i-j, j ) = a( i, j )
1135 320 CONTINUE
1136 DO 330 i = max( 1, j-kb ), j
1137 bb( kb+1+i-j, j ) = b( i, j )
1138 330 CONTINUE
1139 340 CONTINUE
1140 ELSE
1141 DO 370 j = 1, n
1142 DO 350 i = j, min( n, j+ka )
1143 ab( 1+i-j, j ) = a( i, j )
1144 350 CONTINUE
1145 DO 360 i = j, min( n, j+kb )
1146 bb( 1+i-j, j ) = b( i, j )
1147 360 CONTINUE
1148 370 CONTINUE
1149 END IF
1150*
1151 CALL zhbgv( 'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1152 $ d, z, ldz, work, rwork, iinfo )
1153 IF( iinfo.NE.0 ) THEN
1154 WRITE( nounit, fmt = 9999 )'ZHBGV(V,' //
1155 $ uplo // ')', iinfo, n, jtype, ioldsd
1156 info = abs( iinfo )
1157 IF( iinfo.LT.0 ) THEN
1158 RETURN
1159 ELSE
1160 result( ntest ) = ulpinv
1161 GO TO 620
1162 END IF
1163 END IF
1164*
1165* Do Test
1166*
1167 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1168 $ ldz, d, work, rwork, result( ntest ) )
1169*
1170* TEST ZHBGVD
1171*
1172 ntest = ntest + 1
1173*
1174* Copy the matrices into band storage.
1175*
1176 IF( lsame( uplo, 'U' ) ) THEN
1177 DO 400 j = 1, n
1178 DO 380 i = max( 1, j-ka ), j
1179 ab( ka+1+i-j, j ) = a( i, j )
1180 380 CONTINUE
1181 DO 390 i = max( 1, j-kb ), j
1182 bb( kb+1+i-j, j ) = b( i, j )
1183 390 CONTINUE
1184 400 CONTINUE
1185 ELSE
1186 DO 430 j = 1, n
1187 DO 410 i = j, min( n, j+ka )
1188 ab( 1+i-j, j ) = a( i, j )
1189 410 CONTINUE
1190 DO 420 i = j, min( n, j+kb )
1191 bb( 1+i-j, j ) = b( i, j )
1192 420 CONTINUE
1193 430 CONTINUE
1194 END IF
1195*
1196 CALL zhbgvd( 'V', uplo, n, ka, kb, ab, lda, bb,
1197 $ ldb, d, z, ldz, work, nwork, rwork,
1198 $ lrwork, iwork, liwork, iinfo )
1199 IF( iinfo.NE.0 ) THEN
1200 WRITE( nounit, fmt = 9999 )'ZHBGVD(V,' //
1201 $ uplo // ')', iinfo, n, jtype, ioldsd
1202 info = abs( iinfo )
1203 IF( iinfo.LT.0 ) THEN
1204 RETURN
1205 ELSE
1206 result( ntest ) = ulpinv
1207 GO TO 620
1208 END IF
1209 END IF
1210*
1211* Do Test
1212*
1213 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1214 $ ldz, d, work, rwork, result( ntest ) )
1215*
1216* Test ZHBGVX
1217*
1218 ntest = ntest + 1
1219*
1220* Copy the matrices into band storage.
1221*
1222 IF( lsame( uplo, 'U' ) ) THEN
1223 DO 460 j = 1, n
1224 DO 440 i = max( 1, j-ka ), j
1225 ab( ka+1+i-j, j ) = a( i, j )
1226 440 CONTINUE
1227 DO 450 i = max( 1, j-kb ), j
1228 bb( kb+1+i-j, j ) = b( i, j )
1229 450 CONTINUE
1230 460 CONTINUE
1231 ELSE
1232 DO 490 j = 1, n
1233 DO 470 i = j, min( n, j+ka )
1234 ab( 1+i-j, j ) = a( i, j )
1235 470 CONTINUE
1236 DO 480 i = j, min( n, j+kb )
1237 bb( 1+i-j, j ) = b( i, j )
1238 480 CONTINUE
1239 490 CONTINUE
1240 END IF
1241*
1242 CALL zhbgvx( 'V', 'A', uplo, n, ka, kb, ab, lda,
1243 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1244 $ iu, abstol, m, d, z, ldz, work, rwork,
1245 $ iwork( n+1 ), iwork, iinfo )
1246 IF( iinfo.NE.0 ) THEN
1247 WRITE( nounit, fmt = 9999 )'ZHBGVX(V,A' //
1248 $ uplo // ')', iinfo, n, jtype, ioldsd
1249 info = abs( iinfo )
1250 IF( iinfo.LT.0 ) THEN
1251 RETURN
1252 ELSE
1253 result( ntest ) = ulpinv
1254 GO TO 620
1255 END IF
1256 END IF
1257*
1258* Do Test
1259*
1260 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1261 $ ldz, d, work, rwork, result( ntest ) )
1262*
1263 ntest = ntest + 1
1264*
1265* Copy the matrices into band storage.
1266*
1267 IF( lsame( uplo, 'U' ) ) THEN
1268 DO 520 j = 1, n
1269 DO 500 i = max( 1, j-ka ), j
1270 ab( ka+1+i-j, j ) = a( i, j )
1271 500 CONTINUE
1272 DO 510 i = max( 1, j-kb ), j
1273 bb( kb+1+i-j, j ) = b( i, j )
1274 510 CONTINUE
1275 520 CONTINUE
1276 ELSE
1277 DO 550 j = 1, n
1278 DO 530 i = j, min( n, j+ka )
1279 ab( 1+i-j, j ) = a( i, j )
1280 530 CONTINUE
1281 DO 540 i = j, min( n, j+kb )
1282 bb( 1+i-j, j ) = b( i, j )
1283 540 CONTINUE
1284 550 CONTINUE
1285 END IF
1286*
1287 vl = zero
1288 vu = anorm
1289 CALL zhbgvx( 'V', 'V', uplo, n, ka, kb, ab, lda,
1290 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1291 $ iu, abstol, m, d, z, ldz, work, rwork,
1292 $ iwork( n+1 ), iwork, iinfo )
1293 IF( iinfo.NE.0 ) THEN
1294 WRITE( nounit, fmt = 9999 )'ZHBGVX(V,V' //
1295 $ uplo // ')', iinfo, n, jtype, ioldsd
1296 info = abs( iinfo )
1297 IF( iinfo.LT.0 ) THEN
1298 RETURN
1299 ELSE
1300 result( ntest ) = ulpinv
1301 GO TO 620
1302 END IF
1303 END IF
1304*
1305* Do Test
1306*
1307 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1308 $ ldz, d, work, rwork, result( ntest ) )
1309*
1310 ntest = ntest + 1
1311*
1312* Copy the matrices into band storage.
1313*
1314 IF( lsame( uplo, 'U' ) ) THEN
1315 DO 580 j = 1, n
1316 DO 560 i = max( 1, j-ka ), j
1317 ab( ka+1+i-j, j ) = a( i, j )
1318 560 CONTINUE
1319 DO 570 i = max( 1, j-kb ), j
1320 bb( kb+1+i-j, j ) = b( i, j )
1321 570 CONTINUE
1322 580 CONTINUE
1323 ELSE
1324 DO 610 j = 1, n
1325 DO 590 i = j, min( n, j+ka )
1326 ab( 1+i-j, j ) = a( i, j )
1327 590 CONTINUE
1328 DO 600 i = j, min( n, j+kb )
1329 bb( 1+i-j, j ) = b( i, j )
1330 600 CONTINUE
1331 610 CONTINUE
1332 END IF
1333*
1334 CALL zhbgvx( 'V', 'I', uplo, n, ka, kb, ab, lda,
1335 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1336 $ iu, abstol, m, d, z, ldz, work, rwork,
1337 $ iwork( n+1 ), iwork, iinfo )
1338 IF( iinfo.NE.0 ) THEN
1339 WRITE( nounit, fmt = 9999 )'ZHBGVX(V,I' //
1340 $ uplo // ')', iinfo, n, jtype, ioldsd
1341 info = abs( iinfo )
1342 IF( iinfo.LT.0 ) THEN
1343 RETURN
1344 ELSE
1345 result( ntest ) = ulpinv
1346 GO TO 620
1347 END IF
1348 END IF
1349*
1350* Do Test
1351*
1352 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1353 $ ldz, d, work, rwork, result( ntest ) )
1354*
1355 END IF
1356*
1357 620 CONTINUE
1358 630 CONTINUE
1359*
1360* End of Loop -- Check for RESULT(j) > THRESH
1361*
1362 ntestt = ntestt + ntest
1363 CALL dlafts( 'ZSG', n, n, jtype, ntest, result, ioldsd,
1364 $ thresh, nounit, nerrs )
1365 640 CONTINUE
1366 650 CONTINUE
1367*
1368* Summary
1369*
1370 CALL dlasum( 'ZSG', nounit, nerrs, ntestt )
1371*
1372 RETURN
1373*
1374 9999 FORMAT( ' ZDRVSG2STG: ', a, ' returned INFO=', i6, '.', / 9x,
1375 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1376*
1377* End of ZDRVSG2STG
1378*
zhegv_2stage
subroutine zhegv_2stage(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, info)
ZHEGV_2STAGE
Definition zhegv_2stage.f:232

◆ zdrvst()

subroutine zdrvst ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d1,
double precision, dimension( * ) d2,
double precision, dimension( * ) d3,
double precision, dimension( * ) wa1,
double precision, dimension( * ) wa2,
double precision, dimension( * ) wa3,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldu, * ) v,
complex*16, dimension( * ) tau,
complex*16, dimension( ldu, * ) z,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer lrwork,
integer, dimension( * ) iwork,
integer liwork,
double precision, dimension( * ) result,
integer info )

ZDRVST

Purpose:
!>
!>      ZDRVST  checks the Hermitian eigenvalue problem drivers.
!>
!>              ZHEEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix,
!>              using a divide-and-conquer algorithm.
!>
!>              ZHEEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix.
!>
!>              ZHEEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              ZHPEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage, using a divide-and-conquer algorithm.
!>
!>              ZHPEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage.
!>
!>              ZHBEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix,
!>              using a divide-and-conquer algorithm.
!>
!>              ZHBEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix.
!>
!>              ZHEEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix.
!>
!>              ZHPEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage.
!>
!>              ZHBEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix.
!>
!>      When ZDRVST is called, a number of matrix  () and a
!>      number of matrix  are specified.  For each size ()
!>      and each type of matrix, one matrix will be generated and used
!>      to test the appropriate drivers.  For each matrix and each
!>      driver routine called, the following tests will be performed:
!>
!>      (1)     | A - Z D Z' | / ( |A| n ulp )
!>
!>      (2)     | I - Z Z' | / ( n ulp )
!>
!>      (3)     | D1 - D2 | / ( |D1| ulp )
!>
!>      where Z is the matrix of eigenvectors returned when the
!>      eigenvector option is given and D1 and D2 are the eigenvalues
!>      returned with and without the eigenvector option.
!>
!>      The  are specified by an array NN(1:NSIZES); the value of
!>      each element NN(j) specifies one size.
!>      The  are specified by a logical array DOTYPE( 1:NTYPES );
!>      if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!>      Currently, the list of possible types is:
!>
!>      (1)  The zero matrix.
!>      (2)  The identity matrix.
!>
!>      (3)  A diagonal matrix with evenly spaced entries
!>           1, ..., ULP  and random signs.
!>           (ULP = (first number larger than 1) - 1 )
!>      (4)  A diagonal matrix with geometrically spaced entries
!>           1, ..., ULP  and random signs.
!>      (5)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>           and random signs.
!>
!>      (6)  Same as (4), but multiplied by SQRT( overflow threshold )
!>      (7)  Same as (4), but multiplied by SQRT( underflow threshold )
!>
!>      (8)  A matrix of the form  U* D U, where U is unitary and
!>           D has evenly spaced entries 1, ..., ULP with random signs
!>           on the diagonal.
!>
!>      (9)  A matrix of the form  U* D U, where U is unitary and
!>           D has geometrically spaced entries 1, ..., ULP with random
!>           signs on the diagonal.
!>
!>      (10) A matrix of the form  U* D U, where U is unitary and
!>           D has  entries 1, ULP,..., ULP with random
!>           signs on the diagonal.
!>
!>      (11) Same as (8), but multiplied by SQRT( overflow threshold )
!>      (12) Same as (8), but multiplied by SQRT( underflow threshold )
!>
!>      (13) Symmetric matrix with random entries chosen from (-1,1).
!>      (14) Same as (13), but multiplied by SQRT( overflow threshold )
!>      (15) Same as (13), but multiplied by SQRT( underflow threshold )
!>      (16) A band matrix with half bandwidth randomly chosen between
!>           0 and N-1, with evenly spaced eigenvalues 1, ..., ULP
!>           with random signs.
!>      (17) Same as (16), but multiplied by SQRT( overflow threshold )
!>      (18) Same as (16), but multiplied by SQRT( underflow threshold )
!> 
!>  NSIZES  INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZDRVST does nothing.  It must be at least zero.
!>          Not modified.
!>
!>  NN      INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>          Not modified.
!>
!>  NTYPES  INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZDRVST
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>          Not modified.
!>
!>  DOTYPE  LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>          Not modified.
!>
!>  ISEED   INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRVST to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       COMPLEX*16 array, dimension (LDA , max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  D1      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by ZSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>          Modified.
!>
!>  D2      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by ZSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>          Modified.
!>
!>  D3      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by DSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>          Modified.
!>
!>  WA1     DOUBLE PRECISION array, dimension
!>
!>  WA2     DOUBLE PRECISION array, dimension
!>
!>  WA3     DOUBLE PRECISION array, dimension
!>
!>  U       COMPLEX*16 array, dimension (LDU, max(NN))
!>          The unitary matrix computed by ZHETRD + ZUNGC3.
!>          Modified.
!>
!>  LDU     INTEGER
!>          The leading dimension of U, Z, and V.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  V       COMPLEX*16 array, dimension (LDU, max(NN))
!>          The Housholder vectors computed by ZHETRD in reducing A to
!>          tridiagonal form.
!>          Modified.
!>
!>  TAU     COMPLEX*16 array, dimension (max(NN))
!>          The Householder factors computed by ZHETRD in reducing A
!>          to tridiagonal form.
!>          Modified.
!>
!>  Z       COMPLEX*16 array, dimension (LDU, max(NN))
!>          The unitary matrix of eigenvectors computed by ZHEEVD,
!>          ZHEEVX, ZHPEVD, CHPEVX, ZHBEVD, and CHBEVX.
!>          Modified.
!>
!>  WORK  - COMPLEX*16 array of dimension ( LWORK )
!>           Workspace.
!>           Modified.
!>
!>  LWORK - INTEGER
!>           The number of entries in WORK.  This must be at least
!>           2*max( NN(j), 2 )**2.
!>           Not modified.
!>
!>  RWORK   DOUBLE PRECISION array, dimension (3*max(NN))
!>           Workspace.
!>           Modified.
!>
!>  LRWORK - INTEGER
!>           The number of entries in RWORK.
!>
!>  IWORK   INTEGER array, dimension (6*max(NN))
!>          Workspace.
!>          Modified.
!>
!>  LIWORK - INTEGER
!>           The number of entries in IWORK.
!>
!>  RESULT  DOUBLE PRECISION array, dimension (??)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>          Modified.
!>
!>  INFO    INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -16: LDU < 1 or LDU < NMAX.
!>          -21: LWORK too small.
!>          If  DLATMR, SLATMS, ZHETRD, DORGC3, ZSTEQR, DSTERF,
!>              or DORMC2 returns an error code, the
!>              absolute value of it is returned.
!>          Modified.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far (computed by DLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 334 of file zdrvst.f.

338*
339* -- LAPACK test routine --
340* -- LAPACK is a software package provided by Univ. of Tennessee, --
341* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
342*
343* .. Scalar Arguments ..
344 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
345 $ NSIZES, NTYPES
346 DOUBLE PRECISION THRESH
347* ..
348* .. Array Arguments ..
349 LOGICAL DOTYPE( * )
350 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
351 DOUBLE PRECISION D1( * ), D2( * ), D3( * ), RESULT( * ),
352 $ RWORK( * ), WA1( * ), WA2( * ), WA3( * )
353 COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ),
354 $ V( LDU, * ), WORK( * ), Z( LDU, * )
355* ..
356*
357* =====================================================================
358*
359*
360* .. Parameters ..
361 DOUBLE PRECISION ZERO, ONE, TWO, TEN
362 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
363 $ ten = 10.0d+0 )
364 DOUBLE PRECISION HALF
365 parameter( half = one / two )
366 COMPLEX*16 CZERO, CONE
367 parameter( czero = ( 0.0d+0, 0.0d+0 ),
368 $ cone = ( 1.0d+0, 0.0d+0 ) )
369 INTEGER MAXTYP
370 parameter( maxtyp = 18 )
371* ..
372* .. Local Scalars ..
373 LOGICAL BADNN
374 CHARACTER UPLO
375 INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDWRK, INDX,
376 $ IROW, ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL,
377 $ JSIZE, JTYPE, KD, LGN, LIWEDC, LRWEDC, LWEDC,
378 $ M, M2, M3, MTYPES, N, NERRS, NMATS, NMAX,
379 $ NTEST, NTESTT
380 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
381 $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL,
382 $ VL, VU
383* ..
384* .. Local Arrays ..
385 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
386 $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
387 $ KTYPE( MAXTYP )
388* ..
389* .. External Functions ..
390 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
391 EXTERNAL dlamch, dlarnd, dsxt1
392* ..
393* .. External Subroutines ..
394 EXTERNAL alasvm, dlabad, dlafts, xerbla, zhbev, zhbevd,
395 $ zhbevx, zheev, zheevd, zheevr, zheevx, zhet21,
396 $ zhet22, zhpev, zhpevd, zhpevx, zlacpy, zlaset,
397 $ zlatmr, zlatms
398* ..
399* .. Intrinsic Functions ..
400 INTRINSIC abs, dble, int, log, max, min, sqrt
401* ..
402* .. Data statements ..
403 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 3*9 /
404 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
405 $ 2, 3, 1, 2, 3 /
406 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
407 $ 0, 0, 4, 4, 4 /
408* ..
409* .. Executable Statements ..
410*
411* 1) Check for errors
412*
413 ntestt = 0
414 info = 0
415*
416 badnn = .false.
417 nmax = 1
418 DO 10 j = 1, nsizes
419 nmax = max( nmax, nn( j ) )
420 IF( nn( j ).LT.0 )
421 $ badnn = .true.
422 10 CONTINUE
423*
424* Check for errors
425*
426 IF( nsizes.LT.0 ) THEN
427 info = -1
428 ELSE IF( badnn ) THEN
429 info = -2
430 ELSE IF( ntypes.LT.0 ) THEN
431 info = -3
432 ELSE IF( lda.LT.nmax ) THEN
433 info = -9
434 ELSE IF( ldu.LT.nmax ) THEN
435 info = -16
436 ELSE IF( 2*max( 2, nmax )**2.GT.lwork ) THEN
437 info = -22
438 END IF
439*
440 IF( info.NE.0 ) THEN
441 CALL xerbla( 'ZDRVST', -info )
442 RETURN
443 END IF
444*
445* Quick return if nothing to do
446*
447 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
448 $ RETURN
449*
450* More Important constants
451*
452 unfl = dlamch( 'Safe minimum' )
453 ovfl = dlamch( 'Overflow' )
454 CALL dlabad( unfl, ovfl )
455 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
456 ulpinv = one / ulp
457 rtunfl = sqrt( unfl )
458 rtovfl = sqrt( ovfl )
459*
460* Loop over sizes, types
461*
462 DO 20 i = 1, 4
463 iseed2( i ) = iseed( i )
464 iseed3( i ) = iseed( i )
465 20 CONTINUE
466*
467 nerrs = 0
468 nmats = 0
469*
470 DO 1220 jsize = 1, nsizes
471 n = nn( jsize )
472 IF( n.GT.0 ) THEN
473 lgn = int( log( dble( n ) ) / log( two ) )
474 IF( 2**lgn.LT.n )
475 $ lgn = lgn + 1
476 IF( 2**lgn.LT.n )
477 $ lgn = lgn + 1
478 lwedc = max( 2*n+n*n, 2*n*n )
479 lrwedc = 1 + 4*n + 2*n*lgn + 3*n**2
480 liwedc = 3 + 5*n
481 ELSE
482 lwedc = 2
483 lrwedc = 8
484 liwedc = 8
485 END IF
486 aninv = one / dble( max( 1, n ) )
487*
488 IF( nsizes.NE.1 ) THEN
489 mtypes = min( maxtyp, ntypes )
490 ELSE
491 mtypes = min( maxtyp+1, ntypes )
492 END IF
493*
494 DO 1210 jtype = 1, mtypes
495 IF( .NOT.dotype( jtype ) )
496 $ GO TO 1210
497 nmats = nmats + 1
498 ntest = 0
499*
500 DO 30 j = 1, 4
501 ioldsd( j ) = iseed( j )
502 30 CONTINUE
503*
504* 2) Compute "A"
505*
506* Control parameters:
507*
508* KMAGN KMODE KTYPE
509* =1 O(1) clustered 1 zero
510* =2 large clustered 2 identity
511* =3 small exponential (none)
512* =4 arithmetic diagonal, (w/ eigenvalues)
513* =5 random log Hermitian, w/ eigenvalues
514* =6 random (none)
515* =7 random diagonal
516* =8 random Hermitian
517* =9 band Hermitian, w/ eigenvalues
518*
519 IF( mtypes.GT.maxtyp )
520 $ GO TO 110
521*
522 itype = ktype( jtype )
523 imode = kmode( jtype )
524*
525* Compute norm
526*
527 GO TO ( 40, 50, 60 )kmagn( jtype )
528*
529 40 CONTINUE
530 anorm = one
531 GO TO 70
532*
533 50 CONTINUE
534 anorm = ( rtovfl*ulp )*aninv
535 GO TO 70
536*
537 60 CONTINUE
538 anorm = rtunfl*n*ulpinv
539 GO TO 70
540*
541 70 CONTINUE
542*
543 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
544 iinfo = 0
545 cond = ulpinv
546*
547* Special Matrices -- Identity & Jordan block
548*
549* Zero
550*
551 IF( itype.EQ.1 ) THEN
552 iinfo = 0
553*
554 ELSE IF( itype.EQ.2 ) THEN
555*
556* Identity
557*
558 DO 80 jcol = 1, n
559 a( jcol, jcol ) = anorm
560 80 CONTINUE
561*
562 ELSE IF( itype.EQ.4 ) THEN
563*
564* Diagonal Matrix, [Eigen]values Specified
565*
566 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
567 $ anorm, 0, 0, 'N', a, lda, work, iinfo )
568*
569 ELSE IF( itype.EQ.5 ) THEN
570*
571* Hermitian, eigenvalues specified
572*
573 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
574 $ anorm, n, n, 'N', a, lda, work, iinfo )
575*
576 ELSE IF( itype.EQ.7 ) THEN
577*
578* Diagonal, random eigenvalues
579*
580 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
581 $ 'T', 'N', work( n+1 ), 1, one,
582 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
583 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
584*
585 ELSE IF( itype.EQ.8 ) THEN
586*
587* Hermitian, random eigenvalues
588*
589 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
590 $ 'T', 'N', work( n+1 ), 1, one,
591 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
592 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
593*
594 ELSE IF( itype.EQ.9 ) THEN
595*
596* Hermitian banded, eigenvalues specified
597*
598 ihbw = int( ( n-1 )*dlarnd( 1, iseed3 ) )
599 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
600 $ anorm, ihbw, ihbw, 'Z', u, ldu, work,
601 $ iinfo )
602*
603* Store as dense matrix for most routines.
604*
605 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
606 DO 100 idiag = -ihbw, ihbw
607 irow = ihbw - idiag + 1
608 j1 = max( 1, idiag+1 )
609 j2 = min( n, n+idiag )
610 DO 90 j = j1, j2
611 i = j - idiag
612 a( i, j ) = u( irow, j )
613 90 CONTINUE
614 100 CONTINUE
615 ELSE
616 iinfo = 1
617 END IF
618*
619 IF( iinfo.NE.0 ) THEN
620 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
621 $ ioldsd
622 info = abs( iinfo )
623 RETURN
624 END IF
625*
626 110 CONTINUE
627*
628 abstol = unfl + unfl
629 IF( n.LE.1 ) THEN
630 il = 1
631 iu = n
632 ELSE
633 il = 1 + int( ( n-1 )*dlarnd( 1, iseed2 ) )
634 iu = 1 + int( ( n-1 )*dlarnd( 1, iseed2 ) )
635 IF( il.GT.iu ) THEN
636 itemp = il
637 il = iu
638 iu = itemp
639 END IF
640 END IF
641*
642* Perform tests storing upper or lower triangular
643* part of matrix.
644*
645 DO 1200 iuplo = 0, 1
646 IF( iuplo.EQ.0 ) THEN
647 uplo = 'L'
648 ELSE
649 uplo = 'U'
650 END IF
651*
652* Call ZHEEVD and CHEEVX.
653*
654 CALL zlacpy( ' ', n, n, a, lda, v, ldu )
655*
656 ntest = ntest + 1
657 CALL zheevd( 'V', uplo, n, a, ldu, d1, work, lwedc,
658 $ rwork, lrwedc, iwork, liwedc, iinfo )
659 IF( iinfo.NE.0 ) THEN
660 WRITE( nounit, fmt = 9999 )'ZHEEVD(V,' // uplo //
661 $ ')', iinfo, n, jtype, ioldsd
662 info = abs( iinfo )
663 IF( iinfo.LT.0 ) THEN
664 RETURN
665 ELSE
666 result( ntest ) = ulpinv
667 result( ntest+1 ) = ulpinv
668 result( ntest+2 ) = ulpinv
669 GO TO 130
670 END IF
671 END IF
672*
673* Do tests 1 and 2.
674*
675 CALL zhet21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
676 $ ldu, tau, work, rwork, result( ntest ) )
677*
678 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
679*
680 ntest = ntest + 2
681 CALL zheevd( 'N', uplo, n, a, ldu, d3, work, lwedc,
682 $ rwork, lrwedc, iwork, liwedc, iinfo )
683 IF( iinfo.NE.0 ) THEN
684 WRITE( nounit, fmt = 9999 )'ZHEEVD(N,' // uplo //
685 $ ')', iinfo, n, jtype, ioldsd
686 info = abs( iinfo )
687 IF( iinfo.LT.0 ) THEN
688 RETURN
689 ELSE
690 result( ntest ) = ulpinv
691 GO TO 130
692 END IF
693 END IF
694*
695* Do test 3.
696*
697 temp1 = zero
698 temp2 = zero
699 DO 120 j = 1, n
700 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
701 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
702 120 CONTINUE
703 result( ntest ) = temp2 / max( unfl,
704 $ ulp*max( temp1, temp2 ) )
705*
706 130 CONTINUE
707 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
708*
709 ntest = ntest + 1
710*
711 IF( n.GT.0 ) THEN
712 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
713 IF( il.NE.1 ) THEN
714 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
715 $ ten*ulp*temp3, ten*rtunfl )
716 ELSE IF( n.GT.0 ) THEN
717 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
718 $ ten*ulp*temp3, ten*rtunfl )
719 END IF
720 IF( iu.NE.n ) THEN
721 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
722 $ ten*ulp*temp3, ten*rtunfl )
723 ELSE IF( n.GT.0 ) THEN
724 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
725 $ ten*ulp*temp3, ten*rtunfl )
726 END IF
727 ELSE
728 temp3 = zero
729 vl = zero
730 vu = one
731 END IF
732*
733 CALL zheevx( 'V', 'A', uplo, n, a, ldu, vl, vu, il, iu,
734 $ abstol, m, wa1, z, ldu, work, lwork, rwork,
735 $ iwork, iwork( 5*n+1 ), iinfo )
736 IF( iinfo.NE.0 ) THEN
737 WRITE( nounit, fmt = 9999 )'ZHEEVX(V,A,' // uplo //
738 $ ')', iinfo, n, jtype, ioldsd
739 info = abs( iinfo )
740 IF( iinfo.LT.0 ) THEN
741 RETURN
742 ELSE
743 result( ntest ) = ulpinv
744 result( ntest+1 ) = ulpinv
745 result( ntest+2 ) = ulpinv
746 GO TO 150
747 END IF
748 END IF
749*
750* Do tests 4 and 5.
751*
752 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
753*
754 CALL zhet21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
755 $ ldu, tau, work, rwork, result( ntest ) )
756*
757 ntest = ntest + 2
758 CALL zheevx( 'N', 'A', uplo, n, a, ldu, vl, vu, il, iu,
759 $ abstol, m2, wa2, z, ldu, work, lwork, rwork,
760 $ iwork, iwork( 5*n+1 ), iinfo )
761 IF( iinfo.NE.0 ) THEN
762 WRITE( nounit, fmt = 9999 )'ZHEEVX(N,A,' // uplo //
763 $ ')', iinfo, n, jtype, ioldsd
764 info = abs( iinfo )
765 IF( iinfo.LT.0 ) THEN
766 RETURN
767 ELSE
768 result( ntest ) = ulpinv
769 GO TO 150
770 END IF
771 END IF
772*
773* Do test 6.
774*
775 temp1 = zero
776 temp2 = zero
777 DO 140 j = 1, n
778 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
779 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
780 140 CONTINUE
781 result( ntest ) = temp2 / max( unfl,
782 $ ulp*max( temp1, temp2 ) )
783*
784 150 CONTINUE
785 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
786*
787 ntest = ntest + 1
788*
789 CALL zheevx( 'V', 'I', uplo, n, a, ldu, vl, vu, il, iu,
790 $ abstol, m2, wa2, z, ldu, work, lwork, rwork,
791 $ iwork, iwork( 5*n+1 ), iinfo )
792 IF( iinfo.NE.0 ) THEN
793 WRITE( nounit, fmt = 9999 )'ZHEEVX(V,I,' // uplo //
794 $ ')', iinfo, n, jtype, ioldsd
795 info = abs( iinfo )
796 IF( iinfo.LT.0 ) THEN
797 RETURN
798 ELSE
799 result( ntest ) = ulpinv
800 GO TO 160
801 END IF
802 END IF
803*
804* Do tests 7 and 8.
805*
806 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
807*
808 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
809 $ v, ldu, tau, work, rwork, result( ntest ) )
810*
811 ntest = ntest + 2
812*
813 CALL zheevx( 'N', 'I', uplo, n, a, ldu, vl, vu, il, iu,
814 $ abstol, m3, wa3, z, ldu, work, lwork, rwork,
815 $ iwork, iwork( 5*n+1 ), iinfo )
816 IF( iinfo.NE.0 ) THEN
817 WRITE( nounit, fmt = 9999 )'ZHEEVX(N,I,' // uplo //
818 $ ')', iinfo, n, jtype, ioldsd
819 info = abs( iinfo )
820 IF( iinfo.LT.0 ) THEN
821 RETURN
822 ELSE
823 result( ntest ) = ulpinv
824 GO TO 160
825 END IF
826 END IF
827*
828* Do test 9.
829*
830 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
831 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
832 IF( n.GT.0 ) THEN
833 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
834 ELSE
835 temp3 = zero
836 END IF
837 result( ntest ) = ( temp1+temp2 ) /
838 $ max( unfl, temp3*ulp )
839*
840 160 CONTINUE
841 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
842*
843 ntest = ntest + 1
844*
845 CALL zheevx( 'V', 'V', uplo, n, a, ldu, vl, vu, il, iu,
846 $ abstol, m2, wa2, z, ldu, work, lwork, rwork,
847 $ iwork, iwork( 5*n+1 ), iinfo )
848 IF( iinfo.NE.0 ) THEN
849 WRITE( nounit, fmt = 9999 )'ZHEEVX(V,V,' // uplo //
850 $ ')', iinfo, n, jtype, ioldsd
851 info = abs( iinfo )
852 IF( iinfo.LT.0 ) THEN
853 RETURN
854 ELSE
855 result( ntest ) = ulpinv
856 GO TO 170
857 END IF
858 END IF
859*
860* Do tests 10 and 11.
861*
862 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
863*
864 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
865 $ v, ldu, tau, work, rwork, result( ntest ) )
866*
867 ntest = ntest + 2
868*
869 CALL zheevx( 'N', 'V', uplo, n, a, ldu, vl, vu, il, iu,
870 $ abstol, m3, wa3, z, ldu, work, lwork, rwork,
871 $ iwork, iwork( 5*n+1 ), iinfo )
872 IF( iinfo.NE.0 ) THEN
873 WRITE( nounit, fmt = 9999 )'ZHEEVX(N,V,' // uplo //
874 $ ')', iinfo, n, jtype, ioldsd
875 info = abs( iinfo )
876 IF( iinfo.LT.0 ) THEN
877 RETURN
878 ELSE
879 result( ntest ) = ulpinv
880 GO TO 170
881 END IF
882 END IF
883*
884 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
885 result( ntest ) = ulpinv
886 GO TO 170
887 END IF
888*
889* Do test 12.
890*
891 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
892 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
893 IF( n.GT.0 ) THEN
894 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
895 ELSE
896 temp3 = zero
897 END IF
898 result( ntest ) = ( temp1+temp2 ) /
899 $ max( unfl, temp3*ulp )
900*
901 170 CONTINUE
902*
903* Call ZHPEVD and CHPEVX.
904*
905 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
906*
907* Load array WORK with the upper or lower triangular
908* part of the matrix in packed form.
909*
910 IF( iuplo.EQ.1 ) THEN
911 indx = 1
912 DO 190 j = 1, n
913 DO 180 i = 1, j
914 work( indx ) = a( i, j )
915 indx = indx + 1
916 180 CONTINUE
917 190 CONTINUE
918 ELSE
919 indx = 1
920 DO 210 j = 1, n
921 DO 200 i = j, n
922 work( indx ) = a( i, j )
923 indx = indx + 1
924 200 CONTINUE
925 210 CONTINUE
926 END IF
927*
928 ntest = ntest + 1
929 indwrk = n*( n+1 ) / 2 + 1
930 CALL zhpevd( 'V', uplo, n, work, d1, z, ldu,
931 $ work( indwrk ), lwedc, rwork, lrwedc, iwork,
932 $ liwedc, iinfo )
933 IF( iinfo.NE.0 ) THEN
934 WRITE( nounit, fmt = 9999 )'ZHPEVD(V,' // uplo //
935 $ ')', iinfo, n, jtype, ioldsd
936 info = abs( iinfo )
937 IF( iinfo.LT.0 ) THEN
938 RETURN
939 ELSE
940 result( ntest ) = ulpinv
941 result( ntest+1 ) = ulpinv
942 result( ntest+2 ) = ulpinv
943 GO TO 270
944 END IF
945 END IF
946*
947* Do tests 13 and 14.
948*
949 CALL zhet21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
950 $ ldu, tau, work, rwork, result( ntest ) )
951*
952 IF( iuplo.EQ.1 ) THEN
953 indx = 1
954 DO 230 j = 1, n
955 DO 220 i = 1, j
956 work( indx ) = a( i, j )
957 indx = indx + 1
958 220 CONTINUE
959 230 CONTINUE
960 ELSE
961 indx = 1
962 DO 250 j = 1, n
963 DO 240 i = j, n
964 work( indx ) = a( i, j )
965 indx = indx + 1
966 240 CONTINUE
967 250 CONTINUE
968 END IF
969*
970 ntest = ntest + 2
971 indwrk = n*( n+1 ) / 2 + 1
972 CALL zhpevd( 'N', uplo, n, work, d3, z, ldu,
973 $ work( indwrk ), lwedc, rwork, lrwedc, iwork,
974 $ liwedc, iinfo )
975 IF( iinfo.NE.0 ) THEN
976 WRITE( nounit, fmt = 9999 )'ZHPEVD(N,' // uplo //
977 $ ')', iinfo, n, jtype, ioldsd
978 info = abs( iinfo )
979 IF( iinfo.LT.0 ) THEN
980 RETURN
981 ELSE
982 result( ntest ) = ulpinv
983 GO TO 270
984 END IF
985 END IF
986*
987* Do test 15.
988*
989 temp1 = zero
990 temp2 = zero
991 DO 260 j = 1, n
992 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
993 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
994 260 CONTINUE
995 result( ntest ) = temp2 / max( unfl,
996 $ ulp*max( temp1, temp2 ) )
997*
998* Load array WORK with the upper or lower triangular part
999* of the matrix in packed form.
1000*
1001 270 CONTINUE
1002 IF( iuplo.EQ.1 ) THEN
1003 indx = 1
1004 DO 290 j = 1, n
1005 DO 280 i = 1, j
1006 work( indx ) = a( i, j )
1007 indx = indx + 1
1008 280 CONTINUE
1009 290 CONTINUE
1010 ELSE
1011 indx = 1
1012 DO 310 j = 1, n
1013 DO 300 i = j, n
1014 work( indx ) = a( i, j )
1015 indx = indx + 1
1016 300 CONTINUE
1017 310 CONTINUE
1018 END IF
1019*
1020 ntest = ntest + 1
1021*
1022 IF( n.GT.0 ) THEN
1023 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
1024 IF( il.NE.1 ) THEN
1025 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
1026 $ ten*ulp*temp3, ten*rtunfl )
1027 ELSE IF( n.GT.0 ) THEN
1028 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
1029 $ ten*ulp*temp3, ten*rtunfl )
1030 END IF
1031 IF( iu.NE.n ) THEN
1032 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
1033 $ ten*ulp*temp3, ten*rtunfl )
1034 ELSE IF( n.GT.0 ) THEN
1035 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
1036 $ ten*ulp*temp3, ten*rtunfl )
1037 END IF
1038 ELSE
1039 temp3 = zero
1040 vl = zero
1041 vu = one
1042 END IF
1043*
1044 CALL zhpevx( 'V', 'A', uplo, n, work, vl, vu, il, iu,
1045 $ abstol, m, wa1, z, ldu, v, rwork, iwork,
1046 $ iwork( 5*n+1 ), iinfo )
1047 IF( iinfo.NE.0 ) THEN
1048 WRITE( nounit, fmt = 9999 )'ZHPEVX(V,A,' // uplo //
1049 $ ')', iinfo, n, jtype, ioldsd
1050 info = abs( iinfo )
1051 IF( iinfo.LT.0 ) THEN
1052 RETURN
1053 ELSE
1054 result( ntest ) = ulpinv
1055 result( ntest+1 ) = ulpinv
1056 result( ntest+2 ) = ulpinv
1057 GO TO 370
1058 END IF
1059 END IF
1060*
1061* Do tests 16 and 17.
1062*
1063 CALL zhet21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
1064 $ ldu, tau, work, rwork, result( ntest ) )
1065*
1066 ntest = ntest + 2
1067*
1068 IF( iuplo.EQ.1 ) THEN
1069 indx = 1
1070 DO 330 j = 1, n
1071 DO 320 i = 1, j
1072 work( indx ) = a( i, j )
1073 indx = indx + 1
1074 320 CONTINUE
1075 330 CONTINUE
1076 ELSE
1077 indx = 1
1078 DO 350 j = 1, n
1079 DO 340 i = j, n
1080 work( indx ) = a( i, j )
1081 indx = indx + 1
1082 340 CONTINUE
1083 350 CONTINUE
1084 END IF
1085*
1086 CALL zhpevx( 'N', 'A', uplo, n, work, vl, vu, il, iu,
1087 $ abstol, m2, wa2, z, ldu, v, rwork, iwork,
1088 $ iwork( 5*n+1 ), iinfo )
1089 IF( iinfo.NE.0 ) THEN
1090 WRITE( nounit, fmt = 9999 )'ZHPEVX(N,A,' // uplo //
1091 $ ')', iinfo, n, jtype, ioldsd
1092 info = abs( iinfo )
1093 IF( iinfo.LT.0 ) THEN
1094 RETURN
1095 ELSE
1096 result( ntest ) = ulpinv
1097 GO TO 370
1098 END IF
1099 END IF
1100*
1101* Do test 18.
1102*
1103 temp1 = zero
1104 temp2 = zero
1105 DO 360 j = 1, n
1106 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1107 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1108 360 CONTINUE
1109 result( ntest ) = temp2 / max( unfl,
1110 $ ulp*max( temp1, temp2 ) )
1111*
1112 370 CONTINUE
1113 ntest = ntest + 1
1114 IF( iuplo.EQ.1 ) THEN
1115 indx = 1
1116 DO 390 j = 1, n
1117 DO 380 i = 1, j
1118 work( indx ) = a( i, j )
1119 indx = indx + 1
1120 380 CONTINUE
1121 390 CONTINUE
1122 ELSE
1123 indx = 1
1124 DO 410 j = 1, n
1125 DO 400 i = j, n
1126 work( indx ) = a( i, j )
1127 indx = indx + 1
1128 400 CONTINUE
1129 410 CONTINUE
1130 END IF
1131*
1132 CALL zhpevx( 'V', 'I', uplo, n, work, vl, vu, il, iu,
1133 $ abstol, m2, wa2, z, ldu, v, rwork, iwork,
1134 $ iwork( 5*n+1 ), iinfo )
1135 IF( iinfo.NE.0 ) THEN
1136 WRITE( nounit, fmt = 9999 )'ZHPEVX(V,I,' // uplo //
1137 $ ')', iinfo, n, jtype, ioldsd
1138 info = abs( iinfo )
1139 IF( iinfo.LT.0 ) THEN
1140 RETURN
1141 ELSE
1142 result( ntest ) = ulpinv
1143 result( ntest+1 ) = ulpinv
1144 result( ntest+2 ) = ulpinv
1145 GO TO 460
1146 END IF
1147 END IF
1148*
1149* Do tests 19 and 20.
1150*
1151 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1152 $ v, ldu, tau, work, rwork, result( ntest ) )
1153*
1154 ntest = ntest + 2
1155*
1156 IF( iuplo.EQ.1 ) THEN
1157 indx = 1
1158 DO 430 j = 1, n
1159 DO 420 i = 1, j
1160 work( indx ) = a( i, j )
1161 indx = indx + 1
1162 420 CONTINUE
1163 430 CONTINUE
1164 ELSE
1165 indx = 1
1166 DO 450 j = 1, n
1167 DO 440 i = j, n
1168 work( indx ) = a( i, j )
1169 indx = indx + 1
1170 440 CONTINUE
1171 450 CONTINUE
1172 END IF
1173*
1174 CALL zhpevx( 'N', 'I', uplo, n, work, vl, vu, il, iu,
1175 $ abstol, m3, wa3, z, ldu, v, rwork, iwork,
1176 $ iwork( 5*n+1 ), iinfo )
1177 IF( iinfo.NE.0 ) THEN
1178 WRITE( nounit, fmt = 9999 )'ZHPEVX(N,I,' // uplo //
1179 $ ')', iinfo, n, jtype, ioldsd
1180 info = abs( iinfo )
1181 IF( iinfo.LT.0 ) THEN
1182 RETURN
1183 ELSE
1184 result( ntest ) = ulpinv
1185 GO TO 460
1186 END IF
1187 END IF
1188*
1189* Do test 21.
1190*
1191 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1192 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1193 IF( n.GT.0 ) THEN
1194 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1195 ELSE
1196 temp3 = zero
1197 END IF
1198 result( ntest ) = ( temp1+temp2 ) /
1199 $ max( unfl, temp3*ulp )
1200*
1201 460 CONTINUE
1202 ntest = ntest + 1
1203 IF( iuplo.EQ.1 ) THEN
1204 indx = 1
1205 DO 480 j = 1, n
1206 DO 470 i = 1, j
1207 work( indx ) = a( i, j )
1208 indx = indx + 1
1209 470 CONTINUE
1210 480 CONTINUE
1211 ELSE
1212 indx = 1
1213 DO 500 j = 1, n
1214 DO 490 i = j, n
1215 work( indx ) = a( i, j )
1216 indx = indx + 1
1217 490 CONTINUE
1218 500 CONTINUE
1219 END IF
1220*
1221 CALL zhpevx( 'V', 'V', uplo, n, work, vl, vu, il, iu,
1222 $ abstol, m2, wa2, z, ldu, v, rwork, iwork,
1223 $ iwork( 5*n+1 ), iinfo )
1224 IF( iinfo.NE.0 ) THEN
1225 WRITE( nounit, fmt = 9999 )'ZHPEVX(V,V,' // uplo //
1226 $ ')', iinfo, n, jtype, ioldsd
1227 info = abs( iinfo )
1228 IF( iinfo.LT.0 ) THEN
1229 RETURN
1230 ELSE
1231 result( ntest ) = ulpinv
1232 result( ntest+1 ) = ulpinv
1233 result( ntest+2 ) = ulpinv
1234 GO TO 550
1235 END IF
1236 END IF
1237*
1238* Do tests 22 and 23.
1239*
1240 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1241 $ v, ldu, tau, work, rwork, result( ntest ) )
1242*
1243 ntest = ntest + 2
1244*
1245 IF( iuplo.EQ.1 ) THEN
1246 indx = 1
1247 DO 520 j = 1, n
1248 DO 510 i = 1, j
1249 work( indx ) = a( i, j )
1250 indx = indx + 1
1251 510 CONTINUE
1252 520 CONTINUE
1253 ELSE
1254 indx = 1
1255 DO 540 j = 1, n
1256 DO 530 i = j, n
1257 work( indx ) = a( i, j )
1258 indx = indx + 1
1259 530 CONTINUE
1260 540 CONTINUE
1261 END IF
1262*
1263 CALL zhpevx( 'N', 'V', uplo, n, work, vl, vu, il, iu,
1264 $ abstol, m3, wa3, z, ldu, v, rwork, iwork,
1265 $ iwork( 5*n+1 ), iinfo )
1266 IF( iinfo.NE.0 ) THEN
1267 WRITE( nounit, fmt = 9999 )'ZHPEVX(N,V,' // uplo //
1268 $ ')', iinfo, n, jtype, ioldsd
1269 info = abs( iinfo )
1270 IF( iinfo.LT.0 ) THEN
1271 RETURN
1272 ELSE
1273 result( ntest ) = ulpinv
1274 GO TO 550
1275 END IF
1276 END IF
1277*
1278 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1279 result( ntest ) = ulpinv
1280 GO TO 550
1281 END IF
1282*
1283* Do test 24.
1284*
1285 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1286 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1287 IF( n.GT.0 ) THEN
1288 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1289 ELSE
1290 temp3 = zero
1291 END IF
1292 result( ntest ) = ( temp1+temp2 ) /
1293 $ max( unfl, temp3*ulp )
1294*
1295 550 CONTINUE
1296*
1297* Call ZHBEVD and CHBEVX.
1298*
1299 IF( jtype.LE.7 ) THEN
1300 kd = 0
1301 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
1302 kd = max( n-1, 0 )
1303 ELSE
1304 kd = ihbw
1305 END IF
1306*
1307* Load array V with the upper or lower triangular part
1308* of the matrix in band form.
1309*
1310 IF( iuplo.EQ.1 ) THEN
1311 DO 570 j = 1, n
1312 DO 560 i = max( 1, j-kd ), j
1313 v( kd+1+i-j, j ) = a( i, j )
1314 560 CONTINUE
1315 570 CONTINUE
1316 ELSE
1317 DO 590 j = 1, n
1318 DO 580 i = j, min( n, j+kd )
1319 v( 1+i-j, j ) = a( i, j )
1320 580 CONTINUE
1321 590 CONTINUE
1322 END IF
1323*
1324 ntest = ntest + 1
1325 CALL zhbevd( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
1326 $ lwedc, rwork, lrwedc, iwork, liwedc, iinfo )
1327 IF( iinfo.NE.0 ) THEN
1328 WRITE( nounit, fmt = 9998 )'ZHBEVD(V,' // uplo //
1329 $ ')', iinfo, n, kd, jtype, ioldsd
1330 info = abs( iinfo )
1331 IF( iinfo.LT.0 ) THEN
1332 RETURN
1333 ELSE
1334 result( ntest ) = ulpinv
1335 result( ntest+1 ) = ulpinv
1336 result( ntest+2 ) = ulpinv
1337 GO TO 650
1338 END IF
1339 END IF
1340*
1341* Do tests 25 and 26.
1342*
1343 CALL zhet21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
1344 $ ldu, tau, work, rwork, result( ntest ) )
1345*
1346 IF( iuplo.EQ.1 ) THEN
1347 DO 610 j = 1, n
1348 DO 600 i = max( 1, j-kd ), j
1349 v( kd+1+i-j, j ) = a( i, j )
1350 600 CONTINUE
1351 610 CONTINUE
1352 ELSE
1353 DO 630 j = 1, n
1354 DO 620 i = j, min( n, j+kd )
1355 v( 1+i-j, j ) = a( i, j )
1356 620 CONTINUE
1357 630 CONTINUE
1358 END IF
1359*
1360 ntest = ntest + 2
1361 CALL zhbevd( 'N', uplo, n, kd, v, ldu, d3, z, ldu, work,
1362 $ lwedc, rwork, lrwedc, iwork, liwedc, iinfo )
1363 IF( iinfo.NE.0 ) THEN
1364 WRITE( nounit, fmt = 9998 )'ZHBEVD(N,' // uplo //
1365 $ ')', iinfo, n, kd, jtype, ioldsd
1366 info = abs( iinfo )
1367 IF( iinfo.LT.0 ) THEN
1368 RETURN
1369 ELSE
1370 result( ntest ) = ulpinv
1371 GO TO 650
1372 END IF
1373 END IF
1374*
1375* Do test 27.
1376*
1377 temp1 = zero
1378 temp2 = zero
1379 DO 640 j = 1, n
1380 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1381 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1382 640 CONTINUE
1383 result( ntest ) = temp2 / max( unfl,
1384 $ ulp*max( temp1, temp2 ) )
1385*
1386* Load array V with the upper or lower triangular part
1387* of the matrix in band form.
1388*
1389 650 CONTINUE
1390 IF( iuplo.EQ.1 ) THEN
1391 DO 670 j = 1, n
1392 DO 660 i = max( 1, j-kd ), j
1393 v( kd+1+i-j, j ) = a( i, j )
1394 660 CONTINUE
1395 670 CONTINUE
1396 ELSE
1397 DO 690 j = 1, n
1398 DO 680 i = j, min( n, j+kd )
1399 v( 1+i-j, j ) = a( i, j )
1400 680 CONTINUE
1401 690 CONTINUE
1402 END IF
1403*
1404 ntest = ntest + 1
1405 CALL zhbevx( 'V', 'A', uplo, n, kd, v, ldu, u, ldu, vl,
1406 $ vu, il, iu, abstol, m, wa1, z, ldu, work,
1407 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1408 IF( iinfo.NE.0 ) THEN
1409 WRITE( nounit, fmt = 9999 )'ZHBEVX(V,A,' // uplo //
1410 $ ')', iinfo, n, kd, jtype, ioldsd
1411 info = abs( iinfo )
1412 IF( iinfo.LT.0 ) THEN
1413 RETURN
1414 ELSE
1415 result( ntest ) = ulpinv
1416 result( ntest+1 ) = ulpinv
1417 result( ntest+2 ) = ulpinv
1418 GO TO 750
1419 END IF
1420 END IF
1421*
1422* Do tests 28 and 29.
1423*
1424 CALL zhet21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
1425 $ ldu, tau, work, rwork, result( ntest ) )
1426*
1427 ntest = ntest + 2
1428*
1429 IF( iuplo.EQ.1 ) THEN
1430 DO 710 j = 1, n
1431 DO 700 i = max( 1, j-kd ), j
1432 v( kd+1+i-j, j ) = a( i, j )
1433 700 CONTINUE
1434 710 CONTINUE
1435 ELSE
1436 DO 730 j = 1, n
1437 DO 720 i = j, min( n, j+kd )
1438 v( 1+i-j, j ) = a( i, j )
1439 720 CONTINUE
1440 730 CONTINUE
1441 END IF
1442*
1443 CALL zhbevx( 'N', 'A', uplo, n, kd, v, ldu, u, ldu, vl,
1444 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
1445 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1446 IF( iinfo.NE.0 ) THEN
1447 WRITE( nounit, fmt = 9998 )'ZHBEVX(N,A,' // uplo //
1448 $ ')', iinfo, n, kd, jtype, ioldsd
1449 info = abs( iinfo )
1450 IF( iinfo.LT.0 ) THEN
1451 RETURN
1452 ELSE
1453 result( ntest ) = ulpinv
1454 GO TO 750
1455 END IF
1456 END IF
1457*
1458* Do test 30.
1459*
1460 temp1 = zero
1461 temp2 = zero
1462 DO 740 j = 1, n
1463 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1464 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1465 740 CONTINUE
1466 result( ntest ) = temp2 / max( unfl,
1467 $ ulp*max( temp1, temp2 ) )
1468*
1469* Load array V with the upper or lower triangular part
1470* of the matrix in band form.
1471*
1472 750 CONTINUE
1473 ntest = ntest + 1
1474 IF( iuplo.EQ.1 ) THEN
1475 DO 770 j = 1, n
1476 DO 760 i = max( 1, j-kd ), j
1477 v( kd+1+i-j, j ) = a( i, j )
1478 760 CONTINUE
1479 770 CONTINUE
1480 ELSE
1481 DO 790 j = 1, n
1482 DO 780 i = j, min( n, j+kd )
1483 v( 1+i-j, j ) = a( i, j )
1484 780 CONTINUE
1485 790 CONTINUE
1486 END IF
1487*
1488 CALL zhbevx( 'V', 'I', uplo, n, kd, v, ldu, u, ldu, vl,
1489 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
1490 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1491 IF( iinfo.NE.0 ) THEN
1492 WRITE( nounit, fmt = 9998 )'ZHBEVX(V,I,' // uplo //
1493 $ ')', iinfo, n, kd, jtype, ioldsd
1494 info = abs( iinfo )
1495 IF( iinfo.LT.0 ) THEN
1496 RETURN
1497 ELSE
1498 result( ntest ) = ulpinv
1499 result( ntest+1 ) = ulpinv
1500 result( ntest+2 ) = ulpinv
1501 GO TO 840
1502 END IF
1503 END IF
1504*
1505* Do tests 31 and 32.
1506*
1507 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1508 $ v, ldu, tau, work, rwork, result( ntest ) )
1509*
1510 ntest = ntest + 2
1511*
1512 IF( iuplo.EQ.1 ) THEN
1513 DO 810 j = 1, n
1514 DO 800 i = max( 1, j-kd ), j
1515 v( kd+1+i-j, j ) = a( i, j )
1516 800 CONTINUE
1517 810 CONTINUE
1518 ELSE
1519 DO 830 j = 1, n
1520 DO 820 i = j, min( n, j+kd )
1521 v( 1+i-j, j ) = a( i, j )
1522 820 CONTINUE
1523 830 CONTINUE
1524 END IF
1525 CALL zhbevx( 'N', 'I', uplo, n, kd, v, ldu, u, ldu, vl,
1526 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
1527 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1528 IF( iinfo.NE.0 ) THEN
1529 WRITE( nounit, fmt = 9998 )'ZHBEVX(N,I,' // uplo //
1530 $ ')', iinfo, n, kd, jtype, ioldsd
1531 info = abs( iinfo )
1532 IF( iinfo.LT.0 ) THEN
1533 RETURN
1534 ELSE
1535 result( ntest ) = ulpinv
1536 GO TO 840
1537 END IF
1538 END IF
1539*
1540* Do test 33.
1541*
1542 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1543 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1544 IF( n.GT.0 ) THEN
1545 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1546 ELSE
1547 temp3 = zero
1548 END IF
1549 result( ntest ) = ( temp1+temp2 ) /
1550 $ max( unfl, temp3*ulp )
1551*
1552* Load array V with the upper or lower triangular part
1553* of the matrix in band form.
1554*
1555 840 CONTINUE
1556 ntest = ntest + 1
1557 IF( iuplo.EQ.1 ) THEN
1558 DO 860 j = 1, n
1559 DO 850 i = max( 1, j-kd ), j
1560 v( kd+1+i-j, j ) = a( i, j )
1561 850 CONTINUE
1562 860 CONTINUE
1563 ELSE
1564 DO 880 j = 1, n
1565 DO 870 i = j, min( n, j+kd )
1566 v( 1+i-j, j ) = a( i, j )
1567 870 CONTINUE
1568 880 CONTINUE
1569 END IF
1570 CALL zhbevx( 'V', 'V', uplo, n, kd, v, ldu, u, ldu, vl,
1571 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
1572 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1573 IF( iinfo.NE.0 ) THEN
1574 WRITE( nounit, fmt = 9998 )'ZHBEVX(V,V,' // uplo //
1575 $ ')', iinfo, n, kd, jtype, ioldsd
1576 info = abs( iinfo )
1577 IF( iinfo.LT.0 ) THEN
1578 RETURN
1579 ELSE
1580 result( ntest ) = ulpinv
1581 result( ntest+1 ) = ulpinv
1582 result( ntest+2 ) = ulpinv
1583 GO TO 930
1584 END IF
1585 END IF
1586*
1587* Do tests 34 and 35.
1588*
1589 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1590 $ v, ldu, tau, work, rwork, result( ntest ) )
1591*
1592 ntest = ntest + 2
1593*
1594 IF( iuplo.EQ.1 ) THEN
1595 DO 900 j = 1, n
1596 DO 890 i = max( 1, j-kd ), j
1597 v( kd+1+i-j, j ) = a( i, j )
1598 890 CONTINUE
1599 900 CONTINUE
1600 ELSE
1601 DO 920 j = 1, n
1602 DO 910 i = j, min( n, j+kd )
1603 v( 1+i-j, j ) = a( i, j )
1604 910 CONTINUE
1605 920 CONTINUE
1606 END IF
1607 CALL zhbevx( 'N', 'V', uplo, n, kd, v, ldu, u, ldu, vl,
1608 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
1609 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1610 IF( iinfo.NE.0 ) THEN
1611 WRITE( nounit, fmt = 9998 )'ZHBEVX(N,V,' // uplo //
1612 $ ')', iinfo, n, kd, jtype, ioldsd
1613 info = abs( iinfo )
1614 IF( iinfo.LT.0 ) THEN
1615 RETURN
1616 ELSE
1617 result( ntest ) = ulpinv
1618 GO TO 930
1619 END IF
1620 END IF
1621*
1622 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1623 result( ntest ) = ulpinv
1624 GO TO 930
1625 END IF
1626*
1627* Do test 36.
1628*
1629 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1630 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1631 IF( n.GT.0 ) THEN
1632 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1633 ELSE
1634 temp3 = zero
1635 END IF
1636 result( ntest ) = ( temp1+temp2 ) /
1637 $ max( unfl, temp3*ulp )
1638*
1639 930 CONTINUE
1640*
1641* Call ZHEEV
1642*
1643 CALL zlacpy( ' ', n, n, a, lda, v, ldu )
1644*
1645 ntest = ntest + 1
1646 CALL zheev( 'V', uplo, n, a, ldu, d1, work, lwork, rwork,
1647 $ iinfo )
1648 IF( iinfo.NE.0 ) THEN
1649 WRITE( nounit, fmt = 9999 )'ZHEEV(V,' // uplo // ')',
1650 $ iinfo, n, jtype, ioldsd
1651 info = abs( iinfo )
1652 IF( iinfo.LT.0 ) THEN
1653 RETURN
1654 ELSE
1655 result( ntest ) = ulpinv
1656 result( ntest+1 ) = ulpinv
1657 result( ntest+2 ) = ulpinv
1658 GO TO 950
1659 END IF
1660 END IF
1661*
1662* Do tests 37 and 38
1663*
1664 CALL zhet21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
1665 $ ldu, tau, work, rwork, result( ntest ) )
1666*
1667 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1668*
1669 ntest = ntest + 2
1670 CALL zheev( 'N', uplo, n, a, ldu, d3, work, lwork, rwork,
1671 $ iinfo )
1672 IF( iinfo.NE.0 ) THEN
1673 WRITE( nounit, fmt = 9999 )'ZHEEV(N,' // uplo // ')',
1674 $ iinfo, n, jtype, ioldsd
1675 info = abs( iinfo )
1676 IF( iinfo.LT.0 ) THEN
1677 RETURN
1678 ELSE
1679 result( ntest ) = ulpinv
1680 GO TO 950
1681 END IF
1682 END IF
1683*
1684* Do test 39
1685*
1686 temp1 = zero
1687 temp2 = zero
1688 DO 940 j = 1, n
1689 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1690 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1691 940 CONTINUE
1692 result( ntest ) = temp2 / max( unfl,
1693 $ ulp*max( temp1, temp2 ) )
1694*
1695 950 CONTINUE
1696*
1697 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1698*
1699* Call ZHPEV
1700*
1701* Load array WORK with the upper or lower triangular
1702* part of the matrix in packed form.
1703*
1704 IF( iuplo.EQ.1 ) THEN
1705 indx = 1
1706 DO 970 j = 1, n
1707 DO 960 i = 1, j
1708 work( indx ) = a( i, j )
1709 indx = indx + 1
1710 960 CONTINUE
1711 970 CONTINUE
1712 ELSE
1713 indx = 1
1714 DO 990 j = 1, n
1715 DO 980 i = j, n
1716 work( indx ) = a( i, j )
1717 indx = indx + 1
1718 980 CONTINUE
1719 990 CONTINUE
1720 END IF
1721*
1722 ntest = ntest + 1
1723 indwrk = n*( n+1 ) / 2 + 1
1724 CALL zhpev( 'V', uplo, n, work, d1, z, ldu,
1725 $ work( indwrk ), rwork, iinfo )
1726 IF( iinfo.NE.0 ) THEN
1727 WRITE( nounit, fmt = 9999 )'ZHPEV(V,' // uplo // ')',
1728 $ iinfo, n, jtype, ioldsd
1729 info = abs( iinfo )
1730 IF( iinfo.LT.0 ) THEN
1731 RETURN
1732 ELSE
1733 result( ntest ) = ulpinv
1734 result( ntest+1 ) = ulpinv
1735 result( ntest+2 ) = ulpinv
1736 GO TO 1050
1737 END IF
1738 END IF
1739*
1740* Do tests 40 and 41.
1741*
1742 CALL zhet21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
1743 $ ldu, tau, work, rwork, result( ntest ) )
1744*
1745 IF( iuplo.EQ.1 ) THEN
1746 indx = 1
1747 DO 1010 j = 1, n
1748 DO 1000 i = 1, j
1749 work( indx ) = a( i, j )
1750 indx = indx + 1
1751 1000 CONTINUE
1752 1010 CONTINUE
1753 ELSE
1754 indx = 1
1755 DO 1030 j = 1, n
1756 DO 1020 i = j, n
1757 work( indx ) = a( i, j )
1758 indx = indx + 1
1759 1020 CONTINUE
1760 1030 CONTINUE
1761 END IF
1762*
1763 ntest = ntest + 2
1764 indwrk = n*( n+1 ) / 2 + 1
1765 CALL zhpev( 'N', uplo, n, work, d3, z, ldu,
1766 $ work( indwrk ), rwork, iinfo )
1767 IF( iinfo.NE.0 ) THEN
1768 WRITE( nounit, fmt = 9999 )'ZHPEV(N,' // uplo // ')',
1769 $ iinfo, n, jtype, ioldsd
1770 info = abs( iinfo )
1771 IF( iinfo.LT.0 ) THEN
1772 RETURN
1773 ELSE
1774 result( ntest ) = ulpinv
1775 GO TO 1050
1776 END IF
1777 END IF
1778*
1779* Do test 42
1780*
1781 temp1 = zero
1782 temp2 = zero
1783 DO 1040 j = 1, n
1784 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1785 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1786 1040 CONTINUE
1787 result( ntest ) = temp2 / max( unfl,
1788 $ ulp*max( temp1, temp2 ) )
1789*
1790 1050 CONTINUE
1791*
1792* Call ZHBEV
1793*
1794 IF( jtype.LE.7 ) THEN
1795 kd = 0
1796 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
1797 kd = max( n-1, 0 )
1798 ELSE
1799 kd = ihbw
1800 END IF
1801*
1802* Load array V with the upper or lower triangular part
1803* of the matrix in band form.
1804*
1805 IF( iuplo.EQ.1 ) THEN
1806 DO 1070 j = 1, n
1807 DO 1060 i = max( 1, j-kd ), j
1808 v( kd+1+i-j, j ) = a( i, j )
1809 1060 CONTINUE
1810 1070 CONTINUE
1811 ELSE
1812 DO 1090 j = 1, n
1813 DO 1080 i = j, min( n, j+kd )
1814 v( 1+i-j, j ) = a( i, j )
1815 1080 CONTINUE
1816 1090 CONTINUE
1817 END IF
1818*
1819 ntest = ntest + 1
1820 CALL zhbev( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
1821 $ rwork, iinfo )
1822 IF( iinfo.NE.0 ) THEN
1823 WRITE( nounit, fmt = 9998 )'ZHBEV(V,' // uplo // ')',
1824 $ iinfo, n, kd, jtype, ioldsd
1825 info = abs( iinfo )
1826 IF( iinfo.LT.0 ) THEN
1827 RETURN
1828 ELSE
1829 result( ntest ) = ulpinv
1830 result( ntest+1 ) = ulpinv
1831 result( ntest+2 ) = ulpinv
1832 GO TO 1140
1833 END IF
1834 END IF
1835*
1836* Do tests 43 and 44.
1837*
1838 CALL zhet21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
1839 $ ldu, tau, work, rwork, result( ntest ) )
1840*
1841 IF( iuplo.EQ.1 ) THEN
1842 DO 1110 j = 1, n
1843 DO 1100 i = max( 1, j-kd ), j
1844 v( kd+1+i-j, j ) = a( i, j )
1845 1100 CONTINUE
1846 1110 CONTINUE
1847 ELSE
1848 DO 1130 j = 1, n
1849 DO 1120 i = j, min( n, j+kd )
1850 v( 1+i-j, j ) = a( i, j )
1851 1120 CONTINUE
1852 1130 CONTINUE
1853 END IF
1854*
1855 ntest = ntest + 2
1856 CALL zhbev( 'N', uplo, n, kd, v, ldu, d3, z, ldu, work,
1857 $ rwork, iinfo )
1858 IF( iinfo.NE.0 ) THEN
1859 WRITE( nounit, fmt = 9998 )'ZHBEV(N,' // uplo // ')',
1860 $ iinfo, n, kd, jtype, ioldsd
1861 info = abs( iinfo )
1862 IF( iinfo.LT.0 ) THEN
1863 RETURN
1864 ELSE
1865 result( ntest ) = ulpinv
1866 GO TO 1140
1867 END IF
1868 END IF
1869*
1870 1140 CONTINUE
1871*
1872* Do test 45.
1873*
1874 temp1 = zero
1875 temp2 = zero
1876 DO 1150 j = 1, n
1877 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1878 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1879 1150 CONTINUE
1880 result( ntest ) = temp2 / max( unfl,
1881 $ ulp*max( temp1, temp2 ) )
1882*
1883 CALL zlacpy( ' ', n, n, a, lda, v, ldu )
1884 ntest = ntest + 1
1885 CALL zheevr( 'V', 'A', uplo, n, a, ldu, vl, vu, il, iu,
1886 $ abstol, m, wa1, z, ldu, iwork, work, lwork,
1887 $ rwork, lrwork, iwork( 2*n+1 ), liwork-2*n,
1888 $ iinfo )
1889 IF( iinfo.NE.0 ) THEN
1890 WRITE( nounit, fmt = 9999 )'ZHEEVR(V,A,' // uplo //
1891 $ ')', iinfo, n, jtype, ioldsd
1892 info = abs( iinfo )
1893 IF( iinfo.LT.0 ) THEN
1894 RETURN
1895 ELSE
1896 result( ntest ) = ulpinv
1897 result( ntest+1 ) = ulpinv
1898 result( ntest+2 ) = ulpinv
1899 GO TO 1170
1900 END IF
1901 END IF
1902*
1903* Do tests 45 and 46 (or ... )
1904*
1905 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1906*
1907 CALL zhet21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
1908 $ ldu, tau, work, rwork, result( ntest ) )
1909*
1910 ntest = ntest + 2
1911 CALL zheevr( 'N', 'A', uplo, n, a, ldu, vl, vu, il, iu,
1912 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
1913 $ rwork, lrwork, iwork( 2*n+1 ), liwork-2*n,
1914 $ iinfo )
1915 IF( iinfo.NE.0 ) THEN
1916 WRITE( nounit, fmt = 9999 )'ZHEEVR(N,A,' // uplo //
1917 $ ')', iinfo, n, jtype, ioldsd
1918 info = abs( iinfo )
1919 IF( iinfo.LT.0 ) THEN
1920 RETURN
1921 ELSE
1922 result( ntest ) = ulpinv
1923 GO TO 1170
1924 END IF
1925 END IF
1926*
1927* Do test 47 (or ... )
1928*
1929 temp1 = zero
1930 temp2 = zero
1931 DO 1160 j = 1, n
1932 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1933 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1934 1160 CONTINUE
1935 result( ntest ) = temp2 / max( unfl,
1936 $ ulp*max( temp1, temp2 ) )
1937*
1938 1170 CONTINUE
1939*
1940 ntest = ntest + 1
1941 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1942 CALL zheevr( 'V', 'I', uplo, n, a, ldu, vl, vu, il, iu,
1943 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
1944 $ rwork, lrwork, iwork( 2*n+1 ), liwork-2*n,
1945 $ iinfo )
1946 IF( iinfo.NE.0 ) THEN
1947 WRITE( nounit, fmt = 9999 )'ZHEEVR(V,I,' // uplo //
1948 $ ')', iinfo, n, jtype, ioldsd
1949 info = abs( iinfo )
1950 IF( iinfo.LT.0 ) THEN
1951 RETURN
1952 ELSE
1953 result( ntest ) = ulpinv
1954 result( ntest+1 ) = ulpinv
1955 result( ntest+2 ) = ulpinv
1956 GO TO 1180
1957 END IF
1958 END IF
1959*
1960* Do tests 48 and 49 (or +??)
1961*
1962 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1963*
1964 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1965 $ v, ldu, tau, work, rwork, result( ntest ) )
1966*
1967 ntest = ntest + 2
1968 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1969 CALL zheevr( 'N', 'I', uplo, n, a, ldu, vl, vu, il, iu,
1970 $ abstol, m3, wa3, z, ldu, iwork, work, lwork,
1971 $ rwork, lrwork, iwork( 2*n+1 ), liwork-2*n,
1972 $ iinfo )
1973 IF( iinfo.NE.0 ) THEN
1974 WRITE( nounit, fmt = 9999 )'ZHEEVR(N,I,' // uplo //
1975 $ ')', iinfo, n, jtype, ioldsd
1976 info = abs( iinfo )
1977 IF( iinfo.LT.0 ) THEN
1978 RETURN
1979 ELSE
1980 result( ntest ) = ulpinv
1981 GO TO 1180
1982 END IF
1983 END IF
1984*
1985* Do test 50 (or +??)
1986*
1987 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1988 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1989 result( ntest ) = ( temp1+temp2 ) /
1990 $ max( unfl, ulp*temp3 )
1991 1180 CONTINUE
1992*
1993 ntest = ntest + 1
1994 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1995 CALL zheevr( 'V', 'V', uplo, n, a, ldu, vl, vu, il, iu,
1996 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
1997 $ rwork, lrwork, iwork( 2*n+1 ), liwork-2*n,
1998 $ iinfo )
1999 IF( iinfo.NE.0 ) THEN
2000 WRITE( nounit, fmt = 9999 )'ZHEEVR(V,V,' // uplo //
2001 $ ')', iinfo, n, jtype, ioldsd
2002 info = abs( iinfo )
2003 IF( iinfo.LT.0 ) THEN
2004 RETURN
2005 ELSE
2006 result( ntest ) = ulpinv
2007 result( ntest+1 ) = ulpinv
2008 result( ntest+2 ) = ulpinv
2009 GO TO 1190
2010 END IF
2011 END IF
2012*
2013* Do tests 51 and 52 (or +??)
2014*
2015 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
2016*
2017 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2018 $ v, ldu, tau, work, rwork, result( ntest ) )
2019*
2020 ntest = ntest + 2
2021 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
2022 CALL zheevr( 'N', 'V', uplo, n, a, ldu, vl, vu, il, iu,
2023 $ abstol, m3, wa3, z, ldu, iwork, work, lwork,
2024 $ rwork, lrwork, iwork( 2*n+1 ), liwork-2*n,
2025 $ iinfo )
2026 IF( iinfo.NE.0 ) THEN
2027 WRITE( nounit, fmt = 9999 )'ZHEEVR(N,V,' // uplo //
2028 $ ')', iinfo, n, jtype, ioldsd
2029 info = abs( iinfo )
2030 IF( iinfo.LT.0 ) THEN
2031 RETURN
2032 ELSE
2033 result( ntest ) = ulpinv
2034 GO TO 1190
2035 END IF
2036 END IF
2037*
2038 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2039 result( ntest ) = ulpinv
2040 GO TO 1190
2041 END IF
2042*
2043* Do test 52 (or +??)
2044*
2045 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2046 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2047 IF( n.GT.0 ) THEN
2048 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2049 ELSE
2050 temp3 = zero
2051 END IF
2052 result( ntest ) = ( temp1+temp2 ) /
2053 $ max( unfl, temp3*ulp )
2054*
2055 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
2056*
2057*
2058*
2059*
2060* Load array V with the upper or lower triangular part
2061* of the matrix in band form.
2062*
2063 1190 CONTINUE
2064*
2065 1200 CONTINUE
2066*
2067* End of Loop -- Check for RESULT(j) > THRESH
2068*
2069 ntestt = ntestt + ntest
2070 CALL dlafts( 'ZST', n, n, jtype, ntest, result, ioldsd,
2071 $ thresh, nounit, nerrs )
2072*
2073 1210 CONTINUE
2074 1220 CONTINUE
2075*
2076* Summary
2077*
2078 CALL alasvm( 'ZST', nounit, nerrs, ntestt, 0 )
2079*
2080 9999 FORMAT( ' ZDRVST: ', a, ' returned INFO=', i6, / 9x, 'N=', i6,
2081 $ ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2082 9998 FORMAT( ' ZDRVST: ', a, ' returned INFO=', i6, / 9x, 'N=', i6,
2083 $ ', KD=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5,
2084 $ ')' )
2085*
2086 RETURN
2087*
2088* End of ZDRVST
2089*
zheevr
subroutine zheevr(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHEEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
Definition zheevr.f:357
zheevx
subroutine zheevx(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, rwork, iwork, ifail, info)
ZHEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
Definition zheevx.f:259
zheev
subroutine zheev(jobz, uplo, n, a, lda, w, work, lwork, rwork, info)
ZHEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
Definition zheev.f:140
zheevd
subroutine zheevd(jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHEEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
Definition zheevd.f:205
zhpevd
subroutine zhpevd(jobz, uplo, n, ap, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition zhpevd.f:200
zhbev
subroutine zhbev(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, rwork, info)
ZHBEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition zhbev.f:152
zhbevd
subroutine zhbevd(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHBEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition zhbevd.f:215
zhpevx
subroutine zhpevx(jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m, w, z, ldz, work, rwork, iwork, ifail, info)
ZHPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition zhpevx.f:240
zhbevx
subroutine zhbevx(jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, ldz, work, rwork, iwork, ifail, info)
ZHBEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition zhbevx.f:267
zhpev
subroutine zhpev(jobz, uplo, n, ap, w, z, ldz, work, rwork, info)
ZHPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition zhpev.f:138
zhet22
subroutine zhet22(itype, uplo, n, m, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
ZHET22
Definition zhet22.f:161

◆ zdrvst2stg()

subroutine zdrvst2stg ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d1,
double precision, dimension( * ) d2,
double precision, dimension( * ) d3,
double precision, dimension( * ) wa1,
double precision, dimension( * ) wa2,
double precision, dimension( * ) wa3,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldu, * ) v,
complex*16, dimension( * ) tau,
complex*16, dimension( ldu, * ) z,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer lrwork,
integer, dimension( * ) iwork,
integer liwork,
double precision, dimension( * ) result,
integer info )

ZDRVST2STG

Purpose:
!>
!>      ZDRVST2STG  checks the Hermitian eigenvalue problem drivers.
!>
!>              ZHEEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix,
!>              using a divide-and-conquer algorithm.
!>
!>              ZHEEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix.
!>
!>              ZHEEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              ZHPEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage, using a divide-and-conquer algorithm.
!>
!>              ZHPEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage.
!>
!>              ZHBEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix,
!>              using a divide-and-conquer algorithm.
!>
!>              ZHBEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix.
!>
!>              ZHEEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix.
!>
!>              ZHPEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage.
!>
!>              ZHBEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix.
!>
!>      When ZDRVST2STG is called, a number of matrix  () and a
!>      number of matrix  are specified.  For each size ()
!>      and each type of matrix, one matrix will be generated and used
!>      to test the appropriate drivers.  For each matrix and each
!>      driver routine called, the following tests will be performed:
!>
!>      (1)     | A - Z D Z' | / ( |A| n ulp )
!>
!>      (2)     | I - Z Z' | / ( n ulp )
!>
!>      (3)     | D1 - D2 | / ( |D1| ulp )
!>
!>      where Z is the matrix of eigenvectors returned when the
!>      eigenvector option is given and D1 and D2 are the eigenvalues
!>      returned with and without the eigenvector option.
!>
!>      The  are specified by an array NN(1:NSIZES); the value of
!>      each element NN(j) specifies one size.
!>      The  are specified by a logical array DOTYPE( 1:NTYPES );
!>      if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!>      Currently, the list of possible types is:
!>
!>      (1)  The zero matrix.
!>      (2)  The identity matrix.
!>
!>      (3)  A diagonal matrix with evenly spaced entries
!>           1, ..., ULP  and random signs.
!>           (ULP = (first number larger than 1) - 1 )
!>      (4)  A diagonal matrix with geometrically spaced entries
!>           1, ..., ULP  and random signs.
!>      (5)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>           and random signs.
!>
!>      (6)  Same as (4), but multiplied by SQRT( overflow threshold )
!>      (7)  Same as (4), but multiplied by SQRT( underflow threshold )
!>
!>      (8)  A matrix of the form  U* D U, where U is unitary and
!>           D has evenly spaced entries 1, ..., ULP with random signs
!>           on the diagonal.
!>
!>      (9)  A matrix of the form  U* D U, where U is unitary and
!>           D has geometrically spaced entries 1, ..., ULP with random
!>           signs on the diagonal.
!>
!>      (10) A matrix of the form  U* D U, where U is unitary and
!>           D has  entries 1, ULP,..., ULP with random
!>           signs on the diagonal.
!>
!>      (11) Same as (8), but multiplied by SQRT( overflow threshold )
!>      (12) Same as (8), but multiplied by SQRT( underflow threshold )
!>
!>      (13) Symmetric matrix with random entries chosen from (-1,1).
!>      (14) Same as (13), but multiplied by SQRT( overflow threshold )
!>      (15) Same as (13), but multiplied by SQRT( underflow threshold )
!>      (16) A band matrix with half bandwidth randomly chosen between
!>           0 and N-1, with evenly spaced eigenvalues 1, ..., ULP
!>           with random signs.
!>      (17) Same as (16), but multiplied by SQRT( overflow threshold )
!>      (18) Same as (16), but multiplied by SQRT( underflow threshold )
!> 
!>  NSIZES  INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          ZDRVST2STG does nothing.  It must be at least zero.
!>          Not modified.
!>
!>  NN      INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>          Not modified.
!>
!>  NTYPES  INTEGER
!>          The number of elements in DOTYPE.   If it is zero, ZDRVST2STG
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>          Not modified.
!>
!>  DOTYPE  LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>          Not modified.
!>
!>  ISEED   INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRVST2STG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       COMPLEX*16 array, dimension (LDA , max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  D1      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by ZSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>          Modified.
!>
!>  D2      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by ZSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>          Modified.
!>
!>  D3      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by DSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>          Modified.
!>
!>  WA1     DOUBLE PRECISION array, dimension
!>
!>  WA2     DOUBLE PRECISION array, dimension
!>
!>  WA3     DOUBLE PRECISION array, dimension
!>
!>  U       COMPLEX*16 array, dimension (LDU, max(NN))
!>          The unitary matrix computed by ZHETRD + ZUNGC3.
!>          Modified.
!>
!>  LDU     INTEGER
!>          The leading dimension of U, Z, and V.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  V       COMPLEX*16 array, dimension (LDU, max(NN))
!>          The Housholder vectors computed by ZHETRD in reducing A to
!>          tridiagonal form.
!>          Modified.
!>
!>  TAU     COMPLEX*16 array, dimension (max(NN))
!>          The Householder factors computed by ZHETRD in reducing A
!>          to tridiagonal form.
!>          Modified.
!>
!>  Z       COMPLEX*16 array, dimension (LDU, max(NN))
!>          The unitary matrix of eigenvectors computed by ZHEEVD,
!>          ZHEEVX, ZHPEVD, CHPEVX, ZHBEVD, and CHBEVX.
!>          Modified.
!>
!>  WORK  - COMPLEX*16 array of dimension ( LWORK )
!>           Workspace.
!>           Modified.
!>
!>  LWORK - INTEGER
!>           The number of entries in WORK.  This must be at least
!>           2*max( NN(j), 2 )**2.
!>           Not modified.
!>
!>  RWORK   DOUBLE PRECISION array, dimension (3*max(NN))
!>           Workspace.
!>           Modified.
!>
!>  LRWORK - INTEGER
!>           The number of entries in RWORK.
!>
!>  IWORK   INTEGER array, dimension (6*max(NN))
!>          Workspace.
!>          Modified.
!>
!>  LIWORK - INTEGER
!>           The number of entries in IWORK.
!>
!>  RESULT  DOUBLE PRECISION array, dimension (??)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>          Modified.
!>
!>  INFO    INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -16: LDU < 1 or LDU < NMAX.
!>          -21: LWORK too small.
!>          If  DLATMR, SLATMS, ZHETRD, DORGC3, ZSTEQR, DSTERF,
!>              or DORMC2 returns an error code, the
!>              absolute value of it is returned.
!>          Modified.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far (computed by DLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 334 of file zdrvst2stg.f.

338*
339* -- LAPACK test routine --
340* -- LAPACK is a software package provided by Univ. of Tennessee, --
341* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
342*
343* .. Scalar Arguments ..
344 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
345 $ NSIZES, NTYPES
346 DOUBLE PRECISION THRESH
347* ..
348* .. Array Arguments ..
349 LOGICAL DOTYPE( * )
350 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
351 DOUBLE PRECISION D1( * ), D2( * ), D3( * ), RESULT( * ),
352 $ RWORK( * ), WA1( * ), WA2( * ), WA3( * )
353 COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ),
354 $ V( LDU, * ), WORK( * ), Z( LDU, * )
355* ..
356*
357* =====================================================================
358*
359*
360* .. Parameters ..
361 DOUBLE PRECISION ZERO, ONE, TWO, TEN
362 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
363 $ ten = 10.0d+0 )
364 DOUBLE PRECISION HALF
365 parameter( half = one / two )
366 COMPLEX*16 CZERO, CONE
367 parameter( czero = ( 0.0d+0, 0.0d+0 ),
368 $ cone = ( 1.0d+0, 0.0d+0 ) )
369 INTEGER MAXTYP
370 parameter( maxtyp = 18 )
371* ..
372* .. Local Scalars ..
373 LOGICAL BADNN
374 CHARACTER UPLO
375 INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDWRK, INDX,
376 $ IROW, ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL,
377 $ JSIZE, JTYPE, KD, LGN, LIWEDC, LRWEDC, LWEDC,
378 $ M, M2, M3, MTYPES, N, NERRS, NMATS, NMAX,
379 $ NTEST, NTESTT
380 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
381 $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL,
382 $ VL, VU
383* ..
384* .. Local Arrays ..
385 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
386 $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
387 $ KTYPE( MAXTYP )
388* ..
389* .. External Functions ..
390 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
391 EXTERNAL dlamch, dlarnd, dsxt1
392* ..
393* .. External Subroutines ..
394 EXTERNAL alasvm, dlabad, dlafts, xerbla, zhbev, zhbevd,
395 $ zhbevx, zheev, zheevd, zheevr, zheevx, zhet21,
396 $ zhet22, zhpev, zhpevd, zhpevx, zlacpy, zlaset,
397 $ zheevd_2stage, zheevr_2stage, zheevx_2stage,
398 $ zheev_2stage, zhbev_2stage, zhbevd_2stage,
399 $ zhbevx_2stage, zhetrd_2stage, zlatmr, zlatms
400* ..
401* .. Intrinsic Functions ..
402 INTRINSIC abs, dble, int, log, max, min, sqrt
403* ..
404* .. Data statements ..
405 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 3*9 /
406 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
407 $ 2, 3, 1, 2, 3 /
408 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
409 $ 0, 0, 4, 4, 4 /
410* ..
411* .. Executable Statements ..
412*
413* 1) Check for errors
414*
415 ntestt = 0
416 info = 0
417*
418 badnn = .false.
419 nmax = 1
420 DO 10 j = 1, nsizes
421 nmax = max( nmax, nn( j ) )
422 IF( nn( j ).LT.0 )
423 $ badnn = .true.
424 10 CONTINUE
425*
426* Check for errors
427*
428 IF( nsizes.LT.0 ) THEN
429 info = -1
430 ELSE IF( badnn ) THEN
431 info = -2
432 ELSE IF( ntypes.LT.0 ) THEN
433 info = -3
434 ELSE IF( lda.LT.nmax ) THEN
435 info = -9
436 ELSE IF( ldu.LT.nmax ) THEN
437 info = -16
438 ELSE IF( 2*max( 2, nmax )**2.GT.lwork ) THEN
439 info = -22
440 END IF
441*
442 IF( info.NE.0 ) THEN
443 CALL xerbla( 'ZDRVST2STG', -info )
444 RETURN
445 END IF
446*
447* Quick return if nothing to do
448*
449 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
450 $ RETURN
451*
452* More Important constants
453*
454 unfl = dlamch( 'Safe minimum' )
455 ovfl = dlamch( 'Overflow' )
456 CALL dlabad( unfl, ovfl )
457 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
458 ulpinv = one / ulp
459 rtunfl = sqrt( unfl )
460 rtovfl = sqrt( ovfl )
461*
462* Loop over sizes, types
463*
464 DO 20 i = 1, 4
465 iseed2( i ) = iseed( i )
466 iseed3( i ) = iseed( i )
467 20 CONTINUE
468*
469 nerrs = 0
470 nmats = 0
471*
472 DO 1220 jsize = 1, nsizes
473 n = nn( jsize )
474 IF( n.GT.0 ) THEN
475 lgn = int( log( dble( n ) ) / log( two ) )
476 IF( 2**lgn.LT.n )
477 $ lgn = lgn + 1
478 IF( 2**lgn.LT.n )
479 $ lgn = lgn + 1
480 lwedc = max( 2*n+n*n, 2*n*n )
481 lrwedc = 1 + 4*n + 2*n*lgn + 3*n**2
482 liwedc = 3 + 5*n
483 ELSE
484 lwedc = 2
485 lrwedc = 8
486 liwedc = 8
487 END IF
488 aninv = one / dble( max( 1, n ) )
489*
490 IF( nsizes.NE.1 ) THEN
491 mtypes = min( maxtyp, ntypes )
492 ELSE
493 mtypes = min( maxtyp+1, ntypes )
494 END IF
495*
496 DO 1210 jtype = 1, mtypes
497 IF( .NOT.dotype( jtype ) )
498 $ GO TO 1210
499 nmats = nmats + 1
500 ntest = 0
501*
502 DO 30 j = 1, 4
503 ioldsd( j ) = iseed( j )
504 30 CONTINUE
505*
506* 2) Compute "A"
507*
508* Control parameters:
509*
510* KMAGN KMODE KTYPE
511* =1 O(1) clustered 1 zero
512* =2 large clustered 2 identity
513* =3 small exponential (none)
514* =4 arithmetic diagonal, (w/ eigenvalues)
515* =5 random log Hermitian, w/ eigenvalues
516* =6 random (none)
517* =7 random diagonal
518* =8 random Hermitian
519* =9 band Hermitian, w/ eigenvalues
520*
521 IF( mtypes.GT.maxtyp )
522 $ GO TO 110
523*
524 itype = ktype( jtype )
525 imode = kmode( jtype )
526*
527* Compute norm
528*
529 GO TO ( 40, 50, 60 )kmagn( jtype )
530*
531 40 CONTINUE
532 anorm = one
533 GO TO 70
534*
535 50 CONTINUE
536 anorm = ( rtovfl*ulp )*aninv
537 GO TO 70
538*
539 60 CONTINUE
540 anorm = rtunfl*n*ulpinv
541 GO TO 70
542*
543 70 CONTINUE
544*
545 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
546 iinfo = 0
547 cond = ulpinv
548*
549* Special Matrices -- Identity & Jordan block
550*
551* Zero
552*
553 IF( itype.EQ.1 ) THEN
554 iinfo = 0
555*
556 ELSE IF( itype.EQ.2 ) THEN
557*
558* Identity
559*
560 DO 80 jcol = 1, n
561 a( jcol, jcol ) = anorm
562 80 CONTINUE
563*
564 ELSE IF( itype.EQ.4 ) THEN
565*
566* Diagonal Matrix, [Eigen]values Specified
567*
568 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
569 $ anorm, 0, 0, 'N', a, lda, work, iinfo )
570*
571 ELSE IF( itype.EQ.5 ) THEN
572*
573* Hermitian, eigenvalues specified
574*
575 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
576 $ anorm, n, n, 'N', a, lda, work, iinfo )
577*
578 ELSE IF( itype.EQ.7 ) THEN
579*
580* Diagonal, random eigenvalues
581*
582 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
583 $ 'T', 'N', work( n+1 ), 1, one,
584 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
585 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
586*
587 ELSE IF( itype.EQ.8 ) THEN
588*
589* Hermitian, random eigenvalues
590*
591 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
592 $ 'T', 'N', work( n+1 ), 1, one,
593 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
594 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
595*
596 ELSE IF( itype.EQ.9 ) THEN
597*
598* Hermitian banded, eigenvalues specified
599*
600 ihbw = int( ( n-1 )*dlarnd( 1, iseed3 ) )
601 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
602 $ anorm, ihbw, ihbw, 'Z', u, ldu, work,
603 $ iinfo )
604*
605* Store as dense matrix for most routines.
606*
607 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
608 DO 100 idiag = -ihbw, ihbw
609 irow = ihbw - idiag + 1
610 j1 = max( 1, idiag+1 )
611 j2 = min( n, n+idiag )
612 DO 90 j = j1, j2
613 i = j - idiag
614 a( i, j ) = u( irow, j )
615 90 CONTINUE
616 100 CONTINUE
617 ELSE
618 iinfo = 1
619 END IF
620*
621 IF( iinfo.NE.0 ) THEN
622 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
623 $ ioldsd
624 info = abs( iinfo )
625 RETURN
626 END IF
627*
628 110 CONTINUE
629*
630 abstol = unfl + unfl
631 IF( n.LE.1 ) THEN
632 il = 1
633 iu = n
634 ELSE
635 il = 1 + int( ( n-1 )*dlarnd( 1, iseed2 ) )
636 iu = 1 + int( ( n-1 )*dlarnd( 1, iseed2 ) )
637 IF( il.GT.iu ) THEN
638 itemp = il
639 il = iu
640 iu = itemp
641 END IF
642 END IF
643*
644* Perform tests storing upper or lower triangular
645* part of matrix.
646*
647 DO 1200 iuplo = 0, 1
648 IF( iuplo.EQ.0 ) THEN
649 uplo = 'L'
650 ELSE
651 uplo = 'U'
652 END IF
653*
654* Call ZHEEVD and CHEEVX.
655*
656 CALL zlacpy( ' ', n, n, a, lda, v, ldu )
657*
658 ntest = ntest + 1
659 CALL zheevd( 'V', uplo, n, a, ldu, d1, work, lwedc,
660 $ rwork, lrwedc, iwork, liwedc, iinfo )
661 IF( iinfo.NE.0 ) THEN
662 WRITE( nounit, fmt = 9999 )'ZHEEVD(V,' // uplo //
663 $ ')', iinfo, n, jtype, ioldsd
664 info = abs( iinfo )
665 IF( iinfo.LT.0 ) THEN
666 RETURN
667 ELSE
668 result( ntest ) = ulpinv
669 result( ntest+1 ) = ulpinv
670 result( ntest+2 ) = ulpinv
671 GO TO 130
672 END IF
673 END IF
674*
675* Do tests 1 and 2.
676*
677 CALL zhet21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
678 $ ldu, tau, work, rwork, result( ntest ) )
679*
680 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
681*
682 ntest = ntest + 2
683 CALL zheevd_2stage( 'N', uplo, n, a, ldu, d3, work,
684 $ lwork, rwork, lrwedc, iwork, liwedc, iinfo )
685 IF( iinfo.NE.0 ) THEN
686 WRITE( nounit, fmt = 9999 )
687 $ 'ZHEEVD_2STAGE(N,' // uplo //
688 $ ')', iinfo, n, jtype, ioldsd
689 info = abs( iinfo )
690 IF( iinfo.LT.0 ) THEN
691 RETURN
692 ELSE
693 result( ntest ) = ulpinv
694 GO TO 130
695 END IF
696 END IF
697*
698* Do test 3.
699*
700 temp1 = zero
701 temp2 = zero
702 DO 120 j = 1, n
703 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
704 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
705 120 CONTINUE
706 result( ntest ) = temp2 / max( unfl,
707 $ ulp*max( temp1, temp2 ) )
708*
709 130 CONTINUE
710 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
711*
712 ntest = ntest + 1
713*
714 IF( n.GT.0 ) THEN
715 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
716 IF( il.NE.1 ) THEN
717 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
718 $ ten*ulp*temp3, ten*rtunfl )
719 ELSE IF( n.GT.0 ) THEN
720 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
721 $ ten*ulp*temp3, ten*rtunfl )
722 END IF
723 IF( iu.NE.n ) THEN
724 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
725 $ ten*ulp*temp3, ten*rtunfl )
726 ELSE IF( n.GT.0 ) THEN
727 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
728 $ ten*ulp*temp3, ten*rtunfl )
729 END IF
730 ELSE
731 temp3 = zero
732 vl = zero
733 vu = one
734 END IF
735*
736 CALL zheevx( 'V', 'A', uplo, n, a, ldu, vl, vu, il, iu,
737 $ abstol, m, wa1, z, ldu, work, lwork, rwork,
738 $ iwork, iwork( 5*n+1 ), iinfo )
739 IF( iinfo.NE.0 ) THEN
740 WRITE( nounit, fmt = 9999 )'ZHEEVX(V,A,' // uplo //
741 $ ')', iinfo, n, jtype, ioldsd
742 info = abs( iinfo )
743 IF( iinfo.LT.0 ) THEN
744 RETURN
745 ELSE
746 result( ntest ) = ulpinv
747 result( ntest+1 ) = ulpinv
748 result( ntest+2 ) = ulpinv
749 GO TO 150
750 END IF
751 END IF
752*
753* Do tests 4 and 5.
754*
755 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
756*
757 CALL zhet21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
758 $ ldu, tau, work, rwork, result( ntest ) )
759*
760 ntest = ntest + 2
761 CALL zheevx_2stage( 'N', 'A', uplo, n, a, ldu, vl, vu,
762 $ il, iu, abstol, m2, wa2, z, ldu,
763 $ work, lwork, rwork, iwork,
764 $ iwork( 5*n+1 ), iinfo )
765 IF( iinfo.NE.0 ) THEN
766 WRITE( nounit, fmt = 9999 )
767 $ 'ZHEEVX_2STAGE(N,A,' // uplo //
768 $ ')', iinfo, n, jtype, ioldsd
769 info = abs( iinfo )
770 IF( iinfo.LT.0 ) THEN
771 RETURN
772 ELSE
773 result( ntest ) = ulpinv
774 GO TO 150
775 END IF
776 END IF
777*
778* Do test 6.
779*
780 temp1 = zero
781 temp2 = zero
782 DO 140 j = 1, n
783 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
784 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
785 140 CONTINUE
786 result( ntest ) = temp2 / max( unfl,
787 $ ulp*max( temp1, temp2 ) )
788*
789 150 CONTINUE
790 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
791*
792 ntest = ntest + 1
793*
794 CALL zheevx( 'V', 'I', uplo, n, a, ldu, vl, vu, il, iu,
795 $ abstol, m2, wa2, z, ldu, work, lwork, rwork,
796 $ iwork, iwork( 5*n+1 ), iinfo )
797 IF( iinfo.NE.0 ) THEN
798 WRITE( nounit, fmt = 9999 )'ZHEEVX(V,I,' // uplo //
799 $ ')', iinfo, n, jtype, ioldsd
800 info = abs( iinfo )
801 IF( iinfo.LT.0 ) THEN
802 RETURN
803 ELSE
804 result( ntest ) = ulpinv
805 GO TO 160
806 END IF
807 END IF
808*
809* Do tests 7 and 8.
810*
811 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
812*
813 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
814 $ v, ldu, tau, work, rwork, result( ntest ) )
815*
816 ntest = ntest + 2
817*
818 CALL zheevx_2stage( 'N', 'I', uplo, n, a, ldu, vl, vu,
819 $ il, iu, abstol, m3, wa3, z, ldu,
820 $ work, lwork, rwork, iwork,
821 $ iwork( 5*n+1 ), iinfo )
822 IF( iinfo.NE.0 ) THEN
823 WRITE( nounit, fmt = 9999 )
824 $ 'ZHEEVX_2STAGE(N,I,' // uplo //
825 $ ')', iinfo, n, jtype, ioldsd
826 info = abs( iinfo )
827 IF( iinfo.LT.0 ) THEN
828 RETURN
829 ELSE
830 result( ntest ) = ulpinv
831 GO TO 160
832 END IF
833 END IF
834*
835* Do test 9.
836*
837 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
838 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
839 IF( n.GT.0 ) THEN
840 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
841 ELSE
842 temp3 = zero
843 END IF
844 result( ntest ) = ( temp1+temp2 ) /
845 $ max( unfl, temp3*ulp )
846*
847 160 CONTINUE
848 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
849*
850 ntest = ntest + 1
851*
852 CALL zheevx( 'V', 'V', uplo, n, a, ldu, vl, vu, il, iu,
853 $ abstol, m2, wa2, z, ldu, work, lwork, rwork,
854 $ iwork, iwork( 5*n+1 ), iinfo )
855 IF( iinfo.NE.0 ) THEN
856 WRITE( nounit, fmt = 9999 )'ZHEEVX(V,V,' // uplo //
857 $ ')', iinfo, n, jtype, ioldsd
858 info = abs( iinfo )
859 IF( iinfo.LT.0 ) THEN
860 RETURN
861 ELSE
862 result( ntest ) = ulpinv
863 GO TO 170
864 END IF
865 END IF
866*
867* Do tests 10 and 11.
868*
869 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
870*
871 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
872 $ v, ldu, tau, work, rwork, result( ntest ) )
873*
874 ntest = ntest + 2
875*
876 CALL zheevx_2stage( 'N', 'V', uplo, n, a, ldu, vl, vu,
877 $ il, iu, abstol, m3, wa3, z, ldu,
878 $ work, lwork, rwork, iwork,
879 $ iwork( 5*n+1 ), iinfo )
880 IF( iinfo.NE.0 ) THEN
881 WRITE( nounit, fmt = 9999 )
882 $ 'ZHEEVX_2STAGE(N,V,' // uplo //
883 $ ')', iinfo, n, jtype, ioldsd
884 info = abs( iinfo )
885 IF( iinfo.LT.0 ) THEN
886 RETURN
887 ELSE
888 result( ntest ) = ulpinv
889 GO TO 170
890 END IF
891 END IF
892*
893 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
894 result( ntest ) = ulpinv
895 GO TO 170
896 END IF
897*
898* Do test 12.
899*
900 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
901 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
902 IF( n.GT.0 ) THEN
903 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
904 ELSE
905 temp3 = zero
906 END IF
907 result( ntest ) = ( temp1+temp2 ) /
908 $ max( unfl, temp3*ulp )
909*
910 170 CONTINUE
911*
912* Call ZHPEVD and CHPEVX.
913*
914 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
915*
916* Load array WORK with the upper or lower triangular
917* part of the matrix in packed form.
918*
919 IF( iuplo.EQ.1 ) THEN
920 indx = 1
921 DO 190 j = 1, n
922 DO 180 i = 1, j
923 work( indx ) = a( i, j )
924 indx = indx + 1
925 180 CONTINUE
926 190 CONTINUE
927 ELSE
928 indx = 1
929 DO 210 j = 1, n
930 DO 200 i = j, n
931 work( indx ) = a( i, j )
932 indx = indx + 1
933 200 CONTINUE
934 210 CONTINUE
935 END IF
936*
937 ntest = ntest + 1
938 indwrk = n*( n+1 ) / 2 + 1
939 CALL zhpevd( 'V', uplo, n, work, d1, z, ldu,
940 $ work( indwrk ), lwedc, rwork, lrwedc, iwork,
941 $ liwedc, iinfo )
942 IF( iinfo.NE.0 ) THEN
943 WRITE( nounit, fmt = 9999 )'ZHPEVD(V,' // uplo //
944 $ ')', iinfo, n, jtype, ioldsd
945 info = abs( iinfo )
946 IF( iinfo.LT.0 ) THEN
947 RETURN
948 ELSE
949 result( ntest ) = ulpinv
950 result( ntest+1 ) = ulpinv
951 result( ntest+2 ) = ulpinv
952 GO TO 270
953 END IF
954 END IF
955*
956* Do tests 13 and 14.
957*
958 CALL zhet21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
959 $ ldu, tau, work, rwork, result( ntest ) )
960*
961 IF( iuplo.EQ.1 ) THEN
962 indx = 1
963 DO 230 j = 1, n
964 DO 220 i = 1, j
965 work( indx ) = a( i, j )
966 indx = indx + 1
967 220 CONTINUE
968 230 CONTINUE
969 ELSE
970 indx = 1
971 DO 250 j = 1, n
972 DO 240 i = j, n
973 work( indx ) = a( i, j )
974 indx = indx + 1
975 240 CONTINUE
976 250 CONTINUE
977 END IF
978*
979 ntest = ntest + 2
980 indwrk = n*( n+1 ) / 2 + 1
981 CALL zhpevd( 'N', uplo, n, work, d3, z, ldu,
982 $ work( indwrk ), lwedc, rwork, lrwedc, iwork,
983 $ liwedc, iinfo )
984 IF( iinfo.NE.0 ) THEN
985 WRITE( nounit, fmt = 9999 )'ZHPEVD(N,' // uplo //
986 $ ')', iinfo, n, jtype, ioldsd
987 info = abs( iinfo )
988 IF( iinfo.LT.0 ) THEN
989 RETURN
990 ELSE
991 result( ntest ) = ulpinv
992 GO TO 270
993 END IF
994 END IF
995*
996* Do test 15.
997*
998 temp1 = zero
999 temp2 = zero
1000 DO 260 j = 1, n
1001 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1002 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1003 260 CONTINUE
1004 result( ntest ) = temp2 / max( unfl,
1005 $ ulp*max( temp1, temp2 ) )
1006*
1007* Load array WORK with the upper or lower triangular part
1008* of the matrix in packed form.
1009*
1010 270 CONTINUE
1011 IF( iuplo.EQ.1 ) THEN
1012 indx = 1
1013 DO 290 j = 1, n
1014 DO 280 i = 1, j
1015 work( indx ) = a( i, j )
1016 indx = indx + 1
1017 280 CONTINUE
1018 290 CONTINUE
1019 ELSE
1020 indx = 1
1021 DO 310 j = 1, n
1022 DO 300 i = j, n
1023 work( indx ) = a( i, j )
1024 indx = indx + 1
1025 300 CONTINUE
1026 310 CONTINUE
1027 END IF
1028*
1029 ntest = ntest + 1
1030*
1031 IF( n.GT.0 ) THEN
1032 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
1033 IF( il.NE.1 ) THEN
1034 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
1035 $ ten*ulp*temp3, ten*rtunfl )
1036 ELSE IF( n.GT.0 ) THEN
1037 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
1038 $ ten*ulp*temp3, ten*rtunfl )
1039 END IF
1040 IF( iu.NE.n ) THEN
1041 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
1042 $ ten*ulp*temp3, ten*rtunfl )
1043 ELSE IF( n.GT.0 ) THEN
1044 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
1045 $ ten*ulp*temp3, ten*rtunfl )
1046 END IF
1047 ELSE
1048 temp3 = zero
1049 vl = zero
1050 vu = one
1051 END IF
1052*
1053 CALL zhpevx( 'V', 'A', uplo, n, work, vl, vu, il, iu,
1054 $ abstol, m, wa1, z, ldu, v, rwork, iwork,
1055 $ iwork( 5*n+1 ), iinfo )
1056 IF( iinfo.NE.0 ) THEN
1057 WRITE( nounit, fmt = 9999 )'ZHPEVX(V,A,' // uplo //
1058 $ ')', iinfo, n, jtype, ioldsd
1059 info = abs( iinfo )
1060 IF( iinfo.LT.0 ) THEN
1061 RETURN
1062 ELSE
1063 result( ntest ) = ulpinv
1064 result( ntest+1 ) = ulpinv
1065 result( ntest+2 ) = ulpinv
1066 GO TO 370
1067 END IF
1068 END IF
1069*
1070* Do tests 16 and 17.
1071*
1072 CALL zhet21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
1073 $ ldu, tau, work, rwork, result( ntest ) )
1074*
1075 ntest = ntest + 2
1076*
1077 IF( iuplo.EQ.1 ) THEN
1078 indx = 1
1079 DO 330 j = 1, n
1080 DO 320 i = 1, j
1081 work( indx ) = a( i, j )
1082 indx = indx + 1
1083 320 CONTINUE
1084 330 CONTINUE
1085 ELSE
1086 indx = 1
1087 DO 350 j = 1, n
1088 DO 340 i = j, n
1089 work( indx ) = a( i, j )
1090 indx = indx + 1
1091 340 CONTINUE
1092 350 CONTINUE
1093 END IF
1094*
1095 CALL zhpevx( 'N', 'A', uplo, n, work, vl, vu, il, iu,
1096 $ abstol, m2, wa2, z, ldu, v, rwork, iwork,
1097 $ iwork( 5*n+1 ), iinfo )
1098 IF( iinfo.NE.0 ) THEN
1099 WRITE( nounit, fmt = 9999 )'ZHPEVX(N,A,' // uplo //
1100 $ ')', iinfo, n, jtype, ioldsd
1101 info = abs( iinfo )
1102 IF( iinfo.LT.0 ) THEN
1103 RETURN
1104 ELSE
1105 result( ntest ) = ulpinv
1106 GO TO 370
1107 END IF
1108 END IF
1109*
1110* Do test 18.
1111*
1112 temp1 = zero
1113 temp2 = zero
1114 DO 360 j = 1, n
1115 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1116 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1117 360 CONTINUE
1118 result( ntest ) = temp2 / max( unfl,
1119 $ ulp*max( temp1, temp2 ) )
1120*
1121 370 CONTINUE
1122 ntest = ntest + 1
1123 IF( iuplo.EQ.1 ) THEN
1124 indx = 1
1125 DO 390 j = 1, n
1126 DO 380 i = 1, j
1127 work( indx ) = a( i, j )
1128 indx = indx + 1
1129 380 CONTINUE
1130 390 CONTINUE
1131 ELSE
1132 indx = 1
1133 DO 410 j = 1, n
1134 DO 400 i = j, n
1135 work( indx ) = a( i, j )
1136 indx = indx + 1
1137 400 CONTINUE
1138 410 CONTINUE
1139 END IF
1140*
1141 CALL zhpevx( 'V', 'I', uplo, n, work, vl, vu, il, iu,
1142 $ abstol, m2, wa2, z, ldu, v, rwork, iwork,
1143 $ iwork( 5*n+1 ), iinfo )
1144 IF( iinfo.NE.0 ) THEN
1145 WRITE( nounit, fmt = 9999 )'ZHPEVX(V,I,' // uplo //
1146 $ ')', iinfo, n, jtype, ioldsd
1147 info = abs( iinfo )
1148 IF( iinfo.LT.0 ) THEN
1149 RETURN
1150 ELSE
1151 result( ntest ) = ulpinv
1152 result( ntest+1 ) = ulpinv
1153 result( ntest+2 ) = ulpinv
1154 GO TO 460
1155 END IF
1156 END IF
1157*
1158* Do tests 19 and 20.
1159*
1160 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1161 $ v, ldu, tau, work, rwork, result( ntest ) )
1162*
1163 ntest = ntest + 2
1164*
1165 IF( iuplo.EQ.1 ) THEN
1166 indx = 1
1167 DO 430 j = 1, n
1168 DO 420 i = 1, j
1169 work( indx ) = a( i, j )
1170 indx = indx + 1
1171 420 CONTINUE
1172 430 CONTINUE
1173 ELSE
1174 indx = 1
1175 DO 450 j = 1, n
1176 DO 440 i = j, n
1177 work( indx ) = a( i, j )
1178 indx = indx + 1
1179 440 CONTINUE
1180 450 CONTINUE
1181 END IF
1182*
1183 CALL zhpevx( 'N', 'I', uplo, n, work, vl, vu, il, iu,
1184 $ abstol, m3, wa3, z, ldu, v, rwork, iwork,
1185 $ iwork( 5*n+1 ), iinfo )
1186 IF( iinfo.NE.0 ) THEN
1187 WRITE( nounit, fmt = 9999 )'ZHPEVX(N,I,' // uplo //
1188 $ ')', iinfo, n, jtype, ioldsd
1189 info = abs( iinfo )
1190 IF( iinfo.LT.0 ) THEN
1191 RETURN
1192 ELSE
1193 result( ntest ) = ulpinv
1194 GO TO 460
1195 END IF
1196 END IF
1197*
1198* Do test 21.
1199*
1200 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1201 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1202 IF( n.GT.0 ) THEN
1203 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1204 ELSE
1205 temp3 = zero
1206 END IF
1207 result( ntest ) = ( temp1+temp2 ) /
1208 $ max( unfl, temp3*ulp )
1209*
1210 460 CONTINUE
1211 ntest = ntest + 1
1212 IF( iuplo.EQ.1 ) THEN
1213 indx = 1
1214 DO 480 j = 1, n
1215 DO 470 i = 1, j
1216 work( indx ) = a( i, j )
1217 indx = indx + 1
1218 470 CONTINUE
1219 480 CONTINUE
1220 ELSE
1221 indx = 1
1222 DO 500 j = 1, n
1223 DO 490 i = j, n
1224 work( indx ) = a( i, j )
1225 indx = indx + 1
1226 490 CONTINUE
1227 500 CONTINUE
1228 END IF
1229*
1230 CALL zhpevx( 'V', 'V', uplo, n, work, vl, vu, il, iu,
1231 $ abstol, m2, wa2, z, ldu, v, rwork, iwork,
1232 $ iwork( 5*n+1 ), iinfo )
1233 IF( iinfo.NE.0 ) THEN
1234 WRITE( nounit, fmt = 9999 )'ZHPEVX(V,V,' // uplo //
1235 $ ')', iinfo, n, jtype, ioldsd
1236 info = abs( iinfo )
1237 IF( iinfo.LT.0 ) THEN
1238 RETURN
1239 ELSE
1240 result( ntest ) = ulpinv
1241 result( ntest+1 ) = ulpinv
1242 result( ntest+2 ) = ulpinv
1243 GO TO 550
1244 END IF
1245 END IF
1246*
1247* Do tests 22 and 23.
1248*
1249 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1250 $ v, ldu, tau, work, rwork, result( ntest ) )
1251*
1252 ntest = ntest + 2
1253*
1254 IF( iuplo.EQ.1 ) THEN
1255 indx = 1
1256 DO 520 j = 1, n
1257 DO 510 i = 1, j
1258 work( indx ) = a( i, j )
1259 indx = indx + 1
1260 510 CONTINUE
1261 520 CONTINUE
1262 ELSE
1263 indx = 1
1264 DO 540 j = 1, n
1265 DO 530 i = j, n
1266 work( indx ) = a( i, j )
1267 indx = indx + 1
1268 530 CONTINUE
1269 540 CONTINUE
1270 END IF
1271*
1272 CALL zhpevx( 'N', 'V', uplo, n, work, vl, vu, il, iu,
1273 $ abstol, m3, wa3, z, ldu, v, rwork, iwork,
1274 $ iwork( 5*n+1 ), iinfo )
1275 IF( iinfo.NE.0 ) THEN
1276 WRITE( nounit, fmt = 9999 )'ZHPEVX(N,V,' // uplo //
1277 $ ')', iinfo, n, jtype, ioldsd
1278 info = abs( iinfo )
1279 IF( iinfo.LT.0 ) THEN
1280 RETURN
1281 ELSE
1282 result( ntest ) = ulpinv
1283 GO TO 550
1284 END IF
1285 END IF
1286*
1287 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1288 result( ntest ) = ulpinv
1289 GO TO 550
1290 END IF
1291*
1292* Do test 24.
1293*
1294 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1295 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1296 IF( n.GT.0 ) THEN
1297 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1298 ELSE
1299 temp3 = zero
1300 END IF
1301 result( ntest ) = ( temp1+temp2 ) /
1302 $ max( unfl, temp3*ulp )
1303*
1304 550 CONTINUE
1305*
1306* Call ZHBEVD and CHBEVX.
1307*
1308 IF( jtype.LE.7 ) THEN
1309 kd = 0
1310 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
1311 kd = max( n-1, 0 )
1312 ELSE
1313 kd = ihbw
1314 END IF
1315*
1316* Load array V with the upper or lower triangular part
1317* of the matrix in band form.
1318*
1319 IF( iuplo.EQ.1 ) THEN
1320 DO 570 j = 1, n
1321 DO 560 i = max( 1, j-kd ), j
1322 v( kd+1+i-j, j ) = a( i, j )
1323 560 CONTINUE
1324 570 CONTINUE
1325 ELSE
1326 DO 590 j = 1, n
1327 DO 580 i = j, min( n, j+kd )
1328 v( 1+i-j, j ) = a( i, j )
1329 580 CONTINUE
1330 590 CONTINUE
1331 END IF
1332*
1333 ntest = ntest + 1
1334 CALL zhbevd( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
1335 $ lwedc, rwork, lrwedc, iwork, liwedc, iinfo )
1336 IF( iinfo.NE.0 ) THEN
1337 WRITE( nounit, fmt = 9998 )'ZHBEVD(V,' // uplo //
1338 $ ')', iinfo, n, kd, jtype, ioldsd
1339 info = abs( iinfo )
1340 IF( iinfo.LT.0 ) THEN
1341 RETURN
1342 ELSE
1343 result( ntest ) = ulpinv
1344 result( ntest+1 ) = ulpinv
1345 result( ntest+2 ) = ulpinv
1346 GO TO 650
1347 END IF
1348 END IF
1349*
1350* Do tests 25 and 26.
1351*
1352 CALL zhet21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
1353 $ ldu, tau, work, rwork, result( ntest ) )
1354*
1355 IF( iuplo.EQ.1 ) THEN
1356 DO 610 j = 1, n
1357 DO 600 i = max( 1, j-kd ), j
1358 v( kd+1+i-j, j ) = a( i, j )
1359 600 CONTINUE
1360 610 CONTINUE
1361 ELSE
1362 DO 630 j = 1, n
1363 DO 620 i = j, min( n, j+kd )
1364 v( 1+i-j, j ) = a( i, j )
1365 620 CONTINUE
1366 630 CONTINUE
1367 END IF
1368*
1369 ntest = ntest + 2
1370 CALL zhbevd_2stage( 'N', uplo, n, kd, v, ldu, d3,
1371 $ z, ldu, work, lwork, rwork,
1372 $ lrwedc, iwork, liwedc, iinfo )
1373 IF( iinfo.NE.0 ) THEN
1374 WRITE( nounit, fmt = 9998 )
1375 $ 'ZHBEVD_2STAGE(N,' // uplo //
1376 $ ')', iinfo, n, kd, jtype, ioldsd
1377 info = abs( iinfo )
1378 IF( iinfo.LT.0 ) THEN
1379 RETURN
1380 ELSE
1381 result( ntest ) = ulpinv
1382 GO TO 650
1383 END IF
1384 END IF
1385*
1386* Do test 27.
1387*
1388 temp1 = zero
1389 temp2 = zero
1390 DO 640 j = 1, n
1391 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1392 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1393 640 CONTINUE
1394 result( ntest ) = temp2 / max( unfl,
1395 $ ulp*max( temp1, temp2 ) )
1396*
1397* Load array V with the upper or lower triangular part
1398* of the matrix in band form.
1399*
1400 650 CONTINUE
1401 IF( iuplo.EQ.1 ) THEN
1402 DO 670 j = 1, n
1403 DO 660 i = max( 1, j-kd ), j
1404 v( kd+1+i-j, j ) = a( i, j )
1405 660 CONTINUE
1406 670 CONTINUE
1407 ELSE
1408 DO 690 j = 1, n
1409 DO 680 i = j, min( n, j+kd )
1410 v( 1+i-j, j ) = a( i, j )
1411 680 CONTINUE
1412 690 CONTINUE
1413 END IF
1414*
1415 ntest = ntest + 1
1416 CALL zhbevx( 'V', 'A', uplo, n, kd, v, ldu, u, ldu, vl,
1417 $ vu, il, iu, abstol, m, wa1, z, ldu, work,
1418 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1419 IF( iinfo.NE.0 ) THEN
1420 WRITE( nounit, fmt = 9999 )'ZHBEVX(V,A,' // uplo //
1421 $ ')', iinfo, n, kd, jtype, ioldsd
1422 info = abs( iinfo )
1423 IF( iinfo.LT.0 ) THEN
1424 RETURN
1425 ELSE
1426 result( ntest ) = ulpinv
1427 result( ntest+1 ) = ulpinv
1428 result( ntest+2 ) = ulpinv
1429 GO TO 750
1430 END IF
1431 END IF
1432*
1433* Do tests 28 and 29.
1434*
1435 CALL zhet21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
1436 $ ldu, tau, work, rwork, result( ntest ) )
1437*
1438 ntest = ntest + 2
1439*
1440 IF( iuplo.EQ.1 ) THEN
1441 DO 710 j = 1, n
1442 DO 700 i = max( 1, j-kd ), j
1443 v( kd+1+i-j, j ) = a( i, j )
1444 700 CONTINUE
1445 710 CONTINUE
1446 ELSE
1447 DO 730 j = 1, n
1448 DO 720 i = j, min( n, j+kd )
1449 v( 1+i-j, j ) = a( i, j )
1450 720 CONTINUE
1451 730 CONTINUE
1452 END IF
1453*
1454 CALL zhbevx_2stage( 'N', 'A', uplo, n, kd, v, ldu,
1455 $ u, ldu, vl, vu, il, iu, abstol,
1456 $ m2, wa2, z, ldu, work, lwork,
1457 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1458 IF( iinfo.NE.0 ) THEN
1459 WRITE( nounit, fmt = 9998 )
1460 $ 'ZHBEVX_2STAGE(N,A,' // uplo //
1461 $ ')', iinfo, n, kd, jtype, ioldsd
1462 info = abs( iinfo )
1463 IF( iinfo.LT.0 ) THEN
1464 RETURN
1465 ELSE
1466 result( ntest ) = ulpinv
1467 GO TO 750
1468 END IF
1469 END IF
1470*
1471* Do test 30.
1472*
1473 temp1 = zero
1474 temp2 = zero
1475 DO 740 j = 1, n
1476 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1477 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1478 740 CONTINUE
1479 result( ntest ) = temp2 / max( unfl,
1480 $ ulp*max( temp1, temp2 ) )
1481*
1482* Load array V with the upper or lower triangular part
1483* of the matrix in band form.
1484*
1485 750 CONTINUE
1486 ntest = ntest + 1
1487 IF( iuplo.EQ.1 ) THEN
1488 DO 770 j = 1, n
1489 DO 760 i = max( 1, j-kd ), j
1490 v( kd+1+i-j, j ) = a( i, j )
1491 760 CONTINUE
1492 770 CONTINUE
1493 ELSE
1494 DO 790 j = 1, n
1495 DO 780 i = j, min( n, j+kd )
1496 v( 1+i-j, j ) = a( i, j )
1497 780 CONTINUE
1498 790 CONTINUE
1499 END IF
1500*
1501 CALL zhbevx( 'V', 'I', uplo, n, kd, v, ldu, u, ldu, vl,
1502 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
1503 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1504 IF( iinfo.NE.0 ) THEN
1505 WRITE( nounit, fmt = 9998 )'ZHBEVX(V,I,' // uplo //
1506 $ ')', iinfo, n, kd, jtype, ioldsd
1507 info = abs( iinfo )
1508 IF( iinfo.LT.0 ) THEN
1509 RETURN
1510 ELSE
1511 result( ntest ) = ulpinv
1512 result( ntest+1 ) = ulpinv
1513 result( ntest+2 ) = ulpinv
1514 GO TO 840
1515 END IF
1516 END IF
1517*
1518* Do tests 31 and 32.
1519*
1520 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1521 $ v, ldu, tau, work, rwork, result( ntest ) )
1522*
1523 ntest = ntest + 2
1524*
1525 IF( iuplo.EQ.1 ) THEN
1526 DO 810 j = 1, n
1527 DO 800 i = max( 1, j-kd ), j
1528 v( kd+1+i-j, j ) = a( i, j )
1529 800 CONTINUE
1530 810 CONTINUE
1531 ELSE
1532 DO 830 j = 1, n
1533 DO 820 i = j, min( n, j+kd )
1534 v( 1+i-j, j ) = a( i, j )
1535 820 CONTINUE
1536 830 CONTINUE
1537 END IF
1538 CALL zhbevx_2stage( 'N', 'I', uplo, n, kd, v, ldu,
1539 $ u, ldu, vl, vu, il, iu, abstol,
1540 $ m3, wa3, z, ldu, work, lwork,
1541 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1542 IF( iinfo.NE.0 ) THEN
1543 WRITE( nounit, fmt = 9998 )
1544 $ 'ZHBEVX_2STAGE(N,I,' // uplo //
1545 $ ')', iinfo, n, kd, jtype, ioldsd
1546 info = abs( iinfo )
1547 IF( iinfo.LT.0 ) THEN
1548 RETURN
1549 ELSE
1550 result( ntest ) = ulpinv
1551 GO TO 840
1552 END IF
1553 END IF
1554*
1555* Do test 33.
1556*
1557 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1558 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1559 IF( n.GT.0 ) THEN
1560 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1561 ELSE
1562 temp3 = zero
1563 END IF
1564 result( ntest ) = ( temp1+temp2 ) /
1565 $ max( unfl, temp3*ulp )
1566*
1567* Load array V with the upper or lower triangular part
1568* of the matrix in band form.
1569*
1570 840 CONTINUE
1571 ntest = ntest + 1
1572 IF( iuplo.EQ.1 ) THEN
1573 DO 860 j = 1, n
1574 DO 850 i = max( 1, j-kd ), j
1575 v( kd+1+i-j, j ) = a( i, j )
1576 850 CONTINUE
1577 860 CONTINUE
1578 ELSE
1579 DO 880 j = 1, n
1580 DO 870 i = j, min( n, j+kd )
1581 v( 1+i-j, j ) = a( i, j )
1582 870 CONTINUE
1583 880 CONTINUE
1584 END IF
1585 CALL zhbevx( 'V', 'V', uplo, n, kd, v, ldu, u, ldu, vl,
1586 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
1587 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1588 IF( iinfo.NE.0 ) THEN
1589 WRITE( nounit, fmt = 9998 )'ZHBEVX(V,V,' // uplo //
1590 $ ')', iinfo, n, kd, jtype, ioldsd
1591 info = abs( iinfo )
1592 IF( iinfo.LT.0 ) THEN
1593 RETURN
1594 ELSE
1595 result( ntest ) = ulpinv
1596 result( ntest+1 ) = ulpinv
1597 result( ntest+2 ) = ulpinv
1598 GO TO 930
1599 END IF
1600 END IF
1601*
1602* Do tests 34 and 35.
1603*
1604 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1605 $ v, ldu, tau, work, rwork, result( ntest ) )
1606*
1607 ntest = ntest + 2
1608*
1609 IF( iuplo.EQ.1 ) THEN
1610 DO 900 j = 1, n
1611 DO 890 i = max( 1, j-kd ), j
1612 v( kd+1+i-j, j ) = a( i, j )
1613 890 CONTINUE
1614 900 CONTINUE
1615 ELSE
1616 DO 920 j = 1, n
1617 DO 910 i = j, min( n, j+kd )
1618 v( 1+i-j, j ) = a( i, j )
1619 910 CONTINUE
1620 920 CONTINUE
1621 END IF
1622 CALL zhbevx_2stage( 'N', 'V', uplo, n, kd, v, ldu,
1623 $ u, ldu, vl, vu, il, iu, abstol,
1624 $ m3, wa3, z, ldu, work, lwork,
1625 $ rwork, iwork, iwork( 5*n+1 ), iinfo )
1626 IF( iinfo.NE.0 ) THEN
1627 WRITE( nounit, fmt = 9998 )
1628 $ 'ZHBEVX_2STAGE(N,V,' // uplo //
1629 $ ')', iinfo, n, kd, jtype, ioldsd
1630 info = abs( iinfo )
1631 IF( iinfo.LT.0 ) THEN
1632 RETURN
1633 ELSE
1634 result( ntest ) = ulpinv
1635 GO TO 930
1636 END IF
1637 END IF
1638*
1639 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1640 result( ntest ) = ulpinv
1641 GO TO 930
1642 END IF
1643*
1644* Do test 36.
1645*
1646 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1647 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1648 IF( n.GT.0 ) THEN
1649 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1650 ELSE
1651 temp3 = zero
1652 END IF
1653 result( ntest ) = ( temp1+temp2 ) /
1654 $ max( unfl, temp3*ulp )
1655*
1656 930 CONTINUE
1657*
1658* Call ZHEEV
1659*
1660 CALL zlacpy( ' ', n, n, a, lda, v, ldu )
1661*
1662 ntest = ntest + 1
1663 CALL zheev( 'V', uplo, n, a, ldu, d1, work, lwork, rwork,
1664 $ iinfo )
1665 IF( iinfo.NE.0 ) THEN
1666 WRITE( nounit, fmt = 9999 )'ZHEEV(V,' // uplo // ')',
1667 $ iinfo, n, jtype, ioldsd
1668 info = abs( iinfo )
1669 IF( iinfo.LT.0 ) THEN
1670 RETURN
1671 ELSE
1672 result( ntest ) = ulpinv
1673 result( ntest+1 ) = ulpinv
1674 result( ntest+2 ) = ulpinv
1675 GO TO 950
1676 END IF
1677 END IF
1678*
1679* Do tests 37 and 38
1680*
1681 CALL zhet21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
1682 $ ldu, tau, work, rwork, result( ntest ) )
1683*
1684 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1685*
1686 ntest = ntest + 2
1687 CALL zheev_2stage( 'N', uplo, n, a, ldu, d3,
1688 $ work, lwork, rwork, iinfo )
1689 IF( iinfo.NE.0 ) THEN
1690 WRITE( nounit, fmt = 9999 )
1691 $ 'ZHEEV_2STAGE(N,' // uplo // ')',
1692 $ iinfo, n, jtype, ioldsd
1693 info = abs( iinfo )
1694 IF( iinfo.LT.0 ) THEN
1695 RETURN
1696 ELSE
1697 result( ntest ) = ulpinv
1698 GO TO 950
1699 END IF
1700 END IF
1701*
1702* Do test 39
1703*
1704 temp1 = zero
1705 temp2 = zero
1706 DO 940 j = 1, n
1707 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1708 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1709 940 CONTINUE
1710 result( ntest ) = temp2 / max( unfl,
1711 $ ulp*max( temp1, temp2 ) )
1712*
1713 950 CONTINUE
1714*
1715 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1716*
1717* Call ZHPEV
1718*
1719* Load array WORK with the upper or lower triangular
1720* part of the matrix in packed form.
1721*
1722 IF( iuplo.EQ.1 ) THEN
1723 indx = 1
1724 DO 970 j = 1, n
1725 DO 960 i = 1, j
1726 work( indx ) = a( i, j )
1727 indx = indx + 1
1728 960 CONTINUE
1729 970 CONTINUE
1730 ELSE
1731 indx = 1
1732 DO 990 j = 1, n
1733 DO 980 i = j, n
1734 work( indx ) = a( i, j )
1735 indx = indx + 1
1736 980 CONTINUE
1737 990 CONTINUE
1738 END IF
1739*
1740 ntest = ntest + 1
1741 indwrk = n*( n+1 ) / 2 + 1
1742 CALL zhpev( 'V', uplo, n, work, d1, z, ldu,
1743 $ work( indwrk ), rwork, iinfo )
1744 IF( iinfo.NE.0 ) THEN
1745 WRITE( nounit, fmt = 9999 )'ZHPEV(V,' // uplo // ')',
1746 $ iinfo, n, jtype, ioldsd
1747 info = abs( iinfo )
1748 IF( iinfo.LT.0 ) THEN
1749 RETURN
1750 ELSE
1751 result( ntest ) = ulpinv
1752 result( ntest+1 ) = ulpinv
1753 result( ntest+2 ) = ulpinv
1754 GO TO 1050
1755 END IF
1756 END IF
1757*
1758* Do tests 40 and 41.
1759*
1760 CALL zhet21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
1761 $ ldu, tau, work, rwork, result( ntest ) )
1762*
1763 IF( iuplo.EQ.1 ) THEN
1764 indx = 1
1765 DO 1010 j = 1, n
1766 DO 1000 i = 1, j
1767 work( indx ) = a( i, j )
1768 indx = indx + 1
1769 1000 CONTINUE
1770 1010 CONTINUE
1771 ELSE
1772 indx = 1
1773 DO 1030 j = 1, n
1774 DO 1020 i = j, n
1775 work( indx ) = a( i, j )
1776 indx = indx + 1
1777 1020 CONTINUE
1778 1030 CONTINUE
1779 END IF
1780*
1781 ntest = ntest + 2
1782 indwrk = n*( n+1 ) / 2 + 1
1783 CALL zhpev( 'N', uplo, n, work, d3, z, ldu,
1784 $ work( indwrk ), rwork, iinfo )
1785 IF( iinfo.NE.0 ) THEN
1786 WRITE( nounit, fmt = 9999 )'ZHPEV(N,' // uplo // ')',
1787 $ iinfo, n, jtype, ioldsd
1788 info = abs( iinfo )
1789 IF( iinfo.LT.0 ) THEN
1790 RETURN
1791 ELSE
1792 result( ntest ) = ulpinv
1793 GO TO 1050
1794 END IF
1795 END IF
1796*
1797* Do test 42
1798*
1799 temp1 = zero
1800 temp2 = zero
1801 DO 1040 j = 1, n
1802 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1803 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1804 1040 CONTINUE
1805 result( ntest ) = temp2 / max( unfl,
1806 $ ulp*max( temp1, temp2 ) )
1807*
1808 1050 CONTINUE
1809*
1810* Call ZHBEV
1811*
1812 IF( jtype.LE.7 ) THEN
1813 kd = 0
1814 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
1815 kd = max( n-1, 0 )
1816 ELSE
1817 kd = ihbw
1818 END IF
1819*
1820* Load array V with the upper or lower triangular part
1821* of the matrix in band form.
1822*
1823 IF( iuplo.EQ.1 ) THEN
1824 DO 1070 j = 1, n
1825 DO 1060 i = max( 1, j-kd ), j
1826 v( kd+1+i-j, j ) = a( i, j )
1827 1060 CONTINUE
1828 1070 CONTINUE
1829 ELSE
1830 DO 1090 j = 1, n
1831 DO 1080 i = j, min( n, j+kd )
1832 v( 1+i-j, j ) = a( i, j )
1833 1080 CONTINUE
1834 1090 CONTINUE
1835 END IF
1836*
1837 ntest = ntest + 1
1838 CALL zhbev( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
1839 $ rwork, iinfo )
1840 IF( iinfo.NE.0 ) THEN
1841 WRITE( nounit, fmt = 9998 )'ZHBEV(V,' // uplo // ')',
1842 $ iinfo, n, kd, jtype, ioldsd
1843 info = abs( iinfo )
1844 IF( iinfo.LT.0 ) THEN
1845 RETURN
1846 ELSE
1847 result( ntest ) = ulpinv
1848 result( ntest+1 ) = ulpinv
1849 result( ntest+2 ) = ulpinv
1850 GO TO 1140
1851 END IF
1852 END IF
1853*
1854* Do tests 43 and 44.
1855*
1856 CALL zhet21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
1857 $ ldu, tau, work, rwork, result( ntest ) )
1858*
1859 IF( iuplo.EQ.1 ) THEN
1860 DO 1110 j = 1, n
1861 DO 1100 i = max( 1, j-kd ), j
1862 v( kd+1+i-j, j ) = a( i, j )
1863 1100 CONTINUE
1864 1110 CONTINUE
1865 ELSE
1866 DO 1130 j = 1, n
1867 DO 1120 i = j, min( n, j+kd )
1868 v( 1+i-j, j ) = a( i, j )
1869 1120 CONTINUE
1870 1130 CONTINUE
1871 END IF
1872*
1873 ntest = ntest + 2
1874 CALL zhbev_2stage( 'N', uplo, n, kd, v, ldu, d3, z, ldu,
1875 $ work, lwork, rwork, iinfo )
1876 IF( iinfo.NE.0 ) THEN
1877 WRITE( nounit, fmt = 9998 )
1878 $ 'ZHBEV_2STAGE(N,' // uplo // ')',
1879 $ iinfo, n, kd, jtype, ioldsd
1880 info = abs( iinfo )
1881 IF( iinfo.LT.0 ) THEN
1882 RETURN
1883 ELSE
1884 result( ntest ) = ulpinv
1885 GO TO 1140
1886 END IF
1887 END IF
1888*
1889 1140 CONTINUE
1890*
1891* Do test 45.
1892*
1893 temp1 = zero
1894 temp2 = zero
1895 DO 1150 j = 1, n
1896 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1897 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1898 1150 CONTINUE
1899 result( ntest ) = temp2 / max( unfl,
1900 $ ulp*max( temp1, temp2 ) )
1901*
1902 CALL zlacpy( ' ', n, n, a, lda, v, ldu )
1903 ntest = ntest + 1
1904 CALL zheevr( 'V', 'A', uplo, n, a, ldu, vl, vu, il, iu,
1905 $ abstol, m, wa1, z, ldu, iwork, work, lwork,
1906 $ rwork, lrwork, iwork( 2*n+1 ), liwork-2*n,
1907 $ iinfo )
1908 IF( iinfo.NE.0 ) THEN
1909 WRITE( nounit, fmt = 9999 )'ZHEEVR(V,A,' // uplo //
1910 $ ')', iinfo, n, jtype, ioldsd
1911 info = abs( iinfo )
1912 IF( iinfo.LT.0 ) THEN
1913 RETURN
1914 ELSE
1915 result( ntest ) = ulpinv
1916 result( ntest+1 ) = ulpinv
1917 result( ntest+2 ) = ulpinv
1918 GO TO 1170
1919 END IF
1920 END IF
1921*
1922* Do tests 45 and 46 (or ... )
1923*
1924 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1925*
1926 CALL zhet21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
1927 $ ldu, tau, work, rwork, result( ntest ) )
1928*
1929 ntest = ntest + 2
1930 CALL zheevr_2stage( 'N', 'A', uplo, n, a, ldu, vl, vu,
1931 $ il, iu, abstol, m2, wa2, z, ldu,
1932 $ iwork, work, lwork, rwork, lrwork,
1933 $ iwork( 2*n+1 ), liwork-2*n, iinfo )
1934 IF( iinfo.NE.0 ) THEN
1935 WRITE( nounit, fmt = 9999 )
1936 $ 'ZHEEVR_2STAGE(N,A,' // uplo //
1937 $ ')', iinfo, n, jtype, ioldsd
1938 info = abs( iinfo )
1939 IF( iinfo.LT.0 ) THEN
1940 RETURN
1941 ELSE
1942 result( ntest ) = ulpinv
1943 GO TO 1170
1944 END IF
1945 END IF
1946*
1947* Do test 47 (or ... )
1948*
1949 temp1 = zero
1950 temp2 = zero
1951 DO 1160 j = 1, n
1952 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1953 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1954 1160 CONTINUE
1955 result( ntest ) = temp2 / max( unfl,
1956 $ ulp*max( temp1, temp2 ) )
1957*
1958 1170 CONTINUE
1959*
1960 ntest = ntest + 1
1961 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1962 CALL zheevr( 'V', 'I', uplo, n, a, ldu, vl, vu, il, iu,
1963 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
1964 $ rwork, lrwork, iwork( 2*n+1 ), liwork-2*n,
1965 $ iinfo )
1966 IF( iinfo.NE.0 ) THEN
1967 WRITE( nounit, fmt = 9999 )'ZHEEVR(V,I,' // uplo //
1968 $ ')', iinfo, n, jtype, ioldsd
1969 info = abs( iinfo )
1970 IF( iinfo.LT.0 ) THEN
1971 RETURN
1972 ELSE
1973 result( ntest ) = ulpinv
1974 result( ntest+1 ) = ulpinv
1975 result( ntest+2 ) = ulpinv
1976 GO TO 1180
1977 END IF
1978 END IF
1979*
1980* Do tests 48 and 49 (or +??)
1981*
1982 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1983*
1984 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1985 $ v, ldu, tau, work, rwork, result( ntest ) )
1986*
1987 ntest = ntest + 2
1988 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
1989 CALL zheevr_2stage( 'N', 'I', uplo, n, a, ldu, vl, vu,
1990 $ il, iu, abstol, m3, wa3, z, ldu,
1991 $ iwork, work, lwork, rwork, lrwork,
1992 $ iwork( 2*n+1 ), liwork-2*n, iinfo )
1993 IF( iinfo.NE.0 ) THEN
1994 WRITE( nounit, fmt = 9999 )
1995 $ 'ZHEEVR_2STAGE(N,I,' // uplo //
1996 $ ')', iinfo, n, jtype, ioldsd
1997 info = abs( iinfo )
1998 IF( iinfo.LT.0 ) THEN
1999 RETURN
2000 ELSE
2001 result( ntest ) = ulpinv
2002 GO TO 1180
2003 END IF
2004 END IF
2005*
2006* Do test 50 (or +??)
2007*
2008 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2009 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2010 result( ntest ) = ( temp1+temp2 ) /
2011 $ max( unfl, ulp*temp3 )
2012 1180 CONTINUE
2013*
2014 ntest = ntest + 1
2015 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
2016 CALL zheevr( 'V', 'V', uplo, n, a, ldu, vl, vu, il, iu,
2017 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2018 $ rwork, lrwork, iwork( 2*n+1 ), liwork-2*n,
2019 $ iinfo )
2020 IF( iinfo.NE.0 ) THEN
2021 WRITE( nounit, fmt = 9999 )'ZHEEVR(V,V,' // uplo //
2022 $ ')', iinfo, n, jtype, ioldsd
2023 info = abs( iinfo )
2024 IF( iinfo.LT.0 ) THEN
2025 RETURN
2026 ELSE
2027 result( ntest ) = ulpinv
2028 result( ntest+1 ) = ulpinv
2029 result( ntest+2 ) = ulpinv
2030 GO TO 1190
2031 END IF
2032 END IF
2033*
2034* Do tests 51 and 52 (or +??)
2035*
2036 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
2037*
2038 CALL zhet22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2039 $ v, ldu, tau, work, rwork, result( ntest ) )
2040*
2041 ntest = ntest + 2
2042 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
2043 CALL zheevr_2stage( 'N', 'V', uplo, n, a, ldu, vl, vu,
2044 $ il, iu, abstol, m3, wa3, z, ldu,
2045 $ iwork, work, lwork, rwork, lrwork,
2046 $ iwork( 2*n+1 ), liwork-2*n, iinfo )
2047 IF( iinfo.NE.0 ) THEN
2048 WRITE( nounit, fmt = 9999 )
2049 $ 'ZHEEVR_2STAGE(N,V,' // uplo //
2050 $ ')', iinfo, n, jtype, ioldsd
2051 info = abs( iinfo )
2052 IF( iinfo.LT.0 ) THEN
2053 RETURN
2054 ELSE
2055 result( ntest ) = ulpinv
2056 GO TO 1190
2057 END IF
2058 END IF
2059*
2060 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2061 result( ntest ) = ulpinv
2062 GO TO 1190
2063 END IF
2064*
2065* Do test 52 (or +??)
2066*
2067 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2068 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2069 IF( n.GT.0 ) THEN
2070 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2071 ELSE
2072 temp3 = zero
2073 END IF
2074 result( ntest ) = ( temp1+temp2 ) /
2075 $ max( unfl, temp3*ulp )
2076*
2077 CALL zlacpy( ' ', n, n, v, ldu, a, lda )
2078*
2079*
2080*
2081*
2082* Load array V with the upper or lower triangular part
2083* of the matrix in band form.
2084*
2085 1190 CONTINUE
2086*
2087 1200 CONTINUE
2088*
2089* End of Loop -- Check for RESULT(j) > THRESH
2090*
2091 ntestt = ntestt + ntest
2092 CALL dlafts( 'ZST', n, n, jtype, ntest, result, ioldsd,
2093 $ thresh, nounit, nerrs )
2094*
2095 1210 CONTINUE
2096 1220 CONTINUE
2097*
2098* Summary
2099*
2100 CALL alasvm( 'ZST', nounit, nerrs, ntestt, 0 )
2101*
2102 9999 FORMAT( ' ZDRVST2STG: ', a, ' returned INFO=', i6, / 9x, 'N=', i6,
2103 $ ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2104 9998 FORMAT( ' ZDRVST2STG: ', a, ' returned INFO=', i6, / 9x, 'N=', i6,
2105 $ ', KD=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5,
2106 $ ')' )
2107*
2108 RETURN
2109*
2110* End of ZDRVST2STG
2111*
zheevr_2stage
subroutine zheevr_2stage(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHEEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE mat...
Definition zheevr_2stage.f:406
zheev_2stage
subroutine zheev_2stage(jobz, uplo, n, a, lda, w, work, lwork, rwork, info)
ZHEEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matr...
Definition zheev_2stage.f:189
zheevx_2stage
subroutine zheevx_2stage(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, rwork, iwork, ifail, info)
ZHEEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE mat...
Definition zheevx_2stage.f:306
zheevd_2stage
subroutine zheevd_2stage(jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHEEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE mat...
Definition zheevd_2stage.f:253
zhbevd_2stage
subroutine zhbevd_2stage(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZHBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER ...
Definition zhbevd_2stage.f:260
zhbev_2stage
subroutine zhbev_2stage(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, rwork, info)
ZHBEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER m...
Definition zhbev_2stage.f:211
zhbevx_2stage
subroutine zhbevx_2stage(jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, rwork, iwork, ifail, info)
ZHBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER ...
Definition zhbevx_2stage.f:327

◆ zdrvsx()

subroutine zdrvsx ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer niunit,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) h,
complex*16, dimension( lda, * ) ht,
complex*16, dimension( * ) w,
complex*16, dimension( * ) wt,
complex*16, dimension( * ) wtmp,
complex*16, dimension( ldvs, * ) vs,
integer ldvs,
complex*16, dimension( ldvs, * ) vs1,
double precision, dimension( 17 ) result,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
logical, dimension( * ) bwork,
integer info )

ZDRVSX

Purpose:
!>
!>    ZDRVSX checks the nonsymmetric eigenvalue (Schur form) problem
!>    expert driver ZGEESX.
!>
!>    ZDRVSX uses both test matrices generated randomly depending on
!>    data supplied in the calling sequence, as well as on data
!>    read from an input file and including precomputed condition
!>    numbers to which it compares the ones it computes.
!>
!>    When ZDRVSX is called, a number of matrix  () and a
!>    number of matrix  are specified.  For each size ()
!>    and each type of matrix, one matrix will be generated and used
!>    to test the nonsymmetric eigenroutines.  For each matrix, 15
!>    tests will be performed:
!>
!>    (1)     0 if T is in Schur form, 1/ulp otherwise
!>           (no sorting of eigenvalues)
!>
!>    (2)     | A - VS T VS' | / ( n |A| ulp )
!>
!>      Here VS is the matrix of Schur eigenvectors, and T is in Schur
!>      form  (no sorting of eigenvalues).
!>
!>    (3)     | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
!>
!>    (4)     0     if W are eigenvalues of T
!>            1/ulp otherwise
!>            (no sorting of eigenvalues)
!>
!>    (5)     0     if T(with VS) = T(without VS),
!>            1/ulp otherwise
!>            (no sorting of eigenvalues)
!>
!>    (6)     0     if eigenvalues(with VS) = eigenvalues(without VS),
!>            1/ulp otherwise
!>            (no sorting of eigenvalues)
!>
!>    (7)     0 if T is in Schur form, 1/ulp otherwise
!>            (with sorting of eigenvalues)
!>
!>    (8)     | A - VS T VS' | / ( n |A| ulp )
!>
!>      Here VS is the matrix of Schur eigenvectors, and T is in Schur
!>      form  (with sorting of eigenvalues).
!>
!>    (9)     | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
!>
!>    (10)    0     if W are eigenvalues of T
!>            1/ulp otherwise
!>            If workspace sufficient, also compare W with and
!>            without reciprocal condition numbers
!>            (with sorting of eigenvalues)
!>
!>    (11)    0     if T(with VS) = T(without VS),
!>            1/ulp otherwise
!>            If workspace sufficient, also compare T with and without
!>            reciprocal condition numbers
!>            (with sorting of eigenvalues)
!>
!>    (12)    0     if eigenvalues(with VS) = eigenvalues(without VS),
!>            1/ulp otherwise
!>            If workspace sufficient, also compare VS with and without
!>            reciprocal condition numbers
!>            (with sorting of eigenvalues)
!>
!>    (13)    if sorting worked and SDIM is the number of
!>            eigenvalues which were SELECTed
!>            If workspace sufficient, also compare SDIM with and
!>            without reciprocal condition numbers
!>
!>    (14)    if RCONDE the same no matter if VS and/or RCONDV computed
!>
!>    (15)    if RCONDV the same no matter if VS and/or RCONDE computed
!>
!>    The  are specified by an array NN(1:NSIZES); the value of
!>    each element NN(j) specifies one size.
!>    The  are specified by a logical array DOTYPE( 1:NTYPES );
!>    if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!>    Currently, the list of possible types is:
!>
!>    (1)  The zero matrix.
!>    (2)  The identity matrix.
!>    (3)  A (transposed) Jordan block, with 1's on the diagonal.
!>
!>    (4)  A diagonal matrix with evenly spaced entries
!>         1, ..., ULP  and random complex angles.
!>         (ULP = (first number larger than 1) - 1 )
!>    (5)  A diagonal matrix with geometrically spaced entries
!>         1, ..., ULP  and random complex angles.
!>    (6)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>         and random complex angles.
!>
!>    (7)  Same as (4), but multiplied by a constant near
!>         the overflow threshold
!>    (8)  Same as (4), but multiplied by a constant near
!>         the underflow threshold
!>
!>    (9)  A matrix of the form  U' T U, where U is unitary and
!>         T has evenly spaced entries 1, ..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (10) A matrix of the form  U' T U, where U is unitary and
!>         T has geometrically spaced entries 1, ..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (11) A matrix of the form  U' T U, where U is orthogonal and
!>         T has  entries 1, ULP,..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (12) A matrix of the form  U' T U, where U is unitary and
!>         T has complex eigenvalues randomly chosen from
!>         ULP < |z| < 1   and random O(1) entries in the upper
!>         triangle.
!>
!>    (13) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
!>         with random complex angles on the diagonal and random O(1)
!>         entries in the upper triangle.
!>
!>    (14) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has geometrically spaced entries
!>         1, ..., ULP with random complex angles on the diagonal
!>         and random O(1) entries in the upper triangle.
!>
!>    (15) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has  entries 1, ULP,..., ULP
!>         with random complex angles on the diagonal and random O(1)
!>         entries in the upper triangle.
!>
!>    (16) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has complex eigenvalues randomly chosen
!>         from ULP < |z| < 1 and random O(1) entries in the upper
!>         triangle.
!>
!>    (17) Same as (16), but multiplied by a constant
!>         near the overflow threshold
!>    (18) Same as (16), but multiplied by a constant
!>         near the underflow threshold
!>
!>    (19) Nonsymmetric matrix with random entries chosen from (-1,1).
!>         If N is at least 4, all entries in first two rows and last
!>         row, and first column and last two columns are zero.
!>    (20) Same as (19), but multiplied by a constant
!>         near the overflow threshold
!>    (21) Same as (19), but multiplied by a constant
!>         near the underflow threshold
!>
!>    In addition, an input file will be read from logical unit number
!>    NIUNIT. The file contains matrices along with precomputed
!>    eigenvalues and reciprocal condition numbers for the eigenvalue
!>    average and right invariant subspace. For these matrices, in
!>    addition to tests (1) to (15) we will compute the following two
!>    tests:
!>
!>   (16)  |RCONDE - RCDEIN| / cond(RCONDE)
!>
!>      RCONDE is the reciprocal average eigenvalue condition number
!>      computed by ZGEESX and RCDEIN (the precomputed true value)
!>      is supplied as input.  cond(RCONDE) is the condition number
!>      of RCONDE, and takes errors in computing RCONDE into account,
!>      so that the resulting quantity should be O(ULP). cond(RCONDE)
!>      is essentially given by norm(A)/RCONDV.
!>
!>   (17)  |RCONDV - RCDVIN| / cond(RCONDV)
!>
!>      RCONDV is the reciprocal right invariant subspace condition
!>      number computed by ZGEESX and RCDVIN (the precomputed true
!>      value) is supplied as input. cond(RCONDV) is the condition
!>      number of RCONDV, and takes errors in computing RCONDV into
!>      account, so that the resulting quantity should be O(ULP).
!>      cond(RCONDV) is essentially given by norm(A)/RCONDE.
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  NSIZES must be at
!>          least zero. If it is zero, no randomly generated matrices
!>          are tested, but any test matrices read from NIUNIT will be
!>          tested.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE. NTYPES must be at least
!>          zero. If it is zero, no randomly generated test matrices
!>          are tested, but and test matrices read from NIUNIT will be
!>          tested. If it is MAXTYP+1 and NSIZES is 1, then an
!>          additional type, MAXTYP+1 is defined, which is to use
!>          whatever matrix is in A.  This is only useful if
!>          DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRVSX to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NIUNIT
!>          NIUNIT is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA, max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually used.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, and H. LDA must be at
!>          least 1 and at least max( NN ).
!>
[out]H
!>          H is COMPLEX*16 array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by ZGEESX.
!>
[out]HT
!>          HT is COMPLEX*16 array, dimension (LDA, max(NN))
!>          Yet another copy of the test matrix A, modified by ZGEESX.
!>
[out]W
!>          W is COMPLEX*16 array, dimension (max(NN))
!>          The computed eigenvalues of A.
!>
[out]WT
!>          WT is COMPLEX*16 array, dimension (max(NN))
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when ZGEESX only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]WTMP
!>          WTMP is COMPLEX*16 array, dimension (max(NN))
!>          More temporary storage for eigenvalues.
!>
[out]VS
!>          VS is COMPLEX*16 array, dimension (LDVS, max(NN))
!>          VS holds the computed Schur vectors.
!>
[in]LDVS
!>          LDVS is INTEGER
!>          Leading dimension of VS. Must be at least max(1,max(NN)).
!>
[out]VS1
!>          VS1 is COMPLEX*16 array, dimension (LDVS, max(NN))
!>          VS1 holds another copy of the computed Schur vectors.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (17)
!>          The values computed by the 17 tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          max(1,2*NN(j)**2) for all j.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]BWORK
!>          BWORK is LOGICAL array, dimension (max(NN))
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0,  successful exit.
!>            <0,  input parameter -INFO is incorrect
!>            >0,  ZLATMR, CLATMS, CLATME or ZGET24 returned an error
!>                 code and INFO is its absolute value
!>
!>-----------------------------------------------------------------------
!>
!>     Some Local Variables and Parameters:
!>     ---- ----- --------- --- ----------
!>     ZERO, ONE       Real 0 and 1.
!>     MAXTYP          The number of types defined.
!>     NMAX            Largest value in NN.
!>     NERRS           The number of tests which have exceeded THRESH
!>     COND, CONDS,
!>     IMODE           Values to be passed to the matrix generators.
!>     ANORM           Norm of A; passed to matrix generators.
!>
!>     OVFL, UNFL      Overflow and underflow thresholds.
!>     ULP, ULPINV     Finest relative precision and its inverse.
!>     RTULP, RTULPI   Square roots of the previous 4 values.
!>             The following four arrays decode JTYPE:
!>     KTYPE(j)        The general type (1-10) for type .
!>     KMODE(j)        The MODE value to be passed to the matrix
!>                     generator for type .
!>     KMAGN(j)        The order of magnitude ( O(1),
!>                     O(overflow^(1/2) ), O(underflow^(1/2) )
!>     KCONDS(j)       Selectw whether CONDS is to be 1 or
!>                     1/sqrt(ulp).  (0 means irrelevant.)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 431 of file zdrvsx.f.

435*
436* -- LAPACK test routine --
437* -- LAPACK is a software package provided by Univ. of Tennessee, --
438* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
439*
440* .. Scalar Arguments ..
441 INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES,
442 $ NTYPES
443 DOUBLE PRECISION THRESH
444* ..
445* .. Array Arguments ..
446 LOGICAL BWORK( * ), DOTYPE( * )
447 INTEGER ISEED( 4 ), NN( * )
448 DOUBLE PRECISION RESULT( 17 ), RWORK( * )
449 COMPLEX*16 A( LDA, * ), H( LDA, * ), HT( LDA, * ),
450 $ VS( LDVS, * ), VS1( LDVS, * ), W( * ),
451 $ WORK( * ), WT( * ), WTMP( * )
452* ..
453*
454* =====================================================================
455*
456* .. Parameters ..
457 COMPLEX*16 CZERO
458 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
459 COMPLEX*16 CONE
460 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
461 DOUBLE PRECISION ZERO, ONE
462 parameter( zero = 0.0d+0, one = 1.0d+0 )
463 INTEGER MAXTYP
464 parameter( maxtyp = 21 )
465* ..
466* .. Local Scalars ..
467 LOGICAL BADNN
468 CHARACTER*3 PATH
469 INTEGER I, IINFO, IMODE, ISRT, ITYPE, IWK, J, JCOL,
470 $ JSIZE, JTYPE, MTYPES, N, NERRS, NFAIL, NMAX,
471 $ NNWORK, NSLCT, NTEST, NTESTF, NTESTT
472 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RCDEIN, RCDVIN,
473 $ RTULP, RTULPI, ULP, ULPINV, UNFL
474* ..
475* .. Local Arrays ..
476 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISLCT( 20 ),
477 $ KCONDS( MAXTYP ), KMAGN( MAXTYP ),
478 $ KMODE( MAXTYP ), KTYPE( MAXTYP )
479* ..
480* .. Arrays in Common ..
481 LOGICAL SELVAL( 20 )
482 DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
483* ..
484* .. Scalars in Common ..
485 INTEGER SELDIM, SELOPT
486* ..
487* .. Common blocks ..
488 COMMON / sslct / selopt, seldim, selval, selwr, selwi
489* ..
490* .. External Functions ..
491 DOUBLE PRECISION DLAMCH
492 EXTERNAL dlamch
493* ..
494* .. External Subroutines ..
495 EXTERNAL dlabad, dlasum, xerbla, zget24, zlaset, zlatme,
496 $ zlatmr, zlatms
497* ..
498* .. Intrinsic Functions ..
499 INTRINSIC abs, max, min, sqrt
500* ..
501* .. Data statements ..
502 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
503 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
504 $ 3, 1, 2, 3 /
505 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
506 $ 1, 5, 5, 5, 4, 3, 1 /
507 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
508* ..
509* .. Executable Statements ..
510*
511 path( 1: 1 ) = 'Zomplex precision'
512 path( 2: 3 ) = 'SX'
513*
514* Check for errors
515*
516 ntestt = 0
517 ntestf = 0
518 info = 0
519*
520* Important constants
521*
522 badnn = .false.
523*
524* 8 is the largest dimension in the input file of precomputed
525* problems
526*
527 nmax = 8
528 DO 10 j = 1, nsizes
529 nmax = max( nmax, nn( j ) )
530 IF( nn( j ).LT.0 )
531 $ badnn = .true.
532 10 CONTINUE
533*
534* Check for errors
535*
536 IF( nsizes.LT.0 ) THEN
537 info = -1
538 ELSE IF( badnn ) THEN
539 info = -2
540 ELSE IF( ntypes.LT.0 ) THEN
541 info = -3
542 ELSE IF( thresh.LT.zero ) THEN
543 info = -6
544 ELSE IF( niunit.LE.0 ) THEN
545 info = -7
546 ELSE IF( nounit.LE.0 ) THEN
547 info = -8
548 ELSE IF( lda.LT.1 .OR. lda.LT.nmax ) THEN
549 info = -10
550 ELSE IF( ldvs.LT.1 .OR. ldvs.LT.nmax ) THEN
551 info = -20
552 ELSE IF( max( 3*nmax, 2*nmax**2 ).GT.lwork ) THEN
553 info = -24
554 END IF
555*
556 IF( info.NE.0 ) THEN
557 CALL xerbla( 'ZDRVSX', -info )
558 RETURN
559 END IF
560*
561* If nothing to do check on NIUNIT
562*
563 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
564 $ GO TO 150
565*
566* More Important constants
567*
568 unfl = dlamch( 'Safe minimum' )
569 ovfl = one / unfl
570 CALL dlabad( unfl, ovfl )
571 ulp = dlamch( 'Precision' )
572 ulpinv = one / ulp
573 rtulp = sqrt( ulp )
574 rtulpi = one / rtulp
575*
576* Loop over sizes, types
577*
578 nerrs = 0
579*
580 DO 140 jsize = 1, nsizes
581 n = nn( jsize )
582 IF( nsizes.NE.1 ) THEN
583 mtypes = min( maxtyp, ntypes )
584 ELSE
585 mtypes = min( maxtyp+1, ntypes )
586 END IF
587*
588 DO 130 jtype = 1, mtypes
589 IF( .NOT.dotype( jtype ) )
590 $ GO TO 130
591*
592* Save ISEED in case of an error.
593*
594 DO 20 j = 1, 4
595 ioldsd( j ) = iseed( j )
596 20 CONTINUE
597*
598* Compute "A"
599*
600* Control parameters:
601*
602* KMAGN KCONDS KMODE KTYPE
603* =1 O(1) 1 clustered 1 zero
604* =2 large large clustered 2 identity
605* =3 small exponential Jordan
606* =4 arithmetic diagonal, (w/ eigenvalues)
607* =5 random log symmetric, w/ eigenvalues
608* =6 random general, w/ eigenvalues
609* =7 random diagonal
610* =8 random symmetric
611* =9 random general
612* =10 random triangular
613*
614 IF( mtypes.GT.maxtyp )
615 $ GO TO 90
616*
617 itype = ktype( jtype )
618 imode = kmode( jtype )
619*
620* Compute norm
621*
622 GO TO ( 30, 40, 50 )kmagn( jtype )
623*
624 30 CONTINUE
625 anorm = one
626 GO TO 60
627*
628 40 CONTINUE
629 anorm = ovfl*ulp
630 GO TO 60
631*
632 50 CONTINUE
633 anorm = unfl*ulpinv
634 GO TO 60
635*
636 60 CONTINUE
637*
638 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
639 iinfo = 0
640 cond = ulpinv
641*
642* Special Matrices -- Identity & Jordan block
643*
644 IF( itype.EQ.1 ) THEN
645*
646* Zero
647*
648 iinfo = 0
649*
650 ELSE IF( itype.EQ.2 ) THEN
651*
652* Identity
653*
654 DO 70 jcol = 1, n
655 a( jcol, jcol ) = anorm
656 70 CONTINUE
657*
658 ELSE IF( itype.EQ.3 ) THEN
659*
660* Jordan Block
661*
662 DO 80 jcol = 1, n
663 a( jcol, jcol ) = anorm
664 IF( jcol.GT.1 )
665 $ a( jcol, jcol-1 ) = cone
666 80 CONTINUE
667*
668 ELSE IF( itype.EQ.4 ) THEN
669*
670* Diagonal Matrix, [Eigen]values Specified
671*
672 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
673 $ anorm, 0, 0, 'N', a, lda, work( n+1 ),
674 $ iinfo )
675*
676 ELSE IF( itype.EQ.5 ) THEN
677*
678* Symmetric, eigenvalues specified
679*
680 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
681 $ anorm, n, n, 'N', a, lda, work( n+1 ),
682 $ iinfo )
683*
684 ELSE IF( itype.EQ.6 ) THEN
685*
686* General, eigenvalues specified
687*
688 IF( kconds( jtype ).EQ.1 ) THEN
689 conds = one
690 ELSE IF( kconds( jtype ).EQ.2 ) THEN
691 conds = rtulpi
692 ELSE
693 conds = zero
694 END IF
695*
696 CALL zlatme( n, 'D', iseed, work, imode, cond, cone,
697 $ 'T', 'T', 'T', rwork, 4, conds, n, n, anorm,
698 $ a, lda, work( 2*n+1 ), iinfo )
699*
700 ELSE IF( itype.EQ.7 ) THEN
701*
702* Diagonal, random eigenvalues
703*
704 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
705 $ 'T', 'N', work( n+1 ), 1, one,
706 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
707 $ zero, anorm, 'NO', a, lda, idumma, iinfo )
708*
709 ELSE IF( itype.EQ.8 ) THEN
710*
711* Symmetric, random eigenvalues
712*
713 CALL zlatmr( n, n, 'D', iseed, 'H', work, 6, one, cone,
714 $ 'T', 'N', work( n+1 ), 1, one,
715 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
716 $ zero, anorm, 'NO', a, lda, idumma, iinfo )
717*
718 ELSE IF( itype.EQ.9 ) THEN
719*
720* General, random eigenvalues
721*
722 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
723 $ 'T', 'N', work( n+1 ), 1, one,
724 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
725 $ zero, anorm, 'NO', a, lda, idumma, iinfo )
726 IF( n.GE.4 ) THEN
727 CALL zlaset( 'Full', 2, n, czero, czero, a, lda )
728 CALL zlaset( 'Full', n-3, 1, czero, czero, a( 3, 1 ),
729 $ lda )
730 CALL zlaset( 'Full', n-3, 2, czero, czero,
731 $ a( 3, n-1 ), lda )
732 CALL zlaset( 'Full', 1, n, czero, czero, a( n, 1 ),
733 $ lda )
734 END IF
735*
736 ELSE IF( itype.EQ.10 ) THEN
737*
738* Triangular, random eigenvalues
739*
740 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
741 $ 'T', 'N', work( n+1 ), 1, one,
742 $ work( 2*n+1 ), 1, one, 'N', idumma, n, 0,
743 $ zero, anorm, 'NO', a, lda, idumma, iinfo )
744*
745 ELSE
746*
747 iinfo = 1
748 END IF
749*
750 IF( iinfo.NE.0 ) THEN
751 WRITE( nounit, fmt = 9991 )'Generator', iinfo, n, jtype,
752 $ ioldsd
753 info = abs( iinfo )
754 RETURN
755 END IF
756*
757 90 CONTINUE
758*
759* Test for minimal and generous workspace
760*
761 DO 120 iwk = 1, 2
762 IF( iwk.EQ.1 ) THEN
763 nnwork = 2*n
764 ELSE
765 nnwork = max( 2*n, n*( n+1 ) / 2 )
766 END IF
767 nnwork = max( nnwork, 1 )
768*
769 CALL zget24( .false., jtype, thresh, ioldsd, nounit, n,
770 $ a, lda, h, ht, w, wt, wtmp, vs, ldvs, vs1,
771 $ rcdein, rcdvin, nslct, islct, 0, result,
772 $ work, nnwork, rwork, bwork, info )
773*
774* Check for RESULT(j) > THRESH
775*
776 ntest = 0
777 nfail = 0
778 DO 100 j = 1, 15
779 IF( result( j ).GE.zero )
780 $ ntest = ntest + 1
781 IF( result( j ).GE.thresh )
782 $ nfail = nfail + 1
783 100 CONTINUE
784*
785 IF( nfail.GT.0 )
786 $ ntestf = ntestf + 1
787 IF( ntestf.EQ.1 ) THEN
788 WRITE( nounit, fmt = 9999 )path
789 WRITE( nounit, fmt = 9998 )
790 WRITE( nounit, fmt = 9997 )
791 WRITE( nounit, fmt = 9996 )
792 WRITE( nounit, fmt = 9995 )thresh
793 WRITE( nounit, fmt = 9994 )
794 ntestf = 2
795 END IF
796*
797 DO 110 j = 1, 15
798 IF( result( j ).GE.thresh ) THEN
799 WRITE( nounit, fmt = 9993 )n, iwk, ioldsd, jtype,
800 $ j, result( j )
801 END IF
802 110 CONTINUE
803*
804 nerrs = nerrs + nfail
805 ntestt = ntestt + ntest
806*
807 120 CONTINUE
808 130 CONTINUE
809 140 CONTINUE
810*
811 150 CONTINUE
812*
813* Read in data from file to check accuracy of condition estimation
814* Read input data until N=0
815*
816 jtype = 0
817 160 CONTINUE
818 READ( niunit, fmt = *, END = 200 )N, NSLCT, isrt
819 IF( n.EQ.0 )
820 $ GO TO 200
821 jtype = jtype + 1
822 iseed( 1 ) = jtype
823 READ( niunit, fmt = * )( islct( i ), i = 1, nslct )
824 DO 170 i = 1, n
825 READ( niunit, fmt = * )( a( i, j ), j = 1, n )
826 170 CONTINUE
827 READ( niunit, fmt = * )rcdein, rcdvin
828*
829 CALL zget24( .true., 22, thresh, iseed, nounit, n, a, lda, h, ht,
830 $ w, wt, wtmp, vs, ldvs, vs1, rcdein, rcdvin, nslct,
831 $ islct, isrt, result, work, lwork, rwork, bwork,
832 $ info )
833*
834* Check for RESULT(j) > THRESH
835*
836 ntest = 0
837 nfail = 0
838 DO 180 j = 1, 17
839 IF( result( j ).GE.zero )
840 $ ntest = ntest + 1
841 IF( result( j ).GE.thresh )
842 $ nfail = nfail + 1
843 180 CONTINUE
844*
845 IF( nfail.GT.0 )
846 $ ntestf = ntestf + 1
847 IF( ntestf.EQ.1 ) THEN
848 WRITE( nounit, fmt = 9999 )path
849 WRITE( nounit, fmt = 9998 )
850 WRITE( nounit, fmt = 9997 )
851 WRITE( nounit, fmt = 9996 )
852 WRITE( nounit, fmt = 9995 )thresh
853 WRITE( nounit, fmt = 9994 )
854 ntestf = 2
855 END IF
856 DO 190 j = 1, 17
857 IF( result( j ).GE.thresh ) THEN
858 WRITE( nounit, fmt = 9992 )n, jtype, j, result( j )
859 END IF
860 190 CONTINUE
861*
862 nerrs = nerrs + nfail
863 ntestt = ntestt + ntest
864 GO TO 160
865 200 CONTINUE
866*
867* Summary
868*
869 CALL dlasum( path, nounit, nerrs, ntestt )
870*
871 9999 FORMAT( / 1x, a3, ' -- Complex Schur Form Decomposition Expert ',
872 $ 'Driver', / ' Matrix types (see ZDRVSX for details): ' )
873*
874 9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
875 $ ' ', ' 5=Diagonal: geometr. spaced entries.',
876 $ / ' 2=Identity matrix. ', ' 6=Diagona',
877 $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
878 $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
879 $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
880 $ 'mall, evenly spaced.' )
881 9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
882 $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
883 $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
884 $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
885 $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
886 $ 'lex ', / ' 12=Well-cond., random complex ', ' ',
887 $ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
888 $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
889 $ ' complx ' )
890 9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
891 $ 'with small random entries.', / ' 20=Matrix with large ran',
892 $ 'dom entries. ', / )
893 9995 FORMAT( ' Tests performed with test threshold =', f8.2,
894 $ / ' ( A denotes A on input and T denotes A on output)',
895 $ / / ' 1 = 0 if T in Schur form (no sort), ',
896 $ ' 1/ulp otherwise', /
897 $ ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
898 $ / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ',
899 $ / ' 4 = 0 if W are eigenvalues of T (no sort),',
900 $ ' 1/ulp otherwise', /
901 $ ' 5 = 0 if T same no matter if VS computed (no sort),',
902 $ ' 1/ulp otherwise', /
903 $ ' 6 = 0 if W same no matter if VS computed (no sort)',
904 $ ', 1/ulp otherwise' )
905 9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', ' 1/ulp otherwise',
906 $ / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
907 $ / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
908 $ / ' 10 = 0 if W are eigenvalues of T (sort),',
909 $ ' 1/ulp otherwise', /
910 $ ' 11 = 0 if T same no matter what else computed (sort),',
911 $ ' 1/ulp otherwise', /
912 $ ' 12 = 0 if W same no matter what else computed ',
913 $ '(sort), 1/ulp otherwise', /
914 $ ' 13 = 0 if sorting successful, 1/ulp otherwise',
915 $ / ' 14 = 0 if RCONDE same no matter what else computed,',
916 $ ' 1/ulp otherwise', /
917 $ ' 15 = 0 if RCONDv same no matter what else computed,',
918 $ ' 1/ulp otherwise', /
919 $ ' 16 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),',
920 $ / ' 17 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),' )
921 9993 FORMAT( ' N=', i5, ', IWK=', i2, ', seed=', 4( i4, ',' ),
922 $ ' type ', i2, ', test(', i2, ')=', g10.3 )
923 9992 FORMAT( ' N=', i5, ', input example =', i3, ', test(', i2, ')=',
924 $ g10.3 )
925 9991 FORMAT( ' ZDRVSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
926 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
927*
928 RETURN
929*
930* End of ZDRVSX
931*
zget24
subroutine zget24(comp, jtype, thresh, iseed, nounit, n, a, lda, h, ht, w, wt, wtmp, vs, ldvs, vs1, rcdein, rcdvin, nslct, islct, isrt, result, work, lwork, rwork, bwork, info)
ZGET24
Definition zget24.f:335

◆ zdrvvx()

subroutine zdrvvx ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer niunit,
integer nounit,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) h,
complex*16, dimension( * ) w,
complex*16, dimension( * ) w1,
complex*16, dimension( ldvl, * ) vl,
integer ldvl,
complex*16, dimension( ldvr, * ) vr,
integer ldvr,
complex*16, dimension( ldlre, * ) lre,
integer ldlre,
double precision, dimension( * ) rcondv,
double precision, dimension( * ) rcndv1,
double precision, dimension( * ) rcdvin,
double precision, dimension( * ) rconde,
double precision, dimension( * ) rcnde1,
double precision, dimension( * ) rcdein,
double precision, dimension( * ) scale,
double precision, dimension( * ) scale1,
double precision, dimension( 11 ) result,
complex*16, dimension( * ) work,
integer nwork,
double precision, dimension( * ) rwork,
integer info )

ZDRVVX

Purpose:
!>
!>    ZDRVVX  checks the nonsymmetric eigenvalue problem expert driver
!>    ZGEEVX.
!>
!>    ZDRVVX uses both test matrices generated randomly depending on
!>    data supplied in the calling sequence, as well as on data
!>    read from an input file and including precomputed condition
!>    numbers to which it compares the ones it computes.
!>
!>    When ZDRVVX is called, a number of matrix  () and a
!>    number of matrix  are specified in the calling sequence.
!>    For each size () and each type of matrix, one matrix will be
!>    generated and used to test the nonsymmetric eigenroutines.  For
!>    each matrix, 9 tests will be performed:
!>
!>    (1)     | A * VR - VR * W | / ( n |A| ulp )
!>
!>      Here VR is the matrix of unit right eigenvectors.
!>      W is a diagonal matrix with diagonal entries W(j).
!>
!>    (2)     | A**H  * VL - VL * W**H | / ( n |A| ulp )
!>
!>      Here VL is the matrix of unit left eigenvectors, A**H is the
!>      conjugate transpose of A, and W is as above.
!>
!>    (3)     | |VR(i)| - 1 | / ulp and largest component real
!>
!>      VR(i) denotes the i-th column of VR.
!>
!>    (4)     | |VL(i)| - 1 | / ulp and largest component real
!>
!>      VL(i) denotes the i-th column of VL.
!>
!>    (5)     W(full) = W(partial)
!>
!>      W(full) denotes the eigenvalues computed when VR, VL, RCONDV
!>      and RCONDE are also computed, and W(partial) denotes the
!>      eigenvalues computed when only some of VR, VL, RCONDV, and
!>      RCONDE are computed.
!>
!>    (6)     VR(full) = VR(partial)
!>
!>      VR(full) denotes the right eigenvectors computed when VL, RCONDV
!>      and RCONDE are computed, and VR(partial) denotes the result
!>      when only some of VL and RCONDV are computed.
!>
!>    (7)     VL(full) = VL(partial)
!>
!>      VL(full) denotes the left eigenvectors computed when VR, RCONDV
!>      and RCONDE are computed, and VL(partial) denotes the result
!>      when only some of VR and RCONDV are computed.
!>
!>    (8)     0 if SCALE, ILO, IHI, ABNRM (full) =
!>                 SCALE, ILO, IHI, ABNRM (partial)
!>            1/ulp otherwise
!>
!>      SCALE, ILO, IHI and ABNRM describe how the matrix is balanced.
!>      (full) is when VR, VL, RCONDE and RCONDV are also computed, and
!>      (partial) is when some are not computed.
!>
!>    (9)     RCONDV(full) = RCONDV(partial)
!>
!>      RCONDV(full) denotes the reciprocal condition numbers of the
!>      right eigenvectors computed when VR, VL and RCONDE are also
!>      computed. RCONDV(partial) denotes the reciprocal condition
!>      numbers when only some of VR, VL and RCONDE are computed.
!>
!>    The  are specified by an array NN(1:NSIZES); the value of
!>    each element NN(j) specifies one size.
!>    The  are specified by a logical array DOTYPE( 1:NTYPES );
!>    if DOTYPE(j) is .TRUE., then matrix type  will be generated.
!>    Currently, the list of possible types is:
!>
!>    (1)  The zero matrix.
!>    (2)  The identity matrix.
!>    (3)  A (transposed) Jordan block, with 1's on the diagonal.
!>
!>    (4)  A diagonal matrix with evenly spaced entries
!>         1, ..., ULP  and random complex angles.
!>         (ULP = (first number larger than 1) - 1 )
!>    (5)  A diagonal matrix with geometrically spaced entries
!>         1, ..., ULP  and random complex angles.
!>    (6)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>         and random complex angles.
!>
!>    (7)  Same as (4), but multiplied by a constant near
!>         the overflow threshold
!>    (8)  Same as (4), but multiplied by a constant near
!>         the underflow threshold
!>
!>    (9)  A matrix of the form  U' T U, where U is unitary and
!>         T has evenly spaced entries 1, ..., ULP with random complex
!>         angles on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (10) A matrix of the form  U' T U, where U is unitary and
!>         T has geometrically spaced entries 1, ..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (11) A matrix of the form  U' T U, where U is unitary and
!>         T has  entries 1, ULP,..., ULP with random
!>         complex angles on the diagonal and random O(1) entries in
!>         the upper triangle.
!>
!>    (12) A matrix of the form  U' T U, where U is unitary and
!>         T has complex eigenvalues randomly chosen from
!>         ULP < |z| < 1   and random O(1) entries in the upper
!>         triangle.
!>
!>    (13) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
!>         with random complex angles on the diagonal and random O(1)
!>         entries in the upper triangle.
!>
!>    (14) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has geometrically spaced entries
!>         1, ..., ULP with random complex angles on the diagonal
!>         and random O(1) entries in the upper triangle.
!>
!>    (15) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has  entries 1, ULP,..., ULP
!>         with random complex angles on the diagonal and random O(1)
!>         entries in the upper triangle.
!>
!>    (16) A matrix of the form  X' T X, where X has condition
!>         SQRT( ULP ) and T has complex eigenvalues randomly chosen
!>         from ULP < |z| < 1 and random O(1) entries in the upper
!>         triangle.
!>
!>    (17) Same as (16), but multiplied by a constant
!>         near the overflow threshold
!>    (18) Same as (16), but multiplied by a constant
!>         near the underflow threshold
!>
!>    (19) Nonsymmetric matrix with random entries chosen from |z| < 1
!>         If N is at least 4, all entries in first two rows and last
!>         row, and first column and last two columns are zero.
!>    (20) Same as (19), but multiplied by a constant
!>         near the overflow threshold
!>    (21) Same as (19), but multiplied by a constant
!>         near the underflow threshold
!>
!>    In addition, an input file will be read from logical unit number
!>    NIUNIT. The file contains matrices along with precomputed
!>    eigenvalues and reciprocal condition numbers for the eigenvalues
!>    and right eigenvectors. For these matrices, in addition to tests
!>    (1) to (9) we will compute the following two tests:
!>
!>   (10)  |RCONDV - RCDVIN| / cond(RCONDV)
!>
!>      RCONDV is the reciprocal right eigenvector condition number
!>      computed by ZGEEVX and RCDVIN (the precomputed true value)
!>      is supplied as input. cond(RCONDV) is the condition number of
!>      RCONDV, and takes errors in computing RCONDV into account, so
!>      that the resulting quantity should be O(ULP). cond(RCONDV) is
!>      essentially given by norm(A)/RCONDE.
!>
!>   (11)  |RCONDE - RCDEIN| / cond(RCONDE)
!>
!>      RCONDE is the reciprocal eigenvalue condition number
!>      computed by ZGEEVX and RCDEIN (the precomputed true value)
!>      is supplied as input.  cond(RCONDE) is the condition number
!>      of RCONDE, and takes errors in computing RCONDE into account,
!>      so that the resulting quantity should be O(ULP). cond(RCONDE)
!>      is essentially given by norm(A)/RCONDV.
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  NSIZES must be at
!>          least zero. If it is zero, no randomly generated matrices
!>          are tested, but any test matrices read from NIUNIT will be
!>          tested.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  The values must be at least
!>          zero.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE. NTYPES must be at least
!>          zero. If it is zero, no randomly generated test matrices
!>          are tested, but and test matrices read from NIUNIT will be
!>          tested. If it is MAXTYP+1 and NSIZES is 1, then an
!>          additional type, MAXTYP+1 is defined, which is to use
!>          whatever matrix is in A.  This is only useful if
!>          DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated.  If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096.  Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to ZDRVVX to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NIUNIT
!>          NIUNIT is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA, max(NN,12))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually used.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, and H. LDA must be at
!>          least 1 and at least max( NN, 12 ). (12 is the
!>          dimension of the largest matrix on the precomputed
!>          input file.)
!>
[out]H
!>          H is COMPLEX*16 array, dimension (LDA, max(NN,12))
!>          Another copy of the test matrix A, modified by ZGEEVX.
!>
[out]W
!>          W is COMPLEX*16 array, dimension (max(NN,12))
!>          Contains the eigenvalues of A.
!>
[out]W1
!>          W1 is COMPLEX*16 array, dimension (max(NN,12))
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when ZGEEVX only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is COMPLEX*16 array, dimension (LDVL, max(NN,12))
!>          VL holds the computed left eigenvectors.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          Leading dimension of VL. Must be at least max(1,max(NN,12)).
!>
[out]VR
!>          VR is COMPLEX*16 array, dimension (LDVR, max(NN,12))
!>          VR holds the computed right eigenvectors.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          Leading dimension of VR. Must be at least max(1,max(NN,12)).
!>
[out]LRE
!>          LRE is COMPLEX*16 array, dimension (LDLRE, max(NN,12))
!>          LRE holds the computed right or left eigenvectors.
!>
[in]LDLRE
!>          LDLRE is INTEGER
!>          Leading dimension of LRE. Must be at least max(1,max(NN,12))
!>
[out]RCONDV
!>          RCONDV is DOUBLE PRECISION array, dimension (N)
!>          RCONDV holds the computed reciprocal condition numbers
!>          for eigenvectors.
!>
[out]RCNDV1
!>          RCNDV1 is DOUBLE PRECISION array, dimension (N)
!>          RCNDV1 holds more computed reciprocal condition numbers
!>          for eigenvectors.
!>
[in]RCDVIN
!>          RCDVIN is DOUBLE PRECISION array, dimension (N)
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition numbers for eigenvectors to be compared with
!>          RCONDV.
!>
[out]RCONDE
!>          RCONDE is DOUBLE PRECISION array, dimension (N)
!>          RCONDE holds the computed reciprocal condition numbers
!>          for eigenvalues.
!>
[out]RCNDE1
!>          RCNDE1 is DOUBLE PRECISION array, dimension (N)
!>          RCNDE1 holds more computed reciprocal condition numbers
!>          for eigenvalues.
!>
[in]RCDEIN
!>          RCDEIN is DOUBLE PRECISION array, dimension (N)
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition numbers for eigenvalues to be compared with
!>          RCONDE.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]SCALE1
!>          SCALE1 is DOUBLE PRECISION array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NWORK)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (11)
!>          The values computed by the seven tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[in]NWORK
!>          NWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) =
!>          max(    360     ,6*NN(j)+2*NN(j)**2)    for all j.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*max(NN,12))
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0,  then successful exit.
!>          If <0, then input parameter -INFO is incorrect.
!>          If >0, ZLATMR, CLATMS, CLATME or ZGET23 returned an error
!>                 code, and INFO is its absolute value.
!>
!>-----------------------------------------------------------------------
!>
!>     Some Local Variables and Parameters:
!>     ---- ----- --------- --- ----------
!>
!>     ZERO, ONE       Real 0 and 1.
!>     MAXTYP          The number of types defined.
!>     NMAX            Largest value in NN or 12.
!>     NERRS           The number of tests which have exceeded THRESH
!>     COND, CONDS,
!>     IMODE           Values to be passed to the matrix generators.
!>     ANORM           Norm of A; passed to matrix generators.
!>
!>     OVFL, UNFL      Overflow and underflow thresholds.
!>     ULP, ULPINV     Finest relative precision and its inverse.
!>     RTULP, RTULPI   Square roots of the previous 4 values.
!>
!>             The following four arrays decode JTYPE:
!>     KTYPE(j)        The general type (1-10) for type .
!>     KMODE(j)        The MODE value to be passed to the matrix
!>                     generator for type .
!>     KMAGN(j)        The order of magnitude ( O(1),
!>                     O(overflow^(1/2) ), O(underflow^(1/2) )
!>     KCONDS(j)       Selectw whether CONDS is to be 1 or
!>                     1/sqrt(ulp).  (0 means irrelevant.)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 491 of file zdrvvx.f.

496*
497* -- LAPACK test routine --
498* -- LAPACK is a software package provided by Univ. of Tennessee, --
499* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
500*
501* .. Scalar Arguments ..
502 INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT,
503 $ NSIZES, NTYPES, NWORK
504 DOUBLE PRECISION THRESH
505* ..
506* .. Array Arguments ..
507 LOGICAL DOTYPE( * )
508 INTEGER ISEED( 4 ), NN( * )
509 DOUBLE PRECISION RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
510 $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
511 $ RESULT( 11 ), RWORK( * ), SCALE( * ),
512 $ SCALE1( * )
513 COMPLEX*16 A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
514 $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ),
515 $ WORK( * )
516* ..
517*
518* =====================================================================
519*
520* .. Parameters ..
521 COMPLEX*16 CZERO
522 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
523 COMPLEX*16 CONE
524 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
525 DOUBLE PRECISION ZERO, ONE
526 parameter( zero = 0.0d+0, one = 1.0d+0 )
527 INTEGER MAXTYP
528 parameter( maxtyp = 21 )
529* ..
530* .. Local Scalars ..
531 LOGICAL BADNN
532 CHARACTER BALANC
533 CHARACTER*3 PATH
534 INTEGER I, IBAL, IINFO, IMODE, ISRT, ITYPE, IWK, J,
535 $ JCOL, JSIZE, JTYPE, MTYPES, N, NERRS, NFAIL,
536 $ NMAX, NNWORK, NTEST, NTESTF, NTESTT
537 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
538 $ ULPINV, UNFL, WI, WR
539* ..
540* .. Local Arrays ..
541 CHARACTER BAL( 4 )
542 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
543 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
544 $ KTYPE( MAXTYP )
545* ..
546* .. External Functions ..
547 DOUBLE PRECISION DLAMCH
548 EXTERNAL dlamch
549* ..
550* .. External Subroutines ..
551 EXTERNAL dlabad, dlasum, xerbla, zget23, zlaset, zlatme,
552 $ zlatmr, zlatms
553* ..
554* .. Intrinsic Functions ..
555 INTRINSIC abs, dcmplx, max, min, sqrt
556* ..
557* .. Data statements ..
558 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
559 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
560 $ 3, 1, 2, 3 /
561 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
562 $ 1, 5, 5, 5, 4, 3, 1 /
563 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
564 DATA bal / 'N', 'P', 'S', 'B' /
565* ..
566* .. Executable Statements ..
567*
568 path( 1: 1 ) = 'Zomplex precision'
569 path( 2: 3 ) = 'VX'
570*
571* Check for errors
572*
573 ntestt = 0
574 ntestf = 0
575 info = 0
576*
577* Important constants
578*
579 badnn = .false.
580*
581* 7 is the largest dimension in the input file of precomputed
582* problems
583*
584 nmax = 7
585 DO 10 j = 1, nsizes
586 nmax = max( nmax, nn( j ) )
587 IF( nn( j ).LT.0 )
588 $ badnn = .true.
589 10 CONTINUE
590*
591* Check for errors
592*
593 IF( nsizes.LT.0 ) THEN
594 info = -1
595 ELSE IF( badnn ) THEN
596 info = -2
597 ELSE IF( ntypes.LT.0 ) THEN
598 info = -3
599 ELSE IF( thresh.LT.zero ) THEN
600 info = -6
601 ELSE IF( lda.LT.1 .OR. lda.LT.nmax ) THEN
602 info = -10
603 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax ) THEN
604 info = -15
605 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax ) THEN
606 info = -17
607 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax ) THEN
608 info = -19
609 ELSE IF( 6*nmax+2*nmax**2.GT.nwork ) THEN
610 info = -30
611 END IF
612*
613 IF( info.NE.0 ) THEN
614 CALL xerbla( 'ZDRVVX', -info )
615 RETURN
616 END IF
617*
618* If nothing to do check on NIUNIT
619*
620 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
621 $ GO TO 160
622*
623* More Important constants
624*
625 unfl = dlamch( 'Safe minimum' )
626 ovfl = one / unfl
627 CALL dlabad( unfl, ovfl )
628 ulp = dlamch( 'Precision' )
629 ulpinv = one / ulp
630 rtulp = sqrt( ulp )
631 rtulpi = one / rtulp
632*
633* Loop over sizes, types
634*
635 nerrs = 0
636*
637 DO 150 jsize = 1, nsizes
638 n = nn( jsize )
639 IF( nsizes.NE.1 ) THEN
640 mtypes = min( maxtyp, ntypes )
641 ELSE
642 mtypes = min( maxtyp+1, ntypes )
643 END IF
644*
645 DO 140 jtype = 1, mtypes
646 IF( .NOT.dotype( jtype ) )
647 $ GO TO 140
648*
649* Save ISEED in case of an error.
650*
651 DO 20 j = 1, 4
652 ioldsd( j ) = iseed( j )
653 20 CONTINUE
654*
655* Compute "A"
656*
657* Control parameters:
658*
659* KMAGN KCONDS KMODE KTYPE
660* =1 O(1) 1 clustered 1 zero
661* =2 large large clustered 2 identity
662* =3 small exponential Jordan
663* =4 arithmetic diagonal, (w/ eigenvalues)
664* =5 random log symmetric, w/ eigenvalues
665* =6 random general, w/ eigenvalues
666* =7 random diagonal
667* =8 random symmetric
668* =9 random general
669* =10 random triangular
670*
671 IF( mtypes.GT.maxtyp )
672 $ GO TO 90
673*
674 itype = ktype( jtype )
675 imode = kmode( jtype )
676*
677* Compute norm
678*
679 GO TO ( 30, 40, 50 )kmagn( jtype )
680*
681 30 CONTINUE
682 anorm = one
683 GO TO 60
684*
685 40 CONTINUE
686 anorm = ovfl*ulp
687 GO TO 60
688*
689 50 CONTINUE
690 anorm = unfl*ulpinv
691 GO TO 60
692*
693 60 CONTINUE
694*
695 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
696 iinfo = 0
697 cond = ulpinv
698*
699* Special Matrices -- Identity & Jordan block
700*
701* Zero
702*
703 IF( itype.EQ.1 ) THEN
704 iinfo = 0
705*
706 ELSE IF( itype.EQ.2 ) THEN
707*
708* Identity
709*
710 DO 70 jcol = 1, n
711 a( jcol, jcol ) = anorm
712 70 CONTINUE
713*
714 ELSE IF( itype.EQ.3 ) THEN
715*
716* Jordan Block
717*
718 DO 80 jcol = 1, n
719 a( jcol, jcol ) = anorm
720 IF( jcol.GT.1 )
721 $ a( jcol, jcol-1 ) = one
722 80 CONTINUE
723*
724 ELSE IF( itype.EQ.4 ) THEN
725*
726* Diagonal Matrix, [Eigen]values Specified
727*
728 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
729 $ anorm, 0, 0, 'N', a, lda, work( n+1 ),
730 $ iinfo )
731*
732 ELSE IF( itype.EQ.5 ) THEN
733*
734* Symmetric, eigenvalues specified
735*
736 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
737 $ anorm, n, n, 'N', a, lda, work( n+1 ),
738 $ iinfo )
739*
740 ELSE IF( itype.EQ.6 ) THEN
741*
742* General, eigenvalues specified
743*
744 IF( kconds( jtype ).EQ.1 ) THEN
745 conds = one
746 ELSE IF( kconds( jtype ).EQ.2 ) THEN
747 conds = rtulpi
748 ELSE
749 conds = zero
750 END IF
751*
752 CALL zlatme( n, 'D', iseed, work, imode, cond, cone,
753 $ 'T', 'T', 'T', rwork, 4, conds, n, n, anorm,
754 $ a, lda, work( 2*n+1 ), iinfo )
755*
756 ELSE IF( itype.EQ.7 ) THEN
757*
758* Diagonal, random eigenvalues
759*
760 CALL zlatmr( n, n, 'D', iseed, 'S', work, 6, one, cone,
761 $ 'T', 'N', work( n+1 ), 1, one,
762 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
763 $ zero, anorm, 'NO', a, lda, idumma, iinfo )
764*
765 ELSE IF( itype.EQ.8 ) THEN
766*
767* Symmetric, random eigenvalues
768*
769 CALL zlatmr( n, n, 'D', iseed, 'H', work, 6, one, cone,
770 $ 'T', 'N', work( n+1 ), 1, one,
771 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
772 $ zero, anorm, 'NO', a, lda, idumma, iinfo )
773*
774 ELSE IF( itype.EQ.9 ) THEN
775*
776* General, random eigenvalues
777*
778 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
779 $ 'T', 'N', work( n+1 ), 1, one,
780 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
781 $ zero, anorm, 'NO', a, lda, idumma, iinfo )
782 IF( n.GE.4 ) THEN
783 CALL zlaset( 'Full', 2, n, czero, czero, a, lda )
784 CALL zlaset( 'Full', n-3, 1, czero, czero, a( 3, 1 ),
785 $ lda )
786 CALL zlaset( 'Full', n-3, 2, czero, czero,
787 $ a( 3, n-1 ), lda )
788 CALL zlaset( 'Full', 1, n, czero, czero, a( n, 1 ),
789 $ lda )
790 END IF
791*
792 ELSE IF( itype.EQ.10 ) THEN
793*
794* Triangular, random eigenvalues
795*
796 CALL zlatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
797 $ 'T', 'N', work( n+1 ), 1, one,
798 $ work( 2*n+1 ), 1, one, 'N', idumma, n, 0,
799 $ zero, anorm, 'NO', a, lda, idumma, iinfo )
800*
801 ELSE
802*
803 iinfo = 1
804 END IF
805*
806 IF( iinfo.NE.0 ) THEN
807 WRITE( nounit, fmt = 9992 )'Generator', iinfo, n, jtype,
808 $ ioldsd
809 info = abs( iinfo )
810 RETURN
811 END IF
812*
813 90 CONTINUE
814*
815* Test for minimal and generous workspace
816*
817 DO 130 iwk = 1, 3
818 IF( iwk.EQ.1 ) THEN
819 nnwork = 2*n
820 ELSE IF( iwk.EQ.2 ) THEN
821 nnwork = 2*n + n**2
822 ELSE
823 nnwork = 6*n + 2*n**2
824 END IF
825 nnwork = max( nnwork, 1 )
826*
827* Test for all balancing options
828*
829 DO 120 ibal = 1, 4
830 balanc = bal( ibal )
831*
832* Perform tests
833*
834 CALL zget23( .false., 0, balanc, jtype, thresh,
835 $ ioldsd, nounit, n, a, lda, h, w, w1, vl,
836 $ ldvl, vr, ldvr, lre, ldlre, rcondv,
837 $ rcndv1, rcdvin, rconde, rcnde1, rcdein,
838 $ scale, scale1, result, work, nnwork,
839 $ rwork, info )
840*
841* Check for RESULT(j) > THRESH
842*
843 ntest = 0
844 nfail = 0
845 DO 100 j = 1, 9
846 IF( result( j ).GE.zero )
847 $ ntest = ntest + 1
848 IF( result( j ).GE.thresh )
849 $ nfail = nfail + 1
850 100 CONTINUE
851*
852 IF( nfail.GT.0 )
853 $ ntestf = ntestf + 1
854 IF( ntestf.EQ.1 ) THEN
855 WRITE( nounit, fmt = 9999 )path
856 WRITE( nounit, fmt = 9998 )
857 WRITE( nounit, fmt = 9997 )
858 WRITE( nounit, fmt = 9996 )
859 WRITE( nounit, fmt = 9995 )thresh
860 ntestf = 2
861 END IF
862*
863 DO 110 j = 1, 9
864 IF( result( j ).GE.thresh ) THEN
865 WRITE( nounit, fmt = 9994 )balanc, n, iwk,
866 $ ioldsd, jtype, j, result( j )
867 END IF
868 110 CONTINUE
869*
870 nerrs = nerrs + nfail
871 ntestt = ntestt + ntest
872*
873 120 CONTINUE
874 130 CONTINUE
875 140 CONTINUE
876 150 CONTINUE
877*
878 160 CONTINUE
879*
880* Read in data from file to check accuracy of condition estimation.
881* Assume input eigenvalues are sorted lexicographically (increasing
882* by real part, then decreasing by imaginary part)
883*
884 jtype = 0
885 170 CONTINUE
886 READ( niunit, fmt = *, END = 220 )N, isrt
887*
888* Read input data until N=0
889*
890 IF( n.EQ.0 )
891 $ GO TO 220
892 jtype = jtype + 1
893 iseed( 1 ) = jtype
894 DO 180 i = 1, n
895 READ( niunit, fmt = * )( a( i, j ), j = 1, n )
896 180 CONTINUE
897 DO 190 i = 1, n
898 READ( niunit, fmt = * )wr, wi, rcdein( i ), rcdvin( i )
899 w1( i ) = dcmplx( wr, wi )
900 190 CONTINUE
901 CALL zget23( .true., isrt, 'N', 22, thresh, iseed, nounit, n, a,
902 $ lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre,
903 $ rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein,
904 $ scale, scale1, result, work, 6*n+2*n**2, rwork,
905 $ info )
906*
907* Check for RESULT(j) > THRESH
908*
909 ntest = 0
910 nfail = 0
911 DO 200 j = 1, 11
912 IF( result( j ).GE.zero )
913 $ ntest = ntest + 1
914 IF( result( j ).GE.thresh )
915 $ nfail = nfail + 1
916 200 CONTINUE
917*
918 IF( nfail.GT.0 )
919 $ ntestf = ntestf + 1
920 IF( ntestf.EQ.1 ) THEN
921 WRITE( nounit, fmt = 9999 )path
922 WRITE( nounit, fmt = 9998 )
923 WRITE( nounit, fmt = 9997 )
924 WRITE( nounit, fmt = 9996 )
925 WRITE( nounit, fmt = 9995 )thresh
926 ntestf = 2
927 END IF
928*
929 DO 210 j = 1, 11
930 IF( result( j ).GE.thresh ) THEN
931 WRITE( nounit, fmt = 9993 )n, jtype, j, result( j )
932 END IF
933 210 CONTINUE
934*
935 nerrs = nerrs + nfail
936 ntestt = ntestt + ntest
937 GO TO 170
938 220 CONTINUE
939*
940* Summary
941*
942 CALL dlasum( path, nounit, nerrs, ntestt )
943*
944 9999 FORMAT( / 1x, a3, ' -- Complex Eigenvalue-Eigenvector ',
945 $ 'Decomposition Expert Driver',
946 $ / ' Matrix types (see ZDRVVX for details): ' )
947*
948 9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
949 $ ' ', ' 5=Diagonal: geometr. spaced entries.',
950 $ / ' 2=Identity matrix. ', ' 6=Diagona',
951 $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
952 $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
953 $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
954 $ 'mall, evenly spaced.' )
955 9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
956 $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
957 $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
958 $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
959 $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
960 $ 'lex ', / ' 12=Well-cond., random complex ', ' ',
961 $ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
962 $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
963 $ ' complx ' )
964 9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
965 $ 'with small random entries.', / ' 20=Matrix with large ran',
966 $ 'dom entries. ', ' 22=Matrix read from input file', / )
967 9995 FORMAT( ' Tests performed with test threshold =', f8.2,
968 $ / / ' 1 = | A VR - VR W | / ( n |A| ulp ) ',
969 $ / ' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
970 $ / ' 3 = | |VR(i)| - 1 | / ulp ',
971 $ / ' 4 = | |VL(i)| - 1 | / ulp ',
972 $ / ' 5 = 0 if W same no matter if VR or VL computed,',
973 $ ' 1/ulp otherwise', /
974 $ ' 6 = 0 if VR same no matter what else computed,',
975 $ ' 1/ulp otherwise', /
976 $ ' 7 = 0 if VL same no matter what else computed,',
977 $ ' 1/ulp otherwise', /
978 $ ' 8 = 0 if RCONDV same no matter what else computed,',
979 $ ' 1/ulp otherwise', /
980 $ ' 9 = 0 if SCALE, ILO, IHI, ABNRM same no matter what else',
981 $ ' computed, 1/ulp otherwise',
982 $ / ' 10 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),',
983 $ / ' 11 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),' )
984 9994 FORMAT( ' BALANC=''', a1, ''',N=', i4, ',IWK=', i1, ', seed=',
985 $ 4( i4, ',' ), ' type ', i2, ', test(', i2, ')=', g10.3 )
986 9993 FORMAT( ' N=', i5, ', input example =', i3, ', test(', i2, ')=',
987 $ g10.3 )
988 9992 FORMAT( ' ZDRVVX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
989 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
990*
991 RETURN
992*
993* End of ZDRVVX
994*
zget23
subroutine zget23(comp, isrt, balanc, jtype, thresh, iseed, nounit, n, a, lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein, scale, scale1, result, work, lwork, rwork, info)
ZGET23
Definition zget23.f:368

◆ zerrbd()

subroutine zerrbd ( character*3 path,
integer nunit )

ZERRBD

Purpose:
!>
!> ZERRBD tests the error exits for ZGEBRD, ZUNGBR, ZUNMBR, and ZBDSQR.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 53 of file zerrbd.f.

54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 CHARACTER*3 PATH
61 INTEGER NUNIT
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 INTEGER NMAX, LW
68 parameter( nmax = 4, lw = nmax )
69* ..
70* .. Local Scalars ..
71 CHARACTER*2 C2
72 INTEGER I, INFO, J, NT
73* ..
74* .. Local Arrays ..
75 DOUBLE PRECISION D( NMAX ), E( NMAX ), RW( 4*NMAX )
76 COMPLEX*16 A( NMAX, NMAX ), TP( NMAX ), TQ( NMAX ),
77 $ U( NMAX, NMAX ), V( NMAX, NMAX ), W( LW )
78* ..
79* .. External Functions ..
80 LOGICAL LSAMEN
81 EXTERNAL lsamen
82* ..
83* .. External Subroutines ..
84 EXTERNAL chkxer, zbdsqr, zgebrd, zungbr, zunmbr
85* ..
86* .. Scalars in Common ..
87 LOGICAL LERR, OK
88 CHARACTER*32 SRNAMT
89 INTEGER INFOT, NOUT
90* ..
91* .. Common blocks ..
92 COMMON / infoc / infot, nout, ok, lerr
93 COMMON / srnamc / srnamt
94* ..
95* .. Intrinsic Functions ..
96 INTRINSIC dble
97* ..
98* .. Executable Statements ..
99*
100 nout = nunit
101 WRITE( nout, fmt = * )
102 c2 = path( 2: 3 )
103*
104* Set the variables to innocuous values.
105*
106 DO 20 j = 1, nmax
107 DO 10 i = 1, nmax
108 a( i, j ) = 1.d0 / dble( i+j )
109 10 CONTINUE
110 20 CONTINUE
111 ok = .true.
112 nt = 0
113*
114* Test error exits of the SVD routines.
115*
116 IF( lsamen( 2, c2, 'BD' ) ) THEN
117*
118* ZGEBRD
119*
120 srnamt = 'ZGEBRD'
121 infot = 1
122 CALL zgebrd( -1, 0, a, 1, d, e, tq, tp, w, 1, info )
123 CALL chkxer( 'ZGEBRD', infot, nout, lerr, ok )
124 infot = 2
125 CALL zgebrd( 0, -1, a, 1, d, e, tq, tp, w, 1, info )
126 CALL chkxer( 'ZGEBRD', infot, nout, lerr, ok )
127 infot = 4
128 CALL zgebrd( 2, 1, a, 1, d, e, tq, tp, w, 2, info )
129 CALL chkxer( 'ZGEBRD', infot, nout, lerr, ok )
130 infot = 10
131 CALL zgebrd( 2, 1, a, 2, d, e, tq, tp, w, 1, info )
132 CALL chkxer( 'ZGEBRD', infot, nout, lerr, ok )
133 nt = nt + 4
134*
135* ZUNGBR
136*
137 srnamt = 'ZUNGBR'
138 infot = 1
139 CALL zungbr( '/', 0, 0, 0, a, 1, tq, w, 1, info )
140 CALL chkxer( 'ZUNGBR', infot, nout, lerr, ok )
141 infot = 2
142 CALL zungbr( 'Q', -1, 0, 0, a, 1, tq, w, 1, info )
143 CALL chkxer( 'ZUNGBR', infot, nout, lerr, ok )
144 infot = 3
145 CALL zungbr( 'Q', 0, -1, 0, a, 1, tq, w, 1, info )
146 CALL chkxer( 'ZUNGBR', infot, nout, lerr, ok )
147 infot = 3
148 CALL zungbr( 'Q', 0, 1, 0, a, 1, tq, w, 1, info )
149 CALL chkxer( 'ZUNGBR', infot, nout, lerr, ok )
150 infot = 3
151 CALL zungbr( 'Q', 1, 0, 1, a, 1, tq, w, 1, info )
152 CALL chkxer( 'ZUNGBR', infot, nout, lerr, ok )
153 infot = 3
154 CALL zungbr( 'P', 1, 0, 0, a, 1, tq, w, 1, info )
155 CALL chkxer( 'ZUNGBR', infot, nout, lerr, ok )
156 infot = 3
157 CALL zungbr( 'P', 0, 1, 1, a, 1, tq, w, 1, info )
158 CALL chkxer( 'ZUNGBR', infot, nout, lerr, ok )
159 infot = 4
160 CALL zungbr( 'Q', 0, 0, -1, a, 1, tq, w, 1, info )
161 CALL chkxer( 'ZUNGBR', infot, nout, lerr, ok )
162 infot = 6
163 CALL zungbr( 'Q', 2, 1, 1, a, 1, tq, w, 1, info )
164 CALL chkxer( 'ZUNGBR', infot, nout, lerr, ok )
165 infot = 9
166 CALL zungbr( 'Q', 2, 2, 1, a, 2, tq, w, 1, info )
167 CALL chkxer( 'ZUNGBR', infot, nout, lerr, ok )
168 nt = nt + 10
169*
170* ZUNMBR
171*
172 srnamt = 'ZUNMBR'
173 infot = 1
174 CALL zunmbr( '/', 'L', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
175 $ info )
176 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
177 infot = 2
178 CALL zunmbr( 'Q', '/', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
179 $ info )
180 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
181 infot = 3
182 CALL zunmbr( 'Q', 'L', '/', 0, 0, 0, a, 1, tq, u, 1, w, 1,
183 $ info )
184 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
185 infot = 4
186 CALL zunmbr( 'Q', 'L', 'C', -1, 0, 0, a, 1, tq, u, 1, w, 1,
187 $ info )
188 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
189 infot = 5
190 CALL zunmbr( 'Q', 'L', 'C', 0, -1, 0, a, 1, tq, u, 1, w, 1,
191 $ info )
192 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
193 infot = 6
194 CALL zunmbr( 'Q', 'L', 'C', 0, 0, -1, a, 1, tq, u, 1, w, 1,
195 $ info )
196 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
197 infot = 8
198 CALL zunmbr( 'Q', 'L', 'C', 2, 0, 0, a, 1, tq, u, 2, w, 1,
199 $ info )
200 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
201 infot = 8
202 CALL zunmbr( 'Q', 'R', 'C', 0, 2, 0, a, 1, tq, u, 1, w, 1,
203 $ info )
204 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
205 infot = 8
206 CALL zunmbr( 'P', 'L', 'C', 2, 0, 2, a, 1, tq, u, 2, w, 1,
207 $ info )
208 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
209 infot = 8
210 CALL zunmbr( 'P', 'R', 'C', 0, 2, 2, a, 1, tq, u, 1, w, 1,
211 $ info )
212 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
213 infot = 11
214 CALL zunmbr( 'Q', 'R', 'C', 2, 0, 0, a, 1, tq, u, 1, w, 1,
215 $ info )
216 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
217 infot = 13
218 CALL zunmbr( 'Q', 'L', 'C', 0, 2, 0, a, 1, tq, u, 1, w, 0,
219 $ info )
220 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
221 infot = 13
222 CALL zunmbr( 'Q', 'R', 'C', 2, 0, 0, a, 1, tq, u, 2, w, 0,
223 $ info )
224 CALL chkxer( 'ZUNMBR', infot, nout, lerr, ok )
225 nt = nt + 13
226*
227* ZBDSQR
228*
229 srnamt = 'ZBDSQR'
230 infot = 1
231 CALL zbdsqr( '/', 0, 0, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
232 $ info )
233 CALL chkxer( 'ZBDSQR', infot, nout, lerr, ok )
234 infot = 2
235 CALL zbdsqr( 'U', -1, 0, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
236 $ info )
237 CALL chkxer( 'ZBDSQR', infot, nout, lerr, ok )
238 infot = 3
239 CALL zbdsqr( 'U', 0, -1, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
240 $ info )
241 CALL chkxer( 'ZBDSQR', infot, nout, lerr, ok )
242 infot = 4
243 CALL zbdsqr( 'U', 0, 0, -1, 0, d, e, v, 1, u, 1, a, 1, rw,
244 $ info )
245 CALL chkxer( 'ZBDSQR', infot, nout, lerr, ok )
246 infot = 5
247 CALL zbdsqr( 'U', 0, 0, 0, -1, d, e, v, 1, u, 1, a, 1, rw,
248 $ info )
249 CALL chkxer( 'ZBDSQR', infot, nout, lerr, ok )
250 infot = 9
251 CALL zbdsqr( 'U', 2, 1, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
252 $ info )
253 CALL chkxer( 'ZBDSQR', infot, nout, lerr, ok )
254 infot = 11
255 CALL zbdsqr( 'U', 0, 0, 2, 0, d, e, v, 1, u, 1, a, 1, rw,
256 $ info )
257 CALL chkxer( 'ZBDSQR', infot, nout, lerr, ok )
258 infot = 13
259 CALL zbdsqr( 'U', 2, 0, 0, 1, d, e, v, 1, u, 1, a, 1, rw,
260 $ info )
261 CALL chkxer( 'ZBDSQR', infot, nout, lerr, ok )
262 nt = nt + 8
263 END IF
264*
265* Print a summary line.
266*
267 IF( ok ) THEN
268 WRITE( nout, fmt = 9999 )path, nt
269 ELSE
270 WRITE( nout, fmt = 9998 )path
271 END IF
272*
273 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits (',
274 $ i3, ' tests done)' )
275 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
276 $ 'exits ***' )
277*
278 RETURN
279*
280* End of ZERRBD
281*
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3196
lsamen
logical function lsamen(n, ca, cb)
LSAMEN
Definition lsamen.f:74
zunmbr
subroutine zunmbr(vect, side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMBR
Definition zunmbr.f:196

◆ zerrec()

subroutine zerrec ( character*3 path,
integer nunit )

ZERREC

Purpose:
!>
!> ZERREC tests the error exits for the routines for eigen- condition
!> estimation for DOUBLE PRECISION matrices:
!>    ZTRSYL, ZTREXC, ZTRSNA and ZTRSEN.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 55 of file zerrec.f.

56*
57* -- LAPACK test routine --
58* -- LAPACK is a software package provided by Univ. of Tennessee, --
59* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
60*
61* .. Scalar Arguments ..
62 CHARACTER*3 PATH
63 INTEGER NUNIT
64* ..
65*
66* =====================================================================
67*
68* .. Parameters ..
69 INTEGER NMAX, LW
70 parameter( nmax = 4, lw = nmax*( nmax+2 ) )
71 DOUBLE PRECISION ONE, ZERO
72 parameter( one = 1.0d0, zero = 0.0d0 )
73* ..
74* .. Local Scalars ..
75 INTEGER I, IFST, ILST, INFO, J, M, NT
76 DOUBLE PRECISION SCALE
77* ..
78* .. Local Arrays ..
79 LOGICAL SEL( NMAX )
80 DOUBLE PRECISION RW( LW ), S( NMAX ), SEP( NMAX )
81 COMPLEX*16 A( NMAX, NMAX ), B( NMAX, NMAX ),
82 $ C( NMAX, NMAX ), WORK( LW ), X( NMAX )
83* ..
84* .. External Subroutines ..
85 EXTERNAL chkxer, ztrexc, ztrsen, ztrsna, ztrsyl
86* ..
87* .. Scalars in Common ..
88 LOGICAL LERR, OK
89 CHARACTER*32 SRNAMT
90 INTEGER INFOT, NOUT
91* ..
92* .. Common blocks ..
93 COMMON / infoc / infot, nout, ok, lerr
94 COMMON / srnamc / srnamt
95* ..
96* .. Executable Statements ..
97*
98 nout = nunit
99 ok = .true.
100 nt = 0
101*
102* Initialize A, B and SEL
103*
104 DO 20 j = 1, nmax
105 DO 10 i = 1, nmax
106 a( i, j ) = zero
107 b( i, j ) = zero
108 10 CONTINUE
109 20 CONTINUE
110 DO 30 i = 1, nmax
111 a( i, i ) = one
112 sel( i ) = .true.
113 30 CONTINUE
114*
115* Test ZTRSYL
116*
117 srnamt = 'ZTRSYL'
118 infot = 1
119 CALL ztrsyl( 'X', 'N', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
120 CALL chkxer( 'ZTRSYL', infot, nout, lerr, ok )
121 infot = 2
122 CALL ztrsyl( 'N', 'X', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
123 CALL chkxer( 'ZTRSYL', infot, nout, lerr, ok )
124 infot = 3
125 CALL ztrsyl( 'N', 'N', 0, 0, 0, a, 1, b, 1, c, 1, scale, info )
126 CALL chkxer( 'ZTRSYL', infot, nout, lerr, ok )
127 infot = 4
128 CALL ztrsyl( 'N', 'N', 1, -1, 0, a, 1, b, 1, c, 1, scale, info )
129 CALL chkxer( 'ZTRSYL', infot, nout, lerr, ok )
130 infot = 5
131 CALL ztrsyl( 'N', 'N', 1, 0, -1, a, 1, b, 1, c, 1, scale, info )
132 CALL chkxer( 'ZTRSYL', infot, nout, lerr, ok )
133 infot = 7
134 CALL ztrsyl( 'N', 'N', 1, 2, 0, a, 1, b, 1, c, 2, scale, info )
135 CALL chkxer( 'ZTRSYL', infot, nout, lerr, ok )
136 infot = 9
137 CALL ztrsyl( 'N', 'N', 1, 0, 2, a, 1, b, 1, c, 1, scale, info )
138 CALL chkxer( 'ZTRSYL', infot, nout, lerr, ok )
139 infot = 11
140 CALL ztrsyl( 'N', 'N', 1, 2, 0, a, 2, b, 1, c, 1, scale, info )
141 CALL chkxer( 'ZTRSYL', infot, nout, lerr, ok )
142 nt = nt + 8
143*
144* Test ZTREXC
145*
146 srnamt = 'ZTREXC'
147 ifst = 1
148 ilst = 1
149 infot = 1
150 CALL ztrexc( 'X', 1, a, 1, b, 1, ifst, ilst, info )
151 CALL chkxer( 'ZTREXC', infot, nout, lerr, ok )
152 infot = 2
153 CALL ztrexc( 'N', -1, a, 1, b, 1, ifst, ilst, info )
154 CALL chkxer( 'ZTREXC', infot, nout, lerr, ok )
155 infot = 4
156 ilst = 2
157 CALL ztrexc( 'N', 2, a, 1, b, 1, ifst, ilst, info )
158 CALL chkxer( 'ZTREXC', infot, nout, lerr, ok )
159 infot = 6
160 CALL ztrexc( 'V', 2, a, 2, b, 1, ifst, ilst, info )
161 CALL chkxer( 'ZTREXC', infot, nout, lerr, ok )
162 infot = 7
163 ifst = 0
164 ilst = 1
165 CALL ztrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
166 CALL chkxer( 'ZTREXC', infot, nout, lerr, ok )
167 infot = 7
168 ifst = 2
169 CALL ztrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
170 CALL chkxer( 'ZTREXC', infot, nout, lerr, ok )
171 infot = 8
172 ifst = 1
173 ilst = 0
174 CALL ztrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
175 CALL chkxer( 'ZTREXC', infot, nout, lerr, ok )
176 infot = 8
177 ilst = 2
178 CALL ztrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
179 CALL chkxer( 'ZTREXC', infot, nout, lerr, ok )
180 nt = nt + 8
181*
182* Test ZTRSNA
183*
184 srnamt = 'ZTRSNA'
185 infot = 1
186 CALL ztrsna( 'X', 'A', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
187 $ work, 1, rw, info )
188 CALL chkxer( 'ZTRSNA', infot, nout, lerr, ok )
189 infot = 2
190 CALL ztrsna( 'B', 'X', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
191 $ work, 1, rw, info )
192 CALL chkxer( 'ZTRSNA', infot, nout, lerr, ok )
193 infot = 4
194 CALL ztrsna( 'B', 'A', sel, -1, a, 1, b, 1, c, 1, s, sep, 1, m,
195 $ work, 1, rw, info )
196 CALL chkxer( 'ZTRSNA', infot, nout, lerr, ok )
197 infot = 6
198 CALL ztrsna( 'V', 'A', sel, 2, a, 1, b, 1, c, 1, s, sep, 2, m,
199 $ work, 2, rw, info )
200 CALL chkxer( 'ZTRSNA', infot, nout, lerr, ok )
201 infot = 8
202 CALL ztrsna( 'B', 'A', sel, 2, a, 2, b, 1, c, 2, s, sep, 2, m,
203 $ work, 2, rw, info )
204 CALL chkxer( 'ZTRSNA', infot, nout, lerr, ok )
205 infot = 10
206 CALL ztrsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 1, s, sep, 2, m,
207 $ work, 2, rw, info )
208 CALL chkxer( 'ZTRSNA', infot, nout, lerr, ok )
209 infot = 13
210 CALL ztrsna( 'B', 'A', sel, 1, a, 1, b, 1, c, 1, s, sep, 0, m,
211 $ work, 1, rw, info )
212 CALL chkxer( 'ZTRSNA', infot, nout, lerr, ok )
213 infot = 13
214 CALL ztrsna( 'B', 'S', sel, 2, a, 2, b, 2, c, 2, s, sep, 1, m,
215 $ work, 1, rw, info )
216 CALL chkxer( 'ZTRSNA', infot, nout, lerr, ok )
217 infot = 16
218 CALL ztrsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 2, s, sep, 2, m,
219 $ work, 1, rw, info )
220 CALL chkxer( 'ZTRSNA', infot, nout, lerr, ok )
221 nt = nt + 9
222*
223* Test ZTRSEN
224*
225 sel( 1 ) = .false.
226 srnamt = 'ZTRSEN'
227 infot = 1
228 CALL ztrsen( 'X', 'N', sel, 0, a, 1, b, 1, x, m, s( 1 ), sep( 1 ),
229 $ work, 1, info )
230 CALL chkxer( 'ZTRSEN', infot, nout, lerr, ok )
231 infot = 2
232 CALL ztrsen( 'N', 'X', sel, 0, a, 1, b, 1, x, m, s( 1 ), sep( 1 ),
233 $ work, 1, info )
234 CALL chkxer( 'ZTRSEN', infot, nout, lerr, ok )
235 infot = 4
236 CALL ztrsen( 'N', 'N', sel, -1, a, 1, b, 1, x, m, s( 1 ),
237 $ sep( 1 ), work, 1, info )
238 CALL chkxer( 'ZTRSEN', infot, nout, lerr, ok )
239 infot = 6
240 CALL ztrsen( 'N', 'N', sel, 2, a, 1, b, 1, x, m, s( 1 ), sep( 1 ),
241 $ work, 2, info )
242 CALL chkxer( 'ZTRSEN', infot, nout, lerr, ok )
243 infot = 8
244 CALL ztrsen( 'N', 'V', sel, 2, a, 2, b, 1, x, m, s( 1 ), sep( 1 ),
245 $ work, 1, info )
246 CALL chkxer( 'ZTRSEN', infot, nout, lerr, ok )
247 infot = 14
248 CALL ztrsen( 'N', 'V', sel, 2, a, 2, b, 2, x, m, s( 1 ), sep( 1 ),
249 $ work, 0, info )
250 CALL chkxer( 'ZTRSEN', infot, nout, lerr, ok )
251 infot = 14
252 CALL ztrsen( 'E', 'V', sel, 3, a, 3, b, 3, x, m, s( 1 ), sep( 1 ),
253 $ work, 1, info )
254 CALL chkxer( 'ZTRSEN', infot, nout, lerr, ok )
255 infot = 14
256 CALL ztrsen( 'V', 'V', sel, 3, a, 3, b, 3, x, m, s( 1 ), sep( 1 ),
257 $ work, 3, info )
258 CALL chkxer( 'ZTRSEN', infot, nout, lerr, ok )
259 nt = nt + 8
260*
261* Print a summary line.
262*
263 IF( ok ) THEN
264 WRITE( nout, fmt = 9999 )path, nt
265 ELSE
266 WRITE( nout, fmt = 9998 )path
267 END IF
268*
269 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits (',
270 $ i3, ' tests done)' )
271 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
272 $ 'exits ***' )
273 RETURN
274*
275* End of ZERREC
276*
ztrexc
subroutine ztrexc(compq, n, t, ldt, q, ldq, ifst, ilst, info)
ZTREXC
Definition ztrexc.f:126
ztrsen
subroutine ztrsen(job, compq, select, n, t, ldt, q, ldq, w, m, s, sep, work, lwork, info)
ZTRSEN
Definition ztrsen.f:264
ztrsna
subroutine ztrsna(job, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, s, sep, mm, m, work, ldwork, rwork, info)
ZTRSNA
Definition ztrsna.f:249
ztrsyl
subroutine ztrsyl(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
ZTRSYL
Definition ztrsyl.f:157

◆ zerred()

subroutine zerred ( character*3 path,
integer nunit )

ZERRED

Purpose:
!>
!> ZERRED tests the error exits for the eigenvalue driver routines for
!> DOUBLE COMPLEX PRECISION matrices:
!>
!> PATH  driver   description
!> ----  ------   -----------
!> ZEV   ZGEEV    find eigenvalues/eigenvectors for nonsymmetric A
!> ZES   ZGEES    find eigenvalues/Schur form for nonsymmetric A
!> ZVX   ZGEEVX   ZGEEV + balancing and condition estimation
!> ZSX   ZGEESX   ZGEES + balancing and condition estimation
!> ZBD   ZGESVD   compute SVD of an M-by-N matrix A
!>       ZGESDD   compute SVD of an M-by-N matrix A(by divide and
!>                conquer)
!>       ZGEJSV   compute SVD of an M-by-N matrix A where M >= N
!>       ZGESVDX  compute SVD of an M-by-N matrix A(by bisection
!>                and inverse iteration)
!>       ZGESVDQ  compute SVD of an M-by-N matrix A(with a 
!>                QR-Preconditioned )
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 69 of file zerred.f.

70*
71* -- LAPACK test routine --
72* -- LAPACK is a software package provided by Univ. of Tennessee, --
73* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
74*
75* .. Scalar Arguments ..
76 CHARACTER*3 PATH
77 INTEGER NUNIT
78* ..
79*
80* =====================================================================
81*
82* .. Parameters ..
83 INTEGER NMAX, LW
84 parameter( nmax = 4, lw = 5*nmax )
85 DOUBLE PRECISION ONE, ZERO
86 parameter( one = 1.0d0, zero = 0.0d0 )
87* ..
88* .. Local Scalars ..
89 CHARACTER*2 C2
90 INTEGER I, IHI, ILO, INFO, J, NS, NT, SDIM
91 DOUBLE PRECISION ABNRM
92* ..
93* .. Local Arrays ..
94 LOGICAL B( NMAX )
95 INTEGER IW( 4*NMAX )
96 DOUBLE PRECISION R1( NMAX ), R2( NMAX ), RW( LW ), S( NMAX )
97 COMPLEX*16 A( NMAX, NMAX ), U( NMAX, NMAX ),
98 $ VL( NMAX, NMAX ), VR( NMAX, NMAX ),
99 $ VT( NMAX, NMAX ), W( 10*NMAX ), X( NMAX )
100* ..
101* .. External Subroutines ..
102 EXTERNAL chkxer, zgees, zgeesx, zgeev, zgeevx, zgesvj,
103 $ zgesdd, zgesvd, zgesvdx, zgesvq
104* ..
105* .. External Functions ..
106 LOGICAL LSAMEN, ZSLECT
107 EXTERNAL lsamen, zslect
108* ..
109* .. Intrinsic Functions ..
110 INTRINSIC len_trim
111* ..
112* .. Arrays in Common ..
113 LOGICAL SELVAL( 20 )
114 DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
115* ..
116* .. Scalars in Common ..
117 LOGICAL LERR, OK
118 CHARACTER*32 SRNAMT
119 INTEGER INFOT, NOUT, SELDIM, SELOPT
120* ..
121* .. Common blocks ..
122 COMMON / infoc / infot, nout, ok, lerr
123 COMMON / srnamc / srnamt
124 COMMON / sslct / selopt, seldim, selval, selwr, selwi
125* ..
126* .. Executable Statements ..
127*
128 nout = nunit
129 WRITE( nout, fmt = * )
130 c2 = path( 2: 3 )
131*
132* Initialize A
133*
134 DO 20 j = 1, nmax
135 DO 10 i = 1, nmax
136 a( i, j ) = zero
137 10 CONTINUE
138 20 CONTINUE
139 DO 30 i = 1, nmax
140 a( i, i ) = one
141 30 CONTINUE
142 ok = .true.
143 nt = 0
144*
145 IF( lsamen( 2, c2, 'EV' ) ) THEN
146*
147* Test ZGEEV
148*
149 srnamt = 'ZGEEV '
150 infot = 1
151 CALL zgeev( 'X', 'N', 0, a, 1, x, vl, 1, vr, 1, w, 1, rw,
152 $ info )
153 CALL chkxer( 'ZGEEV ', infot, nout, lerr, ok )
154 infot = 2
155 CALL zgeev( 'N', 'X', 0, a, 1, x, vl, 1, vr, 1, w, 1, rw,
156 $ info )
157 CALL chkxer( 'ZGEEV ', infot, nout, lerr, ok )
158 infot = 3
159 CALL zgeev( 'N', 'N', -1, a, 1, x, vl, 1, vr, 1, w, 1, rw,
160 $ info )
161 CALL chkxer( 'ZGEEV ', infot, nout, lerr, ok )
162 infot = 5
163 CALL zgeev( 'N', 'N', 2, a, 1, x, vl, 1, vr, 1, w, 4, rw,
164 $ info )
165 CALL chkxer( 'ZGEEV ', infot, nout, lerr, ok )
166 infot = 8
167 CALL zgeev( 'V', 'N', 2, a, 2, x, vl, 1, vr, 1, w, 4, rw,
168 $ info )
169 CALL chkxer( 'ZGEEV ', infot, nout, lerr, ok )
170 infot = 10
171 CALL zgeev( 'N', 'V', 2, a, 2, x, vl, 1, vr, 1, w, 4, rw,
172 $ info )
173 CALL chkxer( 'ZGEEV ', infot, nout, lerr, ok )
174 infot = 12
175 CALL zgeev( 'V', 'V', 1, a, 1, x, vl, 1, vr, 1, w, 1, rw,
176 $ info )
177 CALL chkxer( 'ZGEEV ', infot, nout, lerr, ok )
178 nt = nt + 7
179*
180 ELSE IF( lsamen( 2, c2, 'ES' ) ) THEN
181*
182* Test ZGEES
183*
184 srnamt = 'ZGEES '
185 infot = 1
186 CALL zgees( 'X', 'N', zslect, 0, a, 1, sdim, x, vl, 1, w, 1,
187 $ rw, b, info )
188 CALL chkxer( 'ZGEES ', infot, nout, lerr, ok )
189 infot = 2
190 CALL zgees( 'N', 'X', zslect, 0, a, 1, sdim, x, vl, 1, w, 1,
191 $ rw, b, info )
192 CALL chkxer( 'ZGEES ', infot, nout, lerr, ok )
193 infot = 4
194 CALL zgees( 'N', 'S', zslect, -1, a, 1, sdim, x, vl, 1, w, 1,
195 $ rw, b, info )
196 CALL chkxer( 'ZGEES ', infot, nout, lerr, ok )
197 infot = 6
198 CALL zgees( 'N', 'S', zslect, 2, a, 1, sdim, x, vl, 1, w, 4,
199 $ rw, b, info )
200 CALL chkxer( 'ZGEES ', infot, nout, lerr, ok )
201 infot = 10
202 CALL zgees( 'V', 'S', zslect, 2, a, 2, sdim, x, vl, 1, w, 4,
203 $ rw, b, info )
204 CALL chkxer( 'ZGEES ', infot, nout, lerr, ok )
205 infot = 12
206 CALL zgees( 'N', 'S', zslect, 1, a, 1, sdim, x, vl, 1, w, 1,
207 $ rw, b, info )
208 CALL chkxer( 'ZGEES ', infot, nout, lerr, ok )
209 nt = nt + 6
210*
211 ELSE IF( lsamen( 2, c2, 'VX' ) ) THEN
212*
213* Test ZGEEVX
214*
215 srnamt = 'ZGEEVX'
216 infot = 1
217 CALL zgeevx( 'X', 'N', 'N', 'N', 0, a, 1, x, vl, 1, vr, 1, ilo,
218 $ ihi, s, abnrm, r1, r2, w, 1, rw, info )
219 CALL chkxer( 'ZGEEVX', infot, nout, lerr, ok )
220 infot = 2
221 CALL zgeevx( 'N', 'X', 'N', 'N', 0, a, 1, x, vl, 1, vr, 1, ilo,
222 $ ihi, s, abnrm, r1, r2, w, 1, rw, info )
223 CALL chkxer( 'ZGEEVX', infot, nout, lerr, ok )
224 infot = 3
225 CALL zgeevx( 'N', 'N', 'X', 'N', 0, a, 1, x, vl, 1, vr, 1, ilo,
226 $ ihi, s, abnrm, r1, r2, w, 1, rw, info )
227 CALL chkxer( 'ZGEEVX', infot, nout, lerr, ok )
228 infot = 4
229 CALL zgeevx( 'N', 'N', 'N', 'X', 0, a, 1, x, vl, 1, vr, 1, ilo,
230 $ ihi, s, abnrm, r1, r2, w, 1, rw, info )
231 CALL chkxer( 'ZGEEVX', infot, nout, lerr, ok )
232 infot = 5
233 CALL zgeevx( 'N', 'N', 'N', 'N', -1, a, 1, x, vl, 1, vr, 1,
234 $ ilo, ihi, s, abnrm, r1, r2, w, 1, rw, info )
235 CALL chkxer( 'ZGEEVX', infot, nout, lerr, ok )
236 infot = 7
237 CALL zgeevx( 'N', 'N', 'N', 'N', 2, a, 1, x, vl, 1, vr, 1, ilo,
238 $ ihi, s, abnrm, r1, r2, w, 4, rw, info )
239 CALL chkxer( 'ZGEEVX', infot, nout, lerr, ok )
240 infot = 10
241 CALL zgeevx( 'N', 'V', 'N', 'N', 2, a, 2, x, vl, 1, vr, 1, ilo,
242 $ ihi, s, abnrm, r1, r2, w, 4, rw, info )
243 CALL chkxer( 'ZGEEVX', infot, nout, lerr, ok )
244 infot = 12
245 CALL zgeevx( 'N', 'N', 'V', 'N', 2, a, 2, x, vl, 1, vr, 1, ilo,
246 $ ihi, s, abnrm, r1, r2, w, 4, rw, info )
247 CALL chkxer( 'ZGEEVX', infot, nout, lerr, ok )
248 infot = 20
249 CALL zgeevx( 'N', 'N', 'N', 'N', 1, a, 1, x, vl, 1, vr, 1, ilo,
250 $ ihi, s, abnrm, r1, r2, w, 1, rw, info )
251 CALL chkxer( 'ZGEEVX', infot, nout, lerr, ok )
252 infot = 20
253 CALL zgeevx( 'N', 'N', 'V', 'V', 1, a, 1, x, vl, 1, vr, 1, ilo,
254 $ ihi, s, abnrm, r1, r2, w, 2, rw, info )
255 CALL chkxer( 'ZGEEVX', infot, nout, lerr, ok )
256 nt = nt + 10
257*
258 ELSE IF( lsamen( 2, c2, 'SX' ) ) THEN
259*
260* Test ZGEESX
261*
262 srnamt = 'ZGEESX'
263 infot = 1
264 CALL zgeesx( 'X', 'N', zslect, 'N', 0, a, 1, sdim, x, vl, 1,
265 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
266 CALL chkxer( 'ZGEESX', infot, nout, lerr, ok )
267 infot = 2
268 CALL zgeesx( 'N', 'X', zslect, 'N', 0, a, 1, sdim, x, vl, 1,
269 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
270 CALL chkxer( 'ZGEESX', infot, nout, lerr, ok )
271 infot = 4
272 CALL zgeesx( 'N', 'N', zslect, 'X', 0, a, 1, sdim, x, vl, 1,
273 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
274 CALL chkxer( 'ZGEESX', infot, nout, lerr, ok )
275 infot = 5
276 CALL zgeesx( 'N', 'N', zslect, 'N', -1, a, 1, sdim, x, vl, 1,
277 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
278 CALL chkxer( 'ZGEESX', infot, nout, lerr, ok )
279 infot = 7
280 CALL zgeesx( 'N', 'N', zslect, 'N', 2, a, 1, sdim, x, vl, 1,
281 $ r1( 1 ), r2( 1 ), w, 4, rw, b, info )
282 CALL chkxer( 'ZGEESX', infot, nout, lerr, ok )
283 infot = 11
284 CALL zgeesx( 'V', 'N', zslect, 'N', 2, a, 2, sdim, x, vl, 1,
285 $ r1( 1 ), r2( 1 ), w, 4, rw, b, info )
286 CALL chkxer( 'ZGEESX', infot, nout, lerr, ok )
287 infot = 15
288 CALL zgeesx( 'N', 'N', zslect, 'N', 1, a, 1, sdim, x, vl, 1,
289 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
290 CALL chkxer( 'ZGEESX', infot, nout, lerr, ok )
291 nt = nt + 7
292*
293 ELSE IF( lsamen( 2, c2, 'BD' ) ) THEN
294*
295* Test ZGESVD
296*
297 srnamt = 'ZGESVD'
298 infot = 1
299 CALL zgesvd( 'X', 'N', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
300 $ info )
301 CALL chkxer( 'ZGESVD', infot, nout, lerr, ok )
302 infot = 2
303 CALL zgesvd( 'N', 'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
304 $ info )
305 CALL chkxer( 'ZGESVD', infot, nout, lerr, ok )
306 infot = 2
307 CALL zgesvd( 'O', 'O', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
308 $ info )
309 CALL chkxer( 'ZGESVD', infot, nout, lerr, ok )
310 infot = 3
311 CALL zgesvd( 'N', 'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
312 $ info )
313 CALL chkxer( 'ZGESVD', infot, nout, lerr, ok )
314 infot = 4
315 CALL zgesvd( 'N', 'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, rw,
316 $ info )
317 CALL chkxer( 'ZGESVD', infot, nout, lerr, ok )
318 infot = 6
319 CALL zgesvd( 'N', 'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, rw,
320 $ info )
321 CALL chkxer( 'ZGESVD', infot, nout, lerr, ok )
322 infot = 9
323 CALL zgesvd( 'A', 'N', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, rw,
324 $ info )
325 CALL chkxer( 'ZGESVD', infot, nout, lerr, ok )
326 infot = 11
327 CALL zgesvd( 'N', 'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, rw,
328 $ info )
329 CALL chkxer( 'ZGESVD', infot, nout, lerr, ok )
330 nt = nt + 8
331 IF( ok ) THEN
332 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
333 $ nt
334 ELSE
335 WRITE( nout, fmt = 9998 )
336 END IF
337*
338* Test ZGESDD
339*
340 srnamt = 'ZGESDD'
341 infot = 1
342 CALL zgesdd( 'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw, iw,
343 $ info )
344 CALL chkxer( 'ZGESDD', infot, nout, lerr, ok )
345 infot = 2
346 CALL zgesdd( 'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, rw, iw,
347 $ info )
348 CALL chkxer( 'ZGESDD', infot, nout, lerr, ok )
349 infot = 3
350 CALL zgesdd( 'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, rw, iw,
351 $ info )
352 CALL chkxer( 'ZGESDD', infot, nout, lerr, ok )
353 infot = 5
354 CALL zgesdd( 'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, rw, iw,
355 $ info )
356 CALL chkxer( 'ZGESDD', infot, nout, lerr, ok )
357 infot = 8
358 CALL zgesdd( 'A', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, rw, iw,
359 $ info )
360 CALL chkxer( 'ZGESDD', infot, nout, lerr, ok )
361 infot = 10
362 CALL zgesdd( 'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, rw, iw,
363 $ info )
364 CALL chkxer( 'ZGESDD', infot, nout, lerr, ok )
365 nt = nt - 2
366 IF( ok ) THEN
367 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
368 $ nt
369 ELSE
370 WRITE( nout, fmt = 9998 )
371 END IF
372*
373* Test ZGEJSV
374*
375 srnamt = 'ZGEJSV'
376 infot = 1
377 CALL zgejsv( 'X', 'U', 'V', 'R', 'N', 'N',
378 $ 0, 0, a, 1, s, u, 1, vt, 1,
379 $ w, 1, rw, 1, iw, info)
380 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
381 infot = 2
382 CALL zgejsv( 'G', 'X', 'V', 'R', 'N', 'N',
383 $ 0, 0, a, 1, s, u, 1, vt, 1,
384 $ w, 1, rw, 1, iw, info)
385 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
386 infot = 3
387 CALL zgejsv( 'G', 'U', 'X', 'R', 'N', 'N',
388 $ 0, 0, a, 1, s, u, 1, vt, 1,
389 $ w, 1, rw, 1, iw, info)
390 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
391 infot = 4
392 CALL zgejsv( 'G', 'U', 'V', 'X', 'N', 'N',
393 $ 0, 0, a, 1, s, u, 1, vt, 1,
394 $ w, 1, rw, 1, iw, info)
395 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
396 infot = 5
397 CALL zgejsv( 'G', 'U', 'V', 'R', 'X', 'N',
398 $ 0, 0, a, 1, s, u, 1, vt, 1,
399 $ w, 1, rw, 1, iw, info)
400 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
401 infot = 6
402 CALL zgejsv( 'G', 'U', 'V', 'R', 'N', 'X',
403 $ 0, 0, a, 1, s, u, 1, vt, 1,
404 $ w, 1, rw, 1, iw, info)
405 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
406 infot = 7
407 CALL zgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
408 $ -1, 0, a, 1, s, u, 1, vt, 1,
409 $ w, 1, rw, 1, iw, info)
410 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
411 infot = 8
412 CALL zgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
413 $ 0, -1, a, 1, s, u, 1, vt, 1,
414 $ w, 1, rw, 1, iw, info)
415 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
416 infot = 10
417 CALL zgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
418 $ 2, 1, a, 1, s, u, 1, vt, 1,
419 $ w, 1, rw, 1, iw, info)
420 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
421 infot = 13
422 CALL zgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
423 $ 2, 2, a, 2, s, u, 1, vt, 2,
424 $ w, 1, rw, 1, iw, info)
425 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
426 infot = 15
427 CALL zgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
428 $ 2, 2, a, 2, s, u, 2, vt, 1,
429 $ w, 1, rw, 1, iw, info)
430 CALL chkxer( 'ZGEJSV', infot, nout, lerr, ok )
431 nt = 11
432 IF( ok ) THEN
433 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
434 $ nt
435 ELSE
436 WRITE( nout, fmt = 9998 )
437 END IF
438*
439* Test ZGESVDX
440*
441 srnamt = 'ZGESVDX'
442 infot = 1
443 CALL zgesvdx( 'X', 'N', 'A', 0, 0, a, 1, zero, zero,
444 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
445 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
446 infot = 2
447 CALL zgesvdx( 'N', 'X', 'A', 0, 0, a, 1, zero, zero,
448 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
449 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
450 infot = 3
451 CALL zgesvdx( 'N', 'N', 'X', 0, 0, a, 1, zero, zero,
452 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
453 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
454 infot = 4
455 CALL zgesvdx( 'N', 'N', 'A', -1, 0, a, 1, zero, zero,
456 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
457 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
458 infot = 5
459 CALL zgesvdx( 'N', 'N', 'A', 0, -1, a, 1, zero, zero,
460 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
461 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
462 infot = 7
463 CALL zgesvdx( 'N', 'N', 'A', 2, 1, a, 1, zero, zero,
464 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
465 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
466 infot = 8
467 CALL zgesvdx( 'N', 'N', 'V', 2, 1, a, 2, -one, zero,
468 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
469 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
470 infot = 9
471 CALL zgesvdx( 'N', 'N', 'V', 2, 1, a, 2, one, zero,
472 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
473 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
474 infot = 10
475 CALL zgesvdx( 'N', 'N', 'I', 2, 2, a, 2, zero, zero,
476 $ 0, 1, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
477 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
478 infot = 11
479 CALL zgesvdx( 'V', 'N', 'I', 2, 2, a, 2, zero, zero,
480 $ 1, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
481 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
482 infot = 15
483 CALL zgesvdx( 'V', 'N', 'A', 2, 2, a, 2, zero, zero,
484 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
485 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
486 infot = 17
487 CALL zgesvdx( 'N', 'V', 'A', 2, 2, a, 2, zero, zero,
488 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
489 CALL chkxer( 'ZGESVDX', infot, nout, lerr, ok )
490 nt = 12
491 IF( ok ) THEN
492 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
493 $ nt
494 ELSE
495 WRITE( nout, fmt = 9998 )
496 END IF
497*
498* Test ZGESVDQ
499*
500 srnamt = 'ZGESVDQ'
501 infot = 1
502 CALL zgesvdq( 'X', 'P', 'T', 'A', 'A', 0, 0, a, 1, s, u,
503 $ 0, vt, 0, ns, iw, 1, w, 1, rw, 1, info )
504 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
505 infot = 2
506 CALL zgesvdq( 'A', 'X', 'T', 'A', 'A', 0, 0, a, 1, s, u,
507 $ 0, vt, 0, ns, iw, 1, w, 1, rw, 1, info )
508 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
509 infot = 3
510 CALL zgesvdq( 'A', 'P', 'X', 'A', 'A', 0, 0, a, 1, s, u,
511 $ 0, vt, 0, ns, iw, 1, w, 1, rw, 1, info )
512 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
513 infot = 4
514 CALL zgesvdq( 'A', 'P', 'T', 'X', 'A', 0, 0, a, 1, s, u,
515 $ 0, vt, 0, ns, iw, 1, w, 1, rw, 1, info )
516 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
517 infot = 5
518 CALL zgesvdq( 'A', 'P', 'T', 'A', 'X', 0, 0, a, 1, s, u,
519 $ 0, vt, 0, ns, iw, 1, w, 1, rw, 1, info )
520 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
521 infot = 6
522 CALL zgesvdq( 'A', 'P', 'T', 'A', 'A', -1, 0, a, 1, s, u,
523 $ 0, vt, 0, ns, iw, 1, w, 1, rw, 1, info )
524 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
525 infot = 7
526 CALL zgesvdq( 'A', 'P', 'T', 'A', 'A', 0, 1, a, 1, s, u,
527 $ 0, vt, 0, ns, iw, 1, w, 1, rw, 1, info )
528 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
529 infot = 9
530 CALL zgesvdq( 'A', 'P', 'T', 'A', 'A', 1, 1, a, 0, s, u,
531 $ 0, vt, 0, ns, iw, 1, w, 1, rw, 1, info )
532 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
533 infot = 12
534 CALL zgesvdq( 'A', 'P', 'T', 'A', 'A', 1, 1, a, 1, s, u,
535 $ -1, vt, 0, ns, iw, 1, w, 1, rw, 1, info )
536 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
537 infot = 14
538 CALL zgesvdq( 'A', 'P', 'T', 'A', 'A', 1, 1, a, 1, s, u,
539 $ 1, vt, -1, ns, iw, 1, w, 1, rw, 1, info )
540 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
541 infot = 17
542 CALL zgesvdq( 'A', 'P', 'T', 'A', 'A', 1, 1, a, 1, s, u,
543 $ 1, vt, 1, ns, iw, -5, w, 1, rw, 1, info )
544 CALL chkxer( 'ZGESVDQ', infot, nout, lerr, ok )
545 nt = 11
546 IF( ok ) THEN
547 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
548 $ nt
549 ELSE
550 WRITE( nout, fmt = 9998 )
551 END IF
552 END IF
553*
554* Print a summary line.
555*
556 IF( .NOT.lsamen( 2, c2, 'BD' ) ) THEN
557 IF( ok ) THEN
558 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
559 $ nt
560 ELSE
561 WRITE( nout, fmt = 9998 )
562 END IF
563 END IF
564*
565 9999 FORMAT( 1x, a, ' passed the tests of the error exits (', i3,
566 $ ' tests done)' )
567 9998 FORMAT( ' *** ', a, ' failed the tests of the error exits ***' )
568 RETURN
569*
570* End of ZERRED
571*
zgeesx
subroutine zgeesx(jobvs, sort, select, sense, n, a, lda, sdim, w, vs, ldvs, rconde, rcondv, work, lwork, rwork, bwork, info)
ZGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition zgeesx.f:239
zgeevx
subroutine zgeevx(balanc, jobvl, jobvr, sense, n, a, lda, w, vl, ldvl, vr, ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, work, lwork, rwork, info)
ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition zgeevx.f:288

◆ zerrgg()

subroutine zerrgg ( character*3 path,
integer nunit )

ZERRGG

Purpose:
!>
!> ZERRGG tests the error exits for ZGGES, ZGGESX, ZGGEV, ZGGEVX,
!> ZGGES3, ZGGEV3, ZGGGLM, ZGGHRD, ZGGLSE, ZGGQRF, ZGGRQF,
!> ZGGSVD3, ZGGSVP3, ZHGEQZ, ZTGEVC, ZTGEXC, ZTGSEN, ZTGSJA,
!> ZTGSNA, ZTGSYL, and ZUNCSD.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 56 of file zerrgg.f.

57*
58* -- LAPACK test routine --
59* -- LAPACK is a software package provided by Univ. of Tennessee, --
60* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
61*
62* .. Scalar Arguments ..
63 CHARACTER*3 PATH
64 INTEGER NUNIT
65* ..
66*
67* =====================================================================
68*
69* .. Parameters ..
70 INTEGER NMAX, LW
71 parameter( nmax = 3, lw = 6*nmax )
72 DOUBLE PRECISION ONE, ZERO
73 parameter( one = 1.0d+0, zero = 0.0d+0 )
74* ..
75* .. Local Scalars ..
76 CHARACTER*2 C2
77 INTEGER DUMMYK, DUMMYL, I, IFST, IHI, ILO, ILST, INFO,
78 $ J, M, NCYCLE, NT, SDIM, LWORK
79 DOUBLE PRECISION ANRM, BNRM, DIF, SCALE, TOLA, TOLB
80* ..
81* .. Local Arrays ..
82 LOGICAL BW( NMAX ), SEL( NMAX )
83 INTEGER IW( LW ), IDUM(NMAX)
84 DOUBLE PRECISION LS( NMAX ), R1( NMAX ), R2( NMAX ),
85 $ RCE( NMAX ), RCV( NMAX ), RS( NMAX ), RW( LW )
86 COMPLEX*16 A( NMAX, NMAX ), ALPHA( NMAX ),
87 $ B( NMAX, NMAX ), BETA( NMAX ), Q( NMAX, NMAX ),
88 $ TAU( NMAX ), U( NMAX, NMAX ), V( NMAX, NMAX ),
89 $ W( LW ), Z( NMAX, NMAX )
90* ..
91* .. External Functions ..
92 LOGICAL LSAMEN, ZLCTES, ZLCTSX
93 EXTERNAL lsamen, zlctes, zlctsx
94* ..
95* .. External Subroutines ..
96 EXTERNAL chkxer, zgges, zggesx, zggev, zggevx, zggglm,
97 $ zgghrd, zgglse, zggqrf, zggrqf,
98 $ zhgeqz, ztgevc, ztgexc, ztgsen, ztgsja, ztgsna,
99 $ ztgsyl, zuncsd, zgges3, zggev3, zgghd3,
100 $ zggsvd3, zggsvp3, xlaenv
101* ..
102* .. Scalars in Common ..
103 LOGICAL LERR, OK
104 CHARACTER*32 SRNAMT
105 INTEGER INFOT, NOUT
106* ..
107* .. Common blocks ..
108 COMMON / infoc / infot, nout, ok, lerr
109 COMMON / srnamc / srnamt
110* ..
111* .. Executable Statements ..
112*
113 nout = nunit
114 WRITE( nout, fmt = * )
115 c2 = path( 2: 3 )
116*
117* Set the variables to innocuous values.
118*
119 DO 20 j = 1, nmax
120 sel( j ) = .true.
121 DO 10 i = 1, nmax
122 a( i, j ) = zero
123 b( i, j ) = zero
124 10 CONTINUE
125 20 CONTINUE
126 DO 30 i = 1, nmax
127 a( i, i ) = one
128 b( i, i ) = one
129 30 CONTINUE
130 ok = .true.
131 tola = 1.0d0
132 tolb = 1.0d0
133 ifst = 1
134 ilst = 1
135 nt = 0
136 lwork = 1
137*
138* Call XLAENV to set the parameters used in CLAQZ0
139*
140 CALL xlaenv( 12, 10 )
141 CALL xlaenv( 13, 12 )
142 CALL xlaenv( 14, 13 )
143 CALL xlaenv( 15, 2 )
144 CALL xlaenv( 17, 10 )
145*
146* Test error exits for the GG path.
147*
148 IF( lsamen( 2, c2, 'GG' ) ) THEN
149*
150* ZGGHRD
151*
152 srnamt = 'ZGGHRD'
153 infot = 1
154 CALL zgghrd( '/', 'N', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, info )
155 CALL chkxer( 'ZGGHRD', infot, nout, lerr, ok )
156 infot = 2
157 CALL zgghrd( 'N', '/', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, info )
158 CALL chkxer( 'ZGGHRD', infot, nout, lerr, ok )
159 infot = 3
160 CALL zgghrd( 'N', 'N', -1, 0, 0, a, 1, b, 1, q, 1, z, 1, info )
161 CALL chkxer( 'ZGGHRD', infot, nout, lerr, ok )
162 infot = 4
163 CALL zgghrd( 'N', 'N', 0, 0, 0, a, 1, b, 1, q, 1, z, 1, info )
164 CALL chkxer( 'ZGGHRD', infot, nout, lerr, ok )
165 infot = 5
166 CALL zgghrd( 'N', 'N', 0, 1, 1, a, 1, b, 1, q, 1, z, 1, info )
167 CALL chkxer( 'ZGGHRD', infot, nout, lerr, ok )
168 infot = 7
169 CALL zgghrd( 'N', 'N', 2, 1, 1, a, 1, b, 2, q, 1, z, 1, info )
170 CALL chkxer( 'ZGGHRD', infot, nout, lerr, ok )
171 infot = 9
172 CALL zgghrd( 'N', 'N', 2, 1, 1, a, 2, b, 1, q, 1, z, 1, info )
173 CALL chkxer( 'ZGGHRD', infot, nout, lerr, ok )
174 infot = 11
175 CALL zgghrd( 'V', 'N', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, info )
176 CALL chkxer( 'ZGGHRD', infot, nout, lerr, ok )
177 infot = 13
178 CALL zgghrd( 'N', 'V', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, info )
179 CALL chkxer( 'ZGGHRD', infot, nout, lerr, ok )
180 nt = nt + 9
181*
182* ZGGHD3
183*
184 srnamt = 'ZGGHD3'
185 infot = 1
186 CALL zgghd3( '/', 'N', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
187 $ info )
188 CALL chkxer( 'ZGGHD3', infot, nout, lerr, ok )
189 infot = 2
190 CALL zgghd3( 'N', '/', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
191 $ info )
192 CALL chkxer( 'ZGGHD3', infot, nout, lerr, ok )
193 infot = 3
194 CALL zgghd3( 'N', 'N', -1, 0, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
195 $ info )
196 CALL chkxer( 'ZGGHD3', infot, nout, lerr, ok )
197 infot = 4
198 CALL zgghd3( 'N', 'N', 0, 0, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
199 $ info )
200 CALL chkxer( 'ZGGHD3', infot, nout, lerr, ok )
201 infot = 5
202 CALL zgghd3( 'N', 'N', 0, 1, 1, a, 1, b, 1, q, 1, z, 1, w, lw,
203 $ info )
204 CALL chkxer( 'ZGGHD3', infot, nout, lerr, ok )
205 infot = 7
206 CALL zgghd3( 'N', 'N', 2, 1, 1, a, 1, b, 2, q, 1, z, 1, w, lw,
207 $ info )
208 CALL chkxer( 'ZGGHD3', infot, nout, lerr, ok )
209 infot = 9
210 CALL zgghd3( 'N', 'N', 2, 1, 1, a, 2, b, 1, q, 1, z, 1, w, lw,
211 $ info )
212 CALL chkxer( 'ZGGHD3', infot, nout, lerr, ok )
213 infot = 11
214 CALL zgghd3( 'V', 'N', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, w, lw,
215 $ info )
216 CALL chkxer( 'ZGGHD3', infot, nout, lerr, ok )
217 infot = 13
218 CALL zgghd3( 'N', 'V', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, w, lw,
219 $ info )
220 CALL chkxer( 'ZGGHD3', infot, nout, lerr, ok )
221 nt = nt + 9
222*
223* ZHGEQZ
224*
225 srnamt = 'ZHGEQZ'
226 infot = 1
227 CALL zhgeqz( '/', 'N', 'N', 0, 1, 0, a, 1, b, 1, alpha, beta,
228 $ q, 1, z, 1, w, 1, rw, info )
229 CALL chkxer( 'ZHGEQZ', infot, nout, lerr, ok )
230 infot = 2
231 CALL zhgeqz( 'E', '/', 'N', 0, 1, 0, a, 1, b, 1, alpha, beta,
232 $ q, 1, z, 1, w, 1, rw, info )
233 CALL chkxer( 'ZHGEQZ', infot, nout, lerr, ok )
234 infot = 3
235 CALL zhgeqz( 'E', 'N', '/', 0, 1, 0, a, 1, b, 1, alpha, beta,
236 $ q, 1, z, 1, w, 1, rw, info )
237 CALL chkxer( 'ZHGEQZ', infot, nout, lerr, ok )
238 infot = 4
239 CALL zhgeqz( 'E', 'N', 'N', -1, 0, 0, a, 1, b, 1, alpha, beta,
240 $ q, 1, z, 1, w, 1, rw, info )
241 CALL chkxer( 'ZHGEQZ', infot, nout, lerr, ok )
242 infot = 5
243 CALL zhgeqz( 'E', 'N', 'N', 0, 0, 0, a, 1, b, 1, alpha, beta,
244 $ q, 1, z, 1, w, 1, rw, info )
245 CALL chkxer( 'ZHGEQZ', infot, nout, lerr, ok )
246 infot = 6
247 CALL zhgeqz( 'E', 'N', 'N', 0, 1, 1, a, 1, b, 1, alpha, beta,
248 $ q, 1, z, 1, w, 1, rw, info )
249 CALL chkxer( 'ZHGEQZ', infot, nout, lerr, ok )
250 infot = 8
251 CALL zhgeqz( 'E', 'N', 'N', 2, 1, 1, a, 1, b, 2, alpha, beta,
252 $ q, 1, z, 1, w, 1, rw, info )
253 CALL chkxer( 'ZHGEQZ', infot, nout, lerr, ok )
254 infot = 10
255 CALL zhgeqz( 'E', 'N', 'N', 2, 1, 1, a, 2, b, 1, alpha, beta,
256 $ q, 1, z, 1, w, 1, rw, info )
257 CALL chkxer( 'ZHGEQZ', infot, nout, lerr, ok )
258 infot = 14
259 CALL zhgeqz( 'E', 'V', 'N', 2, 1, 1, a, 2, b, 2, alpha, beta,
260 $ q, 1, z, 1, w, 1, rw, info )
261 CALL chkxer( 'ZHGEQZ', infot, nout, lerr, ok )
262 infot = 16
263 CALL zhgeqz( 'E', 'N', 'V', 2, 1, 1, a, 2, b, 2, alpha, beta,
264 $ q, 1, z, 1, w, 1, rw, info )
265 CALL chkxer( 'ZHGEQZ', infot, nout, lerr, ok )
266 nt = nt + 10
267*
268* ZTGEVC
269*
270 srnamt = 'ZTGEVC'
271 infot = 1
272 CALL ztgevc( '/', 'A', sel, 0, a, 1, b, 1, q, 1, z, 1, 0, m, w,
273 $ rw, info )
274 CALL chkxer( 'ZTGEVC', infot, nout, lerr, ok )
275 infot = 2
276 CALL ztgevc( 'R', '/', sel, 0, a, 1, b, 1, q, 1, z, 1, 0, m, w,
277 $ rw, info )
278 CALL chkxer( 'ZTGEVC', infot, nout, lerr, ok )
279 infot = 4
280 CALL ztgevc( 'R', 'A', sel, -1, a, 1, b, 1, q, 1, z, 1, 0, m,
281 $ w, rw, info )
282 CALL chkxer( 'ZTGEVC', infot, nout, lerr, ok )
283 infot = 6
284 CALL ztgevc( 'R', 'A', sel, 2, a, 1, b, 2, q, 1, z, 2, 0, m, w,
285 $ rw, info )
286 CALL chkxer( 'ZTGEVC', infot, nout, lerr, ok )
287 infot = 8
288 CALL ztgevc( 'R', 'A', sel, 2, a, 2, b, 1, q, 1, z, 2, 0, m, w,
289 $ rw, info )
290 CALL chkxer( 'ZTGEVC', infot, nout, lerr, ok )
291 infot = 10
292 CALL ztgevc( 'L', 'A', sel, 2, a, 2, b, 2, q, 1, z, 1, 0, m, w,
293 $ rw, info )
294 CALL chkxer( 'ZTGEVC', infot, nout, lerr, ok )
295 infot = 12
296 CALL ztgevc( 'R', 'A', sel, 2, a, 2, b, 2, q, 1, z, 1, 0, m, w,
297 $ rw, info )
298 CALL chkxer( 'ZTGEVC', infot, nout, lerr, ok )
299 infot = 13
300 CALL ztgevc( 'R', 'A', sel, 2, a, 2, b, 2, q, 1, z, 2, 1, m, w,
301 $ rw, info )
302 CALL chkxer( 'ZTGEVC', infot, nout, lerr, ok )
303 nt = nt + 8
304*
305* Test error exits for the GSV path.
306*
307 ELSE IF( lsamen( 3, path, 'GSV' ) ) THEN
308*
309* ZGGSVD3
310*
311 srnamt = 'ZGGSVD3'
312 infot = 1
313 CALL zggsvd3( '/', 'N', 'N', 0, 0, 0, dummyk, dummyl, a, 1, b,
314 $ 1, r1, r2, u, 1, v, 1, q, 1, w, lwork, rw, idum,
315 $ info )
316 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
317 infot = 2
318 CALL zggsvd3( 'N', '/', 'N', 0, 0, 0, dummyk, dummyl, a, 1, b,
319 $ 1, r1, r2, u, 1, v, 1, q, 1, w, lwork, rw, idum,
320 $ info )
321 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
322 infot = 3
323 CALL zggsvd3( 'N', 'N', '/', 0, 0, 0, dummyk, dummyl, a, 1, b,
324 $ 1, r1, r2, u, 1, v, 1, q, 1, w, lwork, rw, idum,
325 $ info )
326 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
327 infot = 4
328 CALL zggsvd3( 'N', 'N', 'N', -1, 0, 0, dummyk, dummyl, a, 1, b,
329 $ 1, r1, r2, u, 1, v, 1, q, 1, w, lwork, rw, idum,
330 $ info )
331 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
332 infot = 5
333 CALL zggsvd3( 'N', 'N', 'N', 0, -1, 0, dummyk, dummyl, a, 1, b,
334 $ 1, r1, r2, u, 1, v, 1, q, 1, w, lwork, rw, idum,
335 $ info )
336 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
337 infot = 6
338 CALL zggsvd3( 'N', 'N', 'N', 0, 0, -1, dummyk, dummyl, a, 1, b,
339 $ 1, r1, r2, u, 1, v, 1, q, 1, w, lwork, rw, idum,
340 $ info )
341 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
342 infot = 10
343 CALL zggsvd3( 'N', 'N', 'N', 2, 1, 1, dummyk, dummyl, a, 1, b,
344 $ 1, r1, r2, u, 1, v, 1, q, 1, w, lwork, rw, idum,
345 $ info )
346 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
347 infot = 12
348 CALL zggsvd3( 'N', 'N', 'N', 1, 1, 2, dummyk, dummyl, a, 1, b,
349 $ 1, r1, r2, u, 1, v, 1, q, 1, w, lwork, rw, idum,
350 $ info )
351 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
352 infot = 16
353 CALL zggsvd3( 'U', 'N', 'N', 2, 2, 2, dummyk, dummyl, a, 2, b,
354 $ 2, r1, r2, u, 1, v, 1, q, 1, w, lwork, rw, idum,
355 $ info )
356 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
357 infot = 18
358 CALL zggsvd3( 'N', 'V', 'N', 2, 2, 2, dummyk, dummyl, a, 2, b,
359 $ 2, r1, r2, u, 2, v, 1, q, 1, w, lwork, rw, idum,
360 $ info )
361 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
362 infot = 20
363 CALL zggsvd3( 'N', 'N', 'Q', 2, 2, 2, dummyk, dummyl, a, 2, b,
364 $ 2, r1, r2, u, 2, v, 2, q, 1, w, lwork, rw, idum,
365 $ info )
366 CALL chkxer( 'ZGGSVD3', infot, nout, lerr, ok )
367 nt = nt + 11
368*
369* ZGGSVP3
370*
371 srnamt = 'ZGGSVP3'
372 infot = 1
373 CALL zggsvp3( '/', 'N', 'N', 0, 0, 0, a, 1, b, 1, tola, tolb,
374 $ dummyk, dummyl, u, 1, v, 1, q, 1, iw, rw, tau, w,
375 $ lwork, info )
376 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
377 infot = 2
378 CALL zggsvp3( 'N', '/', 'N', 0, 0, 0, a, 1, b, 1, tola, tolb,
379 $ dummyk, dummyl, u, 1, v, 1, q, 1, iw, rw, tau, w,
380 $ lwork, info )
381 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
382 infot = 3
383 CALL zggsvp3( 'N', 'N', '/', 0, 0, 0, a, 1, b, 1, tola, tolb,
384 $ dummyk, dummyl, u, 1, v, 1, q, 1, iw, rw, tau, w,
385 $ lwork, info )
386 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
387 infot = 4
388 CALL zggsvp3( 'N', 'N', 'N', -1, 0, 0, a, 1, b, 1, tola, tolb,
389 $ dummyk, dummyl, u, 1, v, 1, q, 1, iw, rw, tau, w,
390 $ lwork, info )
391 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
392 infot = 5
393 CALL zggsvp3( 'N', 'N', 'N', 0, -1, 0, a, 1, b, 1, tola, tolb,
394 $ dummyk, dummyl, u, 1, v, 1, q, 1, iw, rw, tau, w,
395 $ lwork, info )
396 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
397 infot = 6
398 CALL zggsvp3( 'N', 'N', 'N', 0, 0, -1, a, 1, b, 1, tola, tolb,
399 $ dummyk, dummyl, u, 1, v, 1, q, 1, iw, rw, tau, w,
400 $ lwork, info )
401 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
402 infot = 8
403 CALL zggsvp3( 'N', 'N', 'N', 2, 1, 1, a, 1, b, 1, tola, tolb,
404 $ dummyk, dummyl, u, 1, v, 1, q, 1, iw, rw, tau, w,
405 $ lwork, info )
406 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
407 infot = 10
408 CALL zggsvp3( 'N', 'N', 'N', 1, 2, 1, a, 1, b, 1, tola, tolb,
409 $ dummyk, dummyl, u, 1, v, 1, q, 1, iw, rw, tau, w,
410 $ lwork, info )
411 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
412 infot = 16
413 CALL zggsvp3( 'U', 'N', 'N', 2, 2, 2, a, 2, b, 2, tola, tolb,
414 $ dummyk, dummyl, u, 1, v, 1, q, 1, iw, rw, tau, w,
415 $ lwork, info )
416 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
417 infot = 18
418 CALL zggsvp3( 'N', 'V', 'N', 2, 2, 2, a, 2, b, 2, tola, tolb,
419 $ dummyk, dummyl, u, 2, v, 1, q, 1, iw, rw, tau, w,
420 $ lwork, info )
421 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
422 infot = 20
423 CALL zggsvp3( 'N', 'N', 'Q', 2, 2, 2, a, 2, b, 2, tola, tolb,
424 $ dummyk, dummyl, u, 2, v, 2, q, 1, iw, rw, tau, w,
425 $ lwork, info )
426 CALL chkxer( 'ZGGSVP3', infot, nout, lerr, ok )
427 nt = nt + 11
428*
429* ZTGSJA
430*
431 srnamt = 'ZTGSJA'
432 infot = 1
433 CALL ztgsja( '/', 'N', 'N', 0, 0, 0, dummyk, dummyl, a, 1, b,
434 $ 1, tola, tolb, r1, r2, u, 1, v, 1, q, 1, w,
435 $ ncycle, info )
436 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
437 infot = 2
438 CALL ztgsja( 'N', '/', 'N', 0, 0, 0, dummyk, dummyl, a, 1, b,
439 $ 1, tola, tolb, r1, r2, u, 1, v, 1, q, 1, w,
440 $ ncycle, info )
441 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
442 infot = 3
443 CALL ztgsja( 'N', 'N', '/', 0, 0, 0, dummyk, dummyl, a, 1, b,
444 $ 1, tola, tolb, r1, r2, u, 1, v, 1, q, 1, w,
445 $ ncycle, info )
446 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
447 infot = 4
448 CALL ztgsja( 'N', 'N', 'N', -1, 0, 0, dummyk, dummyl, a, 1, b,
449 $ 1, tola, tolb, r1, r2, u, 1, v, 1, q, 1, w,
450 $ ncycle, info )
451 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
452 infot = 5
453 CALL ztgsja( 'N', 'N', 'N', 0, -1, 0, dummyk, dummyl, a, 1, b,
454 $ 1, tola, tolb, r1, r2, u, 1, v, 1, q, 1, w,
455 $ ncycle, info )
456 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
457 infot = 6
458 CALL ztgsja( 'N', 'N', 'N', 0, 0, -1, dummyk, dummyl, a, 1, b,
459 $ 1, tola, tolb, r1, r2, u, 1, v, 1, q, 1, w,
460 $ ncycle, info )
461 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
462 infot = 10
463 CALL ztgsja( 'N', 'N', 'N', 0, 0, 0, dummyk, dummyl, a, 0, b,
464 $ 1, tola, tolb, r1, r2, u, 1, v, 1, q, 1, w,
465 $ ncycle, info )
466 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
467 infot = 12
468 CALL ztgsja( 'N', 'N', 'N', 0, 0, 0, dummyk, dummyl, a, 1, b,
469 $ 0, tola, tolb, r1, r2, u, 1, v, 1, q, 1, w,
470 $ ncycle, info )
471 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
472 infot = 18
473 CALL ztgsja( 'U', 'N', 'N', 0, 0, 0, dummyk, dummyl, a, 1, b,
474 $ 1, tola, tolb, r1, r2, u, 0, v, 1, q, 1, w,
475 $ ncycle, info )
476 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
477 infot = 20
478 CALL ztgsja( 'N', 'V', 'N', 0, 0, 0, dummyk, dummyl, a, 1, b,
479 $ 1, tola, tolb, r1, r2, u, 1, v, 0, q, 1, w,
480 $ ncycle, info )
481 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
482 infot = 22
483 CALL ztgsja( 'N', 'N', 'Q', 0, 0, 0, dummyk, dummyl, a, 1, b,
484 $ 1, tola, tolb, r1, r2, u, 1, v, 1, q, 0, w,
485 $ ncycle, info )
486 CALL chkxer( 'ZTGSJA', infot, nout, lerr, ok )
487 nt = nt + 11
488*
489* Test error exits for the GLM path.
490*
491 ELSE IF( lsamen( 3, path, 'GLM' ) ) THEN
492*
493* ZGGGLM
494*
495 srnamt = 'ZGGGLM'
496 infot = 1
497 CALL zggglm( -1, 0, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
498 $ info )
499 CALL chkxer( 'ZGGGLM', infot, nout, lerr, ok )
500 infot = 2
501 CALL zggglm( 0, -1, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
502 $ info )
503 CALL chkxer( 'ZGGGLM', infot, nout, lerr, ok )
504 infot = 2
505 CALL zggglm( 0, 1, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
506 $ info )
507 CALL chkxer( 'ZGGGLM', infot, nout, lerr, ok )
508 infot = 3
509 CALL zggglm( 0, 0, -1, a, 1, b, 1, tau, alpha, beta, w, lw,
510 $ info )
511 CALL chkxer( 'ZGGGLM', infot, nout, lerr, ok )
512 infot = 3
513 CALL zggglm( 1, 0, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
514 $ info )
515 CALL chkxer( 'ZGGGLM', infot, nout, lerr, ok )
516 infot = 5
517 CALL zggglm( 0, 0, 0, a, 0, b, 1, tau, alpha, beta, w, lw,
518 $ info )
519 CALL chkxer( 'ZGGGLM', infot, nout, lerr, ok )
520 infot = 7
521 CALL zggglm( 0, 0, 0, a, 1, b, 0, tau, alpha, beta, w, lw,
522 $ info )
523 CALL chkxer( 'ZGGGLM', infot, nout, lerr, ok )
524 infot = 12
525 CALL zggglm( 1, 1, 1, a, 1, b, 1, tau, alpha, beta, w, 1,
526 $ info )
527 CALL chkxer( 'ZGGGLM', infot, nout, lerr, ok )
528 nt = nt + 8
529*
530* Test error exits for the LSE path.
531*
532 ELSE IF( lsamen( 3, path, 'LSE' ) ) THEN
533*
534* ZGGLSE
535*
536 srnamt = 'ZGGLSE'
537 infot = 1
538 CALL zgglse( -1, 0, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
539 $ info )
540 CALL chkxer( 'ZGGLSE', infot, nout, lerr, ok )
541 infot = 2
542 CALL zgglse( 0, -1, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
543 $ info )
544 CALL chkxer( 'ZGGLSE', infot, nout, lerr, ok )
545 infot = 3
546 CALL zgglse( 0, 0, -1, a, 1, b, 1, tau, alpha, beta, w, lw,
547 $ info )
548 CALL chkxer( 'ZGGLSE', infot, nout, lerr, ok )
549 infot = 3
550 CALL zgglse( 0, 0, 1, a, 1, b, 1, tau, alpha, beta, w, lw,
551 $ info )
552 CALL chkxer( 'ZGGLSE', infot, nout, lerr, ok )
553 infot = 3
554 CALL zgglse( 0, 1, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
555 $ info )
556 CALL chkxer( 'ZGGLSE', infot, nout, lerr, ok )
557 infot = 5
558 CALL zgglse( 0, 0, 0, a, 0, b, 1, tau, alpha, beta, w, lw,
559 $ info )
560 CALL chkxer( 'ZGGLSE', infot, nout, lerr, ok )
561 infot = 7
562 CALL zgglse( 0, 0, 0, a, 1, b, 0, tau, alpha, beta, w, lw,
563 $ info )
564 CALL chkxer( 'ZGGLSE', infot, nout, lerr, ok )
565 infot = 12
566 CALL zgglse( 1, 1, 1, a, 1, b, 1, tau, alpha, beta, w, 1,
567 $ info )
568 CALL chkxer( 'ZGGLSE', infot, nout, lerr, ok )
569 nt = nt + 8
570*
571* Test error exits for the CSD path.
572*
573 ELSE IF( lsamen( 3, path, 'CSD' ) ) THEN
574*
575* ZUNCSD
576*
577 srnamt = 'ZUNCSD'
578 infot = 7
579 CALL zuncsd( 'Y', 'Y', 'Y', 'Y', 'N', 'N',
580 $ -1, 0, 0, a, 1, a,
581 $ 1, a, 1, a, 1, rs,
582 $ a, 1, a, 1, a, 1, a,
583 $ 1, w, lw, rw, lw, iw, info )
584 CALL chkxer( 'ZUNCSD', infot, nout, lerr, ok )
585 infot = 8
586 CALL zuncsd( 'Y', 'Y', 'Y', 'Y', 'N', 'N',
587 $ 1, -1, 0, a, 1, a,
588 $ 1, a, 1, a, 1, rs,
589 $ a, 1, a, 1, a, 1, a,
590 $ 1, w, lw, rw, lw, iw, info )
591 CALL chkxer( 'ZUNCSD', infot, nout, lerr, ok )
592 infot = 9
593 CALL zuncsd( 'Y', 'Y', 'Y', 'Y', 'N', 'N',
594 $ 1, 1, -1, a, 1, a,
595 $ 1, a, 1, a, 1, rs,
596 $ a, 1, a, 1, a, 1, a,
597 $ 1, w, lw, rw, lw, iw, info )
598 CALL chkxer( 'ZUNCSD', infot, nout, lerr, ok )
599 infot = 11
600 CALL zuncsd( 'Y', 'Y', 'Y', 'Y', 'N', 'N',
601 $ 1, 1, 1, a, -1, a,
602 $ 1, a, 1, a, 1, rs,
603 $ a, 1, a, 1, a, 1, a,
604 $ 1, w, lw, rw, lw, iw, info )
605 CALL chkxer( 'ZUNCSD', infot, nout, lerr, ok )
606 infot = 20
607 CALL zuncsd( 'Y', 'Y', 'Y', 'Y', 'N', 'N',
608 $ 1, 1, 1, a, 1, a,
609 $ 1, a, 1, a, 1, rs,
610 $ a, -1, a, 1, a, 1, a,
611 $ 1, w, lw, rw, lw, iw, info )
612 CALL chkxer( 'ZUNCSD', infot, nout, lerr, ok )
613 infot = 22
614 CALL zuncsd( 'Y', 'Y', 'Y', 'Y', 'N', 'N',
615 $ 1, 1, 1, a, 1, a,
616 $ 1, a, 1, a, 1, rs,
617 $ a, 1, a, -1, a, 1, a,
618 $ 1, w, lw, rw, lw, iw, info )
619 CALL chkxer( 'ZUNCSD', infot, nout, lerr, ok )
620 infot = 24
621 CALL zuncsd( 'Y', 'Y', 'Y', 'Y', 'N', 'N',
622 $ 1, 1, 1, a, 1, a,
623 $ 1, a, 1, a, 1, rs,
624 $ a, 1, a, 1, a, -1, a,
625 $ 1, w, lw, rw, lw, iw, info )
626 CALL chkxer( 'ZUNCSD', infot, nout, lerr, ok )
627 infot = 26
628 CALL zuncsd( 'Y', 'Y', 'Y', 'Y', 'N', 'N',
629 $ 1, 1, 1, a, 1, a,
630 $ 1, a, 1, a, 1, rs,
631 $ a, 1, a, 1, a, 1, a,
632 $ -1, w, lw, rw, lw, iw, info )
633 CALL chkxer( 'ZUNCSD', infot, nout, lerr, ok )
634 nt = nt + 8
635*
636* Test error exits for the GQR path.
637*
638 ELSE IF( lsamen( 3, path, 'GQR' ) ) THEN
639*
640* ZGGQRF
641*
642 srnamt = 'ZGGQRF'
643 infot = 1
644 CALL zggqrf( -1, 0, 0, a, 1, alpha, b, 1, beta, w, lw, info )
645 CALL chkxer( 'ZGGQRF', infot, nout, lerr, ok )
646 infot = 2
647 CALL zggqrf( 0, -1, 0, a, 1, alpha, b, 1, beta, w, lw, info )
648 CALL chkxer( 'ZGGQRF', infot, nout, lerr, ok )
649 infot = 3
650 CALL zggqrf( 0, 0, -1, a, 1, alpha, b, 1, beta, w, lw, info )
651 CALL chkxer( 'ZGGQRF', infot, nout, lerr, ok )
652 infot = 5
653 CALL zggqrf( 0, 0, 0, a, 0, alpha, b, 1, beta, w, lw, info )
654 CALL chkxer( 'ZGGQRF', infot, nout, lerr, ok )
655 infot = 8
656 CALL zggqrf( 0, 0, 0, a, 1, alpha, b, 0, beta, w, lw, info )
657 CALL chkxer( 'ZGGQRF', infot, nout, lerr, ok )
658 infot = 11
659 CALL zggqrf( 1, 1, 2, a, 1, alpha, b, 1, beta, w, 1, info )
660 CALL chkxer( 'ZGGQRF', infot, nout, lerr, ok )
661 nt = nt + 6
662*
663* ZGGRQF
664*
665 srnamt = 'ZGGRQF'
666 infot = 1
667 CALL zggrqf( -1, 0, 0, a, 1, alpha, b, 1, beta, w, lw, info )
668 CALL chkxer( 'ZGGRQF', infot, nout, lerr, ok )
669 infot = 2
670 CALL zggrqf( 0, -1, 0, a, 1, alpha, b, 1, beta, w, lw, info )
671 CALL chkxer( 'ZGGRQF', infot, nout, lerr, ok )
672 infot = 3
673 CALL zggrqf( 0, 0, -1, a, 1, alpha, b, 1, beta, w, lw, info )
674 CALL chkxer( 'ZGGRQF', infot, nout, lerr, ok )
675 infot = 5
676 CALL zggrqf( 0, 0, 0, a, 0, alpha, b, 1, beta, w, lw, info )
677 CALL chkxer( 'ZGGRQF', infot, nout, lerr, ok )
678 infot = 8
679 CALL zggrqf( 0, 0, 0, a, 1, alpha, b, 0, beta, w, lw, info )
680 CALL chkxer( 'ZGGRQF', infot, nout, lerr, ok )
681 infot = 11
682 CALL zggrqf( 1, 1, 2, a, 1, alpha, b, 1, beta, w, 1, info )
683 CALL chkxer( 'ZGGRQF', infot, nout, lerr, ok )
684 nt = nt + 6
685*
686* Test error exits for the ZGS, ZGV, ZGX, and ZXV paths.
687*
688 ELSE IF( lsamen( 3, path, 'ZGS' ) .OR.
689 $ lsamen( 3, path, 'ZGV' ) .OR.
690 $ lsamen( 3, path, 'ZGX' ) .OR. lsamen( 3, path, 'ZXV' ) )
691 $ THEN
692*
693* ZGGES
694*
695 srnamt = 'ZGGES '
696 infot = 1
697 CALL zgges( '/', 'N', 'S', zlctes, 1, a, 1, b, 1, sdim, alpha,
698 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
699 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
700 infot = 2
701 CALL zgges( 'N', '/', 'S', zlctes, 1, a, 1, b, 1, sdim, alpha,
702 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
703 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
704 infot = 3
705 CALL zgges( 'N', 'V', '/', zlctes, 1, a, 1, b, 1, sdim, alpha,
706 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
707 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
708 infot = 5
709 CALL zgges( 'N', 'V', 'S', zlctes, -1, a, 1, b, 1, sdim, alpha,
710 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
711 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
712 infot = 7
713 CALL zgges( 'N', 'V', 'S', zlctes, 1, a, 0, b, 1, sdim, alpha,
714 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
715 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
716 infot = 9
717 CALL zgges( 'N', 'V', 'S', zlctes, 1, a, 1, b, 0, sdim, alpha,
718 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
719 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
720 infot = 14
721 CALL zgges( 'N', 'V', 'S', zlctes, 1, a, 1, b, 1, sdim, alpha,
722 $ beta, q, 0, u, 1, w, 1, rw, bw, info )
723 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
724 infot = 14
725 CALL zgges( 'V', 'V', 'S', zlctes, 2, a, 2, b, 2, sdim, alpha,
726 $ beta, q, 1, u, 2, w, 1, rw, bw, info )
727 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
728 infot = 16
729 CALL zgges( 'N', 'V', 'S', zlctes, 1, a, 1, b, 1, sdim, alpha,
730 $ beta, q, 1, u, 0, w, 1, rw, bw, info )
731 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
732 infot = 16
733 CALL zgges( 'V', 'V', 'S', zlctes, 2, a, 2, b, 2, sdim, alpha,
734 $ beta, q, 2, u, 1, w, 1, rw, bw, info )
735 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
736 infot = 18
737 CALL zgges( 'V', 'V', 'S', zlctes, 2, a, 2, b, 2, sdim, alpha,
738 $ beta, q, 2, u, 2, w, 1, rw, bw, info )
739 CALL chkxer( 'ZGGES ', infot, nout, lerr, ok )
740 nt = nt + 11
741*
742* ZGGES3
743*
744 srnamt = 'ZGGES3'
745 infot = 1
746 CALL zgges3( '/', 'N', 'S', zlctes, 1, a, 1, b, 1, sdim, alpha,
747 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
748 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
749 infot = 2
750 CALL zgges3( 'N', '/', 'S', zlctes, 1, a, 1, b, 1, sdim, alpha,
751 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
752 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
753 infot = 3
754 CALL zgges3( 'N', 'V', '/', zlctes, 1, a, 1, b, 1, sdim, alpha,
755 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
756 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
757 infot = 5
758 CALL zgges3( 'N', 'V', 'S', zlctes, -1, a, 1, b, 1, sdim,
759 $ alpha, beta, q, 1, u, 1, w, 1, rw, bw, info )
760 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
761 infot = 7
762 CALL zgges3( 'N', 'V', 'S', zlctes, 1, a, 0, b, 1, sdim, alpha,
763 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
764 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
765 infot = 9
766 CALL zgges3( 'N', 'V', 'S', zlctes, 1, a, 1, b, 0, sdim, alpha,
767 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
768 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
769 infot = 14
770 CALL zgges3( 'N', 'V', 'S', zlctes, 1, a, 1, b, 1, sdim, alpha,
771 $ beta, q, 0, u, 1, w, 1, rw, bw, info )
772 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
773 infot = 14
774 CALL zgges3( 'V', 'V', 'S', zlctes, 2, a, 2, b, 2, sdim, alpha,
775 $ beta, q, 1, u, 2, w, 1, rw, bw, info )
776 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
777 infot = 16
778 CALL zgges3( 'N', 'V', 'S', zlctes, 1, a, 1, b, 1, sdim, alpha,
779 $ beta, q, 1, u, 0, w, 1, rw, bw, info )
780 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
781 infot = 16
782 CALL zgges3( 'V', 'V', 'S', zlctes, 2, a, 2, b, 2, sdim, alpha,
783 $ beta, q, 2, u, 1, w, 1, rw, bw, info )
784 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
785 infot = 18
786 CALL zgges3( 'V', 'V', 'S', zlctes, 2, a, 2, b, 2, sdim, alpha,
787 $ beta, q, 2, u, 2, w, 1, rw, bw, info )
788 CALL chkxer( 'ZGGES3', infot, nout, lerr, ok )
789 nt = nt + 11
790*
791* ZGGESX
792*
793 srnamt = 'ZGGESX'
794 infot = 1
795 CALL zggesx( '/', 'N', 'S', zlctsx, 'N', 1, a, 1, b, 1, sdim,
796 $ alpha, beta, q, 1, u, 1, rce, rcv, w, 1, rw, iw,
797 $ 1, bw, info )
798 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
799 infot = 2
800 CALL zggesx( 'N', '/', 'S', zlctsx, 'N', 1, a, 1, b, 1, sdim,
801 $ alpha, beta, q, 1, u, 1, rce, rcv, w, 1, rw, iw,
802 $ 1, bw, info )
803 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
804 infot = 3
805 CALL zggesx( 'V', 'V', '/', zlctsx, 'N', 1, a, 1, b, 1, sdim,
806 $ alpha, beta, q, 1, u, 1, rce, rcv, w, 1, rw, iw,
807 $ 1, bw, info )
808 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
809 infot = 5
810 CALL zggesx( 'V', 'V', 'S', zlctsx, '/', 1, a, 1, b, 1, sdim,
811 $ alpha, beta, q, 1, u, 1, rce, rcv, w, 1, rw, iw,
812 $ 1, bw, info )
813 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
814 infot = 6
815 CALL zggesx( 'V', 'V', 'S', zlctsx, 'B', -1, a, 1, b, 1, sdim,
816 $ alpha, beta, q, 1, u, 1, rce, rcv, w, 1, rw, iw,
817 $ 1, bw, info )
818 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
819 infot = 8
820 CALL zggesx( 'V', 'V', 'S', zlctsx, 'B', 1, a, 0, b, 1, sdim,
821 $ alpha, beta, q, 1, u, 1, rce, rcv, w, 1, rw, iw,
822 $ 1, bw, info )
823 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
824 infot = 10
825 CALL zggesx( 'V', 'V', 'S', zlctsx, 'B', 1, a, 1, b, 0, sdim,
826 $ alpha, beta, q, 1, u, 1, rce, rcv, w, 1, rw, iw,
827 $ 1, bw, info )
828 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
829 infot = 15
830 CALL zggesx( 'V', 'V', 'S', zlctsx, 'B', 1, a, 1, b, 1, sdim,
831 $ alpha, beta, q, 0, u, 1, rce, rcv, w, 1, rw, iw,
832 $ 1, bw, info )
833 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
834 infot = 15
835 CALL zggesx( 'V', 'V', 'S', zlctsx, 'B', 2, a, 2, b, 2, sdim,
836 $ alpha, beta, q, 1, u, 1, rce, rcv, w, 1, rw, iw,
837 $ 1, bw, info )
838 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
839 infot = 17
840 CALL zggesx( 'V', 'V', 'S', zlctsx, 'B', 1, a, 1, b, 1, sdim,
841 $ alpha, beta, q, 1, u, 0, rce, rcv, w, 1, rw, iw,
842 $ 1, bw, info )
843 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
844 infot = 17
845 CALL zggesx( 'V', 'V', 'S', zlctsx, 'B', 2, a, 2, b, 2, sdim,
846 $ alpha, beta, q, 2, u, 1, rce, rcv, w, 1, rw, iw,
847 $ 1, bw, info )
848 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
849 infot = 21
850 CALL zggesx( 'V', 'V', 'S', zlctsx, 'B', 2, a, 2, b, 2, sdim,
851 $ alpha, beta, q, 2, u, 2, rce, rcv, w, 1, rw, iw,
852 $ 1, bw, info )
853 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
854 infot = 24
855 CALL zggesx( 'V', 'V', 'S', zlctsx, 'V', 1, a, 1, b, 1, sdim,
856 $ alpha, beta, q, 1, u, 1, rce, rcv, w, 32, rw, iw,
857 $ 0, bw, info )
858 CALL chkxer( 'ZGGESX', infot, nout, lerr, ok )
859 nt = nt + 13
860*
861* ZGGEV
862*
863 srnamt = 'ZGGEV '
864 infot = 1
865 CALL zggev( '/', 'N', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
866 $ w, 1, rw, info )
867 CALL chkxer( 'ZGGEV ', infot, nout, lerr, ok )
868 infot = 2
869 CALL zggev( 'N', '/', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
870 $ w, 1, rw, info )
871 CALL chkxer( 'ZGGEV ', infot, nout, lerr, ok )
872 infot = 3
873 CALL zggev( 'V', 'V', -1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
874 $ w, 1, rw, info )
875 CALL chkxer( 'ZGGEV ', infot, nout, lerr, ok )
876 infot = 5
877 CALL zggev( 'V', 'V', 1, a, 0, b, 1, alpha, beta, q, 1, u, 1,
878 $ w, 1, rw, info )
879 CALL chkxer( 'ZGGEV ', infot, nout, lerr, ok )
880 infot = 7
881 CALL zggev( 'V', 'V', 1, a, 1, b, 0, alpha, beta, q, 1, u, 1,
882 $ w, 1, rw, info )
883 CALL chkxer( 'ZGGEV ', infot, nout, lerr, ok )
884 infot = 11
885 CALL zggev( 'N', 'V', 1, a, 1, b, 1, alpha, beta, q, 0, u, 1,
886 $ w, 1, rw, info )
887 CALL chkxer( 'ZGGEV ', infot, nout, lerr, ok )
888 infot = 11
889 CALL zggev( 'V', 'V', 2, a, 2, b, 2, alpha, beta, q, 1, u, 2,
890 $ w, 1, rw, info )
891 CALL chkxer( 'ZGGEV ', infot, nout, lerr, ok )
892 infot = 13
893 CALL zggev( 'V', 'N', 2, a, 2, b, 2, alpha, beta, q, 2, u, 0,
894 $ w, 1, rw, info )
895 CALL chkxer( 'ZGGEV ', infot, nout, lerr, ok )
896 infot = 13
897 CALL zggev( 'V', 'V', 2, a, 2, b, 2, alpha, beta, q, 2, u, 1,
898 $ w, 1, rw, info )
899 CALL chkxer( 'ZGGEV ', infot, nout, lerr, ok )
900 infot = 15
901 CALL zggev( 'V', 'V', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
902 $ w, 1, rw, info )
903 CALL chkxer( 'ZGGEV ', infot, nout, lerr, ok )
904 nt = nt + 10
905*
906* ZGGEV3
907*
908 srnamt = 'ZGGEV3'
909 infot = 1
910 CALL zggev3( '/', 'N', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
911 $ w, 1, rw, info )
912 CALL chkxer( 'ZGGEV3', infot, nout, lerr, ok )
913 infot = 2
914 CALL zggev3( 'N', '/', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
915 $ w, 1, rw, info )
916 CALL chkxer( 'ZGGEV3', infot, nout, lerr, ok )
917 infot = 3
918 CALL zggev3( 'V', 'V', -1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
919 $ w, 1, rw, info )
920 CALL chkxer( 'ZGGEV3', infot, nout, lerr, ok )
921 infot = 5
922 CALL zggev3( 'V', 'V', 1, a, 0, b, 1, alpha, beta, q, 1, u, 1,
923 $ w, 1, rw, info )
924 CALL chkxer( 'ZGGEV3', infot, nout, lerr, ok )
925 infot = 7
926 CALL zggev3( 'V', 'V', 1, a, 1, b, 0, alpha, beta, q, 1, u, 1,
927 $ w, 1, rw, info )
928 CALL chkxer( 'ZGGEV3', infot, nout, lerr, ok )
929 infot = 11
930 CALL zggev3( 'N', 'V', 1, a, 1, b, 1, alpha, beta, q, 0, u, 1,
931 $ w, 1, rw, info )
932 CALL chkxer( 'ZGGEV3', infot, nout, lerr, ok )
933 infot = 11
934 CALL zggev3( 'V', 'V', 2, a, 2, b, 2, alpha, beta, q, 1, u, 2,
935 $ w, 1, rw, info )
936 CALL chkxer( 'ZGGEV3', infot, nout, lerr, ok )
937 infot = 13
938 CALL zggev3( 'V', 'N', 2, a, 2, b, 2, alpha, beta, q, 2, u, 0,
939 $ w, 1, rw, info )
940 CALL chkxer( 'ZGGEV3', infot, nout, lerr, ok )
941 infot = 13
942 CALL zggev3( 'V', 'V', 2, a, 2, b, 2, alpha, beta, q, 2, u, 1,
943 $ w, 1, rw, info )
944 CALL chkxer( 'ZGGEV3', infot, nout, lerr, ok )
945 infot = 15
946 CALL zggev3( 'V', 'V', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
947 $ w, 1, rw, info )
948 CALL chkxer( 'ZGGEV3', infot, nout, lerr, ok )
949 nt = nt + 10
950*
951* ZGGEVX
952*
953 srnamt = 'ZGGEVX'
954 infot = 1
955 CALL zggevx( '/', 'N', 'N', 'N', 1, a, 1, b, 1, alpha, beta, q,
956 $ 1, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
957 $ w, 1, rw, iw, bw, info )
958 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
959 infot = 2
960 CALL zggevx( 'N', '/', 'N', 'N', 1, a, 1, b, 1, alpha, beta, q,
961 $ 1, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
962 $ w, 1, rw, iw, bw, info )
963 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
964 infot = 3
965 CALL zggevx( 'N', 'N', '/', 'N', 1, a, 1, b, 1, alpha, beta, q,
966 $ 1, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
967 $ w, 1, rw, iw, bw, info )
968 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
969 infot = 4
970 CALL zggevx( 'N', 'N', 'N', '/', 1, a, 1, b, 1, alpha, beta, q,
971 $ 1, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
972 $ w, 1, rw, iw, bw, info )
973 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
974 infot = 5
975 CALL zggevx( 'N', 'N', 'N', 'N', -1, a, 1, b, 1, alpha, beta,
976 $ q, 1, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce,
977 $ rcv, w, 1, rw, iw, bw, info )
978 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
979 infot = 7
980 CALL zggevx( 'N', 'N', 'N', 'N', 1, a, 0, b, 1, alpha, beta, q,
981 $ 1, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
982 $ w, 1, rw, iw, bw, info )
983 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
984 infot = 9
985 CALL zggevx( 'N', 'N', 'N', 'N', 1, a, 1, b, 0, alpha, beta, q,
986 $ 1, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
987 $ w, 1, rw, iw, bw, info )
988 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
989 infot = 13
990 CALL zggevx( 'N', 'N', 'N', 'N', 1, a, 1, b, 1, alpha, beta, q,
991 $ 0, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
992 $ w, 1, rw, iw, bw, info )
993 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
994 infot = 13
995 CALL zggevx( 'N', 'V', 'N', 'N', 2, a, 2, b, 2, alpha, beta, q,
996 $ 1, u, 2, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
997 $ w, 1, rw, iw, bw, info )
998 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
999 infot = 15
1000 CALL zggevx( 'N', 'N', 'N', 'N', 1, a, 1, b, 1, alpha, beta, q,
1001 $ 1, u, 0, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
1002 $ w, 1, rw, iw, bw, info )
1003 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
1004 infot = 15
1005 CALL zggevx( 'N', 'N', 'V', 'N', 2, a, 2, b, 2, alpha, beta, q,
1006 $ 2, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
1007 $ w, 1, rw, iw, bw, info )
1008 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
1009 infot = 25
1010 CALL zggevx( 'N', 'N', 'V', 'N', 2, a, 2, b, 2, alpha, beta, q,
1011 $ 2, u, 2, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
1012 $ w, 0, rw, iw, bw, info )
1013 CALL chkxer( 'ZGGEVX', infot, nout, lerr, ok )
1014 nt = nt + 12
1015*
1016* ZTGEXC
1017*
1018 srnamt = 'ZTGEXC'
1019 infot = 3
1020 CALL ztgexc( .true., .true., -1, a, 1, b, 1, q, 1, z, 1, ifst,
1021 $ ilst, info )
1022 CALL chkxer( 'ZTGEXC', infot, nout, lerr, ok )
1023 infot = 5
1024 CALL ztgexc( .true., .true., 1, a, 0, b, 1, q, 1, z, 1, ifst,
1025 $ ilst, info )
1026 CALL chkxer( 'ZTGEXC', infot, nout, lerr, ok )
1027 infot = 7
1028 CALL ztgexc( .true., .true., 1, a, 1, b, 0, q, 1, z, 1, ifst,
1029 $ ilst, info )
1030 CALL chkxer( 'ZTGEXC', infot, nout, lerr, ok )
1031 infot = 9
1032 CALL ztgexc( .false., .true., 1, a, 1, b, 1, q, 0, z, 1, ifst,
1033 $ ilst, info )
1034 CALL chkxer( 'ZTGEXC', infot, nout, lerr, ok )
1035 infot = 9
1036 CALL ztgexc( .true., .true., 1, a, 1, b, 1, q, 0, z, 1, ifst,
1037 $ ilst, info )
1038 CALL chkxer( 'ZTGEXC', infot, nout, lerr, ok )
1039 infot = 11
1040 CALL ztgexc( .true., .false., 1, a, 1, b, 1, q, 1, z, 0, ifst,
1041 $ ilst, info )
1042 CALL chkxer( 'ZTGEXC', infot, nout, lerr, ok )
1043 infot = 11
1044 CALL ztgexc( .true., .true., 1, a, 1, b, 1, q, 1, z, 0, ifst,
1045 $ ilst, info )
1046 CALL chkxer( 'ZTGEXC', infot, nout, lerr, ok )
1047 nt = nt + 7
1048*
1049* ZTGSEN
1050*
1051 srnamt = 'ZTGSEN'
1052 infot = 1
1053 CALL ztgsen( -1, .true., .true., sel, 1, a, 1, b, 1, alpha,
1054 $ beta, q, 1, z, 1, m, tola, tolb, rcv, w, 1, iw, 1,
1055 $ info )
1056 CALL chkxer( 'ZTGSEN', infot, nout, lerr, ok )
1057 infot = 5
1058 CALL ztgsen( 1, .true., .true., sel, -1, a, 1, b, 1, alpha,
1059 $ beta, q, 1, z, 1, m, tola, tolb, rcv, w, 1, iw, 1,
1060 $ info )
1061 CALL chkxer( 'ZTGSEN', infot, nout, lerr, ok )
1062 infot = 7
1063 CALL ztgsen( 1, .true., .true., sel, 1, a, 0, b, 1, alpha,
1064 $ beta, q, 1, z, 1, m, tola, tolb, rcv, w, 1, iw, 1,
1065 $ info )
1066 CALL chkxer( 'ZTGSEN', infot, nout, lerr, ok )
1067 infot = 9
1068 CALL ztgsen( 1, .true., .true., sel, 1, a, 1, b, 0, alpha,
1069 $ beta, q, 1, z, 1, m, tola, tolb, rcv, w, 1, iw, 1,
1070 $ info )
1071 CALL chkxer( 'ZTGSEN', infot, nout, lerr, ok )
1072 infot = 13
1073 CALL ztgsen( 1, .true., .true., sel, 1, a, 1, b, 1, alpha,
1074 $ beta, q, 0, z, 1, m, tola, tolb, rcv, w, 1, iw, 1,
1075 $ info )
1076 CALL chkxer( 'ZTGSEN', infot, nout, lerr, ok )
1077 infot = 15
1078 CALL ztgsen( 1, .true., .true., sel, 1, a, 1, b, 1, alpha,
1079 $ beta, q, 1, z, 0, m, tola, tolb, rcv, w, 1, iw, 1,
1080 $ info )
1081 CALL chkxer( 'ZTGSEN', infot, nout, lerr, ok )
1082 infot = 21
1083 CALL ztgsen( 3, .true., .true., sel, 1, a, 1, b, 1, alpha,
1084 $ beta, q, 1, z, 1, m, tola, tolb, rcv, w, -5, iw,
1085 $ 1, info )
1086 CALL chkxer( 'ZTGSEN', infot, nout, lerr, ok )
1087 infot = 23
1088 CALL ztgsen( 0, .true., .true., sel, 1, a, 1, b, 1, alpha,
1089 $ beta, q, 1, z, 1, m, tola, tolb, rcv, w, 20, iw,
1090 $ 0, info )
1091 CALL chkxer( 'ZTGSEN', infot, nout, lerr, ok )
1092 infot = 23
1093 CALL ztgsen( 1, .true., .true., sel, 1, a, 1, b, 1, alpha,
1094 $ beta, q, 1, z, 1, m, tola, tolb, rcv, w, 20, iw,
1095 $ 0, info )
1096 CALL chkxer( 'ZTGSEN', infot, nout, lerr, ok )
1097 infot = 23
1098 CALL ztgsen( 5, .true., .true., sel, 1, a, 1, b, 1, alpha,
1099 $ beta, q, 1, z, 1, m, tola, tolb, rcv, w, 20, iw,
1100 $ 1, info )
1101 CALL chkxer( 'ZTGSEN', infot, nout, lerr, ok )
1102 nt = nt + 11
1103*
1104* ZTGSNA
1105*
1106 srnamt = 'ZTGSNA'
1107 infot = 1
1108 CALL ztgsna( '/', 'A', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1109 $ 1, m, w, 1, iw, info )
1110 CALL chkxer( 'ZTGSNA', infot, nout, lerr, ok )
1111 infot = 2
1112 CALL ztgsna( 'B', '/', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1113 $ 1, m, w, 1, iw, info )
1114 CALL chkxer( 'ZTGSNA', infot, nout, lerr, ok )
1115 infot = 4
1116 CALL ztgsna( 'B', 'A', sel, -1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1117 $ 1, m, w, 1, iw, info )
1118 CALL chkxer( 'ZTGSNA', infot, nout, lerr, ok )
1119 infot = 6
1120 CALL ztgsna( 'B', 'A', sel, 1, a, 0, b, 1, q, 1, u, 1, r1, r2,
1121 $ 1, m, w, 1, iw, info )
1122 CALL chkxer( 'ZTGSNA', infot, nout, lerr, ok )
1123 infot = 8
1124 CALL ztgsna( 'B', 'A', sel, 1, a, 1, b, 0, q, 1, u, 1, r1, r2,
1125 $ 1, m, w, 1, iw, info )
1126 CALL chkxer( 'ZTGSNA', infot, nout, lerr, ok )
1127 infot = 10
1128 CALL ztgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 0, u, 1, r1, r2,
1129 $ 1, m, w, 1, iw, info )
1130 CALL chkxer( 'ZTGSNA', infot, nout, lerr, ok )
1131 infot = 12
1132 CALL ztgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 1, u, 0, r1, r2,
1133 $ 1, m, w, 1, iw, info )
1134 CALL chkxer( 'ZTGSNA', infot, nout, lerr, ok )
1135 infot = 15
1136 CALL ztgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1137 $ 0, m, w, 1, iw, info )
1138 CALL chkxer( 'ZTGSNA', infot, nout, lerr, ok )
1139 infot = 18
1140 CALL ztgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1141 $ 1, m, w, 0, iw, info )
1142 CALL chkxer( 'ZTGSNA', infot, nout, lerr, ok )
1143 nt = nt + 9
1144*
1145* ZTGSYL
1146*
1147 srnamt = 'ZTGSYL'
1148 infot = 1
1149 CALL ztgsyl( '/', 0, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1150 $ scale, dif, w, 1, iw, info )
1151 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1152 infot = 2
1153 CALL ztgsyl( 'N', -1, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1154 $ scale, dif, w, 1, iw, info )
1155 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1156 infot = 3
1157 CALL ztgsyl( 'N', 0, 0, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1158 $ scale, dif, w, 1, iw, info )
1159 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1160 infot = 4
1161 CALL ztgsyl( 'N', 0, 1, 0, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1162 $ scale, dif, w, 1, iw, info )
1163 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1164 infot = 6
1165 CALL ztgsyl( 'N', 0, 1, 1, a, 0, b, 1, q, 1, u, 1, v, 1, z, 1,
1166 $ scale, dif, w, 1, iw, info )
1167 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1168 infot = 8
1169 CALL ztgsyl( 'N', 0, 1, 1, a, 1, b, 0, q, 1, u, 1, v, 1, z, 1,
1170 $ scale, dif, w, 1, iw, info )
1171 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1172 infot = 10
1173 CALL ztgsyl( 'N', 0, 1, 1, a, 1, b, 1, q, 0, u, 1, v, 1, z, 1,
1174 $ scale, dif, w, 1, iw, info )
1175 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1176 infot = 12
1177 CALL ztgsyl( 'N', 0, 1, 1, a, 1, b, 1, q, 1, u, 0, v, 1, z, 1,
1178 $ scale, dif, w, 1, iw, info )
1179 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1180 infot = 14
1181 CALL ztgsyl( 'N', 0, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 0, z, 1,
1182 $ scale, dif, w, 1, iw, info )
1183 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1184 infot = 16
1185 CALL ztgsyl( 'N', 0, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 0,
1186 $ scale, dif, w, 1, iw, info )
1187 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1188 infot = 20
1189 CALL ztgsyl( 'N', 1, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1190 $ scale, dif, w, 1, iw, info )
1191 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1192 infot = 20
1193 CALL ztgsyl( 'N', 2, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1194 $ scale, dif, w, 1, iw, info )
1195 CALL chkxer( 'ZTGSYL', infot, nout, lerr, ok )
1196 nt = nt + 12
1197 END IF
1198*
1199* Print a summary line.
1200*
1201 IF( ok ) THEN
1202 WRITE( nout, fmt = 9999 )path, nt
1203 ELSE
1204 WRITE( nout, fmt = 9998 )path
1205 END IF
1206*
1207 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits (',
1208 $ i3, ' tests done)' )
1209 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
1210 $ 'exits ***' )
1211*
1212 RETURN
1213*
1214* End of ZERRGG
1215*
ztgexc
subroutine ztgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, info)
ZTGEXC
Definition ztgexc.f:200
zggsvd3
subroutine zggsvd3(jobu, jobv, jobq, m, n, p, k, l, a, lda, b, ldb, alpha, beta, u, ldu, v, ldv, q, ldq, work, lwork, rwork, iwork, info)
ZGGSVD3 computes the singular value decomposition (SVD) for OTHER matrices
Definition zggsvd3.f:353
zgghd3
subroutine zgghd3(compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, work, lwork, info)
ZGGHD3
Definition zgghd3.f:227
zggsvp3
subroutine zggsvp3(jobu, jobv, jobq, m, p, n, a, lda, b, ldb, tola, tolb, k, l, u, ldu, v, ldv, q, ldq, iwork, rwork, tau, work, lwork, info)
ZGGSVP3
Definition zggsvp3.f:278
ztgsna
subroutine ztgsna(job, howmny, select, n, a, lda, b, ldb, vl, ldvl, vr, ldvr, s, dif, mm, m, work, lwork, iwork, info)
ZTGSNA
Definition ztgsna.f:311
zggqrf
subroutine zggqrf(n, m, p, a, lda, taua, b, ldb, taub, work, lwork, info)
ZGGQRF
Definition zggqrf.f:215
ztgsja
subroutine ztgsja(jobu, jobv, jobq, m, p, n, k, l, a, lda, b, ldb, tola, tolb, alpha, beta, u, ldu, v, ldv, q, ldq, work, ncycle, info)
ZTGSJA
Definition ztgsja.f:379
ztgsen
subroutine ztgsen(ijob, wantq, wantz, select, n, a, lda, b, ldb, alpha, beta, q, ldq, z, ldz, m, pl, pr, dif, work, lwork, iwork, liwork, info)
ZTGSEN
Definition ztgsen.f:433
zggrqf
subroutine zggrqf(m, p, n, a, lda, taua, b, ldb, taub, work, lwork, info)
ZGGRQF
Definition zggrqf.f:214
zggglm
subroutine zggglm(n, m, p, a, lda, b, ldb, d, x, y, work, lwork, info)
ZGGGLM
Definition zggglm.f:185
zgglse
subroutine zgglse(m, n, p, a, lda, b, ldb, c, d, x, work, lwork, info)
ZGGLSE solves overdetermined or underdetermined systems for OTHER matrices
Definition zgglse.f:180
ztgsyl
subroutine ztgsyl(trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, dif, work, lwork, iwork, info)
ZTGSYL
Definition ztgsyl.f:295

◆ zerrhs()

subroutine zerrhs ( character*3 path,
integer nunit )

ZERRHS

Purpose:
!>
!> ZERRHS tests the error exits for ZGEBAK, CGEBAL, CGEHRD, ZUNGHR,
!> ZUNMHR, ZHSEQR, CHSEIN, and ZTREVC.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrhs.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX, LW
69 parameter( nmax = 3, lw = nmax*nmax )
70* ..
71* .. Local Scalars ..
72 CHARACTER*2 C2
73 INTEGER I, IHI, ILO, INFO, J, M, NT
74* ..
75* .. Local Arrays ..
76 LOGICAL SEL( NMAX )
77 INTEGER IFAILL( NMAX ), IFAILR( NMAX )
78 DOUBLE PRECISION RW( NMAX ), S( NMAX )
79 COMPLEX*16 A( NMAX, NMAX ), C( NMAX, NMAX ), TAU( NMAX ),
80 $ VL( NMAX, NMAX ), VR( NMAX, NMAX ), W( LW ),
81 $ X( NMAX )
82* ..
83* .. External Functions ..
84 LOGICAL LSAMEN
85 EXTERNAL lsamen
86* ..
87* .. External Subroutines ..
88 EXTERNAL chkxer, zgebak, zgebal, zgehrd, zhsein, zhseqr,
89 $ ztrevc, zunghr, zunmhr
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC dble
93* ..
94* .. Scalars in Common ..
95 LOGICAL LERR, OK
96 CHARACTER*32 SRNAMT
97 INTEGER INFOT, NOUT
98* ..
99* .. Common blocks ..
100 COMMON / infoc / infot, nout, ok, lerr
101 COMMON / srnamc / srnamt
102* ..
103* .. Executable Statements ..
104*
105 nout = nunit
106 WRITE( nout, fmt = * )
107 c2 = path( 2: 3 )
108*
109* Set the variables to innocuous values.
110*
111 DO 20 j = 1, nmax
112 DO 10 i = 1, nmax
113 a( i, j ) = 1.d0 / dble( i+j )
114 10 CONTINUE
115 sel( j ) = .true.
116 20 CONTINUE
117 ok = .true.
118 nt = 0
119*
120* Test error exits of the nonsymmetric eigenvalue routines.
121*
122 IF( lsamen( 2, c2, 'HS' ) ) THEN
123*
124* ZGEBAL
125*
126 srnamt = 'ZGEBAL'
127 infot = 1
128 CALL zgebal( '/', 0, a, 1, ilo, ihi, s, info )
129 CALL chkxer( 'ZGEBAL', infot, nout, lerr, ok )
130 infot = 2
131 CALL zgebal( 'N', -1, a, 1, ilo, ihi, s, info )
132 CALL chkxer( 'ZGEBAL', infot, nout, lerr, ok )
133 infot = 4
134 CALL zgebal( 'N', 2, a, 1, ilo, ihi, s, info )
135 CALL chkxer( 'ZGEBAL', infot, nout, lerr, ok )
136 nt = nt + 3
137*
138* ZGEBAK
139*
140 srnamt = 'ZGEBAK'
141 infot = 1
142 CALL zgebak( '/', 'R', 0, 1, 0, s, 0, a, 1, info )
143 CALL chkxer( 'ZGEBAK', infot, nout, lerr, ok )
144 infot = 2
145 CALL zgebak( 'N', '/', 0, 1, 0, s, 0, a, 1, info )
146 CALL chkxer( 'ZGEBAK', infot, nout, lerr, ok )
147 infot = 3
148 CALL zgebak( 'N', 'R', -1, 1, 0, s, 0, a, 1, info )
149 CALL chkxer( 'ZGEBAK', infot, nout, lerr, ok )
150 infot = 4
151 CALL zgebak( 'N', 'R', 0, 0, 0, s, 0, a, 1, info )
152 CALL chkxer( 'ZGEBAK', infot, nout, lerr, ok )
153 infot = 4
154 CALL zgebak( 'N', 'R', 0, 2, 0, s, 0, a, 1, info )
155 CALL chkxer( 'ZGEBAK', infot, nout, lerr, ok )
156 infot = 5
157 CALL zgebak( 'N', 'R', 2, 2, 1, s, 0, a, 2, info )
158 CALL chkxer( 'ZGEBAK', infot, nout, lerr, ok )
159 infot = 5
160 CALL zgebak( 'N', 'R', 0, 1, 1, s, 0, a, 1, info )
161 CALL chkxer( 'ZGEBAK', infot, nout, lerr, ok )
162 infot = 7
163 CALL zgebak( 'N', 'R', 0, 1, 0, s, -1, a, 1, info )
164 CALL chkxer( 'ZGEBAK', infot, nout, lerr, ok )
165 infot = 9
166 CALL zgebak( 'N', 'R', 2, 1, 2, s, 0, a, 1, info )
167 CALL chkxer( 'ZGEBAK', infot, nout, lerr, ok )
168 nt = nt + 9
169*
170* ZGEHRD
171*
172 srnamt = 'ZGEHRD'
173 infot = 1
174 CALL zgehrd( -1, 1, 1, a, 1, tau, w, 1, info )
175 CALL chkxer( 'ZGEHRD', infot, nout, lerr, ok )
176 infot = 2
177 CALL zgehrd( 0, 0, 0, a, 1, tau, w, 1, info )
178 CALL chkxer( 'ZGEHRD', infot, nout, lerr, ok )
179 infot = 2
180 CALL zgehrd( 0, 2, 0, a, 1, tau, w, 1, info )
181 CALL chkxer( 'ZGEHRD', infot, nout, lerr, ok )
182 infot = 3
183 CALL zgehrd( 1, 1, 0, a, 1, tau, w, 1, info )
184 CALL chkxer( 'ZGEHRD', infot, nout, lerr, ok )
185 infot = 3
186 CALL zgehrd( 0, 1, 1, a, 1, tau, w, 1, info )
187 CALL chkxer( 'ZGEHRD', infot, nout, lerr, ok )
188 infot = 5
189 CALL zgehrd( 2, 1, 1, a, 1, tau, w, 2, info )
190 CALL chkxer( 'ZGEHRD', infot, nout, lerr, ok )
191 infot = 8
192 CALL zgehrd( 2, 1, 2, a, 2, tau, w, 1, info )
193 CALL chkxer( 'ZGEHRD', infot, nout, lerr, ok )
194 nt = nt + 7
195*
196* ZUNGHR
197*
198 srnamt = 'ZUNGHR'
199 infot = 1
200 CALL zunghr( -1, 1, 1, a, 1, tau, w, 1, info )
201 CALL chkxer( 'ZUNGHR', infot, nout, lerr, ok )
202 infot = 2
203 CALL zunghr( 0, 0, 0, a, 1, tau, w, 1, info )
204 CALL chkxer( 'ZUNGHR', infot, nout, lerr, ok )
205 infot = 2
206 CALL zunghr( 0, 2, 0, a, 1, tau, w, 1, info )
207 CALL chkxer( 'ZUNGHR', infot, nout, lerr, ok )
208 infot = 3
209 CALL zunghr( 1, 1, 0, a, 1, tau, w, 1, info )
210 CALL chkxer( 'ZUNGHR', infot, nout, lerr, ok )
211 infot = 3
212 CALL zunghr( 0, 1, 1, a, 1, tau, w, 1, info )
213 CALL chkxer( 'ZUNGHR', infot, nout, lerr, ok )
214 infot = 5
215 CALL zunghr( 2, 1, 1, a, 1, tau, w, 1, info )
216 CALL chkxer( 'ZUNGHR', infot, nout, lerr, ok )
217 infot = 8
218 CALL zunghr( 3, 1, 3, a, 3, tau, w, 1, info )
219 CALL chkxer( 'ZUNGHR', infot, nout, lerr, ok )
220 nt = nt + 7
221*
222* ZUNMHR
223*
224 srnamt = 'ZUNMHR'
225 infot = 1
226 CALL zunmhr( '/', 'N', 0, 0, 1, 0, a, 1, tau, c, 1, w, 1,
227 $ info )
228 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
229 infot = 2
230 CALL zunmhr( 'L', '/', 0, 0, 1, 0, a, 1, tau, c, 1, w, 1,
231 $ info )
232 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
233 infot = 3
234 CALL zunmhr( 'L', 'N', -1, 0, 1, 0, a, 1, tau, c, 1, w, 1,
235 $ info )
236 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
237 infot = 4
238 CALL zunmhr( 'L', 'N', 0, -1, 1, 0, a, 1, tau, c, 1, w, 1,
239 $ info )
240 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
241 infot = 5
242 CALL zunmhr( 'L', 'N', 0, 0, 0, 0, a, 1, tau, c, 1, w, 1,
243 $ info )
244 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
245 infot = 5
246 CALL zunmhr( 'L', 'N', 0, 0, 2, 0, a, 1, tau, c, 1, w, 1,
247 $ info )
248 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
249 infot = 5
250 CALL zunmhr( 'L', 'N', 1, 2, 2, 1, a, 1, tau, c, 1, w, 2,
251 $ info )
252 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
253 infot = 5
254 CALL zunmhr( 'R', 'N', 2, 1, 2, 1, a, 1, tau, c, 2, w, 2,
255 $ info )
256 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
257 infot = 6
258 CALL zunmhr( 'L', 'N', 1, 1, 1, 0, a, 1, tau, c, 1, w, 1,
259 $ info )
260 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
261 infot = 6
262 CALL zunmhr( 'L', 'N', 0, 1, 1, 1, a, 1, tau, c, 1, w, 1,
263 $ info )
264 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
265 infot = 6
266 CALL zunmhr( 'R', 'N', 1, 0, 1, 1, a, 1, tau, c, 1, w, 1,
267 $ info )
268 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
269 infot = 8
270 CALL zunmhr( 'L', 'N', 2, 1, 1, 1, a, 1, tau, c, 2, w, 1,
271 $ info )
272 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
273 infot = 8
274 CALL zunmhr( 'R', 'N', 1, 2, 1, 1, a, 1, tau, c, 1, w, 1,
275 $ info )
276 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
277 infot = 11
278 CALL zunmhr( 'L', 'N', 2, 1, 1, 1, a, 2, tau, c, 1, w, 1,
279 $ info )
280 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
281 infot = 13
282 CALL zunmhr( 'L', 'N', 1, 2, 1, 1, a, 1, tau, c, 1, w, 1,
283 $ info )
284 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
285 infot = 13
286 CALL zunmhr( 'R', 'N', 2, 1, 1, 1, a, 1, tau, c, 2, w, 1,
287 $ info )
288 CALL chkxer( 'ZUNMHR', infot, nout, lerr, ok )
289 nt = nt + 16
290*
291* ZHSEQR
292*
293 srnamt = 'ZHSEQR'
294 infot = 1
295 CALL zhseqr( '/', 'N', 0, 1, 0, a, 1, x, c, 1, w, 1, info )
296 CALL chkxer( 'ZHSEQR', infot, nout, lerr, ok )
297 infot = 2
298 CALL zhseqr( 'E', '/', 0, 1, 0, a, 1, x, c, 1, w, 1, info )
299 CALL chkxer( 'ZHSEQR', infot, nout, lerr, ok )
300 infot = 3
301 CALL zhseqr( 'E', 'N', -1, 1, 0, a, 1, x, c, 1, w, 1, info )
302 CALL chkxer( 'ZHSEQR', infot, nout, lerr, ok )
303 infot = 4
304 CALL zhseqr( 'E', 'N', 0, 0, 0, a, 1, x, c, 1, w, 1, info )
305 CALL chkxer( 'ZHSEQR', infot, nout, lerr, ok )
306 infot = 4
307 CALL zhseqr( 'E', 'N', 0, 2, 0, a, 1, x, c, 1, w, 1, info )
308 CALL chkxer( 'ZHSEQR', infot, nout, lerr, ok )
309 infot = 5
310 CALL zhseqr( 'E', 'N', 1, 1, 0, a, 1, x, c, 1, w, 1, info )
311 CALL chkxer( 'ZHSEQR', infot, nout, lerr, ok )
312 infot = 5
313 CALL zhseqr( 'E', 'N', 1, 1, 2, a, 1, x, c, 1, w, 1, info )
314 CALL chkxer( 'ZHSEQR', infot, nout, lerr, ok )
315 infot = 7
316 CALL zhseqr( 'E', 'N', 2, 1, 2, a, 1, x, c, 2, w, 1, info )
317 CALL chkxer( 'ZHSEQR', infot, nout, lerr, ok )
318 infot = 10
319 CALL zhseqr( 'E', 'V', 2, 1, 2, a, 2, x, c, 1, w, 1, info )
320 CALL chkxer( 'ZHSEQR', infot, nout, lerr, ok )
321 nt = nt + 9
322*
323* ZHSEIN
324*
325 srnamt = 'ZHSEIN'
326 infot = 1
327 CALL zhsein( '/', 'N', 'N', sel, 0, a, 1, x, vl, 1, vr, 1, 0,
328 $ m, w, rw, ifaill, ifailr, info )
329 CALL chkxer( 'ZHSEIN', infot, nout, lerr, ok )
330 infot = 2
331 CALL zhsein( 'R', '/', 'N', sel, 0, a, 1, x, vl, 1, vr, 1, 0,
332 $ m, w, rw, ifaill, ifailr, info )
333 CALL chkxer( 'ZHSEIN', infot, nout, lerr, ok )
334 infot = 3
335 CALL zhsein( 'R', 'N', '/', sel, 0, a, 1, x, vl, 1, vr, 1, 0,
336 $ m, w, rw, ifaill, ifailr, info )
337 CALL chkxer( 'ZHSEIN', infot, nout, lerr, ok )
338 infot = 5
339 CALL zhsein( 'R', 'N', 'N', sel, -1, a, 1, x, vl, 1, vr, 1, 0,
340 $ m, w, rw, ifaill, ifailr, info )
341 CALL chkxer( 'ZHSEIN', infot, nout, lerr, ok )
342 infot = 7
343 CALL zhsein( 'R', 'N', 'N', sel, 2, a, 1, x, vl, 1, vr, 2, 4,
344 $ m, w, rw, ifaill, ifailr, info )
345 CALL chkxer( 'ZHSEIN', infot, nout, lerr, ok )
346 infot = 10
347 CALL zhsein( 'L', 'N', 'N', sel, 2, a, 2, x, vl, 1, vr, 1, 4,
348 $ m, w, rw, ifaill, ifailr, info )
349 CALL chkxer( 'ZHSEIN', infot, nout, lerr, ok )
350 infot = 12
351 CALL zhsein( 'R', 'N', 'N', sel, 2, a, 2, x, vl, 1, vr, 1, 4,
352 $ m, w, rw, ifaill, ifailr, info )
353 CALL chkxer( 'ZHSEIN', infot, nout, lerr, ok )
354 infot = 13
355 CALL zhsein( 'R', 'N', 'N', sel, 2, a, 2, x, vl, 1, vr, 2, 1,
356 $ m, w, rw, ifaill, ifailr, info )
357 CALL chkxer( 'ZHSEIN', infot, nout, lerr, ok )
358 nt = nt + 8
359*
360* ZTREVC
361*
362 srnamt = 'ZTREVC'
363 infot = 1
364 CALL ztrevc( '/', 'A', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w, rw,
365 $ info )
366 CALL chkxer( 'ZTREVC', infot, nout, lerr, ok )
367 infot = 2
368 CALL ztrevc( 'L', '/', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w, rw,
369 $ info )
370 CALL chkxer( 'ZTREVC', infot, nout, lerr, ok )
371 infot = 4
372 CALL ztrevc( 'L', 'A', sel, -1, a, 1, vl, 1, vr, 1, 0, m, w,
373 $ rw, info )
374 CALL chkxer( 'ZTREVC', infot, nout, lerr, ok )
375 infot = 6
376 CALL ztrevc( 'L', 'A', sel, 2, a, 1, vl, 2, vr, 1, 4, m, w, rw,
377 $ info )
378 CALL chkxer( 'ZTREVC', infot, nout, lerr, ok )
379 infot = 8
380 CALL ztrevc( 'L', 'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w, rw,
381 $ info )
382 CALL chkxer( 'ZTREVC', infot, nout, lerr, ok )
383 infot = 10
384 CALL ztrevc( 'R', 'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w, rw,
385 $ info )
386 CALL chkxer( 'ZTREVC', infot, nout, lerr, ok )
387 infot = 11
388 CALL ztrevc( 'L', 'A', sel, 2, a, 2, vl, 2, vr, 1, 1, m, w, rw,
389 $ info )
390 CALL chkxer( 'ZTREVC', infot, nout, lerr, ok )
391 nt = nt + 7
392 END IF
393*
394* Print a summary line.
395*
396 IF( ok ) THEN
397 WRITE( nout, fmt = 9999 )path, nt
398 ELSE
399 WRITE( nout, fmt = 9998 )path
400 END IF
401*
402 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits',
403 $ ' (', i3, ' tests done)' )
404 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
405 $ 'exits ***' )
406*
407 RETURN
408*
409* End of ZERRHS
410*

◆ zerrst()

subroutine zerrst ( character*3 path,
integer nunit )

ZERRST

Purpose:
!>
!> ZERRST tests the error exits for ZHETRD, ZUNGTR, CUNMTR, ZHPTRD,
!> ZUNGTR, ZUPMTR, ZSTEQR, CSTEIN, ZPTEQR, ZHBTRD,
!> ZHEEV, CHEEVX, CHEEVD, ZHBEV, CHBEVX, CHBEVD,
!> ZHPEV, CHPEVX, CHPEVD, and ZSTEDC.
!> ZHEEVD_2STAGE, ZHEEVR_2STAGE, ZHEEVX_2STAGE,
!> ZHEEV_2STAGE, ZHBEV_2STAGE, ZHBEVD_2STAGE,
!> ZHBEVX_2STAGE, ZHETRD_2STAGE
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 61 of file zerrst.f.

62*
63* -- LAPACK test routine --
64* -- LAPACK is a software package provided by Univ. of Tennessee, --
65* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
66*
67* .. Scalar Arguments ..
68 CHARACTER*3 PATH
69 INTEGER NUNIT
70* ..
71*
72* =====================================================================
73*
74* .. Parameters ..
75 INTEGER NMAX, LIW, LW
76 parameter( nmax = 3, liw = 12*nmax, lw = 20*nmax )
77* ..
78* .. Local Scalars ..
79 CHARACTER*2 C2
80 INTEGER I, INFO, J, M, N, NT
81* ..
82* .. Local Arrays ..
83 INTEGER I1( NMAX ), I2( NMAX ), I3( NMAX ), IW( LIW )
84 DOUBLE PRECISION D( NMAX ), E( NMAX ), R( LW ), RW( LW ),
85 $ X( NMAX )
86 COMPLEX*16 A( NMAX, NMAX ), C( NMAX, NMAX ),
87 $ Q( NMAX, NMAX ), TAU( NMAX ), W( LW ),
88 $ Z( NMAX, NMAX )
89* ..
90* .. External Functions ..
91 LOGICAL LSAMEN
92 EXTERNAL lsamen
93* ..
94* .. External Subroutines ..
95 EXTERNAL chkxer, zhbev, zhbevd, zhbevx, zhbtrd, zheev,
96 $ zheevd, zheevr, zheevx, zhetrd, zhpev, zhpevd,
97 $ zhpevx, zhptrd, zpteqr, zstedc, zstein, zsteqr,
98 $ zungtr, zunmtr, zupgtr, zupmtr,
99 $ zheevd_2stage, zheevr_2stage, zheevx_2stage,
100 $ zheev_2stage, zhbev_2stage, zhbevd_2stage,
101 $ zhbevx_2stage, zhetrd_2stage
102* ..
103* .. Scalars in Common ..
104 LOGICAL LERR, OK
105 CHARACTER*32 SRNAMT
106 INTEGER INFOT, NOUT
107* ..
108* .. Common blocks ..
109 COMMON / infoc / infot, nout, ok, lerr
110 COMMON / srnamc / srnamt
111* ..
112* .. Intrinsic Functions ..
113 INTRINSIC dble
114* ..
115* .. Executable Statements ..
116*
117 nout = nunit
118 WRITE( nout, fmt = * )
119 c2 = path( 2: 3 )
120*
121* Set the variables to innocuous values.
122*
123 DO 20 j = 1, nmax
124 DO 10 i = 1, nmax
125 a( i, j ) = 1.d0 / dble( i+j )
126 10 CONTINUE
127 20 CONTINUE
128 DO 30 j = 1, nmax
129 d( j ) = dble( j )
130 e( j ) = 0.0d0
131 i1( j ) = j
132 i2( j ) = j
133 tau( j ) = 1.d0
134 30 CONTINUE
135 ok = .true.
136 nt = 0
137*
138* Test error exits for the ST path.
139*
140 IF( lsamen( 2, c2, 'ST' ) ) THEN
141*
142* ZHETRD
143*
144 srnamt = 'ZHETRD'
145 infot = 1
146 CALL zhetrd( '/', 0, a, 1, d, e, tau, w, 1, info )
147 CALL chkxer( 'ZHETRD', infot, nout, lerr, ok )
148 infot = 2
149 CALL zhetrd( 'U', -1, a, 1, d, e, tau, w, 1, info )
150 CALL chkxer( 'ZHETRD', infot, nout, lerr, ok )
151 infot = 4
152 CALL zhetrd( 'U', 2, a, 1, d, e, tau, w, 1, info )
153 CALL chkxer( 'ZHETRD', infot, nout, lerr, ok )
154 infot = 9
155 CALL zhetrd( 'U', 0, a, 1, d, e, tau, w, 0, info )
156 CALL chkxer( 'ZHETRD', infot, nout, lerr, ok )
157 nt = nt + 4
158*
159* ZHETRD_2STAGE
160*
161 srnamt = 'ZHETRD_2STAGE'
162 infot = 1
163 CALL zhetrd_2stage( '/', 'U', 0, a, 1, d, e, tau,
164 $ c, 1, w, 1, info )
165 CALL chkxer( 'ZHETRD_2STAGE', infot, nout, lerr, ok )
166 infot = 1
167 CALL zhetrd_2stage( 'H', 'U', 0, a, 1, d, e, tau,
168 $ c, 1, w, 1, info )
169 CALL chkxer( 'ZHETRD_2STAGE', infot, nout, lerr, ok )
170 infot = 2
171 CALL zhetrd_2stage( 'N', '/', 0, a, 1, d, e, tau,
172 $ c, 1, w, 1, info )
173 CALL chkxer( 'ZHETRD_2STAGE', infot, nout, lerr, ok )
174 infot = 3
175 CALL zhetrd_2stage( 'N', 'U', -1, a, 1, d, e, tau,
176 $ c, 1, w, 1, info )
177 CALL chkxer( 'ZHETRD_2STAGE', infot, nout, lerr, ok )
178 infot = 5
179 CALL zhetrd_2stage( 'N', 'U', 2, a, 1, d, e, tau,
180 $ c, 1, w, 1, info )
181 CALL chkxer( 'ZHETRD_2STAGE', infot, nout, lerr, ok )
182 infot = 10
183 CALL zhetrd_2stage( 'N', 'U', 0, a, 1, d, e, tau,
184 $ c, 0, w, 1, info )
185 CALL chkxer( 'ZHETRD_2STAGE', infot, nout, lerr, ok )
186 infot = 12
187 CALL zhetrd_2stage( 'N', 'U', 0, a, 1, d, e, tau,
188 $ c, 1, w, 0, info )
189 CALL chkxer( 'ZHETRD_2STAGE', infot, nout, lerr, ok )
190 nt = nt + 7
191*
192* ZHETRD_HE2HB
193*
194 srnamt = 'ZHETRD_HE2HB'
195 infot = 1
196 CALL zhetrd_he2hb( '/', 0, 0, a, 1, c, 1, tau, w, 1, info )
197 CALL chkxer( 'ZHETRD_HE2HB', infot, nout, lerr, ok )
198 infot = 2
199 CALL zhetrd_he2hb( 'U', -1, 0, a, 1, c, 1, tau, w, 1, info )
200 CALL chkxer( 'ZHETRD_HE2HB', infot, nout, lerr, ok )
201 infot = 3
202 CALL zhetrd_he2hb( 'U', 0, -1, a, 1, c, 1, tau, w, 1, info )
203 CALL chkxer( 'ZHETRD_HE2HB', infot, nout, lerr, ok )
204 infot = 5
205 CALL zhetrd_he2hb( 'U', 2, 0, a, 1, c, 1, tau, w, 1, info )
206 CALL chkxer( 'ZHETRD_HE2HB', infot, nout, lerr, ok )
207 infot = 7
208 CALL zhetrd_he2hb( 'U', 0, 2, a, 1, c, 1, tau, w, 1, info )
209 CALL chkxer( 'ZHETRD_HE2HB', infot, nout, lerr, ok )
210 infot = 10
211 CALL zhetrd_he2hb( 'U', 0, 0, a, 1, c, 1, tau, w, 0, info )
212 CALL chkxer( 'ZHETRD_HE2HB', infot, nout, lerr, ok )
213 nt = nt + 6
214*
215* ZHETRD_HB2ST
216*
217 srnamt = 'ZHETRD_HB2ST'
218 infot = 1
219 CALL zhetrd_hb2st( '/', 'N', 'U', 0, 0, a, 1, d, e,
220 $ c, 1, w, 1, info )
221 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
222 infot = 2
223 CALL zhetrd_hb2st( 'Y', '/', 'U', 0, 0, a, 1, d, e,
224 $ c, 1, w, 1, info )
225 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
226 infot = 2
227 CALL zhetrd_hb2st( 'Y', 'H', 'U', 0, 0, a, 1, d, e,
228 $ c, 1, w, 1, info )
229 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
230 infot = 3
231 CALL zhetrd_hb2st( 'Y', 'N', '/', 0, 0, a, 1, d, e,
232 $ c, 1, w, 1, info )
233 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
234 infot = 4
235 CALL zhetrd_hb2st( 'Y', 'N', 'U', -1, 0, a, 1, d, e,
236 $ c, 1, w, 1, info )
237 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
238 infot = 5
239 CALL zhetrd_hb2st( 'Y', 'N', 'U', 0, -1, a, 1, d, e,
240 $ c, 1, w, 1, info )
241 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
242 infot = 7
243 CALL zhetrd_hb2st( 'Y', 'N', 'U', 0, 1, a, 1, d, e,
244 $ c, 1, w, 1, info )
245 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
246 infot = 11
247 CALL zhetrd_hb2st( 'Y', 'N', 'U', 0, 0, a, 1, d, e,
248 $ c, 0, w, 1, info )
249 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
250 infot = 13
251 CALL zhetrd_hb2st( 'Y', 'N', 'U', 0, 0, a, 1, d, e,
252 $ c, 1, w, 0, info )
253 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
254 nt = nt + 9
255*
256* ZUNGTR
257*
258 srnamt = 'ZUNGTR'
259 infot = 1
260 CALL zungtr( '/', 0, a, 1, tau, w, 1, info )
261 CALL chkxer( 'ZUNGTR', infot, nout, lerr, ok )
262 infot = 2
263 CALL zungtr( 'U', -1, a, 1, tau, w, 1, info )
264 CALL chkxer( 'ZUNGTR', infot, nout, lerr, ok )
265 infot = 4
266 CALL zungtr( 'U', 2, a, 1, tau, w, 1, info )
267 CALL chkxer( 'ZUNGTR', infot, nout, lerr, ok )
268 infot = 7
269 CALL zungtr( 'U', 3, a, 3, tau, w, 1, info )
270 CALL chkxer( 'ZUNGTR', infot, nout, lerr, ok )
271 nt = nt + 4
272*
273* ZUNMTR
274*
275 srnamt = 'ZUNMTR'
276 infot = 1
277 CALL zunmtr( '/', 'U', 'N', 0, 0, a, 1, tau, c, 1, w, 1, info )
278 CALL chkxer( 'ZUNMTR', infot, nout, lerr, ok )
279 infot = 2
280 CALL zunmtr( 'L', '/', 'N', 0, 0, a, 1, tau, c, 1, w, 1, info )
281 CALL chkxer( 'ZUNMTR', infot, nout, lerr, ok )
282 infot = 3
283 CALL zunmtr( 'L', 'U', '/', 0, 0, a, 1, tau, c, 1, w, 1, info )
284 CALL chkxer( 'ZUNMTR', infot, nout, lerr, ok )
285 infot = 4
286 CALL zunmtr( 'L', 'U', 'N', -1, 0, a, 1, tau, c, 1, w, 1,
287 $ info )
288 CALL chkxer( 'ZUNMTR', infot, nout, lerr, ok )
289 infot = 5
290 CALL zunmtr( 'L', 'U', 'N', 0, -1, a, 1, tau, c, 1, w, 1,
291 $ info )
292 CALL chkxer( 'ZUNMTR', infot, nout, lerr, ok )
293 infot = 7
294 CALL zunmtr( 'L', 'U', 'N', 2, 0, a, 1, tau, c, 2, w, 1, info )
295 CALL chkxer( 'ZUNMTR', infot, nout, lerr, ok )
296 infot = 7
297 CALL zunmtr( 'R', 'U', 'N', 0, 2, a, 1, tau, c, 1, w, 1, info )
298 CALL chkxer( 'ZUNMTR', infot, nout, lerr, ok )
299 infot = 10
300 CALL zunmtr( 'L', 'U', 'N', 2, 0, a, 2, tau, c, 1, w, 1, info )
301 CALL chkxer( 'ZUNMTR', infot, nout, lerr, ok )
302 infot = 12
303 CALL zunmtr( 'L', 'U', 'N', 0, 2, a, 1, tau, c, 1, w, 1, info )
304 CALL chkxer( 'ZUNMTR', infot, nout, lerr, ok )
305 infot = 12
306 CALL zunmtr( 'R', 'U', 'N', 2, 0, a, 1, tau, c, 2, w, 1, info )
307 CALL chkxer( 'ZUNMTR', infot, nout, lerr, ok )
308 nt = nt + 10
309*
310* ZHPTRD
311*
312 srnamt = 'ZHPTRD'
313 infot = 1
314 CALL zhptrd( '/', 0, a, d, e, tau, info )
315 CALL chkxer( 'ZHPTRD', infot, nout, lerr, ok )
316 infot = 2
317 CALL zhptrd( 'U', -1, a, d, e, tau, info )
318 CALL chkxer( 'ZHPTRD', infot, nout, lerr, ok )
319 nt = nt + 2
320*
321* ZUPGTR
322*
323 srnamt = 'ZUPGTR'
324 infot = 1
325 CALL zupgtr( '/', 0, a, tau, z, 1, w, info )
326 CALL chkxer( 'ZUPGTR', infot, nout, lerr, ok )
327 infot = 2
328 CALL zupgtr( 'U', -1, a, tau, z, 1, w, info )
329 CALL chkxer( 'ZUPGTR', infot, nout, lerr, ok )
330 infot = 6
331 CALL zupgtr( 'U', 2, a, tau, z, 1, w, info )
332 CALL chkxer( 'ZUPGTR', infot, nout, lerr, ok )
333 nt = nt + 3
334*
335* ZUPMTR
336*
337 srnamt = 'ZUPMTR'
338 infot = 1
339 CALL zupmtr( '/', 'U', 'N', 0, 0, a, tau, c, 1, w, info )
340 CALL chkxer( 'ZUPMTR', infot, nout, lerr, ok )
341 infot = 2
342 CALL zupmtr( 'L', '/', 'N', 0, 0, a, tau, c, 1, w, info )
343 CALL chkxer( 'ZUPMTR', infot, nout, lerr, ok )
344 infot = 3
345 CALL zupmtr( 'L', 'U', '/', 0, 0, a, tau, c, 1, w, info )
346 CALL chkxer( 'ZUPMTR', infot, nout, lerr, ok )
347 infot = 4
348 CALL zupmtr( 'L', 'U', 'N', -1, 0, a, tau, c, 1, w, info )
349 CALL chkxer( 'ZUPMTR', infot, nout, lerr, ok )
350 infot = 5
351 CALL zupmtr( 'L', 'U', 'N', 0, -1, a, tau, c, 1, w, info )
352 CALL chkxer( 'ZUPMTR', infot, nout, lerr, ok )
353 infot = 9
354 CALL zupmtr( 'L', 'U', 'N', 2, 0, a, tau, c, 1, w, info )
355 CALL chkxer( 'ZUPMTR', infot, nout, lerr, ok )
356 nt = nt + 6
357*
358* ZPTEQR
359*
360 srnamt = 'ZPTEQR'
361 infot = 1
362 CALL zpteqr( '/', 0, d, e, z, 1, rw, info )
363 CALL chkxer( 'ZPTEQR', infot, nout, lerr, ok )
364 infot = 2
365 CALL zpteqr( 'N', -1, d, e, z, 1, rw, info )
366 CALL chkxer( 'ZPTEQR', infot, nout, lerr, ok )
367 infot = 6
368 CALL zpteqr( 'V', 2, d, e, z, 1, rw, info )
369 CALL chkxer( 'ZPTEQR', infot, nout, lerr, ok )
370 nt = nt + 3
371*
372* ZSTEIN
373*
374 srnamt = 'ZSTEIN'
375 infot = 1
376 CALL zstein( -1, d, e, 0, x, i1, i2, z, 1, rw, iw, i3, info )
377 CALL chkxer( 'ZSTEIN', infot, nout, lerr, ok )
378 infot = 4
379 CALL zstein( 0, d, e, -1, x, i1, i2, z, 1, rw, iw, i3, info )
380 CALL chkxer( 'ZSTEIN', infot, nout, lerr, ok )
381 infot = 4
382 CALL zstein( 0, d, e, 1, x, i1, i2, z, 1, rw, iw, i3, info )
383 CALL chkxer( 'ZSTEIN', infot, nout, lerr, ok )
384 infot = 9
385 CALL zstein( 2, d, e, 0, x, i1, i2, z, 1, rw, iw, i3, info )
386 CALL chkxer( 'ZSTEIN', infot, nout, lerr, ok )
387 nt = nt + 4
388*
389* ZSTEQR
390*
391 srnamt = 'ZSTEQR'
392 infot = 1
393 CALL zsteqr( '/', 0, d, e, z, 1, rw, info )
394 CALL chkxer( 'ZSTEQR', infot, nout, lerr, ok )
395 infot = 2
396 CALL zsteqr( 'N', -1, d, e, z, 1, rw, info )
397 CALL chkxer( 'ZSTEQR', infot, nout, lerr, ok )
398 infot = 6
399 CALL zsteqr( 'V', 2, d, e, z, 1, rw, info )
400 CALL chkxer( 'ZSTEQR', infot, nout, lerr, ok )
401 nt = nt + 3
402*
403* ZSTEDC
404*
405 srnamt = 'ZSTEDC'
406 infot = 1
407 CALL zstedc( '/', 0, d, e, z, 1, w, 1, rw, 1, iw, 1, info )
408 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
409 infot = 2
410 CALL zstedc( 'N', -1, d, e, z, 1, w, 1, rw, 1, iw, 1, info )
411 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
412 infot = 6
413 CALL zstedc( 'V', 2, d, e, z, 1, w, 4, rw, 23, iw, 28, info )
414 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
415 infot = 8
416 CALL zstedc( 'N', 2, d, e, z, 1, w, 0, rw, 1, iw, 1, info )
417 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
418 infot = 8
419 CALL zstedc( 'V', 2, d, e, z, 2, w, 0, rw, 23, iw, 28, info )
420 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
421 infot = 10
422 CALL zstedc( 'N', 2, d, e, z, 1, w, 1, rw, 0, iw, 1, info )
423 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
424 infot = 10
425 CALL zstedc( 'I', 2, d, e, z, 2, w, 1, rw, 1, iw, 12, info )
426 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
427 infot = 10
428 CALL zstedc( 'V', 2, d, e, z, 2, w, 4, rw, 1, iw, 28, info )
429 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
430 infot = 12
431 CALL zstedc( 'N', 2, d, e, z, 1, w, 1, rw, 1, iw, 0, info )
432 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
433 infot = 12
434 CALL zstedc( 'I', 2, d, e, z, 2, w, 1, rw, 23, iw, 0, info )
435 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
436 infot = 12
437 CALL zstedc( 'V', 2, d, e, z, 2, w, 4, rw, 23, iw, 0, info )
438 CALL chkxer( 'ZSTEDC', infot, nout, lerr, ok )
439 nt = nt + 11
440*
441* ZHEEVD
442*
443 srnamt = 'ZHEEVD'
444 infot = 1
445 CALL zheevd( '/', 'U', 0, a, 1, x, w, 1, rw, 1, iw, 1, info )
446 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
447 infot = 2
448 CALL zheevd( 'N', '/', 0, a, 1, x, w, 1, rw, 1, iw, 1, info )
449 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
450 infot = 3
451 CALL zheevd( 'N', 'U', -1, a, 1, x, w, 1, rw, 1, iw, 1, info )
452 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
453 infot = 5
454 CALL zheevd( 'N', 'U', 2, a, 1, x, w, 3, rw, 2, iw, 1, info )
455 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
456 infot = 8
457 CALL zheevd( 'N', 'U', 1, a, 1, x, w, 0, rw, 1, iw, 1, info )
458 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
459 infot = 8
460 CALL zheevd( 'N', 'U', 2, a, 2, x, w, 2, rw, 2, iw, 1, info )
461 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
462 infot = 8
463 CALL zheevd( 'V', 'U', 2, a, 2, x, w, 3, rw, 25, iw, 12, info )
464 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
465 infot = 10
466 CALL zheevd( 'N', 'U', 1, a, 1, x, w, 1, rw, 0, iw, 1, info )
467 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
468 infot = 10
469 CALL zheevd( 'N', 'U', 2, a, 2, x, w, 3, rw, 1, iw, 1, info )
470 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
471 infot = 10
472 CALL zheevd( 'V', 'U', 2, a, 2, x, w, 8, rw, 18, iw, 12, info )
473 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
474 infot = 12
475 CALL zheevd( 'N', 'U', 1, a, 1, x, w, 1, rw, 1, iw, 0, info )
476 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
477 infot = 12
478 CALL zheevd( 'V', 'U', 2, a, 2, x, w, 8, rw, 25, iw, 11, info )
479 CALL chkxer( 'ZHEEVD', infot, nout, lerr, ok )
480 nt = nt + 12
481*
482* ZHEEVD_2STAGE
483*
484 srnamt = 'ZHEEVD_2STAGE'
485 infot = 1
486 CALL zheevd_2stage( '/', 'U', 0, a, 1, x, w, 1,
487 $ rw, 1, iw, 1, info )
488 CALL chkxer( 'ZHEEVD_2STAGE', infot, nout, lerr, ok )
489 infot = 1
490 CALL zheevd_2stage( 'V', 'U', 0, a, 1, x, w, 1,
491 $ rw, 1, iw, 1, info )
492 CALL chkxer( 'ZHEEVD_2STAGE', infot, nout, lerr, ok )
493 infot = 2
494 CALL zheevd_2stage( 'N', '/', 0, a, 1, x, w, 1,
495 $ rw, 1, iw, 1, info )
496 CALL chkxer( 'ZHEEVD_2STAGE', infot, nout, lerr, ok )
497 infot = 3
498 CALL zheevd_2stage( 'N', 'U', -1, a, 1, x, w, 1,
499 $ rw, 1, iw, 1, info )
500 CALL chkxer( 'ZHEEVD_2STAGE', infot, nout, lerr, ok )
501 infot = 5
502 CALL zheevd_2stage( 'N', 'U', 2, a, 1, x, w, 3,
503 $ rw, 2, iw, 1, info )
504 CALL chkxer( 'ZHEEVD_2STAGE', infot, nout, lerr, ok )
505 infot = 8
506 CALL zheevd_2stage( 'N', 'U', 1, a, 1, x, w, 0,
507 $ rw, 1, iw, 1, info )
508 CALL chkxer( 'ZHEEVD_2STAGE', infot, nout, lerr, ok )
509 infot = 8
510 CALL zheevd_2stage( 'N', 'U', 2, a, 2, x, w, 2,
511 $ rw, 2, iw, 1, info )
512 CALL chkxer( 'ZHEEVD_2STAGE', infot, nout, lerr, ok )
513* INFOT = 8
514* CALL ZHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 3,
515* $ RW, 25, IW, 12, INFO )
516* CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK )
517 infot = 10
518 CALL zheevd_2stage( 'N', 'U', 1, a, 1, x, w, 1,
519 $ rw, 0, iw, 1, info )
520 CALL chkxer( 'ZHEEVD_2STAGE', infot, nout, lerr, ok )
521 infot = 10
522 CALL zheevd_2stage( 'N', 'U', 2, a, 2, x, w, 25,
523 $ rw, 1, iw, 1, info )
524 CALL chkxer( 'ZHEEVD_2STAGE', infot, nout, lerr, ok )
525* INFOT = 10
526* CALL ZHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8,
527* $ RW, 18, IW, 12, INFO )
528* CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK )
529 infot = 12
530 CALL zheevd_2stage( 'N', 'U', 1, a, 1, x, w, 1,
531 $ rw, 1, iw, 0, info )
532 CALL chkxer( 'ZHEEVD_2STAGE', infot, nout, lerr, ok )
533 infot = 12
534* CALL ZHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8,
535* $ RW, 25, IW, 11, INFO )
536* CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK )
537 nt = nt + 10
538*
539* ZHEEV
540*
541 srnamt = 'ZHEEV '
542 infot = 1
543 CALL zheev( '/', 'U', 0, a, 1, x, w, 1, rw, info )
544 CALL chkxer( 'ZHEEV ', infot, nout, lerr, ok )
545 infot = 2
546 CALL zheev( 'N', '/', 0, a, 1, x, w, 1, rw, info )
547 CALL chkxer( 'ZHEEV ', infot, nout, lerr, ok )
548 infot = 3
549 CALL zheev( 'N', 'U', -1, a, 1, x, w, 1, rw, info )
550 CALL chkxer( 'ZHEEV ', infot, nout, lerr, ok )
551 infot = 5
552 CALL zheev( 'N', 'U', 2, a, 1, x, w, 3, rw, info )
553 CALL chkxer( 'ZHEEV ', infot, nout, lerr, ok )
554 infot = 8
555 CALL zheev( 'N', 'U', 2, a, 2, x, w, 2, rw, info )
556 CALL chkxer( 'ZHEEV ', infot, nout, lerr, ok )
557 nt = nt + 5
558*
559* ZHEEV_2STAGE
560*
561 srnamt = 'ZHEEV_2STAGE '
562 infot = 1
563 CALL zheev_2stage( '/', 'U', 0, a, 1, x, w, 1, rw, info )
564 CALL chkxer( 'ZHEEV_2STAGE ', infot, nout, lerr, ok )
565 infot = 1
566 CALL zheev_2stage( 'V', 'U', 0, a, 1, x, w, 1, rw, info )
567 CALL chkxer( 'ZHEEV_2STAGE ', infot, nout, lerr, ok )
568 infot = 2
569 CALL zheev_2stage( 'N', '/', 0, a, 1, x, w, 1, rw, info )
570 CALL chkxer( 'ZHEEV_2STAGE ', infot, nout, lerr, ok )
571 infot = 3
572 CALL zheev_2stage( 'N', 'U', -1, a, 1, x, w, 1, rw, info )
573 CALL chkxer( 'ZHEEV_2STAGE ', infot, nout, lerr, ok )
574 infot = 5
575 CALL zheev_2stage( 'N', 'U', 2, a, 1, x, w, 3, rw, info )
576 CALL chkxer( 'ZHEEV_2STAGE ', infot, nout, lerr, ok )
577 infot = 8
578 CALL zheev_2stage( 'N', 'U', 2, a, 2, x, w, 2, rw, info )
579 CALL chkxer( 'ZHEEV_2STAGE ', infot, nout, lerr, ok )
580 nt = nt + 6
581*
582* ZHEEVX
583*
584 srnamt = 'ZHEEVX'
585 infot = 1
586 CALL zheevx( '/', 'A', 'U', 0, a, 1, 0.0d0, 0.0d0, 0, 0, 0.0d0,
587 $ m, x, z, 1, w, 1, rw, iw, i3, info )
588 CALL chkxer( 'ZHEEVX', infot, nout, lerr, ok )
589 infot = 2
590 CALL zheevx( 'V', '/', 'U', 0, a, 1, 0.0d0, 1.0d0, 1, 0, 0.0d0,
591 $ m, x, z, 1, w, 1, rw, iw, i3, info )
592 CALL chkxer( 'ZHEEVX', infot, nout, lerr, ok )
593 infot = 3
594 CALL zheevx( 'V', 'A', '/', 0, a, 1, 0.0d0, 0.0d0, 0, 0, 0.0d0,
595 $ m, x, z, 1, w, 1, rw, iw, i3, info )
596 infot = 4
597 CALL zheevx( 'V', 'A', 'U', -1, a, 1, 0.0d0, 0.0d0, 0, 0,
598 $ 0.0d0, m, x, z, 1, w, 1, rw, iw, i3, info )
599 CALL chkxer( 'ZHEEVX', infot, nout, lerr, ok )
600 infot = 6
601 CALL zheevx( 'V', 'A', 'U', 2, a, 1, 0.0d0, 0.0d0, 0, 0, 0.0d0,
602 $ m, x, z, 2, w, 3, rw, iw, i3, info )
603 CALL chkxer( 'ZHEEVX', infot, nout, lerr, ok )
604 infot = 8
605 CALL zheevx( 'V', 'V', 'U', 1, a, 1, 0.0d0, 0.0d0, 0, 0, 0.0d0,
606 $ m, x, z, 1, w, 1, rw, iw, i3, info )
607 CALL chkxer( 'ZHEEVX', infot, nout, lerr, ok )
608 infot = 9
609 CALL zheevx( 'V', 'I', 'U', 1, a, 1, 0.0d0, 0.0d0, 0, 0, 0.0d0,
610 $ m, x, z, 1, w, 1, rw, iw, i3, info )
611 CALL chkxer( 'ZHEEVX', infot, nout, lerr, ok )
612 infot = 10
613 CALL zheevx( 'V', 'I', 'U', 2, a, 2, 0.0d0, 0.0d0, 2, 1, 0.0d0,
614 $ m, x, z, 2, w, 3, rw, iw, i3, info )
615 CALL chkxer( 'ZHEEVX', infot, nout, lerr, ok )
616 infot = 15
617 CALL zheevx( 'V', 'A', 'U', 2, a, 2, 0.0d0, 0.0d0, 0, 0, 0.0d0,
618 $ m, x, z, 1, w, 3, rw, iw, i3, info )
619 CALL chkxer( 'ZHEEVX', infot, nout, lerr, ok )
620 infot = 17
621 CALL zheevx( 'V', 'A', 'U', 2, a, 2, 0.0d0, 0.0d0, 0, 0, 0.0d0,
622 $ m, x, z, 2, w, 2, rw, iw, i1, info )
623 CALL chkxer( 'ZHEEVX', infot, nout, lerr, ok )
624 nt = nt + 10
625*
626* ZHEEVX_2STAGE
627*
628 srnamt = 'ZHEEVX_2STAGE'
629 infot = 1
630 CALL zheevx_2stage( '/', 'A', 'U', 0, a, 1,
631 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
632 $ m, x, z, 1, w, 1, rw, iw, i3, info )
633 CALL chkxer( 'ZHEEVX_2STAGE', infot, nout, lerr, ok )
634 infot = 1
635 CALL zheevx_2stage( 'V', 'A', 'U', 0, a, 1,
636 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
637 $ m, x, z, 1, w, 1, rw, iw, i3, info )
638 CALL chkxer( 'ZHEEVX_2STAGE', infot, nout, lerr, ok )
639 infot = 2
640 CALL zheevx_2stage( 'N', '/', 'U', 0, a, 1,
641 $ 0.0d0, 1.0d0, 1, 0, 0.0d0,
642 $ m, x, z, 1, w, 1, rw, iw, i3, info )
643 CALL chkxer( 'ZHEEVX_2STAGE', infot, nout, lerr, ok )
644 infot = 3
645 CALL zheevx_2stage( 'N', 'A', '/', 0, a, 1,
646 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
647 $ m, x, z, 1, w, 1, rw, iw, i3, info )
648 infot = 4
649 CALL zheevx_2stage( 'N', 'A', 'U', -1, a, 1,
650 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
651 $ m, x, z, 1, w, 1, rw, iw, i3, info )
652 CALL chkxer( 'ZHEEVX_2STAGE', infot, nout, lerr, ok )
653 infot = 6
654 CALL zheevx_2stage( 'N', 'A', 'U', 2, a, 1,
655 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
656 $ m, x, z, 2, w, 3, rw, iw, i3, info )
657 CALL chkxer( 'ZHEEVX_2STAGE', infot, nout, lerr, ok )
658 infot = 8
659 CALL zheevx_2stage( 'N', 'V', 'U', 1, a, 1,
660 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
661 $ m, x, z, 1, w, 1, rw, iw, i3, info )
662 CALL chkxer( 'ZHEEVX_2STAGE', infot, nout, lerr, ok )
663 infot = 9
664 CALL zheevx_2stage( 'N', 'I', 'U', 1, a, 1,
665 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
666 $ m, x, z, 1, w, 1, rw, iw, i3, info )
667 CALL chkxer( 'ZHEEVX_2STAGE', infot, nout, lerr, ok )
668 infot = 10
669 CALL zheevx_2stage( 'N', 'I', 'U', 2, a, 2,
670 $ 0.0d0, 0.0d0, 2, 1, 0.0d0,
671 $ m, x, z, 2, w, 3, rw, iw, i3, info )
672 CALL chkxer( 'ZHEEVX_2STAGE', infot, nout, lerr, ok )
673 infot = 15
674 CALL zheevx_2stage( 'N', 'A', 'U', 2, a, 2,
675 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
676 $ m, x, z, 0, w, 3, rw, iw, i3, info )
677 CALL chkxer( 'ZHEEVX_2STAGE', infot, nout, lerr, ok )
678 infot = 17
679 CALL zheevx_2stage( 'N', 'A', 'U', 2, a, 2,
680 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
681 $ m, x, z, 2, w, 0, rw, iw, i1, info )
682 CALL chkxer( 'ZHEEVX_2STAGE', infot, nout, lerr, ok )
683 nt = nt + 11
684*
685* ZHEEVR
686*
687 srnamt = 'ZHEEVR'
688 n = 1
689 infot = 1
690 CALL zheevr( '/', 'A', 'U', 0, a, 1, 0.0d0, 0.0d0, 1, 1, 0.0d0,
691 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
692 $ 10*n, info )
693 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
694 infot = 2
695 CALL zheevr( 'V', '/', 'U', 0, a, 1, 0.0d0, 0.0d0, 1, 1, 0.0d0,
696 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
697 $ 10*n, info )
698 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
699 infot = 3
700 CALL zheevr( 'V', 'A', '/', -1, a, 1, 0.0d0, 0.0d0, 1, 1,
701 $ 0.0d0, m, r, z, 1, iw, q, 2*n, rw, 24*n,
702 $ iw( 2*n+1 ), 10*n, info )
703 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
704 infot = 4
705 CALL zheevr( 'V', 'A', 'U', -1, a, 1, 0.0d0, 0.0d0, 1, 1,
706 $ 0.0d0, m, r, z, 1, iw, q, 2*n, rw, 24*n,
707 $ iw( 2*n+1 ), 10*n, info )
708 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
709 infot = 6
710 CALL zheevr( 'V', 'A', 'U', 2, a, 1, 0.0d0, 0.0d0, 1, 1, 0.0d0,
711 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
712 $ 10*n, info )
713 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
714 infot = 8
715 CALL zheevr( 'V', 'V', 'U', 1, a, 1, 0.0d0, 0.0d0, 1, 1, 0.0d0,
716 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
717 $ 10*n, info )
718 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
719 infot = 9
720 CALL zheevr( 'V', 'I', 'U', 1, a, 1, 0.0d0, 0.0d0, 0, 1, 0.0d0,
721 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
722 $ 10*n, info )
723 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
724 infot = 10
725*
726 CALL zheevr( 'V', 'I', 'U', 2, a, 2, 0.0d0, 0.0d0, 2, 1, 0.0d0,
727 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
728 $ 10*n, info )
729 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
730 infot = 15
731 CALL zheevr( 'V', 'I', 'U', 1, a, 1, 0.0d0, 0.0d0, 1, 1, 0.0d0,
732 $ m, r, z, 0, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
733 $ 10*n, info )
734 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
735 infot = 18
736 CALL zheevr( 'V', 'I', 'U', 1, a, 1, 0.0d0, 0.0d0, 1, 1, 0.0d0,
737 $ m, r, z, 1, iw, q, 2*n-1, rw, 24*n, iw( 2*n+1 ),
738 $ 10*n, info )
739 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
740 infot = 20
741 CALL zheevr( 'V', 'I', 'U', 1, a, 1, 0.0d0, 0.0d0, 1, 1, 0.0d0,
742 $ m, r, z, 1, iw, q, 2*n, rw, 24*n-1, iw( 2*n-1 ),
743 $ 10*n, info )
744 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
745 infot = 22
746 CALL zheevr( 'V', 'I', 'U', 1, a, 1, 0.0d0, 0.0d0, 1, 1, 0.0d0,
747 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw, 10*n-1,
748 $ info )
749 CALL chkxer( 'ZHEEVR', infot, nout, lerr, ok )
750 nt = nt + 12
751*
752* ZHEEVR_2STAGE
753*
754 srnamt = 'ZHEEVR_2STAGE'
755 n = 1
756 infot = 1
757 CALL zheevr_2stage( '/', 'A', 'U', 0, a, 1,
758 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
759 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
760 $ 10*n, info )
761 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
762 infot = 1
763 CALL zheevr_2stage( 'V', 'A', 'U', 0, a, 1,
764 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
765 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
766 $ 10*n, info )
767 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
768 infot = 2
769 CALL zheevr_2stage( 'N', '/', 'U', 0, a, 1,
770 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
771 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
772 $ 10*n, info )
773 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
774 infot = 3
775 CALL zheevr_2stage( 'N', 'A', '/', -1, a, 1,
776 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
777 $ m, r, z, 1, iw, q, 2*n, rw, 24*n,
778 $ iw( 2*n+1 ), 10*n, info )
779 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
780 infot = 4
781 CALL zheevr_2stage( 'N', 'A', 'U', -1, a, 1,
782 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
783 $ m, r, z, 1, iw, q, 2*n, rw, 24*n,
784 $ iw( 2*n+1 ), 10*n, info )
785 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
786 infot = 6
787 CALL zheevr_2stage( 'N', 'A', 'U', 2, a, 1,
788 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
789 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
790 $ 10*n, info )
791 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
792 infot = 8
793 CALL zheevr_2stage( 'N', 'V', 'U', 1, a, 1,
794 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
795 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
796 $ 10*n, info )
797 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
798 infot = 9
799 CALL zheevr_2stage( 'N', 'I', 'U', 1, a, 1,
800 $ 0.0d0, 0.0d0, 0, 1, 0.0d0,
801 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
802 $ 10*n, info )
803 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
804 infot = 10
805 CALL zheevr_2stage( 'N', 'I', 'U', 2, a, 2,
806 $ 0.0d0, 0.0d0, 2, 1, 0.0d0,
807 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
808 $ 10*n, info )
809 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
810 infot = 15
811 CALL zheevr_2stage( 'N', 'I', 'U', 1, a, 1,
812 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
813 $ m, r, z, 0, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
814 $ 10*n, info )
815 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
816 infot = 18
817 CALL zheevr_2stage( 'N', 'I', 'U', 1, a, 1,
818 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
819 $ m, r, z, 1, iw, q, 2*n-1, rw, 24*n, iw( 2*n+1 ),
820 $ 10*n, info )
821 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
822 infot = 20
823 CALL zheevr_2stage( 'N', 'I', 'U', 1, a, 1,
824 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
825 $ m, r, z, 1, iw, q, 26*n, rw, 24*n-1, iw( 2*n-1 ),
826 $ 10*n, info )
827 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
828 infot = 22
829 CALL zheevr_2stage( 'N', 'I', 'U', 1, a, 1,
830 $ 0.0d0, 0.0d0, 1, 1, 0.0d0,
831 $ m, r, z, 1, iw, q, 26*n, rw, 24*n, iw, 10*n-1,
832 $ info )
833 CALL chkxer( 'ZHEEVR_2STAGE', infot, nout, lerr, ok )
834 nt = nt + 13
835*
836* ZHPEVD
837*
838 srnamt = 'ZHPEVD'
839 infot = 1
840 CALL zhpevd( '/', 'U', 0, a, x, z, 1, w, 1, rw, 1, iw, 1,
841 $ info )
842 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
843 infot = 2
844 CALL zhpevd( 'N', '/', 0, a, x, z, 1, w, 1, rw, 1, iw, 1,
845 $ info )
846 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
847 infot = 3
848 CALL zhpevd( 'N', 'U', -1, a, x, z, 1, w, 1, rw, 1, iw, 1,
849 $ info )
850 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
851 infot = 7
852 CALL zhpevd( 'V', 'U', 2, a, x, z, 1, w, 4, rw, 25, iw, 12,
853 $ info )
854 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
855 infot = 9
856 CALL zhpevd( 'N', 'U', 1, a, x, z, 1, w, 0, rw, 1, iw, 1,
857 $ info )
858 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
859 infot = 9
860 CALL zhpevd( 'N', 'U', 2, a, x, z, 2, w, 1, rw, 2, iw, 1,
861 $ info )
862 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
863 infot = 9
864 CALL zhpevd( 'V', 'U', 2, a, x, z, 2, w, 2, rw, 25, iw, 12,
865 $ info )
866 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
867 infot = 11
868 CALL zhpevd( 'N', 'U', 1, a, x, z, 1, w, 1, rw, 0, iw, 1,
869 $ info )
870 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
871 infot = 11
872 CALL zhpevd( 'N', 'U', 2, a, x, z, 2, w, 2, rw, 1, iw, 1,
873 $ info )
874 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
875 infot = 11
876 CALL zhpevd( 'V', 'U', 2, a, x, z, 2, w, 4, rw, 18, iw, 12,
877 $ info )
878 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
879 infot = 13
880 CALL zhpevd( 'N', 'U', 1, a, x, z, 1, w, 1, rw, 1, iw, 0,
881 $ info )
882 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
883 infot = 13
884 CALL zhpevd( 'N', 'U', 2, a, x, z, 2, w, 2, rw, 2, iw, 0,
885 $ info )
886 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
887 infot = 13
888 CALL zhpevd( 'V', 'U', 2, a, x, z, 2, w, 4, rw, 25, iw, 2,
889 $ info )
890 CALL chkxer( 'ZHPEVD', infot, nout, lerr, ok )
891 nt = nt + 13
892*
893* ZHPEV
894*
895 srnamt = 'ZHPEV '
896 infot = 1
897 CALL zhpev( '/', 'U', 0, a, x, z, 1, w, rw, info )
898 CALL chkxer( 'ZHPEV ', infot, nout, lerr, ok )
899 infot = 2
900 CALL zhpev( 'N', '/', 0, a, x, z, 1, w, rw, info )
901 CALL chkxer( 'ZHPEV ', infot, nout, lerr, ok )
902 infot = 3
903 CALL zhpev( 'N', 'U', -1, a, x, z, 1, w, rw, info )
904 CALL chkxer( 'ZHPEV ', infot, nout, lerr, ok )
905 infot = 7
906 CALL zhpev( 'V', 'U', 2, a, x, z, 1, w, rw, info )
907 CALL chkxer( 'ZHPEV ', infot, nout, lerr, ok )
908 nt = nt + 4
909*
910* ZHPEVX
911*
912 srnamt = 'ZHPEVX'
913 infot = 1
914 CALL zhpevx( '/', 'A', 'U', 0, a, 0.0d0, 0.0d0, 0, 0, 0.0d0, m,
915 $ x, z, 1, w, rw, iw, i3, info )
916 CALL chkxer( 'ZHPEVX', infot, nout, lerr, ok )
917 infot = 2
918 CALL zhpevx( 'V', '/', 'U', 0, a, 0.0d0, 1.0d0, 1, 0, 0.0d0, m,
919 $ x, z, 1, w, rw, iw, i3, info )
920 CALL chkxer( 'ZHPEVX', infot, nout, lerr, ok )
921 infot = 3
922 CALL zhpevx( 'V', 'A', '/', 0, a, 0.0d0, 0.0d0, 0, 0, 0.0d0, m,
923 $ x, z, 1, w, rw, iw, i3, info )
924 CALL chkxer( 'ZHPEVX', infot, nout, lerr, ok )
925 infot = 4
926 CALL zhpevx( 'V', 'A', 'U', -1, a, 0.0d0, 0.0d0, 0, 0, 0.0d0,
927 $ m, x, z, 1, w, rw, iw, i3, info )
928 CALL chkxer( 'ZHPEVX', infot, nout, lerr, ok )
929 infot = 7
930 CALL zhpevx( 'V', 'V', 'U', 1, a, 0.0d0, 0.0d0, 0, 0, 0.0d0, m,
931 $ x, z, 1, w, rw, iw, i3, info )
932 CALL chkxer( 'ZHPEVX', infot, nout, lerr, ok )
933 infot = 8
934 CALL zhpevx( 'V', 'I', 'U', 1, a, 0.0d0, 0.0d0, 0, 0, 0.0d0, m,
935 $ x, z, 1, w, rw, iw, i3, info )
936 CALL chkxer( 'ZHPEVX', infot, nout, lerr, ok )
937 infot = 9
938 CALL zhpevx( 'V', 'I', 'U', 2, a, 0.0d0, 0.0d0, 2, 1, 0.0d0, m,
939 $ x, z, 2, w, rw, iw, i3, info )
940 CALL chkxer( 'ZHPEVX', infot, nout, lerr, ok )
941 infot = 14
942 CALL zhpevx( 'V', 'A', 'U', 2, a, 0.0d0, 0.0d0, 0, 0, 0.0d0, m,
943 $ x, z, 1, w, rw, iw, i3, info )
944 CALL chkxer( 'ZHPEVX', infot, nout, lerr, ok )
945 nt = nt + 8
946*
947* Test error exits for the HB path.
948*
949 ELSE IF( lsamen( 2, c2, 'HB' ) ) THEN
950*
951* ZHBTRD
952*
953 srnamt = 'ZHBTRD'
954 infot = 1
955 CALL zhbtrd( '/', 'U', 0, 0, a, 1, d, e, z, 1, w, info )
956 CALL chkxer( 'ZHBTRD', infot, nout, lerr, ok )
957 infot = 2
958 CALL zhbtrd( 'N', '/', 0, 0, a, 1, d, e, z, 1, w, info )
959 CALL chkxer( 'ZHBTRD', infot, nout, lerr, ok )
960 infot = 3
961 CALL zhbtrd( 'N', 'U', -1, 0, a, 1, d, e, z, 1, w, info )
962 CALL chkxer( 'ZHBTRD', infot, nout, lerr, ok )
963 infot = 4
964 CALL zhbtrd( 'N', 'U', 0, -1, a, 1, d, e, z, 1, w, info )
965 CALL chkxer( 'ZHBTRD', infot, nout, lerr, ok )
966 infot = 6
967 CALL zhbtrd( 'N', 'U', 1, 1, a, 1, d, e, z, 1, w, info )
968 CALL chkxer( 'ZHBTRD', infot, nout, lerr, ok )
969 infot = 10
970 CALL zhbtrd( 'V', 'U', 2, 0, a, 1, d, e, z, 1, w, info )
971 CALL chkxer( 'ZHBTRD', infot, nout, lerr, ok )
972 nt = nt + 6
973*
974* ZHETRD_HB2ST
975*
976 srnamt = 'ZHETRD_HB2ST'
977 infot = 1
978 CALL zhetrd_hb2st( '/', 'N', 'U', 0, 0, a, 1, d, e,
979 $ c, 1, w, 1, info )
980 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
981 infot = 2
982 CALL zhetrd_hb2st( 'N', '/', 'U', 0, 0, a, 1, d, e,
983 $ c, 1, w, 1, info )
984 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
985 infot = 2
986 CALL zhetrd_hb2st( 'N', 'H', 'U', 0, 0, a, 1, d, e,
987 $ c, 1, w, 1, info )
988 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
989 infot = 3
990 CALL zhetrd_hb2st( 'N', 'N', '/', 0, 0, a, 1, d, e,
991 $ c, 1, w, 1, info )
992 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
993 infot = 4
994 CALL zhetrd_hb2st( 'N', 'N', 'U', -1, 0, a, 1, d, e,
995 $ c, 1, w, 1, info )
996 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
997 infot = 5
998 CALL zhetrd_hb2st( 'N', 'N', 'U', 0, -1, a, 1, d, e,
999 $ c, 1, w, 1, info )
1000 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
1001 infot = 7
1002 CALL zhetrd_hb2st( 'N', 'N', 'U', 0, 1, a, 1, d, e,
1003 $ c, 1, w, 1, info )
1004 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
1005 infot = 11
1006 CALL zhetrd_hb2st( 'N', 'N', 'U', 0, 0, a, 1, d, e,
1007 $ c, 0, w, 1, info )
1008 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
1009 infot = 13
1010 CALL zhetrd_hb2st( 'N', 'N', 'U', 0, 0, a, 1, d, e,
1011 $ c, 1, w, 0, info )
1012 CALL chkxer( 'ZHETRD_HB2ST', infot, nout, lerr, ok )
1013 nt = nt + 9
1014*
1015* ZHBEVD
1016*
1017 srnamt = 'ZHBEVD'
1018 infot = 1
1019 CALL zhbevd( '/', 'U', 0, 0, a, 1, x, z, 1, w, 1, rw, 1, iw, 1,
1020 $ info )
1021 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1022 infot = 2
1023 CALL zhbevd( 'N', '/', 0, 0, a, 1, x, z, 1, w, 1, rw, 1, iw, 1,
1024 $ info )
1025 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1026 infot = 3
1027 CALL zhbevd( 'N', 'U', -1, 0, a, 1, x, z, 1, w, 1, rw, 1, iw,
1028 $ 1, info )
1029 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1030 infot = 4
1031 CALL zhbevd( 'N', 'U', 0, -1, a, 1, x, z, 1, w, 1, rw, 1, iw,
1032 $ 1, info )
1033 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1034 infot = 6
1035 CALL zhbevd( 'N', 'U', 2, 1, a, 1, x, z, 1, w, 2, rw, 2, iw, 1,
1036 $ info )
1037 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1038 infot = 9
1039 CALL zhbevd( 'V', 'U', 2, 1, a, 2, x, z, 1, w, 8, rw, 25, iw,
1040 $ 12, info )
1041 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1042 infot = 11
1043 CALL zhbevd( 'N', 'U', 1, 0, a, 1, x, z, 1, w, 0, rw, 1, iw, 1,
1044 $ info )
1045 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1046 infot = 11
1047 CALL zhbevd( 'N', 'U', 2, 1, a, 2, x, z, 2, w, 1, rw, 2, iw, 1,
1048 $ info )
1049 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1050 infot = 11
1051 CALL zhbevd( 'V', 'U', 2, 1, a, 2, x, z, 2, w, 2, rw, 25, iw,
1052 $ 12, info )
1053 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1054 infot = 13
1055 CALL zhbevd( 'N', 'U', 1, 0, a, 1, x, z, 1, w, 1, rw, 0, iw, 1,
1056 $ info )
1057 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1058 infot = 13
1059 CALL zhbevd( 'N', 'U', 2, 1, a, 2, x, z, 2, w, 2, rw, 1, iw, 1,
1060 $ info )
1061 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1062 infot = 13
1063 CALL zhbevd( 'V', 'U', 2, 1, a, 2, x, z, 2, w, 8, rw, 2, iw,
1064 $ 12, info )
1065 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1066 infot = 15
1067 CALL zhbevd( 'N', 'U', 1, 0, a, 1, x, z, 1, w, 1, rw, 1, iw, 0,
1068 $ info )
1069 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1070 infot = 15
1071 CALL zhbevd( 'N', 'U', 2, 1, a, 2, x, z, 2, w, 2, rw, 2, iw, 0,
1072 $ info )
1073 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1074 infot = 15
1075 CALL zhbevd( 'V', 'U', 2, 1, a, 2, x, z, 2, w, 8, rw, 25, iw,
1076 $ 2, info )
1077 CALL chkxer( 'ZHBEVD', infot, nout, lerr, ok )
1078 nt = nt + 15
1079*
1080* ZHBEVD_2STAGE
1081*
1082 srnamt = 'ZHBEVD_2STAGE'
1083 infot = 1
1084 CALL zhbevd_2stage( '/', 'U', 0, 0, a, 1, x, z, 1,
1085 $ w, 1, rw, 1, iw, 1, info )
1086 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1087 infot = 1
1088 CALL zhbevd_2stage( 'V', 'U', 0, 0, a, 1, x, z, 1,
1089 $ w, 1, rw, 1, iw, 1, info )
1090 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1091 infot = 2
1092 CALL zhbevd_2stage( 'N', '/', 0, 0, a, 1, x, z, 1,
1093 $ w, 1, rw, 1, iw, 1, info )
1094 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1095 infot = 3
1096 CALL zhbevd_2stage( 'N', 'U', -1, 0, a, 1, x, z, 1,
1097 $ w, 1, rw, 1, iw, 1, info )
1098 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1099 infot = 4
1100 CALL zhbevd_2stage( 'N', 'U', 0, -1, a, 1, x, z, 1,
1101 $ w, 1, rw, 1, iw, 1, info )
1102 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1103 infot = 6
1104 CALL zhbevd_2stage( 'N', 'U', 2, 1, a, 1, x, z, 1,
1105 $ w, 2, rw, 2, iw, 1, info )
1106 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1107 infot = 9
1108 CALL zhbevd_2stage( 'N', 'U', 2, 1, a, 2, x, z, 0,
1109 $ w, 8, rw, 25, iw, 12, info )
1110 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1111 infot = 11
1112 CALL zhbevd_2stage( 'N', 'U', 1, 0, a, 1, x, z, 1,
1113 $ w, 0, rw, 1, iw, 1, info )
1114 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1115 infot = 11
1116 CALL zhbevd_2stage( 'N', 'U', 2, 1, a, 2, x, z, 2,
1117 $ w, 1, rw, 2, iw, 1, info )
1118 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1119* INFOT = 11
1120* CALL ZHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2,
1121* $ W, 2, RW, 25, IW, 12, INFO )
1122* CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK )
1123 infot = 13
1124 CALL zhbevd_2stage( 'N', 'U', 1, 0, a, 1, x, z, 1,
1125 $ w, 1, rw, 0, iw, 1, info )
1126 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1127 infot = 13
1128 CALL zhbevd_2stage( 'N', 'U', 2, 1, a, 2, x, z, 2,
1129 $ w, 25, rw, 1, iw, 1, info )
1130 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1131* INFOT = 13
1132* CALL ZHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2,
1133* $ W, 25, RW, 2, IW, 12, INFO )
1134* CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK )
1135 infot = 15
1136 CALL zhbevd_2stage( 'N', 'U', 1, 0, a, 1, x, z, 1,
1137 $ w, 1, rw, 1, iw, 0, info )
1138 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1139 infot = 15
1140 CALL zhbevd_2stage( 'N', 'U', 2, 1, a, 2, x, z, 2,
1141 $ w, 25, rw, 2, iw, 0, info )
1142 CALL chkxer( 'ZHBEVD_2STAGE', infot, nout, lerr, ok )
1143* INFOT = 15
1144* CALL ZHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2,
1145* $ W, 25, RW, 25, IW, 2, INFO )
1146* CALL CHKXER( 'ZHBEVD_2STAGE', INFOT, NOUT, LERR, OK )
1147 nt = nt + 13
1148*
1149* ZHBEV
1150*
1151 srnamt = 'ZHBEV '
1152 infot = 1
1153 CALL zhbev( '/', 'U', 0, 0, a, 1, x, z, 1, w, rw, info )
1154 CALL chkxer( 'ZHBEV ', infot, nout, lerr, ok )
1155 infot = 2
1156 CALL zhbev( 'N', '/', 0, 0, a, 1, x, z, 1, w, rw, info )
1157 CALL chkxer( 'ZHBEV ', infot, nout, lerr, ok )
1158 infot = 3
1159 CALL zhbev( 'N', 'U', -1, 0, a, 1, x, z, 1, w, rw, info )
1160 CALL chkxer( 'ZHBEV ', infot, nout, lerr, ok )
1161 infot = 4
1162 CALL zhbev( 'N', 'U', 0, -1, a, 1, x, z, 1, w, rw, info )
1163 CALL chkxer( 'ZHBEV ', infot, nout, lerr, ok )
1164 infot = 6
1165 CALL zhbev( 'N', 'U', 2, 1, a, 1, x, z, 1, w, rw, info )
1166 CALL chkxer( 'ZHBEV ', infot, nout, lerr, ok )
1167 infot = 9
1168 CALL zhbev( 'V', 'U', 2, 0, a, 1, x, z, 1, w, rw, info )
1169 CALL chkxer( 'ZHBEV ', infot, nout, lerr, ok )
1170 nt = nt + 6
1171*
1172* ZHBEV_2STAGE
1173*
1174 srnamt = 'ZHBEV_2STAGE '
1175 infot = 1
1176 CALL zhbev_2stage( '/', 'U', 0, 0, a, 1, x,
1177 $ z, 1, w, 0, rw, info )
1178 CALL chkxer( 'ZHBEV_2STAGE ', infot, nout, lerr, ok )
1179 infot = 1
1180 CALL zhbev_2stage( 'V', 'U', 0, 0, a, 1, x,
1181 $ z, 1, w, 0, rw, info )
1182 CALL chkxer( 'ZHBEV_2STAGE ', infot, nout, lerr, ok )
1183 infot = 2
1184 CALL zhbev_2stage( 'N', '/', 0, 0, a, 1, x,
1185 $ z, 1, w, 0, rw, info )
1186 CALL chkxer( 'ZHBEV_2STAGE ', infot, nout, lerr, ok )
1187 infot = 3
1188 CALL zhbev_2stage( 'N', 'U', -1, 0, a, 1, x,
1189 $ z, 1, w, 0, rw, info )
1190 CALL chkxer( 'ZHBEV_2STAGE ', infot, nout, lerr, ok )
1191 infot = 4
1192 CALL zhbev_2stage( 'N', 'U', 0, -1, a, 1, x,
1193 $ z, 1, w, 0, rw, info )
1194 CALL chkxer( 'ZHBEV_2STAGE ', infot, nout, lerr, ok )
1195 infot = 6
1196 CALL zhbev_2stage( 'N', 'U', 2, 1, a, 1, x,
1197 $ z, 1, w, 0, rw, info )
1198 CALL chkxer( 'ZHBEV_2STAGE ', infot, nout, lerr, ok )
1199 infot = 9
1200 CALL zhbev_2stage( 'N', 'U', 2, 0, a, 1, x,
1201 $ z, 0, w, 0, rw, info )
1202 CALL chkxer( 'ZHBEV_2STAGE ', infot, nout, lerr, ok )
1203 infot = 11
1204 CALL zhbev_2stage( 'N', 'U', 2, 0, a, 1, x,
1205 $ z, 1, w, 0, rw, info )
1206 CALL chkxer( 'ZHBEV_2STAGE ', infot, nout, lerr, ok )
1207 nt = nt + 8
1208*
1209* ZHBEVX
1210*
1211 srnamt = 'ZHBEVX'
1212 infot = 1
1213 CALL zhbevx( '/', 'A', 'U', 0, 0, a, 1, q, 1, 0.0d0, 0.0d0, 0,
1214 $ 0, 0.0d0, m, x, z, 1, w, rw, iw, i3, info )
1215 CALL chkxer( 'ZHBEVX', infot, nout, lerr, ok )
1216 infot = 2
1217 CALL zhbevx( 'V', '/', 'U', 0, 0, a, 1, q, 1, 0.0d0, 1.0d0, 1,
1218 $ 0, 0.0d0, m, x, z, 1, w, rw, iw, i3, info )
1219 CALL chkxer( 'ZHBEVX', infot, nout, lerr, ok )
1220 infot = 3
1221 CALL zhbevx( 'V', 'A', '/', 0, 0, a, 1, q, 1, 0.0d0, 0.0d0, 0,
1222 $ 0, 0.0d0, m, x, z, 1, w, rw, iw, i3, info )
1223 infot = 4
1224 CALL zhbevx( 'V', 'A', 'U', -1, 0, a, 1, q, 1, 0.0d0, 0.0d0, 0,
1225 $ 0, 0.0d0, m, x, z, 1, w, rw, iw, i3, info )
1226 CALL chkxer( 'ZHBEVX', infot, nout, lerr, ok )
1227 infot = 5
1228 CALL zhbevx( 'V', 'A', 'U', 0, -1, a, 1, q, 1, 0.0d0, 0.0d0, 0,
1229 $ 0, 0.0d0, m, x, z, 1, w, rw, iw, i3, info )
1230 CALL chkxer( 'ZHBEVX', infot, nout, lerr, ok )
1231 infot = 7
1232 CALL zhbevx( 'V', 'A', 'U', 2, 1, a, 1, q, 2, 0.0d0, 0.0d0, 0,
1233 $ 0, 0.0d0, m, x, z, 2, w, rw, iw, i3, info )
1234 CALL chkxer( 'ZHBEVX', infot, nout, lerr, ok )
1235 infot = 9
1236 CALL zhbevx( 'V', 'A', 'U', 2, 0, a, 1, q, 1, 0.0d0, 0.0d0, 0,
1237 $ 0, 0.0d0, m, x, z, 2, w, rw, iw, i3, info )
1238 CALL chkxer( 'ZHBEVX', infot, nout, lerr, ok )
1239 infot = 11
1240 CALL zhbevx( 'V', 'V', 'U', 1, 0, a, 1, q, 1, 0.0d0, 0.0d0, 0,
1241 $ 0, 0.0d0, m, x, z, 1, w, rw, iw, i3, info )
1242 CALL chkxer( 'ZHBEVX', infot, nout, lerr, ok )
1243 infot = 12
1244 CALL zhbevx( 'V', 'I', 'U', 1, 0, a, 1, q, 1, 0.0d0, 0.0d0, 0,
1245 $ 0, 0.0d0, m, x, z, 1, w, rw, iw, i3, info )
1246 CALL chkxer( 'ZHBEVX', infot, nout, lerr, ok )
1247 infot = 13
1248 CALL zhbevx( 'V', 'I', 'U', 1, 0, a, 1, q, 1, 0.0d0, 0.0d0, 1,
1249 $ 2, 0.0d0, m, x, z, 1, w, rw, iw, i3, info )
1250 CALL chkxer( 'ZHBEVX', infot, nout, lerr, ok )
1251 infot = 18
1252 CALL zhbevx( 'V', 'A', 'U', 2, 0, a, 1, q, 2, 0.0d0, 0.0d0, 0,
1253 $ 0, 0.0d0, m, x, z, 1, w, rw, iw, i3, info )
1254 CALL chkxer( 'ZHBEVX', infot, nout, lerr, ok )
1255 nt = nt + 11
1256*
1257* ZHBEVX_2STAGE
1258*
1259 srnamt = 'ZHBEVX_2STAGE'
1260 infot = 1
1261 CALL zhbevx_2stage( '/', 'A', 'U', 0, 0, a, 1, q, 1,
1262 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
1263 $ m, x, z, 1, w, 0, rw, iw, i3, info )
1264 infot = 1
1265 CALL zhbevx_2stage( 'V', 'A', 'U', 0, 0, a, 1, q, 1,
1266 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
1267 $ m, x, z, 1, w, 0, rw, iw, i3, info )
1268 CALL chkxer( 'ZHBEVX_2STAGE', infot, nout, lerr, ok )
1269 infot = 2
1270 CALL zhbevx_2stage( 'N', '/', 'U', 0, 0, a, 1, q, 1,
1271 $ 0.0d0, 1.0d0, 1, 0, 0.0d0,
1272 $ m, x, z, 1, w, 0, rw, iw, i3, info )
1273 CALL chkxer( 'ZHBEVX_2STAGE', infot, nout, lerr, ok )
1274 infot = 3
1275 CALL zhbevx_2stage( 'N', 'A', '/', 0, 0, a, 1, q, 1,
1276 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
1277 $ m, x, z, 1, w, 0, rw, iw, i3, info )
1278 infot = 4
1279 CALL zhbevx_2stage( 'N', 'A', 'U', -1, 0, a, 1, q, 1,
1280 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
1281 $ m, x, z, 1, w, 0, rw, iw, i3, info )
1282 CALL chkxer( 'ZHBEVX_2STAGE', infot, nout, lerr, ok )
1283 infot = 5
1284 CALL zhbevx_2stage( 'N', 'A', 'U', 0, -1, a, 1, q, 1,
1285 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
1286 $ m, x, z, 1, w, 0, rw, iw, i3, info )
1287 CALL chkxer( 'ZHBEVX_2STAGE', infot, nout, lerr, ok )
1288 infot = 7
1289 CALL zhbevx_2stage( 'N', 'A', 'U', 2, 1, a, 1, q, 2,
1290 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
1291 $ m, x, z, 2, w, 0, rw, iw, i3, info )
1292 CALL chkxer( 'ZHBEVX_2STAGE', infot, nout, lerr, ok )
1293* INFOT = 9
1294* CALL ZHBEVX_2STAGE( 'V', 'A', 'U', 2, 0, A, 1, Q, 1,
1295* $ 0.0D0, 0.0D0, 0, 0, 0.0D0,
1296* $ M, X, Z, 2, W, 0, RW, IW, I3, INFO )
1297* CALL CHKXER( 'ZHBEVX_2STAGE', INFOT, NOUT, LERR, OK )
1298 infot = 11
1299 CALL zhbevx_2stage( 'N', 'V', 'U', 1, 0, a, 1, q, 1,
1300 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
1301 $ m, x, z, 1, w, 0, rw, iw, i3, info )
1302 CALL chkxer( 'ZHBEVX_2STAGE', infot, nout, lerr, ok )
1303 infot = 12
1304 CALL zhbevx_2stage( 'N', 'I', 'U', 1, 0, a, 1, q, 1,
1305 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
1306 $ m, x, z, 1, w, 0, rw, iw, i3, info )
1307 CALL chkxer( 'ZHBEVX_2STAGE', infot, nout, lerr, ok )
1308 infot = 13
1309 CALL zhbevx_2stage( 'N', 'I', 'U', 1, 0, a, 1, q, 1,
1310 $ 0.0d0, 0.0d0, 1, 2, 0.0d0,
1311 $ m, x, z, 1, w, 0, rw, iw, i3, info )
1312 CALL chkxer( 'ZHBEVX_2STAGE', infot, nout, lerr, ok )
1313 infot = 18
1314 CALL zhbevx_2stage( 'N', 'A', 'U', 2, 0, a, 1, q, 2,
1315 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
1316 $ m, x, z, 0, w, 0, rw, iw, i3, info )
1317 CALL chkxer( 'ZHBEVX_2STAGE', infot, nout, lerr, ok )
1318 infot = 20
1319 CALL zhbevx_2stage( 'N', 'A', 'U', 2, 0, a, 1, q, 2,
1320 $ 0.0d0, 0.0d0, 0, 0, 0.0d0,
1321 $ m, x, z, 1, w, 0, rw, iw, i3, info )
1322 CALL chkxer( 'ZHBEVX_2STAGE', infot, nout, lerr, ok )
1323 nt = nt + 12
1324 END IF
1325*
1326* Print a summary line.
1327*
1328 IF( ok ) THEN
1329 WRITE( nout, fmt = 9999 )path, nt
1330 ELSE
1331 WRITE( nout, fmt = 9998 )path
1332 END IF
1333*
1334 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits',
1335 $ ' (', i3, ' tests done)' )
1336 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
1337 $ 'exits ***' )
1338*
1339 RETURN
1340*
1341* End of ZERRST
1342*
zhetrd_he2hb
subroutine zhetrd_he2hb(uplo, n, kd, a, lda, ab, ldab, tau, work, lwork, info)
ZHETRD_HE2HB
Definition zhetrd_he2hb.f:243
zupmtr
subroutine zupmtr(side, uplo, trans, m, n, ap, tau, c, ldc, work, info)
ZUPMTR
Definition zupmtr.f:150
zunmtr
subroutine zunmtr(side, uplo, trans, m, n, a, lda, tau, c, ldc, work, lwork, info)
ZUNMTR
Definition zunmtr.f:171

◆ zget02()

subroutine zget02 ( character trans,
integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZGET02

Purpose:
!>
!> ZGET02 computes the residual for a solution of a system of linear
!> equations op(A)*X = B:
!>    RESID = norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ),
!> where op(A) = A, A**T, or A**H, depending on TRANS, and EPS is the
!> machine epsilon.
!>
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]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]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B, the matrix of right hand sides.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original M x N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  If TRANS = 'N',
!>          LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 132 of file zget02.f.

134*
135* -- LAPACK test 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 CHARACTER TRANS
141 INTEGER LDA, LDB, LDX, M, N, NRHS
142 DOUBLE PRECISION RESID
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION RWORK( * )
146 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
147* ..
148*
149* =====================================================================
150*
151* .. Parameters ..
152 DOUBLE PRECISION ZERO, ONE
153 parameter( zero = 0.0d+0, one = 1.0d+0 )
154 COMPLEX*16 CONE
155 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
156* ..
157* .. Local Scalars ..
158 INTEGER J, N1, N2
159 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
160* ..
161* .. External Functions ..
162 LOGICAL LSAME
163 DOUBLE PRECISION DLAMCH, DZASUM, ZLANGE
164 EXTERNAL lsame, dlamch, dzasum, zlange
165* ..
166* .. External Subroutines ..
167 EXTERNAL zgemm
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC max
171* ..
172* .. Executable Statements ..
173*
174* Quick exit if M = 0 or N = 0 or NRHS = 0
175*
176 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.EQ.0 ) THEN
177 resid = zero
178 RETURN
179 END IF
180*
181 IF( lsame( trans, 'T' ) .OR. lsame( trans, 'C' ) ) THEN
182 n1 = n
183 n2 = m
184 ELSE
185 n1 = m
186 n2 = n
187 END IF
188*
189* Exit with RESID = 1/EPS if ANORM = 0.
190*
191 eps = dlamch( 'Epsilon' )
192 IF( lsame( trans, 'N' ) ) THEN
193 anorm = zlange( '1', m, n, a, lda, rwork )
194 ELSE
195 anorm = zlange( 'I', m, n, a, lda, rwork )
196 END IF
197 IF( anorm.LE.zero ) THEN
198 resid = one / eps
199 RETURN
200 END IF
201*
202* Compute B - op(A)*X and store in B.
203*
204 CALL zgemm( trans, 'No transpose', n1, nrhs, n2, -cone, a, lda, x,
205 $ ldx, cone, b, ldb )
206*
207* Compute the maximum over the number of right hand sides of
208* norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ) .
209*
210 resid = zero
211 DO 10 j = 1, nrhs
212 bnorm = dzasum( n1, b( 1, j ), 1 )
213 xnorm = dzasum( n2, x( 1, j ), 1 )
214 IF( xnorm.LE.zero ) THEN
215 resid = one / eps
216 ELSE
217 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
218 END IF
219 10 CONTINUE
220*
221 RETURN
222*
223* End of ZGET02
224*

◆ zget10()

subroutine zget10 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision result )

ZGET10

Purpose:
!>
!> ZGET10 compares two matrices A and B and computes the ratio
!> RESULT = norm( A - B ) / ( norm(A) * M * EPS )
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrices A and B.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and B.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m by n matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          The m by n matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (M)
!>
[out]RWORK
!>          RWORK is COMPLEX*16 array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION
!>          RESULT = norm( A - B ) / ( norm(A) * M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 98 of file zget10.f.

99*
100* -- LAPACK test routine --
101* -- LAPACK is a software package provided by Univ. of Tennessee, --
102* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
103*
104* .. Scalar Arguments ..
105 INTEGER LDA, LDB, M, N
106 DOUBLE PRECISION RESULT
107* ..
108* .. Array Arguments ..
109 DOUBLE PRECISION RWORK( * )
110 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
111* ..
112*
113* =====================================================================
114*
115* .. Parameters ..
116 DOUBLE PRECISION ONE, ZERO
117 parameter( one = 1.0d+0, zero = 0.0d+0 )
118* ..
119* .. Local Scalars ..
120 INTEGER J
121 DOUBLE PRECISION ANORM, EPS, UNFL, WNORM
122* ..
123* .. External Functions ..
124 DOUBLE PRECISION DLAMCH, DZASUM, ZLANGE
125 EXTERNAL dlamch, dzasum, zlange
126* ..
127* .. External Subroutines ..
128 EXTERNAL zaxpy, zcopy
129* ..
130* .. Intrinsic Functions ..
131 INTRINSIC dble, dcmplx, max, min
132* ..
133* .. Executable Statements ..
134*
135* Quick return if possible
136*
137 IF( m.LE.0 .OR. n.LE.0 ) THEN
138 result = zero
139 RETURN
140 END IF
141*
142 unfl = dlamch( 'Safe minimum' )
143 eps = dlamch( 'Precision' )
144*
145 wnorm = zero
146 DO 10 j = 1, n
147 CALL zcopy( m, a( 1, j ), 1, work, 1 )
148 CALL zaxpy( m, dcmplx( -one ), b( 1, j ), 1, work, 1 )
149 wnorm = max( wnorm, dzasum( n, work, 1 ) )
150 10 CONTINUE
151*
152 anorm = max( zlange( '1', m, n, a, lda, rwork ), unfl )
153*
154 IF( anorm.GT.wnorm ) THEN
155 result = ( wnorm / anorm ) / ( m*eps )
156 ELSE
157 IF( anorm.LT.one ) THEN
158 result = ( min( wnorm, m*anorm ) / anorm ) / ( m*eps )
159 ELSE
160 result = min( wnorm / anorm, dble( m ) ) / ( m*eps )
161 END IF
162 END IF
163*
164 RETURN
165*
166* End of ZGET10
167*
zaxpy
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
Definition zaxpy.f:88

◆ zget22()

subroutine zget22 ( character transa,
character transe,
character transw,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lde, * ) e,
integer lde,
complex*16, dimension( * ) w,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision, dimension( 2 ) result )

ZGET22

Purpose:
!>
!> ZGET22 does an eigenvector check.
!>
!> The basic test is:
!>
!>    RESULT(1) = | A E  -  E W | / ( |A| |E| ulp )
!>
!> using the 1-norm.  It also tests the normalization of E:
!>
!>    RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
!>                 j
!>
!> where E(j) is the j-th eigenvector, and m-norm is the max-norm of a
!> vector.  The max-norm of a complex n-vector x in this case is the
!> maximum of |re(x(i)| + |im(x(i)| over i = 1, ..., n.
!>
Parameters
[in]TRANSA
!>          TRANSA is CHARACTER*1
!>          Specifies whether or not A is transposed.
!>          = 'N':  No transpose
!>          = 'T':  Transpose
!>          = 'C':  Conjugate transpose
!>
[in]TRANSE
!>          TRANSE is CHARACTER*1
!>          Specifies whether or not E is transposed.
!>          = 'N':  No transpose, eigenvectors are in columns of E
!>          = 'T':  Transpose, eigenvectors are in rows of E
!>          = 'C':  Conjugate transpose, eigenvectors are in rows of E
!>
[in]TRANSW
!>          TRANSW is CHARACTER*1
!>          Specifies whether or not W is transposed.
!>          = 'N':  No transpose
!>          = 'T':  Transpose, same as TRANSW = 'N'
!>          = 'C':  Conjugate transpose, use -WI(j) instead of WI(j)
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The matrix whose eigenvectors are in E.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]E
!>          E is COMPLEX*16 array, dimension (LDE,N)
!>          The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors
!>          are stored in the columns of E, if TRANSE = 'T' or 'C', the
!>          eigenvectors are stored in the rows of E.
!>
[in]LDE
!>          LDE is INTEGER
!>          The leading dimension of the array E.  LDE >= max(1,N).
!>
[in]W
!>          W is COMPLEX*16 array, dimension (N)
!>          The eigenvalues of A.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          RESULT(1) = | A E  -  E W | / ( |A| |E| ulp )
!>          RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
!>                       j
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 142 of file zget22.f.

144*
145* -- LAPACK test routine --
146* -- LAPACK is a software package provided by Univ. of Tennessee, --
147* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
148*
149* .. Scalar Arguments ..
150 CHARACTER TRANSA, TRANSE, TRANSW
151 INTEGER LDA, LDE, N
152* ..
153* .. Array Arguments ..
154 DOUBLE PRECISION RESULT( 2 ), RWORK( * )
155 COMPLEX*16 A( LDA, * ), E( LDE, * ), W( * ), WORK( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 DOUBLE PRECISION ZERO, ONE
162 parameter( zero = 0.0d+0, one = 1.0d+0 )
163 COMPLEX*16 CZERO, CONE
164 parameter( czero = ( 0.0d+0, 0.0d+0 ),
165 $ cone = ( 1.0d+0, 0.0d+0 ) )
166* ..
167* .. Local Scalars ..
168 CHARACTER NORMA, NORME
169 INTEGER ITRNSE, ITRNSW, J, JCOL, JOFF, JROW, JVEC
170 DOUBLE PRECISION ANORM, ENORM, ENRMAX, ENRMIN, ERRNRM, TEMP1,
171 $ ULP, UNFL
172 COMPLEX*16 WTEMP
173* ..
174* .. External Functions ..
175 LOGICAL LSAME
176 DOUBLE PRECISION DLAMCH, ZLANGE
177 EXTERNAL lsame, dlamch, zlange
178* ..
179* .. External Subroutines ..
180 EXTERNAL zgemm, zlaset
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC abs, dble, dconjg, dimag, max, min
184* ..
185* .. Executable Statements ..
186*
187* Initialize RESULT (in case N=0)
188*
189 result( 1 ) = zero
190 result( 2 ) = zero
191 IF( n.LE.0 )
192 $ RETURN
193*
194 unfl = dlamch( 'Safe minimum' )
195 ulp = dlamch( 'Precision' )
196*
197 itrnse = 0
198 itrnsw = 0
199 norma = 'O'
200 norme = 'O'
201*
202 IF( lsame( transa, 'T' ) .OR. lsame( transa, 'C' ) ) THEN
203 norma = 'I'
204 END IF
205*
206 IF( lsame( transe, 'T' ) ) THEN
207 itrnse = 1
208 norme = 'I'
209 ELSE IF( lsame( transe, 'C' ) ) THEN
210 itrnse = 2
211 norme = 'I'
212 END IF
213*
214 IF( lsame( transw, 'C' ) ) THEN
215 itrnsw = 1
216 END IF
217*
218* Normalization of E:
219*
220 enrmin = one / ulp
221 enrmax = zero
222 IF( itrnse.EQ.0 ) THEN
223 DO 20 jvec = 1, n
224 temp1 = zero
225 DO 10 j = 1, n
226 temp1 = max( temp1, abs( dble( e( j, jvec ) ) )+
227 $ abs( dimag( e( j, jvec ) ) ) )
228 10 CONTINUE
229 enrmin = min( enrmin, temp1 )
230 enrmax = max( enrmax, temp1 )
231 20 CONTINUE
232 ELSE
233 DO 30 jvec = 1, n
234 rwork( jvec ) = zero
235 30 CONTINUE
236*
237 DO 50 j = 1, n
238 DO 40 jvec = 1, n
239 rwork( jvec ) = max( rwork( jvec ),
240 $ abs( dble( e( jvec, j ) ) )+
241 $ abs( dimag( e( jvec, j ) ) ) )
242 40 CONTINUE
243 50 CONTINUE
244*
245 DO 60 jvec = 1, n
246 enrmin = min( enrmin, rwork( jvec ) )
247 enrmax = max( enrmax, rwork( jvec ) )
248 60 CONTINUE
249 END IF
250*
251* Norm of A:
252*
253 anorm = max( zlange( norma, n, n, a, lda, rwork ), unfl )
254*
255* Norm of E:
256*
257 enorm = max( zlange( norme, n, n, e, lde, rwork ), ulp )
258*
259* Norm of error:
260*
261* Error = AE - EW
262*
263 CALL zlaset( 'Full', n, n, czero, czero, work, n )
264*
265 joff = 0
266 DO 100 jcol = 1, n
267 IF( itrnsw.EQ.0 ) THEN
268 wtemp = w( jcol )
269 ELSE
270 wtemp = dconjg( w( jcol ) )
271 END IF
272*
273 IF( itrnse.EQ.0 ) THEN
274 DO 70 jrow = 1, n
275 work( joff+jrow ) = e( jrow, jcol )*wtemp
276 70 CONTINUE
277 ELSE IF( itrnse.EQ.1 ) THEN
278 DO 80 jrow = 1, n
279 work( joff+jrow ) = e( jcol, jrow )*wtemp
280 80 CONTINUE
281 ELSE
282 DO 90 jrow = 1, n
283 work( joff+jrow ) = dconjg( e( jcol, jrow ) )*wtemp
284 90 CONTINUE
285 END IF
286 joff = joff + n
287 100 CONTINUE
288*
289 CALL zgemm( transa, transe, n, n, n, cone, a, lda, e, lde, -cone,
290 $ work, n )
291*
292 errnrm = zlange( 'One', n, n, work, n, rwork ) / enorm
293*
294* Compute RESULT(1) (avoiding under/overflow)
295*
296 IF( anorm.GT.errnrm ) THEN
297 result( 1 ) = ( errnrm / anorm ) / ulp
298 ELSE
299 IF( anorm.LT.one ) THEN
300 result( 1 ) = one / ulp
301 ELSE
302 result( 1 ) = min( errnrm / anorm, one ) / ulp
303 END IF
304 END IF
305*
306* Compute RESULT(2) : the normalization error in E.
307*
308 result( 2 ) = max( abs( enrmax-one ), abs( enrmin-one ) ) /
309 $ ( dble( n )*ulp )
310*
311 RETURN
312*
313* End of ZGET22
314*

◆ zget23()

subroutine zget23 ( logical comp,
integer isrt,
character balanc,
integer jtype,
double precision thresh,
integer, dimension( 4 ) iseed,
integer nounit,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) h,
complex*16, dimension( * ) w,
complex*16, dimension( * ) w1,
complex*16, dimension( ldvl, * ) vl,
integer ldvl,
complex*16, dimension( ldvr, * ) vr,
integer ldvr,
complex*16, dimension( ldlre, * ) lre,
integer ldlre,
double precision, dimension( * ) rcondv,
double precision, dimension( * ) rcndv1,
double precision, dimension( * ) rcdvin,
double precision, dimension( * ) rconde,
double precision, dimension( * ) rcnde1,
double precision, dimension( * ) rcdein,
double precision, dimension( * ) scale,
double precision, dimension( * ) scale1,
double precision, dimension( 11 ) result,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
integer info )

ZGET23

Purpose:
!>
!>    ZGET23  checks the nonsymmetric eigenvalue problem driver CGEEVX.
!>    If COMP = .FALSE., the first 8 of the following tests will be
!>    performed on the input matrix A, and also test 9 if LWORK is
!>    sufficiently large.
!>    if COMP is .TRUE. all 11 tests will be performed.
!>
!>    (1)     | A * VR - VR * W | / ( n |A| ulp )
!>
!>      Here VR is the matrix of unit right eigenvectors.
!>      W is a diagonal matrix with diagonal entries W(j).
!>
!>    (2)     | A**H * VL - VL * W**H | / ( n |A| ulp )
!>
!>      Here VL is the matrix of unit left eigenvectors, A**H is the
!>      conjugate transpose of A, and W is as above.
!>
!>    (3)     | |VR(i)| - 1 | / ulp and largest component real
!>
!>      VR(i) denotes the i-th column of VR.
!>
!>    (4)     | |VL(i)| - 1 | / ulp and largest component real
!>
!>      VL(i) denotes the i-th column of VL.
!>
!>    (5)     0 if W(full) = W(partial), 1/ulp otherwise
!>
!>      W(full) denotes the eigenvalues computed when VR, VL, RCONDV
!>      and RCONDE are also computed, and W(partial) denotes the
!>      eigenvalues computed when only some of VR, VL, RCONDV, and
!>      RCONDE are computed.
!>
!>    (6)     0 if VR(full) = VR(partial), 1/ulp otherwise
!>
!>      VR(full) denotes the right eigenvectors computed when VL, RCONDV
!>      and RCONDE are computed, and VR(partial) denotes the result
!>      when only some of VL and RCONDV are computed.
!>
!>    (7)     0 if VL(full) = VL(partial), 1/ulp otherwise
!>
!>      VL(full) denotes the left eigenvectors computed when VR, RCONDV
!>      and RCONDE are computed, and VL(partial) denotes the result
!>      when only some of VR and RCONDV are computed.
!>
!>    (8)     0 if SCALE, ILO, IHI, ABNRM (full) =
!>                 SCALE, ILO, IHI, ABNRM (partial)
!>            1/ulp otherwise
!>
!>      SCALE, ILO, IHI and ABNRM describe how the matrix is balanced.
!>      (full) is when VR, VL, RCONDE and RCONDV are also computed, and
!>      (partial) is when some are not computed.
!>
!>    (9)     0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise
!>
!>      RCONDV(full) denotes the reciprocal condition numbers of the
!>      right eigenvectors computed when VR, VL and RCONDE are also
!>      computed. RCONDV(partial) denotes the reciprocal condition
!>      numbers when only some of VR, VL and RCONDE are computed.
!>
!>   (10)     |RCONDV - RCDVIN| / cond(RCONDV)
!>
!>      RCONDV is the reciprocal right eigenvector condition number
!>      computed by ZGEEVX and RCDVIN (the precomputed true value)
!>      is supplied as input. cond(RCONDV) is the condition number of
!>      RCONDV, and takes errors in computing RCONDV into account, so
!>      that the resulting quantity should be O(ULP). cond(RCONDV) is
!>      essentially given by norm(A)/RCONDE.
!>
!>   (11)     |RCONDE - RCDEIN| / cond(RCONDE)
!>
!>      RCONDE is the reciprocal eigenvalue condition number
!>      computed by ZGEEVX and RCDEIN (the precomputed true value)
!>      is supplied as input.  cond(RCONDE) is the condition number
!>      of RCONDE, and takes errors in computing RCONDE into account,
!>      so that the resulting quantity should be O(ULP). cond(RCONDE)
!>      is essentially given by norm(A)/RCONDV.
!>
Parameters
[in]COMP
!>          COMP is LOGICAL
!>          COMP describes which input tests to perform:
!>            = .FALSE. if the computed condition numbers are not to
!>                      be tested against RCDVIN and RCDEIN
!>            = .TRUE.  if they are to be compared
!>
[in]ISRT
!>          ISRT is INTEGER
!>          If COMP = .TRUE., ISRT indicates in how the eigenvalues
!>          corresponding to values in RCDVIN and RCDEIN are ordered:
!>            = 0 means the eigenvalues are sorted by
!>                increasing real part
!>            = 1 means the eigenvalues are sorted by
!>                increasing imaginary part
!>          If COMP = .FALSE., ISRT is not referenced.
!>
[in]BALANC
!>          BALANC is CHARACTER
!>          Describes the balancing option to be tested.
!>            = 'N' for no permuting or diagonal scaling
!>            = 'P' for permuting but no diagonal scaling
!>            = 'S' for no permuting but diagonal scaling
!>            = 'B' for permuting and diagonal scaling
!>
[in]JTYPE
!>          JTYPE is INTEGER
!>          Type of input matrix. Used to label output if error occurs.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          If COMP = .FALSE., the random number generator seed
!>          used to produce matrix.
!>          If COMP = .TRUE., ISEED(1) = the number of the example.
!>          Used to label output if error occurs.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[in]N
!>          N is INTEGER
!>          The dimension of A. N must be at least 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, and H. LDA must be at
!>          least 1 and at least N.
!>
[out]H
!>          H is COMPLEX*16 array, dimension (LDA,N)
!>          Another copy of the test matrix A, modified by ZGEEVX.
!>
[out]W
!>          W is COMPLEX*16 array, dimension (N)
!>          Contains the eigenvalues of A.
!>
[out]W1
!>          W1 is COMPLEX*16 array, dimension (N)
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when ZGEEVX only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is COMPLEX*16 array, dimension (LDVL,N)
!>          VL holds the computed left eigenvectors.
!>
[in]LDVL
!>          LDVL is INTEGER
!>          Leading dimension of VL. Must be at least max(1,N).
!>
[out]VR
!>          VR is COMPLEX*16 array, dimension (LDVR,N)
!>          VR holds the computed right eigenvectors.
!>
[in]LDVR
!>          LDVR is INTEGER
!>          Leading dimension of VR. Must be at least max(1,N).
!>
[out]LRE
!>          LRE is COMPLEX*16 array, dimension (LDLRE,N)
!>          LRE holds the computed right or left eigenvectors.
!>
[in]LDLRE
!>          LDLRE is INTEGER
!>          Leading dimension of LRE. Must be at least max(1,N).
!>
[out]RCONDV
!>          RCONDV is DOUBLE PRECISION array, dimension (N)
!>          RCONDV holds the computed reciprocal condition numbers
!>          for eigenvectors.
!>
[out]RCNDV1
!>          RCNDV1 is DOUBLE PRECISION array, dimension (N)
!>          RCNDV1 holds more computed reciprocal condition numbers
!>          for eigenvectors.
!>
[in]RCDVIN
!>          RCDVIN is DOUBLE PRECISION array, dimension (N)
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition numbers for eigenvectors to be compared with
!>          RCONDV.
!>
[out]RCONDE
!>          RCONDE is DOUBLE PRECISION array, dimension (N)
!>          RCONDE holds the computed reciprocal condition numbers
!>          for eigenvalues.
!>
[out]RCNDE1
!>          RCNDE1 is DOUBLE PRECISION array, dimension (N)
!>          RCNDE1 holds more computed reciprocal condition numbers
!>          for eigenvalues.
!>
[in]RCDEIN
!>          RCDEIN is DOUBLE PRECISION array, dimension (N)
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition numbers for eigenvalues to be compared with
!>          RCONDE.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]SCALE1
!>          SCALE1 is DOUBLE PRECISION array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (11)
!>          The values computed by the 11 tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          2*N, and 2*N+N**2 if tests 9, 10 or 11 are to be performed.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0,  successful exit.
!>          If <0, input parameter -INFO had an incorrect value.
!>          If >0, ZGEEVX returned an error code, the absolute
!>                 value of which is returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 363 of file zget23.f.

368*
369* -- LAPACK test routine --
370* -- LAPACK is a software package provided by Univ. of Tennessee, --
371* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
372*
373* .. Scalar Arguments ..
374 LOGICAL COMP
375 CHARACTER BALANC
376 INTEGER INFO, ISRT, JTYPE, LDA, LDLRE, LDVL, LDVR,
377 $ LWORK, N, NOUNIT
378 DOUBLE PRECISION THRESH
379* ..
380* .. Array Arguments ..
381 INTEGER ISEED( 4 )
382 DOUBLE PRECISION RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
383 $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
384 $ RESULT( 11 ), RWORK( * ), SCALE( * ),
385 $ SCALE1( * )
386 COMPLEX*16 A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
387 $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ),
388 $ WORK( * )
389* ..
390*
391* =====================================================================
392*
393* .. Parameters ..
394 DOUBLE PRECISION ZERO, ONE, TWO
395 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
396 DOUBLE PRECISION EPSIN
397 parameter( epsin = 5.9605d-8 )
398* ..
399* .. Local Scalars ..
400 LOGICAL BALOK, NOBAL
401 CHARACTER SENSE
402 INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM,
403 $ J, JJ, KMIN
404 DOUBLE PRECISION ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN,
405 $ ULP, ULPINV, V, VMAX, VMX, VRICMP, VRIMIN,
406 $ VRMX, VTST
407 COMPLEX*16 CTMP
408* ..
409* .. Local Arrays ..
410 CHARACTER SENS( 2 )
411 DOUBLE PRECISION RES( 2 )
412 COMPLEX*16 CDUM( 1 )
413* ..
414* .. External Functions ..
415 LOGICAL LSAME
416 DOUBLE PRECISION DLAMCH, DZNRM2
417 EXTERNAL lsame, dlamch, dznrm2
418* ..
419* .. External Subroutines ..
420 EXTERNAL xerbla, zgeevx, zget22, zlacpy
421* ..
422* .. Intrinsic Functions ..
423 INTRINSIC abs, dble, dimag, max, min
424* ..
425* .. Data statements ..
426 DATA sens / 'N', 'V' /
427* ..
428* .. Executable Statements ..
429*
430* Check for errors
431*
432 nobal = lsame( balanc, 'N' )
433 balok = nobal .OR. lsame( balanc, 'P' ) .OR.
434 $ lsame( balanc, 'S' ) .OR. lsame( balanc, 'B' )
435 info = 0
436 IF( isrt.NE.0 .AND. isrt.NE.1 ) THEN
437 info = -2
438 ELSE IF( .NOT.balok ) THEN
439 info = -3
440 ELSE IF( thresh.LT.zero ) THEN
441 info = -5
442 ELSE IF( nounit.LE.0 ) THEN
443 info = -7
444 ELSE IF( n.LT.0 ) THEN
445 info = -8
446 ELSE IF( lda.LT.1 .OR. lda.LT.n ) THEN
447 info = -10
448 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.n ) THEN
449 info = -15
450 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.n ) THEN
451 info = -17
452 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.n ) THEN
453 info = -19
454 ELSE IF( lwork.LT.2*n .OR. ( comp .AND. lwork.LT.2*n+n*n ) ) THEN
455 info = -30
456 END IF
457*
458 IF( info.NE.0 ) THEN
459 CALL xerbla( 'ZGET23', -info )
460 RETURN
461 END IF
462*
463* Quick return if nothing to do
464*
465 DO 10 i = 1, 11
466 result( i ) = -one
467 10 CONTINUE
468*
469 IF( n.EQ.0 )
470 $ RETURN
471*
472* More Important constants
473*
474 ulp = dlamch( 'Precision' )
475 smlnum = dlamch( 'S' )
476 ulpinv = one / ulp
477*
478* Compute eigenvalues and eigenvectors, and test them
479*
480 IF( lwork.GE.2*n+n*n ) THEN
481 sense = 'B'
482 isensm = 2
483 ELSE
484 sense = 'E'
485 isensm = 1
486 END IF
487 CALL zlacpy( 'F', n, n, a, lda, h, lda )
488 CALL zgeevx( balanc, 'V', 'V', sense, n, h, lda, w, vl, ldvl, vr,
489 $ ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, work,
490 $ lwork, rwork, iinfo )
491 IF( iinfo.NE.0 ) THEN
492 result( 1 ) = ulpinv
493 IF( jtype.NE.22 ) THEN
494 WRITE( nounit, fmt = 9998 )'ZGEEVX1', iinfo, n, jtype,
495 $ balanc, iseed
496 ELSE
497 WRITE( nounit, fmt = 9999 )'ZGEEVX1', iinfo, n, iseed( 1 )
498 END IF
499 info = abs( iinfo )
500 RETURN
501 END IF
502*
503* Do Test (1)
504*
505 CALL zget22( 'N', 'N', 'N', n, a, lda, vr, ldvr, w, work, rwork,
506 $ res )
507 result( 1 ) = res( 1 )
508*
509* Do Test (2)
510*
511 CALL zget22( 'C', 'N', 'C', n, a, lda, vl, ldvl, w, work, rwork,
512 $ res )
513 result( 2 ) = res( 1 )
514*
515* Do Test (3)
516*
517 DO 30 j = 1, n
518 tnrm = dznrm2( n, vr( 1, j ), 1 )
519 result( 3 ) = max( result( 3 ),
520 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
521 vmx = zero
522 vrmx = zero
523 DO 20 jj = 1, n
524 vtst = abs( vr( jj, j ) )
525 IF( vtst.GT.vmx )
526 $ vmx = vtst
527 IF( dimag( vr( jj, j ) ).EQ.zero .AND.
528 $ abs( dble( vr( jj, j ) ) ).GT.vrmx )
529 $ vrmx = abs( dble( vr( jj, j ) ) )
530 20 CONTINUE
531 IF( vrmx / vmx.LT.one-two*ulp )
532 $ result( 3 ) = ulpinv
533 30 CONTINUE
534*
535* Do Test (4)
536*
537 DO 50 j = 1, n
538 tnrm = dznrm2( n, vl( 1, j ), 1 )
539 result( 4 ) = max( result( 4 ),
540 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
541 vmx = zero
542 vrmx = zero
543 DO 40 jj = 1, n
544 vtst = abs( vl( jj, j ) )
545 IF( vtst.GT.vmx )
546 $ vmx = vtst
547 IF( dimag( vl( jj, j ) ).EQ.zero .AND.
548 $ abs( dble( vl( jj, j ) ) ).GT.vrmx )
549 $ vrmx = abs( dble( vl( jj, j ) ) )
550 40 CONTINUE
551 IF( vrmx / vmx.LT.one-two*ulp )
552 $ result( 4 ) = ulpinv
553 50 CONTINUE
554*
555* Test for all options of computing condition numbers
556*
557 DO 200 isens = 1, isensm
558*
559 sense = sens( isens )
560*
561* Compute eigenvalues only, and test them
562*
563 CALL zlacpy( 'F', n, n, a, lda, h, lda )
564 CALL zgeevx( balanc, 'N', 'N', sense, n, h, lda, w1, cdum, 1,
565 $ cdum, 1, ilo1, ihi1, scale1, abnrm1, rcnde1,
566 $ rcndv1, work, lwork, rwork, iinfo )
567 IF( iinfo.NE.0 ) THEN
568 result( 1 ) = ulpinv
569 IF( jtype.NE.22 ) THEN
570 WRITE( nounit, fmt = 9998 )'ZGEEVX2', iinfo, n, jtype,
571 $ balanc, iseed
572 ELSE
573 WRITE( nounit, fmt = 9999 )'ZGEEVX2', iinfo, n,
574 $ iseed( 1 )
575 END IF
576 info = abs( iinfo )
577 GO TO 190
578 END IF
579*
580* Do Test (5)
581*
582 DO 60 j = 1, n
583 IF( w( j ).NE.w1( j ) )
584 $ result( 5 ) = ulpinv
585 60 CONTINUE
586*
587* Do Test (8)
588*
589 IF( .NOT.nobal ) THEN
590 DO 70 j = 1, n
591 IF( scale( j ).NE.scale1( j ) )
592 $ result( 8 ) = ulpinv
593 70 CONTINUE
594 IF( ilo.NE.ilo1 )
595 $ result( 8 ) = ulpinv
596 IF( ihi.NE.ihi1 )
597 $ result( 8 ) = ulpinv
598 IF( abnrm.NE.abnrm1 )
599 $ result( 8 ) = ulpinv
600 END IF
601*
602* Do Test (9)
603*
604 IF( isens.EQ.2 .AND. n.GT.1 ) THEN
605 DO 80 j = 1, n
606 IF( rcondv( j ).NE.rcndv1( j ) )
607 $ result( 9 ) = ulpinv
608 80 CONTINUE
609 END IF
610*
611* Compute eigenvalues and right eigenvectors, and test them
612*
613 CALL zlacpy( 'F', n, n, a, lda, h, lda )
614 CALL zgeevx( balanc, 'N', 'V', sense, n, h, lda, w1, cdum, 1,
615 $ lre, ldlre, ilo1, ihi1, scale1, abnrm1, rcnde1,
616 $ rcndv1, work, lwork, rwork, iinfo )
617 IF( iinfo.NE.0 ) THEN
618 result( 1 ) = ulpinv
619 IF( jtype.NE.22 ) THEN
620 WRITE( nounit, fmt = 9998 )'ZGEEVX3', iinfo, n, jtype,
621 $ balanc, iseed
622 ELSE
623 WRITE( nounit, fmt = 9999 )'ZGEEVX3', iinfo, n,
624 $ iseed( 1 )
625 END IF
626 info = abs( iinfo )
627 GO TO 190
628 END IF
629*
630* Do Test (5) again
631*
632 DO 90 j = 1, n
633 IF( w( j ).NE.w1( j ) )
634 $ result( 5 ) = ulpinv
635 90 CONTINUE
636*
637* Do Test (6)
638*
639 DO 110 j = 1, n
640 DO 100 jj = 1, n
641 IF( vr( j, jj ).NE.lre( j, jj ) )
642 $ result( 6 ) = ulpinv
643 100 CONTINUE
644 110 CONTINUE
645*
646* Do Test (8) again
647*
648 IF( .NOT.nobal ) THEN
649 DO 120 j = 1, n
650 IF( scale( j ).NE.scale1( j ) )
651 $ result( 8 ) = ulpinv
652 120 CONTINUE
653 IF( ilo.NE.ilo1 )
654 $ result( 8 ) = ulpinv
655 IF( ihi.NE.ihi1 )
656 $ result( 8 ) = ulpinv
657 IF( abnrm.NE.abnrm1 )
658 $ result( 8 ) = ulpinv
659 END IF
660*
661* Do Test (9) again
662*
663 IF( isens.EQ.2 .AND. n.GT.1 ) THEN
664 DO 130 j = 1, n
665 IF( rcondv( j ).NE.rcndv1( j ) )
666 $ result( 9 ) = ulpinv
667 130 CONTINUE
668 END IF
669*
670* Compute eigenvalues and left eigenvectors, and test them
671*
672 CALL zlacpy( 'F', n, n, a, lda, h, lda )
673 CALL zgeevx( balanc, 'V', 'N', sense, n, h, lda, w1, lre,
674 $ ldlre, cdum, 1, ilo1, ihi1, scale1, abnrm1,
675 $ rcnde1, rcndv1, work, lwork, rwork, iinfo )
676 IF( iinfo.NE.0 ) THEN
677 result( 1 ) = ulpinv
678 IF( jtype.NE.22 ) THEN
679 WRITE( nounit, fmt = 9998 )'ZGEEVX4', iinfo, n, jtype,
680 $ balanc, iseed
681 ELSE
682 WRITE( nounit, fmt = 9999 )'ZGEEVX4', iinfo, n,
683 $ iseed( 1 )
684 END IF
685 info = abs( iinfo )
686 GO TO 190
687 END IF
688*
689* Do Test (5) again
690*
691 DO 140 j = 1, n
692 IF( w( j ).NE.w1( j ) )
693 $ result( 5 ) = ulpinv
694 140 CONTINUE
695*
696* Do Test (7)
697*
698 DO 160 j = 1, n
699 DO 150 jj = 1, n
700 IF( vl( j, jj ).NE.lre( j, jj ) )
701 $ result( 7 ) = ulpinv
702 150 CONTINUE
703 160 CONTINUE
704*
705* Do Test (8) again
706*
707 IF( .NOT.nobal ) THEN
708 DO 170 j = 1, n
709 IF( scale( j ).NE.scale1( j ) )
710 $ result( 8 ) = ulpinv
711 170 CONTINUE
712 IF( ilo.NE.ilo1 )
713 $ result( 8 ) = ulpinv
714 IF( ihi.NE.ihi1 )
715 $ result( 8 ) = ulpinv
716 IF( abnrm.NE.abnrm1 )
717 $ result( 8 ) = ulpinv
718 END IF
719*
720* Do Test (9) again
721*
722 IF( isens.EQ.2 .AND. n.GT.1 ) THEN
723 DO 180 j = 1, n
724 IF( rcondv( j ).NE.rcndv1( j ) )
725 $ result( 9 ) = ulpinv
726 180 CONTINUE
727 END IF
728*
729 190 CONTINUE
730*
731 200 CONTINUE
732*
733* If COMP, compare condition numbers to precomputed ones
734*
735 IF( comp ) THEN
736 CALL zlacpy( 'F', n, n, a, lda, h, lda )
737 CALL zgeevx( 'N', 'V', 'V', 'B', n, h, lda, w, vl, ldvl, vr,
738 $ ldvr, ilo, ihi, scale, abnrm, rconde, rcondv,
739 $ work, lwork, rwork, iinfo )
740 IF( iinfo.NE.0 ) THEN
741 result( 1 ) = ulpinv
742 WRITE( nounit, fmt = 9999 )'ZGEEVX5', iinfo, n, iseed( 1 )
743 info = abs( iinfo )
744 GO TO 250
745 END IF
746*
747* Sort eigenvalues and condition numbers lexicographically
748* to compare with inputs
749*
750 DO 220 i = 1, n - 1
751 kmin = i
752 IF( isrt.EQ.0 ) THEN
753 vrimin = dble( w( i ) )
754 ELSE
755 vrimin = dimag( w( i ) )
756 END IF
757 DO 210 j = i + 1, n
758 IF( isrt.EQ.0 ) THEN
759 vricmp = dble( w( j ) )
760 ELSE
761 vricmp = dimag( w( j ) )
762 END IF
763 IF( vricmp.LT.vrimin ) THEN
764 kmin = j
765 vrimin = vricmp
766 END IF
767 210 CONTINUE
768 ctmp = w( kmin )
769 w( kmin ) = w( i )
770 w( i ) = ctmp
771 vrimin = rconde( kmin )
772 rconde( kmin ) = rconde( i )
773 rconde( i ) = vrimin
774 vrimin = rcondv( kmin )
775 rcondv( kmin ) = rcondv( i )
776 rcondv( i ) = vrimin
777 220 CONTINUE
778*
779* Compare condition numbers for eigenvectors
780* taking their condition numbers into account
781*
782 result( 10 ) = zero
783 eps = max( epsin, ulp )
784 v = max( dble( n )*eps*abnrm, smlnum )
785 IF( abnrm.EQ.zero )
786 $ v = one
787 DO 230 i = 1, n
788 IF( v.GT.rcondv( i )*rconde( i ) ) THEN
789 tol = rcondv( i )
790 ELSE
791 tol = v / rconde( i )
792 END IF
793 IF( v.GT.rcdvin( i )*rcdein( i ) ) THEN
794 tolin = rcdvin( i )
795 ELSE
796 tolin = v / rcdein( i )
797 END IF
798 tol = max( tol, smlnum / eps )
799 tolin = max( tolin, smlnum / eps )
800 IF( eps*( rcdvin( i )-tolin ).GT.rcondv( i )+tol ) THEN
801 vmax = one / eps
802 ELSE IF( rcdvin( i )-tolin.GT.rcondv( i )+tol ) THEN
803 vmax = ( rcdvin( i )-tolin ) / ( rcondv( i )+tol )
804 ELSE IF( rcdvin( i )+tolin.LT.eps*( rcondv( i )-tol ) ) THEN
805 vmax = one / eps
806 ELSE IF( rcdvin( i )+tolin.LT.rcondv( i )-tol ) THEN
807 vmax = ( rcondv( i )-tol ) / ( rcdvin( i )+tolin )
808 ELSE
809 vmax = one
810 END IF
811 result( 10 ) = max( result( 10 ), vmax )
812 230 CONTINUE
813*
814* Compare condition numbers for eigenvalues
815* taking their condition numbers into account
816*
817 result( 11 ) = zero
818 DO 240 i = 1, n
819 IF( v.GT.rcondv( i ) ) THEN
820 tol = one
821 ELSE
822 tol = v / rcondv( i )
823 END IF
824 IF( v.GT.rcdvin( i ) ) THEN
825 tolin = one
826 ELSE
827 tolin = v / rcdvin( i )
828 END IF
829 tol = max( tol, smlnum / eps )
830 tolin = max( tolin, smlnum / eps )
831 IF( eps*( rcdein( i )-tolin ).GT.rconde( i )+tol ) THEN
832 vmax = one / eps
833 ELSE IF( rcdein( i )-tolin.GT.rconde( i )+tol ) THEN
834 vmax = ( rcdein( i )-tolin ) / ( rconde( i )+tol )
835 ELSE IF( rcdein( i )+tolin.LT.eps*( rconde( i )-tol ) ) THEN
836 vmax = one / eps
837 ELSE IF( rcdein( i )+tolin.LT.rconde( i )-tol ) THEN
838 vmax = ( rconde( i )-tol ) / ( rcdein( i )+tolin )
839 ELSE
840 vmax = one
841 END IF
842 result( 11 ) = max( result( 11 ), vmax )
843 240 CONTINUE
844 250 CONTINUE
845*
846 END IF
847*
848 9999 FORMAT( ' ZGET23: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
849 $ i6, ', INPUT EXAMPLE NUMBER = ', i4 )
850 9998 FORMAT( ' ZGET23: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
851 $ i6, ', JTYPE=', i6, ', BALANC = ', a, ', ISEED=(',
852 $ 3( i5, ',' ), i5, ')' )
853*
854 RETURN
855*
856* End of ZGET23
857*
comp
int comp(int a, int b)
Definition set_surface_lines.cpp:102

◆ zget24()

subroutine zget24 ( logical comp,
integer jtype,
double precision thresh,
integer, dimension( 4 ) iseed,
integer nounit,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) h,
complex*16, dimension( lda, * ) ht,
complex*16, dimension( * ) w,
complex*16, dimension( * ) wt,
complex*16, dimension( * ) wtmp,
complex*16, dimension( ldvs, * ) vs,
integer ldvs,
complex*16, dimension( ldvs, * ) vs1,
double precision rcdein,
double precision rcdvin,
integer nslct,
integer, dimension( * ) islct,
integer isrt,
double precision, dimension( 17 ) result,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
logical, dimension( * ) bwork,
integer info )

ZGET24

Purpose:
!>
!>    ZGET24 checks the nonsymmetric eigenvalue (Schur form) problem
!>    expert driver ZGEESX.
!>
!>    If COMP = .FALSE., the first 13 of the following tests will be
!>    be performed on the input matrix A, and also tests 14 and 15
!>    if LWORK is sufficiently large.
!>    If COMP = .TRUE., all 17 test will be performed.
!>
!>    (1)     0 if T is in Schur form, 1/ulp otherwise
!>           (no sorting of eigenvalues)
!>
!>    (2)     | A - VS T VS' | / ( n |A| ulp )
!>
!>      Here VS is the matrix of Schur eigenvectors, and T is in Schur
!>      form  (no sorting of eigenvalues).
!>
!>    (3)     | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
!>
!>    (4)     0     if W are eigenvalues of T
!>            1/ulp otherwise
!>            (no sorting of eigenvalues)
!>
!>    (5)     0     if T(with VS) = T(without VS),
!>            1/ulp otherwise
!>            (no sorting of eigenvalues)
!>
!>    (6)     0     if eigenvalues(with VS) = eigenvalues(without VS),
!>            1/ulp otherwise
!>            (no sorting of eigenvalues)
!>
!>    (7)     0 if T is in Schur form, 1/ulp otherwise
!>            (with sorting of eigenvalues)
!>
!>    (8)     | A - VS T VS' | / ( n |A| ulp )
!>
!>      Here VS is the matrix of Schur eigenvectors, and T is in Schur
!>      form  (with sorting of eigenvalues).
!>
!>    (9)     | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
!>
!>    (10)    0     if W are eigenvalues of T
!>            1/ulp otherwise
!>            If workspace sufficient, also compare W with and
!>            without reciprocal condition numbers
!>            (with sorting of eigenvalues)
!>
!>    (11)    0     if T(with VS) = T(without VS),
!>            1/ulp otherwise
!>            If workspace sufficient, also compare T with and without
!>            reciprocal condition numbers
!>            (with sorting of eigenvalues)
!>
!>    (12)    0     if eigenvalues(with VS) = eigenvalues(without VS),
!>            1/ulp otherwise
!>            If workspace sufficient, also compare VS with and without
!>            reciprocal condition numbers
!>            (with sorting of eigenvalues)
!>
!>    (13)    if sorting worked and SDIM is the number of
!>            eigenvalues which were SELECTed
!>            If workspace sufficient, also compare SDIM with and
!>            without reciprocal condition numbers
!>
!>    (14)    if RCONDE the same no matter if VS and/or RCONDV computed
!>
!>    (15)    if RCONDV the same no matter if VS and/or RCONDE computed
!>
!>    (16)  |RCONDE - RCDEIN| / cond(RCONDE)
!>
!>       RCONDE is the reciprocal average eigenvalue condition number
!>       computed by ZGEESX and RCDEIN (the precomputed true value)
!>       is supplied as input.  cond(RCONDE) is the condition number
!>       of RCONDE, and takes errors in computing RCONDE into account,
!>       so that the resulting quantity should be O(ULP). cond(RCONDE)
!>       is essentially given by norm(A)/RCONDV.
!>
!>    (17)  |RCONDV - RCDVIN| / cond(RCONDV)
!>
!>       RCONDV is the reciprocal right invariant subspace condition
!>       number computed by ZGEESX and RCDVIN (the precomputed true
!>       value) is supplied as input. cond(RCONDV) is the condition
!>       number of RCONDV, and takes errors in computing RCONDV into
!>       account, so that the resulting quantity should be O(ULP).
!>       cond(RCONDV) is essentially given by norm(A)/RCONDE.
!>
Parameters
[in]COMP
!>          COMP is LOGICAL
!>          COMP describes which input tests to perform:
!>            = .FALSE. if the computed condition numbers are not to
!>                      be tested against RCDVIN and RCDEIN
!>            = .TRUE.  if they are to be compared
!>
[in]JTYPE
!>          JTYPE is INTEGER
!>          Type of input matrix. Used to label output if error occurs.
!>
[in]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          If COMP = .FALSE., the random number generator seed
!>          used to produce matrix.
!>          If COMP = .TRUE., ISEED(1) = the number of the example.
!>          Used to label output if error occurs.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[in]N
!>          N is INTEGER
!>          The dimension of A. N must be at least 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, and H. LDA must be at
!>          least 1 and at least N.
!>
[out]H
!>          H is COMPLEX*16 array, dimension (LDA, N)
!>          Another copy of the test matrix A, modified by ZGEESX.
!>
[out]HT
!>          HT is COMPLEX*16 array, dimension (LDA, N)
!>          Yet another copy of the test matrix A, modified by ZGEESX.
!>
[out]W
!>          W is COMPLEX*16 array, dimension (N)
!>          The computed eigenvalues of A.
!>
[out]WT
!>          WT is COMPLEX*16 array, dimension (N)
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when ZGEESX only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]WTMP
!>          WTMP is COMPLEX*16 array, dimension (N)
!>          Like W, this array contains the eigenvalues of A,
!>          but sorted by increasing real or imaginary part.
!>
[out]VS
!>          VS is COMPLEX*16 array, dimension (LDVS, N)
!>          VS holds the computed Schur vectors.
!>
[in]LDVS
!>          LDVS is INTEGER
!>          Leading dimension of VS. Must be at least max(1, N).
!>
[out]VS1
!>          VS1 is COMPLEX*16 array, dimension (LDVS, N)
!>          VS1 holds another copy of the computed Schur vectors.
!>
[in]RCDEIN
!>          RCDEIN is DOUBLE PRECISION
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition number for the average of selected eigenvalues.
!>
[in]RCDVIN
!>          RCDVIN is DOUBLE PRECISION
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition number for the selected right invariant subspace.
!>
[in]NSLCT
!>          NSLCT is INTEGER
!>          When COMP = .TRUE. the number of selected eigenvalues
!>          corresponding to the precomputed values RCDEIN and RCDVIN.
!>
[in]ISLCT
!>          ISLCT is INTEGER array, dimension (NSLCT)
!>          When COMP = .TRUE. ISLCT selects the eigenvalues of the
!>          input matrix corresponding to the precomputed values RCDEIN
!>          and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the
!>          eigenvalue with the J-th largest real or imaginary part is
!>          selected. The real part is used if ISRT = 0, and the
!>          imaginary part if ISRT = 1.
!>          Not referenced if COMP = .FALSE.
!>
[in]ISRT
!>          ISRT is INTEGER
!>          When COMP = .TRUE., ISRT describes how ISLCT is used to
!>          choose a subset of the spectrum.
!>          Not referenced if COMP = .FALSE.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (17)
!>          The values computed by the 17 tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N*N)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK to be passed to ZGEESX. This
!>          must be at least 2*N, and N*(N+1)/2 if tests 14--16 are to
!>          be performed.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]BWORK
!>          BWORK is LOGICAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0,  successful exit.
!>          If <0, input parameter -INFO had an incorrect value.
!>          If >0, ZGEESX returned an error code, the absolute
!>                 value of which is returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 331 of file zget24.f.

335*
336* -- LAPACK test routine --
337* -- LAPACK is a software package provided by Univ. of Tennessee, --
338* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
339*
340* .. Scalar Arguments ..
341 LOGICAL COMP
342 INTEGER INFO, ISRT, JTYPE, LDA, LDVS, LWORK, N, NOUNIT,
343 $ NSLCT
344 DOUBLE PRECISION RCDEIN, RCDVIN, THRESH
345* ..
346* .. Array Arguments ..
347 LOGICAL BWORK( * )
348 INTEGER ISEED( 4 ), ISLCT( * )
349 DOUBLE PRECISION RESULT( 17 ), RWORK( * )
350 COMPLEX*16 A( LDA, * ), H( LDA, * ), HT( LDA, * ),
351 $ VS( LDVS, * ), VS1( LDVS, * ), W( * ),
352 $ WORK( * ), WT( * ), WTMP( * )
353* ..
354*
355* =====================================================================
356*
357* .. Parameters ..
358 COMPLEX*16 CZERO, CONE
359 parameter( czero = ( 0.0d+0, 0.0d+0 ),
360 $ cone = ( 1.0d+0, 0.0d+0 ) )
361 DOUBLE PRECISION ZERO, ONE
362 parameter( zero = 0.0d+0, one = 1.0d+0 )
363 DOUBLE PRECISION EPSIN
364 parameter( epsin = 5.9605d-8 )
365* ..
366* .. Local Scalars ..
367 CHARACTER SORT
368 INTEGER I, IINFO, ISORT, ITMP, J, KMIN, KNTEIG, RSUB,
369 $ SDIM, SDIM1
370 DOUBLE PRECISION ANORM, EPS, RCNDE1, RCNDV1, RCONDE, RCONDV,
371 $ SMLNUM, TOL, TOLIN, ULP, ULPINV, V, VRICMP,
372 $ VRIMIN, WNORM
373 COMPLEX*16 CTMP
374* ..
375* .. Local Arrays ..
376 INTEGER IPNT( 20 )
377* ..
378* .. External Functions ..
379 LOGICAL ZSLECT
380 DOUBLE PRECISION DLAMCH, ZLANGE
381 EXTERNAL zslect, dlamch, zlange
382* ..
383* .. External Subroutines ..
384 EXTERNAL xerbla, zcopy, zgeesx, zgemm, zlacpy, zunt01
385* ..
386* .. Intrinsic Functions ..
387 INTRINSIC abs, dble, dimag, max, min
388* ..
389* .. Arrays in Common ..
390 LOGICAL SELVAL( 20 )
391 DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
392* ..
393* .. Scalars in Common ..
394 INTEGER SELDIM, SELOPT
395* ..
396* .. Common blocks ..
397 COMMON / sslct / selopt, seldim, selval, selwr, selwi
398* ..
399* .. Executable Statements ..
400*
401* Check for errors
402*
403 info = 0
404 IF( thresh.LT.zero ) THEN
405 info = -3
406 ELSE IF( nounit.LE.0 ) THEN
407 info = -5
408 ELSE IF( n.LT.0 ) THEN
409 info = -6
410 ELSE IF( lda.LT.1 .OR. lda.LT.n ) THEN
411 info = -8
412 ELSE IF( ldvs.LT.1 .OR. ldvs.LT.n ) THEN
413 info = -15
414 ELSE IF( lwork.LT.2*n ) THEN
415 info = -24
416 END IF
417*
418 IF( info.NE.0 ) THEN
419 CALL xerbla( 'ZGET24', -info )
420 RETURN
421 END IF
422*
423* Quick return if nothing to do
424*
425 DO 10 i = 1, 17
426 result( i ) = -one
427 10 CONTINUE
428*
429 IF( n.EQ.0 )
430 $ RETURN
431*
432* Important constants
433*
434 smlnum = dlamch( 'Safe minimum' )
435 ulp = dlamch( 'Precision' )
436 ulpinv = one / ulp
437*
438* Perform tests (1)-(13)
439*
440 selopt = 0
441 DO 90 isort = 0, 1
442 IF( isort.EQ.0 ) THEN
443 sort = 'N'
444 rsub = 0
445 ELSE
446 sort = 'S'
447 rsub = 6
448 END IF
449*
450* Compute Schur form and Schur vectors, and test them
451*
452 CALL zlacpy( 'F', n, n, a, lda, h, lda )
453 CALL zgeesx( 'V', sort, zslect, 'N', n, h, lda, sdim, w, vs,
454 $ ldvs, rconde, rcondv, work, lwork, rwork, bwork,
455 $ iinfo )
456 IF( iinfo.NE.0 ) THEN
457 result( 1+rsub ) = ulpinv
458 IF( jtype.NE.22 ) THEN
459 WRITE( nounit, fmt = 9998 )'ZGEESX1', iinfo, n, jtype,
460 $ iseed
461 ELSE
462 WRITE( nounit, fmt = 9999 )'ZGEESX1', iinfo, n,
463 $ iseed( 1 )
464 END IF
465 info = abs( iinfo )
466 RETURN
467 END IF
468 IF( isort.EQ.0 ) THEN
469 CALL zcopy( n, w, 1, wtmp, 1 )
470 END IF
471*
472* Do Test (1) or Test (7)
473*
474 result( 1+rsub ) = zero
475 DO 30 j = 1, n - 1
476 DO 20 i = j + 1, n
477 IF( h( i, j ).NE.czero )
478 $ result( 1+rsub ) = ulpinv
479 20 CONTINUE
480 30 CONTINUE
481*
482* Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP)
483*
484* Copy A to VS1, used as workspace
485*
486 CALL zlacpy( ' ', n, n, a, lda, vs1, ldvs )
487*
488* Compute Q*H and store in HT.
489*
490 CALL zgemm( 'No transpose', 'No transpose', n, n, n, cone, vs,
491 $ ldvs, h, lda, czero, ht, lda )
492*
493* Compute A - Q*H*Q'
494*
495 CALL zgemm( 'No transpose', 'Conjugate transpose', n, n, n,
496 $ -cone, ht, lda, vs, ldvs, cone, vs1, ldvs )
497*
498 anorm = max( zlange( '1', n, n, a, lda, rwork ), smlnum )
499 wnorm = zlange( '1', n, n, vs1, ldvs, rwork )
500*
501 IF( anorm.GT.wnorm ) THEN
502 result( 2+rsub ) = ( wnorm / anorm ) / ( n*ulp )
503 ELSE
504 IF( anorm.LT.one ) THEN
505 result( 2+rsub ) = ( min( wnorm, n*anorm ) / anorm ) /
506 $ ( n*ulp )
507 ELSE
508 result( 2+rsub ) = min( wnorm / anorm, dble( n ) ) /
509 $ ( n*ulp )
510 END IF
511 END IF
512*
513* Test (3) or (9): Compute norm( I - Q'*Q ) / ( N * ULP )
514*
515 CALL zunt01( 'Columns', n, n, vs, ldvs, work, lwork, rwork,
516 $ result( 3+rsub ) )
517*
518* Do Test (4) or Test (10)
519*
520 result( 4+rsub ) = zero
521 DO 40 i = 1, n
522 IF( h( i, i ).NE.w( i ) )
523 $ result( 4+rsub ) = ulpinv
524 40 CONTINUE
525*
526* Do Test (5) or Test (11)
527*
528 CALL zlacpy( 'F', n, n, a, lda, ht, lda )
529 CALL zgeesx( 'N', sort, zslect, 'N', n, ht, lda, sdim, wt, vs,
530 $ ldvs, rconde, rcondv, work, lwork, rwork, bwork,
531 $ iinfo )
532 IF( iinfo.NE.0 ) THEN
533 result( 5+rsub ) = ulpinv
534 IF( jtype.NE.22 ) THEN
535 WRITE( nounit, fmt = 9998 )'ZGEESX2', iinfo, n, jtype,
536 $ iseed
537 ELSE
538 WRITE( nounit, fmt = 9999 )'ZGEESX2', iinfo, n,
539 $ iseed( 1 )
540 END IF
541 info = abs( iinfo )
542 GO TO 220
543 END IF
544*
545 result( 5+rsub ) = zero
546 DO 60 j = 1, n
547 DO 50 i = 1, n
548 IF( h( i, j ).NE.ht( i, j ) )
549 $ result( 5+rsub ) = ulpinv
550 50 CONTINUE
551 60 CONTINUE
552*
553* Do Test (6) or Test (12)
554*
555 result( 6+rsub ) = zero
556 DO 70 i = 1, n
557 IF( w( i ).NE.wt( i ) )
558 $ result( 6+rsub ) = ulpinv
559 70 CONTINUE
560*
561* Do Test (13)
562*
563 IF( isort.EQ.1 ) THEN
564 result( 13 ) = zero
565 knteig = 0
566 DO 80 i = 1, n
567 IF( zslect( w( i ) ) )
568 $ knteig = knteig + 1
569 IF( i.LT.n ) THEN
570 IF( zslect( w( i+1 ) ) .AND.
571 $ ( .NOT.zslect( w( i ) ) ) )result( 13 ) = ulpinv
572 END IF
573 80 CONTINUE
574 IF( sdim.NE.knteig )
575 $ result( 13 ) = ulpinv
576 END IF
577*
578 90 CONTINUE
579*
580* If there is enough workspace, perform tests (14) and (15)
581* as well as (10) through (13)
582*
583 IF( lwork.GE.( n*( n+1 ) ) / 2 ) THEN
584*
585* Compute both RCONDE and RCONDV with VS
586*
587 sort = 'S'
588 result( 14 ) = zero
589 result( 15 ) = zero
590 CALL zlacpy( 'F', n, n, a, lda, ht, lda )
591 CALL zgeesx( 'V', sort, zslect, 'B', n, ht, lda, sdim1, wt,
592 $ vs1, ldvs, rconde, rcondv, work, lwork, rwork,
593 $ bwork, iinfo )
594 IF( iinfo.NE.0 ) THEN
595 result( 14 ) = ulpinv
596 result( 15 ) = ulpinv
597 IF( jtype.NE.22 ) THEN
598 WRITE( nounit, fmt = 9998 )'ZGEESX3', iinfo, n, jtype,
599 $ iseed
600 ELSE
601 WRITE( nounit, fmt = 9999 )'ZGEESX3', iinfo, n,
602 $ iseed( 1 )
603 END IF
604 info = abs( iinfo )
605 GO TO 220
606 END IF
607*
608* Perform tests (10), (11), (12), and (13)
609*
610 DO 110 i = 1, n
611 IF( w( i ).NE.wt( i ) )
612 $ result( 10 ) = ulpinv
613 DO 100 j = 1, n
614 IF( h( i, j ).NE.ht( i, j ) )
615 $ result( 11 ) = ulpinv
616 IF( vs( i, j ).NE.vs1( i, j ) )
617 $ result( 12 ) = ulpinv
618 100 CONTINUE
619 110 CONTINUE
620 IF( sdim.NE.sdim1 )
621 $ result( 13 ) = ulpinv
622*
623* Compute both RCONDE and RCONDV without VS, and compare
624*
625 CALL zlacpy( 'F', n, n, a, lda, ht, lda )
626 CALL zgeesx( 'N', sort, zslect, 'B', n, ht, lda, sdim1, wt,
627 $ vs1, ldvs, rcnde1, rcndv1, work, lwork, rwork,
628 $ bwork, iinfo )
629 IF( iinfo.NE.0 ) THEN
630 result( 14 ) = ulpinv
631 result( 15 ) = ulpinv
632 IF( jtype.NE.22 ) THEN
633 WRITE( nounit, fmt = 9998 )'ZGEESX4', iinfo, n, jtype,
634 $ iseed
635 ELSE
636 WRITE( nounit, fmt = 9999 )'ZGEESX4', iinfo, n,
637 $ iseed( 1 )
638 END IF
639 info = abs( iinfo )
640 GO TO 220
641 END IF
642*
643* Perform tests (14) and (15)
644*
645 IF( rcnde1.NE.rconde )
646 $ result( 14 ) = ulpinv
647 IF( rcndv1.NE.rcondv )
648 $ result( 15 ) = ulpinv
649*
650* Perform tests (10), (11), (12), and (13)
651*
652 DO 130 i = 1, n
653 IF( w( i ).NE.wt( i ) )
654 $ result( 10 ) = ulpinv
655 DO 120 j = 1, n
656 IF( h( i, j ).NE.ht( i, j ) )
657 $ result( 11 ) = ulpinv
658 IF( vs( i, j ).NE.vs1( i, j ) )
659 $ result( 12 ) = ulpinv
660 120 CONTINUE
661 130 CONTINUE
662 IF( sdim.NE.sdim1 )
663 $ result( 13 ) = ulpinv
664*
665* Compute RCONDE with VS, and compare
666*
667 CALL zlacpy( 'F', n, n, a, lda, ht, lda )
668 CALL zgeesx( 'V', sort, zslect, 'E', n, ht, lda, sdim1, wt,
669 $ vs1, ldvs, rcnde1, rcndv1, work, lwork, rwork,
670 $ bwork, iinfo )
671 IF( iinfo.NE.0 ) THEN
672 result( 14 ) = ulpinv
673 IF( jtype.NE.22 ) THEN
674 WRITE( nounit, fmt = 9998 )'ZGEESX5', iinfo, n, jtype,
675 $ iseed
676 ELSE
677 WRITE( nounit, fmt = 9999 )'ZGEESX5', iinfo, n,
678 $ iseed( 1 )
679 END IF
680 info = abs( iinfo )
681 GO TO 220
682 END IF
683*
684* Perform test (14)
685*
686 IF( rcnde1.NE.rconde )
687 $ result( 14 ) = ulpinv
688*
689* Perform tests (10), (11), (12), and (13)
690*
691 DO 150 i = 1, n
692 IF( w( i ).NE.wt( i ) )
693 $ result( 10 ) = ulpinv
694 DO 140 j = 1, n
695 IF( h( i, j ).NE.ht( i, j ) )
696 $ result( 11 ) = ulpinv
697 IF( vs( i, j ).NE.vs1( i, j ) )
698 $ result( 12 ) = ulpinv
699 140 CONTINUE
700 150 CONTINUE
701 IF( sdim.NE.sdim1 )
702 $ result( 13 ) = ulpinv
703*
704* Compute RCONDE without VS, and compare
705*
706 CALL zlacpy( 'F', n, n, a, lda, ht, lda )
707 CALL zgeesx( 'N', sort, zslect, 'E', n, ht, lda, sdim1, wt,
708 $ vs1, ldvs, rcnde1, rcndv1, work, lwork, rwork,
709 $ bwork, iinfo )
710 IF( iinfo.NE.0 ) THEN
711 result( 14 ) = ulpinv
712 IF( jtype.NE.22 ) THEN
713 WRITE( nounit, fmt = 9998 )'ZGEESX6', iinfo, n, jtype,
714 $ iseed
715 ELSE
716 WRITE( nounit, fmt = 9999 )'ZGEESX6', iinfo, n,
717 $ iseed( 1 )
718 END IF
719 info = abs( iinfo )
720 GO TO 220
721 END IF
722*
723* Perform test (14)
724*
725 IF( rcnde1.NE.rconde )
726 $ result( 14 ) = ulpinv
727*
728* Perform tests (10), (11), (12), and (13)
729*
730 DO 170 i = 1, n
731 IF( w( i ).NE.wt( i ) )
732 $ result( 10 ) = ulpinv
733 DO 160 j = 1, n
734 IF( h( i, j ).NE.ht( i, j ) )
735 $ result( 11 ) = ulpinv
736 IF( vs( i, j ).NE.vs1( i, j ) )
737 $ result( 12 ) = ulpinv
738 160 CONTINUE
739 170 CONTINUE
740 IF( sdim.NE.sdim1 )
741 $ result( 13 ) = ulpinv
742*
743* Compute RCONDV with VS, and compare
744*
745 CALL zlacpy( 'F', n, n, a, lda, ht, lda )
746 CALL zgeesx( 'V', sort, zslect, 'V', n, ht, lda, sdim1, wt,
747 $ vs1, ldvs, rcnde1, rcndv1, work, lwork, rwork,
748 $ bwork, iinfo )
749 IF( iinfo.NE.0 ) THEN
750 result( 15 ) = ulpinv
751 IF( jtype.NE.22 ) THEN
752 WRITE( nounit, fmt = 9998 )'ZGEESX7', iinfo, n, jtype,
753 $ iseed
754 ELSE
755 WRITE( nounit, fmt = 9999 )'ZGEESX7', iinfo, n,
756 $ iseed( 1 )
757 END IF
758 info = abs( iinfo )
759 GO TO 220
760 END IF
761*
762* Perform test (15)
763*
764 IF( rcndv1.NE.rcondv )
765 $ result( 15 ) = ulpinv
766*
767* Perform tests (10), (11), (12), and (13)
768*
769 DO 190 i = 1, n
770 IF( w( i ).NE.wt( i ) )
771 $ result( 10 ) = ulpinv
772 DO 180 j = 1, n
773 IF( h( i, j ).NE.ht( i, j ) )
774 $ result( 11 ) = ulpinv
775 IF( vs( i, j ).NE.vs1( i, j ) )
776 $ result( 12 ) = ulpinv
777 180 CONTINUE
778 190 CONTINUE
779 IF( sdim.NE.sdim1 )
780 $ result( 13 ) = ulpinv
781*
782* Compute RCONDV without VS, and compare
783*
784 CALL zlacpy( 'F', n, n, a, lda, ht, lda )
785 CALL zgeesx( 'N', sort, zslect, 'V', n, ht, lda, sdim1, wt,
786 $ vs1, ldvs, rcnde1, rcndv1, work, lwork, rwork,
787 $ bwork, iinfo )
788 IF( iinfo.NE.0 ) THEN
789 result( 15 ) = ulpinv
790 IF( jtype.NE.22 ) THEN
791 WRITE( nounit, fmt = 9998 )'ZGEESX8', iinfo, n, jtype,
792 $ iseed
793 ELSE
794 WRITE( nounit, fmt = 9999 )'ZGEESX8', iinfo, n,
795 $ iseed( 1 )
796 END IF
797 info = abs( iinfo )
798 GO TO 220
799 END IF
800*
801* Perform test (15)
802*
803 IF( rcndv1.NE.rcondv )
804 $ result( 15 ) = ulpinv
805*
806* Perform tests (10), (11), (12), and (13)
807*
808 DO 210 i = 1, n
809 IF( w( i ).NE.wt( i ) )
810 $ result( 10 ) = ulpinv
811 DO 200 j = 1, n
812 IF( h( i, j ).NE.ht( i, j ) )
813 $ result( 11 ) = ulpinv
814 IF( vs( i, j ).NE.vs1( i, j ) )
815 $ result( 12 ) = ulpinv
816 200 CONTINUE
817 210 CONTINUE
818 IF( sdim.NE.sdim1 )
819 $ result( 13 ) = ulpinv
820*
821 END IF
822*
823 220 CONTINUE
824*
825* If there are precomputed reciprocal condition numbers, compare
826* computed values with them.
827*
828 IF( comp ) THEN
829*
830* First set up SELOPT, SELDIM, SELVAL, SELWR and SELWI so that
831* the logical function ZSLECT selects the eigenvalues specified
832* by NSLCT, ISLCT and ISRT.
833*
834 seldim = n
835 selopt = 1
836 eps = max( ulp, epsin )
837 DO 230 i = 1, n
838 ipnt( i ) = i
839 selval( i ) = .false.
840 selwr( i ) = dble( wtmp( i ) )
841 selwi( i ) = dimag( wtmp( i ) )
842 230 CONTINUE
843 DO 250 i = 1, n - 1
844 kmin = i
845 IF( isrt.EQ.0 ) THEN
846 vrimin = dble( wtmp( i ) )
847 ELSE
848 vrimin = dimag( wtmp( i ) )
849 END IF
850 DO 240 j = i + 1, n
851 IF( isrt.EQ.0 ) THEN
852 vricmp = dble( wtmp( j ) )
853 ELSE
854 vricmp = dimag( wtmp( j ) )
855 END IF
856 IF( vricmp.LT.vrimin ) THEN
857 kmin = j
858 vrimin = vricmp
859 END IF
860 240 CONTINUE
861 ctmp = wtmp( kmin )
862 wtmp( kmin ) = wtmp( i )
863 wtmp( i ) = ctmp
864 itmp = ipnt( i )
865 ipnt( i ) = ipnt( kmin )
866 ipnt( kmin ) = itmp
867 250 CONTINUE
868 DO 260 i = 1, nslct
869 selval( ipnt( islct( i ) ) ) = .true.
870 260 CONTINUE
871*
872* Compute condition numbers
873*
874 CALL zlacpy( 'F', n, n, a, lda, ht, lda )
875 CALL zgeesx( 'N', 'S', zslect, 'B', n, ht, lda, sdim1, wt, vs1,
876 $ ldvs, rconde, rcondv, work, lwork, rwork, bwork,
877 $ iinfo )
878 IF( iinfo.NE.0 ) THEN
879 result( 16 ) = ulpinv
880 result( 17 ) = ulpinv
881 WRITE( nounit, fmt = 9999 )'ZGEESX9', iinfo, n, iseed( 1 )
882 info = abs( iinfo )
883 GO TO 270
884 END IF
885*
886* Compare condition number for average of selected eigenvalues
887* taking its condition number into account
888*
889 anorm = zlange( '1', n, n, a, lda, rwork )
890 v = max( dble( n )*eps*anorm, smlnum )
891 IF( anorm.EQ.zero )
892 $ v = one
893 IF( v.GT.rcondv ) THEN
894 tol = one
895 ELSE
896 tol = v / rcondv
897 END IF
898 IF( v.GT.rcdvin ) THEN
899 tolin = one
900 ELSE
901 tolin = v / rcdvin
902 END IF
903 tol = max( tol, smlnum / eps )
904 tolin = max( tolin, smlnum / eps )
905 IF( eps*( rcdein-tolin ).GT.rconde+tol ) THEN
906 result( 16 ) = ulpinv
907 ELSE IF( rcdein-tolin.GT.rconde+tol ) THEN
908 result( 16 ) = ( rcdein-tolin ) / ( rconde+tol )
909 ELSE IF( rcdein+tolin.LT.eps*( rconde-tol ) ) THEN
910 result( 16 ) = ulpinv
911 ELSE IF( rcdein+tolin.LT.rconde-tol ) THEN
912 result( 16 ) = ( rconde-tol ) / ( rcdein+tolin )
913 ELSE
914 result( 16 ) = one
915 END IF
916*
917* Compare condition numbers for right invariant subspace
918* taking its condition number into account
919*
920 IF( v.GT.rcondv*rconde ) THEN
921 tol = rcondv
922 ELSE
923 tol = v / rconde
924 END IF
925 IF( v.GT.rcdvin*rcdein ) THEN
926 tolin = rcdvin
927 ELSE
928 tolin = v / rcdein
929 END IF
930 tol = max( tol, smlnum / eps )
931 tolin = max( tolin, smlnum / eps )
932 IF( eps*( rcdvin-tolin ).GT.rcondv+tol ) THEN
933 result( 17 ) = ulpinv
934 ELSE IF( rcdvin-tolin.GT.rcondv+tol ) THEN
935 result( 17 ) = ( rcdvin-tolin ) / ( rcondv+tol )
936 ELSE IF( rcdvin+tolin.LT.eps*( rcondv-tol ) ) THEN
937 result( 17 ) = ulpinv
938 ELSE IF( rcdvin+tolin.LT.rcondv-tol ) THEN
939 result( 17 ) = ( rcondv-tol ) / ( rcdvin+tolin )
940 ELSE
941 result( 17 ) = one
942 END IF
943*
944 270 CONTINUE
945*
946 END IF
947*
948 9999 FORMAT( ' ZGET24: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
949 $ i6, ', INPUT EXAMPLE NUMBER = ', i4 )
950 9998 FORMAT( ' ZGET24: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
951 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
952*
953 RETURN
954*
955* End of ZGET24
956*

◆ zget35()

subroutine zget35 ( double precision rmax,
integer lmax,
integer ninfo,
integer knt,
integer nin )

ZGET35

Purpose:
!>
!> ZGET35 tests ZTRSYL, a routine for solving the Sylvester matrix
!> equation
!>
!>    op(A)*X + ISGN*X*op(B) = scale*C,
!>
!> A and B are assumed to be in Schur canonical form, op() represents an
!> optional transpose, and ISGN can be -1 or +1.  Scale is an output
!> less than or equal to 1, chosen to avoid overflow in X.
!>
!> The test code verifies that the following residual is order 1:
!>
!>    norm(op(A)*X + ISGN*X*op(B) - scale*C) /
!>        (EPS*max(norm(A),norm(B))*norm(X))
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION
!>          Value of the largest test ratio.
!>
[out]LMAX
!>          LMAX is INTEGER
!>          Example number where largest test ratio achieved.
!>
[out]NINFO
!>          NINFO is INTEGER
!>          Number of examples where INFO is nonzero.
!>
[out]KNT
!>          KNT is INTEGER
!>          Total number of examples tested.
!>
[in]NIN
!>          NIN is INTEGER
!>          Input logical unit number.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 83 of file zget35.f.

84*
85* -- LAPACK test routine --
86* -- LAPACK is a software package provided by Univ. of Tennessee, --
87* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
88*
89* .. Scalar Arguments ..
90 INTEGER KNT, LMAX, NIN, NINFO
91 DOUBLE PRECISION RMAX
92* ..
93*
94* =====================================================================
95*
96* .. Parameters ..
97 INTEGER LDT
98 parameter( ldt = 10 )
99 DOUBLE PRECISION ZERO, ONE, TWO
100 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
101 DOUBLE PRECISION LARGE
102 parameter( large = 1.0d6 )
103 COMPLEX*16 CONE
104 parameter( cone = 1.0d0 )
105* ..
106* .. Local Scalars ..
107 CHARACTER TRANA, TRANB
108 INTEGER I, IMLA, IMLAD, IMLB, IMLC, INFO, ISGN, ITRANA,
109 $ ITRANB, J, M, N
110 DOUBLE PRECISION BIGNUM, EPS, RES, RES1, SCALE, SMLNUM, TNRM,
111 $ XNRM
112 COMPLEX*16 RMUL
113* ..
114* .. Local Arrays ..
115 DOUBLE PRECISION DUM( 1 ), VM1( 3 ), VM2( 3 )
116 COMPLEX*16 A( LDT, LDT ), ATMP( LDT, LDT ), B( LDT, LDT ),
117 $ BTMP( LDT, LDT ), C( LDT, LDT ),
118 $ CSAV( LDT, LDT ), CTMP( LDT, LDT )
119* ..
120* .. External Functions ..
121 DOUBLE PRECISION DLAMCH, ZLANGE
122 EXTERNAL dlamch, zlange
123* ..
124* .. External Subroutines ..
125 EXTERNAL dlabad, zgemm, ztrsyl
126* ..
127* .. Intrinsic Functions ..
128 INTRINSIC abs, dble, max, sqrt
129* ..
130* .. Executable Statements ..
131*
132* Get machine parameters
133*
134 eps = dlamch( 'P' )
135 smlnum = dlamch( 'S' ) / eps
136 bignum = one / smlnum
137 CALL dlabad( smlnum, bignum )
138*
139* Set up test case parameters
140*
141 vm1( 1 ) = sqrt( smlnum )
142 vm1( 2 ) = one
143 vm1( 3 ) = large
144 vm2( 1 ) = one
145 vm2( 2 ) = one + two*eps
146 vm2( 3 ) = two
147*
148 knt = 0
149 ninfo = 0
150 lmax = 0
151 rmax = zero
152*
153* Begin test loop
154*
155 10 CONTINUE
156 READ( nin, fmt = * )m, n
157 IF( n.EQ.0 )
158 $ RETURN
159 DO 20 i = 1, m
160 READ( nin, fmt = * )( atmp( i, j ), j = 1, m )
161 20 CONTINUE
162 DO 30 i = 1, n
163 READ( nin, fmt = * )( btmp( i, j ), j = 1, n )
164 30 CONTINUE
165 DO 40 i = 1, m
166 READ( nin, fmt = * )( ctmp( i, j ), j = 1, n )
167 40 CONTINUE
168 DO 170 imla = 1, 3
169 DO 160 imlad = 1, 3
170 DO 150 imlb = 1, 3
171 DO 140 imlc = 1, 3
172 DO 130 itrana = 1, 2
173 DO 120 itranb = 1, 2
174 DO 110 isgn = -1, 1, 2
175 IF( itrana.EQ.1 )
176 $ trana = 'N'
177 IF( itrana.EQ.2 )
178 $ trana = 'C'
179 IF( itranb.EQ.1 )
180 $ tranb = 'N'
181 IF( itranb.EQ.2 )
182 $ tranb = 'C'
183 tnrm = zero
184 DO 60 i = 1, m
185 DO 50 j = 1, m
186 a( i, j ) = atmp( i, j )*vm1( imla )
187 tnrm = max( tnrm, abs( a( i, j ) ) )
188 50 CONTINUE
189 a( i, i ) = a( i, i )*vm2( imlad )
190 tnrm = max( tnrm, abs( a( i, i ) ) )
191 60 CONTINUE
192 DO 80 i = 1, n
193 DO 70 j = 1, n
194 b( i, j ) = btmp( i, j )*vm1( imlb )
195 tnrm = max( tnrm, abs( b( i, j ) ) )
196 70 CONTINUE
197 80 CONTINUE
198 IF( tnrm.EQ.zero )
199 $ tnrm = one
200 DO 100 i = 1, m
201 DO 90 j = 1, n
202 c( i, j ) = ctmp( i, j )*vm1( imlc )
203 csav( i, j ) = c( i, j )
204 90 CONTINUE
205 100 CONTINUE
206 knt = knt + 1
207 CALL ztrsyl( trana, tranb, isgn, m, n, a,
208 $ ldt, b, ldt, c, ldt, scale,
209 $ info )
210 IF( info.NE.0 )
211 $ ninfo = ninfo + 1
212 xnrm = zlange( 'M', m, n, c, ldt, dum )
213 rmul = cone
214 IF( xnrm.GT.one .AND. tnrm.GT.one ) THEN
215 IF( xnrm.GT.bignum / tnrm ) THEN
216 rmul = max( xnrm, tnrm )
217 rmul = cone / rmul
218 END IF
219 END IF
220 CALL zgemm( trana, 'N', m, n, m, rmul, a,
221 $ ldt, c, ldt, -scale*rmul, csav,
222 $ ldt )
223 CALL zgemm( 'N', tranb, m, n, n,
224 $ dble( isgn )*rmul, c, ldt, b,
225 $ ldt, cone, csav, ldt )
226 res1 = zlange( 'M', m, n, csav, ldt, dum )
227 res = res1 / max( smlnum, smlnum*xnrm,
228 $ ( ( abs( rmul )*tnrm )*eps )*xnrm )
229 IF( res.GT.rmax ) THEN
230 lmax = knt
231 rmax = res
232 END IF
233 110 CONTINUE
234 120 CONTINUE
235 130 CONTINUE
236 140 CONTINUE
237 150 CONTINUE
238 160 CONTINUE
239 170 CONTINUE
240 GO TO 10
241*
242* End of ZGET35
243*

◆ zget36()

subroutine zget36 ( double precision rmax,
integer lmax,
integer ninfo,
integer knt,
integer nin )

ZGET36

Purpose:
!>
!> ZGET36 tests ZTREXC, a routine for reordering diagonal entries of a
!> matrix in complex Schur form. Thus, ZLAEXC computes a unitary matrix
!> Q such that
!>
!>    Q' * T1 * Q  = T2
!>
!> and where one of the diagonal blocks of T1 (the one at row IFST) has
!> been moved to position ILST.
!>
!> The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
!> is in Schur form, and that the final position of the IFST block is
!> ILST.
!>
!> The test matrices are read from a file with logical unit number NIN.
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION
!>          Value of the largest test ratio.
!>
[out]LMAX
!>          LMAX is INTEGER
!>          Example number where largest test ratio achieved.
!>
[out]NINFO
!>          NINFO is INTEGER
!>          Number of examples where INFO is nonzero.
!>
[out]KNT
!>          KNT is INTEGER
!>          Total number of examples tested.
!>
[in]NIN
!>          NIN is INTEGER
!>          Input logical unit number.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 84 of file zget36.f.

85*
86* -- LAPACK test routine --
87* -- LAPACK is a software package provided by Univ. of Tennessee, --
88* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
89*
90* .. Scalar Arguments ..
91 INTEGER KNT, LMAX, NIN, NINFO
92 DOUBLE PRECISION RMAX
93* ..
94*
95* =====================================================================
96*
97* .. Parameters ..
98 DOUBLE PRECISION ZERO, ONE
99 parameter( zero = 0.0d+0, one = 1.0d+0 )
100 COMPLEX*16 CZERO, CONE
101 parameter( czero = ( 0.0d+0, 0.0d+0 ),
102 $ cone = ( 1.0d+0, 0.0d+0 ) )
103 INTEGER LDT, LWORK
104 parameter( ldt = 10, lwork = 2*ldt*ldt )
105* ..
106* .. Local Scalars ..
107 INTEGER I, IFST, ILST, INFO1, INFO2, J, N
108 DOUBLE PRECISION EPS, RES
109 COMPLEX*16 CTEMP
110* ..
111* .. Local Arrays ..
112 DOUBLE PRECISION RESULT( 2 ), RWORK( LDT )
113 COMPLEX*16 DIAG( LDT ), Q( LDT, LDT ), T1( LDT, LDT ),
114 $ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
115* ..
116* .. External Functions ..
117 DOUBLE PRECISION DLAMCH
118 EXTERNAL dlamch
119* ..
120* .. External Subroutines ..
121 EXTERNAL zcopy, zhst01, zlacpy, zlaset, ztrexc
122* ..
123* .. Executable Statements ..
124*
125 eps = dlamch( 'P' )
126 rmax = zero
127 lmax = 0
128 knt = 0
129 ninfo = 0
130*
131* Read input data until N=0
132*
133 10 CONTINUE
134 READ( nin, fmt = * )n, ifst, ilst
135 IF( n.EQ.0 )
136 $ RETURN
137 knt = knt + 1
138 DO 20 i = 1, n
139 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
140 20 CONTINUE
141 CALL zlacpy( 'F', n, n, tmp, ldt, t1, ldt )
142 CALL zlacpy( 'F', n, n, tmp, ldt, t2, ldt )
143 res = zero
144*
145* Test without accumulating Q
146*
147 CALL zlaset( 'Full', n, n, czero, cone, q, ldt )
148 CALL ztrexc( 'N', n, t1, ldt, q, ldt, ifst, ilst, info1 )
149 DO 40 i = 1, n
150 DO 30 j = 1, n
151 IF( i.EQ.j .AND. q( i, j ).NE.cone )
152 $ res = res + one / eps
153 IF( i.NE.j .AND. q( i, j ).NE.czero )
154 $ res = res + one / eps
155 30 CONTINUE
156 40 CONTINUE
157*
158* Test with accumulating Q
159*
160 CALL zlaset( 'Full', n, n, czero, cone, q, ldt )
161 CALL ztrexc( 'V', n, t2, ldt, q, ldt, ifst, ilst, info2 )
162*
163* Compare T1 with T2
164*
165 DO 60 i = 1, n
166 DO 50 j = 1, n
167 IF( t1( i, j ).NE.t2( i, j ) )
168 $ res = res + one / eps
169 50 CONTINUE
170 60 CONTINUE
171 IF( info1.NE.0 .OR. info2.NE.0 )
172 $ ninfo = ninfo + 1
173 IF( info1.NE.info2 )
174 $ res = res + one / eps
175*
176* Test for successful reordering of T2
177*
178 CALL zcopy( n, tmp, ldt+1, diag, 1 )
179 IF( ifst.LT.ilst ) THEN
180 DO 70 i = ifst + 1, ilst
181 ctemp = diag( i )
182 diag( i ) = diag( i-1 )
183 diag( i-1 ) = ctemp
184 70 CONTINUE
185 ELSE IF( ifst.GT.ilst ) THEN
186 DO 80 i = ifst - 1, ilst, -1
187 ctemp = diag( i+1 )
188 diag( i+1 ) = diag( i )
189 diag( i ) = ctemp
190 80 CONTINUE
191 END IF
192 DO 90 i = 1, n
193 IF( t2( i, i ).NE.diag( i ) )
194 $ res = res + one / eps
195 90 CONTINUE
196*
197* Test for small residual, and orthogonality of Q
198*
199 CALL zhst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
200 $ rwork, result )
201 res = res + result( 1 ) + result( 2 )
202*
203* Test for T2 being in Schur form
204*
205 DO 110 j = 1, n - 1
206 DO 100 i = j + 1, n
207 IF( t2( i, j ).NE.czero )
208 $ res = res + one / eps
209 100 CONTINUE
210 110 CONTINUE
211 IF( res.GT.rmax ) THEN
212 rmax = res
213 lmax = knt
214 END IF
215 GO TO 10
216*
217* End of ZGET36
218*

◆ zget37()

subroutine zget37 ( double precision, dimension( 3 ) rmax,
integer, dimension( 3 ) lmax,
integer, dimension( 3 ) ninfo,
integer knt,
integer nin )

ZGET37

Purpose:
!>
!> ZGET37 tests ZTRSNA, a routine for estimating condition numbers of
!> eigenvalues and/or right eigenvectors of a matrix.
!>
!> The test matrices are read from a file with logical unit number NIN.
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION array, dimension (3)
!>          Value of the largest test ratio.
!>          RMAX(1) = largest ratio comparing different calls to ZTRSNA
!>          RMAX(2) = largest error in reciprocal condition
!>                    numbers taking their conditioning into account
!>          RMAX(3) = largest error in reciprocal condition
!>                    numbers not taking their conditioning into
!>                    account (may be larger than RMAX(2))
!>
[out]LMAX
!>          LMAX is INTEGER array, dimension (3)
!>          LMAX(i) is example number where largest test ratio
!>          RMAX(i) is achieved. Also:
!>          If ZGEHRD returns INFO nonzero on example i, LMAX(1)=i
!>          If ZHSEQR returns INFO nonzero on example i, LMAX(2)=i
!>          If ZTRSNA returns INFO nonzero on example i, LMAX(3)=i
!>
[out]NINFO
!>          NINFO is INTEGER array, dimension (3)
!>          NINFO(1) = No. of times ZGEHRD returned INFO nonzero
!>          NINFO(2) = No. of times ZHSEQR returned INFO nonzero
!>          NINFO(3) = No. of times ZTRSNA returned INFO nonzero
!>
[out]KNT
!>          KNT is INTEGER
!>          Total number of examples tested.
!>
[in]NIN
!>          NIN is INTEGER
!>          Input logical unit number
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 89 of file zget37.f.

90*
91* -- LAPACK test routine --
92* -- LAPACK is a software package provided by Univ. of Tennessee, --
93* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
94*
95* .. Scalar Arguments ..
96 INTEGER KNT, NIN
97* ..
98* .. Array Arguments ..
99 INTEGER LMAX( 3 ), NINFO( 3 )
100 DOUBLE PRECISION RMAX( 3 )
101* ..
102*
103* =====================================================================
104*
105* .. Parameters ..
106 DOUBLE PRECISION ZERO, ONE, TWO
107 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
108 DOUBLE PRECISION EPSIN
109 parameter( epsin = 5.9605d-8 )
110 INTEGER LDT, LWORK
111 parameter( ldt = 20, lwork = 2*ldt*( 10+ldt ) )
112* ..
113* .. Local Scalars ..
114 INTEGER I, ICMP, INFO, ISCL, ISRT, J, KMIN, M, N
115 DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TNRM, TOL, TOLIN, V,
116 $ VCMIN, VMAX, VMIN, VMUL
117* ..
118* .. Local Arrays ..
119 LOGICAL SELECT( LDT )
120 INTEGER LCMP( 3 )
121 DOUBLE PRECISION DUM( 1 ), RWORK( 2*LDT ), S( LDT ), SEP( LDT ),
122 $ SEPIN( LDT ), SEPTMP( LDT ), SIN( LDT ),
123 $ STMP( LDT ), VAL( 3 ), WIIN( LDT ),
124 $ WRIN( LDT ), WSRT( LDT )
125 COMPLEX*16 CDUM( 1 ), LE( LDT, LDT ), RE( LDT, LDT ),
126 $ T( LDT, LDT ), TMP( LDT, LDT ), W( LDT ),
127 $ WORK( LWORK ), WTMP( LDT )
128* ..
129* .. External Functions ..
130 DOUBLE PRECISION DLAMCH, ZLANGE
131 EXTERNAL dlamch, zlange
132* ..
133* .. External Subroutines ..
134 EXTERNAL dcopy, dlabad, dscal, zcopy, zdscal, zgehrd,
135 $ zhseqr, zlacpy, ztrevc, ztrsna
136* ..
137* .. Intrinsic Functions ..
138 INTRINSIC dble, dimag, max, sqrt
139* ..
140* .. Executable Statements ..
141*
142 eps = dlamch( 'P' )
143 smlnum = dlamch( 'S' ) / eps
144 bignum = one / smlnum
145 CALL dlabad( smlnum, bignum )
146*
147* EPSIN = 2**(-24) = precision to which input data computed
148*
149 eps = max( eps, epsin )
150 rmax( 1 ) = zero
151 rmax( 2 ) = zero
152 rmax( 3 ) = zero
153 lmax( 1 ) = 0
154 lmax( 2 ) = 0
155 lmax( 3 ) = 0
156 knt = 0
157 ninfo( 1 ) = 0
158 ninfo( 2 ) = 0
159 ninfo( 3 ) = 0
160 val( 1 ) = sqrt( smlnum )
161 val( 2 ) = one
162 val( 3 ) = sqrt( bignum )
163*
164* Read input data until N=0. Assume input eigenvalues are sorted
165* lexicographically (increasing by real part if ISRT = 0,
166* increasing by imaginary part if ISRT = 1)
167*
168 10 CONTINUE
169 READ( nin, fmt = * )n, isrt
170 IF( n.EQ.0 )
171 $ RETURN
172 DO 20 i = 1, n
173 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
174 20 CONTINUE
175 DO 30 i = 1, n
176 READ( nin, fmt = * )wrin( i ), wiin( i ), sin( i ), sepin( i )
177 30 CONTINUE
178 tnrm = zlange( 'M', n, n, tmp, ldt, rwork )
179 DO 260 iscl = 1, 3
180*
181* Scale input matrix
182*
183 knt = knt + 1
184 CALL zlacpy( 'F', n, n, tmp, ldt, t, ldt )
185 vmul = val( iscl )
186 DO 40 i = 1, n
187 CALL zdscal( n, vmul, t( 1, i ), 1 )
188 40 CONTINUE
189 IF( tnrm.EQ.zero )
190 $ vmul = one
191*
192* Compute eigenvalues and eigenvectors
193*
194 CALL zgehrd( n, 1, n, t, ldt, work( 1 ), work( n+1 ), lwork-n,
195 $ info )
196 IF( info.NE.0 ) THEN
197 lmax( 1 ) = knt
198 ninfo( 1 ) = ninfo( 1 ) + 1
199 GO TO 260
200 END IF
201 DO 60 j = 1, n - 2
202 DO 50 i = j + 2, n
203 t( i, j ) = zero
204 50 CONTINUE
205 60 CONTINUE
206*
207* Compute Schur form
208*
209 CALL zhseqr( 'S', 'N', n, 1, n, t, ldt, w, cdum, 1, work,
210 $ lwork, info )
211 IF( info.NE.0 ) THEN
212 lmax( 2 ) = knt
213 ninfo( 2 ) = ninfo( 2 ) + 1
214 GO TO 260
215 END IF
216*
217* Compute eigenvectors
218*
219 DO 70 i = 1, n
220 SELECT( i ) = .true.
221 70 CONTINUE
222 CALL ztrevc( 'B', 'A', SELECT, n, t, ldt, le, ldt, re, ldt, n,
223 $ m, work, rwork, info )
224*
225* Compute condition numbers
226*
227 CALL ztrsna( 'B', 'A', SELECT, n, t, ldt, le, ldt, re, ldt, s,
228 $ sep, n, m, work, n, rwork, info )
229 IF( info.NE.0 ) THEN
230 lmax( 3 ) = knt
231 ninfo( 3 ) = ninfo( 3 ) + 1
232 GO TO 260
233 END IF
234*
235* Sort eigenvalues and condition numbers lexicographically
236* to compare with inputs
237*
238 CALL zcopy( n, w, 1, wtmp, 1 )
239 IF( isrt.EQ.0 ) THEN
240*
241* Sort by increasing real part
242*
243 DO 80 i = 1, n
244 wsrt( i ) = dble( w( i ) )
245 80 CONTINUE
246 ELSE
247*
248* Sort by increasing imaginary part
249*
250 DO 90 i = 1, n
251 wsrt( i ) = dimag( w( i ) )
252 90 CONTINUE
253 END IF
254 CALL dcopy( n, s, 1, stmp, 1 )
255 CALL dcopy( n, sep, 1, septmp, 1 )
256 CALL dscal( n, one / vmul, septmp, 1 )
257 DO 110 i = 1, n - 1
258 kmin = i
259 vmin = wsrt( i )
260 DO 100 j = i + 1, n
261 IF( wsrt( j ).LT.vmin ) THEN
262 kmin = j
263 vmin = wsrt( j )
264 END IF
265 100 CONTINUE
266 wsrt( kmin ) = wsrt( i )
267 wsrt( i ) = vmin
268 vcmin = wtmp( i )
269 wtmp( i ) = w( kmin )
270 wtmp( kmin ) = vcmin
271 vmin = stmp( kmin )
272 stmp( kmin ) = stmp( i )
273 stmp( i ) = vmin
274 vmin = septmp( kmin )
275 septmp( kmin ) = septmp( i )
276 septmp( i ) = vmin
277 110 CONTINUE
278*
279* Compare condition numbers for eigenvalues
280* taking their condition numbers into account
281*
282 v = max( two*dble( n )*eps*tnrm, smlnum )
283 IF( tnrm.EQ.zero )
284 $ v = one
285 DO 120 i = 1, n
286 IF( v.GT.septmp( i ) ) THEN
287 tol = one
288 ELSE
289 tol = v / septmp( i )
290 END IF
291 IF( v.GT.sepin( i ) ) THEN
292 tolin = one
293 ELSE
294 tolin = v / sepin( i )
295 END IF
296 tol = max( tol, smlnum / eps )
297 tolin = max( tolin, smlnum / eps )
298 IF( eps*( sin( i )-tolin ).GT.stmp( i )+tol ) THEN
299 vmax = one / eps
300 ELSE IF( sin( i )-tolin.GT.stmp( i )+tol ) THEN
301 vmax = ( sin( i )-tolin ) / ( stmp( i )+tol )
302 ELSE IF( sin( i )+tolin.LT.eps*( stmp( i )-tol ) ) THEN
303 vmax = one / eps
304 ELSE IF( sin( i )+tolin.LT.stmp( i )-tol ) THEN
305 vmax = ( stmp( i )-tol ) / ( sin( i )+tolin )
306 ELSE
307 vmax = one
308 END IF
309 IF( vmax.GT.rmax( 2 ) ) THEN
310 rmax( 2 ) = vmax
311 IF( ninfo( 2 ).EQ.0 )
312 $ lmax( 2 ) = knt
313 END IF
314 120 CONTINUE
315*
316* Compare condition numbers for eigenvectors
317* taking their condition numbers into account
318*
319 DO 130 i = 1, n
320 IF( v.GT.septmp( i )*stmp( i ) ) THEN
321 tol = septmp( i )
322 ELSE
323 tol = v / stmp( i )
324 END IF
325 IF( v.GT.sepin( i )*sin( i ) ) THEN
326 tolin = sepin( i )
327 ELSE
328 tolin = v / sin( i )
329 END IF
330 tol = max( tol, smlnum / eps )
331 tolin = max( tolin, smlnum / eps )
332 IF( eps*( sepin( i )-tolin ).GT.septmp( i )+tol ) THEN
333 vmax = one / eps
334 ELSE IF( sepin( i )-tolin.GT.septmp( i )+tol ) THEN
335 vmax = ( sepin( i )-tolin ) / ( septmp( i )+tol )
336 ELSE IF( sepin( i )+tolin.LT.eps*( septmp( i )-tol ) ) THEN
337 vmax = one / eps
338 ELSE IF( sepin( i )+tolin.LT.septmp( i )-tol ) THEN
339 vmax = ( septmp( i )-tol ) / ( sepin( i )+tolin )
340 ELSE
341 vmax = one
342 END IF
343 IF( vmax.GT.rmax( 2 ) ) THEN
344 rmax( 2 ) = vmax
345 IF( ninfo( 2 ).EQ.0 )
346 $ lmax( 2 ) = knt
347 END IF
348 130 CONTINUE
349*
350* Compare condition numbers for eigenvalues
351* without taking their condition numbers into account
352*
353 DO 140 i = 1, n
354 IF( sin( i ).LE.dble( 2*n )*eps .AND. stmp( i ).LE.
355 $ dble( 2*n )*eps ) THEN
356 vmax = one
357 ELSE IF( eps*sin( i ).GT.stmp( i ) ) THEN
358 vmax = one / eps
359 ELSE IF( sin( i ).GT.stmp( i ) ) THEN
360 vmax = sin( i ) / stmp( i )
361 ELSE IF( sin( i ).LT.eps*stmp( i ) ) THEN
362 vmax = one / eps
363 ELSE IF( sin( i ).LT.stmp( i ) ) THEN
364 vmax = stmp( i ) / sin( i )
365 ELSE
366 vmax = one
367 END IF
368 IF( vmax.GT.rmax( 3 ) ) THEN
369 rmax( 3 ) = vmax
370 IF( ninfo( 3 ).EQ.0 )
371 $ lmax( 3 ) = knt
372 END IF
373 140 CONTINUE
374*
375* Compare condition numbers for eigenvectors
376* without taking their condition numbers into account
377*
378 DO 150 i = 1, n
379 IF( sepin( i ).LE.v .AND. septmp( i ).LE.v ) THEN
380 vmax = one
381 ELSE IF( eps*sepin( i ).GT.septmp( i ) ) THEN
382 vmax = one / eps
383 ELSE IF( sepin( i ).GT.septmp( i ) ) THEN
384 vmax = sepin( i ) / septmp( i )
385 ELSE IF( sepin( i ).LT.eps*septmp( i ) ) THEN
386 vmax = one / eps
387 ELSE IF( sepin( i ).LT.septmp( i ) ) THEN
388 vmax = septmp( i ) / sepin( i )
389 ELSE
390 vmax = one
391 END IF
392 IF( vmax.GT.rmax( 3 ) ) THEN
393 rmax( 3 ) = vmax
394 IF( ninfo( 3 ).EQ.0 )
395 $ lmax( 3 ) = knt
396 END IF
397 150 CONTINUE
398*
399* Compute eigenvalue condition numbers only and compare
400*
401 vmax = zero
402 dum( 1 ) = -one
403 CALL dcopy( n, dum, 0, stmp, 1 )
404 CALL dcopy( n, dum, 0, septmp, 1 )
405 CALL ztrsna( 'E', 'A', SELECT, n, t, ldt, le, ldt, re, ldt,
406 $ stmp, septmp, n, m, work, n, rwork, info )
407 IF( info.NE.0 ) THEN
408 lmax( 3 ) = knt
409 ninfo( 3 ) = ninfo( 3 ) + 1
410 GO TO 260
411 END IF
412 DO 160 i = 1, n
413 IF( stmp( i ).NE.s( i ) )
414 $ vmax = one / eps
415 IF( septmp( i ).NE.dum( 1 ) )
416 $ vmax = one / eps
417 160 CONTINUE
418*
419* Compute eigenvector condition numbers only and compare
420*
421 CALL dcopy( n, dum, 0, stmp, 1 )
422 CALL dcopy( n, dum, 0, septmp, 1 )
423 CALL ztrsna( 'V', 'A', SELECT, n, t, ldt, le, ldt, re, ldt,
424 $ stmp, septmp, n, m, work, n, rwork, info )
425 IF( info.NE.0 ) THEN
426 lmax( 3 ) = knt
427 ninfo( 3 ) = ninfo( 3 ) + 1
428 GO TO 260
429 END IF
430 DO 170 i = 1, n
431 IF( stmp( i ).NE.dum( 1 ) )
432 $ vmax = one / eps
433 IF( septmp( i ).NE.sep( i ) )
434 $ vmax = one / eps
435 170 CONTINUE
436*
437* Compute all condition numbers using SELECT and compare
438*
439 DO 180 i = 1, n
440 SELECT( i ) = .true.
441 180 CONTINUE
442 CALL dcopy( n, dum, 0, stmp, 1 )
443 CALL dcopy( n, dum, 0, septmp, 1 )
444 CALL ztrsna( 'B', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
445 $ stmp, septmp, n, m, work, n, rwork, info )
446 IF( info.NE.0 ) THEN
447 lmax( 3 ) = knt
448 ninfo( 3 ) = ninfo( 3 ) + 1
449 GO TO 260
450 END IF
451 DO 190 i = 1, n
452 IF( septmp( i ).NE.sep( i ) )
453 $ vmax = one / eps
454 IF( stmp( i ).NE.s( i ) )
455 $ vmax = one / eps
456 190 CONTINUE
457*
458* Compute eigenvalue condition numbers using SELECT and compare
459*
460 CALL dcopy( n, dum, 0, stmp, 1 )
461 CALL dcopy( n, dum, 0, septmp, 1 )
462 CALL ztrsna( 'E', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
463 $ stmp, septmp, n, m, work, n, rwork, info )
464 IF( info.NE.0 ) THEN
465 lmax( 3 ) = knt
466 ninfo( 3 ) = ninfo( 3 ) + 1
467 GO TO 260
468 END IF
469 DO 200 i = 1, n
470 IF( stmp( i ).NE.s( i ) )
471 $ vmax = one / eps
472 IF( septmp( i ).NE.dum( 1 ) )
473 $ vmax = one / eps
474 200 CONTINUE
475*
476* Compute eigenvector condition numbers using SELECT and compare
477*
478 CALL dcopy( n, dum, 0, stmp, 1 )
479 CALL dcopy( n, dum, 0, septmp, 1 )
480 CALL ztrsna( 'V', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
481 $ stmp, septmp, n, m, work, n, rwork, info )
482 IF( info.NE.0 ) THEN
483 lmax( 3 ) = knt
484 ninfo( 3 ) = ninfo( 3 ) + 1
485 GO TO 260
486 END IF
487 DO 210 i = 1, n
488 IF( stmp( i ).NE.dum( 1 ) )
489 $ vmax = one / eps
490 IF( septmp( i ).NE.sep( i ) )
491 $ vmax = one / eps
492 210 CONTINUE
493 IF( vmax.GT.rmax( 1 ) ) THEN
494 rmax( 1 ) = vmax
495 IF( ninfo( 1 ).EQ.0 )
496 $ lmax( 1 ) = knt
497 END IF
498*
499* Select second and next to last eigenvalues
500*
501 DO 220 i = 1, n
502 SELECT( i ) = .false.
503 220 CONTINUE
504 icmp = 0
505 IF( n.GT.1 ) THEN
506 icmp = 1
507 lcmp( 1 ) = 2
508 SELECT( 2 ) = .true.
509 CALL zcopy( n, re( 1, 2 ), 1, re( 1, 1 ), 1 )
510 CALL zcopy( n, le( 1, 2 ), 1, le( 1, 1 ), 1 )
511 END IF
512 IF( n.GT.3 ) THEN
513 icmp = 2
514 lcmp( 2 ) = n - 1
515 SELECT( n-1 ) = .true.
516 CALL zcopy( n, re( 1, n-1 ), 1, re( 1, 2 ), 1 )
517 CALL zcopy( n, le( 1, n-1 ), 1, le( 1, 2 ), 1 )
518 END IF
519*
520* Compute all selected condition numbers
521*
522 CALL dcopy( icmp, dum, 0, stmp, 1 )
523 CALL dcopy( icmp, dum, 0, septmp, 1 )
524 CALL ztrsna( 'B', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
525 $ stmp, septmp, n, m, work, n, rwork, info )
526 IF( info.NE.0 ) THEN
527 lmax( 3 ) = knt
528 ninfo( 3 ) = ninfo( 3 ) + 1
529 GO TO 260
530 END IF
531 DO 230 i = 1, icmp
532 j = lcmp( i )
533 IF( septmp( i ).NE.sep( j ) )
534 $ vmax = one / eps
535 IF( stmp( i ).NE.s( j ) )
536 $ vmax = one / eps
537 230 CONTINUE
538*
539* Compute selected eigenvalue condition numbers
540*
541 CALL dcopy( icmp, dum, 0, stmp, 1 )
542 CALL dcopy( icmp, dum, 0, septmp, 1 )
543 CALL ztrsna( 'E', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
544 $ stmp, septmp, n, m, work, n, rwork, info )
545 IF( info.NE.0 ) THEN
546 lmax( 3 ) = knt
547 ninfo( 3 ) = ninfo( 3 ) + 1
548 GO TO 260
549 END IF
550 DO 240 i = 1, icmp
551 j = lcmp( i )
552 IF( stmp( i ).NE.s( j ) )
553 $ vmax = one / eps
554 IF( septmp( i ).NE.dum( 1 ) )
555 $ vmax = one / eps
556 240 CONTINUE
557*
558* Compute selected eigenvector condition numbers
559*
560 CALL dcopy( icmp, dum, 0, stmp, 1 )
561 CALL dcopy( icmp, dum, 0, septmp, 1 )
562 CALL ztrsna( 'V', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
563 $ stmp, septmp, n, m, work, n, rwork, info )
564 IF( info.NE.0 ) THEN
565 lmax( 3 ) = knt
566 ninfo( 3 ) = ninfo( 3 ) + 1
567 GO TO 260
568 END IF
569 DO 250 i = 1, icmp
570 j = lcmp( i )
571 IF( stmp( i ).NE.dum( 1 ) )
572 $ vmax = one / eps
573 IF( septmp( i ).NE.sep( j ) )
574 $ vmax = one / eps
575 250 CONTINUE
576 IF( vmax.GT.rmax( 1 ) ) THEN
577 rmax( 1 ) = vmax
578 IF( ninfo( 1 ).EQ.0 )
579 $ lmax( 1 ) = knt
580 END IF
581 260 CONTINUE
582 GO TO 10
583*
584* End of ZGET37
585*
zdscal
subroutine zdscal(n, da, zx, incx)
ZDSCAL
Definition zdscal.f:78
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79

◆ zget38()

subroutine zget38 ( double precision, dimension( 3 ) rmax,
integer, dimension( 3 ) lmax,
integer, dimension( 3 ) ninfo,
integer knt,
integer nin )

ZGET38

Purpose:
!>
!> ZGET38 tests ZTRSEN, a routine for estimating condition numbers of a
!> cluster of eigenvalues and/or its associated right invariant subspace
!>
!> The test matrices are read from a file with logical unit number NIN.
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION array, dimension (3)
!>          Values of the largest test ratios.
!>          RMAX(1) = largest residuals from ZHST01 or comparing
!>                    different calls to ZTRSEN
!>          RMAX(2) = largest error in reciprocal condition
!>                    numbers taking their conditioning into account
!>          RMAX(3) = largest error in reciprocal condition
!>                    numbers not taking their conditioning into
!>                    account (may be larger than RMAX(2))
!>
[out]LMAX
!>          LMAX is INTEGER array, dimension (3)
!>          LMAX(i) is example number where largest test ratio
!>          RMAX(i) is achieved. Also:
!>          If ZGEHRD returns INFO nonzero on example i, LMAX(1)=i
!>          If ZHSEQR returns INFO nonzero on example i, LMAX(2)=i
!>          If ZTRSEN returns INFO nonzero on example i, LMAX(3)=i
!>
[out]NINFO
!>          NINFO is INTEGER array, dimension (3)
!>          NINFO(1) = No. of times ZGEHRD returned INFO nonzero
!>          NINFO(2) = No. of times ZHSEQR returned INFO nonzero
!>          NINFO(3) = No. of times ZTRSEN returned INFO nonzero
!>
[out]KNT
!>          KNT is INTEGER
!>          Total number of examples tested.
!>
[in]NIN
!>          NIN is INTEGER
!>          Input logical unit number.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 90 of file zget38.f.

91*
92* -- LAPACK test routine --
93* -- LAPACK is a software package provided by Univ. of Tennessee, --
94* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
95*
96* .. Scalar Arguments ..
97 INTEGER KNT, NIN
98* ..
99* .. Array Arguments ..
100 INTEGER LMAX( 3 ), NINFO( 3 )
101 DOUBLE PRECISION RMAX( 3 )
102* ..
103*
104* =====================================================================
105*
106* .. Parameters ..
107 INTEGER LDT, LWORK
108 parameter( ldt = 20, lwork = 2*ldt*( 10+ldt ) )
109 DOUBLE PRECISION ZERO, ONE, TWO
110 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
111 DOUBLE PRECISION EPSIN
112 parameter( epsin = 5.9605d-8 )
113 COMPLEX*16 CZERO
114 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
115* ..
116* .. Local Scalars ..
117 INTEGER I, INFO, ISCL, ISRT, ITMP, J, KMIN, M, N, NDIM
118 DOUBLE PRECISION BIGNUM, EPS, S, SEP, SEPIN, SEPTMP, SIN,
119 $ SMLNUM, STMP, TNRM, TOL, TOLIN, V, VMAX, VMIN,
120 $ VMUL
121* ..
122* .. Local Arrays ..
123 LOGICAL SELECT( LDT )
124 INTEGER IPNT( LDT ), ISELEC( LDT )
125 DOUBLE PRECISION RESULT( 2 ), RWORK( LDT ), VAL( 3 ),
126 $ WSRT( LDT )
127 COMPLEX*16 Q( LDT, LDT ), QSAV( LDT, LDT ),
128 $ QTMP( LDT, LDT ), T( LDT, LDT ),
129 $ TMP( LDT, LDT ), TSAV( LDT, LDT ),
130 $ TSAV1( LDT, LDT ), TTMP( LDT, LDT ), W( LDT ),
131 $ WORK( LWORK ), WTMP( LDT )
132* ..
133* .. External Functions ..
134 DOUBLE PRECISION DLAMCH, ZLANGE
135 EXTERNAL dlamch, zlange
136* ..
137* .. External Subroutines ..
138 EXTERNAL dlabad, zdscal, zgehrd, zhseqr, zhst01, zlacpy,
139 $ ztrsen, zunghr
140* ..
141* .. Intrinsic Functions ..
142 INTRINSIC dble, dimag, max, sqrt
143* ..
144* .. Executable Statements ..
145*
146 eps = dlamch( 'P' )
147 smlnum = dlamch( 'S' ) / eps
148 bignum = one / smlnum
149 CALL dlabad( smlnum, bignum )
150*
151* EPSIN = 2**(-24) = precision to which input data computed
152*
153 eps = max( eps, epsin )
154 rmax( 1 ) = zero
155 rmax( 2 ) = zero
156 rmax( 3 ) = zero
157 lmax( 1 ) = 0
158 lmax( 2 ) = 0
159 lmax( 3 ) = 0
160 knt = 0
161 ninfo( 1 ) = 0
162 ninfo( 2 ) = 0
163 ninfo( 3 ) = 0
164 val( 1 ) = sqrt( smlnum )
165 val( 2 ) = one
166 val( 3 ) = sqrt( sqrt( bignum ) )
167*
168* Read input data until N=0. Assume input eigenvalues are sorted
169* lexicographically (increasing by real part, then decreasing by
170* imaginary part)
171*
172 10 CONTINUE
173 READ( nin, fmt = * )n, ndim, isrt
174 IF( n.EQ.0 )
175 $ RETURN
176 READ( nin, fmt = * )( iselec( i ), i = 1, ndim )
177 DO 20 i = 1, n
178 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
179 20 CONTINUE
180 READ( nin, fmt = * )sin, sepin
181*
182 tnrm = zlange( 'M', n, n, tmp, ldt, rwork )
183 DO 200 iscl = 1, 3
184*
185* Scale input matrix
186*
187 knt = knt + 1
188 CALL zlacpy( 'F', n, n, tmp, ldt, t, ldt )
189 vmul = val( iscl )
190 DO 30 i = 1, n
191 CALL zdscal( n, vmul, t( 1, i ), 1 )
192 30 CONTINUE
193 IF( tnrm.EQ.zero )
194 $ vmul = one
195 CALL zlacpy( 'F', n, n, t, ldt, tsav, ldt )
196*
197* Compute Schur form
198*
199 CALL zgehrd( n, 1, n, t, ldt, work( 1 ), work( n+1 ), lwork-n,
200 $ info )
201 IF( info.NE.0 ) THEN
202 lmax( 1 ) = knt
203 ninfo( 1 ) = ninfo( 1 ) + 1
204 GO TO 200
205 END IF
206*
207* Generate unitary matrix
208*
209 CALL zlacpy( 'L', n, n, t, ldt, q, ldt )
210 CALL zunghr( n, 1, n, q, ldt, work( 1 ), work( n+1 ), lwork-n,
211 $ info )
212*
213* Compute Schur form
214*
215 DO 50 j = 1, n - 2
216 DO 40 i = j + 2, n
217 t( i, j ) = czero
218 40 CONTINUE
219 50 CONTINUE
220 CALL zhseqr( 'S', 'V', n, 1, n, t, ldt, w, q, ldt, work, lwork,
221 $ info )
222 IF( info.NE.0 ) THEN
223 lmax( 2 ) = knt
224 ninfo( 2 ) = ninfo( 2 ) + 1
225 GO TO 200
226 END IF
227*
228* Sort, select eigenvalues
229*
230 DO 60 i = 1, n
231 ipnt( i ) = i
232 SELECT( i ) = .false.
233 60 CONTINUE
234 IF( isrt.EQ.0 ) THEN
235 DO 70 i = 1, n
236 wsrt( i ) = dble( w( i ) )
237 70 CONTINUE
238 ELSE
239 DO 80 i = 1, n
240 wsrt( i ) = dimag( w( i ) )
241 80 CONTINUE
242 END IF
243 DO 100 i = 1, n - 1
244 kmin = i
245 vmin = wsrt( i )
246 DO 90 j = i + 1, n
247 IF( wsrt( j ).LT.vmin ) THEN
248 kmin = j
249 vmin = wsrt( j )
250 END IF
251 90 CONTINUE
252 wsrt( kmin ) = wsrt( i )
253 wsrt( i ) = vmin
254 itmp = ipnt( i )
255 ipnt( i ) = ipnt( kmin )
256 ipnt( kmin ) = itmp
257 100 CONTINUE
258 DO 110 i = 1, ndim
259 SELECT( ipnt( iselec( i ) ) ) = .true.
260 110 CONTINUE
261*
262* Compute condition numbers
263*
264 CALL zlacpy( 'F', n, n, q, ldt, qsav, ldt )
265 CALL zlacpy( 'F', n, n, t, ldt, tsav1, ldt )
266 CALL ztrsen( 'B', 'V', SELECT, n, t, ldt, q, ldt, wtmp, m, s,
267 $ sep, work, lwork, info )
268 IF( info.NE.0 ) THEN
269 lmax( 3 ) = knt
270 ninfo( 3 ) = ninfo( 3 ) + 1
271 GO TO 200
272 END IF
273 septmp = sep / vmul
274 stmp = s
275*
276* Compute residuals
277*
278 CALL zhst01( n, 1, n, tsav, ldt, t, ldt, q, ldt, work, lwork,
279 $ rwork, result )
280 vmax = max( result( 1 ), result( 2 ) )
281 IF( vmax.GT.rmax( 1 ) ) THEN
282 rmax( 1 ) = vmax
283 IF( ninfo( 1 ).EQ.0 )
284 $ lmax( 1 ) = knt
285 END IF
286*
287* Compare condition number for eigenvalue cluster
288* taking its condition number into account
289*
290 v = max( two*dble( n )*eps*tnrm, smlnum )
291 IF( tnrm.EQ.zero )
292 $ v = one
293 IF( v.GT.septmp ) THEN
294 tol = one
295 ELSE
296 tol = v / septmp
297 END IF
298 IF( v.GT.sepin ) THEN
299 tolin = one
300 ELSE
301 tolin = v / sepin
302 END IF
303 tol = max( tol, smlnum / eps )
304 tolin = max( tolin, smlnum / eps )
305 IF( eps*( sin-tolin ).GT.stmp+tol ) THEN
306 vmax = one / eps
307 ELSE IF( sin-tolin.GT.stmp+tol ) THEN
308 vmax = ( sin-tolin ) / ( stmp+tol )
309 ELSE IF( sin+tolin.LT.eps*( stmp-tol ) ) THEN
310 vmax = one / eps
311 ELSE IF( sin+tolin.LT.stmp-tol ) THEN
312 vmax = ( stmp-tol ) / ( sin+tolin )
313 ELSE
314 vmax = one
315 END IF
316 IF( vmax.GT.rmax( 2 ) ) THEN
317 rmax( 2 ) = vmax
318 IF( ninfo( 2 ).EQ.0 )
319 $ lmax( 2 ) = knt
320 END IF
321*
322* Compare condition numbers for invariant subspace
323* taking its condition number into account
324*
325 IF( v.GT.septmp*stmp ) THEN
326 tol = septmp
327 ELSE
328 tol = v / stmp
329 END IF
330 IF( v.GT.sepin*sin ) THEN
331 tolin = sepin
332 ELSE
333 tolin = v / sin
334 END IF
335 tol = max( tol, smlnum / eps )
336 tolin = max( tolin, smlnum / eps )
337 IF( eps*( sepin-tolin ).GT.septmp+tol ) THEN
338 vmax = one / eps
339 ELSE IF( sepin-tolin.GT.septmp+tol ) THEN
340 vmax = ( sepin-tolin ) / ( septmp+tol )
341 ELSE IF( sepin+tolin.LT.eps*( septmp-tol ) ) THEN
342 vmax = one / eps
343 ELSE IF( sepin+tolin.LT.septmp-tol ) THEN
344 vmax = ( septmp-tol ) / ( sepin+tolin )
345 ELSE
346 vmax = one
347 END IF
348 IF( vmax.GT.rmax( 2 ) ) THEN
349 rmax( 2 ) = vmax
350 IF( ninfo( 2 ).EQ.0 )
351 $ lmax( 2 ) = knt
352 END IF
353*
354* Compare condition number for eigenvalue cluster
355* without taking its condition number into account
356*
357 IF( sin.LE.dble( 2*n )*eps .AND. stmp.LE.dble( 2*n )*eps ) THEN
358 vmax = one
359 ELSE IF( eps*sin.GT.stmp ) THEN
360 vmax = one / eps
361 ELSE IF( sin.GT.stmp ) THEN
362 vmax = sin / stmp
363 ELSE IF( sin.LT.eps*stmp ) THEN
364 vmax = one / eps
365 ELSE IF( sin.LT.stmp ) THEN
366 vmax = stmp / sin
367 ELSE
368 vmax = one
369 END IF
370 IF( vmax.GT.rmax( 3 ) ) THEN
371 rmax( 3 ) = vmax
372 IF( ninfo( 3 ).EQ.0 )
373 $ lmax( 3 ) = knt
374 END IF
375*
376* Compare condition numbers for invariant subspace
377* without taking its condition number into account
378*
379 IF( sepin.LE.v .AND. septmp.LE.v ) THEN
380 vmax = one
381 ELSE IF( eps*sepin.GT.septmp ) THEN
382 vmax = one / eps
383 ELSE IF( sepin.GT.septmp ) THEN
384 vmax = sepin / septmp
385 ELSE IF( sepin.LT.eps*septmp ) THEN
386 vmax = one / eps
387 ELSE IF( sepin.LT.septmp ) THEN
388 vmax = septmp / sepin
389 ELSE
390 vmax = one
391 END IF
392 IF( vmax.GT.rmax( 3 ) ) THEN
393 rmax( 3 ) = vmax
394 IF( ninfo( 3 ).EQ.0 )
395 $ lmax( 3 ) = knt
396 END IF
397*
398* Compute eigenvalue condition number only and compare
399* Update Q
400*
401 vmax = zero
402 CALL zlacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
403 CALL zlacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
404 septmp = -one
405 stmp = -one
406 CALL ztrsen( 'E', 'V', SELECT, n, ttmp, ldt, qtmp, ldt, wtmp,
407 $ m, stmp, septmp, work, lwork, info )
408 IF( info.NE.0 ) THEN
409 lmax( 3 ) = knt
410 ninfo( 3 ) = ninfo( 3 ) + 1
411 GO TO 200
412 END IF
413 IF( s.NE.stmp )
414 $ vmax = one / eps
415 IF( -one.NE.septmp )
416 $ vmax = one / eps
417 DO 130 i = 1, n
418 DO 120 j = 1, n
419 IF( ttmp( i, j ).NE.t( i, j ) )
420 $ vmax = one / eps
421 IF( qtmp( i, j ).NE.q( i, j ) )
422 $ vmax = one / eps
423 120 CONTINUE
424 130 CONTINUE
425*
426* Compute invariant subspace condition number only and compare
427* Update Q
428*
429 CALL zlacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
430 CALL zlacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
431 septmp = -one
432 stmp = -one
433 CALL ztrsen( 'V', 'V', SELECT, n, ttmp, ldt, qtmp, ldt, wtmp,
434 $ m, stmp, septmp, work, lwork, info )
435 IF( info.NE.0 ) THEN
436 lmax( 3 ) = knt
437 ninfo( 3 ) = ninfo( 3 ) + 1
438 GO TO 200
439 END IF
440 IF( -one.NE.stmp )
441 $ vmax = one / eps
442 IF( sep.NE.septmp )
443 $ vmax = one / eps
444 DO 150 i = 1, n
445 DO 140 j = 1, n
446 IF( ttmp( i, j ).NE.t( i, j ) )
447 $ vmax = one / eps
448 IF( qtmp( i, j ).NE.q( i, j ) )
449 $ vmax = one / eps
450 140 CONTINUE
451 150 CONTINUE
452*
453* Compute eigenvalue condition number only and compare
454* Do not update Q
455*
456 CALL zlacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
457 CALL zlacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
458 septmp = -one
459 stmp = -one
460 CALL ztrsen( 'E', 'N', SELECT, n, ttmp, ldt, qtmp, ldt, wtmp,
461 $ m, stmp, septmp, work, lwork, info )
462 IF( info.NE.0 ) THEN
463 lmax( 3 ) = knt
464 ninfo( 3 ) = ninfo( 3 ) + 1
465 GO TO 200
466 END IF
467 IF( s.NE.stmp )
468 $ vmax = one / eps
469 IF( -one.NE.septmp )
470 $ vmax = one / eps
471 DO 170 i = 1, n
472 DO 160 j = 1, n
473 IF( ttmp( i, j ).NE.t( i, j ) )
474 $ vmax = one / eps
475 IF( qtmp( i, j ).NE.qsav( i, j ) )
476 $ vmax = one / eps
477 160 CONTINUE
478 170 CONTINUE
479*
480* Compute invariant subspace condition number only and compare
481* Do not update Q
482*
483 CALL zlacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
484 CALL zlacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
485 septmp = -one
486 stmp = -one
487 CALL ztrsen( 'V', 'N', SELECT, n, ttmp, ldt, qtmp, ldt, wtmp,
488 $ m, stmp, septmp, work, lwork, info )
489 IF( info.NE.0 ) THEN
490 lmax( 3 ) = knt
491 ninfo( 3 ) = ninfo( 3 ) + 1
492 GO TO 200
493 END IF
494 IF( -one.NE.stmp )
495 $ vmax = one / eps
496 IF( sep.NE.septmp )
497 $ vmax = one / eps
498 DO 190 i = 1, n
499 DO 180 j = 1, n
500 IF( ttmp( i, j ).NE.t( i, j ) )
501 $ vmax = one / eps
502 IF( qtmp( i, j ).NE.qsav( i, j ) )
503 $ vmax = one / eps
504 180 CONTINUE
505 190 CONTINUE
506 IF( vmax.GT.rmax( 1 ) ) THEN
507 rmax( 1 ) = vmax
508 IF( ninfo( 1 ).EQ.0 )
509 $ lmax( 1 ) = knt
510 END IF
511 200 CONTINUE
512 GO TO 10
513*
514* End of ZGET38
515*

◆ zget51()

subroutine zget51 ( integer itype,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldv, * ) v,
integer ldv,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision result )

ZGET51

Purpose:
!>
!>      ZGET51  generally checks a decomposition of the form
!>
!>              A = U B V**H
!>
!>      where **H means conjugate transpose and U and V are unitary.
!>
!>      Specifically, if ITYPE=1
!>
!>              RESULT = | A - U B V**H | / ( |A| n ulp )
!>
!>      If ITYPE=2, then:
!>
!>              RESULT = | A - B | / ( |A| n ulp )
!>
!>      If ITYPE=3, then:
!>
!>              RESULT = | I - U U**H | / ( n ulp )
!>
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          Specifies the type of tests to be performed.
!>          =1: RESULT = | A - U B V**H | / ( |A| n ulp )
!>          =2: RESULT = | A - B | / ( |A| n ulp )
!>          =3: RESULT = | I - U U**H | / ( n ulp )
!>
[in]N
!>          N is INTEGER
!>          The size of the matrix.  If it is zero, ZGET51 does nothing.
!>          It must be at least zero.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          The original (unfactored) matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least N.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          The factored matrix.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of B.  It must be at least 1
!>          and at least N.
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU, N)
!>          The unitary matrix on the left-hand side in the
!>          decomposition.
!>          Not referenced if ITYPE=2
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  LDU must be at least N and
!>          at least 1.
!>
[in]V
!>          V is COMPLEX*16 array, dimension (LDV, N)
!>          The unitary matrix on the left-hand side in the
!>          decomposition.
!>          Not referenced if ITYPE=2
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of V.  LDV must be at least N and
!>          at least 1.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N**2)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION
!>          The values computed by the test specified by ITYPE.  The
!>          value is currently limited to 1/ulp, to avoid overflow.
!>          Errors are flagged by RESULT=10/ulp.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 153 of file zget51.f.

155*
156* -- LAPACK test routine --
157* -- LAPACK is a software package provided by Univ. of Tennessee, --
158* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
159*
160* .. Scalar Arguments ..
161 INTEGER ITYPE, LDA, LDB, LDU, LDV, N
162 DOUBLE PRECISION RESULT
163* ..
164* .. Array Arguments ..
165 DOUBLE PRECISION RWORK( * )
166 COMPLEX*16 A( LDA, * ), B( LDB, * ), U( LDU, * ),
167 $ V( LDV, * ), WORK( * )
168* ..
169*
170* =====================================================================
171*
172* .. Parameters ..
173 DOUBLE PRECISION ZERO, ONE, TEN
174 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 10.0d+0 )
175 COMPLEX*16 CZERO, CONE
176 parameter( czero = ( 0.0d+0, 0.0d+0 ),
177 $ cone = ( 1.0d+0, 0.0d+0 ) )
178* ..
179* .. Local Scalars ..
180 INTEGER JCOL, JDIAG, JROW
181 DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
182* ..
183* .. External Functions ..
184 DOUBLE PRECISION DLAMCH, ZLANGE
185 EXTERNAL dlamch, zlange
186* ..
187* .. External Subroutines ..
188 EXTERNAL zgemm, zlacpy
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC dble, max, min
192* ..
193* .. Executable Statements ..
194*
195 result = zero
196 IF( n.LE.0 )
197 $ RETURN
198*
199* Constants
200*
201 unfl = dlamch( 'Safe minimum' )
202 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
203*
204* Some Error Checks
205*
206 IF( itype.LT.1 .OR. itype.GT.3 ) THEN
207 result = ten / ulp
208 RETURN
209 END IF
210*
211 IF( itype.LE.2 ) THEN
212*
213* Tests scaled by the norm(A)
214*
215 anorm = max( zlange( '1', n, n, a, lda, rwork ), unfl )
216*
217 IF( itype.EQ.1 ) THEN
218*
219* ITYPE=1: Compute W = A - U B V**H
220*
221 CALL zlacpy( ' ', n, n, a, lda, work, n )
222 CALL zgemm( 'N', 'N', n, n, n, cone, u, ldu, b, ldb, czero,
223 $ work( n**2+1 ), n )
224*
225 CALL zgemm( 'N', 'C', n, n, n, -cone, work( n**2+1 ), n, v,
226 $ ldv, cone, work, n )
227*
228 ELSE
229*
230* ITYPE=2: Compute W = A - B
231*
232 CALL zlacpy( ' ', n, n, b, ldb, work, n )
233*
234 DO 20 jcol = 1, n
235 DO 10 jrow = 1, n
236 work( jrow+n*( jcol-1 ) ) = work( jrow+n*( jcol-1 ) )
237 $ - a( jrow, jcol )
238 10 CONTINUE
239 20 CONTINUE
240 END IF
241*
242* Compute norm(W)/ ( ulp*norm(A) )
243*
244 wnorm = zlange( '1', n, n, work, n, rwork )
245*
246 IF( anorm.GT.wnorm ) THEN
247 result = ( wnorm / anorm ) / ( n*ulp )
248 ELSE
249 IF( anorm.LT.one ) THEN
250 result = ( min( wnorm, n*anorm ) / anorm ) / ( n*ulp )
251 ELSE
252 result = min( wnorm / anorm, dble( n ) ) / ( n*ulp )
253 END IF
254 END IF
255*
256 ELSE
257*
258* Tests not scaled by norm(A)
259*
260* ITYPE=3: Compute U U**H - I
261*
262 CALL zgemm( 'N', 'C', n, n, n, cone, u, ldu, u, ldu, czero,
263 $ work, n )
264*
265 DO 30 jdiag = 1, n
266 work( ( n+1 )*( jdiag-1 )+1 ) = work( ( n+1 )*( jdiag-1 )+
267 $ 1 ) - cone
268 30 CONTINUE
269*
270 result = min( zlange( '1', n, n, work, n, rwork ),
271 $ dble( n ) ) / ( n*ulp )
272 END IF
273*
274 RETURN
275*
276* End of ZGET51
277*

◆ zget52()

subroutine zget52 ( logical left,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( lde, * ) e,
integer lde,
complex*16, dimension( * ) alpha,
complex*16, dimension( * ) beta,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision, dimension( 2 ) result )

ZGET52

Purpose:
!>
!> ZGET52  does an eigenvector check for the generalized eigenvalue
!> problem.
!>
!> The basic test for right eigenvectors is:
!>
!>                           | b(i) A E(i) -  a(i) B E(i) |
!>         RESULT(1) = max   -------------------------------
!>                      i    n ulp max( |b(i) A|, |a(i) B| )
!>
!> using the 1-norm.  Here, a(i)/b(i) = w is the i-th generalized
!> eigenvalue of A - w B, or, equivalently, b(i)/a(i) = m is the i-th
!> generalized eigenvalue of m A - B.
!>
!>                         H   H  _      _
!> For left eigenvectors, A , B , a, and b  are used.
!>
!> ZGET52 also tests the normalization of E.  Each eigenvector is
!> supposed to be normalized so that the maximum 
!> of its elements is 1, where in this case, 
!> of a complex value x is  |Re(x)| + |Im(x)| ; let us call this
!> maximum  norm of a vector v  M(v).
!> If a(i)=b(i)=0, then the eigenvector is set to be the jth coordinate
!> vector. The normalization test is:
!>
!>         RESULT(2) =      max       | M(v(i)) - 1 | / ( n ulp )
!>                    eigenvectors v(i)
!>
!>
Parameters
[in]LEFT
!>          LEFT is LOGICAL
!>          =.TRUE.:  The eigenvectors in the columns of E are assumed
!>                    to be *left* eigenvectors.
!>          =.FALSE.: The eigenvectors in the columns of E are assumed
!>                    to be *right* eigenvectors.
!>
[in]N
!>          N is INTEGER
!>          The size of the matrices.  If it is zero, ZGET52 does
!>          nothing.  It must be at least zero.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          The matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least N.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          The matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of B.  It must be at least 1
!>          and at least N.
!>
[in]E
!>          E is COMPLEX*16 array, dimension (LDE, N)
!>          The matrix of eigenvectors.  It must be O( 1 ).
!>
[in]LDE
!>          LDE is INTEGER
!>          The leading dimension of E.  It must be at least 1 and at
!>          least N.
!>
[in]ALPHA
!>          ALPHA is COMPLEX*16 array, dimension (N)
!>          The values a(i) as described above, which, along with b(i),
!>          define the generalized eigenvalues.
!>
[in]BETA
!>          BETA is COMPLEX*16 array, dimension (N)
!>          The values b(i) as described above, which, along with a(i),
!>          define the generalized eigenvalues.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N**2)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the test described above.  If A E or
!>          B E is likely to overflow, then RESULT(1:2) is set to
!>          10 / ulp.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 160 of file zget52.f.

162*
163* -- LAPACK test 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 LOGICAL LEFT
169 INTEGER LDA, LDB, LDE, N
170* ..
171* .. Array Arguments ..
172 DOUBLE PRECISION RESULT( 2 ), RWORK( * )
173 COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
174 $ BETA( * ), E( LDE, * ), WORK( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 DOUBLE PRECISION ZERO, ONE
181 parameter( zero = 0.0d+0, one = 1.0d+0 )
182 COMPLEX*16 CZERO, CONE
183 parameter( czero = ( 0.0d+0, 0.0d+0 ),
184 $ cone = ( 1.0d+0, 0.0d+0 ) )
185* ..
186* .. Local Scalars ..
187 CHARACTER NORMAB, TRANS
188 INTEGER J, JVEC
189 DOUBLE PRECISION ABMAX, ALFMAX, ANORM, BETMAX, BNORM, ENORM,
190 $ ENRMER, ERRNRM, SAFMAX, SAFMIN, SCALE, TEMP1,
191 $ ULP
192 COMPLEX*16 ACOEFF, ALPHAI, BCOEFF, BETAI, X
193* ..
194* .. External Functions ..
195 DOUBLE PRECISION DLAMCH, ZLANGE
196 EXTERNAL dlamch, zlange
197* ..
198* .. External Subroutines ..
199 EXTERNAL zgemv
200* ..
201* .. Intrinsic Functions ..
202 INTRINSIC abs, dble, dconjg, dimag, max
203* ..
204* .. Statement Functions ..
205 DOUBLE PRECISION ABS1
206* ..
207* .. Statement Function definitions ..
208 abs1( x ) = abs( dble( x ) ) + abs( dimag( x ) )
209* ..
210* .. Executable Statements ..
211*
212 result( 1 ) = zero
213 result( 2 ) = zero
214 IF( n.LE.0 )
215 $ RETURN
216*
217 safmin = dlamch( 'Safe minimum' )
218 safmax = one / safmin
219 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
220*
221 IF( left ) THEN
222 trans = 'C'
223 normab = 'I'
224 ELSE
225 trans = 'N'
226 normab = 'O'
227 END IF
228*
229* Norm of A, B, and E:
230*
231 anorm = max( zlange( normab, n, n, a, lda, rwork ), safmin )
232 bnorm = max( zlange( normab, n, n, b, ldb, rwork ), safmin )
233 enorm = max( zlange( 'O', n, n, e, lde, rwork ), ulp )
234 alfmax = safmax / max( one, bnorm )
235 betmax = safmax / max( one, anorm )
236*
237* Compute error matrix.
238* Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B|, |b(i) A| )
239*
240 DO 10 jvec = 1, n
241 alphai = alpha( jvec )
242 betai = beta( jvec )
243 abmax = max( abs1( alphai ), abs1( betai ) )
244 IF( abs1( alphai ).GT.alfmax .OR. abs1( betai ).GT.betmax .OR.
245 $ abmax.LT.one ) THEN
246 scale = one / max( abmax, safmin )
247 alphai = scale*alphai
248 betai = scale*betai
249 END IF
250 scale = one / max( abs1( alphai )*bnorm, abs1( betai )*anorm,
251 $ safmin )
252 acoeff = scale*betai
253 bcoeff = scale*alphai
254 IF( left ) THEN
255 acoeff = dconjg( acoeff )
256 bcoeff = dconjg( bcoeff )
257 END IF
258 CALL zgemv( trans, n, n, acoeff, a, lda, e( 1, jvec ), 1,
259 $ czero, work( n*( jvec-1 )+1 ), 1 )
260 CALL zgemv( trans, n, n, -bcoeff, b, lda, e( 1, jvec ), 1,
261 $ cone, work( n*( jvec-1 )+1 ), 1 )
262 10 CONTINUE
263*
264 errnrm = zlange( 'One', n, n, work, n, rwork ) / enorm
265*
266* Compute RESULT(1)
267*
268 result( 1 ) = errnrm / ulp
269*
270* Normalization of E:
271*
272 enrmer = zero
273 DO 30 jvec = 1, n
274 temp1 = zero
275 DO 20 j = 1, n
276 temp1 = max( temp1, abs1( e( j, jvec ) ) )
277 20 CONTINUE
278 enrmer = max( enrmer, abs( temp1-one ) )
279 30 CONTINUE
280*
281* Compute RESULT(2) : the normalization error in E.
282*
283 result( 2 ) = enrmer / ( dble( n )*ulp )
284*
285 RETURN
286*
287* End of ZGET52
288*

◆ zget54()

subroutine zget54 ( integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( lds, * ) s,
integer lds,
complex*16, dimension( ldt, * ) t,
integer ldt,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldv, * ) v,
integer ldv,
complex*16, dimension( * ) work,
double precision result )

ZGET54

Purpose:
!>
!> ZGET54 checks a generalized decomposition of the form
!>
!>          A = U*S*V'  and B = U*T* V'
!>
!> where ' means conjugate transpose and U and V are unitary.
!>
!> Specifically,
!>
!>   RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp )
!>
Parameters
[in]N
!>          N is INTEGER
!>          The size of the matrix.  If it is zero, DGET54 does nothing.
!>          It must be at least zero.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          The original (unfactored) matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least N.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          The original (unfactored) matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of B.  It must be at least 1
!>          and at least N.
!>
[in]S
!>          S is COMPLEX*16 array, dimension (LDS, N)
!>          The factored matrix S.
!>
[in]LDS
!>          LDS is INTEGER
!>          The leading dimension of S.  It must be at least 1
!>          and at least N.
!>
[in]T
!>          T is COMPLEX*16 array, dimension (LDT, N)
!>          The factored matrix T.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of T.  It must be at least 1
!>          and at least N.
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU, N)
!>          The orthogonal matrix on the left-hand side in the
!>          decomposition.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  LDU must be at least N and
!>          at least 1.
!>
[in]V
!>          V is COMPLEX*16 array, dimension (LDV, N)
!>          The orthogonal matrix on the left-hand side in the
!>          decomposition.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of V.  LDV must be at least N and
!>          at least 1.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (3*N**2)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION
!>          The value RESULT, It is currently limited to 1/ulp, to
!>          avoid overflow. Errors are flagged by RESULT=10/ulp.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 154 of file zget54.f.

156*
157* -- LAPACK test routine --
158* -- LAPACK is a software package provided by Univ. of Tennessee, --
159* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
160*
161* .. Scalar Arguments ..
162 INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N
163 DOUBLE PRECISION RESULT
164* ..
165* .. Array Arguments ..
166 COMPLEX*16 A( LDA, * ), B( LDB, * ), S( LDS, * ),
167 $ T( LDT, * ), U( LDU, * ), V( LDV, * ),
168 $ WORK( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ZERO, ONE
175 parameter( zero = 0.0d+0, one = 1.0d+0 )
176 COMPLEX*16 CZERO, CONE
177 parameter( czero = ( 0.0d+0, 0.0d+0 ),
178 $ cone = ( 1.0d+0, 0.0d+0 ) )
179* ..
180* .. Local Scalars ..
181 DOUBLE PRECISION ABNORM, ULP, UNFL, WNORM
182* ..
183* .. Local Arrays ..
184 DOUBLE PRECISION DUM( 1 )
185* ..
186* .. External Functions ..
187 DOUBLE PRECISION DLAMCH, ZLANGE
188 EXTERNAL dlamch, zlange
189* ..
190* .. External Subroutines ..
191 EXTERNAL zgemm, zlacpy
192* ..
193* .. Intrinsic Functions ..
194 INTRINSIC dble, max, min
195* ..
196* .. Executable Statements ..
197*
198 result = zero
199 IF( n.LE.0 )
200 $ RETURN
201*
202* Constants
203*
204 unfl = dlamch( 'Safe minimum' )
205 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
206*
207* compute the norm of (A,B)
208*
209 CALL zlacpy( 'Full', n, n, a, lda, work, n )
210 CALL zlacpy( 'Full', n, n, b, ldb, work( n*n+1 ), n )
211 abnorm = max( zlange( '1', n, 2*n, work, n, dum ), unfl )
212*
213* Compute W1 = A - U*S*V', and put in the array WORK(1:N*N)
214*
215 CALL zlacpy( ' ', n, n, a, lda, work, n )
216 CALL zgemm( 'N', 'N', n, n, n, cone, u, ldu, s, lds, czero,
217 $ work( n*n+1 ), n )
218*
219 CALL zgemm( 'N', 'C', n, n, n, -cone, work( n*n+1 ), n, v, ldv,
220 $ cone, work, n )
221*
222* Compute W2 = B - U*T*V', and put in the workarray W(N*N+1:2*N*N)
223*
224 CALL zlacpy( ' ', n, n, b, ldb, work( n*n+1 ), n )
225 CALL zgemm( 'N', 'N', n, n, n, cone, u, ldu, t, ldt, czero,
226 $ work( 2*n*n+1 ), n )
227*
228 CALL zgemm( 'N', 'C', n, n, n, -cone, work( 2*n*n+1 ), n, v, ldv,
229 $ cone, work( n*n+1 ), n )
230*
231* Compute norm(W)/ ( ulp*norm((A,B)) )
232*
233 wnorm = zlange( '1', n, 2*n, work, n, dum )
234*
235 IF( abnorm.GT.wnorm ) THEN
236 result = ( wnorm / abnorm ) / ( 2*n*ulp )
237 ELSE
238 IF( abnorm.LT.one ) THEN
239 result = ( min( wnorm, 2*n*abnorm ) / abnorm ) / ( 2*n*ulp )
240 ELSE
241 result = min( wnorm / abnorm, dble( 2*n ) ) / ( 2*n*ulp )
242 END IF
243 END IF
244*
245 RETURN
246*
247* End of ZGET54
248*

◆ zglmts()

subroutine zglmts ( integer n,
integer m,
integer p,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
integer lda,
complex*16, dimension( ldb, * ) b,
complex*16, dimension( ldb, * ) bf,
integer ldb,
complex*16, dimension( * ) d,
complex*16, dimension( * ) df,
complex*16, dimension( * ) x,
complex*16, dimension( * ) u,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision result )

ZGLMTS

Purpose:
!>
!> ZGLMTS tests ZGGGLM - a subroutine for solving the generalized
!> linear model problem.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices A and B.  N >= 0.
!>
[in]M
!>          M is INTEGER
!>          The number of columns of the matrix A.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of columns of the matrix B.  P >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,M)
!>          The N-by-M matrix A.
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (LDA,M)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF. LDA >= max(M,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,P)
!>          The N-by-P matrix A.
!>
[out]BF
!>          BF is COMPLEX*16 array, dimension (LDB,P)
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the arrays B, BF. LDB >= max(P,N).
!>
[in]D
!>          D is COMPLEX*16 array, dimension( N )
!>          On input, the left hand side of the GLM.
!>
[out]DF
!>          DF is COMPLEX*16 array, dimension( N )
!>
[out]X
!>          X is COMPLEX*16 array, dimension( M )
!>          solution vector X in the GLM problem.
!>
[out]U
!>          U is COMPLEX*16 array, dimension( P )
!>          solution vector U in the GLM problem.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION
!>          The test ratio:
!>                           norm( d - A*x - B*u )
!>            RESULT = -----------------------------------------
!>                     (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 144 of file zglmts.f.

146*
147* -- LAPACK test 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 LDA, LDB, LWORK, M, N, P
153 DOUBLE PRECISION RESULT
154* ..
155* .. Array Arguments ..
156*
157* ====================================================================
158*
159 DOUBLE PRECISION RWORK( * )
160 COMPLEX*16 A( LDA, * ), AF( LDA, * ), B( LDB, * ),
161 $ BF( LDB, * ), D( * ), DF( * ), U( * ),
162 $ WORK( LWORK ), X( * )
163* ..
164* .. Parameters ..
165 DOUBLE PRECISION ZERO
166 parameter( zero = 0.0d+0 )
167 COMPLEX*16 CONE
168 parameter( cone = 1.0d+0 )
169* ..
170* .. Local Scalars ..
171 INTEGER INFO
172 DOUBLE PRECISION ANORM, BNORM, DNORM, EPS, UNFL, XNORM, YNORM
173* ..
174* .. External Functions ..
175 DOUBLE PRECISION DLAMCH, DZASUM, ZLANGE
176 EXTERNAL dlamch, dzasum, zlange
177* ..
178* .. External Subroutines ..
179*
180 EXTERNAL zcopy, zgemv, zggglm, zlacpy
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC max
184* ..
185* .. Executable Statements ..
186*
187 eps = dlamch( 'Epsilon' )
188 unfl = dlamch( 'Safe minimum' )
189 anorm = max( zlange( '1', n, m, a, lda, rwork ), unfl )
190 bnorm = max( zlange( '1', n, p, b, ldb, rwork ), unfl )
191*
192* Copy the matrices A and B to the arrays AF and BF,
193* and the vector D the array DF.
194*
195 CALL zlacpy( 'Full', n, m, a, lda, af, lda )
196 CALL zlacpy( 'Full', n, p, b, ldb, bf, ldb )
197 CALL zcopy( n, d, 1, df, 1 )
198*
199* Solve GLM problem
200*
201 CALL zggglm( n, m, p, af, lda, bf, ldb, df, x, u, work, lwork,
202 $ info )
203*
204* Test the residual for the solution of LSE
205*
206* norm( d - A*x - B*u )
207* RESULT = -----------------------------------------
208* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
209*
210 CALL zcopy( n, d, 1, df, 1 )
211 CALL zgemv( 'No transpose', n, m, -cone, a, lda, x, 1, cone, df,
212 $ 1 )
213*
214 CALL zgemv( 'No transpose', n, p, -cone, b, ldb, u, 1, cone, df,
215 $ 1 )
216*
217 dnorm = dzasum( n, df, 1 )
218 xnorm = dzasum( m, x, 1 ) + dzasum( p, u, 1 )
219 ynorm = anorm + bnorm
220*
221 IF( xnorm.LE.zero ) THEN
222 result = zero
223 ELSE
224 result = ( ( dnorm / ynorm ) / xnorm ) / eps
225 END IF
226*
227 RETURN
228*
229* End of ZGLMTS
230*

◆ zgqrts()

subroutine zgqrts ( integer n,
integer m,
integer p,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) r,
integer lda,
complex*16, dimension( * ) taua,
complex*16, dimension( ldb, * ) b,
complex*16, dimension( ldb, * ) bf,
complex*16, dimension( ldb, * ) z,
complex*16, dimension( ldb, * ) t,
complex*16, dimension( ldb, * ) bwk,
integer ldb,
complex*16, dimension( * ) taub,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( 4 ) result )

ZGQRTS

Purpose:
!>
!> ZGQRTS tests ZGGQRF, which computes the GQR factorization of an
!> N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices A and B.  N >= 0.
!>
[in]M
!>          M is INTEGER
!>          The number of columns of the matrix A.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of columns of the matrix B.  P >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,M)
!>          The N-by-M matrix A.
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the GQR factorization of A and B, as returned
!>          by ZGGQRF, see CGGQRF for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,N)
!>          The M-by-M unitary matrix Q.
!>
[out]R
!>          R is COMPLEX*16 array, dimension (LDA,MAX(M,N))
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, R and Q.
!>          LDA >= max(M,N).
!>
[out]TAUA
!>          TAUA is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by ZGGQRF.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,P)
!>          On entry, the N-by-P matrix A.
!>
[out]BF
!>          BF is COMPLEX*16 array, dimension (LDB,N)
!>          Details of the GQR factorization of A and B, as returned
!>          by ZGGQRF, see CGGQRF for further details.
!>
[out]Z
!>          Z is COMPLEX*16 array, dimension (LDB,P)
!>          The P-by-P unitary matrix Z.
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDB,max(P,N))
!>
[out]BWK
!>          BWK is COMPLEX*16 array, dimension (LDB,N)
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the arrays B, BF, Z and T.
!>          LDB >= max(P,N).
!>
[out]TAUB
!>          TAUB is COMPLEX*16 array, dimension (min(P,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGGRQF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK, LWORK >= max(N,M,P)**2.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(N,M,P))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios:
!>            RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP)
!>            RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP)
!>            RESULT(3) = norm( I - Q'*Q ) / ( M*ULP )
!>            RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 174 of file zgqrts.f.

176*
177* -- LAPACK test routine --
178* -- LAPACK is a software package provided by Univ. of Tennessee, --
179* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
180*
181* .. Scalar Arguments ..
182 INTEGER LDA, LDB, LWORK, M, N, P
183* ..
184* .. Array Arguments ..
185 DOUBLE PRECISION RESULT( 4 ), RWORK( * )
186 COMPLEX*16 A( LDA, * ), AF( LDA, * ), B( LDB, * ),
187 $ BF( LDB, * ), BWK( LDB, * ), Q( LDA, * ),
188 $ R( LDA, * ), T( LDB, * ), TAUA( * ), TAUB( * ),
189 $ WORK( LWORK ), Z( LDB, * )
190* ..
191*
192* =====================================================================
193*
194* .. Parameters ..
195 DOUBLE PRECISION ZERO, ONE
196 parameter( zero = 0.0d+0, one = 1.0d+0 )
197 COMPLEX*16 CZERO, CONE
198 parameter( czero = ( 0.0d+0, 0.0d+0 ),
199 $ cone = ( 1.0d+0, 0.0d+0 ) )
200 COMPLEX*16 CROGUE
201 parameter( crogue = ( -1.0d+10, 0.0d+0 ) )
202* ..
203* .. Local Scalars ..
204 INTEGER INFO
205 DOUBLE PRECISION ANORM, BNORM, RESID, ULP, UNFL
206* ..
207* .. External Functions ..
208 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHE
209 EXTERNAL dlamch, zlange, zlanhe
210* ..
211* .. External Subroutines ..
212 EXTERNAL zgemm, zggqrf, zherk, zlacpy, zlaset, zungqr,
213 $ zungrq
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC dble, max, min
217* ..
218* .. Executable Statements ..
219*
220 ulp = dlamch( 'Precision' )
221 unfl = dlamch( 'Safe minimum' )
222*
223* Copy the matrix A to the array AF.
224*
225 CALL zlacpy( 'Full', n, m, a, lda, af, lda )
226 CALL zlacpy( 'Full', n, p, b, ldb, bf, ldb )
227*
228 anorm = max( zlange( '1', n, m, a, lda, rwork ), unfl )
229 bnorm = max( zlange( '1', n, p, b, ldb, rwork ), unfl )
230*
231* Factorize the matrices A and B in the arrays AF and BF.
232*
233 CALL zggqrf( n, m, p, af, lda, taua, bf, ldb, taub, work, lwork,
234 $ info )
235*
236* Generate the N-by-N matrix Q
237*
238 CALL zlaset( 'Full', n, n, crogue, crogue, q, lda )
239 CALL zlacpy( 'Lower', n-1, m, af( 2, 1 ), lda, q( 2, 1 ), lda )
240 CALL zungqr( n, n, min( n, m ), q, lda, taua, work, lwork, info )
241*
242* Generate the P-by-P matrix Z
243*
244 CALL zlaset( 'Full', p, p, crogue, crogue, z, ldb )
245 IF( n.LE.p ) THEN
246 IF( n.GT.0 .AND. n.LT.p )
247 $ CALL zlacpy( 'Full', n, p-n, bf, ldb, z( p-n+1, 1 ), ldb )
248 IF( n.GT.1 )
249 $ CALL zlacpy( 'Lower', n-1, n-1, bf( 2, p-n+1 ), ldb,
250 $ z( p-n+2, p-n+1 ), ldb )
251 ELSE
252 IF( p.GT.1 )
253 $ CALL zlacpy( 'Lower', p-1, p-1, bf( n-p+2, 1 ), ldb,
254 $ z( 2, 1 ), ldb )
255 END IF
256 CALL zungrq( p, p, min( n, p ), z, ldb, taub, work, lwork, info )
257*
258* Copy R
259*
260 CALL zlaset( 'Full', n, m, czero, czero, r, lda )
261 CALL zlacpy( 'Upper', n, m, af, lda, r, lda )
262*
263* Copy T
264*
265 CALL zlaset( 'Full', n, p, czero, czero, t, ldb )
266 IF( n.LE.p ) THEN
267 CALL zlacpy( 'Upper', n, n, bf( 1, p-n+1 ), ldb, t( 1, p-n+1 ),
268 $ ldb )
269 ELSE
270 CALL zlacpy( 'Full', n-p, p, bf, ldb, t, ldb )
271 CALL zlacpy( 'Upper', p, p, bf( n-p+1, 1 ), ldb, t( n-p+1, 1 ),
272 $ ldb )
273 END IF
274*
275* Compute R - Q'*A
276*
277 CALL zgemm( 'Conjugate transpose', 'No transpose', n, m, n, -cone,
278 $ q, lda, a, lda, cone, r, lda )
279*
280* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) .
281*
282 resid = zlange( '1', n, m, r, lda, rwork )
283 IF( anorm.GT.zero ) THEN
284 result( 1 ) = ( ( resid / dble( max( 1, m, n ) ) ) / anorm ) /
285 $ ulp
286 ELSE
287 result( 1 ) = zero
288 END IF
289*
290* Compute T*Z - Q'*B
291*
292 CALL zgemm( 'No Transpose', 'No transpose', n, p, p, cone, t, ldb,
293 $ z, ldb, czero, bwk, ldb )
294 CALL zgemm( 'Conjugate transpose', 'No transpose', n, p, n, -cone,
295 $ q, lda, b, ldb, cone, bwk, ldb )
296*
297* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) .
298*
299 resid = zlange( '1', n, p, bwk, ldb, rwork )
300 IF( bnorm.GT.zero ) THEN
301 result( 2 ) = ( ( resid / dble( max( 1, p, n ) ) ) / bnorm ) /
302 $ ulp
303 ELSE
304 result( 2 ) = zero
305 END IF
306*
307* Compute I - Q'*Q
308*
309 CALL zlaset( 'Full', n, n, czero, cone, r, lda )
310 CALL zherk( 'Upper', 'Conjugate transpose', n, n, -one, q, lda,
311 $ one, r, lda )
312*
313* Compute norm( I - Q'*Q ) / ( N * ULP ) .
314*
315 resid = zlanhe( '1', 'Upper', n, r, lda, rwork )
316 result( 3 ) = ( resid / dble( max( 1, n ) ) ) / ulp
317*
318* Compute I - Z'*Z
319*
320 CALL zlaset( 'Full', p, p, czero, cone, t, ldb )
321 CALL zherk( 'Upper', 'Conjugate transpose', p, p, -one, z, ldb,
322 $ one, t, ldb )
323*
324* Compute norm( I - Z'*Z ) / ( P*ULP ) .
325*
326 resid = zlanhe( '1', 'Upper', p, t, ldb, rwork )
327 result( 4 ) = ( resid / dble( max( 1, p ) ) ) / ulp
328*
329 RETURN
330*
331* End of ZGQRTS
332*
zungrq
subroutine zungrq(m, n, k, a, lda, tau, work, lwork, info)
ZUNGRQ
Definition zungrq.f:128
zungqr
subroutine zungqr(m, n, k, a, lda, tau, work, lwork, info)
ZUNGQR
Definition zungqr.f:128

◆ zgrqts()

subroutine zgrqts ( integer m,
integer p,
integer n,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) r,
integer lda,
complex*16, dimension( * ) taua,
complex*16, dimension( ldb, * ) b,
complex*16, dimension( ldb, * ) bf,
complex*16, dimension( ldb, * ) z,
complex*16, dimension( ldb, * ) t,
complex*16, dimension( ldb, * ) bwk,
integer ldb,
complex*16, dimension( * ) taub,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( 4 ) result )

ZGRQTS

Purpose:
!>
!> ZGRQTS tests ZGGRQF, which computes the GRQ factorization of an
!> M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of rows of the matrix B.  P >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and B.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The M-by-N matrix A.
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the GRQ factorization of A and B, as returned
!>          by ZGGRQF, see CGGRQF for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,N)
!>          The N-by-N unitary matrix Q.
!>
[out]R
!>          R is COMPLEX*16 array, dimension (LDA,MAX(M,N))
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, R and Q.
!>          LDA >= max(M,N).
!>
[out]TAUA
!>          TAUA is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGGQRC.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          On entry, the P-by-N matrix A.
!>
[out]BF
!>          BF is COMPLEX*16 array, dimension (LDB,N)
!>          Details of the GQR factorization of A and B, as returned
!>          by ZGGRQF, see CGGRQF for further details.
!>
[out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDB,P)
!>          The P-by-P unitary matrix Z.
!>
[out]T
!>          T is COMPLEX*16 array, dimension (LDB,max(P,N))
!>
[out]BWK
!>          BWK is COMPLEX*16 array, dimension (LDB,N)
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the arrays B, BF, Z and T.
!>          LDB >= max(P,N).
!>
[out]TAUB
!>          TAUB is COMPLEX*16 array, dimension (min(P,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGGRQF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK, LWORK >= max(M,P,N)**2.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios:
!>            RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP)
!>            RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP)
!>            RESULT(3) = norm( I - Q'*Q ) / ( N*ULP )
!>            RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 174 of file zgrqts.f.

176*
177* -- LAPACK test routine --
178* -- LAPACK is a software package provided by Univ. of Tennessee, --
179* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
180*
181* .. Scalar Arguments ..
182 INTEGER LDA, LDB, LWORK, M, N, P
183* ..
184* .. Array Arguments ..
185 DOUBLE PRECISION RESULT( 4 ), RWORK( * )
186 COMPLEX*16 A( LDA, * ), AF( LDA, * ), B( LDB, * ),
187 $ BF( LDB, * ), BWK( LDB, * ), Q( LDA, * ),
188 $ R( LDA, * ), T( LDB, * ), TAUA( * ), TAUB( * ),
189 $ WORK( LWORK ), Z( LDB, * )
190* ..
191*
192* =====================================================================
193*
194* .. Parameters ..
195 DOUBLE PRECISION ZERO, ONE
196 parameter( zero = 0.0d+0, one = 1.0d+0 )
197 COMPLEX*16 CZERO, CONE
198 parameter( czero = ( 0.0d+0, 0.0d+0 ),
199 $ cone = ( 1.0d+0, 0.0d+0 ) )
200 COMPLEX*16 CROGUE
201 parameter( crogue = ( -1.0d+10, 0.0d+0 ) )
202* ..
203* .. Local Scalars ..
204 INTEGER INFO
205 DOUBLE PRECISION ANORM, BNORM, RESID, ULP, UNFL
206* ..
207* .. External Functions ..
208 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHE
209 EXTERNAL dlamch, zlange, zlanhe
210* ..
211* .. External Subroutines ..
212 EXTERNAL zgemm, zggrqf, zherk, zlacpy, zlaset, zungqr,
213 $ zungrq
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC dble, max, min
217* ..
218* .. Executable Statements ..
219*
220 ulp = dlamch( 'Precision' )
221 unfl = dlamch( 'Safe minimum' )
222*
223* Copy the matrix A to the array AF.
224*
225 CALL zlacpy( 'Full', m, n, a, lda, af, lda )
226 CALL zlacpy( 'Full', p, n, b, ldb, bf, ldb )
227*
228 anorm = max( zlange( '1', m, n, a, lda, rwork ), unfl )
229 bnorm = max( zlange( '1', p, n, b, ldb, rwork ), unfl )
230*
231* Factorize the matrices A and B in the arrays AF and BF.
232*
233 CALL zggrqf( m, p, n, af, lda, taua, bf, ldb, taub, work, lwork,
234 $ info )
235*
236* Generate the N-by-N matrix Q
237*
238 CALL zlaset( 'Full', n, n, crogue, crogue, q, lda )
239 IF( m.LE.n ) THEN
240 IF( m.GT.0 .AND. m.LT.n )
241 $ CALL zlacpy( 'Full', m, n-m, af, lda, q( n-m+1, 1 ), lda )
242 IF( m.GT.1 )
243 $ CALL zlacpy( 'Lower', m-1, m-1, af( 2, n-m+1 ), lda,
244 $ q( n-m+2, n-m+1 ), lda )
245 ELSE
246 IF( n.GT.1 )
247 $ CALL zlacpy( 'Lower', n-1, n-1, af( m-n+2, 1 ), lda,
248 $ q( 2, 1 ), lda )
249 END IF
250 CALL zungrq( n, n, min( m, n ), q, lda, taua, work, lwork, info )
251*
252* Generate the P-by-P matrix Z
253*
254 CALL zlaset( 'Full', p, p, crogue, crogue, z, ldb )
255 IF( p.GT.1 )
256 $ CALL zlacpy( 'Lower', p-1, n, bf( 2, 1 ), ldb, z( 2, 1 ), ldb )
257 CALL zungqr( p, p, min( p, n ), z, ldb, taub, work, lwork, info )
258*
259* Copy R
260*
261 CALL zlaset( 'Full', m, n, czero, czero, r, lda )
262 IF( m.LE.n ) THEN
263 CALL zlacpy( 'Upper', m, m, af( 1, n-m+1 ), lda, r( 1, n-m+1 ),
264 $ lda )
265 ELSE
266 CALL zlacpy( 'Full', m-n, n, af, lda, r, lda )
267 CALL zlacpy( 'Upper', n, n, af( m-n+1, 1 ), lda, r( m-n+1, 1 ),
268 $ lda )
269 END IF
270*
271* Copy T
272*
273 CALL zlaset( 'Full', p, n, czero, czero, t, ldb )
274 CALL zlacpy( 'Upper', p, n, bf, ldb, t, ldb )
275*
276* Compute R - A*Q'
277*
278 CALL zgemm( 'No transpose', 'Conjugate transpose', m, n, n, -cone,
279 $ a, lda, q, lda, cone, r, lda )
280*
281* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) .
282*
283 resid = zlange( '1', m, n, r, lda, rwork )
284 IF( anorm.GT.zero ) THEN
285 result( 1 ) = ( ( resid / dble( max( 1, m, n ) ) ) / anorm ) /
286 $ ulp
287 ELSE
288 result( 1 ) = zero
289 END IF
290*
291* Compute T*Q - Z'*B
292*
293 CALL zgemm( 'Conjugate transpose', 'No transpose', p, n, p, cone,
294 $ z, ldb, b, ldb, czero, bwk, ldb )
295 CALL zgemm( 'No transpose', 'No transpose', p, n, n, cone, t, ldb,
296 $ q, lda, -cone, bwk, ldb )
297*
298* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) .
299*
300 resid = zlange( '1', p, n, bwk, ldb, rwork )
301 IF( bnorm.GT.zero ) THEN
302 result( 2 ) = ( ( resid / dble( max( 1, p, m ) ) ) / bnorm ) /
303 $ ulp
304 ELSE
305 result( 2 ) = zero
306 END IF
307*
308* Compute I - Q*Q'
309*
310 CALL zlaset( 'Full', n, n, czero, cone, r, lda )
311 CALL zherk( 'Upper', 'No Transpose', n, n, -one, q, lda, one, r,
312 $ lda )
313*
314* Compute norm( I - Q'*Q ) / ( N * ULP ) .
315*
316 resid = zlanhe( '1', 'Upper', n, r, lda, rwork )
317 result( 3 ) = ( resid / dble( max( 1, n ) ) ) / ulp
318*
319* Compute I - Z'*Z
320*
321 CALL zlaset( 'Full', p, p, czero, cone, t, ldb )
322 CALL zherk( 'Upper', 'Conjugate transpose', p, p, -one, z, ldb,
323 $ one, t, ldb )
324*
325* Compute norm( I - Z'*Z ) / ( P*ULP ) .
326*
327 resid = zlanhe( '1', 'Upper', p, t, ldb, rwork )
328 result( 4 ) = ( resid / dble( max( 1, p ) ) ) / ulp
329*
330 RETURN
331*
332* End of ZGRQTS
333*

◆ zgsvts3()

subroutine zgsvts3 ( integer m,
integer p,
integer n,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
integer lda,
complex*16, dimension( ldb, * ) b,
complex*16, dimension( ldb, * ) bf,
integer ldb,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldv, * ) v,
integer ldv,
complex*16, dimension( ldq, * ) q,
integer ldq,
double precision, dimension( * ) alpha,
double precision, dimension( * ) beta,
complex*16, dimension( ldr, * ) r,
integer ldr,
integer, dimension( * ) iwork,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( 6 ) result )

ZGSVTS3

Purpose:
!>
!> ZGSVTS3 tests ZGGSVD3, which computes the GSVD of an M-by-N matrix A
!> and a P-by-N matrix B:
!>              U'*A*Q = D1*R and V'*B*Q = D2*R.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of rows of the matrix B.  P >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and B.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,M)
!>          The M-by-N matrix A.
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the GSVD of A and B, as returned by ZGGSVD3,
!>          see ZGGSVD3 for further details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A and AF.
!>          LDA >= max( 1,M ).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,P)
!>          On entry, the P-by-N matrix B.
!>
[out]BF
!>          BF is COMPLEX*16 array, dimension (LDB,N)
!>          Details of the GSVD of A and B, as returned by ZGGSVD3,
!>          see ZGGSVD3 for further details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the arrays B and BF.
!>          LDB >= max(1,P).
!>
[out]U
!>          U is COMPLEX*16 array, dimension(LDU,M)
!>          The M by M unitary matrix U.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U. LDU >= max(1,M).
!>
[out]V
!>          V is COMPLEX*16 array, dimension(LDV,M)
!>          The P by P unitary matrix V.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= max(1,P).
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension(LDQ,N)
!>          The N by N unitary matrix Q.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= max(1,N).
!>
[out]ALPHA
!>          ALPHA is DOUBLE PRECISION array, dimension (N)
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>
!>          The generalized singular value pairs of A and B, the
!>          ``diagonal'' matrices D1 and D2 are constructed from
!>          ALPHA and BETA, see subroutine ZGGSVD3 for details.
!>
[out]R
!>          R is COMPLEX*16 array, dimension(LDQ,N)
!>          The upper triangular matrix R.
!>
[in]LDR
!>          LDR is INTEGER
!>          The leading dimension of the array R. LDR >= max(1,N).
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK,
!>          LWORK >= max(M,P,N)*max(M,P,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(M,P,N))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          The test ratios:
!>          RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP)
!>          RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP)
!>          RESULT(3) = norm( I - U'*U ) / ( M*ULP )
!>          RESULT(4) = norm( I - V'*V ) / ( P*ULP )
!>          RESULT(5) = norm( I - Q'*Q ) / ( N*ULP )
!>          RESULT(6) = 0        if ALPHA is in decreasing order;
!>                    = ULPINV   otherwise.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 206 of file zgsvts3.f.

209*
210* -- LAPACK test routine --
211* -- LAPACK is a software package provided by Univ. of Tennessee, --
212* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
213*
214* .. Scalar Arguments ..
215 INTEGER LDA, LDB, LDQ, LDR, LDU, LDV, LWORK, M, N, P
216* ..
217* .. Array Arguments ..
218 INTEGER IWORK( * )
219 DOUBLE PRECISION ALPHA( * ), BETA( * ), RESULT( 6 ), RWORK( * )
220 COMPLEX*16 A( LDA, * ), AF( LDA, * ), B( LDB, * ),
221 $ BF( LDB, * ), Q( LDQ, * ), R( LDR, * ),
222 $ U( LDU, * ), V( LDV, * ), WORK( LWORK )
223* ..
224*
225* =====================================================================
226*
227* .. Parameters ..
228 DOUBLE PRECISION ZERO, ONE
229 parameter( zero = 0.0d+0, one = 1.0d+0 )
230 COMPLEX*16 CZERO, CONE
231 parameter( czero = ( 0.0d+0, 0.0d+0 ),
232 $ cone = ( 1.0d+0, 0.0d+0 ) )
233* ..
234* .. Local Scalars ..
235 INTEGER I, INFO, J, K, L
236 DOUBLE PRECISION ANORM, BNORM, RESID, TEMP, ULP, ULPINV, UNFL
237* ..
238* .. External Functions ..
239 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHE
240 EXTERNAL dlamch, zlange, zlanhe
241* ..
242* .. External Subroutines ..
243 EXTERNAL dcopy, zgemm, zggsvd3, zherk, zlacpy, zlaset
244* ..
245* .. Intrinsic Functions ..
246 INTRINSIC dble, max, min
247* ..
248* .. Executable Statements ..
249*
250 ulp = dlamch( 'Precision' )
251 ulpinv = one / ulp
252 unfl = dlamch( 'Safe minimum' )
253*
254* Copy the matrix A to the array AF.
255*
256 CALL zlacpy( 'Full', m, n, a, lda, af, lda )
257 CALL zlacpy( 'Full', p, n, b, ldb, bf, ldb )
258*
259 anorm = max( zlange( '1', m, n, a, lda, rwork ), unfl )
260 bnorm = max( zlange( '1', p, n, b, ldb, rwork ), unfl )
261*
262* Factorize the matrices A and B in the arrays AF and BF.
263*
264 CALL zggsvd3( 'U', 'V', 'Q', m, n, p, k, l, af, lda, bf, ldb,
265 $ alpha, beta, u, ldu, v, ldv, q, ldq, work, lwork,
266 $ rwork, iwork, info )
267*
268* Copy R
269*
270 DO 20 i = 1, min( k+l, m )
271 DO 10 j = i, k + l
272 r( i, j ) = af( i, n-k-l+j )
273 10 CONTINUE
274 20 CONTINUE
275*
276 IF( m-k-l.LT.0 ) THEN
277 DO 40 i = m + 1, k + l
278 DO 30 j = i, k + l
279 r( i, j ) = bf( i-k, n-k-l+j )
280 30 CONTINUE
281 40 CONTINUE
282 END IF
283*
284* Compute A:= U'*A*Q - D1*R
285*
286 CALL zgemm( 'No transpose', 'No transpose', m, n, n, cone, a, lda,
287 $ q, ldq, czero, work, lda )
288*
289 CALL zgemm( 'Conjugate transpose', 'No transpose', m, n, m, cone,
290 $ u, ldu, work, lda, czero, a, lda )
291*
292 DO 60 i = 1, k
293 DO 50 j = i, k + l
294 a( i, n-k-l+j ) = a( i, n-k-l+j ) - r( i, j )
295 50 CONTINUE
296 60 CONTINUE
297*
298 DO 80 i = k + 1, min( k+l, m )
299 DO 70 j = i, k + l
300 a( i, n-k-l+j ) = a( i, n-k-l+j ) - alpha( i )*r( i, j )
301 70 CONTINUE
302 80 CONTINUE
303*
304* Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) .
305*
306 resid = zlange( '1', m, n, a, lda, rwork )
307 IF( anorm.GT.zero ) THEN
308 result( 1 ) = ( ( resid / dble( max( 1, m, n ) ) ) / anorm ) /
309 $ ulp
310 ELSE
311 result( 1 ) = zero
312 END IF
313*
314* Compute B := V'*B*Q - D2*R
315*
316 CALL zgemm( 'No transpose', 'No transpose', p, n, n, cone, b, ldb,
317 $ q, ldq, czero, work, ldb )
318*
319 CALL zgemm( 'Conjugate transpose', 'No transpose', p, n, p, cone,
320 $ v, ldv, work, ldb, czero, b, ldb )
321*
322 DO 100 i = 1, l
323 DO 90 j = i, l
324 b( i, n-l+j ) = b( i, n-l+j ) - beta( k+i )*r( k+i, k+j )
325 90 CONTINUE
326 100 CONTINUE
327*
328* Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) .
329*
330 resid = zlange( '1', p, n, b, ldb, rwork )
331 IF( bnorm.GT.zero ) THEN
332 result( 2 ) = ( ( resid / dble( max( 1, p, n ) ) ) / bnorm ) /
333 $ ulp
334 ELSE
335 result( 2 ) = zero
336 END IF
337*
338* Compute I - U'*U
339*
340 CALL zlaset( 'Full', m, m, czero, cone, work, ldq )
341 CALL zherk( 'Upper', 'Conjugate transpose', m, m, -one, u, ldu,
342 $ one, work, ldu )
343*
344* Compute norm( I - U'*U ) / ( M * ULP ) .
345*
346 resid = zlanhe( '1', 'Upper', m, work, ldu, rwork )
347 result( 3 ) = ( resid / dble( max( 1, m ) ) ) / ulp
348*
349* Compute I - V'*V
350*
351 CALL zlaset( 'Full', p, p, czero, cone, work, ldv )
352 CALL zherk( 'Upper', 'Conjugate transpose', p, p, -one, v, ldv,
353 $ one, work, ldv )
354*
355* Compute norm( I - V'*V ) / ( P * ULP ) .
356*
357 resid = zlanhe( '1', 'Upper', p, work, ldv, rwork )
358 result( 4 ) = ( resid / dble( max( 1, p ) ) ) / ulp
359*
360* Compute I - Q'*Q
361*
362 CALL zlaset( 'Full', n, n, czero, cone, work, ldq )
363 CALL zherk( 'Upper', 'Conjugate transpose', n, n, -one, q, ldq,
364 $ one, work, ldq )
365*
366* Compute norm( I - Q'*Q ) / ( N * ULP ) .
367*
368 resid = zlanhe( '1', 'Upper', n, work, ldq, rwork )
369 result( 5 ) = ( resid / dble( max( 1, n ) ) ) / ulp
370*
371* Check sorting
372*
373 CALL dcopy( n, alpha, 1, rwork, 1 )
374 DO 110 i = k + 1, min( k+l, m )
375 j = iwork( i )
376 IF( i.NE.j ) THEN
377 temp = rwork( i )
378 rwork( i ) = rwork( j )
379 rwork( j ) = temp
380 END IF
381 110 CONTINUE
382*
383 result( 6 ) = zero
384 DO 120 i = k + 1, min( k+l, m ) - 1
385 IF( rwork( i ).LT.rwork( i+1 ) )
386 $ result( 6 ) = ulpinv
387 120 CONTINUE
388*
389 RETURN
390*
391* End of ZGSVTS3
392*

◆ zhbt21()

subroutine zhbt21 ( character uplo,
integer n,
integer ka,
integer ks,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision, dimension( 2 ) result )

ZHBT21

Purpose:
!>
!> ZHBT21  generally checks a decomposition of the form
!>
!>         A = U S U**H
!>
!> where **H means conjugate transpose, A is hermitian banded, U is
!> unitary, and S is diagonal (if KS=0) or symmetric
!> tridiagonal (if KS=1).
!>
!> Specifically:
!>
!>         RESULT(1) = | A - U S U**H | / ( |A| n ulp ) and
!>         RESULT(2) = | I - U U**H | / ( n ulp )
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER
!>          If UPLO='U', the upper triangle of A and V will be used and
!>          the (strictly) lower triangle will not be referenced.
!>          If UPLO='L', the lower triangle of A and V will be used and
!>          the (strictly) upper triangle will not be referenced.
!>
[in]N
!>          N is INTEGER
!>          The size of the matrix.  If it is zero, ZHBT21 does nothing.
!>          It must be at least zero.
!>
[in]KA
!>          KA is INTEGER
!>          The bandwidth of the matrix A.  It must be at least zero.  If
!>          it is larger than N-1, then max( 0, N-1 ) will be used.
!>
[in]KS
!>          KS is INTEGER
!>          The bandwidth of the matrix S.  It may only be zero or one.
!>          If zero, then S is diagonal, and E is not referenced.  If
!>          one, then S is symmetric tri-diagonal.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          The original (unfactored) matrix.  It is assumed to be
!>          hermitian, and only the upper (UPLO='U') or only the lower
!>          (UPLO='L') will be referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least min( KA, N-1 ).
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix S.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix S.
!>          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
!>          (3,2) element, etc.
!>          Not referenced if KS=0.
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU, N)
!>          The unitary matrix in the decomposition, expressed as a
!>          dense matrix (i.e., not as a product of Householder
!>          transformations, Givens transformations, etc.)
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  LDU must be at least N and
!>          at least 1.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N**2)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file zhbt21.f.

152*
153* -- LAPACK test routine --
154* -- LAPACK is a software package provided by Univ. of Tennessee, --
155* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
156*
157* .. Scalar Arguments ..
158 CHARACTER UPLO
159 INTEGER KA, KS, LDA, LDU, N
160* ..
161* .. Array Arguments ..
162 DOUBLE PRECISION D( * ), E( * ), RESULT( 2 ), RWORK( * )
163 COMPLEX*16 A( LDA, * ), U( LDU, * ), WORK( * )
164* ..
165*
166* =====================================================================
167*
168* .. Parameters ..
169 COMPLEX*16 CZERO, CONE
170 parameter( czero = ( 0.0d+0, 0.0d+0 ),
171 $ cone = ( 1.0d+0, 0.0d+0 ) )
172 DOUBLE PRECISION ZERO, ONE
173 parameter( zero = 0.0d+0, one = 1.0d+0 )
174* ..
175* .. Local Scalars ..
176 LOGICAL LOWER
177 CHARACTER CUPLO
178 INTEGER IKA, J, JC, JR
179 DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
180* ..
181* .. External Functions ..
182 LOGICAL LSAME
183 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHB, ZLANHP
184 EXTERNAL lsame, dlamch, zlange, zlanhb, zlanhp
185* ..
186* .. External Subroutines ..
187 EXTERNAL zgemm, zhpr, zhpr2
188* ..
189* .. Intrinsic Functions ..
190 INTRINSIC dble, dcmplx, max, min
191* ..
192* .. Executable Statements ..
193*
194* Constants
195*
196 result( 1 ) = zero
197 result( 2 ) = zero
198 IF( n.LE.0 )
199 $ RETURN
200*
201 ika = max( 0, min( n-1, ka ) )
202*
203 IF( lsame( uplo, 'U' ) ) THEN
204 lower = .false.
205 cuplo = 'U'
206 ELSE
207 lower = .true.
208 cuplo = 'L'
209 END IF
210*
211 unfl = dlamch( 'Safe minimum' )
212 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
213*
214* Some Error Checks
215*
216* Do Test 1
217*
218* Norm of A:
219*
220 anorm = max( zlanhb( '1', cuplo, n, ika, a, lda, rwork ), unfl )
221*
222* Compute error matrix: Error = A - U S U**H
223*
224* Copy A from SB to SP storage format.
225*
226 j = 0
227 DO 50 jc = 1, n
228 IF( lower ) THEN
229 DO 10 jr = 1, min( ika+1, n+1-jc )
230 j = j + 1
231 work( j ) = a( jr, jc )
232 10 CONTINUE
233 DO 20 jr = ika + 2, n + 1 - jc
234 j = j + 1
235 work( j ) = zero
236 20 CONTINUE
237 ELSE
238 DO 30 jr = ika + 2, jc
239 j = j + 1
240 work( j ) = zero
241 30 CONTINUE
242 DO 40 jr = min( ika, jc-1 ), 0, -1
243 j = j + 1
244 work( j ) = a( ika+1-jr, jc )
245 40 CONTINUE
246 END IF
247 50 CONTINUE
248*
249 DO 60 j = 1, n
250 CALL zhpr( cuplo, n, -d( j ), u( 1, j ), 1, work )
251 60 CONTINUE
252*
253 IF( n.GT.1 .AND. ks.EQ.1 ) THEN
254 DO 70 j = 1, n - 1
255 CALL zhpr2( cuplo, n, -dcmplx( e( j ) ), u( 1, j ), 1,
256 $ u( 1, j+1 ), 1, work )
257 70 CONTINUE
258 END IF
259 wnorm = zlanhp( '1', cuplo, n, work, rwork )
260*
261 IF( anorm.GT.wnorm ) THEN
262 result( 1 ) = ( wnorm / anorm ) / ( n*ulp )
263 ELSE
264 IF( anorm.LT.one ) THEN
265 result( 1 ) = ( min( wnorm, n*anorm ) / anorm ) / ( n*ulp )
266 ELSE
267 result( 1 ) = min( wnorm / anorm, dble( n ) ) / ( n*ulp )
268 END IF
269 END IF
270*
271* Do Test 2
272*
273* Compute U U**H - I
274*
275 CALL zgemm( 'N', 'C', n, n, n, cone, u, ldu, u, ldu, czero, work,
276 $ n )
277*
278 DO 80 j = 1, n
279 work( ( n+1 )*( j-1 )+1 ) = work( ( n+1 )*( j-1 )+1 ) - cone
280 80 CONTINUE
281*
282 result( 2 ) = min( zlange( '1', n, n, work, n, rwork ),
283 $ dble( n ) ) / ( n*ulp )
284*
285 RETURN
286*
287* End of ZHBT21
288*
zlanhb
double precision function zlanhb(norm, uplo, n, k, ab, ldab, work)
ZLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanhb.f:132
zlanhp
double precision function zlanhp(norm, uplo, n, ap, work)
ZLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanhp.f:117
zhpr
subroutine zhpr(uplo, n, alpha, x, incx, ap)
ZHPR
Definition zhpr.f:130
zhpr2
subroutine zhpr2(uplo, n, alpha, x, incx, y, incy, ap)
ZHPR2
Definition zhpr2.f:145

◆ zhet21()

subroutine zhet21 ( integer itype,
character uplo,
integer n,
integer kband,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldv, * ) v,
integer ldv,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision, dimension( 2 ) result )

ZHET21

Purpose:
!>
!> ZHET21 generally checks a decomposition of the form
!>
!>    A = U S U**H
!>
!> where **H means conjugate transpose, A is hermitian, U is unitary, and
!> S is diagonal (if KBAND=0) or (real) symmetric tridiagonal (if
!> KBAND=1).
!>
!> If ITYPE=1, then U is represented as a dense matrix; otherwise U is
!> expressed as a product of Householder transformations, whose vectors
!> are stored in the array  and whose scaling constants are in .
!> We shall use the letter  to refer to the product of Householder
!> transformations (which should be equal to U).
!>
!> Specifically, if ITYPE=1, then:
!>
!>    RESULT(1) = | A - U S U**H | / ( |A| n ulp ) and
!>    RESULT(2) = | I - U U**H | / ( n ulp )
!>
!> If ITYPE=2, then:
!>
!>    RESULT(1) = | A - V S V**H | / ( |A| n ulp )
!>
!> If ITYPE=3, then:
!>
!>    RESULT(1) = | I - U V**H | / ( n ulp )
!>
!> For ITYPE > 1, the transformation U is expressed as a product
!> V = H(1)...H(n-2),  where H(j) = I  -  tau(j) v(j) v(j)**H and each
!> vector v(j) has its first j elements 0 and the remaining n-j elements
!> stored in V(j+1:n,j).
!>
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          Specifies the type of tests to be performed.
!>          1: U expressed as a dense unitary matrix:
!>             RESULT(1) = | A - U S U**H | / ( |A| n ulp ) and
!>             RESULT(2) = | I - U U**H | / ( n ulp )
!>
!>          2: U expressed as a product V of Housholder transformations:
!>             RESULT(1) = | A - V S V**H | / ( |A| n ulp )
!>
!>          3: U expressed both as a dense unitary matrix and
!>             as a product of Housholder transformations:
!>             RESULT(1) = | I - U V**H | / ( n ulp )
!>
[in]UPLO
!>          UPLO is CHARACTER
!>          If UPLO='U', the upper triangle of A and V will be used and
!>          the (strictly) lower triangle will not be referenced.
!>          If UPLO='L', the lower triangle of A and V will be used and
!>          the (strictly) upper triangle will not be referenced.
!>
[in]N
!>          N is INTEGER
!>          The size of the matrix.  If it is zero, ZHET21 does nothing.
!>          It must be at least zero.
!>
[in]KBAND
!>          KBAND is INTEGER
!>          The bandwidth of the matrix.  It may only be zero or one.
!>          If zero, then S is diagonal, and E is not referenced.  If
!>          one, then S is symmetric tri-diagonal.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          The original (unfactored) matrix.  It is assumed to be
!>          hermitian, and only the upper (UPLO='U') or only the lower
!>          (UPLO='L') will be referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least N.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix.
!>          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
!>          (3,2) element, etc.
!>          Not referenced if KBAND=0.
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU, N)
!>          If ITYPE=1 or 3, this contains the unitary matrix in
!>          the decomposition, expressed as a dense matrix.  If ITYPE=2,
!>          then it is not referenced.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  LDU must be at least N and
!>          at least 1.
!>
[in]V
!>          V is COMPLEX*16 array, dimension (LDV, N)
!>          If ITYPE=2 or 3, the columns of this array contain the
!>          Householder vectors used to describe the unitary matrix
!>          in the decomposition.  If UPLO='L', then the vectors are in
!>          the lower triangle, if UPLO='U', then in the upper
!>          triangle.
!>          *NOTE* If ITYPE=2 or 3, V is modified and restored.  The
!>          subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
!>          is set to one, and later reset to its original value, during
!>          the course of the calculation.
!>          If ITYPE=1, then it is neither referenced nor modified.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of V.  LDV must be at least N and
!>          at least 1.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (N)
!>          If ITYPE >= 2, then TAU(j) is the scalar factor of
!>          v(j) v(j)**H in the Householder transformation H(j) of
!>          the product  U = H(1)...H(n-2)
!>          If ITYPE < 2, then TAU is not referenced.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N**2)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.  RESULT(2) is modified only
!>          if ITYPE=1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 212 of file zhet21.f.

214*
215* -- LAPACK test routine --
216* -- LAPACK is a software package provided by Univ. of Tennessee, --
217* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
218*
219* .. Scalar Arguments ..
220 CHARACTER UPLO
221 INTEGER ITYPE, KBAND, LDA, LDU, LDV, N
222* ..
223* .. Array Arguments ..
224 DOUBLE PRECISION D( * ), E( * ), RESULT( 2 ), RWORK( * )
225 COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ),
226 $ V( LDV, * ), WORK( * )
227* ..
228*
229* =====================================================================
230*
231* .. Parameters ..
232 DOUBLE PRECISION ZERO, ONE, TEN
233 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 10.0d+0 )
234 COMPLEX*16 CZERO, CONE
235 parameter( czero = ( 0.0d+0, 0.0d+0 ),
236 $ cone = ( 1.0d+0, 0.0d+0 ) )
237* ..
238* .. Local Scalars ..
239 LOGICAL LOWER
240 CHARACTER CUPLO
241 INTEGER IINFO, J, JCOL, JR, JROW
242 DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
243 COMPLEX*16 VSAVE
244* ..
245* .. External Functions ..
246 LOGICAL LSAME
247 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHE
248 EXTERNAL lsame, dlamch, zlange, zlanhe
249* ..
250* .. External Subroutines ..
251 EXTERNAL zgemm, zher, zher2, zlacpy, zlarfy, zlaset,
252 $ zunm2l, zunm2r
253* ..
254* .. Intrinsic Functions ..
255 INTRINSIC dble, dcmplx, max, min
256* ..
257* .. Executable Statements ..
258*
259 result( 1 ) = zero
260 IF( itype.EQ.1 )
261 $ result( 2 ) = zero
262 IF( n.LE.0 )
263 $ RETURN
264*
265 IF( lsame( uplo, 'U' ) ) THEN
266 lower = .false.
267 cuplo = 'U'
268 ELSE
269 lower = .true.
270 cuplo = 'L'
271 END IF
272*
273 unfl = dlamch( 'Safe minimum' )
274 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
275*
276* Some Error Checks
277*
278 IF( itype.LT.1 .OR. itype.GT.3 ) THEN
279 result( 1 ) = ten / ulp
280 RETURN
281 END IF
282*
283* Do Test 1
284*
285* Norm of A:
286*
287 IF( itype.EQ.3 ) THEN
288 anorm = one
289 ELSE
290 anorm = max( zlanhe( '1', cuplo, n, a, lda, rwork ), unfl )
291 END IF
292*
293* Compute error matrix:
294*
295 IF( itype.EQ.1 ) THEN
296*
297* ITYPE=1: error = A - U S U**H
298*
299 CALL zlaset( 'Full', n, n, czero, czero, work, n )
300 CALL zlacpy( cuplo, n, n, a, lda, work, n )
301*
302 DO 10 j = 1, n
303 CALL zher( cuplo, n, -d( j ), u( 1, j ), 1, work, n )
304 10 CONTINUE
305*
306 IF( n.GT.1 .AND. kband.EQ.1 ) THEN
307 DO 20 j = 2, n - 1
308 CALL zher2( cuplo, n, -dcmplx( e( j ) ), u( 1, j ), 1,
309 $ u( 1, j-1 ), 1, work, n )
310 20 CONTINUE
311 END IF
312 wnorm = zlanhe( '1', cuplo, n, work, n, rwork )
313*
314 ELSE IF( itype.EQ.2 ) THEN
315*
316* ITYPE=2: error = V S V**H - A
317*
318 CALL zlaset( 'Full', n, n, czero, czero, work, n )
319*
320 IF( lower ) THEN
321 work( n**2 ) = d( n )
322 DO 40 j = n - 1, 1, -1
323 IF( kband.EQ.1 ) THEN
324 work( ( n+1 )*( j-1 )+2 ) = ( cone-tau( j ) )*e( j )
325 DO 30 jr = j + 2, n
326 work( ( j-1 )*n+jr ) = -tau( j )*e( j )*v( jr, j )
327 30 CONTINUE
328 END IF
329*
330 vsave = v( j+1, j )
331 v( j+1, j ) = one
332 CALL zlarfy( 'L', n-j, v( j+1, j ), 1, tau( j ),
333 $ work( ( n+1 )*j+1 ), n, work( n**2+1 ) )
334 v( j+1, j ) = vsave
335 work( ( n+1 )*( j-1 )+1 ) = d( j )
336 40 CONTINUE
337 ELSE
338 work( 1 ) = d( 1 )
339 DO 60 j = 1, n - 1
340 IF( kband.EQ.1 ) THEN
341 work( ( n+1 )*j ) = ( cone-tau( j ) )*e( j )
342 DO 50 jr = 1, j - 1
343 work( j*n+jr ) = -tau( j )*e( j )*v( jr, j+1 )
344 50 CONTINUE
345 END IF
346*
347 vsave = v( j, j+1 )
348 v( j, j+1 ) = one
349 CALL zlarfy( 'U', j, v( 1, j+1 ), 1, tau( j ), work, n,
350 $ work( n**2+1 ) )
351 v( j, j+1 ) = vsave
352 work( ( n+1 )*j+1 ) = d( j+1 )
353 60 CONTINUE
354 END IF
355*
356 DO 90 jcol = 1, n
357 IF( lower ) THEN
358 DO 70 jrow = jcol, n
359 work( jrow+n*( jcol-1 ) ) = work( jrow+n*( jcol-1 ) )
360 $ - a( jrow, jcol )
361 70 CONTINUE
362 ELSE
363 DO 80 jrow = 1, jcol
364 work( jrow+n*( jcol-1 ) ) = work( jrow+n*( jcol-1 ) )
365 $ - a( jrow, jcol )
366 80 CONTINUE
367 END IF
368 90 CONTINUE
369 wnorm = zlanhe( '1', cuplo, n, work, n, rwork )
370*
371 ELSE IF( itype.EQ.3 ) THEN
372*
373* ITYPE=3: error = U V**H - I
374*
375 IF( n.LT.2 )
376 $ RETURN
377 CALL zlacpy( ' ', n, n, u, ldu, work, n )
378 IF( lower ) THEN
379 CALL zunm2r( 'R', 'C', n, n-1, n-1, v( 2, 1 ), ldv, tau,
380 $ work( n+1 ), n, work( n**2+1 ), iinfo )
381 ELSE
382 CALL zunm2l( 'R', 'C', n, n-1, n-1, v( 1, 2 ), ldv, tau,
383 $ work, n, work( n**2+1 ), iinfo )
384 END IF
385 IF( iinfo.NE.0 ) THEN
386 result( 1 ) = ten / ulp
387 RETURN
388 END IF
389*
390 DO 100 j = 1, n
391 work( ( n+1 )*( j-1 )+1 ) = work( ( n+1 )*( j-1 )+1 ) - cone
392 100 CONTINUE
393*
394 wnorm = zlange( '1', n, n, work, n, rwork )
395 END IF
396*
397 IF( anorm.GT.wnorm ) THEN
398 result( 1 ) = ( wnorm / anorm ) / ( n*ulp )
399 ELSE
400 IF( anorm.LT.one ) THEN
401 result( 1 ) = ( min( wnorm, n*anorm ) / anorm ) / ( n*ulp )
402 ELSE
403 result( 1 ) = min( wnorm / anorm, dble( n ) ) / ( n*ulp )
404 END IF
405 END IF
406*
407* Do Test 2
408*
409* Compute U U**H - I
410*
411 IF( itype.EQ.1 ) THEN
412 CALL zgemm( 'N', 'C', n, n, n, cone, u, ldu, u, ldu, czero,
413 $ work, n )
414*
415 DO 110 j = 1, n
416 work( ( n+1 )*( j-1 )+1 ) = work( ( n+1 )*( j-1 )+1 ) - cone
417 110 CONTINUE
418*
419 result( 2 ) = min( zlange( '1', n, n, work, n, rwork ),
420 $ dble( n ) ) / ( n*ulp )
421 END IF
422*
423 RETURN
424*
425* End of ZHET21
426*
zlarfy
subroutine zlarfy(uplo, n, v, incv, tau, c, ldc, work)
ZLARFY
Definition zlarfy.f:108
zunm2l
subroutine zunm2l(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf...
Definition zunm2l.f:159
zher2
subroutine zher2(uplo, n, alpha, x, incx, y, incy, a, lda)
ZHER2
Definition zher2.f:150
zher
subroutine zher(uplo, n, alpha, x, incx, a, lda)
ZHER
Definition zher.f:135

◆ zhet22()

subroutine zhet22 ( integer itype,
character uplo,
integer n,
integer m,
integer kband,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldv, * ) v,
integer ldv,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision, dimension( 2 ) result )

ZHET22

Purpose:
!>
!>      ZHET22  generally checks a decomposition of the form
!>
!>              A U = U S
!>
!>      where A is complex Hermitian, the columns of U are orthonormal,
!>      and S is diagonal (if KBAND=0) or symmetric tridiagonal (if
!>      KBAND=1).  If ITYPE=1, then U is represented as a dense matrix,
!>      otherwise the U is expressed as a product of Householder
!>      transformations, whose vectors are stored in the array  and
!>      whose scaling constants are in  
 we shall use the letter
!>       to refer to the product of Householder transformations
!>      (which should be equal to U).
!>
!>      Specifically, if ITYPE=1, then:
!>
!>              RESULT(1) = | U**H A U - S | / ( |A| m ulp ) and
!>              RESULT(2) = | I - U**H U | / ( m ulp )
!> 
!>  ITYPE   INTEGER
!>          Specifies the type of tests to be performed.
!>          1: U expressed as a dense orthogonal matrix:
!>             RESULT(1) = | A - U S U**H | / ( |A| n ulp )   *and
!>             RESULT(2) = | I - U U**H | / ( n ulp )
!>
!>  UPLO    CHARACTER
!>          If UPLO='U', the upper triangle of A will be used and the
!>          (strictly) lower triangle will not be referenced.  If
!>          UPLO='L', the lower triangle of A will be used and the
!>          (strictly) upper triangle will not be referenced.
!>          Not modified.
!>
!>  N       INTEGER
!>          The size of the matrix.  If it is zero, ZHET22 does nothing.
!>          It must be at least zero.
!>          Not modified.
!>
!>  M       INTEGER
!>          The number of columns of U.  If it is zero, ZHET22 does
!>          nothing.  It must be at least zero.
!>          Not modified.
!>
!>  KBAND   INTEGER
!>          The bandwidth of the matrix.  It may only be zero or one.
!>          If zero, then S is diagonal, and E is not referenced.  If
!>          one, then S is symmetric tri-diagonal.
!>          Not modified.
!>
!>  A       COMPLEX*16 array, dimension (LDA , N)
!>          The original (unfactored) matrix.  It is assumed to be
!>          symmetric, and only the upper (UPLO='U') or only the lower
!>          (UPLO='L') will be referenced.
!>          Not modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least N.
!>          Not modified.
!>
!>  D       DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>          Not modified.
!>
!>  E       DOUBLE PRECISION array, dimension (N)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix.
!>          E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc.
!>          Not referenced if KBAND=0.
!>          Not modified.
!>
!>  U       COMPLEX*16 array, dimension (LDU, N)
!>          If ITYPE=1, this contains the orthogonal matrix in
!>          the decomposition, expressed as a dense matrix.
!>          Not modified.
!>
!>  LDU     INTEGER
!>          The leading dimension of U.  LDU must be at least N and
!>          at least 1.
!>          Not modified.
!>
!>  V       COMPLEX*16 array, dimension (LDV, N)
!>          If ITYPE=2 or 3, the lower triangle of this array contains
!>          the Householder vectors used to describe the orthogonal
!>          matrix in the decomposition.  If ITYPE=1, then it is not
!>          referenced.
!>          Not modified.
!>
!>  LDV     INTEGER
!>          The leading dimension of V.  LDV must be at least N and
!>          at least 1.
!>          Not modified.
!>
!>  TAU     COMPLEX*16 array, dimension (N)
!>          If ITYPE >= 2, then TAU(j) is the scalar factor of
!>          v(j) v(j)**H in the Householder transformation H(j) of
!>          the product  U = H(1)...H(n-2)
!>          If ITYPE < 2, then TAU is not referenced.
!>          Not modified.
!>
!>  WORK    COMPLEX*16 array, dimension (2*N**2)
!>          Workspace.
!>          Modified.
!>
!>  RWORK   DOUBLE PRECISION array, dimension (N)
!>          Workspace.
!>          Modified.
!>
!>  RESULT  DOUBLE PRECISION array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.  RESULT(2) is modified only
!>          if LDU is at least N.
!>          Modified.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 159 of file zhet22.f.

161*
162* -- LAPACK test routine --
163* -- LAPACK is a software package provided by Univ. of Tennessee, --
164* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
165*
166* .. Scalar Arguments ..
167 CHARACTER UPLO
168 INTEGER ITYPE, KBAND, LDA, LDU, LDV, M, N
169* ..
170* .. Array Arguments ..
171 DOUBLE PRECISION D( * ), E( * ), RESULT( 2 ), RWORK( * )
172 COMPLEX*16 A( LDA, * ), TAU( * ), U( LDU, * ),
173 $ V( LDV, * ), WORK( * )
174* ..
175*
176* =====================================================================
177*
178* .. Parameters ..
179 DOUBLE PRECISION ZERO, ONE
180 parameter( zero = 0.0d0, one = 1.0d0 )
181 COMPLEX*16 CZERO, CONE
182 parameter( czero = ( 0.0d0, 0.0d0 ),
183 $ cone = ( 1.0d0, 0.0d0 ) )
184* ..
185* .. Local Scalars ..
186 INTEGER J, JJ, JJ1, JJ2, NN, NNP1
187 DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
188* ..
189* .. External Functions ..
190 DOUBLE PRECISION DLAMCH, ZLANHE
191 EXTERNAL dlamch, zlanhe
192* ..
193* .. External Subroutines ..
194 EXTERNAL zgemm, zhemm, zunt01
195* ..
196* .. Intrinsic Functions ..
197 INTRINSIC dble, max, min
198* ..
199* .. Executable Statements ..
200*
201 result( 1 ) = zero
202 result( 2 ) = zero
203 IF( n.LE.0 .OR. m.LE.0 )
204 $ RETURN
205*
206 unfl = dlamch( 'Safe minimum' )
207 ulp = dlamch( 'Precision' )
208*
209* Do Test 1
210*
211* Norm of A:
212*
213 anorm = max( zlanhe( '1', uplo, n, a, lda, rwork ), unfl )
214*
215* Compute error matrix:
216*
217* ITYPE=1: error = U**H A U - S
218*
219 CALL zhemm( 'L', uplo, n, m, cone, a, lda, u, ldu, czero, work,
220 $ n )
221 nn = n*n
222 nnp1 = nn + 1
223 CALL zgemm( 'C', 'N', m, m, n, cone, u, ldu, work, n, czero,
224 $ work( nnp1 ), n )
225 DO 10 j = 1, m
226 jj = nn + ( j-1 )*n + j
227 work( jj ) = work( jj ) - d( j )
228 10 CONTINUE
229 IF( kband.EQ.1 .AND. n.GT.1 ) THEN
230 DO 20 j = 2, m
231 jj1 = nn + ( j-1 )*n + j - 1
232 jj2 = nn + ( j-2 )*n + j
233 work( jj1 ) = work( jj1 ) - e( j-1 )
234 work( jj2 ) = work( jj2 ) - e( j-1 )
235 20 CONTINUE
236 END IF
237 wnorm = zlanhe( '1', uplo, m, work( nnp1 ), n, rwork )
238*
239 IF( anorm.GT.wnorm ) THEN
240 result( 1 ) = ( wnorm / anorm ) / ( m*ulp )
241 ELSE
242 IF( anorm.LT.one ) THEN
243 result( 1 ) = ( min( wnorm, m*anorm ) / anorm ) / ( m*ulp )
244 ELSE
245 result( 1 ) = min( wnorm / anorm, dble( m ) ) / ( m*ulp )
246 END IF
247 END IF
248*
249* Do Test 2
250*
251* Compute U**H U - I
252*
253 IF( itype.EQ.1 )
254 $ CALL zunt01( 'Columns', n, m, u, ldu, work, 2*n*n, rwork,
255 $ result( 2 ) )
256*
257 RETURN
258*
259* End of ZHET22
260*
zhemm
subroutine zhemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
ZHEMM
Definition zhemm.f:191

◆ zhpt21()

subroutine zhpt21 ( integer itype,
character uplo,
integer n,
integer kband,
complex*16, dimension( * ) ap,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( * ) vp,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision, dimension( 2 ) result )

ZHPT21

Purpose:
!>
!> ZHPT21  generally checks a decomposition of the form
!>
!>         A = U S U**H
!>
!> where **H means conjugate transpose, A is hermitian, U is
!> unitary, and S is diagonal (if KBAND=0) or (real) symmetric
!> tridiagonal (if KBAND=1).  If ITYPE=1, then U is represented as
!> a dense matrix, otherwise the U is expressed as a product of
!> Householder transformations, whose vectors are stored in the
!> array  and whose scaling constants are in  
 we shall
!> use the letter  to refer to the product of Householder
!> transformations (which should be equal to U).
!>
!> Specifically, if ITYPE=1, then:
!>
!>         RESULT(1) = | A - U S U**H | / ( |A| n ulp ) and
!>         RESULT(2) = | I - U U**H | / ( n ulp )
!>
!> If ITYPE=2, then:
!>
!>         RESULT(1) = | A - V S V**H | / ( |A| n ulp )
!>
!> If ITYPE=3, then:
!>
!>         RESULT(1) = | I - U V**H | / ( n ulp )
!>
!> Packed storage means that, for example, if UPLO='U', then the columns
!> of the upper triangle of A are stored one after another, so that
!> A(1,j+1) immediately follows A(j,j) in the array AP.  Similarly, if
!> UPLO='L', then the columns of the lower triangle of A are stored one
!> after another in AP, so that A(j+1,j+1) immediately follows A(n,j)
!> in the array AP.  This means that A(i,j) is stored in:
!>
!>    AP( i + j*(j-1)/2 )                 if UPLO='U'
!>
!>    AP( i + (2*n-j)*(j-1)/2 )           if UPLO='L'
!>
!> The array VP bears the same relation to the matrix V that A does to
!> AP.
!>
!> For ITYPE > 1, the transformation U is expressed as a product
!> of Householder transformations:
!>
!>    If UPLO='U', then  V = H(n-1)...H(1),  where
!>
!>        H(j) = I  -  tau(j) v(j) v(j)**H
!>
!>    and the first j-1 elements of v(j) are stored in V(1:j-1,j+1),
!>    (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ),
!>    the j-th element is 1, and the last n-j elements are 0.
!>
!>    If UPLO='L', then  V = H(1)...H(n-1),  where
!>
!>        H(j) = I  -  tau(j) v(j) v(j)**H
!>
!>    and the first j elements of v(j) are 0, the (j+1)-st is 1, and the
!>    (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e.,
!>    in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .)
!>
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          Specifies the type of tests to be performed.
!>          1: U expressed as a dense unitary matrix:
!>             RESULT(1) = | A - U S U**H | / ( |A| n ulp )   and
!>             RESULT(2) = | I - U U**H | / ( n ulp )
!>
!>          2: U expressed as a product V of Housholder transformations:
!>             RESULT(1) = | A - V S V**H | / ( |A| n ulp )
!>
!>          3: U expressed both as a dense unitary matrix and
!>             as a product of Housholder transformations:
!>             RESULT(1) = | I - U V**H | / ( n ulp )
!>
[in]UPLO
!>          UPLO is CHARACTER
!>          If UPLO='U', the upper triangle of A and V will be used and
!>          the (strictly) lower triangle will not be referenced.
!>          If UPLO='L', the lower triangle of A and V will be used and
!>          the (strictly) upper triangle will not be referenced.
!>
[in]N
!>          N is INTEGER
!>          The size of the matrix.  If it is zero, ZHPT21 does nothing.
!>          It must be at least zero.
!>
[in]KBAND
!>          KBAND is INTEGER
!>          The bandwidth of the matrix.  It may only be zero or one.
!>          If zero, then S is diagonal, and E is not referenced.  If
!>          one, then S is symmetric tri-diagonal.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The original (unfactored) matrix.  It is assumed to be
!>          hermitian, and contains the columns of just the upper
!>          triangle (UPLO='U') or only the lower triangle (UPLO='L'),
!>          packed one after another.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix.
!>          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
!>          (3,2) element, etc.
!>          Not referenced if KBAND=0.
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU, N)
!>          If ITYPE=1 or 3, this contains the unitary matrix in
!>          the decomposition, expressed as a dense matrix.  If ITYPE=2,
!>          then it is not referenced.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  LDU must be at least N and
!>          at least 1.
!>
[in]VP
!>          VP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          If ITYPE=2 or 3, the columns of this array contain the
!>          Householder vectors used to describe the unitary matrix
!>          in the decomposition, as described in purpose.
!>          *NOTE* If ITYPE=2 or 3, V is modified and restored.  The
!>          subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
!>          is set to one, and later reset to its original value, during
!>          the course of the calculation.
!>          If ITYPE=1, then it is neither referenced nor modified.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (N)
!>          If ITYPE >= 2, then TAU(j) is the scalar factor of
!>          v(j) v(j)**H in the Householder transformation H(j) of
!>          the product  U = H(1)...H(n-2)
!>          If ITYPE < 2, then TAU is not referenced.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N**2)
!>          Workspace.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>          Workspace.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.  RESULT(2) is modified only
!>          if ITYPE=1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 226 of file zhpt21.f.

228*
229* -- LAPACK test routine --
230* -- LAPACK is a software package provided by Univ. of Tennessee, --
231* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
232*
233* .. Scalar Arguments ..
234 CHARACTER UPLO
235 INTEGER ITYPE, KBAND, LDU, N
236* ..
237* .. Array Arguments ..
238 DOUBLE PRECISION D( * ), E( * ), RESULT( 2 ), RWORK( * )
239 COMPLEX*16 AP( * ), TAU( * ), U( LDU, * ), VP( * ),
240 $ WORK( * )
241* ..
242*
243* =====================================================================
244*
245* .. Parameters ..
246 DOUBLE PRECISION ZERO, ONE, TEN
247 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 10.0d+0 )
248 DOUBLE PRECISION HALF
249 parameter( half = 1.0d+0 / 2.0d+0 )
250 COMPLEX*16 CZERO, CONE
251 parameter( czero = ( 0.0d+0, 0.0d+0 ),
252 $ cone = ( 1.0d+0, 0.0d+0 ) )
253* ..
254* .. Local Scalars ..
255 LOGICAL LOWER
256 CHARACTER CUPLO
257 INTEGER IINFO, J, JP, JP1, JR, LAP
258 DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
259 COMPLEX*16 TEMP, VSAVE
260* ..
261* .. External Functions ..
262 LOGICAL LSAME
263 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHP
264 COMPLEX*16 ZDOTC
265 EXTERNAL lsame, dlamch, zlange, zlanhp, zdotc
266* ..
267* .. External Subroutines ..
268 EXTERNAL zaxpy, zcopy, zgemm, zhpmv, zhpr, zhpr2,
269 $ zlacpy, zlaset, zupmtr
270* ..
271* .. Intrinsic Functions ..
272 INTRINSIC dble, dcmplx, max, min
273* ..
274* .. Executable Statements ..
275*
276* Constants
277*
278 result( 1 ) = zero
279 IF( itype.EQ.1 )
280 $ result( 2 ) = zero
281 IF( n.LE.0 )
282 $ RETURN
283*
284 lap = ( n*( n+1 ) ) / 2
285*
286 IF( lsame( uplo, 'U' ) ) THEN
287 lower = .false.
288 cuplo = 'U'
289 ELSE
290 lower = .true.
291 cuplo = 'L'
292 END IF
293*
294 unfl = dlamch( 'Safe minimum' )
295 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
296*
297* Some Error Checks
298*
299 IF( itype.LT.1 .OR. itype.GT.3 ) THEN
300 result( 1 ) = ten / ulp
301 RETURN
302 END IF
303*
304* Do Test 1
305*
306* Norm of A:
307*
308 IF( itype.EQ.3 ) THEN
309 anorm = one
310 ELSE
311 anorm = max( zlanhp( '1', cuplo, n, ap, rwork ), unfl )
312 END IF
313*
314* Compute error matrix:
315*
316 IF( itype.EQ.1 ) THEN
317*
318* ITYPE=1: error = A - U S U**H
319*
320 CALL zlaset( 'Full', n, n, czero, czero, work, n )
321 CALL zcopy( lap, ap, 1, work, 1 )
322*
323 DO 10 j = 1, n
324 CALL zhpr( cuplo, n, -d( j ), u( 1, j ), 1, work )
325 10 CONTINUE
326*
327 IF( n.GT.1 .AND. kband.EQ.1 ) THEN
328 DO 20 j = 2, n - 1
329 CALL zhpr2( cuplo, n, -dcmplx( e( j ) ), u( 1, j ), 1,
330 $ u( 1, j-1 ), 1, work )
331 20 CONTINUE
332 END IF
333 wnorm = zlanhp( '1', cuplo, n, work, rwork )
334*
335 ELSE IF( itype.EQ.2 ) THEN
336*
337* ITYPE=2: error = V S V**H - A
338*
339 CALL zlaset( 'Full', n, n, czero, czero, work, n )
340*
341 IF( lower ) THEN
342 work( lap ) = d( n )
343 DO 40 j = n - 1, 1, -1
344 jp = ( ( 2*n-j )*( j-1 ) ) / 2
345 jp1 = jp + n - j
346 IF( kband.EQ.1 ) THEN
347 work( jp+j+1 ) = ( cone-tau( j ) )*e( j )
348 DO 30 jr = j + 2, n
349 work( jp+jr ) = -tau( j )*e( j )*vp( jp+jr )
350 30 CONTINUE
351 END IF
352*
353 IF( tau( j ).NE.czero ) THEN
354 vsave = vp( jp+j+1 )
355 vp( jp+j+1 ) = cone
356 CALL zhpmv( 'L', n-j, cone, work( jp1+j+1 ),
357 $ vp( jp+j+1 ), 1, czero, work( lap+1 ), 1 )
358 temp = -half*tau( j )*zdotc( n-j, work( lap+1 ), 1,
359 $ vp( jp+j+1 ), 1 )
360 CALL zaxpy( n-j, temp, vp( jp+j+1 ), 1, work( lap+1 ),
361 $ 1 )
362 CALL zhpr2( 'L', n-j, -tau( j ), vp( jp+j+1 ), 1,
363 $ work( lap+1 ), 1, work( jp1+j+1 ) )
364*
365 vp( jp+j+1 ) = vsave
366 END IF
367 work( jp+j ) = d( j )
368 40 CONTINUE
369 ELSE
370 work( 1 ) = d( 1 )
371 DO 60 j = 1, n - 1
372 jp = ( j*( j-1 ) ) / 2
373 jp1 = jp + j
374 IF( kband.EQ.1 ) THEN
375 work( jp1+j ) = ( cone-tau( j ) )*e( j )
376 DO 50 jr = 1, j - 1
377 work( jp1+jr ) = -tau( j )*e( j )*vp( jp1+jr )
378 50 CONTINUE
379 END IF
380*
381 IF( tau( j ).NE.czero ) THEN
382 vsave = vp( jp1+j )
383 vp( jp1+j ) = cone
384 CALL zhpmv( 'U', j, cone, work, vp( jp1+1 ), 1, czero,
385 $ work( lap+1 ), 1 )
386 temp = -half*tau( j )*zdotc( j, work( lap+1 ), 1,
387 $ vp( jp1+1 ), 1 )
388 CALL zaxpy( j, temp, vp( jp1+1 ), 1, work( lap+1 ),
389 $ 1 )
390 CALL zhpr2( 'U', j, -tau( j ), vp( jp1+1 ), 1,
391 $ work( lap+1 ), 1, work )
392 vp( jp1+j ) = vsave
393 END IF
394 work( jp1+j+1 ) = d( j+1 )
395 60 CONTINUE
396 END IF
397*
398 DO 70 j = 1, lap
399 work( j ) = work( j ) - ap( j )
400 70 CONTINUE
401 wnorm = zlanhp( '1', cuplo, n, work, rwork )
402*
403 ELSE IF( itype.EQ.3 ) THEN
404*
405* ITYPE=3: error = U V**H - I
406*
407 IF( n.LT.2 )
408 $ RETURN
409 CALL zlacpy( ' ', n, n, u, ldu, work, n )
410 CALL zupmtr( 'R', cuplo, 'C', n, n, vp, tau, work, n,
411 $ work( n**2+1 ), iinfo )
412 IF( iinfo.NE.0 ) THEN
413 result( 1 ) = ten / ulp
414 RETURN
415 END IF
416*
417 DO 80 j = 1, n
418 work( ( n+1 )*( j-1 )+1 ) = work( ( n+1 )*( j-1 )+1 ) - cone
419 80 CONTINUE
420*
421 wnorm = zlange( '1', n, n, work, n, rwork )
422 END IF
423*
424 IF( anorm.GT.wnorm ) THEN
425 result( 1 ) = ( wnorm / anorm ) / ( n*ulp )
426 ELSE
427 IF( anorm.LT.one ) THEN
428 result( 1 ) = ( min( wnorm, n*anorm ) / anorm ) / ( n*ulp )
429 ELSE
430 result( 1 ) = min( wnorm / anorm, dble( n ) ) / ( n*ulp )
431 END IF
432 END IF
433*
434* Do Test 2
435*
436* Compute U U**H - I
437*
438 IF( itype.EQ.1 ) THEN
439 CALL zgemm( 'N', 'C', n, n, n, cone, u, ldu, u, ldu, czero,
440 $ work, n )
441*
442 DO 90 j = 1, n
443 work( ( n+1 )*( j-1 )+1 ) = work( ( n+1 )*( j-1 )+1 ) - cone
444 90 CONTINUE
445*
446 result( 2 ) = min( zlange( '1', n, n, work, n, rwork ),
447 $ dble( n ) ) / ( n*ulp )
448 END IF
449*
450 RETURN
451*
452* End of ZHPT21
453*
zdotc
complex *16 function zdotc(n, zx, incx, zy, incy)
ZDOTC
Definition zdotc.f:83
zhpmv
subroutine zhpmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
ZHPMV
Definition zhpmv.f:149

◆ zhst01()

subroutine zhst01 ( integer n,
integer ilo,
integer ihi,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldh, * ) h,
integer ldh,
complex*16, dimension( ldq, * ) q,
integer ldq,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( 2 ) result )

ZHST01

Purpose:
!>
!> ZHST01 tests the reduction of a general matrix A to upper Hessenberg
!> form:  A = Q*H*Q'.  Two test ratios are computed;
!>
!> RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
!> RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
!>
!> The matrix Q is assumed to be given explicitly as it would be
!> following ZGEHRD + ZUNGHR.
!>
!> In this version, ILO and IHI are not used, but they could be used
!> to save some work if this is desired.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>
!>          A is assumed to be upper triangular in rows and columns
!>          1:ILO-1 and IHI+1:N, so Q differs from the identity only in
!>          rows and columns ILO+1:IHI.
!>
[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]H
!>          H is COMPLEX*16 array, dimension (LDH,N)
!>          The upper Hessenberg matrix H from the reduction A = Q*H*Q'
!>          as computed by ZGEHRD.  H is assumed to be zero below the
!>          first subdiagonal.
!>
[in]LDH
!>          LDH is INTEGER
!>          The leading dimension of the array H.  LDH >= max(1,N).
!>
[in]Q
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          The orthogonal matrix Q from the reduction A = Q*H*Q' as
!>          computed by ZGEHRD + ZUNGHR.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= 2*N*N.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 138 of file zhst01.f.

140*
141* -- LAPACK test 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 IHI, ILO, LDA, LDH, LDQ, LWORK, N
147* ..
148* .. Array Arguments ..
149 DOUBLE PRECISION RESULT( 2 ), RWORK( * )
150 COMPLEX*16 A( LDA, * ), H( LDH, * ), Q( LDQ, * ),
151 $ WORK( LWORK )
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 LDWORK
162 DOUBLE PRECISION ANORM, EPS, OVFL, SMLNUM, UNFL, WNORM
163* ..
164* .. External Functions ..
165 DOUBLE PRECISION DLAMCH, ZLANGE
166 EXTERNAL dlamch, zlange
167* ..
168* .. External Subroutines ..
169 EXTERNAL dlabad, zgemm, zlacpy, zunt01
170* ..
171* .. Intrinsic Functions ..
172 INTRINSIC dcmplx, max, min
173* ..
174* .. Executable Statements ..
175*
176* Quick return if possible
177*
178 IF( n.LE.0 ) THEN
179 result( 1 ) = zero
180 result( 2 ) = zero
181 RETURN
182 END IF
183*
184 unfl = dlamch( 'Safe minimum' )
185 eps = dlamch( 'Precision' )
186 ovfl = one / unfl
187 CALL dlabad( unfl, ovfl )
188 smlnum = unfl*n / eps
189*
190* Test 1: Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
191*
192* Copy A to WORK
193*
194 ldwork = max( 1, n )
195 CALL zlacpy( ' ', n, n, a, lda, work, ldwork )
196*
197* Compute Q*H
198*
199 CALL zgemm( 'No transpose', 'No transpose', n, n, n,
200 $ dcmplx( one ), q, ldq, h, ldh, dcmplx( zero ),
201 $ work( ldwork*n+1 ), ldwork )
202*
203* Compute A - Q*H*Q'
204*
205 CALL zgemm( 'No transpose', 'Conjugate transpose', n, n, n,
206 $ dcmplx( -one ), work( ldwork*n+1 ), ldwork, q, ldq,
207 $ dcmplx( one ), work, ldwork )
208*
209 anorm = max( zlange( '1', n, n, a, lda, rwork ), unfl )
210 wnorm = zlange( '1', n, n, work, ldwork, rwork )
211*
212* Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS)
213*
214 result( 1 ) = min( wnorm, anorm ) / max( smlnum, anorm*eps ) / n
215*
216* Test 2: Compute norm( I - Q'*Q ) / ( N * EPS )
217*
218 CALL zunt01( 'Columns', n, n, q, ldq, work, lwork, rwork,
219 $ result( 2 ) )
220*
221 RETURN
222*
223* End of ZHST01
224*

◆ zlarfy()

subroutine zlarfy ( character uplo,
integer n,
complex*16, dimension( * ) v,
integer incv,
complex*16 tau,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( * ) work )

ZLARFY

Purpose:
!>
!> ZLARFY applies an elementary reflector, or Householder matrix, H,
!> to an n x n Hermitian matrix C, from both the left and the right.
!>
!> H is represented in the form
!>
!>    H = I - tau * v * v'
!>
!> where  tau  is a scalar and  v  is a vector.
!>
!> If  tau  is  zero, then  H  is taken to be the unit matrix.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix C is stored.
!>          = 'U':  Upper triangle
!>          = 'L':  Lower triangle
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix C.  N >= 0.
!>
[in]V
!>          V is COMPLEX*16 array, dimension
!>                  (1 + (N-1)*abs(INCV))
!>          The vector v as described above.
!>
[in]INCV
!>          INCV is INTEGER
!>          The increment between successive elements of v.  INCV must
!>          not be zero.
!>
[in]TAU
!>          TAU is COMPLEX*16
!>          The value tau as described above.
!>
[in,out]C
!>          C is COMPLEX*16 array, dimension (LDC, N)
!>          On entry, the matrix C.
!>          On exit, C is overwritten by H * C * H'.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max( 1, N ).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file zlarfy.f.

108*
109* -- LAPACK test routine --
110* -- LAPACK is a software package provided by Univ. of Tennessee, --
111* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112*
113* .. Scalar Arguments ..
114 CHARACTER UPLO
115 INTEGER INCV, LDC, N
116 COMPLEX*16 TAU
117* ..
118* .. Array Arguments ..
119 COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
120* ..
121*
122* =====================================================================
123*
124* .. Parameters ..
125 COMPLEX*16 ONE, ZERO, HALF
126 parameter( one = ( 1.0d+0, 0.0d+0 ),
127 $ zero = ( 0.0d+0, 0.0d+0 ),
128 $ half = ( 0.5d+0, 0.0d+0 ) )
129* ..
130* .. Local Scalars ..
131 COMPLEX*16 ALPHA
132* ..
133* .. External Subroutines ..
134 EXTERNAL zaxpy, zhemv, zher2
135* ..
136* .. External Functions ..
137 COMPLEX*16 ZDOTC
138 EXTERNAL zdotc
139* ..
140* .. Executable Statements ..
141*
142 IF( tau.EQ.zero )
143 $ RETURN
144*
145* Form w:= C * v
146*
147 CALL zhemv( uplo, n, one, c, ldc, v, incv, zero, work, 1 )
148*
149 alpha = -half*tau*zdotc( n, work, 1, v, incv )
150 CALL zaxpy( n, alpha, v, incv, work, 1 )
151*
152* C := C - v * w' - w * v'
153*
154 CALL zher2( uplo, n, -tau, v, incv, work, 1, c, ldc )
155*
156 RETURN
157*
158* End of ZLARFY
159*
zhemv
subroutine zhemv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
ZHEMV
Definition zhemv.f:154

◆ zlarhs()

subroutine zlarhs ( character*3 path,
character xtype,
character uplo,
character trans,
integer m,
integer n,
integer kl,
integer ku,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer, dimension( 4 ) iseed,
integer info )

ZLARHS

Purpose:
!>
!> ZLARHS chooses a set of NRHS random solution vectors and sets
!> up the right hand sides for the linear system
!>    op(A) * X = B,
!> where op(A) = A, A**T, or A**H, depending on TRANS.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The type of the complex matrix A.  PATH may be given in any
!>          combination of upper and lower case.  Valid paths include
!>             xGE:  General m x n matrix
!>             xGB:  General banded matrix
!>             xPO:  Hermitian positive definite, 2-D storage
!>             xPP:  Hermitian positive definite packed
!>             xPB:  Hermitian positive definite banded
!>             xHE:  Hermitian indefinite, 2-D storage
!>             xHP:  Hermitian indefinite packed
!>             xHB:  Hermitian indefinite banded
!>             xSY:  Symmetric indefinite, 2-D storage
!>             xSP:  Symmetric indefinite packed
!>             xSB:  Symmetric indefinite banded
!>             xTR:  Triangular
!>             xTP:  Triangular packed
!>             xTB:  Triangular banded
!>             xQR:  General m x n matrix
!>             xLQ:  General m x n matrix
!>             xQL:  General m x n matrix
!>             xRQ:  General m x n matrix
!>          where the leading character indicates the precision.
!>
[in]XTYPE
!>          XTYPE is CHARACTER*1
!>          Specifies how the exact solution X will be determined:
!>          = 'N':  New solution; generate a random X.
!>          = 'C':  Computed; use value of X on entry.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Used only if A is symmetric or triangular; specifies whether
!>          the upper or lower triangular part of the matrix A is stored.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Used only if A is nonsymmetric; specifies the operation
!>          applied to the matrix A.
!>          = 'N':  B := A    * X  (No transpose)
!>          = 'T':  B := A**T * X  (Transpose)
!>          = 'C':  B := A**H * X  (Conjugate transpose)
!>
[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]KL
!>          KL is INTEGER
!>          Used only if A is a band matrix; specifies the number of
!>          subdiagonals of A if A is a general band matrix or if A is
!>          symmetric or triangular and UPLO = 'L'; specifies the number
!>          of superdiagonals of A if A is symmetric or triangular and
!>          UPLO = 'U'.  0 <= KL <= M-1.
!>
[in]KU
!>          KU is INTEGER
!>          Used only if A is a general band matrix or if A is
!>          triangular.
!>
!>          If PATH = xGB, specifies the number of superdiagonals of A,
!>          and 0 <= KU <= N-1.
!>
!>          If PATH = xTR, xTP, or xTB, specifies whether or not the
!>          matrix has unit diagonal:
!>          = 1:  matrix has non-unit diagonal (default)
!>          = 2:  matrix has unit diagonal
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors in the system A*X = B.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The test matrix whose type is given by PATH.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If PATH = xGB, LDA >= KL+KU+1.
!>          If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
!>          Otherwise, LDA >= max(1,M).
!>
[in,out]X
!>          X is or output) COMPLEX*16 array, dimension (LDX,NRHS)
!>          On entry, if XTYPE = 'C' (for 'Computed'), then X contains
!>          the exact solution to the system of linear equations.
!>          On exit, if XTYPE = 'N' (for 'New'), then X is initialized
!>          with random values.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  If TRANS = 'N',
!>          LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
!>
[out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vector(s) for the system of equations,
!>          computed from B = op(A) * X, where op(A) is determined by
!>          TRANS.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  If TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          The seed vector for the random number generator (used in
!>          ZLATMS).  Modified on exit.
!>
[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 206 of file zlarhs.f.

208*
209* -- LAPACK test routine --
210* -- LAPACK is a software package provided by Univ. of Tennessee, --
211* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
212*
213* .. Scalar Arguments ..
214 CHARACTER TRANS, UPLO, XTYPE
215 CHARACTER*3 PATH
216 INTEGER INFO, KL, KU, LDA, LDB, LDX, M, N, NRHS
217* ..
218* .. Array Arguments ..
219 INTEGER ISEED( 4 )
220 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
221* ..
222*
223* =====================================================================
224*
225* .. Parameters ..
226 COMPLEX*16 ONE, ZERO
227 parameter( one = ( 1.0d+0, 0.0d+0 ),
228 $ zero = ( 0.0d+0, 0.0d+0 ) )
229* ..
230* .. Local Scalars ..
231 LOGICAL BAND, GEN, NOTRAN, QRS, SYM, TRAN, TRI
232 CHARACTER C1, DIAG
233 CHARACTER*2 C2
234 INTEGER J, MB, NX
235* ..
236* .. External Functions ..
237 LOGICAL LSAME, LSAMEN
238 EXTERNAL lsame, lsamen
239* ..
240* .. External Subroutines ..
241 EXTERNAL xerbla, zgbmv, zgemm, zhbmv, zhemm, zhpmv,
242 $ zlacpy, zlarnv, zsbmv, zspmv, zsymm, ztbmv,
243 $ ztpmv, ztrmm
244* ..
245* .. Intrinsic Functions ..
246 INTRINSIC max
247* ..
248* .. Executable Statements ..
249*
250* Test the input parameters.
251*
252 info = 0
253 c1 = path( 1: 1 )
254 c2 = path( 2: 3 )
255 tran = lsame( trans, 'T' ) .OR. lsame( trans, 'C' )
256 notran = .NOT.tran
257 gen = lsame( path( 2: 2 ), 'G' )
258 qrs = lsame( path( 2: 2 ), 'Q' ) .OR. lsame( path( 3: 3 ), 'Q' )
259 sym = lsame( path( 2: 2 ), 'P' ) .OR.
260 $ lsame( path( 2: 2 ), 'S' ) .OR. lsame( path( 2: 2 ), 'H' )
261 tri = lsame( path( 2: 2 ), 'T' )
262 band = lsame( path( 3: 3 ), 'B' )
263 IF( .NOT.lsame( c1, 'Zomplex precision' ) ) THEN
264 info = -1
265 ELSE IF( .NOT.( lsame( xtype, 'N' ) .OR. lsame( xtype, 'C' ) ) )
266 $ THEN
267 info = -2
268 ELSE IF( ( sym .OR. tri ) .AND. .NOT.
269 $ ( lsame( uplo, 'U' ) .OR. lsame( uplo, 'L' ) ) ) THEN
270 info = -3
271 ELSE IF( ( gen .OR. qrs ) .AND. .NOT.
272 $ ( tran .OR. lsame( trans, 'N' ) ) ) THEN
273 info = -4
274 ELSE IF( m.LT.0 ) THEN
275 info = -5
276 ELSE IF( n.LT.0 ) THEN
277 info = -6
278 ELSE IF( band .AND. kl.LT.0 ) THEN
279 info = -7
280 ELSE IF( band .AND. ku.LT.0 ) THEN
281 info = -8
282 ELSE IF( nrhs.LT.0 ) THEN
283 info = -9
284 ELSE IF( ( .NOT.band .AND. lda.LT.max( 1, m ) ) .OR.
285 $ ( band .AND. ( sym .OR. tri ) .AND. lda.LT.kl+1 ) .OR.
286 $ ( band .AND. gen .AND. lda.LT.kl+ku+1 ) ) THEN
287 info = -11
288 ELSE IF( ( notran .AND. ldx.LT.max( 1, n ) ) .OR.
289 $ ( tran .AND. ldx.LT.max( 1, m ) ) ) THEN
290 info = -13
291 ELSE IF( ( notran .AND. ldb.LT.max( 1, m ) ) .OR.
292 $ ( tran .AND. ldb.LT.max( 1, n ) ) ) THEN
293 info = -15
294 END IF
295 IF( info.NE.0 ) THEN
296 CALL xerbla( 'ZLARHS', -info )
297 RETURN
298 END IF
299*
300* Initialize X to NRHS random vectors unless XTYPE = 'C'.
301*
302 IF( tran ) THEN
303 nx = m
304 mb = n
305 ELSE
306 nx = n
307 mb = m
308 END IF
309 IF( .NOT.lsame( xtype, 'C' ) ) THEN
310 DO 10 j = 1, nrhs
311 CALL zlarnv( 2, iseed, n, x( 1, j ) )
312 10 CONTINUE
313 END IF
314*
315* Multiply X by op(A) using an appropriate
316* matrix multiply routine.
317*
318 IF( lsamen( 2, c2, 'GE' ) .OR. lsamen( 2, c2, 'QR' ) .OR.
319 $ lsamen( 2, c2, 'LQ' ) .OR. lsamen( 2, c2, 'QL' ) .OR.
320 $ lsamen( 2, c2, 'RQ' ) ) THEN
321*
322* General matrix
323*
324 CALL zgemm( trans, 'N', mb, nrhs, nx, one, a, lda, x, ldx,
325 $ zero, b, ldb )
326*
327 ELSE IF( lsamen( 2, c2, 'PO' ) .OR. lsamen( 2, c2, 'HE' ) ) THEN
328*
329* Hermitian matrix, 2-D storage
330*
331 CALL zhemm( 'Left', uplo, n, nrhs, one, a, lda, x, ldx, zero,
332 $ b, ldb )
333*
334 ELSE IF( lsamen( 2, c2, 'SY' ) ) THEN
335*
336* Symmetric matrix, 2-D storage
337*
338 CALL zsymm( 'Left', uplo, n, nrhs, one, a, lda, x, ldx, zero,
339 $ b, ldb )
340*
341 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
342*
343* General matrix, band storage
344*
345 DO 20 j = 1, nrhs
346 CALL zgbmv( trans, m, n, kl, ku, one, a, lda, x( 1, j ), 1,
347 $ zero, b( 1, j ), 1 )
348 20 CONTINUE
349*
350 ELSE IF( lsamen( 2, c2, 'PB' ) .OR. lsamen( 2, c2, 'HB' ) ) THEN
351*
352* Hermitian matrix, band storage
353*
354 DO 30 j = 1, nrhs
355 CALL zhbmv( uplo, n, kl, one, a, lda, x( 1, j ), 1, zero,
356 $ b( 1, j ), 1 )
357 30 CONTINUE
358*
359 ELSE IF( lsamen( 2, c2, 'SB' ) ) THEN
360*
361* Symmetric matrix, band storage
362*
363 DO 40 j = 1, nrhs
364 CALL zsbmv( uplo, n, kl, one, a, lda, x( 1, j ), 1, zero,
365 $ b( 1, j ), 1 )
366 40 CONTINUE
367*
368 ELSE IF( lsamen( 2, c2, 'PP' ) .OR. lsamen( 2, c2, 'HP' ) ) THEN
369*
370* Hermitian matrix, packed storage
371*
372 DO 50 j = 1, nrhs
373 CALL zhpmv( uplo, n, one, a, x( 1, j ), 1, zero, b( 1, j ),
374 $ 1 )
375 50 CONTINUE
376*
377 ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
378*
379* Symmetric matrix, packed storage
380*
381 DO 60 j = 1, nrhs
382 CALL zspmv( uplo, n, one, a, x( 1, j ), 1, zero, b( 1, j ),
383 $ 1 )
384 60 CONTINUE
385*
386 ELSE IF( lsamen( 2, c2, 'TR' ) ) THEN
387*
388* Triangular matrix. Note that for triangular matrices,
389* KU = 1 => non-unit triangular
390* KU = 2 => unit triangular
391*
392 CALL zlacpy( 'Full', n, nrhs, x, ldx, b, ldb )
393 IF( ku.EQ.2 ) THEN
394 diag = 'U'
395 ELSE
396 diag = 'N'
397 END IF
398 CALL ztrmm( 'Left', uplo, trans, diag, n, nrhs, one, a, lda, b,
399 $ ldb )
400*
401 ELSE IF( lsamen( 2, c2, 'TP' ) ) THEN
402*
403* Triangular matrix, packed storage
404*
405 CALL zlacpy( 'Full', n, nrhs, x, ldx, b, ldb )
406 IF( ku.EQ.2 ) THEN
407 diag = 'U'
408 ELSE
409 diag = 'N'
410 END IF
411 DO 70 j = 1, nrhs
412 CALL ztpmv( uplo, trans, diag, n, a, b( 1, j ), 1 )
413 70 CONTINUE
414*
415 ELSE IF( lsamen( 2, c2, 'TB' ) ) THEN
416*
417* Triangular matrix, banded storage
418*
419 CALL zlacpy( 'Full', n, nrhs, x, ldx, b, ldb )
420 IF( ku.EQ.2 ) THEN
421 diag = 'U'
422 ELSE
423 diag = 'N'
424 END IF
425 DO 80 j = 1, nrhs
426 CALL ztbmv( uplo, trans, diag, n, kl, a, lda, b( 1, j ), 1 )
427 80 CONTINUE
428*
429 ELSE
430*
431* If none of the above, set INFO = -1 and return
432*
433 info = -1
434 CALL xerbla( 'ZLARHS', -info )
435 END IF
436*
437 RETURN
438*
439* End of ZLARHS
440*
zlarnv
subroutine zlarnv(idist, iseed, n, x)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition zlarnv.f:99
zspmv
subroutine zspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
ZSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix
Definition zspmv.f:151
zgbmv
subroutine zgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
ZGBMV
Definition zgbmv.f:187
zhbmv
subroutine zhbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
ZHBMV
Definition zhbmv.f:187
ztpmv
subroutine ztpmv(uplo, trans, diag, n, ap, x, incx)
ZTPMV
Definition ztpmv.f:142
ztbmv
subroutine ztbmv(uplo, trans, diag, n, k, a, lda, x, incx)
ZTBMV
Definition ztbmv.f:186
ztrmm
subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRMM
Definition ztrmm.f:177
zsymm
subroutine zsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
ZSYMM
Definition zsymm.f:189
zsbmv
subroutine zsbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
ZSBMV
Definition zsbmv.f:152

◆ zlatm4()

subroutine zlatm4 ( integer itype,
integer n,
integer nz1,
integer nz2,
logical rsign,
double precision amagn,
double precision rcond,
double precision triang,
integer idist,
integer, dimension( 4 ) iseed,
complex*16, dimension( lda, * ) a,
integer lda )

ZLATM4

Purpose:
!>
!> ZLATM4 generates basic square matrices, which may later be
!> multiplied by others in order to produce test matrices.  It is
!> intended mainly to be used to test the generalized eigenvalue
!> routines.
!>
!> It first generates the diagonal and (possibly) subdiagonal,
!> according to the value of ITYPE, NZ1, NZ2, RSIGN, AMAGN, and RCOND.
!> It then fills in the upper triangle with random numbers, if TRIANG is
!> non-zero.
!>
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          The  of matrix on the diagonal and sub-diagonal.
!>          If ITYPE < 0, then type abs(ITYPE) is generated and then
!>             swapped end for end (A(I,J) := A'(N-J,N-I).)  See also
!>             the description of AMAGN and RSIGN.
!>
!>          Special types:
!>          = 0:  the zero matrix.
!>          = 1:  the identity.
!>          = 2:  a transposed Jordan block.
!>          = 3:  If N is odd, then a k+1 x k+1 transposed Jordan block
!>                followed by a k x k identity block, where k=(N-1)/2.
!>                If N is even, then k=(N-2)/2, and a zero diagonal entry
!>                is tacked onto the end.
!>
!>          Diagonal types.  The diagonal consists of NZ1 zeros, then
!>             k=N-NZ1-NZ2 nonzeros.  The subdiagonal is zero.  ITYPE
!>             specifies the nonzero diagonal entries as follows:
!>          = 4:  1, ..., k
!>          = 5:  1, RCOND, ..., RCOND
!>          = 6:  1, ..., 1, RCOND
!>          = 7:  1, a, a^2, ..., a^(k-1)=RCOND
!>          = 8:  1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
!>          = 9:  random numbers chosen from (RCOND,1)
!>          = 10: random numbers with distribution IDIST (see ZLARND.)
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix.
!>
[in]NZ1
!>          NZ1 is INTEGER
!>          If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
!>          be zero.
!>
[in]NZ2
!>          NZ2 is INTEGER
!>          If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
!>          be zero.
!>
[in]RSIGN
!>          RSIGN is LOGICAL
!>          = .TRUE.:  The diagonal and subdiagonal entries will be
!>                     multiplied by random numbers of magnitude 1.
!>          = .FALSE.: The diagonal and subdiagonal entries will be
!>                     left as they are (usually non-negative real.)
!>
[in]AMAGN
!>          AMAGN is DOUBLE PRECISION
!>          The diagonal and subdiagonal entries will be multiplied by
!>          AMAGN.
!>
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          If abs(ITYPE) > 4, then the smallest diagonal entry will be
!>          RCOND.  RCOND must be between 0 and 1.
!>
[in]TRIANG
!>          TRIANG is DOUBLE PRECISION
!>          The entries above the diagonal will be random numbers with
!>          magnitude bounded by TRIANG (i.e., random numbers multiplied
!>          by TRIANG.)
!>
[in]IDIST
!>          IDIST is INTEGER
!>          On entry, DIST specifies the type of distribution to be used
!>          to generate a random matrix .
!>          = 1: real and imaginary parts each UNIFORM( 0, 1 )
!>          = 2: real and imaginary parts each UNIFORM( -1, 1 )
!>          = 3: real and imaginary parts each NORMAL( 0, 1 )
!>          = 4: complex number uniform in DISK( 0, 1 )
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator.  The values of ISEED are changed on exit, and can
!>          be used in the next call to ZLATM4 to continue the same
!>          random number sequence.
!>          Note: ISEED(4) should be odd, for the random number generator
!>          used at present.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          Array to be computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          Leading dimension of A.  Must be at least 1 and at least N.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file zlatm4.f.

171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 LOGICAL RSIGN
178 INTEGER IDIST, ITYPE, LDA, N, NZ1, NZ2
179 DOUBLE PRECISION AMAGN, RCOND, TRIANG
180* ..
181* .. Array Arguments ..
182 INTEGER ISEED( 4 )
183 COMPLEX*16 A( LDA, * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 DOUBLE PRECISION ZERO, ONE
190 parameter( zero = 0.0d+0, one = 1.0d+0 )
191 COMPLEX*16 CZERO, CONE
192 parameter( czero = ( 0.0d+0, 0.0d+0 ),
193 $ cone = ( 1.0d+0, 0.0d+0 ) )
194* ..
195* .. Local Scalars ..
196 INTEGER I, ISDB, ISDE, JC, JD, JR, K, KBEG, KEND, KLEN
197 DOUBLE PRECISION ALPHA
198 COMPLEX*16 CTEMP
199* ..
200* .. External Functions ..
201 DOUBLE PRECISION DLARAN
202 COMPLEX*16 ZLARND
203 EXTERNAL dlaran, zlarnd
204* ..
205* .. External Subroutines ..
206 EXTERNAL zlaset
207* ..
208* .. Intrinsic Functions ..
209 INTRINSIC abs, dble, dcmplx, exp, log, max, min, mod
210* ..
211* .. Executable Statements ..
212*
213 IF( n.LE.0 )
214 $ RETURN
215 CALL zlaset( 'Full', n, n, czero, czero, a, lda )
216*
217* Insure a correct ISEED
218*
219 IF( mod( iseed( 4 ), 2 ).NE.1 )
220 $ iseed( 4 ) = iseed( 4 ) + 1
221*
222* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
223* and RCOND
224*
225 IF( itype.NE.0 ) THEN
226 IF( abs( itype ).GE.4 ) THEN
227 kbeg = max( 1, min( n, nz1+1 ) )
228 kend = max( kbeg, min( n, n-nz2 ) )
229 klen = kend + 1 - kbeg
230 ELSE
231 kbeg = 1
232 kend = n
233 klen = n
234 END IF
235 isdb = 1
236 isde = 0
237 GO TO ( 10, 30, 50, 80, 100, 120, 140, 160,
238 $ 180, 200 )abs( itype )
239*
240* abs(ITYPE) = 1: Identity
241*
242 10 CONTINUE
243 DO 20 jd = 1, n
244 a( jd, jd ) = cone
245 20 CONTINUE
246 GO TO 220
247*
248* abs(ITYPE) = 2: Transposed Jordan block
249*
250 30 CONTINUE
251 DO 40 jd = 1, n - 1
252 a( jd+1, jd ) = cone
253 40 CONTINUE
254 isdb = 1
255 isde = n - 1
256 GO TO 220
257*
258* abs(ITYPE) = 3: Transposed Jordan block, followed by the
259* identity.
260*
261 50 CONTINUE
262 k = ( n-1 ) / 2
263 DO 60 jd = 1, k
264 a( jd+1, jd ) = cone
265 60 CONTINUE
266 isdb = 1
267 isde = k
268 DO 70 jd = k + 2, 2*k + 1
269 a( jd, jd ) = cone
270 70 CONTINUE
271 GO TO 220
272*
273* abs(ITYPE) = 4: 1,...,k
274*
275 80 CONTINUE
276 DO 90 jd = kbeg, kend
277 a( jd, jd ) = dcmplx( jd-nz1 )
278 90 CONTINUE
279 GO TO 220
280*
281* abs(ITYPE) = 5: One large D value:
282*
283 100 CONTINUE
284 DO 110 jd = kbeg + 1, kend
285 a( jd, jd ) = dcmplx( rcond )
286 110 CONTINUE
287 a( kbeg, kbeg ) = cone
288 GO TO 220
289*
290* abs(ITYPE) = 6: One small D value:
291*
292 120 CONTINUE
293 DO 130 jd = kbeg, kend - 1
294 a( jd, jd ) = cone
295 130 CONTINUE
296 a( kend, kend ) = dcmplx( rcond )
297 GO TO 220
298*
299* abs(ITYPE) = 7: Exponentially distributed D values:
300*
301 140 CONTINUE
302 a( kbeg, kbeg ) = cone
303 IF( klen.GT.1 ) THEN
304 alpha = rcond**( one / dble( klen-1 ) )
305 DO 150 i = 2, klen
306 a( nz1+i, nz1+i ) = dcmplx( alpha**dble( i-1 ) )
307 150 CONTINUE
308 END IF
309 GO TO 220
310*
311* abs(ITYPE) = 8: Arithmetically distributed D values:
312*
313 160 CONTINUE
314 a( kbeg, kbeg ) = cone
315 IF( klen.GT.1 ) THEN
316 alpha = ( one-rcond ) / dble( klen-1 )
317 DO 170 i = 2, klen
318 a( nz1+i, nz1+i ) = dcmplx( dble( klen-i )*alpha+rcond )
319 170 CONTINUE
320 END IF
321 GO TO 220
322*
323* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1):
324*
325 180 CONTINUE
326 alpha = log( rcond )
327 DO 190 jd = kbeg, kend
328 a( jd, jd ) = exp( alpha*dlaran( iseed ) )
329 190 CONTINUE
330 GO TO 220
331*
332* abs(ITYPE) = 10: Randomly distributed D values from DIST
333*
334 200 CONTINUE
335 DO 210 jd = kbeg, kend
336 a( jd, jd ) = zlarnd( idist, iseed )
337 210 CONTINUE
338*
339 220 CONTINUE
340*
341* Scale by AMAGN
342*
343 DO 230 jd = kbeg, kend
344 a( jd, jd ) = amagn*dble( a( jd, jd ) )
345 230 CONTINUE
346 DO 240 jd = isdb, isde
347 a( jd+1, jd ) = amagn*dble( a( jd+1, jd ) )
348 240 CONTINUE
349*
350* If RSIGN = .TRUE., assign random signs to diagonal and
351* subdiagonal
352*
353 IF( rsign ) THEN
354 DO 250 jd = kbeg, kend
355 IF( dble( a( jd, jd ) ).NE.zero ) THEN
356 ctemp = zlarnd( 3, iseed )
357 ctemp = ctemp / abs( ctemp )
358 a( jd, jd ) = ctemp*dble( a( jd, jd ) )
359 END IF
360 250 CONTINUE
361 DO 260 jd = isdb, isde
362 IF( dble( a( jd+1, jd ) ).NE.zero ) THEN
363 ctemp = zlarnd( 3, iseed )
364 ctemp = ctemp / abs( ctemp )
365 a( jd+1, jd ) = ctemp*dble( a( jd+1, jd ) )
366 END IF
367 260 CONTINUE
368 END IF
369*
370* Reverse if ITYPE < 0
371*
372 IF( itype.LT.0 ) THEN
373 DO 270 jd = kbeg, ( kbeg+kend-1 ) / 2
374 ctemp = a( jd, jd )
375 a( jd, jd ) = a( kbeg+kend-jd, kbeg+kend-jd )
376 a( kbeg+kend-jd, kbeg+kend-jd ) = ctemp
377 270 CONTINUE
378 DO 280 jd = 1, ( n-1 ) / 2
379 ctemp = a( jd+1, jd )
380 a( jd+1, jd ) = a( n+1-jd, n-jd )
381 a( n+1-jd, n-jd ) = ctemp
382 280 CONTINUE
383 END IF
384*
385 END IF
386*
387* Fill in upper triangle
388*
389 IF( triang.NE.zero ) THEN
390 DO 300 jc = 2, n
391 DO 290 jr = 1, jc - 1
392 a( jr, jc ) = triang*zlarnd( idist, iseed )
393 290 CONTINUE
394 300 CONTINUE
395 END IF
396*
397 RETURN
398*
399* End of ZLATM4
400*

◆ zlctes()

logical function zlctes ( complex*16 z,
complex*16 d )

ZLCTES

Purpose:
!>
!> ZLCTES returns .TRUE. if the eigenvalue Z/D is to be selected
!> (specifically, in this subroutine, if the real part of the
!> eigenvalue is negative), and otherwise it returns .FALSE..
!>
!> It is used by the test routine ZDRGES to test whether the driver
!> routine ZGGES successfully sorts eigenvalues.
!>
Parameters
[in]Z
!>          Z is COMPLEX*16
!>          The numerator part of a complex eigenvalue Z/D.
!>
[in]D
!>          D is COMPLEX*16
!>          The denominator part of a complex eigenvalue Z/D.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 57 of file zlctes.f.

58*
59* -- LAPACK test routine --
60* -- LAPACK is a software package provided by Univ. of Tennessee, --
61* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
62*
63* .. Scalar Arguments ..
64 COMPLEX*16 D, Z
65* ..
66*
67* =====================================================================
68*
69* .. Parameters ..
70*
71 DOUBLE PRECISION ZERO, ONE
72 parameter( zero = 0.0d+0, one = 1.0d+0 )
73 COMPLEX*16 CZERO
74 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
75* ..
76* .. Local Scalars ..
77 DOUBLE PRECISION ZMAX
78* ..
79* .. Intrinsic Functions ..
80 INTRINSIC abs, dble, dimag, max, sign
81* ..
82* .. Executable Statements ..
83*
84 IF( d.EQ.czero ) THEN
85 zlctes = ( dble( z ).LT.zero )
86 ELSE
87 IF( dble( z ).EQ.zero .OR. dble( d ).EQ.zero ) THEN
88 zlctes = ( sign( one, dimag( z ) ).NE.
89 $ sign( one, dimag( d ) ) )
90 ELSE IF( dimag( z ).EQ.zero .OR. dimag( d ).EQ.zero ) THEN
91 zlctes = ( sign( one, dble( z ) ).NE.
92 $ sign( one, dble( d ) ) )
93 ELSE
94 zmax = max( abs( dble( z ) ), abs( dimag( z ) ) )
95 zlctes = ( ( dble( z ) / zmax )*dble( d )+
96 $ ( dimag( z ) / zmax )*dimag( d ).LT.zero )
97 END IF
98 END IF
99*
100 RETURN
101*
102* End of ZLCTES
103*

◆ zlctsx()

logical function zlctsx ( complex*16 alpha,
complex*16 beta )

ZLCTSX

Purpose:
!>
!> This function is used to determine what eigenvalues will be
!> selected.  If this is part of the test driver ZDRGSX, do not
!> change the code UNLESS you are testing input examples and not
!> using the built-in examples.
!>
Parameters
[in]ALPHA
!>          ALPHA is COMPLEX*16
!>
[in]BETA
!>          BETA is COMPLEX*16
!>
!>          parameters to decide whether the pair (ALPHA, BETA) is
!>          selected.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 56 of file zlctsx.f.

57*
58* -- LAPACK test routine --
59* -- LAPACK is a software package provided by Univ. of Tennessee, --
60* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
61*
62* .. Scalar Arguments ..
63 COMPLEX*16 ALPHA, BETA
64* ..
65*
66* =====================================================================
67*
68* .. Parameters ..
69* DOUBLE PRECISION ZERO
70* PARAMETER ( ZERO = 0.0E+0 )
71* COMPLEX*16 CZERO
72* PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
73* ..
74* .. Scalars in Common ..
75 LOGICAL FS
76 INTEGER I, M, MPLUSN, N
77* ..
78* .. Common blocks ..
79 COMMON / mn / m, n, mplusn, i, fs
80* ..
81* .. Save statement ..
82 SAVE
83* ..
84* .. Executable Statements ..
85*
86 IF( fs ) THEN
87 i = i + 1
88 IF( i.LE.m ) THEN
89 zlctsx = .false.
90 ELSE
91 zlctsx = .true.
92 END IF
93 IF( i.EQ.mplusn ) THEN
94 fs = .false.
95 i = 0
96 END IF
97 ELSE
98 i = i + 1
99 IF( i.LE.n ) THEN
100 zlctsx = .true.
101 ELSE
102 zlctsx = .false.
103 END IF
104 IF( i.EQ.mplusn ) THEN
105 fs = .true.
106 i = 0
107 END IF
108 END IF
109*
110* IF( BETA.EQ.CZERO ) THEN
111* ZLCTSX = ( DBLE( ALPHA ).GT.ZERO )
112* ELSE
113* ZLCTSX = ( DBLE( ALPHA/BETA ).GT.ZERO )
114* END IF
115*
116 RETURN
117*
118* End of ZLCTSX
119*

◆ zlsets()

subroutine zlsets ( integer m,
integer p,
integer n,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
integer lda,
complex*16, dimension( ldb, * ) b,
complex*16, dimension( ldb, * ) bf,
integer ldb,
complex*16, dimension( * ) c,
complex*16, dimension( * ) cf,
complex*16, dimension( * ) d,
complex*16, dimension( * ) df,
complex*16, dimension( * ) x,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( 2 ) result )

ZLSETS

Purpose:
!>
!> ZLSETS tests ZGGLSE - a subroutine for solving linear equality
!> constrained least square problem (LSE).
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]P
!>          P is INTEGER
!>          The number of rows of the matrix B.  P >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and B.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The M-by-N matrix A.
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, Q and R.
!>          LDA >= max(M,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          The P-by-N matrix A.
!>
[out]BF
!>          BF is COMPLEX*16 array, dimension (LDB,N)
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the arrays B, BF, V and S.
!>          LDB >= max(P,N).
!>
[in]C
!>          C is COMPLEX*16 array, dimension( M )
!>          the vector C in the LSE problem.
!>
[out]CF
!>          CF is COMPLEX*16 array, dimension( M )
!>
[in]D
!>          D is COMPLEX*16 array, dimension( P )
!>          the vector D in the LSE problem.
!>
[out]DF
!>          DF is COMPLEX*16 array, dimension( P )
!>
[out]X
!>          X is COMPLEX*16 array, dimension( N )
!>          solution vector X in the LSE problem.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>            RESULT(1) = norm( A*x - c )/ norm(A)*norm(X)*EPS
!>            RESULT(2) = norm( B*x - d )/ norm(B)*norm(X)*EPS
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 149 of file zlsets.f.

151*
152* -- LAPACK test routine --
153* -- LAPACK is a software package provided by Univ. of Tennessee, --
154* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
155*
156* .. Scalar Arguments ..
157 INTEGER LDA, LDB, LWORK, M, N, P
158* ..
159* .. Array Arguments ..
160*
161* ====================================================================
162*
163 DOUBLE PRECISION RESULT( 2 ), RWORK( * )
164 COMPLEX*16 A( LDA, * ), AF( LDA, * ), B( LDB, * ),
165 $ BF( LDB, * ), C( * ), CF( * ), D( * ), DF( * ),
166 $ WORK( LWORK ), X( * )
167* ..
168* .. Local Scalars ..
169 INTEGER INFO
170* ..
171* .. External Subroutines ..
172 EXTERNAL zcopy, zget02, zgglse, zlacpy
173* ..
174* .. Executable Statements ..
175*
176* Copy the matrices A and B to the arrays AF and BF,
177* and the vectors C and D to the arrays CF and DF,
178*
179 CALL zlacpy( 'Full', m, n, a, lda, af, lda )
180 CALL zlacpy( 'Full', p, n, b, ldb, bf, ldb )
181 CALL zcopy( m, c, 1, cf, 1 )
182 CALL zcopy( p, d, 1, df, 1 )
183*
184* Solve LSE problem
185*
186 CALL zgglse( m, n, p, af, lda, bf, ldb, cf, df, x, work, lwork,
187 $ info )
188*
189* Test the residual for the solution of LSE
190*
191* Compute RESULT(1) = norm( A*x - c ) / norm(A)*norm(X)*EPS
192*
193 CALL zcopy( m, c, 1, cf, 1 )
194 CALL zcopy( p, d, 1, df, 1 )
195 CALL zget02( 'No transpose', m, n, 1, a, lda, x, n, cf, m, rwork,
196 $ result( 1 ) )
197*
198* Compute result(2) = norm( B*x - d ) / norm(B)*norm(X)*EPS
199*
200 CALL zget02( 'No transpose', p, n, 1, b, ldb, x, n, df, p, rwork,
201 $ result( 2 ) )
202*
203 RETURN
204*
205* End of ZLSETS
206*
zget02
subroutine zget02(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZGET02
Definition zget02.f:134

◆ zsbmv()

subroutine zsbmv ( character uplo,
integer n,
integer k,
complex*16 alpha,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) x,
integer incx,
complex*16 beta,
complex*16, dimension( * ) y,
integer incy )

ZSBMV

Purpose:
!>
!> ZSBMV  performs the matrix-vector  operation
!>
!>    y := alpha*A*x + beta*y,
!>
!> where alpha and beta are scalars, x and y are n element vectors and
!> A is an n by n symmetric band matrix, with k super-diagonals.
!> 
!>  UPLO   - CHARACTER*1
!>           On entry, UPLO specifies whether the upper or lower
!>           triangular part of the band matrix A is being supplied as
!>           follows:
!>
!>              UPLO = 'U' or 'u'   The upper triangular part of A is
!>                                  being supplied.
!>
!>              UPLO = 'L' or 'l'   The lower triangular part of A is
!>                                  being supplied.
!>
!>           Unchanged on exit.
!>
!>  N      - INTEGER
!>           On entry, N specifies the order of the matrix A.
!>           N must be at least zero.
!>           Unchanged on exit.
!>
!>  K      - INTEGER
!>           On entry, K specifies the number of super-diagonals of the
!>           matrix A. K must satisfy  0 .le. K.
!>           Unchanged on exit.
!>
!>  ALPHA  - COMPLEX*16
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
!>  A      - COMPLEX*16 array, dimension( LDA, N )
!>           Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
!>           by n part of the array A must contain the upper triangular
!>           band part of the symmetric matrix, supplied column by
!>           column, with the leading diagonal of the matrix in row
!>           ( k + 1 ) of the array, the first super-diagonal starting at
!>           position 2 in row k, and so on. The top left k by k triangle
!>           of the array A is not referenced.
!>           The following program segment will transfer the upper
!>           triangular part of a symmetric band matrix from conventional
!>           full matrix storage to band storage:
!>
!>                 DO 20, J = 1, N
!>                    M = K + 1 - J
!>                    DO 10, I = MAX( 1, J - K ), J
!>                       A( M + I, J ) = matrix( I, J )
!>              10    CONTINUE
!>              20 CONTINUE
!>
!>           Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
!>           by n part of the array A must contain the lower triangular
!>           band part of the symmetric matrix, supplied column by
!>           column, with the leading diagonal of the matrix in row 1 of
!>           the array, the first sub-diagonal starting at position 1 in
!>           row 2, and so on. The bottom right k by k triangle of the
!>           array A is not referenced.
!>           The following program segment will transfer the lower
!>           triangular part of a symmetric band matrix from conventional
!>           full matrix storage to band storage:
!>
!>                 DO 20, J = 1, N
!>                    M = 1 - J
!>                    DO 10, I = J, MIN( N, J + K )
!>                       A( M + I, J ) = matrix( I, J )
!>              10    CONTINUE
!>              20 CONTINUE
!>
!>           Unchanged on exit.
!>
!>  LDA    - INTEGER
!>           On entry, LDA specifies the first dimension of A as declared
!>           in the calling (sub) program. LDA must be at least
!>           ( k + 1 ).
!>           Unchanged on exit.
!>
!>  X      - COMPLEX*16 array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCX ) ).
!>           Before entry, the incremented array X must contain the
!>           vector x.
!>           Unchanged on exit.
!>
!>  INCX   - INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           X. INCX must not be zero.
!>           Unchanged on exit.
!>
!>  BETA   - COMPLEX*16
!>           On entry, BETA specifies the scalar beta.
!>           Unchanged on exit.
!>
!>  Y      - COMPLEX*16 array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCY ) ).
!>           Before entry, the incremented array Y must contain the
!>           vector y. On exit, Y is overwritten by the updated vector y.
!>
!>  INCY   - INTEGER
!>           On entry, INCY specifies the increment for the elements of
!>           Y. INCY must not be zero.
!>           Unchanged on exit.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file zsbmv.f.

152*
153* -- LAPACK test routine --
154* -- LAPACK is a software package provided by Univ. of Tennessee, --
155* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
156*
157* .. Scalar Arguments ..
158 CHARACTER UPLO
159 INTEGER INCX, INCY, K, LDA, N
160 COMPLEX*16 ALPHA, BETA
161* ..
162* .. Array Arguments ..
163 COMPLEX*16 A( LDA, * ), X( * ), Y( * )
164* ..
165*
166* =====================================================================
167*
168* .. Parameters ..
169 COMPLEX*16 ONE
170 parameter( one = ( 1.0d+0, 0.0d+0 ) )
171 COMPLEX*16 ZERO
172 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
173* ..
174* .. Local Scalars ..
175 INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L
176 COMPLEX*16 TEMP1, TEMP2
177* ..
178* .. External Functions ..
179 LOGICAL LSAME
180 EXTERNAL lsame
181* ..
182* .. External Subroutines ..
183 EXTERNAL xerbla
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC max, min
187* ..
188* .. Executable Statements ..
189*
190* Test the input parameters.
191*
192 info = 0
193 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
194 info = 1
195 ELSE IF( n.LT.0 ) THEN
196 info = 2
197 ELSE IF( k.LT.0 ) THEN
198 info = 3
199 ELSE IF( lda.LT.( k+1 ) ) THEN
200 info = 6
201 ELSE IF( incx.EQ.0 ) THEN
202 info = 8
203 ELSE IF( incy.EQ.0 ) THEN
204 info = 11
205 END IF
206 IF( info.NE.0 ) THEN
207 CALL xerbla( 'ZSBMV ', info )
208 RETURN
209 END IF
210*
211* Quick return if possible.
212*
213 IF( ( n.EQ.0 ) .OR. ( ( alpha.EQ.zero ) .AND. ( beta.EQ.one ) ) )
214 $ RETURN
215*
216* Set up the start points in X and Y.
217*
218 IF( incx.GT.0 ) THEN
219 kx = 1
220 ELSE
221 kx = 1 - ( n-1 )*incx
222 END IF
223 IF( incy.GT.0 ) THEN
224 ky = 1
225 ELSE
226 ky = 1 - ( n-1 )*incy
227 END IF
228*
229* Start the operations. In this version the elements of the array A
230* are accessed sequentially with one pass through A.
231*
232* First form y := beta*y.
233*
234 IF( beta.NE.one ) THEN
235 IF( incy.EQ.1 ) THEN
236 IF( beta.EQ.zero ) THEN
237 DO 10 i = 1, n
238 y( i ) = zero
239 10 CONTINUE
240 ELSE
241 DO 20 i = 1, n
242 y( i ) = beta*y( i )
243 20 CONTINUE
244 END IF
245 ELSE
246 iy = ky
247 IF( beta.EQ.zero ) THEN
248 DO 30 i = 1, n
249 y( iy ) = zero
250 iy = iy + incy
251 30 CONTINUE
252 ELSE
253 DO 40 i = 1, n
254 y( iy ) = beta*y( iy )
255 iy = iy + incy
256 40 CONTINUE
257 END IF
258 END IF
259 END IF
260 IF( alpha.EQ.zero )
261 $ RETURN
262 IF( lsame( uplo, 'U' ) ) THEN
263*
264* Form y when upper triangle of A is stored.
265*
266 kplus1 = k + 1
267 IF( ( incx.EQ.1 ) .AND. ( incy.EQ.1 ) ) THEN
268 DO 60 j = 1, n
269 temp1 = alpha*x( j )
270 temp2 = zero
271 l = kplus1 - j
272 DO 50 i = max( 1, j-k ), j - 1
273 y( i ) = y( i ) + temp1*a( l+i, j )
274 temp2 = temp2 + a( l+i, j )*x( i )
275 50 CONTINUE
276 y( j ) = y( j ) + temp1*a( kplus1, j ) + alpha*temp2
277 60 CONTINUE
278 ELSE
279 jx = kx
280 jy = ky
281 DO 80 j = 1, n
282 temp1 = alpha*x( jx )
283 temp2 = zero
284 ix = kx
285 iy = ky
286 l = kplus1 - j
287 DO 70 i = max( 1, j-k ), j - 1
288 y( iy ) = y( iy ) + temp1*a( l+i, j )
289 temp2 = temp2 + a( l+i, j )*x( ix )
290 ix = ix + incx
291 iy = iy + incy
292 70 CONTINUE
293 y( jy ) = y( jy ) + temp1*a( kplus1, j ) + alpha*temp2
294 jx = jx + incx
295 jy = jy + incy
296 IF( j.GT.k ) THEN
297 kx = kx + incx
298 ky = ky + incy
299 END IF
300 80 CONTINUE
301 END IF
302 ELSE
303*
304* Form y when lower triangle of A is stored.
305*
306 IF( ( incx.EQ.1 ) .AND. ( incy.EQ.1 ) ) THEN
307 DO 100 j = 1, n
308 temp1 = alpha*x( j )
309 temp2 = zero
310 y( j ) = y( j ) + temp1*a( 1, j )
311 l = 1 - j
312 DO 90 i = j + 1, min( n, j+k )
313 y( i ) = y( i ) + temp1*a( l+i, j )
314 temp2 = temp2 + a( l+i, j )*x( i )
315 90 CONTINUE
316 y( j ) = y( j ) + alpha*temp2
317 100 CONTINUE
318 ELSE
319 jx = kx
320 jy = ky
321 DO 120 j = 1, n
322 temp1 = alpha*x( jx )
323 temp2 = zero
324 y( jy ) = y( jy ) + temp1*a( 1, j )
325 l = 1 - j
326 ix = jx
327 iy = jy
328 DO 110 i = j + 1, min( n, j+k )
329 ix = ix + incx
330 iy = iy + incy
331 y( iy ) = y( iy ) + temp1*a( l+i, j )
332 temp2 = temp2 + a( l+i, j )*x( ix )
333 110 CONTINUE
334 y( jy ) = y( jy ) + alpha*temp2
335 jx = jx + incx
336 jy = jy + incy
337 120 CONTINUE
338 END IF
339 END IF
340*
341 RETURN
342*
343* End of ZSBMV
344*

◆ zsgt01()

subroutine zsgt01 ( integer itype,
character uplo,
integer n,
integer m,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldz, * ) z,
integer ldz,
double precision, dimension( * ) d,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZSGT01

Purpose:
!>
!> CDGT01 checks a decomposition of the form
!>
!>    A Z   =  B Z D or
!>    A B Z =  Z D or
!>    B A Z =  Z D
!>
!> where A is a Hermitian matrix, B is Hermitian positive definite,
!> Z is unitary, and D is diagonal.
!>
!> One of the following test ratios is computed:
!>
!> ITYPE = 1:  RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp )
!>
!> ITYPE = 2:  RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp )
!>
!> ITYPE = 3:  RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp )
!>
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          The form of the Hermitian generalized eigenproblem.
!>          = 1:  A*z = (lambda)*B*z
!>          = 2:  A*B*z = (lambda)*z
!>          = 3:  B*A*z = (lambda)*z
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrices A and B is stored.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]M
!>          M is INTEGER
!>          The number of eigenvalues found.  M >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          The original Hermitian matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          The original Hermitian positive definite matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]Z
!>          Z is COMPLEX*16 array, dimension (LDZ, M)
!>          The computed eigenvectors of the generalized eigenproblem.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= max(1,N).
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (M)
!>          The computed eigenvalues of the generalized eigenproblem.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (1)
!>          The test ratio as described above.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file zsgt01.f.

152*
153* -- LAPACK test routine --
154* -- LAPACK is a software package provided by Univ. of Tennessee, --
155* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
156*
157* .. Scalar Arguments ..
158 CHARACTER UPLO
159 INTEGER ITYPE, LDA, LDB, LDZ, M, N
160* ..
161* .. Array Arguments ..
162 DOUBLE PRECISION D( * ), RESULT( * ), RWORK( * )
163 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ),
164 $ Z( LDZ, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 DOUBLE PRECISION ZERO, ONE
171 parameter( zero = 0.0d+0, one = 1.0d+0 )
172 COMPLEX*16 CZERO, CONE
173 parameter( czero = ( 0.0d+0, 0.0d+0 ),
174 $ cone = ( 1.0d+0, 0.0d+0 ) )
175* ..
176* .. Local Scalars ..
177 INTEGER I
178 DOUBLE PRECISION ANORM, ULP
179* ..
180* .. External Functions ..
181 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHE
182 EXTERNAL dlamch, zlange, zlanhe
183* ..
184* .. External Subroutines ..
185 EXTERNAL zdscal, zhemm
186* ..
187* .. Executable Statements ..
188*
189 result( 1 ) = zero
190 IF( n.LE.0 )
191 $ RETURN
192*
193 ulp = dlamch( 'Epsilon' )
194*
195* Compute product of 1-norms of A and Z.
196*
197 anorm = zlanhe( '1', uplo, n, a, lda, rwork )*
198 $ zlange( '1', n, m, z, ldz, rwork )
199 IF( anorm.EQ.zero )
200 $ anorm = one
201*
202 IF( itype.EQ.1 ) THEN
203*
204* Norm of AZ - BZD
205*
206 CALL zhemm( 'Left', uplo, n, m, cone, a, lda, z, ldz, czero,
207 $ work, n )
208 DO 10 i = 1, m
209 CALL zdscal( n, d( i ), z( 1, i ), 1 )
210 10 CONTINUE
211 CALL zhemm( 'Left', uplo, n, m, cone, b, ldb, z, ldz, -cone,
212 $ work, n )
213*
214 result( 1 ) = ( zlange( '1', n, m, work, n, rwork ) / anorm ) /
215 $ ( n*ulp )
216*
217 ELSE IF( itype.EQ.2 ) THEN
218*
219* Norm of ABZ - ZD
220*
221 CALL zhemm( 'Left', uplo, n, m, cone, b, ldb, z, ldz, czero,
222 $ work, n )
223 DO 20 i = 1, m
224 CALL zdscal( n, d( i ), z( 1, i ), 1 )
225 20 CONTINUE
226 CALL zhemm( 'Left', uplo, n, m, cone, a, lda, work, n, -cone,
227 $ z, ldz )
228*
229 result( 1 ) = ( zlange( '1', n, m, z, ldz, rwork ) / anorm ) /
230 $ ( n*ulp )
231*
232 ELSE IF( itype.EQ.3 ) THEN
233*
234* Norm of BAZ - ZD
235*
236 CALL zhemm( 'Left', uplo, n, m, cone, a, lda, z, ldz, czero,
237 $ work, n )
238 DO 30 i = 1, m
239 CALL zdscal( n, d( i ), z( 1, i ), 1 )
240 30 CONTINUE
241 CALL zhemm( 'Left', uplo, n, m, cone, b, ldb, work, n, -cone,
242 $ z, ldz )
243*
244 result( 1 ) = ( zlange( '1', n, m, z, ldz, rwork ) / anorm ) /
245 $ ( n*ulp )
246 END IF
247*
248 RETURN
249*
250* End of ZDGT01
251*

◆ zslect()

logical function zslect ( complex*16 z)

ZSLECT

Purpose:
!>
!> ZSLECT returns .TRUE. if the eigenvalue Z is to be selected,
!> otherwise it returns .FALSE.
!> It is used by ZCHK41 to test if ZGEES successfully sorts eigenvalues,
!> and by ZCHK43 to test if ZGEESX successfully sorts eigenvalues.
!>
!> The common block /SSLCT/ controls how eigenvalues are selected.
!> If SELOPT = 0, then ZSLECT return .TRUE. when real(Z) is less than
!> zero, and .FALSE. otherwise.
!> If SELOPT is at least 1, ZSLECT returns SELVAL(SELOPT) and adds 1
!> to SELOPT, cycling back to 1 at SELMAX.
!>
Parameters
[in]Z
!>          Z is COMPLEX*16
!>          The eigenvalue Z.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 55 of file zslect.f.

56*
57* -- LAPACK test routine --
58* -- LAPACK is a software package provided by Univ. of Tennessee, --
59* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
60*
61* .. Scalar Arguments ..
62 COMPLEX*16 Z
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 DOUBLE PRECISION ZERO
69 parameter( zero = 0.0d0 )
70* ..
71* .. Local Scalars ..
72 INTEGER I
73 DOUBLE PRECISION RMIN, X
74* ..
75* .. Scalars in Common ..
76 INTEGER SELDIM, SELOPT
77* ..
78* .. Arrays in Common ..
79 LOGICAL SELVAL( 20 )
80 DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
81* ..
82* .. Common blocks ..
83 COMMON / sslct / selopt, seldim, selval, selwr, selwi
84* ..
85* .. Intrinsic Functions ..
86 INTRINSIC abs, dble, dcmplx
87* ..
88* .. Executable Statements ..
89*
90 IF( selopt.EQ.0 ) THEN
91 zslect = ( dble( z ).LT.zero )
92 ELSE
93 rmin = abs( z-dcmplx( selwr( 1 ), selwi( 1 ) ) )
94 zslect = selval( 1 )
95 DO 10 i = 2, seldim
96 x = abs( z-dcmplx( selwr( i ), selwi( i ) ) )
97 IF( x.LE.rmin ) THEN
98 rmin = x
99 zslect = selval( i )
100 END IF
101 10 CONTINUE
102 END IF
103 RETURN
104*
105* End of ZSLECT
106*

◆ zstt21()

subroutine zstt21 ( integer n,
integer kband,
double precision, dimension( * ) ad,
double precision, dimension( * ) ae,
double precision, dimension( * ) sd,
double precision, dimension( * ) se,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision, dimension( 2 ) result )

ZSTT21

Purpose:
!>
!> ZSTT21  checks a decomposition of the form
!>
!>    A = U S U**H
!>
!> where **H means conjugate transpose, A is real symmetric tridiagonal,
!> U is unitary, and S is real and diagonal (if KBAND=0) or symmetric
!> tridiagonal (if KBAND=1).  Two tests are performed:
!>
!>    RESULT(1) = | A - U S U**H | / ( |A| n ulp )
!>
!>    RESULT(2) = | I - U U**H | / ( n ulp )
!>
Parameters
[in]N
!>          N is INTEGER
!>          The size of the matrix.  If it is zero, ZSTT21 does nothing.
!>          It must be at least zero.
!>
[in]KBAND
!>          KBAND is INTEGER
!>          The bandwidth of the matrix S.  It may only be zero or one.
!>          If zero, then S is diagonal, and SE is not referenced.  If
!>          one, then S is symmetric tri-diagonal.
!>
[in]AD
!>          AD is DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the original (unfactored) matrix A.  A is
!>          assumed to be real symmetric tridiagonal.
!>
[in]AE
!>          AE is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal of the original (unfactored) matrix A.  A
!>          is assumed to be symmetric tridiagonal.  AE(1) is the (1,2)
!>          and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.
!>
[in]SD
!>          SD is DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the real (symmetric tri-) diagonal matrix S.
!>
[in]SE
!>          SE is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix S.
!>          Not referenced if KBSND=0.  If KBAND=1, then AE(1) is the
!>          (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)
!>          element, etc.
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU, N)
!>          The unitary matrix in the decomposition.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  LDU must be at least N.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N**2)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 131 of file zstt21.f.

133*
134* -- LAPACK test routine --
135* -- LAPACK is a software package provided by Univ. of Tennessee, --
136* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
137*
138* .. Scalar Arguments ..
139 INTEGER KBAND, LDU, N
140* ..
141* .. Array Arguments ..
142 DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), RWORK( * ),
143 $ SD( * ), SE( * )
144 COMPLEX*16 U( LDU, * ), WORK( * )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 DOUBLE PRECISION ZERO, ONE
151 parameter( zero = 0.0d+0, one = 1.0d+0 )
152 COMPLEX*16 CZERO, CONE
153 parameter( czero = ( 0.0d+0, 0.0d+0 ),
154 $ cone = ( 1.0d+0, 0.0d+0 ) )
155* ..
156* .. Local Scalars ..
157 INTEGER J
158 DOUBLE PRECISION ANORM, TEMP1, TEMP2, ULP, UNFL, WNORM
159* ..
160* .. External Functions ..
161 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHE
162 EXTERNAL dlamch, zlange, zlanhe
163* ..
164* .. External Subroutines ..
165 EXTERNAL zgemm, zher, zher2, zlaset
166* ..
167* .. Intrinsic Functions ..
168 INTRINSIC abs, dble, dcmplx, max, min
169* ..
170* .. Executable Statements ..
171*
172* 1) Constants
173*
174 result( 1 ) = zero
175 result( 2 ) = zero
176 IF( n.LE.0 )
177 $ RETURN
178*
179 unfl = dlamch( 'Safe minimum' )
180 ulp = dlamch( 'Precision' )
181*
182* Do Test 1
183*
184* Copy A & Compute its 1-Norm:
185*
186 CALL zlaset( 'Full', n, n, czero, czero, work, n )
187*
188 anorm = zero
189 temp1 = zero
190*
191 DO 10 j = 1, n - 1
192 work( ( n+1 )*( j-1 )+1 ) = ad( j )
193 work( ( n+1 )*( j-1 )+2 ) = ae( j )
194 temp2 = abs( ae( j ) )
195 anorm = max( anorm, abs( ad( j ) )+temp1+temp2 )
196 temp1 = temp2
197 10 CONTINUE
198*
199 work( n**2 ) = ad( n )
200 anorm = max( anorm, abs( ad( n ) )+temp1, unfl )
201*
202* Norm of A - USU*
203*
204 DO 20 j = 1, n
205 CALL zher( 'L', n, -sd( j ), u( 1, j ), 1, work, n )
206 20 CONTINUE
207*
208 IF( n.GT.1 .AND. kband.EQ.1 ) THEN
209 DO 30 j = 1, n - 1
210 CALL zher2( 'L', n, -dcmplx( se( j ) ), u( 1, j ), 1,
211 $ u( 1, j+1 ), 1, work, n )
212 30 CONTINUE
213 END IF
214*
215 wnorm = zlanhe( '1', 'L', n, work, n, rwork )
216*
217 IF( anorm.GT.wnorm ) THEN
218 result( 1 ) = ( wnorm / anorm ) / ( n*ulp )
219 ELSE
220 IF( anorm.LT.one ) THEN
221 result( 1 ) = ( min( wnorm, n*anorm ) / anorm ) / ( n*ulp )
222 ELSE
223 result( 1 ) = min( wnorm / anorm, dble( n ) ) / ( n*ulp )
224 END IF
225 END IF
226*
227* Do Test 2
228*
229* Compute U U**H - I
230*
231 CALL zgemm( 'N', 'C', n, n, n, cone, u, ldu, u, ldu, czero, work,
232 $ n )
233*
234 DO 40 j = 1, n
235 work( ( n+1 )*( j-1 )+1 ) = work( ( n+1 )*( j-1 )+1 ) - cone
236 40 CONTINUE
237*
238 result( 2 ) = min( dble( n ), zlange( '1', n, n, work, n,
239 $ rwork ) ) / ( n*ulp )
240*
241 RETURN
242*
243* End of ZSTT21
244*

◆ zstt22()

subroutine zstt22 ( integer n,
integer m,
integer kband,
double precision, dimension( * ) ad,
double precision, dimension( * ) ae,
double precision, dimension( * ) sd,
double precision, dimension( * ) se,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldwork, * ) work,
integer ldwork,
double precision, dimension( * ) rwork,
double precision, dimension( 2 ) result )

ZSTT22

Purpose:
!>
!> ZSTT22  checks a set of M eigenvalues and eigenvectors,
!>
!>     A U = U S
!>
!> where A is Hermitian tridiagonal, the columns of U are unitary,
!> and S is diagonal (if KBAND=0) or Hermitian tridiagonal (if KBAND=1).
!> Two tests are performed:
!>
!>    RESULT(1) = | U* A U - S | / ( |A| m ulp )
!>
!>    RESULT(2) = | I - U*U | / ( m ulp )
!>
Parameters
[in]N
!>          N is INTEGER
!>          The size of the matrix.  If it is zero, ZSTT22 does nothing.
!>          It must be at least zero.
!>
[in]M
!>          M is INTEGER
!>          The number of eigenpairs to check.  If it is zero, ZSTT22
!>          does nothing.  It must be at least zero.
!>
[in]KBAND
!>          KBAND is INTEGER
!>          The bandwidth of the matrix S.  It may only be zero or one.
!>          If zero, then S is diagonal, and SE is not referenced.  If
!>          one, then S is Hermitian tri-diagonal.
!>
[in]AD
!>          AD is DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the original (unfactored) matrix A.  A is
!>          assumed to be Hermitian tridiagonal.
!>
[in]AE
!>          AE is DOUBLE PRECISION array, dimension (N)
!>          The off-diagonal of the original (unfactored) matrix A.  A
!>          is assumed to be Hermitian tridiagonal.  AE(1) is ignored,
!>          AE(2) is the (1,2) and (2,1) element, etc.
!>
[in]SD
!>          SD is DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the (Hermitian tri-) diagonal matrix S.
!>
[in]SE
!>          SE is DOUBLE PRECISION array, dimension (N)
!>          The off-diagonal of the (Hermitian tri-) diagonal matrix S.
!>          Not referenced if KBSND=0.  If KBAND=1, then AE(1) is
!>          ignored, SE(2) is the (1,2) and (2,1) element, etc.
!>
[in]U
!>          U is DOUBLE PRECISION array, dimension (LDU, N)
!>          The unitary matrix in the decomposition.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  LDU must be at least N.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LDWORK, M+1)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of WORK.  LDWORK must be at least
!>          max(1,M).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 143 of file zstt22.f.

145*
146* -- LAPACK test routine --
147* -- LAPACK is a software package provided by Univ. of Tennessee, --
148* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
149*
150* .. Scalar Arguments ..
151 INTEGER KBAND, LDU, LDWORK, M, N
152* ..
153* .. Array Arguments ..
154 DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), RWORK( * ),
155 $ SD( * ), SE( * )
156 COMPLEX*16 U( LDU, * ), WORK( LDWORK, * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 DOUBLE PRECISION ZERO, ONE
163 parameter( zero = 0.0d0, one = 1.0d0 )
164 COMPLEX*16 CZERO, CONE
165 parameter( czero = ( 0.0d+0, 0.0d+0 ),
166 $ cone = ( 1.0d+0, 0.0d+0 ) )
167* ..
168* .. Local Scalars ..
169 INTEGER I, J, K
170 DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
171 COMPLEX*16 AUKJ
172* ..
173* .. External Functions ..
174 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
175 EXTERNAL dlamch, zlange, zlansy
176* ..
177* .. External Subroutines ..
178 EXTERNAL zgemm
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC abs, dble, max, min
182* ..
183* .. Executable Statements ..
184*
185 result( 1 ) = zero
186 result( 2 ) = zero
187 IF( n.LE.0 .OR. m.LE.0 )
188 $ RETURN
189*
190 unfl = dlamch( 'Safe minimum' )
191 ulp = dlamch( 'Epsilon' )
192*
193* Do Test 1
194*
195* Compute the 1-norm of A.
196*
197 IF( n.GT.1 ) THEN
198 anorm = abs( ad( 1 ) ) + abs( ae( 1 ) )
199 DO 10 j = 2, n - 1
200 anorm = max( anorm, abs( ad( j ) )+abs( ae( j ) )+
201 $ abs( ae( j-1 ) ) )
202 10 CONTINUE
203 anorm = max( anorm, abs( ad( n ) )+abs( ae( n-1 ) ) )
204 ELSE
205 anorm = abs( ad( 1 ) )
206 END IF
207 anorm = max( anorm, unfl )
208*
209* Norm of U*AU - S
210*
211 DO 40 i = 1, m
212 DO 30 j = 1, m
213 work( i, j ) = czero
214 DO 20 k = 1, n
215 aukj = ad( k )*u( k, j )
216 IF( k.NE.n )
217 $ aukj = aukj + ae( k )*u( k+1, j )
218 IF( k.NE.1 )
219 $ aukj = aukj + ae( k-1 )*u( k-1, j )
220 work( i, j ) = work( i, j ) + u( k, i )*aukj
221 20 CONTINUE
222 30 CONTINUE
223 work( i, i ) = work( i, i ) - sd( i )
224 IF( kband.EQ.1 ) THEN
225 IF( i.NE.1 )
226 $ work( i, i-1 ) = work( i, i-1 ) - se( i-1 )
227 IF( i.NE.n )
228 $ work( i, i+1 ) = work( i, i+1 ) - se( i )
229 END IF
230 40 CONTINUE
231*
232 wnorm = zlansy( '1', 'L', m, work, m, rwork )
233*
234 IF( anorm.GT.wnorm ) THEN
235 result( 1 ) = ( wnorm / anorm ) / ( m*ulp )
236 ELSE
237 IF( anorm.LT.one ) THEN
238 result( 1 ) = ( min( wnorm, m*anorm ) / anorm ) / ( m*ulp )
239 ELSE
240 result( 1 ) = min( wnorm / anorm, dble( m ) ) / ( m*ulp )
241 END IF
242 END IF
243*
244* Do Test 2
245*
246* Compute U*U - I
247*
248 CALL zgemm( 'T', 'N', m, m, n, cone, u, ldu, u, ldu, czero, work,
249 $ m )
250*
251 DO 50 j = 1, m
252 work( j, j ) = work( j, j ) - one
253 50 CONTINUE
254*
255 result( 2 ) = min( dble( m ), zlange( '1', m, m, work, m,
256 $ rwork ) ) / ( m*ulp )
257*
258 RETURN
259*
260* End of ZSTT22
261*
zlansy
double precision function zlansy(norm, uplo, n, a, lda, work)
ZLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlansy.f:123

◆ zunt01()

subroutine zunt01 ( character rowcol,
integer m,
integer n,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision resid )

ZUNT01

Purpose:
!>
!> ZUNT01 checks that the matrix U is unitary by computing the ratio
!>
!>    RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
!> or
!>    RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.
!>
!> Alternatively, if there isn't sufficient workspace to form
!> I - U*U' or I - U'*U, the ratio is computed as
!>
!>    RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
!> or
!>    RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.
!>
!> where EPS is the machine precision.  ROWCOL is used only if m = n;
!> if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is
!> assumed to be 'R'.
!>
Parameters
[in]ROWCOL
!>          ROWCOL is CHARACTER
!>          Specifies whether the rows or columns of U should be checked
!>          for orthogonality.  Used only if M = N.
!>          = 'R':  Check for orthogonal rows of U
!>          = 'C':  Check for orthogonal columns of U
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix U.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix U.
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU,N)
!>          The unitary matrix U.  U is checked for orthogonal columns
!>          if m > n or if m = n and ROWCOL = 'C'.  U is checked for
!>          orthogonal rows if m < n or if m = n and ROWCOL = 'R'.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,M).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  For best performance, LWORK
!>          should be at least N*N if ROWCOL = 'C' or M*M if
!>          ROWCOL = 'R', but the test will be done even if LWORK is 0.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (min(M,N))
!>          Used only if LWORK is large enough to use the Level 3 BLAS
!>          code.
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or
!>          RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zunt01.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 CHARACTER ROWCOL
133 INTEGER LDU, LWORK, M, N
134 DOUBLE PRECISION RESID
135* ..
136* .. Array Arguments ..
137 DOUBLE PRECISION RWORK( * )
138 COMPLEX*16 U( LDU, * ), WORK( * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ZERO, ONE
145 parameter( zero = 0.0d+0, one = 1.0d+0 )
146* ..
147* .. Local Scalars ..
148 CHARACTER TRANSU
149 INTEGER I, J, K, LDWORK, MNMIN
150 DOUBLE PRECISION EPS
151 COMPLEX*16 TMP, ZDUM
152* ..
153* .. External Functions ..
154 LOGICAL LSAME
155 DOUBLE PRECISION DLAMCH, ZLANSY
156 COMPLEX*16 ZDOTC
157 EXTERNAL lsame, dlamch, zlansy, zdotc
158* ..
159* .. External Subroutines ..
160 EXTERNAL zherk, zlaset
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC abs, dble, dcmplx, dimag, max, min
164* ..
165* .. Statement Functions ..
166 DOUBLE PRECISION CABS1
167* ..
168* .. Statement Function definitions ..
169 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
170* ..
171* .. Executable Statements ..
172*
173 resid = zero
174*
175* Quick return if possible
176*
177 IF( m.LE.0 .OR. n.LE.0 )
178 $ RETURN
179*
180 eps = dlamch( 'Precision' )
181 IF( m.LT.n .OR. ( m.EQ.n .AND. lsame( rowcol, 'R' ) ) ) THEN
182 transu = 'N'
183 k = n
184 ELSE
185 transu = 'C'
186 k = m
187 END IF
188 mnmin = min( m, n )
189*
190 IF( ( mnmin+1 )*mnmin.LE.lwork ) THEN
191 ldwork = mnmin
192 ELSE
193 ldwork = 0
194 END IF
195 IF( ldwork.GT.0 ) THEN
196*
197* Compute I - U*U' or I - U'*U.
198*
199 CALL zlaset( 'Upper', mnmin, mnmin, dcmplx( zero ),
200 $ dcmplx( one ), work, ldwork )
201 CALL zherk( 'Upper', transu, mnmin, k, -one, u, ldu, one, work,
202 $ ldwork )
203*
204* Compute norm( I - U*U' ) / ( K * EPS ) .
205*
206 resid = zlansy( '1', 'Upper', mnmin, work, ldwork, rwork )
207 resid = ( resid / dble( k ) ) / eps
208 ELSE IF( transu.EQ.'C' ) THEN
209*
210* Find the maximum element in abs( I - U'*U ) / ( m * EPS )
211*
212 DO 20 j = 1, n
213 DO 10 i = 1, j
214 IF( i.NE.j ) THEN
215 tmp = zero
216 ELSE
217 tmp = one
218 END IF
219 tmp = tmp - zdotc( m, u( 1, i ), 1, u( 1, j ), 1 )
220 resid = max( resid, cabs1( tmp ) )
221 10 CONTINUE
222 20 CONTINUE
223 resid = ( resid / dble( m ) ) / eps
224 ELSE
225*
226* Find the maximum element in abs( I - U*U' ) / ( n * EPS )
227*
228 DO 40 j = 1, m
229 DO 30 i = 1, j
230 IF( i.NE.j ) THEN
231 tmp = zero
232 ELSE
233 tmp = one
234 END IF
235 tmp = tmp - zdotc( n, u( j, 1 ), ldu, u( i, 1 ), ldu )
236 resid = max( resid, cabs1( tmp ) )
237 30 CONTINUE
238 40 CONTINUE
239 resid = ( resid / dble( n ) ) / eps
240 END IF
241 RETURN
242*
243* End of ZUNT01
244*

◆ zunt03()

subroutine zunt03 ( character*( * ) rc,
integer mu,
integer mv,
integer n,
integer k,
complex*16, dimension( ldu, * ) u,
integer ldu,
complex*16, dimension( ldv, * ) v,
integer ldv,
complex*16, dimension( * ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision result,
integer info )

ZUNT03

Purpose:
!>
!> ZUNT03 compares two unitary matrices U and V to see if their
!> corresponding rows or columns span the same spaces.  The rows are
!> checked if RC = 'R', and the columns are checked if RC = 'C'.
!>
!> RESULT is the maximum of
!>
!>    | V*V' - I | / ( MV ulp ), if RC = 'R', or
!>
!>    | V'*V - I | / ( MV ulp ), if RC = 'C',
!>
!> and the maximum over rows (or columns) 1 to K of
!>
!>    | U(i) - S*V(i) |/ ( N ulp )
!>
!> where abs(S) = 1 (chosen to minimize the expression), U(i) is the
!> i-th row (column) of U, and V(i) is the i-th row (column) of V.
!>
Parameters
[in]RC
!>          RC is CHARACTER*1
!>          If RC = 'R' the rows of U and V are to be compared.
!>          If RC = 'C' the columns of U and V are to be compared.
!>
[in]MU
!>          MU is INTEGER
!>          The number of rows of U if RC = 'R', and the number of
!>          columns if RC = 'C'.  If MU = 0 ZUNT03 does nothing.
!>          MU must be at least zero.
!>
[in]MV
!>          MV is INTEGER
!>          The number of rows of V if RC = 'R', and the number of
!>          columns if RC = 'C'.  If MV = 0 ZUNT03 does nothing.
!>          MV must be at least zero.
!>
[in]N
!>          N is INTEGER
!>          If RC = 'R', the number of columns in the matrices U and V,
!>          and if RC = 'C', the number of rows in U and V.  If N = 0
!>          ZUNT03 does nothing.  N must be at least zero.
!>
[in]K
!>          K is INTEGER
!>          The number of rows or columns of U and V to compare.
!>          0 <= K <= max(MU,MV).
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU,N)
!>          The first matrix to compare.  If RC = 'R', U is MU by N, and
!>          if RC = 'C', U is N by MU.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  If RC = 'R', LDU >= max(1,MU),
!>          and if RC = 'C', LDU >= max(1,N).
!>
[in]V
!>          V is COMPLEX*16 array, dimension (LDV,N)
!>          The second matrix to compare.  If RC = 'R', V is MV by N, and
!>          if RC = 'C', V is N by MV.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of V.  If RC = 'R', LDV >= max(1,MV),
!>          and if RC = 'C', LDV >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  For best performance, LWORK
!>          should be at least N*N if RC = 'C' or M*M if RC = 'R', but
!>          the tests will be done even if LWORK is 0.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(MV,N))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION
!>          The value computed by the test described above.  RESULT is
!>          limited to 1/ulp to avoid overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          0  indicates a successful exit
!>          -k indicates the k-th parameter had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 160 of file zunt03.f.

162*
163* -- LAPACK test 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*( * ) RC
169 INTEGER INFO, K, LDU, LDV, LWORK, MU, MV, N
170 DOUBLE PRECISION RESULT
171* ..
172* .. Array Arguments ..
173 DOUBLE PRECISION RWORK( * )
174 COMPLEX*16 U( LDU, * ), V( LDV, * ), WORK( * )
175* ..
176*
177* =====================================================================
178*
179*
180* .. Parameters ..
181 DOUBLE PRECISION ZERO, ONE
182 parameter( zero = 0.0d0, one = 1.0d0 )
183* ..
184* .. Local Scalars ..
185 INTEGER I, IRC, J, LMX
186 DOUBLE PRECISION RES1, RES2, ULP
187 COMPLEX*16 S, SU, SV
188* ..
189* .. External Functions ..
190 LOGICAL LSAME
191 INTEGER IZAMAX
192 DOUBLE PRECISION DLAMCH
193 EXTERNAL lsame, izamax, dlamch
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC abs, dble, dcmplx, max, min
197* ..
198* .. External Subroutines ..
199 EXTERNAL xerbla, zunt01
200* ..
201* .. Executable Statements ..
202*
203* Check inputs
204*
205 info = 0
206 IF( lsame( rc, 'R' ) ) THEN
207 irc = 0
208 ELSE IF( lsame( rc, 'C' ) ) THEN
209 irc = 1
210 ELSE
211 irc = -1
212 END IF
213 IF( irc.EQ.-1 ) THEN
214 info = -1
215 ELSE IF( mu.LT.0 ) THEN
216 info = -2
217 ELSE IF( mv.LT.0 ) THEN
218 info = -3
219 ELSE IF( n.LT.0 ) THEN
220 info = -4
221 ELSE IF( k.LT.0 .OR. k.GT.max( mu, mv ) ) THEN
222 info = -5
223 ELSE IF( ( irc.EQ.0 .AND. ldu.LT.max( 1, mu ) ) .OR.
224 $ ( irc.EQ.1 .AND. ldu.LT.max( 1, n ) ) ) THEN
225 info = -7
226 ELSE IF( ( irc.EQ.0 .AND. ldv.LT.max( 1, mv ) ) .OR.
227 $ ( irc.EQ.1 .AND. ldv.LT.max( 1, n ) ) ) THEN
228 info = -9
229 END IF
230 IF( info.NE.0 ) THEN
231 CALL xerbla( 'ZUNT03', -info )
232 RETURN
233 END IF
234*
235* Initialize result
236*
237 result = zero
238 IF( mu.EQ.0 .OR. mv.EQ.0 .OR. n.EQ.0 )
239 $ RETURN
240*
241* Machine constants
242*
243 ulp = dlamch( 'Precision' )
244*
245 IF( irc.EQ.0 ) THEN
246*
247* Compare rows
248*
249 res1 = zero
250 DO 20 i = 1, k
251 lmx = izamax( n, u( i, 1 ), ldu )
252 IF( v( i, lmx ).EQ.dcmplx( zero ) ) THEN
253 sv = one
254 ELSE
255 sv = abs( v( i, lmx ) ) / v( i, lmx )
256 END IF
257 IF( u( i, lmx ).EQ.dcmplx( zero ) ) THEN
258 su = one
259 ELSE
260 su = abs( u( i, lmx ) ) / u( i, lmx )
261 END IF
262 s = sv / su
263 DO 10 j = 1, n
264 res1 = max( res1, abs( u( i, j )-s*v( i, j ) ) )
265 10 CONTINUE
266 20 CONTINUE
267 res1 = res1 / ( dble( n )*ulp )
268*
269* Compute orthogonality of rows of V.
270*
271 CALL zunt01( 'Rows', mv, n, v, ldv, work, lwork, rwork, res2 )
272*
273 ELSE
274*
275* Compare columns
276*
277 res1 = zero
278 DO 40 i = 1, k
279 lmx = izamax( n, u( 1, i ), 1 )
280 IF( v( lmx, i ).EQ.dcmplx( zero ) ) THEN
281 sv = one
282 ELSE
283 sv = abs( v( lmx, i ) ) / v( lmx, i )
284 END IF
285 IF( u( lmx, i ).EQ.dcmplx( zero ) ) THEN
286 su = one
287 ELSE
288 su = abs( u( lmx, i ) ) / u( lmx, i )
289 END IF
290 s = sv / su
291 DO 30 j = 1, n
292 res1 = max( res1, abs( u( j, i )-s*v( j, i ) ) )
293 30 CONTINUE
294 40 CONTINUE
295 res1 = res1 / ( dble( n )*ulp )
296*
297* Compute orthogonality of columns of V.
298*
299 CALL zunt01( 'Columns', n, mv, v, ldv, work, lwork, rwork,
300 $ res2 )
301 END IF
302*
303 result = min( max( res1, res2 ), one / ulp )
304 RETURN
305*
306* End of ZUNT03
307*
izamax
integer function izamax(n, zx, incx)
IZAMAX
Definition izamax.f:71