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

Functions

subroutine cbdt01 (m, n, kd, a, lda, q, ldq, d, e, pt, ldpt, work, rwork, resid)
 CBDT01
subroutine cbdt02 (m, n, b, ldb, c, ldc, u, ldu, work, rwork, resid)
 CBDT02
subroutine cbdt03 (uplo, n, kd, d, e, u, ldu, s, vt, ldvt, work, resid)
 CBDT03
subroutine cchkbb (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)
 CCHKBB
subroutine cchkbd (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)
 CCHKBD
subroutine cchkbk (nin, nout)
 CCHKBK
subroutine cchkbl (nin, nout)
 CCHKBL
subroutine cchkec (thresh, tsterr, nin, nout)
 CCHKEC
program cchkee
 CCHKEE
subroutine cchkgg (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)
 CCHKGG
subroutine cchkgk (nin, nout)
 CCHKGK
subroutine cchkgl (nin, nout)
 CCHKGL
subroutine cchkhb (nsizes, nn, nwdths, kk, ntypes, dotype, iseed, thresh, nounit, a, lda, sd, se, u, ldu, work, lwork, rwork, result, info)
 CCHKHB
subroutine cchkhb2stg (nsizes, nn, nwdths, kk, ntypes, dotype, iseed, thresh, nounit, a, lda, sd, se, d1, d2, d3, u, ldu, work, lwork, rwork, result, info)
 CCHKHB2STG
subroutine cchkhs (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)
 CCHKHS
subroutine cchkst (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)
 CCHKST
subroutine cchkst2stg (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)
 CCHKST2STG
subroutine cckcsd (nm, mval, pval, qval, nmats, iseed, thresh, mmax, x, xf, u1, u2, v1t, v2t, theta, iwork, work, rwork, nin, nout, info)
 CCKCSD
subroutine cckglm (nn, nval, mval, pval, nmats, iseed, thresh, nmax, a, af, b, bf, x, work, rwork, nin, nout, info)
 CCKGLM
subroutine cckgqr (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)
 CCKGQR
subroutine cckgsv (nm, mval, pval, nval, nmats, iseed, thresh, nmax, a, af, b, bf, u, v, q, alpha, beta, r, iwork, work, rwork, nin, nout, info)
 CCKGSV
subroutine ccklse (nn, mval, pval, nval, nmats, iseed, thresh, nmax, a, af, b, bf, x, work, rwork, nin, nout, info)
 CCKLSE
subroutine ccsdts (m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, theta, iwork, work, lwork, rwork, result)
 CCSDTS
subroutine cdrges (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, alpha, beta, work, lwork, rwork, result, bwork, info)
 CDRGES
subroutine cdrges3 (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, alpha, beta, work, lwork, rwork, result, bwork, info)
 CDRGES3
subroutine cdrgev (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)
 CDRGEV
subroutine cdrgev3 (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)
 CDRGEV3
subroutine cdrgsx (nsize, ncmax, thresh, nin, nout, a, lda, b, ai, bi, z, q, alpha, beta, c, ldc, s, work, lwork, rwork, iwork, liwork, bwork, info)
 CDRGSX
subroutine cdrgvx (nsize, thresh, nin, nout, a, lda, b, ai, bi, alpha, beta, vl, vr, ilo, ihi, lscale, rscale, s, stru, dif, diftru, work, lwork, rwork, iwork, liwork, result, bwork, info)
 CDRGVX
subroutine cdrvbd (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)
 CDRVBD
subroutine cdrves (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, h, ht, w, wt, vs, ldvs, result, work, nwork, rwork, iwork, bwork, info)
 CDRVES
subroutine cdrvev (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre, result, work, nwork, rwork, iwork, info)
 CDRVEV
subroutine cdrvsg (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)
 CDRVSG
subroutine cdrvsg2stg (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)
 CDRVSG2STG
subroutine cdrvst (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)
 CDRVST
subroutine cdrvst2stg (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)
 CDRVST2STG
subroutine cdrvsx (nsizes, nn, ntypes, dotype, iseed, thresh, niunit, nounit, a, lda, h, ht, w, wt, wtmp, vs, ldvs, vs1, result, work, lwork, rwork, bwork, info)
 CDRVSX
subroutine cdrvvx (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)
 CDRVVX
subroutine cerrbd (path, nunit)
 CERRBD
subroutine cerrec (path, nunit)
 CERREC
subroutine cerred (path, nunit)
 CERRED
subroutine cerrgg (path, nunit)
 CERRGG
subroutine cerrhs (path, nunit)
 CERRHS
subroutine cerrst (path, nunit)
 CERRST
subroutine cget02 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 CGET02
subroutine cget10 (m, n, a, lda, b, ldb, work, rwork, result)
 CGET10
subroutine cget22 (transa, transe, transw, n, a, lda, e, lde, w, work, rwork, result)
 CGET22
subroutine cget23 (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)
 CGET23
subroutine cget24 (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)
 CGET24
subroutine cget35 (rmax, lmax, ninfo, knt, nin)
 CGET35
subroutine cget36 (rmax, lmax, ninfo, knt, nin)
 CGET36
subroutine cget37 (rmax, lmax, ninfo, knt, nin)
 CGET37
subroutine cget38 (rmax, lmax, ninfo, knt, nin)
 CGET38
subroutine cget51 (itype, n, a, lda, b, ldb, u, ldu, v, ldv, work, rwork, result)
 CGET51
subroutine cget52 (left, n, a, lda, b, ldb, e, lde, alpha, beta, work, rwork, result)
 CGET52
subroutine cget54 (n, a, lda, b, ldb, s, lds, t, ldt, u, ldu, v, ldv, work, result)
 CGET54
subroutine cglmts (n, m, p, a, af, lda, b, bf, ldb, d, df, x, u, work, lwork, rwork, result)
 CGLMTS
subroutine cgqrts (n, m, p, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
 CGQRTS
subroutine cgrqts (m, p, n, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
 CGRQTS
subroutine cgsvts3 (m, p, n, a, af, lda, b, bf, ldb, u, ldu, v, ldv, q, ldq, alpha, beta, r, ldr, iwork, work, lwork, rwork, result)
 CGSVTS3
subroutine chbt21 (uplo, n, ka, ks, a, lda, d, e, u, ldu, work, rwork, result)
 CHBT21
subroutine chet21 (itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
 CHET21
subroutine chet22 (itype, uplo, n, m, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
 CHET22
subroutine chkxer (srnamt, infot, nout, lerr, ok)
 CHKXER
subroutine chpt21 (itype, uplo, n, kband, ap, d, e, u, ldu, vp, tau, work, rwork, result)
 CHPT21
subroutine chst01 (n, ilo, ihi, a, lda, h, ldh, q, ldq, work, lwork, rwork, result)
 CHST01
subroutine clarfy (uplo, n, v, incv, tau, c, ldc, work)
 CLARFY
subroutine clarhs (path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
 CLARHS
subroutine clatm4 (itype, n, nz1, nz2, rsign, amagn, rcond, triang, idist, iseed, a, lda)
 CLATM4
logical function clctes (z, d)
 CLCTES
logical function clctsx (alpha, beta)
 CLCTSX
subroutine clsets (m, p, n, a, af, lda, b, bf, ldb, c, cf, d, df, x, work, lwork, rwork, result)
 CLSETS
subroutine csbmv (uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
 CSBMV
subroutine csgt01 (itype, uplo, n, m, a, lda, b, ldb, z, ldz, d, work, rwork, result)
 CSGT01
logical function cslect (z)
 CSLECT
subroutine cstt21 (n, kband, ad, ae, sd, se, u, ldu, work, rwork, result)
 CSTT21
subroutine cstt22 (n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, rwork, result)
 CSTT22
subroutine cunt01 (rowcol, m, n, u, ldu, work, lwork, rwork, resid)
 CUNT01
subroutine cunt03 (rc, mu, mv, n, k, u, ldu, v, ldv, work, lwork, rwork, result, info)
 CUNT03

Detailed Description

This is the group of complex LAPACK TESTING EIG routines.

Function Documentation

◆ cbdt01()

subroutine cbdt01 ( integer m,
integer n,
integer kd,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldq, * ) q,
integer ldq,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( ldpt, * ) pt,
integer ldpt,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real resid )

CBDT01

Purpose:
!>
!> CBDT01 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 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 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 REAL array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B.
!>
[in]E
!>          E is REAL 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 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 array, dimension (M+N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESID
!>          RESID is REAL
!>          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 cbdt01.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 REAL RESID
155* ..
156* .. Array Arguments ..
157 REAL D( * ), E( * ), RWORK( * )
158 COMPLEX A( LDA, * ), PT( LDPT, * ), Q( LDQ, * ),
159 $ WORK( * )
160* ..
161*
162* =====================================================================
163*
164* .. Parameters ..
165 REAL ZERO, ONE
166 parameter( zero = 0.0e+0, one = 1.0e+0 )
167* ..
168* .. Local Scalars ..
169 INTEGER I, J
170 REAL ANORM, EPS
171* ..
172* .. External Functions ..
173 REAL CLANGE, SCASUM, SLAMCH
174 EXTERNAL clange, scasum, slamch
175* ..
176* .. External Subroutines ..
177 EXTERNAL ccopy, cgemv
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC cmplx, max, min, real
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 ccopy( 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 cgemv( 'No transpose', m, n, -cmplx( one ), q, ldq,
209 $ work( m+1 ), 1, cmplx( one ), work, 1 )
210 resid = max( resid, scasum( 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 ccopy( 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 cgemv( 'No transpose', m, m, -cmplx( one ), q, ldq,
223 $ work( m+1 ), 1, cmplx( one ), work, 1 )
224 resid = max( resid, scasum( m, work, 1 ) )
225 40 CONTINUE
226 ELSE
227*
228* B is lower bidiagonal.
229*
230 DO 60 j = 1, n
231 CALL ccopy( 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 cgemv( 'No transpose', m, m, -cmplx( one ), q, ldq,
238 $ work( m+1 ), 1, cmplx( one ), work, 1 )
239 resid = max( resid, scasum( 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 ccopy( 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 cgemv( 'No transpose', m, n, -cmplx( one ), q, ldq,
253 $ work( m+1 ), 1, cmplx( one ), work, 1 )
254 resid = max( resid, scasum( m, work, 1 ) )
255 80 CONTINUE
256 ELSE
257 DO 100 j = 1, n
258 CALL ccopy( 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 cgemv( 'No transpose', m, m, -cmplx( one ), q, ldq,
263 $ work( m+1 ), 1, cmplx( one ), work, 1 )
264 resid = max( resid, scasum( 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 = clange( '1', m, n, a, lda, rwork )
272 eps = slamch( '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 ) / ( real( n )*eps )
280 ELSE
281 IF( anorm.LT.one ) THEN
282 resid = ( min( resid, real( n )*anorm ) / anorm ) /
283 $ ( real( n )*eps )
284 ELSE
285 resid = min( resid / anorm, real( n ) ) /
286 $ ( real( n )*eps )
287 END IF
288 END IF
289 END IF
290*
291 RETURN
292*
293* End of CBDT01
294*
cmplx
float cmplx[2]
Definition pblas.h:136
clange
real function clange(norm, m, n, a, lda, work)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clange.f:115
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
cgemv
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
Definition cgemv.f:158
scasum
real function scasum(n, cx, incx)
SCASUM
Definition scasum.f:72
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ cbdt02()

subroutine cbdt02 ( integer m,
integer n,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldc, * ) c,
integer ldc,
complex, dimension( ldu, * ) u,
integer ldu,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real resid )

CBDT02

Purpose:
!>
!> CBDT02 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 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 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 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 array, dimension (M)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESID
!>          RESID is REAL
!>          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 cbdt02.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 REAL RESID
128* ..
129* .. Array Arguments ..
130 REAL RWORK( * )
131 COMPLEX B( LDB, * ), C( LDC, * ), U( LDU, * ),
132 $ WORK( * )
133* ..
134*
135* ======================================================================
136*
137* .. Parameters ..
138 REAL ZERO, ONE
139 parameter( zero = 0.0e+0, one = 1.0e+0 )
140* ..
141* .. Local Scalars ..
142 INTEGER J
143 REAL BNORM, EPS, REALMN
144* ..
145* .. External Functions ..
146 REAL CLANGE, SCASUM, SLAMCH
147 EXTERNAL clange, scasum, slamch
148* ..
149* .. External Subroutines ..
150 EXTERNAL ccopy, cgemv
151* ..
152* .. Intrinsic Functions ..
153 INTRINSIC cmplx, max, min, real
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 = real( max( m, n ) )
163 eps = slamch( 'Precision' )
164*
165* Compute norm(B - U * C)
166*
167 DO 10 j = 1, n
168 CALL ccopy( m, b( 1, j ), 1, work, 1 )
169 CALL cgemv( 'No transpose', m, m, -cmplx( one ), u, ldu,
170 $ c( 1, j ), 1, cmplx( one ), work, 1 )
171 resid = max( resid, scasum( m, work, 1 ) )
172 10 CONTINUE
173*
174* Compute norm of B.
175*
176 bnorm = clange( '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 CBDT02
196*

◆ cbdt03()

subroutine cbdt03 ( character uplo,
integer n,
integer kd,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( ldu, * ) u,
integer ldu,
real, dimension( * ) s,
complex, dimension( ldvt, * ) vt,
integer ldvt,
complex, dimension( * ) work,
real resid )

CBDT03

Purpose:
!>
!> CBDT03 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 REAL array, dimension (N)
!>          The n diagonal elements of the bidiagonal matrix B.
!>
[in]E
!>          E is REAL 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 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 REAL array, dimension (N)
!>          The singular values from the SVD of B, sorted in decreasing
!>          order.
!>
[in]VT
!>          VT is COMPLEX 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 array, dimension (2*N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cbdt03.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 REAL RESID
144* ..
145* .. Array Arguments ..
146 REAL D( * ), E( * ), S( * )
147 COMPLEX U( LDU, * ), VT( LDVT, * ), WORK( * )
148* ..
149*
150* ======================================================================
151*
152* .. Parameters ..
153 REAL ZERO, ONE
154 parameter( zero = 0.0e+0, one = 1.0e+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER I, J
158 REAL BNORM, EPS
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 INTEGER ISAMAX
163 REAL SCASUM, SLAMCH
164 EXTERNAL lsame, isamax, scasum, slamch
165* ..
166* .. External Subroutines ..
167 EXTERNAL cgemv
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, cmplx, max, min, real
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 cgemv( 'No transpose', n, n, -cmplx( one ), u, ldu,
196 $ work( n+1 ), 1, cmplx( 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, scasum( 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 cgemv( 'No transpose', n, n, -cmplx( one ), u, ldu,
215 $ work( n+1 ), 1, cmplx( 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, scasum( 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 cgemv( 'No transpose', n, n, -cmplx( one ), u, ldu,
235 $ work( n+1 ), 1, cmplx( zero ), work, 1 )
236 work( j ) = work( j ) + d( j )
237 resid = max( resid, scasum( n, work, 1 ) )
238 60 CONTINUE
239 j = isamax( 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 = slamch( '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 ) / ( real( n )*eps )
253 ELSE
254 IF( bnorm.LT.one ) THEN
255 resid = ( min( resid, real( n )*bnorm ) / bnorm ) /
256 $ ( real( n )*eps )
257 ELSE
258 resid = min( resid / bnorm, real( n ) ) /
259 $ ( real( n )*eps )
260 END IF
261 END IF
262 END IF
263*
264 RETURN
265*
266* End of CBDT03
267*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71

◆ cchkbb()

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

CCHKBB

Purpose:
!>
!> CCHKBB tests the reduction of a general complex rectangular band
!> matrix to real bidiagonal form.
!>
!> CGBBRD factors a general band matrix A as  Q B P* , where * means
!> conjugate transpose, B is upper bidiagonal, and Q and P are unitary;
!> CGBBRD 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, CCHKBB 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,
!>          CCHKBB 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, CCHKBB
!>          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 CCHKBB to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 REAL 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 REAL 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 REAL array, dimension (max(NN))
!>          Used to hold the diagonal of the bidiagonal matrix computed
!>          by CGBBRD.
!>
[out]BE
!>          BE is REAL array, dimension (max(NN))
!>          Used to hold the off-diagonal of the bidiagonal matrix
!>          computed by CGBBRD.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDQ, max(NN))
!>          Used to hold the unitary matrix Q computed by CGBBRD.
!>
[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 array, dimension (LDP, max(NN))
!>          Used to hold the unitary matrix P computed by CGBBRD.
!>
[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 array, dimension (LDC, max(NN))
!>          Used to hold the matrix C updated by CGBBRD.
!>
[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 array, dimension (LDC, max(NN))
!>          Used to hold a copy of the matrix C.
!>
[out]WORK
!>          WORK is COMPLEX 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 REAL array, dimension (max(NN))
!>
[out]RESULT
!>          RESULT is REAL 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 cchkbb.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 REAL THRESH
370* ..
371* .. Array Arguments ..
372 LOGICAL DOTYPE( * )
373 INTEGER ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * )
374 REAL BD( * ), BE( * ), RESULT( * ), RWORK( * )
375 COMPLEX A( LDA, * ), AB( LDAB, * ), C( LDC, * ),
376 $ CC( LDC, * ), P( LDP, * ), Q( LDQ, * ),
377 $ WORK( * )
378* ..
379*
380* =====================================================================
381*
382* .. Parameters ..
383 COMPLEX CZERO, CONE
384 parameter( czero = ( 0.0e+0, 0.0e+0 ),
385 $ cone = ( 1.0e+0, 0.0e+0 ) )
386 REAL ZERO, ONE
387 parameter( zero = 0.0e+0, one = 1.0e+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 REAL 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 REAL SLAMCH
406 EXTERNAL slamch
407* ..
408* .. External Subroutines ..
409 EXTERNAL cbdt01, cbdt02, cgbbrd, clacpy, claset, clatmr,
410 $ clatms, cunt01, slahd2, slasum, xerbla
411* ..
412* .. Intrinsic Functions ..
413 INTRINSIC abs, max, min, real, 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( 'CCHKBB', -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 = slamch( 'Safe minimum' )
496 ovfl = one / unfl
497 ulp = slamch( 'Epsilon' )*slamch( '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 / real( 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 claset( 'Full', lda, n, czero, czero, a, lda )
576 CALL claset( '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 clatms( 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 clatms( 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 clatmr( 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 clatmr( 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 clacpy( 'Full', m, nrhs, c, ldc, cc, ldc )
653*
654* Call CGBBRD to compute B, Q and P, and to update C.
655*
656 CALL cgbbrd( '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 )'CGBBRD', 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 cbdt01( m, n, -1, a, lda, q, ldq, bd, be, p, ldp,
678 $ work, rwork, result( 1 ) )
679 CALL cunt01( 'Columns', m, m, q, ldq, work, lwork, rwork,
680 $ result( 2 ) )
681 CALL cunt01( 'Rows', n, n, p, ldp, work, lwork, rwork,
682 $ result( 3 ) )
683 CALL cbdt02( 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 slahd2( nounit, 'CBB' )
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 slasum( 'CBB', nounit, nerrs, ntestt )
711 RETURN
712*
713 9999 FORMAT( ' CCHKBB: ', 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 CCHKBB
720*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
cgbbrd
subroutine cgbbrd(vect, m, n, ncc, kl, ku, ab, ldab, d, e, q, ldq, pt, ldpt, c, ldc, work, rwork, info)
CGBBRD
Definition cgbbrd.f:193
clacpy
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
Definition clacpy.f:103
claset
subroutine claset(uplo, m, n, alpha, beta, a, lda)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition claset.f:106
cbdt01
subroutine cbdt01(m, n, kd, a, lda, q, ldq, d, e, pt, ldpt, work, rwork, resid)
CBDT01
Definition cbdt01.f:147
cunt01
subroutine cunt01(rowcol, m, n, u, ldu, work, lwork, rwork, resid)
CUNT01
Definition cunt01.f:126
cbdt02
subroutine cbdt02(m, n, b, ldb, c, ldc, u, ldu, work, rwork, resid)
CBDT02
Definition cbdt02.f:120
clatms
subroutine clatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
CLATMS
Definition clatms.f:332
clatmr
subroutine clatmr(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)
CLATMR
Definition clatmr.f:490
slahd2
subroutine slahd2(iounit, path)
SLAHD2
Definition slahd2.f:65
slasum
subroutine slasum(type, iounit, ie, nrun)
SLASUM
Definition slasum.f:41

◆ cchkbd()

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

CCHKBD

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

◆ cchkbk()

subroutine cchkbk ( integer nin,
integer nout )

CCHKBK

Purpose:
!>
!> CCHKBK tests CGEBAK, a routine for backward transformation of
!> the computed right or left eigenvectors if the original matrix
!> was preprocessed by balance subroutine CGEBAL.
!>
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 cchkbk.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 REAL ZERO
70 parameter( zero = 0.0e0 )
71* ..
72* .. Local Scalars ..
73 INTEGER I, IHI, ILO, INFO, J, KNT, N, NINFO
74 REAL EPS, RMAX, SAFMIN, VMAX, X
75 COMPLEX CDUM
76* ..
77* .. Local Arrays ..
78 INTEGER LMAX( 2 )
79 REAL SCALE( LDE )
80 COMPLEX E( LDE, LDE ), EIN( LDE, LDE )
81* ..
82* .. External Functions ..
83 REAL SLAMCH
84 EXTERNAL slamch
85* ..
86* .. External Subroutines ..
87 EXTERNAL cgebak
88* ..
89* .. Intrinsic Functions ..
90 INTRINSIC abs, aimag, max, real
91* ..
92* .. Statement Functions ..
93 REAL CABS1
94* ..
95* .. Statement Function definitions ..
96 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( 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 = slamch( 'E' )
106 safmin = slamch( '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 cgebak( '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 CGEBAK .. ' )
152*
153 WRITE( nout, fmt = 9998 )rmax
154 9998 FORMAT( 1x, 'value of largest test error = ', e12.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 CCHKBK
167*
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2942
cgebak
subroutine cgebak(job, side, n, ilo, ihi, scale, m, v, ldv, info)
CGEBAK
Definition cgebak.f:131

◆ cchkbl()

subroutine cchkbl ( integer nin,
integer nout )

CCHKBL

Purpose:
!>
!> CCHKBL tests CGEBAL, 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 cchkbl.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 REAL ZERO
69 parameter( zero = 0.0e+0 )
70* ..
71* .. Local Scalars ..
72 INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
73 $ NINFO
74 REAL ANORM, MEPS, RMAX, SFMIN, TEMP, VMAX
75 COMPLEX CDUM
76* ..
77* .. Local Arrays ..
78 INTEGER LMAX( 3 )
79 REAL DUMMY( 1 ), SCALE( LDA ), SCALIN( LDA )
80 COMPLEX A( LDA, LDA ), AIN( LDA, LDA )
81* ..
82* .. External Functions ..
83 REAL CLANGE, SLAMCH
84 EXTERNAL clange, slamch
85* ..
86* .. External Subroutines ..
87 EXTERNAL cgebal
88* ..
89* .. Intrinsic Functions ..
90 INTRINSIC abs, aimag, max, real
91* ..
92* .. Statement Functions ..
93 REAL CABS1
94* ..
95* .. Statement Function definitions ..
96 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( 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 = slamch( 'S' )
108 meps = slamch( '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 = clange( 'M', n, n, a, lda, dummy )
126 knt = knt + 1
127 CALL cgebal( '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 CGEBAL .. ' )
164*
165 WRITE( nout, fmt = 9998 )rmax
166 9998 FORMAT( 1x, 'value of largest test error = ', e12.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 CCHKBL
181*
cgebal
subroutine cgebal(job, n, a, lda, ilo, ihi, scale, info)
CGEBAL
Definition cgebal.f:161

◆ cchkec()

subroutine cchkec ( real thresh,
logical tsterr,
integer nin,
integer nout )

CCHKEC

Purpose:
!>
!> CCHKEC tests eigen- condition estimation routines
!>        CTRSYL, 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, CTRSNA 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 REAL
!>          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 cchkec.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 REAL 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 REAL EPS, RTREXC, RTRSYL, SFMIN
94* ..
95* .. Local Arrays ..
96 INTEGER LTRSEN( 3 ), LTRSNA( 3 ), NTRSEN( 3 ),
97 $ NTRSNA( 3 )
98 REAL RTRSEN( 3 ), RTRSNA( 3 )
99* ..
100* .. External Subroutines ..
101 EXTERNAL cerrec, cget35, cget36, cget37, cget38
102* ..
103* .. External Functions ..
104 REAL SLAMCH
105 EXTERNAL slamch
106* ..
107* .. Executable Statements ..
108*
109 path( 1: 1 ) = 'Complex precision'
110 path( 2: 3 ) = 'EC'
111 eps = slamch( 'P' )
112 sfmin = slamch( '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 cerrec( path, nout )
121*
122 ok = .true.
123 CALL cget35( 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 cget36( 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 cget37( 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 cget38( 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 CTRSYL: RMAX =', e12.3, / ' LMAX = ', i8,
156 $ ' NINFO=', i8, ' KNT=', i8 )
157 9998 FORMAT( ' Error in CTREXC: RMAX =', e12.3, / ' LMAX = ', i8,
158 $ ' NINFO=', i8, ' KNT=', i8 )
159 9997 FORMAT( ' Error in CTRSNA: RMAX =', 3e12.3, / ' LMAX = ',
160 $ 3i8, ' NINFO=', 3i8, ' KNT=', i8 )
161 9996 FORMAT( ' Error in CTRSEN: RMAX =', 3e12.3, / ' LMAX = ',
162 $ 3i8, ' 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', / ' CTRSYL, CTREXC, CTRSNA, CTRSEN',
167 $ / )
168 9993 FORMAT( ' Relative machine precision (EPS) = ', e16.6,
169 $ / ' Safe minimum (SFMIN) = ', e16.6, / )
170 9992 FORMAT( ' Routines pass computational tests if test ratio is ',
171 $ 'less than', f8.2, / / )
172 RETURN
173*
174* End of CCHKEC
175*
cget36
subroutine cget36(rmax, lmax, ninfo, knt, nin)
CGET36
Definition cget36.f:85
cget37
subroutine cget37(rmax, lmax, ninfo, knt, nin)
CGET37
Definition cget37.f:90
cget35
subroutine cget35(rmax, lmax, ninfo, knt, nin)
CGET35
Definition cget35.f:84
cerrec
subroutine cerrec(path, nunit)
CERREC
Definition cerrec.f:56
cget38
subroutine cget38(rmax, lmax, ninfo, knt, nin)
CGET38
Definition cget38.f:91

◆ cchkee()

program cchkee

CCHKEE

Purpose:
!>
!> CCHKEE tests the COMPLEX LAPACK subroutines for the matrix
!> eigenvalue problem.  The test paths in this version are
!>
!> NEP (Nonsymmetric Eigenvalue Problem):
!>     Test CGEHRD, CUNGHR, CHSEQR, CTREVC, CHSEIN, and CUNMHR
!>
!> SEP (Hermitian Eigenvalue Problem):
!>     Test CHETRD, CUNGTR, CSTEQR, CSTERF, CSTEIN, CSTEDC,
!>     and drivers CHEEV(X), CHBEV(X), CHPEV(X),
!>                 CHEEVD,   CHBEVD,   CHPEVD
!>
!> SVD (Singular Value Decomposition):
!>     Test CGEBRD, CUNGBR, and CBDSQR
!>     and the drivers CGESVD, CGESDD
!>
!> CEV (Nonsymmetric Eigenvalue/eigenvector Driver):
!>     Test CGEEV
!>
!> CES (Nonsymmetric Schur form Driver):
!>     Test CGEES
!>
!> CVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver):
!>     Test CGEEVX
!>
!> CSX (Nonsymmetric Schur form Expert Driver):
!>     Test CGEESX
!>
!> CGG (Generalized Nonsymmetric Eigenvalue Problem):
!>     Test CGGHD3, CGGBAL, CGGBAK, CHGEQZ, and CTGEVC
!>
!> CGS (Generalized Nonsymmetric Schur form Driver):
!>     Test CGGES
!>
!> CGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver):
!>     Test CGGEV
!>
!> CGX (Generalized Nonsymmetric Schur form Expert Driver):
!>     Test CGGESX
!>
!> CXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver):
!>     Test CGGEVX
!>
!> CSG (Hermitian Generalized Eigenvalue Problem):
!>     Test CHEGST, CHEGV, CHEGVD, CHEGVX, CHPGST, CHPGV, CHPGVD,
!>     CHPGVX, CHBGST, CHBGV, CHBGVD, and CHBGVX
!>
!> CHB (Hermitian Band Eigenvalue Problem):
!>     Test CHBTRD
!>
!> CBB (Band Singular Value Decomposition):
!>     Test CGBBRD
!>
!> CEC (Eigencondition estimation):
!>     Test CTRSYL, CTREXC, CTRSNA, and CTRSEN
!>
!> CBL (Balancing a general matrix)
!>     Test CGEBAL
!>
!> CBK (Back transformation on a balanced matrix)
!>     Test CGEBAK
!>
!> CGL (Balancing a matrix pair)
!>     Test CGGBAL
!>
!> CGK (Back transformation on a matrix pair)
!>     Test CGGBAK
!>
!> GLM (Generalized Linear Regression Model):
!>     Tests CGGGLM
!>
!> GQR (Generalized QR and RQ factorizations):
!>     Tests CGGQRF and CGGRQF
!>
!> GSV (Generalized Singular Value Decomposition):
!>     Tests CGGSVD, CGGSVP, CTGSJA, CLAGS2, CLAPLL, and CLAPMT
!>
!> CSD (CS decomposition):
!>     Tests CUNCSD
!>
!> LSE (Constrained Linear Least Squares):
!>     Tests CGGLSE
!>
!> 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
!>
!> CHS or NEP      21     CCHKHS
!> CST or SEP      21     CCHKST (routines)
!>                 18     CDRVST (drivers)
!> CBD or SVD      16     CCHKBD (routines)
!>                  5     CDRVBD (drivers)
!> CEV             21     CDRVEV
!> CES             21     CDRVES
!> CVX             21     CDRVVX
!> CSX             21     CDRVSX
!> CGG             26     CCHKGG (routines)
!> CGS             26     CDRGES
!> CGX              5     CDRGSX
!> CGV             26     CDRGEV
!> CXV              2     CDRGVX
!> CSG             21     CDRVSG
!> CHB             15     CCHKHB
!> CBB             15     CCHKBB
!> CEC              -     CCHKEC
!> CBL              -     CCHKBL
!> CBK              -     CCHKBK
!> CGL              -     CCHKGL
!> CGK              -     CCHKGK
!> GLM              8     CCKGLM
!> GQR              8     CCKGQR
!> GSV              8     CCKGSV
!> CSD              3     CCKCSD
!> LSE              8     CCKLSE
!>
!>-----------------------------------------------------------------------
!>
!> 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 'CHS' for the
!>          nonsymmetric eigenvalue routines.
!>
!>-----------------------------------------------------------------------
!>
!> SEP or CSG 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 'CST' for the
!>          Hermitian eigenvalue routines and driver routines, and
!>          'CSG' 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 'CBD' for both the
!>          SVD routines and the SVD driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> CEV and CES data files:
!>
!> line 1:  'CEV' or 'CES' 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 'CEV' to test CGEEV, or
!>          'CES' to test CGEES.
!>
!>-----------------------------------------------------------------------
!>
!> The CVX data has two parts. The first part is identical to CEV,
!> and the second part consists of test matrices with precomputed
!> solutions.
!>
!> line 1:  'CVX' 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 'CVX' 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 CSX data is like CVX. The first part is identical to CEV, and the
!> second part consists of test matrices with precomputed solutions.
!>
!> line 1:  'CSX' 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 'CSX' 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.
!>
!>-----------------------------------------------------------------------
!>
!> CGG 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 'CGG' for the generalized
!>          eigenvalue problem routines and driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> CGS and CGV input files:
!>
!> line 1:  'CGS' or 'CGV' 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 'CGS' for the generalized
!>          eigenvalue problem routines and driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> CGX input file:
!> line 1:  'CGX' 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.
!>
!>-----------------------------------------------------------------------
!>
!> CXV input files:
!> line 1:  'CXV' 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.
!>
!>-----------------------------------------------------------------------
!>
!> CHB 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 'CHB'.
!>
!>-----------------------------------------------------------------------
!>
!> CBB 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 'CBB'.
!>
!>-----------------------------------------------------------------------
!>
!> CEC 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.
!>
!>-----------------------------------------------------------------------
!>
!> CBL and CBK input files:
!>
!> line 1:  'CBL' in columns 1-3 to test CGEBAL, or 'CBK' in
!>          columns 1-3 to test CGEBAK.
!>
!> The remaining lines consist of specially constructed test cases.
!>
!>-----------------------------------------------------------------------
!>
!> CGL and CGK input files:
!>
!> line 1:  'CGL' in columns 1-3 to test CGGBAL, or 'CGK' in
!>          columns 1-3 to test CGGBAK.
!>
!> 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 CGG.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 1033 of file cchkee.F.

◆ cchkgg()

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

CCHKGG

Purpose:
!>
!> CCHKGG  checks the nonsymmetric generalized eigenvalue problem
!> routines.
!>                                H          H        H
!> CGGHRD 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
!> CHGEQZ 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
!>
!> CTGEVC 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 CCHKGG 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
!>       STGEVC 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
!>       STGEVC 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,
!>          CCHKGG 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, CCHKGG
!>          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 CCHKGG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 REAL
!>          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 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 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 array, dimension (LDA, max(NN))
!>          The upper Hessenberg matrix computed from A by CGGHRD.
!>
[out]T
!>          T is COMPLEX array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by CGGHRD.
!>
[out]S1
!>          S1 is COMPLEX array, dimension (LDA, max(NN))
!>          The Schur (upper triangular) matrix computed from H by CHGEQZ
!>          when Q and Z are also computed.
!>
[out]S2
!>          S2 is COMPLEX array, dimension (LDA, max(NN))
!>          The Schur (upper triangular) matrix computed from H by CHGEQZ
!>          when Q and Z are not computed.
!>
[out]P1
!>          P1 is COMPLEX array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from T by CHGEQZ
!>          when Q and Z are also computed.
!>
[out]P2
!>          P2 is COMPLEX array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from T by CHGEQZ
!>          when Q and Z are not computed.
!>
[out]U
!>          U is COMPLEX array, dimension (LDU, max(NN))
!>          The (left) unitary matrix computed by CGGHRD.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U, V, Q, Z, EVECTL, and EVECTR.  It
!>          must be at least 1 and at least max( NN ).
!>
[out]V
!>          V is COMPLEX array, dimension (LDU, max(NN))
!>          The (right) unitary matrix computed by CGGHRD.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDU, max(NN))
!>          The (left) unitary matrix computed by CHGEQZ.
!>
[out]Z
!>          Z is COMPLEX array, dimension (LDU, max(NN))
!>          The (left) unitary matrix computed by CHGEQZ.
!>
[out]ALPHA1
!>          ALPHA1 is COMPLEX array, dimension (max(NN))
!>
[out]BETA1
!>          BETA1 is COMPLEX array, dimension (max(NN))
!>          The generalized eigenvalues of (A,B) computed by CHGEQZ
!>          when Q, Z, and the full Schur matrices are computed.
!>
[out]ALPHA3
!>          ALPHA3 is COMPLEX array, dimension (max(NN))
!>
[out]BETA3
!>          BETA3 is COMPLEX array, dimension (max(NN))
!>          The generalized eigenvalues of (A,B) computed by CHGEQZ
!>          when neither Q, Z, nor the Schur matrices are computed.
!>
[out]EVECTL
!>          EVECTL is COMPLEX array, dimension (LDU, max(NN))
!>          The (lower triangular) left eigenvector matrix for the
!>          matrices in S1 and P1.
!>
[out]EVECTR
!>          EVECTR is COMPLEX array, dimension (LDU, max(NN))
!>          The (upper triangular) right eigenvector matrix for the
!>          matrices in S1 and P1.
!>
[out]WORK
!>          WORK is COMPLEX 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 REAL array, dimension (2*max(NN))
!>
[out]LLWORK
!>          LLWORK is LOGICAL array, dimension (max(NN))
!>
[out]RESULT
!>          RESULT is REAL 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 cchkgg.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 REAL THRESH, THRSHN
512* ..
513* .. Array Arguments ..
514 LOGICAL DOTYPE( * ), LLWORK( * )
515 INTEGER ISEED( 4 ), NN( * )
516 REAL RESULT( 15 ), RWORK( * )
517 COMPLEX 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 REAL ZERO, ONE
530 parameter( zero = 0.0e+0, one = 1.0e+0 )
531 COMPLEX CZERO, CONE
532 parameter( czero = ( 0.0e+0, 0.0e+0 ),
533 $ cone = ( 1.0e+0, 0.0e+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 REAL ANORM, BNORM, SAFMAX, SAFMIN, TEMP1, TEMP2,
543 $ ULP, ULPINV
544 COMPLEX 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 REAL DUMMA( 4 ), RMAGN( 0: 3 )
554 COMPLEX CDUMMA( 4 )
555* ..
556* .. External Functions ..
557 REAL CLANGE, SLAMCH
558 COMPLEX CLARND
559 EXTERNAL clange, slamch, clarnd
560* ..
561* .. External Subroutines ..
562 EXTERNAL cgeqr2, cget51, cget52, cgghrd, chgeqz, clacpy,
563 $ clarfg, claset, clatm4, ctgevc, cunm2r, slabad,
564 $ slasum, xerbla
565* ..
566* .. Intrinsic Functions ..
567 INTRINSIC abs, conjg, max, min, real, 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( 'CCHKGG', -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 = slamch( 'Safe minimum' )
639 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
640 safmin = safmin / ulp
641 safmax = one / safmin
642 CALL slabad( 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 / real( 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* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
691* =3 means random.
692* KATYPE: the "type" to be passed to CLATM4 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 claset( 'Full', n, n, czero, czero, a, lda )
718 ELSE
719 in = n
720 END IF
721 CALL clatm4( 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 claset( 'Full', n, n, czero, czero, b, lda )
736 ELSE
737 in = n
738 END IF
739 CALL clatm4( 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 CLARFG 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 ) = clarnd( 3, iseed )
759 v( jr, jc ) = clarnd( 3, iseed )
760 40 CONTINUE
761 CALL clarfg( n+1-jc, u( jc, jc ), u( jc+1, jc ), 1,
762 $ work( jc ) )
763 work( 2*n+jc ) = sign( one, real( u( jc, jc ) ) )
764 u( jc, jc ) = cone
765 CALL clarfg( n+1-jc, v( jc, jc ), v( jc+1, jc ), 1,
766 $ work( n+jc ) )
767 work( 3*n+jc ) = sign( one, real( v( jc, jc ) ) )
768 v( jc, jc ) = cone
769 50 CONTINUE
770 ctemp = clarnd( 3, iseed )
771 u( n, n ) = cone
772 work( n ) = czero
773 work( 3*n ) = ctemp / abs( ctemp )
774 ctemp = clarnd( 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 $ conjg( work( 3*n+jc ) )*
785 $ a( jr, jc )
786 b( jr, jc ) = work( 2*n+jr )*
787 $ conjg( work( 3*n+jc ) )*
788 $ b( jr, jc )
789 60 CONTINUE
790 70 CONTINUE
791 CALL cunm2r( '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 cunm2r( '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 cunm2r( '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 cunm2r( '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 $ clarnd( 4, iseed )
816 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
817 $ clarnd( 4, iseed )
818 80 CONTINUE
819 90 CONTINUE
820 END IF
821*
822 anorm = clange( '1', n, n, a, lda, rwork )
823 bnorm = clange( '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 CGEQR2, CUNM2R, and CGGHRD to compute H, T, U, and V
837*
838 CALL clacpy( ' ', n, n, a, lda, h, lda )
839 CALL clacpy( ' ', n, n, b, lda, t, lda )
840 ntest = 1
841 result( 1 ) = ulpinv
842*
843 CALL cgeqr2( n, n, t, lda, work, work( n+1 ), iinfo )
844 IF( iinfo.NE.0 ) THEN
845 WRITE( nounit, fmt = 9999 )'CGEQR2', iinfo, n, jtype,
846 $ ioldsd
847 info = abs( iinfo )
848 GO TO 210
849 END IF
850*
851 CALL cunm2r( '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 )'CUNM2R', iinfo, n, jtype,
855 $ ioldsd
856 info = abs( iinfo )
857 GO TO 210
858 END IF
859*
860 CALL claset( 'Full', n, n, czero, cone, u, ldu )
861 CALL cunm2r( '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 )'CUNM2R', iinfo, n, jtype,
865 $ ioldsd
866 info = abs( iinfo )
867 GO TO 210
868 END IF
869*
870 CALL cgghrd( '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 )'CGGHRD', 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 cget51( 1, n, a, lda, h, lda, u, ldu, v, ldu, work,
883 $ rwork, result( 1 ) )
884 CALL cget51( 1, n, b, lda, t, lda, u, ldu, v, ldu, work,
885 $ rwork, result( 2 ) )
886 CALL cget51( 3, n, b, lda, t, lda, u, ldu, u, ldu, work,
887 $ rwork, result( 3 ) )
888 CALL cget51( 3, n, b, lda, t, lda, v, ldu, v, ldu, work,
889 $ rwork, result( 4 ) )
890*
891* Call CHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests.
892*
893* Compute T1 and UZ
894*
895* Eigenvalues only
896*
897 CALL clacpy( ' ', n, n, h, lda, s2, lda )
898 CALL clacpy( ' ', n, n, t, lda, p2, lda )
899 ntest = 5
900 result( 5 ) = ulpinv
901*
902 CALL chgeqz( '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 )'CHGEQZ(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 clacpy( ' ', n, n, h, lda, s2, lda )
915 CALL clacpy( ' ', n, n, t, lda, p2, lda )
916*
917 CALL chgeqz( '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 )'CHGEQZ(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 clacpy( ' ', n, n, h, lda, s1, lda )
930 CALL clacpy( ' ', n, n, t, lda, p1, lda )
931*
932 CALL chgeqz( '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 )'CHGEQZ(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 cget51( 1, n, h, lda, s1, lda, q, ldu, z, ldu, work,
947 $ rwork, result( 5 ) )
948 CALL cget51( 1, n, t, lda, p1, lda, q, ldu, z, ldu, work,
949 $ rwork, result( 6 ) )
950 CALL cget51( 3, n, t, lda, p1, lda, q, ldu, q, ldu, work,
951 $ rwork, result( 7 ) )
952 CALL cget51( 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 ctgevc( '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 )'CTGEVC(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 ctgevc( '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 )'CTGEVC(L,S2)', iinfo, n,
996 $ jtype, ioldsd
997 info = abs( iinfo )
998 GO TO 210
999 END IF
1000*
1001 CALL cget52( .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', 'CTGEVC(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 clacpy( 'F', n, n, q, ldu, evectl, ldu )
1015 CALL ctgevc( '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 )'CTGEVC(L,B)', iinfo, n,
1019 $ jtype, ioldsd
1020 info = abs( iinfo )
1021 GO TO 210
1022 END IF
1023*
1024 CALL cget52( .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', 'CTGEVC(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 ctgevc( '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 )'CTGEVC(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 ctgevc( '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 )'CTGEVC(R,S2)', iinfo, n,
1071 $ jtype, ioldsd
1072 info = abs( iinfo )
1073 GO TO 210
1074 END IF
1075*
1076 CALL cget52( .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', 'CTGEVC(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 clacpy( 'F', n, n, z, ldu, evectr, ldu )
1090 CALL ctgevc( '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 )'CTGEVC(R,B)', iinfo, n,
1094 $ jtype, ioldsd
1095 info = abs( iinfo )
1096 GO TO 210
1097 END IF
1098*
1099 CALL cget52( .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', 'CTGEVC(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 cget51( 2, n, s1, lda, s2, lda, q, ldu, z, ldu,
1114 $ work, rwork, result( 13 ) )
1115 CALL cget51( 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 )'CGG'
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.0 ) 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 slasum( 'CGG', nounit, nerrs, ntestt )
1184 RETURN
1185*
1186 9999 FORMAT( ' CCHKGG: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1187 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1188*
1189 9998 FORMAT( ' CCHKGG: ', 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 CCHKGG 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, e10.3 )
1238*
1239* End of CCHKGG
1240*
ctgevc
subroutine ctgevc(side, howmny, select, n, s, lds, p, ldp, vl, ldvl, vr, ldvr, mm, m, work, rwork, info)
CTGEVC
Definition ctgevc.f:219
chgeqz
subroutine chgeqz(job, compq, compz, n, ilo, ihi, h, ldh, t, ldt, alpha, beta, q, ldq, z, ldz, work, lwork, rwork, info)
CHGEQZ
Definition chgeqz.f:284
cgeqr2
subroutine cgeqr2(m, n, a, lda, tau, work, info)
CGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition cgeqr2.f:130
clarfg
subroutine clarfg(n, alpha, x, incx, tau)
CLARFG generates an elementary reflector (Householder matrix).
Definition clarfg.f:106
cunm2r
subroutine cunm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
CUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...
Definition cunm2r.f:159
cgghrd
subroutine cgghrd(compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, info)
CGGHRD
Definition cgghrd.f:204
cget51
subroutine cget51(itype, n, a, lda, b, ldb, u, ldu, v, ldv, work, rwork, result)
CGET51
Definition cget51.f:155
clatm4
subroutine clatm4(itype, n, nz1, nz2, rsign, amagn, rcond, triang, idist, iseed, a, lda)
CLATM4
Definition clatm4.f:171
cget52
subroutine cget52(left, n, a, lda, b, ldb, e, lde, alpha, beta, work, rwork, result)
CGET52
Definition cget52.f:161
clarnd
complex function clarnd(idist, iseed)
CLARND
Definition clarnd.f:75
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ cchkgk()

subroutine cchkgk ( integer nin,
integer nout )

CCHKGK

Purpose:
!>
!> CCHKGK tests CGGBAK, 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 cchkgk.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 REAL ZERO
72 parameter( zero = 0.0e+0 )
73 COMPLEX CZERO, CONE
74 parameter( czero = ( 0.0e+0, 0.0e+0 ),
75 $ cone = ( 1.0e+0, 0.0e+0 ) )
76* ..
77* .. Local Scalars ..
78 INTEGER I, IHI, ILO, INFO, J, KNT, M, N, NINFO
79 REAL ANORM, BNORM, EPS, RMAX, VMAX
80 COMPLEX CDUM
81* ..
82* .. Local Arrays ..
83 INTEGER LMAX( 4 )
84 REAL LSCALE( LDA ), RSCALE( LDA ), RWORK( LRWORK )
85 COMPLEX 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 REAL CLANGE, SLAMCH
93 EXTERNAL clange, slamch
94* ..
95* .. External Subroutines ..
96 EXTERNAL cgemm, cggbak, cggbal, clacpy
97* ..
98* .. Intrinsic Functions ..
99 INTRINSIC abs, aimag, max, real
100* ..
101* .. Statement Functions ..
102 REAL CABS1
103* ..
104* .. Statement Function definitions ..
105 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( 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 = slamch( '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 = clange( 'M', n, n, a, lda, rwork )
143 bnorm = clange( 'M', n, n, b, ldb, rwork )
144*
145 CALL clacpy( 'FULL', n, n, a, lda, af, lda )
146 CALL clacpy( 'FULL', n, n, b, ldb, bf, ldb )
147*
148 CALL cggbal( '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 clacpy( 'FULL', n, m, vl, ldvl, vlf, ldvl )
156 CALL clacpy( 'FULL', n, m, vr, ldvr, vrf, ldvr )
157*
158 CALL cggbak( '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 cggbak( '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 CGGBAK
173*
174* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
175* where tilde(A) denotes the transformed matrix.
176*
177 CALL cgemm( 'N', 'N', n, m, n, cone, af, lda, vr, ldvr, czero,
178 $ work, ldwork )
179 CALL cgemm( 'C', 'N', m, m, n, cone, vl, ldvl, work, ldwork,
180 $ czero, e, lde )
181*
182 CALL cgemm( 'N', 'N', n, m, n, cone, a, lda, vrf, ldvr, czero,
183 $ work, ldwork )
184 CALL cgemm( '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 cgemm( 'N', 'N', n, m, n, cone, bf, ldb, vr, ldvr, czero,
202 $ work, ldwork )
203 CALL cgemm( 'C', 'N', m, m, n, cone, vl, ldvl, work, ldwork,
204 $ czero, e, lde )
205*
206 CALL cgemm( 'n', 'n', n, m, n, cone, b, ldb, vrf, ldvr, czero,
207 $ work, ldwork )
208 CALL cgemm( '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 CGGBAK .. ' )
229*
230 WRITE( nout, fmt = 9998 )rmax
231 9998 FORMAT( ' value of largest test error =', e12.3 )
232 WRITE( nout, fmt = 9997 )lmax( 1 )
233 9997 FORMAT( ' example number where CGGBAL info is not 0 =', i4 )
234 WRITE( nout, fmt = 9996 )lmax( 2 )
235 9996 FORMAT( ' example number where CGGBAK(L) info is not 0 =', i4 )
236 WRITE( nout, fmt = 9995 )lmax( 3 )
237 9995 FORMAT( ' example number where CGGBAK(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 CCHKGK
248*
cggbak
subroutine cggbak(job, side, n, ilo, ihi, lscale, rscale, m, v, ldv, info)
CGGBAK
Definition cggbak.f:148
cggbal
subroutine cggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, work, info)
CGGBAL
Definition cggbal.f:177

◆ cchkgl()

subroutine cchkgl ( integer nin,
integer nout )

CCHKGL

Purpose:
!>
!> CCHKGL tests CGGBAL, 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 cchkgl.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 REAL ZERO
68 parameter( zero = 0.0e+0 )
69* ..
70* .. Local Scalars ..
71 INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
72 $ NINFO
73 REAL ANORM, BNORM, EPS, RMAX, VMAX
74* ..
75* .. Local Arrays ..
76 INTEGER LMAX( 3 )
77 REAL LSCALE( LDA ), LSCLIN( LDA ), RSCALE( LDA ),
78 $ RSCLIN( LDA ), WORK( LWORK )
79 COMPLEX A( LDA, LDA ), AIN( LDA, LDA ), B( LDB, LDB ),
80 $ BIN( LDB, LDB )
81* ..
82* .. External Functions ..
83 REAL CLANGE, SLAMCH
84 EXTERNAL clange, slamch
85* ..
86* .. External Subroutines ..
87 EXTERNAL cggbal
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 = slamch( '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 = clange( 'M', n, n, a, lda, work )
128 bnorm = clange( 'M', n, n, b, ldb, work )
129*
130 knt = knt + 1
131*
132 CALL cggbal( '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 CGGBAL .. ' )
171*
172 WRITE( nout, fmt = 9998 )rmax
173 9998 FORMAT( ' ratio of largest test error = ', e12.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 CCHKGL
188*

◆ cchkhb()

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

CCHKHB

Purpose:
!>
!> CCHKHB tests the reduction of a Hermitian band matrix to tridiagonal
!> from, used with the Hermitian eigenvalue problem.
!>
!> CHBTRD factors a Hermitian band matrix A as  U S U* , where * means
!> conjugate transpose, S is symmetric tridiagonal, and U is unitary.
!> CHBTRD can use either just the lower or just the upper triangle
!> of A; CCHKHB checks both cases.
!>
!> When CCHKHB 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 CHBTRD with
!>                                         UPLO='U'
!>
!> (2)     | I - UU* | / ( n ulp )
!>
!> (3)     | A - V S V* | / ( |A| n ulp )  computed by CHBTRD 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,
!>          CCHKHB 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,
!>          CCHKHB 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, CCHKHB
!>          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 CCHKHB to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 REAL array, dimension (max(NN))
!>          Used to hold the diagonal of the tridiagonal matrix computed
!>          by CHBTRD.
!>
[out]SE
!>          SE is REAL array, dimension (max(NN))
!>          Used to hold the off-diagonal of the tridiagonal matrix
!>          computed by CHBTRD.
!>
[out]U
!>          U is COMPLEX array, dimension (LDU, max(NN))
!>          Used to hold the unitary matrix computed by CHBTRD.
!>
[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 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 REAL array
!>
[out]RESULT
!>          RESULT is REAL 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 cchkhb.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 REAL THRESH
307* ..
308* .. Array Arguments ..
309 LOGICAL DOTYPE( * )
310 INTEGER ISEED( 4 ), KK( * ), NN( * )
311 REAL RESULT( * ), RWORK( * ), SD( * ), SE( * )
312 COMPLEX A( LDA, * ), U( LDU, * ), WORK( * )
313* ..
314*
315* =====================================================================
316*
317* .. Parameters ..
318 COMPLEX CZERO, CONE
319 parameter( czero = ( 0.0e+0, 0.0e+0 ),
320 $ cone = ( 1.0e+0, 0.0e+0 ) )
321 REAL ZERO, ONE, TWO, TEN
322 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
323 $ ten = 10.0e+0 )
324 REAL 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 REAL 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 REAL SLAMCH
343 EXTERNAL slamch
344* ..
345* .. External Subroutines ..
346 EXTERNAL chbt21, chbtrd, clacpy, clatmr, clatms, claset,
347 $ slasum, xerbla
348* ..
349* .. Intrinsic Functions ..
350 INTRINSIC abs, conjg, max, min, real, 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( 'CCHKHB', -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 = slamch( 'Safe minimum' )
418 ovfl = one / unfl
419 ulp = slamch( 'Epsilon' )*slamch( '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 / real( 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 claset( '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 clatms( 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 clatms( 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 clatmr( 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 clatmr( 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 clatms( 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 clatms( 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 CHBTRD to compute S and U from upper triangle.
595*
596 CALL clacpy( ' ', k+1, n, a, lda, work, lda )
597*
598 ntest = 1
599 CALL chbtrd( '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 )'CHBTRD(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 chbt21( '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 ) = conjg( 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 CHBTRD to compute S and U from lower triangle
634*
635 CALL clacpy( ' ', k+1, n, a, lda, work, lda )
636*
637 ntest = 3
638 CALL chbtrd( '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 )'CHBTRD(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 chbt21( '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 )'CHB'
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 slasum( 'CHB', nounit, nerrs, ntestt )
693 RETURN
694*
695 9999 FORMAT( ' CCHKHB: ', 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 SCHK23 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 CCHKHB
730*
chbtrd
subroutine chbtrd(vect, uplo, n, kd, ab, ldab, d, e, q, ldq, work, info)
CHBTRD
Definition chbtrd.f:163
chbt21
subroutine chbt21(uplo, n, ka, ks, a, lda, d, e, u, ldu, work, rwork, result)
CHBT21
Definition chbt21.f:152

◆ cchkhb2stg()

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

CCHKHB2STG

Purpose:
!>
!> CCHKHB2STG tests the reduction of a Hermitian band matrix to tridiagonal
!> from, used with the Hermitian eigenvalue problem.
!>
!> CHBTRD factors a Hermitian band matrix A as  U S U* , where * means
!> conjugate transpose, S is symmetric tridiagonal, and U is unitary.
!> CHBTRD can use either just the lower or just the upper triangle
!> of A; CCHKHB2STG checks both cases.
!>
!> CHETRD_HB2ST factors a Hermitian band matrix A as  U S U* ,
!> where * means conjugate transpose, S is symmetric tridiagonal, and U is
!> unitary. CHETRD_HB2ST can use either just the lower or just
!> the upper triangle of A; CCHKHB2STG 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 CCHKHB2STG 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 CHBTRD with
!>                                         UPLO='U'
!>
!> (2)     | I - UU* | / ( n ulp )
!>
!> (3)     | A - V S V* | / ( |A| n ulp )  computed by CHBTRD 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
!>                                         CHETRD_HB2ST with UPLO='U'
!>
!> (6)     | D1 - D3 | / ( |D1| ulp )      where D1 is computed by
!>                                         DSBTRD with UPLO='U' and
!>                                         D3 is computed by
!>                                         CHETRD_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,
!>          CCHKHB2STG 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,
!>          CCHKHB2STG 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, CCHKHB2STG
!>          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 CCHKHB2STG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 REAL array, dimension (max(NN))
!>          Used to hold the diagonal of the tridiagonal matrix computed
!>          by CHBTRD.
!>
[out]SE
!>          SE is REAL array, dimension (max(NN))
!>          Used to hold the off-diagonal of the tridiagonal matrix
!>          computed by CHBTRD.
!>
[out]D1
!>          D1 is REAL array, dimension (max(NN))
!>          Used store eigenvalues resulting from the tridiagonal
!>          form using the DSBTRD.
!>
[out]D2
!>          D2 is REAL array, dimension (max(NN))
!>
[out]D3
!>          D3 is REAL array, dimension (max(NN))
!>
[out]U
!>          U is COMPLEX array, dimension (LDU, max(NN))
!>          Used to hold the unitary matrix computed by CHBTRD.
!>
[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 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 REAL array
!>
[out]RESULT
!>          RESULT is REAL 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 337 of file cchkhb2stg.f.

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

◆ cchkhs()

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

CCHKHS

Purpose:
!>
!>    CCHKHS  checks the nonsymmetric eigenvalue problem routines.
!>
!>            CGEHRD factors A as  U H U' , where ' means conjugate
!>            transpose, H is hessenberg, and U is unitary.
!>
!>            CUNGHR generates the unitary matrix U.
!>
!>            CUNMHR multiplies a matrix by the unitary matrix U.
!>
!>            CHSEQR 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.
!>
!>            CTREVC 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.
!>
!>            CHSEIN 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 CCHKHS 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,
!>           CCHKHS 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, CCHKHS
!>           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 CCHKHS to continue the same random number
!>           sequence.
!>           Modified.
!>
!>  THRESH - REAL
!>           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 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 array, dimension (LDA,max(NN))
!>           The upper hessenberg matrix computed by CGEHRD.  On exit,
!>           H contains the Hessenberg form of the matrix in A.
!>           Modified.
!>
!>  T1     - COMPLEX array, dimension (LDA,max(NN))
!>           The Schur (=) matrix computed by CHSEQR
!>           if Z is computed.  On exit, T1 contains the Schur form of
!>           the matrix in A.
!>           Modified.
!>
!>  T2     - COMPLEX array, dimension (LDA,max(NN))
!>           The Schur matrix computed by CHSEQR 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 array, dimension (LDU,max(NN))
!>           The unitary matrix computed by CGEHRD.
!>           Modified.
!>
!>  Z      - COMPLEX array, dimension (LDU,max(NN))
!>           The unitary matrix computed by CHSEQR.
!>           Modified.
!>
!>  UZ     - COMPLEX array, dimension (LDU,max(NN))
!>           The product of U times Z.
!>           Modified.
!>
!>  W1     - COMPLEX 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 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 CHSEIN.
!>           Modified.
!>
!>  EVECTL - COMPLEX array, dimension (LDU,max(NN))
!>           The conjugate transpose of the (upper triangular) left
!>           eigenvector matrix for the matrix in T1.
!>           Modified.
!>
!>  EVECTR - COMPLEX array, dimension (LDU,max(NN))
!>           The (upper triangular) right eigenvector matrix for the
!>           matrix in T1.
!>           Modified.
!>
!>  EVECTY - COMPLEX array, dimension (LDU,max(NN))
!>           The conjugate transpose of the left eigenvector matrix
!>           for the matrix in H.
!>           Modified.
!>
!>  EVECTX - COMPLEX array, dimension (LDU,max(NN))
!>           The right eigenvector matrix for the matrix in H.
!>           Modified.
!>
!>  UU     - COMPLEX array, dimension (LDU,max(NN))
!>           Details of the unitary matrix computed by CGEHRD.
!>           Modified.
!>
!>  TAU    - COMPLEX array, dimension (max(NN))
!>           Further details of the unitary matrix computed by CGEHRD.
!>           Modified.
!>
!>  WORK   - COMPLEX array, dimension (NWORK)
!>           Workspace.
!>           Modified.
!>
!>  NWORK  - INTEGER
!>           The number of entries in WORK.  NWORK >= 4*NN(j)*NN(j) + 2.
!>
!>  RWORK  - REAL 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 - REAL 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  CLATMR, CLATMS, or CLATME returns an error code, the
!>               absolute value of it is returned.
!>           If 1, then CHSEQR 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 SLAFTS).
!>     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 cchkhs.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 REAL THRESH
420* ..
421* .. Array Arguments ..
422 LOGICAL DOTYPE( * ), SELECT( * )
423 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
424 REAL RESULT( 14 ), RWORK( * )
425 COMPLEX 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 REAL ZERO, ONE
437 parameter( zero = 0.0e+0, one = 1.0e+0 )
438 COMPLEX CZERO, CONE
439 parameter( czero = ( 0.0e+0, 0.0e+0 ),
440 $ cone = ( 1.0e+0, 0.0e+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 REAL 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 REAL DUMMA( 4 )
457 COMPLEX CDUMMA( 4 )
458* ..
459* .. External Functions ..
460 REAL SLAMCH
461 EXTERNAL slamch
462* ..
463* .. External Subroutines ..
464 EXTERNAL ccopy, cgehrd, cgemm, cget10, cget22, chsein,
465 $ chseqr, chst01, clacpy, claset, clatme, clatmr,
466 $ clatms, ctrevc, cunghr, cunmhr, slabad, slafts,
467 $ slasum, xerbla
468* ..
469* .. Intrinsic Functions ..
470 INTRINSIC abs, max, min, real, 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( 'CCHKHS', -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 = slamch( 'Safe minimum' )
526 ovfl = slamch( 'Overflow' )
527 CALL slabad( unfl, ovfl )
528 ulp = slamch( 'Epsilon' )*slamch( '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 / real( 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 claset( '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 clatmr( 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 clatms( 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 clatme( 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 clatmr( 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 clatmr( 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 clatmr( 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 clatmr( 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 CGEHRD to compute H and U, do tests.
723*
724 CALL clacpy( ' ', n, n, a, lda, h, lda )
725 ntest = 1
726*
727 ilo = 1
728 ihi = n
729*
730 CALL cgehrd( 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 )'CGEHRD', 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 ccopy( n-1, work, 1, tau, 1 )
750 CALL cunghr( n, ilo, ihi, u, ldu, work, work( n+1 ),
751 $ nwork-n, iinfo )
752 ntest = 2
753*
754 CALL chst01( n, ilo, ihi, a, lda, h, lda, u, ldu, work,
755 $ nwork, rwork, result( 1 ) )
756*
757* Call CHSEQR to compute T1, T2 and Z, do tests.
758*
759* Eigenvalues only (W3)
760*
761 CALL clacpy( ' ', n, n, h, lda, t2, lda )
762 ntest = 3
763 result( 3 ) = ulpinv
764*
765 CALL chseqr( '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 )'CHSEQR(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 clacpy( ' ', n, n, h, lda, t2, lda )
779*
780 CALL chseqr( '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 )'CHSEQR(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 clacpy( ' ', n, n, h, lda, t1, lda )
792 CALL clacpy( ' ', n, n, u, ldu, uz, ldu )
793*
794 CALL chseqr( '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 )'CHSEQR(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 cgemm( '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 chst01( 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 chst01( 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 cget10( 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 ctrevc( '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 )'CTREVC(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 cget22( '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', 'CTREVC',
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 ctrevc( '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 )'CTREVC(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', 'CTREVC', n, jtype,
899 $ ioldsd
900*
901* Compute the Left eigenvector Matrix:
902*
903 ntest = 10
904 result( 10 ) = ulpinv
905 CALL ctrevc( '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 )'CTREVC(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 cget22( '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', 'CTREVC', 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 ctrevc( '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 )'CTREVC(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', 'CTREVC', n, jtype,
952 $ ioldsd
953*
954* Call CHSEIN 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 chsein( '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 )'CHSEIN(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 cget22( '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', 'CHSEIN',
983 $ dumma( 2 ), n, jtype, ioldsd
984 END IF
985 END IF
986*
987* Call CHSEIN 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 chsein( '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 )'CHSEIN(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 cget22( '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', 'CHSEIN',
1016 $ dumma( 4 ), n, jtype, ioldsd
1017 END IF
1018 END IF
1019*
1020* Call CUNMHR for Right eigenvectors of A, do test 13
1021*
1022 ntest = 13
1023 result( 13 ) = ulpinv
1024*
1025 CALL cunmhr( '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 )'CUNMHR(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 cget22( '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 CUNMHR for Left eigenvectors of A, do test 14
1046*
1047 ntest = 14
1048 result( 14 ) = ulpinv
1049*
1050 CALL cunmhr( '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 )'CUNMHR(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 cget22( '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 slafts( 'CHS', n, n, jtype, ntest, result, ioldsd,
1076 $ thresh, nounit, nerrs )
1077*
1078 250 CONTINUE
1079 260 CONTINUE
1080*
1081* Summary
1082*
1083 CALL slasum( 'CHS', nounit, nerrs, ntestt )
1084*
1085 RETURN
1086*
1087 9999 FORMAT( ' CCHKHS: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1088 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1089 9998 FORMAT( ' CCHKHS: ', 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( ' CCHKHS: 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 CCHKHS
1098*
cgehrd
subroutine cgehrd(n, ilo, ihi, a, lda, tau, work, lwork, info)
CGEHRD
Definition cgehrd.f:167
cunghr
subroutine cunghr(n, ilo, ihi, a, lda, tau, work, lwork, info)
CUNGHR
Definition cunghr.f:126
chsein
subroutine chsein(side, eigsrc, initv, select, n, h, ldh, w, vl, ldvl, vr, ldvr, mm, m, work, rwork, ifaill, ifailr, info)
CHSEIN
Definition chsein.f:245
ctrevc
subroutine ctrevc(side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, rwork, info)
CTREVC
Definition ctrevc.f:218
chseqr
subroutine chseqr(job, compz, n, ilo, ihi, h, ldh, w, z, ldz, work, lwork, info)
CHSEQR
Definition chseqr.f:299
cunmhr
subroutine cunmhr(side, trans, m, n, ilo, ihi, a, lda, tau, c, ldc, work, lwork, info)
CUNMHR
Definition cunmhr.f:179
cget10
subroutine cget10(m, n, a, lda, b, ldb, work, rwork, result)
CGET10
Definition cget10.f:99
cget22
subroutine cget22(transa, transe, transw, n, a, lda, e, lde, w, work, rwork, result)
CGET22
Definition cget22.f:144
chst01
subroutine chst01(n, ilo, ihi, a, lda, h, ldh, q, ldq, work, lwork, rwork, result)
CHST01
Definition chst01.f:140
clatme
subroutine clatme(n, dist, iseed, d, mode, cond, dmax, rsign, upper, sim, ds, modes, conds, kl, ku, anorm, a, lda, work, info)
CLATME
Definition clatme.f:301
slafts
subroutine slafts(type, m, n, imat, ntests, result, iseed, thresh, iounit, ie)
SLAFTS
Definition slafts.f:99

◆ cchkst()

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

CCHKST

Purpose:
!>
!> CCHKST  checks the Hermitian eigenvalue problem routines.
!>
!>    CHETRD factors A as  U S U* , where * means conjugate transpose,
!>    S is real symmetric tridiagonal, and U is unitary.
!>    CHETRD can use either just the lower or just the upper triangle
!>    of A; CCHKST 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.
!>
!>    CHPTRD does the same as CHETRD, except that A and V are stored
!>    in  format.
!>
!>    CUNGTR constructs the matrix U from the contents of V and TAU.
!>
!>    CUPGTR constructs the matrix U from the contents of VP and TAU.
!>
!>    CSTEQR 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.
!>
!>    SSTERF computes D3, the matrix of eigenvalues, by the
!>    PWK method, which does not yield eigenvectors.
!>
!>    CPTEQR 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.
!>
!>    SSTEBZ 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.
!>
!>    CSTEIN computes Y, the eigenvectors of S, given the
!>    eigenvalues.
!>
!>    CSTEDC 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 CHETRD/CUNGTR or CHPTRD/CUPGTR ('V' option). It may
!>    also just compute eigenvalues ('N' option).
!>
!>    CSTEMR 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).  CSTEMR
!>    uses the Relatively Robust Representation whenever possible.
!>
!> When CCHKST 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 ) CHETRD( UPLO='U', ... )
!>
!> (2)     | I - UV* | / ( n ulp )        CUNGTR( UPLO='U', ... )
!>
!> (3)     | A - V S V* | / ( |A| n ulp ) CHETRD( UPLO='L', ... )
!>
!> (4)     | I - UV* | / ( n ulp )        CUNGTR( UPLO='L', ... )
!>
!> (5-8)   Same as 1-4, but for CHPTRD and CUPGTR.
!>
!> (9)     | S - Z D Z* | / ( |S| n ulp ) CSTEQR('V',...)
!>
!> (10)    | I - ZZ* | / ( n ulp )        CSTEQR('V',...)
!>
!> (11)    | D1 - D2 | / ( |D1| ulp )        CSTEQR('N',...)
!>
!> (12)    | D1 - D3 | / ( |D1| ulp )        SSTERF
!>
!> (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
!>         SSTECH)
!>
!> For S positive definite,
!>
!> (14)    | S - Z4 D4 Z4* | / ( |S| n ulp ) CPTEQR('V',...)
!>
!> (15)    | I - Z4 Z4* | / ( n ulp )        CPTEQR('V',...)
!>
!> (16)    | D4 - D5 | / ( 100 |D4| ulp )       CPTEQR('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
!>                                              SSTEBZ( 'A', 'E', ...)
!>
!> (18)    | WA1 - D3 | / ( |D3| ulp )          SSTEBZ( 'A', 'E', ...)
!>
!> (19)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>                                              SSTEBZ( 'I', 'E', ...)
!>
!> (20)    | S - Y WA1 Y* | / ( |S| n ulp )  SSTEBZ, CSTEIN
!>
!> (21)    | I - Y Y* | / ( n ulp )          SSTEBZ, CSTEIN
!>
!> (22)    | S - Z D Z* | / ( |S| n ulp )    CSTEDC('I')
!>
!> (23)    | I - ZZ* | / ( n ulp )           CSTEDC('I')
!>
!> (24)    | S - Z D Z* | / ( |S| n ulp )    CSTEDC('V')
!>
!> (25)    | I - ZZ* | / ( n ulp )           CSTEDC('V')
!>
!> (26)    | D1 - D2 | / ( |D1| ulp )           CSTEDC('V') and
!>                                              CSTEDC('N')
!>
!> Test 27 is disabled at the moment because CSTEMR 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
!>                                              CSTEMR('V', 'A')
!>
!> (28)    max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              CSTEMR('V', 'I')
!>
!> Tests 29 through 34 are disable at present because CSTEMR
!> does not handle partial spectrum requests.
!>
!> (29)    | S - Z D Z* | / ( |S| n ulp )    CSTEMR('V', 'I')
!>
!> (30)    | I - ZZ* | / ( n ulp )           CSTEMR('V', 'I')
!>
!> (31)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         CSTEMR('N', 'I') vs. CSTEMR('V', 'I')
!>
!> (32)    | S - Z D Z* | / ( |S| n ulp )    CSTEMR('V', 'V')
!>
!> (33)    | I - ZZ* | / ( n ulp )           CSTEMR('V', 'V')
!>
!> (34)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         CSTEMR('N', 'V') vs. CSTEMR('V', 'V')
!>
!> (35)    | S - Z D Z* | / ( |S| n ulp )    CSTEMR('V', 'A')
!>
!> (36)    | I - ZZ* | / ( n ulp )           CSTEMR('V', 'A')
!>
!> (37)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         CSTEMR('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,
!>          CCHKST 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, CCHKST
!>          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 CCHKST to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix A stored in packed format.
!>
[out]SD
!>          SD is REAL array of
!>                             dimension( max(NN) )
!>          The diagonal of the tridiagonal matrix computed by CHETRD.
!>          On exit, SD and SE contain the tridiagonal form of the
!>          matrix in A.
!>
[out]SE
!>          SE is REAL array of
!>                             dimension( max(NN) )
!>          The off-diagonal of the tridiagonal matrix computed by
!>          CHETRD.  On exit, SD and SE contain the tridiagonal form of
!>          the matrix in A.
!>
[out]D1
!>          D1 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by CSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>
[out]D2
!>          D2 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by CSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>
[out]D3
!>          D3 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>
[out]D4
!>          D4 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by CPTEQR(V).
!>          ZPTEQR factors S as  Z4 D4 Z4*
!>          On exit, the eigenvalues in D4 correspond with the matrix in A.
!>
[out]D5
!>          D5 is REAL 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 REAL array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>
[out]WA2
!>          WA2 is REAL array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>          Choose random values for IL and IU, and ask for the
!>          IL-th through IU-th eigenvalues.
!>
[out]WA3
!>          WA3 is REAL array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>          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 array of
!>                             dimension( LDU, max(NN) ).
!>          The unitary matrix computed by CHETRD + CUNGTR.
!>
[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 array of
!>                             dimension( LDU, max(NN) ).
!>          The Housholder vectors computed by CHETRD 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 CHETRD, 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 CUNGTR, set those entries to
!>          1 before using them, and then restore them later.)
!>
[out]VP
!>          VP is COMPLEX array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix V stored in packed format.
!>
[out]TAU
!>          TAU is COMPLEX array of
!>                             dimension( max(NN) )
!>          The Householder factors computed by CHETRD in reducing A
!>          to tridiagonal form.
!>
[out]Z
!>          Z is COMPLEX array of
!>                             dimension( LDU, max(NN) ).
!>          The unitary matrix of eigenvectors computed by CSTEQR,
!>          CPTEQR, and CSTEIN.
!>
[out]WORK
!>          WORK is COMPLEX 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 REAL array
!>
[in]LRWORK
!>          LRWORK is INTEGER
!>          The number of entries in LRWORK (dimension( ??? )
!>
[out]RESULT
!>          RESULT is REAL 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  CLATMR, CLATMS, CHETRD, CUNGTR, CSTEQR, SSTERF,
!>              or CUNMC2 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 cchkst.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 REAL THRESH
613* ..
614* .. Array Arguments ..
615 LOGICAL DOTYPE( * )
616 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
617 REAL D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
618 $ RESULT( * ), RWORK( * ), SD( * ), SE( * ),
619 $ WA1( * ), WA2( * ), WA3( * ), WR( * )
620 COMPLEX A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ),
621 $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * )
622* ..
623*
624* =====================================================================
625*
626* .. Parameters ..
627 REAL ZERO, ONE, TWO, EIGHT, TEN, HUN
628 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
629 $ eight = 8.0e0, ten = 10.0e0, hun = 100.0e0 )
630 COMPLEX CZERO, CONE
631 parameter( czero = ( 0.0e+0, 0.0e+0 ),
632 $ cone = ( 1.0e+0, 0.0e+0 ) )
633 REAL 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 REAL 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 REAL DUMMA( 1 )
658* ..
659* .. External Functions ..
660 INTEGER ILAENV
661 REAL SLAMCH, SLARND, SSXT1
662 EXTERNAL ilaenv, slamch, slarnd, ssxt1
663* ..
664* .. External Subroutines ..
665 EXTERNAL ccopy, chet21, chetrd, chpt21, chptrd, clacpy,
666 $ claset, clatmr, clatms, cpteqr, cstedc, cstemr,
667 $ cstein, csteqr, cstt21, cstt22, cungtr, cupgtr,
668 $ scopy, slabad, slasum, sstebz, sstech, ssterf,
669 $ xerbla
670* ..
671* .. Intrinsic Functions ..
672 INTRINSIC abs, conjg, int, log, max, min, real, 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, 'CHETRD', '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( 'CCHKST', -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 = slamch( 'Safe minimum' )
735 ovfl = one / unfl
736 CALL slabad( unfl, ovfl )
737 ulp = slamch( 'Epsilon' )*slamch( '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( real( 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 / real( 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 claset( '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 clatms( 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 clatms( 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 clatmr( 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 clatmr( 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 clatms( 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 clatms( 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 ) = conjg( 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 CHETRD and CUNGTR to compute S and U from
920* upper triangle.
921*
922 CALL clacpy( 'U', n, n, a, lda, v, ldu )
923*
924 ntest = 1
925 CALL chetrd( 'U', n, v, ldu, sd, se, tau, work, lwork,
926 $ iinfo )
927*
928 IF( iinfo.NE.0 ) THEN
929 WRITE( nounit, fmt = 9999 )'CHETRD(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 clacpy( 'U', n, n, v, ldu, u, ldu )
941*
942 ntest = 2
943 CALL cungtr( 'U', n, u, ldu, tau, work, lwork, iinfo )
944 IF( iinfo.NE.0 ) THEN
945 WRITE( nounit, fmt = 9999 )'CUNGTR(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 chet21( 2, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
959 $ ldu, tau, work, rwork, result( 1 ) )
960 CALL chet21( 3, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
961 $ ldu, tau, work, rwork, result( 2 ) )
962*
963* Call CHETRD and CUNGTR to compute S and U from
964* lower triangle, do tests.
965*
966 CALL clacpy( 'L', n, n, a, lda, v, ldu )
967*
968 ntest = 3
969 CALL chetrd( 'L', n, v, ldu, sd, se, tau, work, lwork,
970 $ iinfo )
971*
972 IF( iinfo.NE.0 ) THEN
973 WRITE( nounit, fmt = 9999 )'CHETRD(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 clacpy( 'L', n, n, v, ldu, u, ldu )
985*
986 ntest = 4
987 CALL cungtr( 'L', n, u, ldu, tau, work, lwork, iinfo )
988 IF( iinfo.NE.0 ) THEN
989 WRITE( nounit, fmt = 9999 )'CUNGTR(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 chet21( 2, 'Lower', n, 1, a, lda, sd, se, u, ldu, v,
1001 $ ldu, tau, work, rwork, result( 3 ) )
1002 CALL chet21( 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 CHPTRD and CUPGTR to compute S and U from AP
1016*
1017 CALL ccopy( nap, ap, 1, vp, 1 )
1018*
1019 ntest = 5
1020 CALL chptrd( 'U', n, vp, sd, se, tau, iinfo )
1021*
1022 IF( iinfo.NE.0 ) THEN
1023 WRITE( nounit, fmt = 9999 )'CHPTRD(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 cupgtr( 'U', n, vp, tau, u, ldu, work, iinfo )
1036 IF( iinfo.NE.0 ) THEN
1037 WRITE( nounit, fmt = 9999 )'CUPGTR(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 chpt21( 2, 'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1051 $ work, rwork, result( 5 ) )
1052 CALL chpt21( 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 CHPTRD and CUPGTR to compute S and U from AP
1066*
1067 CALL ccopy( nap, ap, 1, vp, 1 )
1068*
1069 ntest = 7
1070 CALL chptrd( 'L', n, vp, sd, se, tau, iinfo )
1071*
1072 IF( iinfo.NE.0 ) THEN
1073 WRITE( nounit, fmt = 9999 )'CHPTRD(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 cupgtr( 'L', n, vp, tau, u, ldu, work, iinfo )
1086 IF( iinfo.NE.0 ) THEN
1087 WRITE( nounit, fmt = 9999 )'CUPGTR(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 chpt21( 2, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1099 $ work, rwork, result( 7 ) )
1100 CALL chpt21( 3, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1101 $ work, rwork, result( 8 ) )
1102*
1103* Call CSTEQR to compute D1, D2, and Z, do tests.
1104*
1105* Compute D1 and Z
1106*
1107 CALL scopy( n, sd, 1, d1, 1 )
1108 IF( n.GT.0 )
1109 $ CALL scopy( n-1, se, 1, rwork, 1 )
1110 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1111*
1112 ntest = 9
1113 CALL csteqr( 'V', n, d1, rwork, z, ldu, rwork( n+1 ),
1114 $ iinfo )
1115 IF( iinfo.NE.0 ) THEN
1116 WRITE( nounit, fmt = 9999 )'CSTEQR(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 scopy( n, sd, 1, d2, 1 )
1130 IF( n.GT.0 )
1131 $ CALL scopy( n-1, se, 1, rwork, 1 )
1132*
1133 ntest = 11
1134 CALL csteqr( 'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1135 $ iinfo )
1136 IF( iinfo.NE.0 ) THEN
1137 WRITE( nounit, fmt = 9999 )'CSTEQR(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 scopy( n, sd, 1, d3, 1 )
1151 IF( n.GT.0 )
1152 $ CALL scopy( n-1, se, 1, rwork, 1 )
1153*
1154 ntest = 12
1155 CALL ssterf( n, d3, rwork, iinfo )
1156 IF( iinfo.NE.0 ) THEN
1157 WRITE( nounit, fmt = 9999 )'SSTERF', 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 cstt21( 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 sstech( 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 CPTEQR
1207* and do tests 14, 15, and 16 .
1208*
1209 IF( jtype.GT.15 ) THEN
1210*
1211* Compute D4 and Z4
1212*
1213 CALL scopy( n, sd, 1, d4, 1 )
1214 IF( n.GT.0 )
1215 $ CALL scopy( n-1, se, 1, rwork, 1 )
1216 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1217*
1218 ntest = 14
1219 CALL cpteqr( 'V', n, d4, rwork, z, ldu, rwork( n+1 ),
1220 $ iinfo )
1221 IF( iinfo.NE.0 ) THEN
1222 WRITE( nounit, fmt = 9999 )'CPTEQR(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 cstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1236 $ rwork, result( 14 ) )
1237*
1238* Compute D5
1239*
1240 CALL scopy( n, sd, 1, d5, 1 )
1241 IF( n.GT.0 )
1242 $ CALL scopy( n-1, se, 1, rwork, 1 )
1243*
1244 ntest = 16
1245 CALL cpteqr( 'N', n, d5, rwork, z, ldu, rwork( n+1 ),
1246 $ iinfo )
1247 IF( iinfo.NE.0 ) THEN
1248 WRITE( nounit, fmt = 9999 )'CPTEQR(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 SSTEBZ 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 sstebz( '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 )'SSTEBZ(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 sstebz( '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 )'SSTEBZ(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( slarnd( 1, iseed2 ) )
1358 iu = 1 + ( n-1 )*int( slarnd( 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 sstebz( '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 )'SSTEBZ(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 sstebz( '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 )'SSTEBZ(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1427 temp2 = ssxt1( 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 CSTEIN to compute eigenvectors corresponding to
1437* eigenvalues in WA1. (First call SSTEBZ again, to make sure
1438* it returns these eigenvalues in the correct order.)
1439*
1440 ntest = 21
1441 CALL sstebz( '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 )'SSTEBZ(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 cstein( 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 )'CSTEIN', 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 cstt21( n, 0, sd, se, wa1, dumma, z, ldu, work, rwork,
1476 $ result( 20 ) )
1477*
1478* Call CSTEDC(I) to compute D1 and Z, do tests.
1479*
1480* Compute D1 and Z
1481*
1482 inde = 1
1483 indrwk = inde + n
1484 CALL scopy( n, sd, 1, d1, 1 )
1485 IF( n.GT.0 )
1486 $ CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1487 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1488*
1489 ntest = 22
1490 CALL cstedc( '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 )'CSTEDC(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 cstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1507 $ result( 22 ) )
1508*
1509* Call CSTEDC(V) to compute D1 and Z, do tests.
1510*
1511* Compute D1 and Z
1512*
1513 CALL scopy( n, sd, 1, d1, 1 )
1514 IF( n.GT.0 )
1515 $ CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1516 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1517*
1518 ntest = 24
1519 CALL cstedc( '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 )'CSTEDC(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 cstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1536 $ result( 24 ) )
1537*
1538* Call CSTEDC(N) to compute D2, do tests.
1539*
1540* Compute D2
1541*
1542 CALL scopy( n, sd, 1, d2, 1 )
1543 IF( n.GT.0 )
1544 $ CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1545 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1546*
1547 ntest = 26
1548 CALL cstedc( '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 )'CSTEDC(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 CSTEMR if IEEE compliant
1575*
1576 IF( ilaenv( 10, 'CSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1577 $ ilaenv( 11, 'CSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
1578*
1579* Call CSTEMR, 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 cstemr( '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 )'CSTEMR(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( slarnd( 1, iseed2 ) )
1621 iu = 1 + ( n-1 )*int( slarnd( 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 cstemr( '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 )'CSTEMR(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 CSTEMR(V,I) to compute D1 and Z, do tests.
1670*
1671* Compute D1 and Z
1672*
1673 CALL scopy( n, sd, 1, d5, 1 )
1674 IF( n.GT.0 )
1675 $ CALL scopy( n-1, se, 1, rwork, 1 )
1676 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1677*
1678 IF( crange ) THEN
1679 ntest = 29
1680 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1681 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1682 IF( iu.LT.il ) THEN
1683 itemp = iu
1684 iu = il
1685 il = itemp
1686 END IF
1687 CALL cstemr( '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 )'CSTEMR(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 CSTEMR to compute D2, do tests.
1707*
1708* Compute D2
1709*
1710 CALL scopy( n, sd, 1, d5, 1 )
1711 IF( n.GT.0 )
1712 $ CALL scopy( n-1, se, 1, rwork, 1 )
1713*
1714 ntest = 31
1715 CALL cstemr( '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 )'CSTEMR(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 CSTEMR(V,V) to compute D1 and Z, do tests.
1747*
1748* Compute D1 and Z
1749*
1750 CALL scopy( n, sd, 1, d5, 1 )
1751 IF( n.GT.0 )
1752 $ CALL scopy( n-1, se, 1, rwork, 1 )
1753 CALL claset( '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 cstemr( 'V', 'V', n, d5, rwork, vl, vu, il, iu,
1780 $ m, d1, z, ldu, n, 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 )'CSTEMR(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 cstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1798 $ m, rwork, result( 32 ) )
1799*
1800* Call CSTEMR to compute D2, do tests.
1801*
1802* Compute D2
1803*
1804 CALL scopy( n, sd, 1, d5, 1 )
1805 IF( n.GT.0 )
1806 $ CALL scopy( n-1, se, 1, rwork, 1 )
1807*
1808 ntest = 34
1809 CALL cstemr( '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 )'CSTEMR(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 CSTEMR(V,A) to compute D1 and Z, do tests.
1849*
1850* Compute D1 and Z
1851*
1852 CALL scopy( n, sd, 1, d5, 1 )
1853 IF( n.GT.0 )
1854 $ CALL scopy( n-1, se, 1, rwork, 1 )
1855*
1856 ntest = 35
1857*
1858 CALL cstemr( '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 )'CSTEMR(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 cstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1877 $ rwork, result( 35 ) )
1878*
1879* Call CSTEMR to compute D2, do tests.
1880*
1881* Compute D2
1882*
1883 CALL scopy( n, sd, 1, d5, 1 )
1884 IF( n.GT.0 )
1885 $ CALL scopy( n-1, se, 1, rwork, 1 )
1886*
1887 ntest = 37
1888 CALL cstemr( '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 )'CSTEMR(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 )'CST'
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.0e0 ) 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 slasum( 'CST', nounit, nerrs, ntestt )
1959 RETURN
1960*
1961 9999 FORMAT( ' CCHKST: ', 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 CCHKST 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, e10.3 )
1996*
1997 9987 FORMAT( / 'Test performed: see CCHKST for details.', / )
1998* End of CCHKST
1999*
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
sstebz
subroutine sstebz(range, order, n, vl, vu, il, iu, abstol, d, e, m, nsplit, w, iblock, isplit, work, iwork, info)
SSTEBZ
Definition sstebz.f:273
ssterf
subroutine ssterf(n, d, e, info)
SSTERF
Definition ssterf.f:86
chetrd
subroutine chetrd(uplo, n, a, lda, d, e, tau, work, lwork, info)
CHETRD
Definition chetrd.f:192
cstein
subroutine cstein(n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
CSTEIN
Definition cstein.f:182
cupgtr
subroutine cupgtr(uplo, n, ap, tau, q, ldq, work, info)
CUPGTR
Definition cupgtr.f:114
cungtr
subroutine cungtr(uplo, n, a, lda, tau, work, lwork, info)
CUNGTR
Definition cungtr.f:123
cstemr
subroutine cstemr(jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
CSTEMR
Definition cstemr.f:338
chptrd
subroutine chptrd(uplo, n, ap, d, e, tau, info)
CHPTRD
Definition chptrd.f:151
cstedc
subroutine cstedc(compz, n, d, e, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
CSTEDC
Definition cstedc.f:212
cpteqr
subroutine cpteqr(compz, n, d, e, z, ldz, work, info)
CPTEQR
Definition cpteqr.f:145
chet21
subroutine chet21(itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
CHET21
Definition chet21.f:214
cstt22
subroutine cstt22(n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, rwork, result)
CSTT22
Definition cstt22.f:145
cstt21
subroutine cstt21(n, kband, ad, ae, sd, se, u, ldu, work, rwork, result)
CSTT21
Definition cstt21.f:133
chpt21
subroutine chpt21(itype, uplo, n, kband, ap, d, e, u, ldu, vp, tau, work, rwork, result)
CHPT21
Definition chpt21.f:228
ssxt1
real function ssxt1(ijob, d1, n1, d2, n2, abstol, ulp, unfl)
SSXT1
Definition ssxt1.f:106
sstech
subroutine sstech(n, a, b, eig, tol, work, info)
SSTECH
Definition sstech.f:101

◆ cchkst2stg()

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

CCHKST2STG

Purpose:
!>
!> CCHKST2STG  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
!> CHETRD. For that, we call the standard CHETRD and compute D1 using 
!> DSTEQR, then we call the 2-stage CHETRD_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 CCHKST in the next 
!> release when vectors and generation of Q will be implemented.
!>
!>    CHETRD factors A as  U S U* , where * means conjugate transpose,
!>    S is real symmetric tridiagonal, and U is unitary.
!>    CHETRD can use either just the lower or just the upper triangle
!>    of A; CCHKST2STG 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.
!>
!>    CHPTRD does the same as CHETRD, except that A and V are stored
!>    in  format.
!>
!>    CUNGTR constructs the matrix U from the contents of V and TAU.
!>
!>    CUPGTR constructs the matrix U from the contents of VP and TAU.
!>
!>    CSTEQR 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.
!>
!>    SSTERF computes D3, the matrix of eigenvalues, by the
!>    PWK method, which does not yield eigenvectors.
!>
!>    CPTEQR 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.
!>
!>    SSTEBZ 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.
!>
!>    CSTEIN computes Y, the eigenvectors of S, given the
!>    eigenvalues.
!>
!>    CSTEDC 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 CHETRD/CUNGTR or CHPTRD/CUPGTR ('V' option). It may
!>    also just compute eigenvalues ('N' option).
!>
!>    CSTEMR 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).  CSTEMR
!>    uses the Relatively Robust Representation whenever possible.
!>
!> When CCHKST2STG 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 ) CHETRD( UPLO='U', ... )
!>
!> (2)     | I - UV* | / ( n ulp )        CUNGTR( UPLO='U', ... )
!>
!> (3)     | A - V S V* | / ( |A| n ulp ) CHETRD( 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
!>         CHETRD_2STAGE(, ,....). D1 and D2 are computed 
!>         via DSTEQR('N',...) 
!>
!> (4)     | I - UV* | / ( n ulp )        CUNGTR( 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
!>         CHETRD_2STAGE(, ,....). D1 and D3 are computed 
!>         via DSTEQR('N',...)  
!>
!> (5-8)   Same as 1-4, but for CHPTRD and CUPGTR.
!>
!> (9)     | S - Z D Z* | / ( |S| n ulp ) CSTEQR('V',...)
!>
!> (10)    | I - ZZ* | / ( n ulp )        CSTEQR('V',...)
!>
!> (11)    | D1 - D2 | / ( |D1| ulp )        CSTEQR('N',...)
!>
!> (12)    | D1 - D3 | / ( |D1| ulp )        SSTERF
!>
!> (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
!>         SSTECH)
!>
!> For S positive definite,
!>
!> (14)    | S - Z4 D4 Z4* | / ( |S| n ulp ) CPTEQR('V',...)
!>
!> (15)    | I - Z4 Z4* | / ( n ulp )        CPTEQR('V',...)
!>
!> (16)    | D4 - D5 | / ( 100 |D4| ulp )       CPTEQR('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
!>                                              SSTEBZ( 'A', 'E', ...)
!>
!> (18)    | WA1 - D3 | / ( |D3| ulp )          SSTEBZ( 'A', 'E', ...)
!>
!> (19)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>                                              SSTEBZ( 'I', 'E', ...)
!>
!> (20)    | S - Y WA1 Y* | / ( |S| n ulp )  SSTEBZ, CSTEIN
!>
!> (21)    | I - Y Y* | / ( n ulp )          SSTEBZ, CSTEIN
!>
!> (22)    | S - Z D Z* | / ( |S| n ulp )    CSTEDC('I')
!>
!> (23)    | I - ZZ* | / ( n ulp )           CSTEDC('I')
!>
!> (24)    | S - Z D Z* | / ( |S| n ulp )    CSTEDC('V')
!>
!> (25)    | I - ZZ* | / ( n ulp )           CSTEDC('V')
!>
!> (26)    | D1 - D2 | / ( |D1| ulp )           CSTEDC('V') and
!>                                              CSTEDC('N')
!>
!> Test 27 is disabled at the moment because CSTEMR 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
!>                                              CSTEMR('V', 'A')
!>
!> (28)    max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              CSTEMR('V', 'I')
!>
!> Tests 29 through 34 are disable at present because CSTEMR
!> does not handle partial spectrum requests.
!>
!> (29)    | S - Z D Z* | / ( |S| n ulp )    CSTEMR('V', 'I')
!>
!> (30)    | I - ZZ* | / ( n ulp )           CSTEMR('V', 'I')
!>
!> (31)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         CSTEMR('N', 'I') vs. CSTEMR('V', 'I')
!>
!> (32)    | S - Z D Z* | / ( |S| n ulp )    CSTEMR('V', 'V')
!>
!> (33)    | I - ZZ* | / ( n ulp )           CSTEMR('V', 'V')
!>
!> (34)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         CSTEMR('N', 'V') vs. CSTEMR('V', 'V')
!>
!> (35)    | S - Z D Z* | / ( |S| n ulp )    CSTEMR('V', 'A')
!>
!> (36)    | I - ZZ* | / ( n ulp )           CSTEMR('V', 'A')
!>
!> (37)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         CSTEMR('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,
!>          CCHKST2STG 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, CCHKST2STG
!>          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 CCHKST2STG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix A stored in packed format.
!>
[out]SD
!>          SD is REAL array of
!>                             dimension( max(NN) )
!>          The diagonal of the tridiagonal matrix computed by CHETRD.
!>          On exit, SD and SE contain the tridiagonal form of the
!>          matrix in A.
!>
[out]SE
!>          SE is REAL array of
!>                             dimension( max(NN) )
!>          The off-diagonal of the tridiagonal matrix computed by
!>          CHETRD.  On exit, SD and SE contain the tridiagonal form of
!>          the matrix in A.
!>
[out]D1
!>          D1 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by CSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>
[out]D2
!>          D2 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by CSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>
[out]D3
!>          D3 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>
[out]D4
!>          D4 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by CPTEQR(V).
!>          CPTEQR factors S as  Z4 D4 Z4*
!>          On exit, the eigenvalues in D4 correspond with the matrix in A.
!>
[out]D5
!>          D5 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by CPTEQR(N)
!>          when Z is not computed. On exit, the
!>          eigenvalues in D4 correspond with the matrix in A.
!>
[out]WA1
!>          WA1 is REAL array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>
[out]WA2
!>          WA2 is REAL array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>          Choose random values for IL and IU, and ask for the
!>          IL-th through IU-th eigenvalues.
!>
[out]WA3
!>          WA3 is REAL array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>          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 REAL array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different options.
!>          as computed by SSTEBZ.
!>
[out]U
!>          U is COMPLEX array of
!>                             dimension( LDU, max(NN) ).
!>          The unitary matrix computed by CHETRD + CUNGTR.
!>
[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 array of
!>                             dimension( LDU, max(NN) ).
!>          The Housholder vectors computed by CHETRD 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 CHETRD, 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 CUNGTR, set those entries to
!>          1 before using them, and then restore them later.)
!>
[out]VP
!>          VP is COMPLEX array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix V stored in packed format.
!>
[out]TAU
!>          TAU is COMPLEX array of
!>                             dimension( max(NN) )
!>          The Householder factors computed by CHETRD in reducing A
!>          to tridiagonal form.
!>
[out]Z
!>          Z is COMPLEX array of
!>                             dimension( LDU, max(NN) ).
!>          The unitary matrix of eigenvectors computed by CSTEQR,
!>          CPTEQR, and CSTEIN.
!>
[out]WORK
!>          WORK is COMPLEX 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 REAL array
!>
[in]LRWORK
!>          LRWORK is INTEGER
!>          The number of entries in LRWORK (dimension( ??? )
!>
[out]RESULT
!>          RESULT is REAL 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  CLATMR, CLATMS, CHETRD, CUNGTR, CSTEQR, SSTERF,
!>              or CUNMC2 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 cchkst2stg.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 REAL THRESH
634* ..
635* .. Array Arguments ..
636 LOGICAL DOTYPE( * )
637 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
638 REAL D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
639 $ RESULT( * ), RWORK( * ), SD( * ), SE( * ),
640 $ WA1( * ), WA2( * ), WA3( * ), WR( * )
641 COMPLEX A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ),
642 $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * )
643* ..
644*
645* =====================================================================
646*
647* .. Parameters ..
648 REAL ZERO, ONE, TWO, EIGHT, TEN, HUN
649 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
650 $ eight = 8.0e0, ten = 10.0e0, hun = 100.0e0 )
651 COMPLEX CZERO, CONE
652 parameter( czero = ( 0.0e+0, 0.0e+0 ),
653 $ cone = ( 1.0e+0, 0.0e+0 ) )
654 REAL 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 REAL 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 REAL DUMMA( 1 )
679* ..
680* .. External Functions ..
681 INTEGER ILAENV
682 REAL SLAMCH, SLARND, SSXT1
683 EXTERNAL ilaenv, slamch, slarnd, ssxt1
684* ..
685* .. External Subroutines ..
686 EXTERNAL scopy, slabad, slasum, sstebz, sstech, ssterf,
687 $ xerbla, ccopy, chet21, chetrd, chpt21, chptrd,
688 $ clacpy, claset, clatmr, clatms, cpteqr, cstedc,
689 $ cstemr, cstein, csteqr, cstt21, cstt22, cungtr,
690 $ cupgtr, chetrd_2stage, slaset
691* ..
692* .. Intrinsic Functions ..
693 INTRINSIC abs, real, conjg, 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, 'CHETRD', '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( 'CCHKST2STG', -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 = slamch( 'Safe minimum' )
756 ovfl = one / unfl
757 CALL slabad( unfl, ovfl )
758 ulp = slamch( 'Epsilon' )*slamch( '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( real( 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 / real( 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 claset( '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 clatms( 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 clatms( 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 clatmr( 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 clatmr( 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 clatms( 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 clatms( 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 ) = conjg( 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 CHETRD and CUNGTR to compute S and U from
941* upper triangle.
942*
943 CALL clacpy( 'U', n, n, a, lda, v, ldu )
944*
945 ntest = 1
946 CALL chetrd( 'U', n, v, ldu, sd, se, tau, work, lwork,
947 $ iinfo )
948*
949 IF( iinfo.NE.0 ) THEN
950 WRITE( nounit, fmt = 9999 )'CHETRD(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 clacpy( 'U', n, n, v, ldu, u, ldu )
962*
963 ntest = 2
964 CALL cungtr( 'U', n, u, ldu, tau, work, lwork, iinfo )
965 IF( iinfo.NE.0 ) THEN
966 WRITE( nounit, fmt = 9999 )'CUNGTR(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 chet21( 2, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
980 $ ldu, tau, work, rwork, result( 1 ) )
981 CALL chet21( 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 scopy( n, sd, 1, d1, 1 )
992 IF( n.GT.0 )
993 $ CALL scopy( n-1, se, 1, rwork, 1 )
994*
995 CALL csteqr( 'N', n, d1, rwork, work, ldu, rwork( n+1 ),
996 $ iinfo )
997 IF( iinfo.NE.0 ) THEN
998 WRITE( nounit, fmt = 9999 )'CSTEQR(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 slaset( 'Full', n, 1, zero, zero, sd, n )
1015 CALL slaset( 'Full', n, 1, zero, zero, se, n )
1016 CALL clacpy( 'U', n, n, a, lda, v, ldu )
1017 lh = max(1, 4*n)
1018 lw = lwork - lh
1019 CALL chetrd_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 scopy( n, sd, 1, d2, 1 )
1025 IF( n.GT.0 )
1026 $ CALL scopy( n-1, se, 1, rwork, 1 )
1027*
1028 ntest = 3
1029 CALL csteqr( 'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1030 $ iinfo )
1031 IF( iinfo.NE.0 ) THEN
1032 WRITE( nounit, fmt = 9999 )'CSTEQR(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 slaset( 'Full', n, 1, zero, zero, sd, n )
1049 CALL slaset( 'Full', n, 1, zero, zero, se, n )
1050 CALL clacpy( 'L', n, n, a, lda, v, ldu )
1051 CALL chetrd_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 scopy( n, sd, 1, d3, 1 )
1057 IF( n.GT.0 )
1058 $ CALL scopy( n-1, se, 1, rwork, 1 )
1059*
1060 ntest = 4
1061 CALL csteqr( 'N', n, d3, rwork, work, ldu, rwork( n+1 ),
1062 $ iinfo )
1063 IF( iinfo.NE.0 ) THEN
1064 WRITE( nounit, fmt = 9999 )'CSTEQR(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 CHPTRD and CUPGTR to compute S and U from AP
1105*
1106 CALL ccopy( nap, ap, 1, vp, 1 )
1107*
1108 ntest = 5
1109 CALL chptrd( 'U', n, vp, sd, se, tau, iinfo )
1110*
1111 IF( iinfo.NE.0 ) THEN
1112 WRITE( nounit, fmt = 9999 )'CHPTRD(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 cupgtr( 'U', n, vp, tau, u, ldu, work, iinfo )
1125 IF( iinfo.NE.0 ) THEN
1126 WRITE( nounit, fmt = 9999 )'CUPGTR(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 chpt21( 2, 'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1140 $ work, rwork, result( 5 ) )
1141 CALL chpt21( 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 CHPTRD and CUPGTR to compute S and U from AP
1155*
1156 CALL ccopy( nap, ap, 1, vp, 1 )
1157*
1158 ntest = 7
1159 CALL chptrd( 'L', n, vp, sd, se, tau, iinfo )
1160*
1161 IF( iinfo.NE.0 ) THEN
1162 WRITE( nounit, fmt = 9999 )'CHPTRD(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 cupgtr( 'L', n, vp, tau, u, ldu, work, iinfo )
1175 IF( iinfo.NE.0 ) THEN
1176 WRITE( nounit, fmt = 9999 )'CUPGTR(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 chpt21( 2, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1188 $ work, rwork, result( 7 ) )
1189 CALL chpt21( 3, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1190 $ work, rwork, result( 8 ) )
1191*
1192* Call CSTEQR to compute D1, D2, and Z, do tests.
1193*
1194* Compute D1 and Z
1195*
1196 CALL scopy( n, sd, 1, d1, 1 )
1197 IF( n.GT.0 )
1198 $ CALL scopy( n-1, se, 1, rwork, 1 )
1199 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1200*
1201 ntest = 9
1202 CALL csteqr( 'V', n, d1, rwork, z, ldu, rwork( n+1 ),
1203 $ iinfo )
1204 IF( iinfo.NE.0 ) THEN
1205 WRITE( nounit, fmt = 9999 )'CSTEQR(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 scopy( n, sd, 1, d2, 1 )
1219 IF( n.GT.0 )
1220 $ CALL scopy( n-1, se, 1, rwork, 1 )
1221*
1222 ntest = 11
1223 CALL csteqr( 'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1224 $ iinfo )
1225 IF( iinfo.NE.0 ) THEN
1226 WRITE( nounit, fmt = 9999 )'CSTEQR(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 scopy( n, sd, 1, d3, 1 )
1240 IF( n.GT.0 )
1241 $ CALL scopy( n-1, se, 1, rwork, 1 )
1242*
1243 ntest = 12
1244 CALL ssterf( n, d3, rwork, iinfo )
1245 IF( iinfo.NE.0 ) THEN
1246 WRITE( nounit, fmt = 9999 )'SSTERF', 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 cstt21( 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 sstech( 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 CPTEQR
1296* and do tests 14, 15, and 16 .
1297*
1298 IF( jtype.GT.15 ) THEN
1299*
1300* Compute D4 and Z4
1301*
1302 CALL scopy( n, sd, 1, d4, 1 )
1303 IF( n.GT.0 )
1304 $ CALL scopy( n-1, se, 1, rwork, 1 )
1305 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1306*
1307 ntest = 14
1308 CALL cpteqr( 'V', n, d4, rwork, z, ldu, rwork( n+1 ),
1309 $ iinfo )
1310 IF( iinfo.NE.0 ) THEN
1311 WRITE( nounit, fmt = 9999 )'CPTEQR(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 cstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1325 $ rwork, result( 14 ) )
1326*
1327* Compute D5
1328*
1329 CALL scopy( n, sd, 1, d5, 1 )
1330 IF( n.GT.0 )
1331 $ CALL scopy( n-1, se, 1, rwork, 1 )
1332*
1333 ntest = 16
1334 CALL cpteqr( 'N', n, d5, rwork, z, ldu, rwork( n+1 ),
1335 $ iinfo )
1336 IF( iinfo.NE.0 ) THEN
1337 WRITE( nounit, fmt = 9999 )'CPTEQR(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 SSTEBZ 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 sstebz( '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 )'SSTEBZ(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 sstebz( '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 )'SSTEBZ(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( slarnd( 1, iseed2 ) )
1447 iu = 1 + ( n-1 )*int( slarnd( 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 sstebz( '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 )'SSTEBZ(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 sstebz( '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 )'SSTEBZ(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1516 temp2 = ssxt1( 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 CSTEIN to compute eigenvectors corresponding to
1526* eigenvalues in WA1. (First call SSTEBZ again, to make sure
1527* it returns these eigenvalues in the correct order.)
1528*
1529 ntest = 21
1530 CALL sstebz( '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 )'SSTEBZ(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 cstein( 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 )'CSTEIN', 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 cstt21( n, 0, sd, se, wa1, dumma, z, ldu, work, rwork,
1565 $ result( 20 ) )
1566*
1567* Call CSTEDC(I) to compute D1 and Z, do tests.
1568*
1569* Compute D1 and Z
1570*
1571 inde = 1
1572 indrwk = inde + n
1573 CALL scopy( n, sd, 1, d1, 1 )
1574 IF( n.GT.0 )
1575 $ CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1576 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1577*
1578 ntest = 22
1579 CALL cstedc( '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 )'CSTEDC(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 cstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1596 $ result( 22 ) )
1597*
1598* Call CSTEDC(V) to compute D1 and Z, do tests.
1599*
1600* Compute D1 and Z
1601*
1602 CALL scopy( n, sd, 1, d1, 1 )
1603 IF( n.GT.0 )
1604 $ CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1605 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1606*
1607 ntest = 24
1608 CALL cstedc( '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 )'CSTEDC(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 cstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1625 $ result( 24 ) )
1626*
1627* Call CSTEDC(N) to compute D2, do tests.
1628*
1629* Compute D2
1630*
1631 CALL scopy( n, sd, 1, d2, 1 )
1632 IF( n.GT.0 )
1633 $ CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1634 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1635*
1636 ntest = 26
1637 CALL cstedc( '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 )'CSTEDC(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 CSTEMR if IEEE compliant
1664*
1665 IF( ilaenv( 10, 'CSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1666 $ ilaenv( 11, 'CSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
1667*
1668* Call CSTEMR, 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 cstemr( '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 )'CSTEMR(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( slarnd( 1, iseed2 ) )
1710 iu = 1 + ( n-1 )*int( slarnd( 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 cstemr( '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 )'CSTEMR(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 CSTEMR(V,I) to compute D1 and Z, do tests.
1758*
1759* Compute D1 and Z
1760*
1761 CALL scopy( n, sd, 1, d5, 1 )
1762 IF( n.GT.0 )
1763 $ CALL scopy( n-1, se, 1, rwork, 1 )
1764 CALL claset( 'Full', n, n, czero, cone, z, ldu )
1765*
1766 IF( crange ) THEN
1767 ntest = 29
1768 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1769 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1770 IF( iu.LT.il ) THEN
1771 itemp = iu
1772 iu = il
1773 il = itemp
1774 END IF
1775 CALL cstemr( '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 )'CSTEMR(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 CSTEMR to compute D2, do tests.
1794*
1795* Compute D2
1796*
1797 CALL scopy( n, sd, 1, d5, 1 )
1798 IF( n.GT.0 )
1799 $ CALL scopy( n-1, se, 1, rwork, 1 )
1800*
1801 ntest = 31
1802 CALL cstemr( '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 )'CSTEMR(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 CSTEMR(V,V) to compute D1 and Z, do tests.
1833*
1834* Compute D1 and Z
1835*
1836 CALL scopy( n, sd, 1, d5, 1 )
1837 IF( n.GT.0 )
1838 $ CALL scopy( n-1, se, 1, rwork, 1 )
1839 CALL claset( '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 cstemr( '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 )'CSTEMR(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 cstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1884 $ m, rwork, result( 32 ) )
1885*
1886* Call CSTEMR to compute D2, do tests.
1887*
1888* Compute D2
1889*
1890 CALL scopy( n, sd, 1, d5, 1 )
1891 IF( n.GT.0 )
1892 $ CALL scopy( n-1, se, 1, rwork, 1 )
1893*
1894 ntest = 34
1895 CALL cstemr( '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 )'CSTEMR(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 CSTEMR(V,A) to compute D1 and Z, do tests.
1934*
1935* Compute D1 and Z
1936*
1937 CALL scopy( n, sd, 1, d5, 1 )
1938 IF( n.GT.0 )
1939 $ CALL scopy( n-1, se, 1, rwork, 1 )
1940*
1941 ntest = 35
1942*
1943 CALL cstemr( '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 )'CSTEMR(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 cstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1962 $ rwork, result( 35 ) )
1963*
1964* Call CSTEMR to compute D2, do tests.
1965*
1966* Compute D2
1967*
1968 CALL scopy( n, sd, 1, d5, 1 )
1969 IF( n.GT.0 )
1970 $ CALL scopy( n-1, se, 1, rwork, 1 )
1971*
1972 ntest = 37
1973 CALL cstemr( '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 )'CSTEMR(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 )'CST'
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.0e0 ) 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 slasum( 'CST', nounit, nerrs, ntestt )
2043 RETURN
2044*
2045 9999 FORMAT( ' CCHKST2STG: ', 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 CCHKST2STG 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, e10.3 )
2080*
2081 9987 FORMAT( / 'Test performed: see CCHKST2STG for details.', / )
2082*
2083* End of CCHKST2STG
2084*
chetrd_2stage
subroutine chetrd_2stage(vect, uplo, n, a, lda, d, e, tau, hous2, lhous2, work, lwork, info)
CHETRD_2STAGE
Definition chetrd_2stage.f:224

◆ cckcsd()

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

CCKCSD

Purpose:
!>
!> CCKCSD tests CUNCSD:
!>        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 REAL
!>          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 array, dimension (MMAX*MMAX)
!>
[out]XF
!>          XF is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]U1
!>          U1 is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]U2
!>          U2 is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]V1T
!>          V1T is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]V2T
!>          V2T is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]THETA
!>          THETA is REAL array, dimension (MMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (MMAX)
!>
[out]WORK
!>          WORK is COMPLEX array
!>
[out]RWORK
!>          RWORK is REAL 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 CLAROR 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 cckcsd.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 REAL THRESH
192* ..
193* .. Array Arguments ..
194 INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), PVAL( * ),
195 $ QVAL( * )
196 REAL RWORK( * ), THETA( * )
197 COMPLEX 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 REAL GAPDIGIT, ORTH, REALONE, REALZERO, TEN
209 parameter( gapdigit = 10.0e0, orth = 1.0e-4,
210 $ realone = 1.0e0, realzero = 0.0e0,
211 $ ten = 10.0e0 )
212 COMPLEX ONE, ZERO
213 parameter( one = (1.0e0,0.0e0), zero = (0.0e0,0.0e0) )
214 REAL PIOVER2
215 parameter( piover2 = 1.57079632679489661923132169163975144210e0 )
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 REAL RESULT( NTESTS )
226* ..
227* .. External Subroutines ..
228 EXTERNAL alahdg, alareq, alasum, ccsdts, clacsg, claror,
229 $ claset, csrot
230* ..
231* .. Intrinsic Functions ..
232 INTRINSIC abs, min
233* ..
234* .. External Functions ..
235 REAL SLARAN, SLARND
236 EXTERNAL slaran, slarnd
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 claror( '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 * slarnd( 1, iseed )
282 END DO
283 CALL clacsg( 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*slarnd(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**(-slarnd(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 clacsg( m, p, q, theta, iseed, x, ldx, work )
302 ELSE
303 CALL claset( 'F', m, m, zero, one, x, ldx )
304 DO i = 1, m
305 j = int( slaran( iseed ) * m ) + 1
306 IF( j .NE. i ) THEN
307 CALL csrot( 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 ccsdts( 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( ' CLAROR in CCKCSD: 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 CCKCSD
347*
clacsg
subroutine clacsg(m, p, q, theta, iseed, x, ldx, work)
Definition cckcsd.f:353
alahdg
subroutine alahdg(iounit, path)
ALAHDG
Definition alahdg.f:62
alareq
subroutine alareq(path, nmats, dotype, ntypes, nin, nout)
ALAREQ
Definition alareq.f:90
csrot
subroutine csrot(n, cx, incx, cy, incy, c, s)
CSROT
Definition csrot.f:98
ccsdts
subroutine ccsdts(m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, theta, iwork, work, lwork, rwork, result)
CCSDTS
Definition ccsdts.f:229
claror
subroutine claror(side, init, m, n, a, lda, iseed, x, info)
CLAROR
Definition claror.f:158
slaran
real function slaran(iseed)
SLARAN
Definition slaran.f:67

◆ cckglm()

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

CCKGLM

Purpose:
!>
!> CCKGLM tests CGGGLM - 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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]X
!>          X is COMPLEX array, dimension (4*NMAX)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX 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 CLATMS 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 cckglm.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 REAL THRESH
176* ..
177* .. Array Arguments ..
178 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
179 REAL RWORK( * )
180 COMPLEX 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 REAL ANORM, BNORM, CNDNMA, CNDNMB, RESID
197* ..
198* .. Local Arrays ..
199 LOGICAL DOTYPE( NTYPES )
200* ..
201* .. External Functions ..
202 COMPLEX CLARND
203 EXTERNAL clarnd
204* ..
205* .. External Subroutines ..
206 EXTERNAL alahdg, alareq, alasum, cglmts, clatms, slatb9
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 SLATB9 and generate test
258* matrices A and B with CLATMS.
259*
260 CALL slatb9( path, imat, m, p, n, TYPE, KLA, KUA, KLB, KUB,
261 $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
262 $ DISTA, DISTB )
263*
264 CALL clatms( 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 clatms( 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 ) = clarnd( 2, iseed )
286 20 CONTINUE
287*
288 CALL cglmts( 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( ' CLATMS in CCKGLM 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 CCKGLM
321*
cglmts
subroutine cglmts(n, m, p, a, af, lda, b, bf, ldb, d, df, x, u, work, lwork, rwork, result)
CGLMTS
Definition cglmts.f:150
slatb9
subroutine slatb9(path, imat, m, p, n, type, kla, kua, klb, kub, anorm, bnorm, modea, modeb, cndnma, cndnmb, dista, distb)
SLATB9
Definition slatb9.f:170

◆ cckgqr()

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

CCKGQR

Purpose:
!>
!> CCKGQR tests
!> CGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B,
!> CGGRQF: 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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AR
!>          AR is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]TAUA
!>          TAUA is COMPLEX array, dimension (NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]BZ
!>          BZ is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]BT
!>          BT is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]BWK
!>          BWK is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]TAUB
!>          TAUB is COMPLEX array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is REAL 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 CLATMS 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 cckgqr.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 REAL THRESH
219* ..
220* .. Array Arguments ..
221 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
222 REAL RWORK( * )
223 COMPLEX 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 REAL ANORM, BNORM, CNDNMA, CNDNMB
244* ..
245* .. Local Arrays ..
246 LOGICAL DOTYPE( NTYPES )
247 REAL RESULT( NTESTS )
248* ..
249* .. External Subroutines ..
250 EXTERNAL alahdg, alareq, alasum, cgqrts, cgrqts, clatms,
251 $ slatb9
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 CGGRQF
293*
294* Set up parameters with SLATB9 and generate test
295* matrices A and B with CLATMS.
296*
297 CALL slatb9( 'GRQ', imat, m, p, n, TYPE, KLA, KUA,
298 $ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
299 $ CNDNMA, CNDNMB, DISTA, DISTB )
300*
301 CALL clatms( 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 clatms( 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 cgrqts( 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 CGGQRF
342*
343* Set up parameters with SLATB9 and generate test
344* matrices A and B with CLATMS.
345*
346 CALL slatb9( 'GQR', imat, m, p, n, TYPE, KLA, KUA,
347 $ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
348 $ CNDNMA, CNDNMB, DISTA, DISTB )
349*
350 CALL clatms( 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 clatms( 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 cgqrts( 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( ' CLATMS in CCKGQR: 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 CCKGQR
407*
cgqrts
subroutine cgqrts(n, m, p, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
CGQRTS
Definition cgqrts.f:176
cgrqts
subroutine cgrqts(m, p, n, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
CGRQTS
Definition cgrqts.f:176

◆ cckgsv()

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

CCKGSV

Purpose:
!>
!> CCKGSV tests CGGSVD:
!>        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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]U
!>          U is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]V
!>          V is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]Q
!>          Q is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]ALPHA
!>          ALPHA is REAL array, dimension (NMAX)
!>
[out]BETA
!>          BETA is REAL array, dimension (NMAX)
!>
[out]R
!>          R is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is REAL 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 CLATMS 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 cckgsv.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 REAL THRESH
206* ..
207* .. Array Arguments ..
208 INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * ),
209 $ PVAL( * )
210 REAL ALPHA( * ), BETA( * ), RWORK( * )
211 COMPLEX 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, K, L
230 REAL ANORM, BNORM, CNDNMA, CNDNMB
231* ..
232* .. Local Arrays ..
233 LOGICAL DOTYPE( NTYPES )
234 REAL RESULT( NTESTS )
235* ..
236* .. External Subroutines ..
237 EXTERNAL alahdg, alareq, alasum, clatms, slatb9, cgsvts3
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* Specific cases
261*
262* Test: https://github.com/Reference-LAPACK/lapack/issues/411#issue-608776973
263*
264 m = 6
265 p = 6
266 n = 6
267 a(1:m*n) = cmplx(1.e0, 0.e0)
268 b(1:m*n) = cmplx(0.e0, 0.e0)
269 b(1+0*m) = cmplx(9.e19, 0.e0)
270 b(2+1*m) = cmplx(9.e18, 0.e0)
271 b(3+2*m) = cmplx(9.e17, 0.e0)
272 b(4+3*m) = cmplx(9.e16, 0.e0)
273 b(5+4*m) = cmplx(9.e15, 0.e0)
274 b(6+5*m) = cmplx(9.e14, 0.e0)
275 CALL cggsvd3('N','N','N', m, p, n, k, l, a, m, b, m,
276 $ alpha, beta, u, 1, v, 1, q, 1,
277 $ work, m*n, rwork, iwork, info)
278*
279* Print information there is a NAN in BETA
280 DO 40 i = 1, l
281 IF( beta(i).NE.beta(i) ) THEN
282 info = -i
283 EXIT
284 END IF
285 40 CONTINUE
286 IF( info.LT.0 ) THEN
287 IF( nfail.EQ.0 .AND. firstt ) THEN
288 firstt = .false.
289 CALL alahdg( nout, path )
290 END IF
291 WRITE( nout, fmt = 9997 ) -info
292 nfail = nfail + 1
293 END IF
294 nrun = nrun + 1
295 info = 0
296*
297* Do for each value of M in MVAL.
298*
299 DO 30 im = 1, nm
300 m = mval( im )
301 p = pval( im )
302 n = nval( im )
303*
304 DO 20 imat = 1, ntypes
305*
306* Do the tests only if DOTYPE( IMAT ) is true.
307*
308 IF( .NOT.dotype( imat ) )
309 $ GO TO 20
310*
311* Set up parameters with SLATB9 and generate test
312* matrices A and B with CLATMS.
313*
314 CALL slatb9( path, imat, m, p, n, TYPE, KLA, KUA, KLB, KUB,
315 $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
316 $ DISTA, DISTB )
317*
318* Generate M by N matrix A
319*
320 CALL clatms( m, n, dista, iseed, TYPE, RWORK, MODEA, CNDNMA,
321 $ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
322 $ IINFO )
323 IF( iinfo.NE.0 ) THEN
324 WRITE( nout, fmt = 9999 )iinfo
325 info = abs( iinfo )
326 GO TO 20
327 END IF
328*
329* Generate P by N matrix B
330*
331 CALL clatms( p, n, distb, iseed, TYPE, RWORK, MODEB, CNDNMB,
332 $ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
333 $ IINFO )
334 IF( iinfo.NE.0 ) THEN
335 WRITE( nout, fmt = 9999 )iinfo
336 info = abs( iinfo )
337 GO TO 20
338 END IF
339*
340 nt = 6
341*
342 CALL cgsvts3( m, p, n, a, af, lda, b, bf, ldb, u, ldu, v,
343 $ ldv, q, ldq, alpha, beta, r, ldr, iwork, work,
344 $ lwork, rwork, result )
345*
346* Print information about the tests that did not
347* pass the threshold.
348*
349 DO 10 i = 1, nt
350 IF( result( i ).GE.thresh ) THEN
351 IF( nfail.EQ.0 .AND. firstt ) THEN
352 firstt = .false.
353 CALL alahdg( nout, path )
354 END IF
355 WRITE( nout, fmt = 9998 )m, p, n, imat, i,
356 $ result( i )
357 nfail = nfail + 1
358 END IF
359 10 CONTINUE
360 nrun = nrun + nt
361*
362 20 CONTINUE
363 30 CONTINUE
364*
365* Print a summary of the results.
366*
367 CALL alasum( path, nout, nfail, nrun, 0 )
368*
369 9999 FORMAT( ' CLATMS in CCKGSV INFO = ', i5 )
370 9998 FORMAT( ' M=', i4, ' P=', i4, ', N=', i4, ', type ', i2,
371 $ ', test ', i2, ', ratio=', g13.6 )
372 9997 FORMAT( ' FOUND NaN in BETA(', i4,')' )
373 RETURN
374*
375* End of CCKGSV
376*
alpha
#define alpha
Definition eval.h:35
cggsvd3
subroutine cggsvd3(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)
CGGSVD3 computes the singular value decomposition (SVD) for OTHER matrices
Definition cggsvd3.f:354
cgsvts3
subroutine cgsvts3(m, p, n, a, af, lda, b, bf, ldb, u, ldu, v, ldv, q, ldq, alpha, beta, r, ldr, iwork, work, lwork, rwork, result)
CGSVTS3
Definition cgsvts3.f:209

◆ ccklse()

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

CCKLSE

Purpose:
!>
!> CCKLSE tests CGGLSE - 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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]X
!>          X is COMPLEX array, dimension (5*NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is REAL 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 CLATMS 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 ccklse.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 REAL THRESH
176* ..
177* .. Array Arguments ..
178 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
179 REAL RWORK( * )
180 COMPLEX 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 REAL ANORM, BNORM, CNDNMA, CNDNMB
200* ..
201* .. Local Arrays ..
202 LOGICAL DOTYPE( NTYPES )
203 REAL RESULT( NTESTS )
204* ..
205* .. External Subroutines ..
206 EXTERNAL alahdg, alareq, alasum, clarhs, clatms, clsets,
207 $ slatb9
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 SLATB9 and generate test
259* matrices A and B with CLATMS.
260*
261 CALL slatb9( path, imat, m, p, n, TYPE, KLA, KUA, KLB, KUB,
262 $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
263 $ DISTA, DISTB )
264*
265 CALL clatms( 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 clatms( 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 clarhs( 'CGE', '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 clarhs( 'CGE', '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 clsets( 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( ' CLATMS in CCKLSE 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 CCKLSE
334*
clsets
subroutine clsets(m, p, n, a, af, lda, b, bf, ldb, c, cf, d, df, x, work, lwork, rwork, result)
CLSETS
Definition clsets.f:155
clarhs
subroutine clarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
CLARHS
Definition clarhs.f:208

◆ ccsdts()

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

CCSDTS

Purpose:
!>
!> CCSDTS tests CUNCSD, 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 array, dimension (LDX,M)
!>          The M-by-M matrix X.
!>
[out]XF
!>          XF is COMPLEX array, dimension (LDX,M)
!>          Details of the CSD of X, as returned by CUNCSD;
!>          see CUNCSD 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 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 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 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 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 REAL 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 CUNCSD for
!>          details.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (M)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK
!>
[out]RWORK
!>          RWORK is REAL array
!>
[out]RESULT
!>          RESULT is REAL 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 ccsdts.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 REAL RESULT( 15 ), RWORK( * ), THETA( * )
240 COMPLEX U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
241 $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
242 $ XF( LDX, * )
243* ..
244*
245* =====================================================================
246*
247* .. Parameters ..
248 REAL REALONE, REALZERO
249 parameter( realone = 1.0e0, realzero = 0.0e0 )
250 COMPLEX ZERO, ONE
251 parameter( zero = (0.0e0,0.0e0), one = (1.0e0,0.0e0) )
252 REAL PIOVER2
253 parameter( piover2 = 1.57079632679489661923132169163975144210e0 )
254* ..
255* .. Local Scalars ..
256 INTEGER I, INFO, R
257 REAL EPS2, RESID, ULP, ULPINV
258* ..
259* .. External Functions ..
260 REAL SLAMCH, CLANGE, CLANHE
261 EXTERNAL slamch, clange, clanhe
262* ..
263* .. External Subroutines ..
264 EXTERNAL cgemm, cherk, clacpy, claset, cuncsd,
265 $ cuncsd2by1
266* ..
267* .. Intrinsic Functions ..
268 INTRINSIC cmplx, cos, max, min, real, sin
269* ..
270* .. Executable Statements ..
271*
272 ulp = slamch( 'Precision' )
273 ulpinv = realone / ulp
274*
275* The first half of the routine checks the 2-by-2 CSD
276*
277 CALL claset( 'Full', m, m, zero, one, work, ldx )
278 CALL cherk( 'Upper', 'Conjugate transpose', m, m, -realone,
279 $ x, ldx, realone, work, ldx )
280 IF (m.GT.0) THEN
281 eps2 = max( ulp,
282 $ clange( '1', m, m, work, ldx, rwork ) / real( 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 clacpy( 'Full', m, m, x, ldx, xf, ldx )
291*
292* Compute the CSD
293*
294 CALL cuncsd( '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 clacpy( 'Full', m, m, x, ldx, xf, ldx )
302*
303 CALL cgemm( 'No transpose', 'Conjugate transpose', p, q, q, one,
304 $ xf, ldx, v1t, ldv1t, zero, work, ldx )
305*
306 CALL cgemm( '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) - cmplx( cos(theta(i)),
315 $ 0.0e0 )
316 END DO
317*
318 CALL cgemm( 'No transpose', 'Conjugate transpose', p, m-q, m-q,
319 $ one, xf(1,q+1), ldx, v2t, ldv2t, zero, work, ldx )
320*
321 CALL cgemm( '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 $ cmplx( sin(theta(r-i+1)), 0.0e0 )
331 END DO
332*
333 CALL cgemm( 'No transpose', 'Conjugate transpose', m-p, q, q, one,
334 $ xf(p+1,1), ldx, v1t, ldv1t, zero, work, ldx )
335*
336 CALL cgemm( '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 $ cmplx( sin(theta(r-i+1)), 0.0e0 )
346 END DO
347*
348 CALL cgemm( '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 cgemm( '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 $ cmplx( cos(theta(i)), 0.0e0 )
361 END DO
362*
363* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
364*
365 resid = clange( '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 = clange( '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 = clange( '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 = clange( '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 claset( 'Full', p, p, zero, one, work, ldu1 )
386 CALL cherk( '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 = clanhe( '1', 'Upper', p, work, ldu1, rwork )
392 result( 5 ) = ( resid / real(max(1,p)) ) / ulp
393*
394* Compute I - U2'*U2
395*
396 CALL claset( 'Full', m-p, m-p, zero, one, work, ldu2 )
397 CALL cherk( '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 = clanhe( '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 claset( 'Full', q, q, zero, one, work, ldv1t )
408 CALL cherk( '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 = clanhe( '1', 'Upper', q, work, ldv1t, rwork )
414 result( 7 ) = ( resid / real(max(1,q)) ) / ulp
415*
416* Compute I - V2T*V2T'
417*
418 CALL claset( 'Full', m-q, m-q, zero, one, work, ldv2t )
419 CALL cherk( '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 = clanhe( '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 claset( 'Full', q, q, zero, one, work, ldx )
444 CALL cherk( 'Upper', 'Conjugate transpose', q, m, -realone,
445 $ x, ldx, realone, work, ldx )
446 IF (m.GT.0) THEN
447 eps2 = max( ulp,
448 $ clange( '1', q, q, work, ldx, rwork ) / real( 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 clacpy( 'Full', m, q, x, ldx, xf, ldx )
457*
458* Compute the CSD
459*
460 CALL cuncsd2by1( '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 cgemm( 'No transpose', 'Conjugate transpose', p, q, q, one,
467 $ x, ldx, v1t, ldv1t, zero, work, ldx )
468*
469 CALL cgemm( '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) - cmplx( cos(theta(i)),
478 $ 0.0e0 )
479 END DO
480*
481 CALL cgemm( 'No transpose', 'Conjugate transpose', m-p, q, q, one,
482 $ x(p+1,1), ldx, v1t, ldv1t, zero, work, ldx )
483*
484 CALL cgemm( '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 $ cmplx( sin(theta(r-i+1)), 0.0e0 )
494 END DO
495*
496* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
497*
498 resid = clange( '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 = clange( '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 claset( 'Full', p, p, zero, one, work, ldu1 )
509 CALL cherk( 'Upper', 'Conjugate transpose', p, p, -realone,
510 $ u1, ldu1, realone, work, ldu1 )
511*
512* Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) .
513*
514 resid = clanhe( '1', 'Upper', p, work, ldu1, rwork )
515 result( 12 ) = ( resid / real(max(1,p)) ) / ulp
516*
517* Compute I - U2'*U2
518*
519 CALL claset( 'Full', m-p, m-p, zero, one, work, ldu2 )
520 CALL cherk( '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 = clanhe( '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 claset( 'Full', q, q, zero, one, work, ldv1t )
531 CALL cherk( '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 = clanhe( '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 CCSDTS
556*
clanhe
real function clanhe(norm, uplo, n, a, lda, work)
CLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanhe.f:124
cuncsd
recursive subroutine cuncsd(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)
CUNCSD
Definition cuncsd.f:320
cuncsd2by1
subroutine cuncsd2by1(jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, rwork, lrwork, iwork, info)
CUNCSD2BY1
Definition cuncsd2by1.f:257
cherk
subroutine cherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
CHERK
Definition cherk.f:173

◆ cdrges()

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

CDRGES

Purpose:
!>
!> CDRGES checks the nonsymmetric generalized eigenvalue (Schur form)
!> problem driver CGGES.
!>
!> CGGES 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 CDRGES 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,
!>          SDRGES 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, SDRGES
!>          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 SDRGES to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 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 array, dimension (LDA, max(NN))
!>          The Schur form matrix computed from A by CGGES.  On exit, S
!>          contains the Schur form matrix corresponding to the matrix
!>          in A.
!>
[out]T
!>          T is COMPLEX array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by CGGES.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDQ, max(NN))
!>          The (left) orthogonal matrix computed by CGGES.
!>
[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 array, dimension( LDQ, max(NN) )
!>          The (right) orthogonal matrix computed by CGGES.
!>
[out]ALPHA
!>          ALPHA is COMPLEX array, dimension (max(NN))
!>
[out]BETA
!>          BETA is COMPLEX array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by CGGES.
!>          ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A
!>          and B.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= 3*N*N.
!>
[out]RWORK
!>          RWORK is REAL array, dimension ( 8*N )
!>          Real workspace.
!>
[out]RESULT
!>          RESULT is REAL 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 cdrges.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 REAL THRESH
389* ..
390* .. Array Arguments ..
391 LOGICAL BWORK( * ), DOTYPE( * )
392 INTEGER ISEED( 4 ), NN( * )
393 REAL RESULT( 13 ), RWORK( * )
394 COMPLEX A( LDA, * ), ALPHA( * ), B( LDA, * ),
395 $ BETA( * ), Q( LDQ, * ), S( LDA, * ),
396 $ T( LDA, * ), WORK( * ), Z( LDQ, * )
397* ..
398*
399* =====================================================================
400*
401* .. Parameters ..
402 REAL ZERO, ONE
403 parameter( zero = 0.0e+0, one = 1.0e+0 )
404 COMPLEX CZERO, CONE
405 parameter( czero = ( 0.0e+0, 0.0e+0 ),
406 $ cone = ( 1.0e+0, 0.0e+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 REAL SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
418 COMPLEX 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 REAL RMAGN( 0: 3 )
428* ..
429* .. External Functions ..
430 LOGICAL CLCTES
431 INTEGER ILAENV
432 REAL SLAMCH
433 COMPLEX CLARND
434 EXTERNAL clctes, ilaenv, slamch, clarnd
435* ..
436* .. External Subroutines ..
437 EXTERNAL alasvm, cget51, cget54, cgges, clacpy, clarfg,
438 $ claset, clatm4, cunm2r, slabad, xerbla
439* ..
440* .. Intrinsic Functions ..
441 INTRINSIC abs, aimag, conjg, max, min, real, sign
442* ..
443* .. Statement Functions ..
444 REAL ABS1
445* ..
446* .. Statement Function definitions ..
447 abs1( x ) = abs( real( x ) ) + abs( aimag( 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, 'CGEQRF', ' ', nmax, nmax, -1, -1 ),
513 $ ilaenv( 1, 'CUNMQR', 'LC', nmax, nmax, nmax, -1 ),
514 $ ilaenv( 1, 'CUNGQR', ' ', 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( 'CDRGES', -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 = slamch( 'Precision' )
533 safmin = slamch( 'Safe minimum' )
534 safmin = safmin / ulp
535 safmax = one / safmin
536 CALL slabad( 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 / real( n1 )
554 rmagn( 3 ) = safmin*ulpinv*real( 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* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
587* =3 means random.
588* KATYPE: the "type" to be passed to CLATM4 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 claset( 'Full', n, n, czero, czero, a, lda )
614 ELSE
615 in = n
616 END IF
617 CALL clatm4( 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 claset( 'Full', n, n, czero, czero, b, lda )
632 ELSE
633 in = n
634 END IF
635 CALL clatm4( 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 ) = clarnd( 3, iseed )
654 z( jr, jc ) = clarnd( 3, iseed )
655 40 CONTINUE
656 CALL clarfg( n+1-jc, q( jc, jc ), q( jc+1, jc ), 1,
657 $ work( jc ) )
658 work( 2*n+jc ) = sign( one, real( q( jc, jc ) ) )
659 q( jc, jc ) = cone
660 CALL clarfg( n+1-jc, z( jc, jc ), z( jc+1, jc ), 1,
661 $ work( n+jc ) )
662 work( 3*n+jc ) = sign( one, real( z( jc, jc ) ) )
663 z( jc, jc ) = cone
664 50 CONTINUE
665 ctemp = clarnd( 3, iseed )
666 q( n, n ) = cone
667 work( n ) = czero
668 work( 3*n ) = ctemp / abs( ctemp )
669 ctemp = clarnd( 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 $ conjg( work( 3*n+jc ) )*
680 $ a( jr, jc )
681 b( jr, jc ) = work( 2*n+jr )*
682 $ conjg( work( 3*n+jc ) )*
683 $ b( jr, jc )
684 60 CONTINUE
685 70 CONTINUE
686 CALL cunm2r( '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 cunm2r( '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 cunm2r( '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 cunm2r( '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 $ clarnd( 4, iseed )
711 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
712 $ clarnd( 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 CGGES to compute H, T, Q, Z, alpha, and beta.
744*
745 CALL clacpy( 'Full', n, n, a, lda, s, lda )
746 CALL clacpy( 'Full', n, n, b, lda, t, lda )
747 ntest = 1 + rsub + isort
748 result( 1+rsub+isort ) = ulpinv
749 CALL cgges( 'V', 'V', sort, clctes, 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 )'CGGES', 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 cget51( 1, n, a, lda, s, lda, q, ldq, z, ldq,
766 $ work, rwork, result( 1 ) )
767 CALL cget51( 1, n, b, lda, t, lda, q, ldq, z, ldq,
768 $ work, rwork, result( 2 ) )
769 ELSE
770 CALL cget54( n, a, lda, b, lda, s, lda, t, lda, q,
771 $ ldq, z, ldq, work, result( 2+rsub ) )
772 END IF
773*
774 CALL cget51( 3, n, b, lda, t, lda, q, ldq, q, ldq, work,
775 $ rwork, result( 3+rsub ) )
776 CALL cget51( 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( clctes( 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 )'CGS'
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.0 ) 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( 'CGS', nounit, nerrs, ntestt, 0 )
876*
877 work( 1 ) = maxwrk
878*
879 RETURN
880*
881 9999 FORMAT( ' CDRGES: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
882 $ i6, ', JTYPE=', i6, ', ISEED=(', 4( i4, ',' ), i5, ')' )
883*
884 9998 FORMAT( ' CDRGES: 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 CDRGES 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, e10.3 )
933*
934* End of CDRGES
935*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
cgges
subroutine cgges(jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb, sdim, alpha, beta, vsl, ldvsl, vsr, ldvsr, work, lwork, rwork, bwork, info)
CGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE m...
Definition cgges.f:270
clctes
logical function clctes(z, d)
CLCTES
Definition clctes.f:58
cget54
subroutine cget54(n, a, lda, b, ldb, s, lds, t, ldt, u, ldu, v, ldv, work, result)
CGET54
Definition cget54.f:156

◆ cdrges3()

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

CDRGES3

Purpose:
!>
!> CDRGES3 checks the nonsymmetric generalized eigenvalue (Schur form)
!> problem driver CGGES3.
!>
!> CGGES3 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 CDRGES3 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,
!>          SDRGES3 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, SDRGES3
!>          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 SDRGES3 to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 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 array, dimension (LDA, max(NN))
!>          The Schur form matrix computed from A by CGGES3.  On exit, S
!>          contains the Schur form matrix corresponding to the matrix
!>          in A.
!>
[out]T
!>          T is COMPLEX array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by CGGES3.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDQ, max(NN))
!>          The (left) orthogonal matrix computed by CGGES3.
!>
[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 array, dimension( LDQ, max(NN) )
!>          The (right) orthogonal matrix computed by CGGES3.
!>
[out]ALPHA
!>          ALPHA is COMPLEX array, dimension (max(NN))
!>
[out]BETA
!>          BETA is COMPLEX array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by CGGES3.
!>          ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A
!>          and B.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= 3*N*N.
!>
[out]RWORK
!>          RWORK is REAL array, dimension ( 8*N )
!>          Real workspace.
!>
[out]RESULT
!>          RESULT is REAL 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 cdrges3.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 REAL THRESH
390* ..
391* .. Array Arguments ..
392 LOGICAL BWORK( * ), DOTYPE( * )
393 INTEGER ISEED( 4 ), NN( * )
394 REAL RESULT( 13 ), RWORK( * )
395 COMPLEX A( LDA, * ), ALPHA( * ), B( LDA, * ),
396 $ BETA( * ), Q( LDQ, * ), S( LDA, * ),
397 $ T( LDA, * ), WORK( * ), Z( LDQ, * )
398* ..
399*
400* =====================================================================
401*
402* .. Parameters ..
403 REAL ZERO, ONE
404 parameter( zero = 0.0e+0, one = 1.0e+0 )
405 COMPLEX CZERO, CONE
406 parameter( czero = ( 0.0e+0, 0.0e+0 ),
407 $ cone = ( 1.0e+0, 0.0e+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 REAL SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
419 COMPLEX 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 REAL RMAGN( 0: 3 )
429* ..
430* .. External Functions ..
431 LOGICAL CLCTES
432 INTEGER ILAENV
433 REAL SLAMCH
434 COMPLEX CLARND
435 EXTERNAL clctes, ilaenv, slamch, clarnd
436* ..
437* .. External Subroutines ..
438 EXTERNAL alasvm, cget51, cget54, cgges3, clacpy, clarfg,
439 $ claset, clatm4, cunm2r, slabad, xerbla
440* ..
441* .. Intrinsic Functions ..
442 INTRINSIC abs, aimag, conjg, max, min, real, sign
443* ..
444* .. Statement Functions ..
445 REAL ABS1
446* ..
447* .. Statement Function definitions ..
448 abs1( x ) = abs( real( x ) ) + abs( aimag( 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, 'CGEQRF', ' ', nmax, nmax, -1, -1 ),
514 $ ilaenv( 1, 'CUNMQR', 'LC', nmax, nmax, nmax, -1 ),
515 $ ilaenv( 1, 'CUNGQR', ' ', 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( 'CDRGES3', -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 = slamch( 'Precision' )
534 safmin = slamch( 'Safe minimum' )
535 safmin = safmin / ulp
536 safmax = one / safmin
537 CALL slabad( 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 / real( n1 )
555 rmagn( 3 ) = safmin*ulpinv*real( 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* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
588* =3 means random.
589* KATYPE: the "type" to be passed to CLATM4 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 claset( 'Full', n, n, czero, czero, a, lda )
615 ELSE
616 in = n
617 END IF
618 CALL clatm4( 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 claset( 'Full', n, n, czero, czero, b, lda )
633 ELSE
634 in = n
635 END IF
636 CALL clatm4( 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 ) = clarnd( 3, iseed )
655 z( jr, jc ) = clarnd( 3, iseed )
656 40 CONTINUE
657 CALL clarfg( n+1-jc, q( jc, jc ), q( jc+1, jc ), 1,
658 $ work( jc ) )
659 work( 2*n+jc ) = sign( one, real( q( jc, jc ) ) )
660 q( jc, jc ) = cone
661 CALL clarfg( n+1-jc, z( jc, jc ), z( jc+1, jc ), 1,
662 $ work( n+jc ) )
663 work( 3*n+jc ) = sign( one, real( z( jc, jc ) ) )
664 z( jc, jc ) = cone
665 50 CONTINUE
666 ctemp = clarnd( 3, iseed )
667 q( n, n ) = cone
668 work( n ) = czero
669 work( 3*n ) = ctemp / abs( ctemp )
670 ctemp = clarnd( 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 $ conjg( work( 3*n+jc ) )*
681 $ a( jr, jc )
682 b( jr, jc ) = work( 2*n+jr )*
683 $ conjg( work( 3*n+jc ) )*
684 $ b( jr, jc )
685 60 CONTINUE
686 70 CONTINUE
687 CALL cunm2r( '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 cunm2r( '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 cunm2r( '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 cunm2r( '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 $ clarnd( 4, iseed )
712 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
713 $ clarnd( 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 CLAQZ0
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 CGGES3 to compute H, T, Q, Z, alpha, and beta.
753*
754 CALL clacpy( 'Full', n, n, a, lda, s, lda )
755 CALL clacpy( 'Full', n, n, b, lda, t, lda )
756 ntest = 1 + rsub + isort
757 result( 1+rsub+isort ) = ulpinv
758 CALL cgges3( 'V', 'V', sort, clctes, 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 )'CGGES3', 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 cget51( 1, n, a, lda, s, lda, q, ldq, z, ldq,
775 $ work, rwork, result( 1 ) )
776 CALL cget51( 1, n, b, lda, t, lda, q, ldq, z, ldq,
777 $ work, rwork, result( 2 ) )
778 ELSE
779 CALL cget54( n, a, lda, b, lda, s, lda, t, lda, q,
780 $ ldq, z, ldq, work, result( 2+rsub ) )
781 END IF
782*
783 CALL cget51( 3, n, b, lda, t, lda, q, ldq, q, ldq, work,
784 $ rwork, result( 3+rsub ) )
785 CALL cget51( 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( clctes( 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 )'CGS'
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.0 ) 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( 'CGS', nounit, nerrs, ntestt, 0 )
885*
886 work( 1 ) = maxwrk
887*
888 RETURN
889*
890 9999 FORMAT( ' CDRGES3: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
891 $ i6, ', JTYPE=', i6, ', ISEED=(', 4( i4, ',' ), i5, ')' )
892*
893 9998 FORMAT( ' CDRGES3: 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 CDRGES3 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, e10.3 )
942*
943* End of CDRGES3
944*
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
cgges3
subroutine cgges3(jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb, sdim, alpha, beta, vsl, ldvsl, vsr, ldvsr, work, lwork, rwork, bwork, info)
CGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition cgges3.f:269

◆ cdrgev()

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

CDRGEV

Purpose:
!>
!> CDRGEV checks the nonsymmetric generalized eigenvalue problem driver
!> routine CGGEV.
!>
!> CGGEV 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 CDRGEV 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 CGGEV:
!>
!> (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 right 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,
!>          CDRGES 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, CDRGEV
!>          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 CDRGES to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 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 array, dimension (LDA, max(NN))
!>          The Schur form matrix computed from A by CGGEV.  On exit, S
!>          contains the Schur form matrix corresponding to the matrix
!>          in A.
!>
[out]T
!>          T is COMPLEX array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by CGGEV.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDQ, max(NN))
!>          The (left) eigenvectors matrix computed by CGGEV.
!>
[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 array, dimension( LDQ, max(NN) )
!>          The (right) orthogonal matrix computed by CGGEV.
!>
[out]QE
!>          QE is COMPLEX 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 array, dimension (max(NN))
!>
[out]BETA
!>          BETA is COMPLEX array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by CGGEV.
!>          ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
!>          generalized eigenvalue of A and B.
!>
[out]ALPHA1
!>          ALPHA1 is COMPLEX array, dimension (max(NN))
!>
[out]BETA1
!>          BETA1 is COMPLEX array, dimension (max(NN))
!>
!>          Like ALPHAR, ALPHAI, BETA, these arrays contain the
!>          eigenvalues of A and B, but those computed when CGGEV only
!>          computes a partial eigendecomposition, i.e. not the
!>          eigenvalues and left and right eigenvectors.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  LWORK >= N*(N+1)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (8*N)
!>          Real workspace.
!>
[out]RESULT
!>          RESULT is REAL 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 cdrgev.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 REAL THRESH
408* ..
409* .. Array Arguments ..
410 LOGICAL DOTYPE( * )
411 INTEGER ISEED( 4 ), NN( * )
412 REAL RESULT( * ), RWORK( * )
413 COMPLEX 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 REAL ZERO, ONE
423 parameter( zero = 0.0e+0, one = 1.0e+0 )
424 COMPLEX CZERO, CONE
425 parameter( czero = ( 0.0e+0, 0.0e+0 ),
426 $ cone = ( 1.0e+0, 0.0e+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 REAL SAFMAX, SAFMIN, ULP, ULPINV
436 COMPLEX 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 REAL RMAGN( 0: 3 )
446* ..
447* .. External Functions ..
448 INTEGER ILAENV
449 REAL SLAMCH
450 COMPLEX CLARND
451 EXTERNAL ilaenv, slamch, clarnd
452* ..
453* .. External Subroutines ..
454 EXTERNAL alasvm, cget52, cggev, clacpy, clarfg, claset,
455 $ clatm4, cunm2r, slabad, xerbla
456* ..
457* .. Intrinsic Functions ..
458 INTRINSIC abs, conjg, max, min, real, 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, 'CGEQRF', ' ', nmax, nmax, -1, -1 ),
526 $ ilaenv( 1, 'CUNMQR', 'LC', nmax, nmax, nmax, -1 ),
527 $ ilaenv( 1, 'CUNGQR', ' ', 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( 'CDRGEV', -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 = slamch( 'Precision' )
546 safmin = slamch( 'Safe minimum' )
547 safmin = safmin / ulp
548 safmax = one / safmin
549 CALL slabad( 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 / real( 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* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
591* =3 means random.
592* KATYPE: the "type" to be passed to CLATM4 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 claset( 'Full', n, n, czero, czero, a, lda )
618 ELSE
619 in = n
620 END IF
621 CALL clatm4( 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 claset( 'Full', n, n, czero, czero, b, lda )
636 ELSE
637 in = n
638 END IF
639 CALL clatm4( 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 ) = clarnd( 3, iseed )
658 z( jr, jc ) = clarnd( 3, iseed )
659 30 CONTINUE
660 CALL clarfg( n+1-jc, q( jc, jc ), q( jc+1, jc ), 1,
661 $ work( jc ) )
662 work( 2*n+jc ) = sign( one, real( q( jc, jc ) ) )
663 q( jc, jc ) = cone
664 CALL clarfg( n+1-jc, z( jc, jc ), z( jc+1, jc ), 1,
665 $ work( n+jc ) )
666 work( 3*n+jc ) = sign( one, real( z( jc, jc ) ) )
667 z( jc, jc ) = cone
668 40 CONTINUE
669 ctemp = clarnd( 3, iseed )
670 q( n, n ) = cone
671 work( n ) = czero
672 work( 3*n ) = ctemp / abs( ctemp )
673 ctemp = clarnd( 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 $ conjg( work( 3*n+jc ) )*
684 $ a( jr, jc )
685 b( jr, jc ) = work( 2*n+jr )*
686 $ conjg( work( 3*n+jc ) )*
687 $ b( jr, jc )
688 50 CONTINUE
689 60 CONTINUE
690 CALL cunm2r( '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 cunm2r( '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 cunm2r( '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 cunm2r( '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 $ clarnd( 4, iseed )
715 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
716 $ clarnd( 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 CGGEV to compute eigenvalues and eigenvectors.
737*
738 CALL clacpy( ' ', n, n, a, lda, s, lda )
739 CALL clacpy( ' ', n, n, b, lda, t, lda )
740 CALL cggev( '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 )'CGGEV1', 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 cget52( .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', 'CGGEV1',
756 $ result( 2 ), n, jtype, ioldsd
757 END IF
758*
759* Do the tests (3) and (4)
760*
761 CALL cget52( .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', 'CGGEV1',
765 $ result( 4 ), n, jtype, ioldsd
766 END IF
767*
768* Do test (5)
769*
770 CALL clacpy( ' ', n, n, a, lda, s, lda )
771 CALL clacpy( ' ', n, n, b, lda, t, lda )
772 CALL cggev( '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 )'CGGEV2', 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 clacpy( ' ', n, n, a, lda, s, lda )
791 CALL clacpy( ' ', n, n, b, lda, t, lda )
792 CALL cggev( '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 )'CGGEV3', 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 clacpy( ' ', n, n, a, lda, s, lda )
818 CALL clacpy( ' ', n, n, b, lda, t, lda )
819 CALL cggev( '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 )'CGGEV4', 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 )'CGV'
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.0 ) 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( 'CGV', nounit, nerrs, ntestt, 0 )
886*
887 work( 1 ) = maxwrk
888*
889 RETURN
890*
891 9999 FORMAT( ' CDRGEV: ', a, ' returned INFO=', i6, '.', / 3x, 'N=',
892 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
893*
894 9998 FORMAT( ' CDRGEV: ', 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 CDRGEV 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, e10.3 )
933*
934* End of CDRGEV
935*
cggev
subroutine cggev(jobvl, jobvr, n, a, lda, b, ldb, alpha, beta, vl, ldvl, vr, ldvr, work, lwork, rwork, info)
CGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition cggev.f:217

◆ cdrgev3()

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

CDRGEV3

Purpose:
!>
!> CDRGEV3 checks the nonsymmetric generalized eigenvalue problem driver
!> routine CGGEV3.
!>
!> CGGEV3 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 CDRGEV3 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 CGGEV3:
!>
!> (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,
!>          CDRGEV3 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, CDRGEV3
!>          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 CDRGEV3 to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 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 array, dimension (LDA, max(NN))
!>          The Schur form matrix computed from A by CGGEV3.  On exit, S
!>          contains the Schur form matrix corresponding to the matrix
!>          in A.
!>
[out]T
!>          T is COMPLEX array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by CGGEV3.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDQ, max(NN))
!>          The (left) eigenvectors matrix computed by CGGEV3.
!>
[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 array, dimension( LDQ, max(NN) )
!>          The (right) orthogonal matrix computed by CGGEV3.
!>
[out]QE
!>          QE is COMPLEX 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 array, dimension (max(NN))
!>
[out]BETA
!>          BETA is COMPLEX array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by CGGEV3.
!>          ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
!>          generalized eigenvalue of A and B.
!>
[out]ALPHA1
!>          ALPHA1 is COMPLEX array, dimension (max(NN))
!>
[out]BETA1
!>          BETA1 is COMPLEX array, dimension (max(NN))
!>
!>          Like ALPHAR, ALPHAI, BETA, these arrays contain the
!>          eigenvalues of A and B, but those computed when CGGEV3 only
!>          computes a partial eigendecomposition, i.e. not the
!>          eigenvalues and left and right eigenvectors.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  LWORK >= N*(N+1)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (8*N)
!>          Real workspace.
!>
[out]RESULT
!>          RESULT is REAL 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 cdrgev3.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 REAL THRESH
408* ..
409* .. Array Arguments ..
410 LOGICAL DOTYPE( * )
411 INTEGER ISEED( 4 ), NN( * )
412 REAL RESULT( * ), RWORK( * )
413 COMPLEX 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 REAL ZERO, ONE
423 parameter( zero = 0.0e+0, one = 1.0e+0 )
424 COMPLEX CZERO, CONE
425 parameter( czero = ( 0.0e+0, 0.0e+0 ),
426 $ cone = ( 1.0e+0, 0.0e+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 REAL SAFMAX, SAFMIN, ULP, ULPINV
436 COMPLEX 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 REAL RMAGN( 0: 3 )
446* ..
447* .. External Functions ..
448 INTEGER ILAENV
449 REAL SLAMCH
450 COMPLEX CLARND
451 EXTERNAL ilaenv, slamch, clarnd
452* ..
453* .. External Subroutines ..
454 EXTERNAL alasvm, cget52, cggev3, clacpy, clarfg, claset,
455 $ clatm4, cunm2r, slabad, xerbla
456* ..
457* .. Intrinsic Functions ..
458 INTRINSIC abs, conjg, max, min, real, 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, 'CGEQRF', ' ', nmax, nmax, -1, -1 ),
526 $ ilaenv( 1, 'CUNMQR', 'LC', nmax, nmax, nmax, -1 ),
527 $ ilaenv( 1, 'CUNGQR', ' ', 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( 'CDRGEV3', -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 = slamch( 'Precision' )
546 safmin = slamch( 'Safe minimum' )
547 safmin = safmin / ulp
548 safmax = one / safmin
549 CALL slabad( 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 / real( 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* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
591* =3 means random.
592* KATYPE: the "type" to be passed to CLATM4 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 claset( 'Full', n, n, czero, czero, a, lda )
618 ELSE
619 in = n
620 END IF
621 CALL clatm4( 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 claset( 'Full', n, n, czero, czero, b, lda )
636 ELSE
637 in = n
638 END IF
639 CALL clatm4( 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 ) = clarnd( 3, iseed )
658 z( jr, jc ) = clarnd( 3, iseed )
659 30 CONTINUE
660 CALL clarfg( n+1-jc, q( jc, jc ), q( jc+1, jc ), 1,
661 $ work( jc ) )
662 work( 2*n+jc ) = sign( one, real( q( jc, jc ) ) )
663 q( jc, jc ) = cone
664 CALL clarfg( n+1-jc, z( jc, jc ), z( jc+1, jc ), 1,
665 $ work( n+jc ) )
666 work( 3*n+jc ) = sign( one, real( z( jc, jc ) ) )
667 z( jc, jc ) = cone
668 40 CONTINUE
669 ctemp = clarnd( 3, iseed )
670 q( n, n ) = cone
671 work( n ) = czero
672 work( 3*n ) = ctemp / abs( ctemp )
673 ctemp = clarnd( 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 $ conjg( work( 3*n+jc ) )*
684 $ a( jr, jc )
685 b( jr, jc ) = work( 2*n+jr )*
686 $ conjg( work( 3*n+jc ) )*
687 $ b( jr, jc )
688 50 CONTINUE
689 60 CONTINUE
690 CALL cunm2r( '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 cunm2r( '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 cunm2r( '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 cunm2r( '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 $ clarnd( 4, iseed )
715 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
716 $ clarnd( 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 CLAQZ0
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 CGGEV3 to compute eigenvalues and eigenvectors.
745*
746 CALL clacpy( ' ', n, n, a, lda, s, lda )
747 CALL clacpy( ' ', n, n, b, lda, t, lda )
748 CALL cggev3( '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 )'CGGEV31', 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 cget52( .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', 'CGGEV31',
764 $ result( 2 ), n, jtype, ioldsd
765 END IF
766*
767* Do the tests (3) and (4)
768*
769 CALL cget52( .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', 'CGGEV31',
773 $ result( 4 ), n, jtype, ioldsd
774 END IF
775*
776* Do test (5)
777*
778 CALL clacpy( ' ', n, n, a, lda, s, lda )
779 CALL clacpy( ' ', n, n, b, lda, t, lda )
780 CALL cggev3( '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 )'CGGEV32', 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 the test (6): Compute eigenvalues and left eigenvectors,
796* and test them
797*
798 CALL clacpy( ' ', n, n, a, lda, s, lda )
799 CALL clacpy( ' ', n, n, b, lda, t, lda )
800 CALL cggev3( '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 )'CGGEV33', ierr, n, jtype,
805 $ ioldsd
806 info = abs( ierr )
807 GO TO 190
808 END IF
809
810*
811 DO 130 j = 1, n
812 IF( alpha( j ).NE.alpha1( j ) .OR.
813 $ beta( j ).NE.beta1( j ) ) THEN
814 result( 6 ) = ulpinv
815 ENDIF
816 130 CONTINUE
817*
818 DO 150 j = 1, n
819 DO 140 jc = 1, n
820 IF( q( j, jc ).NE.qe( j, jc ) ) THEN
821 result( 6 ) = ulpinv
822 END IF
823 140 CONTINUE
824 150 CONTINUE
825*
826* DO the test (7): Compute eigenvalues and right eigenvectors,
827* and test them
828*
829 CALL clacpy( ' ', n, n, a, lda, s, lda )
830 CALL clacpy( ' ', n, n, b, lda, t, lda )
831 CALL cggev3( 'N', 'V', n, s, lda, t, lda, alpha1, beta1, q,
832 $ ldq, qe, ldqe, work, lwork, rwork, ierr )
833 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
834 result( 1 ) = ulpinv
835 WRITE( nounit, fmt = 9999 )'CGGEV34', ierr, n, jtype,
836 $ ioldsd
837 info = abs( ierr )
838 GO TO 190
839 END IF
840*
841 DO 160 j = 1, n
842 IF( alpha( j ).NE.alpha1( j ) .OR. beta( j ).NE.
843 $ beta1( j ) )result( 7 ) = ulpinv
844 160 CONTINUE
845*
846 DO 180 j = 1, n
847 DO 170 jc = 1, n
848 IF( z( j, jc ).NE.qe( j, jc ) )
849 $ result( 7 ) = ulpinv
850 170 CONTINUE
851 180 CONTINUE
852*
853* End of Loop -- Check for RESULT(j) > THRESH
854*
855 190 CONTINUE
856*
857 ntestt = ntestt + 7
858*
859* Print out tests which fail.
860*
861 DO 200 jr = 1, 7
862 IF( result( jr ).GE.thresh ) THEN
863*
864* If this is the first test to fail,
865* print a header to the data file.
866*
867 IF( nerrs.EQ.0 ) THEN
868 WRITE( nounit, fmt = 9997 )'CGV'
869*
870* Matrix types
871*
872 WRITE( nounit, fmt = 9996 )
873 WRITE( nounit, fmt = 9995 )
874 WRITE( nounit, fmt = 9994 )'Orthogonal'
875*
876* Tests performed
877*
878 WRITE( nounit, fmt = 9993 )
879*
880 END IF
881 nerrs = nerrs + 1
882 IF( result( jr ).LT.10000.0 ) THEN
883 WRITE( nounit, fmt = 9992 )n, jtype, ioldsd, jr,
884 $ result( jr )
885 ELSE
886 WRITE( nounit, fmt = 9991 )n, jtype, ioldsd, jr,
887 $ result( jr )
888 END IF
889 END IF
890 200 CONTINUE
891*
892 210 CONTINUE
893 220 CONTINUE
894*
895* Summary
896*
897 CALL alasvm( 'CGV3', nounit, nerrs, ntestt, 0 )
898*
899 work( 1 ) = maxwrk
900*
901 RETURN
902*
903 9999 FORMAT( ' CDRGEV3: ', a, ' returned INFO=', i6, '.', / 3x, 'N=',
904 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
905*
906 9998 FORMAT( ' CDRGEV3: ', a, ' Eigenvectors from ', a,
907 $ ' incorrectly normalized.', / ' Bits of error=', 0p, g10.3,
908 $ ',', 3x, 'N=', i4, ', JTYPE=', i3, ', ISEED=(',
909 $ 3( i4, ',' ), i5, ')' )
910*
911 9997 FORMAT( / 1x, a3, ' -- Complex Generalized eigenvalue problem ',
912 $ 'driver' )
913*
914 9996 FORMAT( ' Matrix types (see CDRGEV3 for details): ' )
915*
916 9995 FORMAT( ' Special Matrices:', 23x,
917 $ '(J''=transposed Jordan block)',
918 $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
919 $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
920 $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
921 $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
922 $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
923 $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
924 9994 FORMAT( ' Matrices Rotated by Random ', a, ' Matrices U, V:',
925 $ / ' 16=Transposed Jordan Blocks 19=geometric ',
926 $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
927 $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
928 $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
929 $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
930 $ '23=(small,large) 24=(small,small) 25=(large,large)',
931 $ / ' 26=random O(1) matrices.' )
932*
933 9993 FORMAT( / ' Tests performed: ',
934 $ / ' 1 = max | ( b A - a B )''*l | / const.,',
935 $ / ' 2 = | |VR(i)| - 1 | / ulp,',
936 $ / ' 3 = max | ( b A - a B )*r | / const.',
937 $ / ' 4 = | |VL(i)| - 1 | / ulp,',
938 $ / ' 5 = 0 if W same no matter if r or l computed,',
939 $ / ' 6 = 0 if l same no matter if l computed,',
940 $ / ' 7 = 0 if r same no matter if r computed,', / 1x )
941 9992 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
942 $ 4( i4, ',' ), ' result ', i2, ' is', 0p, f8.2 )
943 9991 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
944 $ 4( i4, ',' ), ' result ', i2, ' is', 1p, e10.3 )
945*
946* End of CDRGEV3
947*
cggev3
subroutine cggev3(jobvl, jobvr, n, a, lda, b, ldb, alpha, beta, vl, ldvl, vr, ldvr, work, lwork, rwork, info)
CGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (...
Definition cggev3.f:216

◆ cdrgsx()

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

CDRGSX

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

◆ cdrgvx()

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

CDRGVX

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

◆ cdrvbd()

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

CDRVBD

Purpose:
!>
!> CDRVBD checks the singular value decomposition (SVD) driver CGESVD,
!> CGESDD, CGESVJ, CGEJSV, CGESVDX, and CGESVDQ.
!>
!> CGESVD and CGESDD 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 CDRVBD 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 CGESVD:
!>
!> (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 CGESDD:
!>
!> (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 CGESVDQ:
!>
!> (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 CGESVJ:
!>
!> (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 CGEJSV:
!>
!> (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 CGESVDX( 'V', 'V', 'A' )/CGESVDX( '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 CGESVDX( '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 CGESVDX( '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,
!>          CDRVBD 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, CDRVBD
!>          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 CDRVBD to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 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 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 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 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 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 REAL array, dimension (max(min(MM,NN)))
!>          Contains the computed singular values.
!>
[out]SSAV
!>          SSAV is REAL array, dimension (max(min(MM,NN)))
!>          Contains another copy of the computed singular values.
!>
[out]E
!>          E is REAL array, dimension (max(min(MM,NN)))
!>          Workspace for CGESVD.
!>
[out]WORK
!>          WORK is COMPLEX 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 REAL 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) ).
!>          -29: LWORK too small.
!>          If  CLATMS, or CGESVD 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 cdrvbd.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 REAL THRESH
412* ..
413* .. Array Arguments ..
414 LOGICAL DOTYPE( * )
415 INTEGER ISEED( 4 ), IWORK( * ), MM( * ), NN( * )
416 REAL E( * ), RWORK( * ), S( * ), SSAV( * )
417 COMPLEX A( LDA, * ), ASAV( LDA, * ), U( LDU, * ),
418 $ USAV( LDU, * ), VT( LDVT, * ),
419 $ VTSAV( LDVT, * ), WORK( * )
420* ..
421*
422* =====================================================================
423*
424* .. Parameters ..
425 REAL ZERO, ONE, TWO, HALF
426 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
427 $ half = 0.5e0 )
428 COMPLEX CZERO, CONE
429 parameter( czero = ( 0.0e+0, 0.0e+0 ),
430 $ cone = ( 1.0e+0, 0.0e+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 REAL ANORM, DIF, DIV, OVFL, RTUNFL, ULP, ULPINV,
443 $ UNFL, VL, VU
444* ..
445* .. Local Scalars for CGESVDQ ..
446 INTEGER LIWORK, NUMRANK
447* ..
448* .. Local Arrays ..
449 CHARACTER CJOB( 4 ), CJOBR( 3 ), CJOBV( 2 )
450 INTEGER IOLDSD( 4 ), ISEED2( 4 )
451 REAL RESULT( 39 )
452* ..
453* .. External Functions ..
454 REAL SLAMCH, SLARND
455 EXTERNAL slamch, slarnd
456* ..
457* .. External Subroutines ..
458 EXTERNAL alasvm, xerbla, cbdt01, cbdt05, cgesdd,
459 $ cgesvd, cgesvdq, cgesvj, cgejsv, cgesvdx,
460 $ clacpy, claset, clatms, cunt01, cunt03
461* ..
462* .. Intrinsic Functions ..
463 INTRINSIC abs, real, 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( 'CDRVBD', -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 = slamch( 'S' )
539 ovfl = one / unfl
540 ulp = slamch( 'E' )
541 ulpinv = one / ulp
542 rtunfl = sqrt( unfl )
543*
544* Loop over sizes, types
545*
546 nerrs = 0
547*
548 DO 310 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 300 jtype = 1, mtypes
560 IF( .NOT.dotype( jtype ) )
561 $ GO TO 300
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 claset( '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 claset( '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 clatms( m, n, 'U', iseed, 'N', s, 4, real( 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 clacpy( 'F', m, n, a, lda, asav, lda )
613*
614* Do for minimal and adequate (for blocking) workspace
615*
616 DO 290 iwspc = 1, 4
617*
618* Test for CGESVD
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 clacpy( 'F', m, n, asav, lda, a, lda )
635 srnamt = 'CGESVD'
636 CALL cgesvd( '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 cbdt01( 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 cunt01( 'Columns', mnmin, m, usav, ldu, work,
651 $ lwork, rwork, result( 2 ) )
652 CALL cunt01( '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 clacpy( 'F', m, n, asav, lda, a, lda )
679 srnamt = 'CGESVD'
680 CALL cgesvd( 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 cunt03( '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 cunt03( '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 cunt03( '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 cunt03( '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 cunt03( '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 cunt03( '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( real( mnmin )*ulp*s( 1 ),
727 $ slamch( '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 CGESDD
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 clacpy( 'F', m, n, asav, lda, a, lda )
751 srnamt = 'CGESDD'
752 CALL cgesdd( '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 cbdt01( 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 cunt01( 'Columns', mnmin, m, usav, ldu, work,
767 $ lwork, rwork, result( 9 ) )
768 CALL cunt01( '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 clacpy( 'F', m, n, asav, lda, a, lda )
791 srnamt = 'CGESDD'
792 CALL cgesdd( 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 cunt03( 'C', m, mnmin, m, mnmin, usav,
802 $ ldu, a, lda, work, lwork, rwork,
803 $ dif, iinfo )
804 ELSE
805 CALL cunt03( '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 cunt03( '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 cunt03( 'R', n, mnmin, n, mnmin, vtsav,
824 $ ldvt, vt, ldvt, work, lwork,
825 $ rwork, dif, iinfo )
826 ELSE
827 CALL cunt03( '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 cunt03( '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( real( mnmin )*ulp*s( 1 ),
843 $ slamch( '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*
855* Test CGESVDQ
856* Note: CGESVDQ only works for M >= N
857*
858 result( 36 ) = zero
859 result( 37 ) = zero
860 result( 38 ) = zero
861 result( 39 ) = zero
862*
863 IF( m.GE.n ) THEN
864 iwtmp = 2*mnmin*mnmin + 2*mnmin + max( m, n )
865 lswork = iwtmp + ( iwspc-1 )*( lwork-iwtmp ) / 3
866 lswork = min( lswork, lwork )
867 lswork = max( lswork, 1 )
868 IF( iwspc.EQ.4 )
869 $ lswork = lwork
870*
871 CALL clacpy( 'F', m, n, asav, lda, a, lda )
872 srnamt = 'CGESVDQ'
873*
874 lrwork = max(2, m, 5*n)
875 liwork = max( n, 1 )
876 CALL cgesvdq( 'H', 'N', 'N', 'A', 'A',
877 $ m, n, a, lda, ssav, usav, ldu,
878 $ vtsav, ldvt, numrank, iwork, liwork,
879 $ work, lwork, rwork, lrwork, iinfo )
880*
881 IF( iinfo.NE.0 ) THEN
882 WRITE( nounit, fmt = 9995 )'CGESVDQ', iinfo, m, n,
883 $ jtype, lswork, ioldsd
884 info = abs( iinfo )
885 RETURN
886 END IF
887*
888* Do tests 36--39
889*
890 CALL cbdt01( m, n, 0, asav, lda, usav, ldu, ssav, e,
891 $ vtsav, ldvt, work, rwork, result( 36 ) )
892 IF( m.NE.0 .AND. n.NE.0 ) THEN
893 CALL cunt01( 'Columns', m, m, usav, ldu, work,
894 $ lwork, rwork, result( 37 ) )
895 CALL cunt01( 'Rows', n, n, vtsav, ldvt, work,
896 $ lwork, rwork, result( 38 ) )
897 END IF
898 result( 39 ) = zero
899 DO 199 i = 1, mnmin - 1
900 IF( ssav( i ).LT.ssav( i+1 ) )
901 $ result( 39 ) = ulpinv
902 IF( ssav( i ).LT.zero )
903 $ result( 39 ) = ulpinv
904 199 CONTINUE
905 IF( mnmin.GE.1 ) THEN
906 IF( ssav( mnmin ).LT.zero )
907 $ result( 39 ) = ulpinv
908 END IF
909 END IF
910*
911* Test CGESVJ
912* Note: CGESVJ only works for M >= N
913*
914 result( 15 ) = zero
915 result( 16 ) = zero
916 result( 17 ) = zero
917 result( 18 ) = zero
918*
919 IF( m.GE.n ) THEN
920 iwtmp = 2*mnmin*mnmin + 2*mnmin + max( m, n )
921 lswork = iwtmp + ( iwspc-1 )*( lwork-iwtmp ) / 3
922 lswork = min( lswork, lwork )
923 lswork = max( lswork, 1 )
924 lrwork = max(6,n)
925 IF( iwspc.EQ.4 )
926 $ lswork = lwork
927*
928 CALL clacpy( 'F', m, n, asav, lda, usav, lda )
929 srnamt = 'CGESVJ'
930 CALL cgesvj( 'G', 'U', 'V', m, n, usav, lda, ssav,
931 & 0, a, ldvt, work, lwork, rwork,
932 & lrwork, iinfo )
933*
934* CGESVJ returns V not VH
935*
936 DO j=1,n
937 DO i=1,n
938 vtsav(j,i) = conjg(a(i,j))
939 END DO
940 END DO
941*
942 IF( iinfo.NE.0 ) THEN
943 WRITE( nounit, fmt = 9995 )'GESVJ', iinfo, m, n,
944 $ jtype, lswork, ioldsd
945 info = abs( iinfo )
946 RETURN
947 END IF
948*
949* Do tests 15--18
950*
951 CALL cbdt01( m, n, 0, asav, lda, usav, ldu, ssav, e,
952 $ vtsav, ldvt, work, rwork, result( 15 ) )
953 IF( m.NE.0 .AND. n.NE.0 ) THEN
954 CALL cunt01( 'Columns', m, m, usav, ldu, work,
955 $ lwork, rwork, result( 16 ) )
956 CALL cunt01( 'Rows', n, n, vtsav, ldvt, work,
957 $ lwork, rwork, result( 17 ) )
958 END IF
959 result( 18 ) = zero
960 DO 131 i = 1, mnmin - 1
961 IF( ssav( i ).LT.ssav( i+1 ) )
962 $ result( 18 ) = ulpinv
963 IF( ssav( i ).LT.zero )
964 $ result( 18 ) = ulpinv
965 131 CONTINUE
966 IF( mnmin.GE.1 ) THEN
967 IF( ssav( mnmin ).LT.zero )
968 $ result( 18 ) = ulpinv
969 END IF
970 END IF
971*
972* Test CGEJSV
973* Note: CGEJSV only works for M >= N
974*
975 result( 19 ) = zero
976 result( 20 ) = zero
977 result( 21 ) = zero
978 result( 22 ) = zero
979 IF( m.GE.n ) THEN
980 iwtmp = 2*mnmin*mnmin + 2*mnmin + max( m, n )
981 lswork = iwtmp + ( iwspc-1 )*( lwork-iwtmp ) / 3
982 lswork = min( lswork, lwork )
983 lswork = max( lswork, 1 )
984 IF( iwspc.EQ.4 )
985 $ lswork = lwork
986 lrwork = max( 7, n + 2*m)
987*
988 CALL clacpy( 'F', m, n, asav, lda, vtsav, lda )
989 srnamt = 'CGEJSV'
990 CALL cgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
991 & m, n, vtsav, lda, ssav, usav, ldu, a, ldvt,
992 & work, lwork, rwork,
993 & lrwork, iwork, iinfo )
994*
995* CGEJSV returns V not VH
996*
997 DO 133 j=1,n
998 DO 132 i=1,n
999 vtsav(j,i) = conjg(a(i,j))
1000 132 END DO
1001 133 END DO
1002*
1003 IF( iinfo.NE.0 ) THEN
1004 WRITE( nounit, fmt = 9995 )'GEJSV', iinfo, m, n,
1005 $ jtype, lswork, ioldsd
1006 info = abs( iinfo )
1007 RETURN
1008 END IF
1009*
1010* Do tests 19--22
1011*
1012 CALL cbdt01( m, n, 0, asav, lda, usav, ldu, ssav, e,
1013 $ vtsav, ldvt, work, rwork, result( 19 ) )
1014 IF( m.NE.0 .AND. n.NE.0 ) THEN
1015 CALL cunt01( 'Columns', m, m, usav, ldu, work,
1016 $ lwork, rwork, result( 20 ) )
1017 CALL cunt01( 'Rows', n, n, vtsav, ldvt, work,
1018 $ lwork, rwork, result( 21 ) )
1019 END IF
1020 result( 22 ) = zero
1021 DO 134 i = 1, mnmin - 1
1022 IF( ssav( i ).LT.ssav( i+1 ) )
1023 $ result( 22 ) = ulpinv
1024 IF( ssav( i ).LT.zero )
1025 $ result( 22 ) = ulpinv
1026 134 CONTINUE
1027 IF( mnmin.GE.1 ) THEN
1028 IF( ssav( mnmin ).LT.zero )
1029 $ result( 22 ) = ulpinv
1030 END IF
1031 END IF
1032*
1033* Test CGESVDX
1034*
1035* Factorize A
1036*
1037 CALL clacpy( 'F', m, n, asav, lda, a, lda )
1038 srnamt = 'CGESVDX'
1039 CALL cgesvdx( 'V', 'V', 'A', m, n, a, lda,
1040 $ vl, vu, il, iu, ns, ssav, usav, ldu,
1041 $ vtsav, ldvt, work, lwork, rwork,
1042 $ iwork, iinfo )
1043 IF( iinfo.NE.0 ) THEN
1044 WRITE( nounit, fmt = 9995 )'GESVDX', iinfo, m, n,
1045 $ jtype, lswork, ioldsd
1046 info = abs( iinfo )
1047 RETURN
1048 END IF
1049*
1050* Do tests 1--4
1051*
1052 result( 23 ) = zero
1053 result( 24 ) = zero
1054 result( 25 ) = zero
1055 CALL cbdt01( m, n, 0, asav, lda, usav, ldu, ssav, e,
1056 $ vtsav, ldvt, work, rwork, result( 23 ) )
1057 IF( m.NE.0 .AND. n.NE.0 ) THEN
1058 CALL cunt01( 'Columns', mnmin, m, usav, ldu, work,
1059 $ lwork, rwork, result( 24 ) )
1060 CALL cunt01( 'Rows', mnmin, n, vtsav, ldvt, work,
1061 $ lwork, rwork, result( 25 ) )
1062 END IF
1063 result( 26 ) = zero
1064 DO 140 i = 1, mnmin - 1
1065 IF( ssav( i ).LT.ssav( i+1 ) )
1066 $ result( 26 ) = ulpinv
1067 IF( ssav( i ).LT.zero )
1068 $ result( 26 ) = ulpinv
1069 140 CONTINUE
1070 IF( mnmin.GE.1 ) THEN
1071 IF( ssav( mnmin ).LT.zero )
1072 $ result( 26 ) = ulpinv
1073 END IF
1074*
1075* Do partial SVDs, comparing to SSAV, USAV, and VTSAV
1076*
1077 result( 27 ) = zero
1078 result( 28 ) = zero
1079 result( 29 ) = zero
1080 DO 170 iju = 0, 1
1081 DO 160 ijvt = 0, 1
1082 IF( ( iju.EQ.0 .AND. ijvt.EQ.0 ) .OR.
1083 $ ( iju.EQ.1 .AND. ijvt.EQ.1 ) ) GO TO 160
1084 jobu = cjobv( iju+1 )
1085 jobvt = cjobv( ijvt+1 )
1086 range = cjobr( 1 )
1087 CALL clacpy( 'F', m, n, asav, lda, a, lda )
1088 srnamt = 'CGESVDX'
1089 CALL cgesvdx( jobu, jobvt, 'A', m, n, a, lda,
1090 $ vl, vu, il, iu, ns, ssav, u, ldu,
1091 $ vt, ldvt, work, lwork, rwork,
1092 $ iwork, iinfo )
1093*
1094* Compare U
1095*
1096 dif = zero
1097 IF( m.GT.0 .AND. n.GT.0 ) THEN
1098 IF( iju.EQ.1 ) THEN
1099 CALL cunt03( 'C', m, mnmin, m, mnmin, usav,
1100 $ ldu, u, ldu, work, lwork, rwork,
1101 $ dif, iinfo )
1102 END IF
1103 END IF
1104 result( 27 ) = max( result( 27 ), dif )
1105*
1106* Compare VT
1107*
1108 dif = zero
1109 IF( m.GT.0 .AND. n.GT.0 ) THEN
1110 IF( ijvt.EQ.1 ) THEN
1111 CALL cunt03( 'R', n, mnmin, n, mnmin, vtsav,
1112 $ ldvt, vt, ldvt, work, lwork,
1113 $ rwork, dif, iinfo )
1114 END IF
1115 END IF
1116 result( 28 ) = max( result( 28 ), dif )
1117*
1118* Compare S
1119*
1120 dif = zero
1121 div = max( real( mnmin )*ulp*s( 1 ),
1122 $ slamch( 'Safe minimum' ) )
1123 DO 150 i = 1, mnmin - 1
1124 IF( ssav( i ).LT.ssav( i+1 ) )
1125 $ dif = ulpinv
1126 IF( ssav( i ).LT.zero )
1127 $ dif = ulpinv
1128 dif = max( dif, abs( ssav( i )-s( i ) ) / div )
1129 150 CONTINUE
1130 result( 29) = max( result( 29 ), dif )
1131 160 CONTINUE
1132 170 CONTINUE
1133*
1134* Do tests 8--10
1135*
1136 DO 180 i = 1, 4
1137 iseed2( i ) = iseed( i )
1138 180 CONTINUE
1139 IF( mnmin.LE.1 ) THEN
1140 il = 1
1141 iu = max( 1, mnmin )
1142 ELSE
1143 il = 1 + int( ( mnmin-1 )*slarnd( 1, iseed2 ) )
1144 iu = 1 + int( ( mnmin-1 )*slarnd( 1, iseed2 ) )
1145 IF( iu.LT.il ) THEN
1146 itemp = iu
1147 iu = il
1148 il = itemp
1149 END IF
1150 END IF
1151 CALL clacpy( 'F', m, n, asav, lda, a, lda )
1152 srnamt = 'CGESVDX'
1153 CALL cgesvdx( 'V', 'V', 'I', m, n, a, lda,
1154 $ vl, vu, il, iu, nsi, s, u, ldu,
1155 $ vt, ldvt, work, lwork, rwork,
1156 $ iwork, iinfo )
1157 IF( iinfo.NE.0 ) THEN
1158 WRITE( nounit, fmt = 9995 )'GESVDX', iinfo, m, n,
1159 $ jtype, lswork, ioldsd
1160 info = abs( iinfo )
1161 RETURN
1162 END IF
1163*
1164 result( 30 ) = zero
1165 result( 31 ) = zero
1166 result( 32 ) = zero
1167 CALL cbdt05( m, n, asav, lda, s, nsi, u, ldu,
1168 $ vt, ldvt, work, result( 30 ) )
1169 IF( m.NE.0 .AND. n.NE.0 ) THEN
1170 CALL cunt01( 'Columns', m, nsi, u, ldu, work,
1171 $ lwork, rwork, result( 31 ) )
1172 CALL cunt01( 'Rows', nsi, n, vt, ldvt, work,
1173 $ lwork, rwork, result( 32 ) )
1174 END IF
1175*
1176* Do tests 11--13
1177*
1178 IF( mnmin.GT.0 .AND. nsi.GT.1 ) THEN
1179 IF( il.NE.1 ) THEN
1180 vu = ssav( il ) +
1181 $ max( half*abs( ssav( il )-ssav( il-1 ) ),
1182 $ ulp*anorm, two*rtunfl )
1183 ELSE
1184 vu = ssav( 1 ) +
1185 $ max( half*abs( ssav( ns )-ssav( 1 ) ),
1186 $ ulp*anorm, two*rtunfl )
1187 END IF
1188 IF( iu.NE.ns ) THEN
1189 vl = ssav( iu ) - max( ulp*anorm, two*rtunfl,
1190 $ half*abs( ssav( iu+1 )-ssav( iu ) ) )
1191 ELSE
1192 vl = ssav( ns ) - max( ulp*anorm, two*rtunfl,
1193 $ half*abs( ssav( ns )-ssav( 1 ) ) )
1194 END IF
1195 vl = max( vl,zero )
1196 vu = max( vu,zero )
1197 IF( vl.GE.vu ) vu = max( vu*2, vu+vl+half )
1198 ELSE
1199 vl = zero
1200 vu = one
1201 END IF
1202 CALL clacpy( 'F', m, n, asav, lda, a, lda )
1203 srnamt = 'CGESVDX'
1204 CALL cgesvdx( 'V', 'V', 'V', m, n, a, lda,
1205 $ vl, vu, il, iu, nsv, s, u, ldu,
1206 $ vt, ldvt, work, lwork, rwork,
1207 $ iwork, iinfo )
1208 IF( iinfo.NE.0 ) THEN
1209 WRITE( nounit, fmt = 9995 )'GESVDX', iinfo, m, n,
1210 $ jtype, lswork, ioldsd
1211 info = abs( iinfo )
1212 RETURN
1213 END IF
1214*
1215 result( 33 ) = zero
1216 result( 34 ) = zero
1217 result( 35 ) = zero
1218 CALL cbdt05( m, n, asav, lda, s, nsv, u, ldu,
1219 $ vt, ldvt, work, result( 33 ) )
1220 IF( m.NE.0 .AND. n.NE.0 ) THEN
1221 CALL cunt01( 'Columns', m, nsv, u, ldu, work,
1222 $ lwork, rwork, result( 34 ) )
1223 CALL cunt01( 'Rows', nsv, n, vt, ldvt, work,
1224 $ lwork, rwork, result( 35 ) )
1225 END IF
1226*
1227* End of Loop -- Check for RESULT(j) > THRESH
1228*
1229 ntest = 0
1230 nfail = 0
1231 DO 190 j = 1, 39
1232 IF( result( j ).GE.zero )
1233 $ ntest = ntest + 1
1234 IF( result( j ).GE.thresh )
1235 $ nfail = nfail + 1
1236 190 CONTINUE
1237*
1238 IF( nfail.GT.0 )
1239 $ ntestf = ntestf + 1
1240 IF( ntestf.EQ.1 ) THEN
1241 WRITE( nounit, fmt = 9999 )
1242 WRITE( nounit, fmt = 9998 )thresh
1243 ntestf = 2
1244 END IF
1245*
1246 DO 200 j = 1, 39
1247 IF( result( j ).GE.thresh ) THEN
1248 WRITE( nounit, fmt = 9997 )m, n, jtype, iwspc,
1249 $ ioldsd, j, result( j )
1250 END IF
1251 200 CONTINUE
1252*
1253 nerrs = nerrs + nfail
1254 ntestt = ntestt + ntest
1255*
1256 290 CONTINUE
1257*
1258 300 CONTINUE
1259 310 CONTINUE
1260*
1261* Summary
1262*
1263 CALL alasvm( 'CBD', nounit, nerrs, ntestt, 0 )
1264*
1265 9999 FORMAT( ' SVD -- Complex Singular Value Decomposition Driver ',
1266 $ / ' Matrix types (see CDRVBD for details):',
1267 $ / / ' 1 = Zero matrix', / ' 2 = Identity matrix',
1268 $ / ' 3 = Evenly spaced singular values near 1',
1269 $ / ' 4 = Evenly spaced singular values near underflow',
1270 $ / ' 5 = Evenly spaced singular values near overflow',
1271 $ / / ' Tests performed: ( A is dense, U and V are unitary,',
1272 $ / 19x, ' S is an array, and Upartial, VTpartial, and',
1273 $ / 19x, ' Spartial are partially computed U, VT and S),', / )
1274 9998 FORMAT( ' Tests performed with Test Threshold = ', f8.2,
1275 $ / ' CGESVD: ', /
1276 $ ' 1 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
1277 $ / ' 2 = | I - U**T U | / ( M ulp ) ',
1278 $ / ' 3 = | I - VT VT**T | / ( N ulp ) ',
1279 $ / ' 4 = 0 if S contains min(M,N) nonnegative values in',
1280 $ ' decreasing order, else 1/ulp',
1281 $ / ' 5 = | U - Upartial | / ( M ulp )',
1282 $ / ' 6 = | VT - VTpartial | / ( N ulp )',
1283 $ / ' 7 = | S - Spartial | / ( min(M,N) ulp |S| )',
1284 $ / ' CGESDD: ', /
1285 $ ' 8 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
1286 $ / ' 9 = | I - U**T U | / ( M ulp ) ',
1287 $ / '10 = | I - VT VT**T | / ( N ulp ) ',
1288 $ / '11 = 0 if S contains min(M,N) nonnegative values in',
1289 $ ' decreasing order, else 1/ulp',
1290 $ / '12 = | U - Upartial | / ( M ulp )',
1291 $ / '13 = | VT - VTpartial | / ( N ulp )',
1292 $ / '14 = | S - Spartial | / ( min(M,N) ulp |S| )',
1293 $ / ' CGESVJ: ', /
1294 $ / '15 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
1295 $ / '16 = | I - U**T U | / ( M ulp ) ',
1296 $ / '17 = | I - VT VT**T | / ( N ulp ) ',
1297 $ / '18 = 0 if S contains min(M,N) nonnegative values in',
1298 $ ' decreasing order, else 1/ulp',
1299 $ / ' CGESJV: ', /
1300 $ / '19 = | A - U diag(S) VT | / ( |A| max(M,N) ulp )',
1301 $ / '20 = | I - U**T U | / ( M ulp ) ',
1302 $ / '21 = | I - VT VT**T | / ( N ulp ) ',
1303 $ / '22 = 0 if S contains min(M,N) nonnegative values in',
1304 $ ' decreasing order, else 1/ulp',
1305 $ / ' CGESVDX(V,V,A): ', /
1306 $ '23 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
1307 $ / '24 = | I - U**T U | / ( M ulp ) ',
1308 $ / '25 = | I - VT VT**T | / ( N ulp ) ',
1309 $ / '26 = 0 if S contains min(M,N) nonnegative values in',
1310 $ ' decreasing order, else 1/ulp',
1311 $ / '27 = | U - Upartial | / ( M ulp )',
1312 $ / '28 = | VT - VTpartial | / ( N ulp )',
1313 $ / '29 = | S - Spartial | / ( min(M,N) ulp |S| )',
1314 $ / ' CGESVDX(V,V,I): ',
1315 $ / '30 = | U**T A VT**T - diag(S) | / ( |A| max(M,N) ulp )',
1316 $ / '31 = | I - U**T U | / ( M ulp ) ',
1317 $ / '32 = | I - VT VT**T | / ( N ulp ) ',
1318 $ / ' CGESVDX(V,V,V) ',
1319 $ / '33 = | U**T A VT**T - diag(S) | / ( |A| max(M,N) ulp )',
1320 $ / '34 = | I - U**T U | / ( M ulp ) ',
1321 $ / '35 = | I - VT VT**T | / ( N ulp ) ',
1322 $ ' CGESVDQ(H,N,N,A,A',
1323 $ / '36 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
1324 $ / '37 = | I - U**T U | / ( M ulp ) ',
1325 $ / '38 = | I - VT VT**T | / ( N ulp ) ',
1326 $ / '39 = 0 if S contains min(M,N) nonnegative values in',
1327 $ ' decreasing order, else 1/ulp',
1328 $ / / )
1329 9997 FORMAT( ' M=', i5, ', N=', i5, ', type ', i1, ', IWS=', i1,
1330 $ ', seed=', 4( i4, ',' ), ' test(', i2, ')=', g11.4 )
1331 9996 FORMAT( ' CDRVBD: ', a, ' returned INFO=', i6, '.', / 9x, 'M=',
1332 $ i6, ', N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ),
1333 $ i5, ')' )
1334 9995 FORMAT( ' CDRVBD: ', a, ' returned INFO=', i6, '.', / 9x, 'M=',
1335 $ i6, ', N=', i6, ', JTYPE=', i6, ', LSWORK=', i6, / 9x,
1336 $ 'ISEED=(', 3( i5, ',' ), i5, ')' )
1337*
1338 RETURN
1339*
1340* End of CDRVBD
1341*
cgesvj
subroutine cgesvj(joba, jobu, jobv, m, n, a, lda, sva, mv, v, ldv, cwork, lwork, rwork, lrwork, info)
CGESVJ
Definition cgesvj.f:351
cgesvdx
subroutine cgesvdx(jobu, jobvt, range, m, n, a, lda, vl, vu, il, iu, ns, s, u, ldu, vt, ldvt, work, lwork, rwork, iwork, info)
CGESVDX computes the singular value decomposition (SVD) for GE matrices
Definition cgesvdx.f:270
cgesdd
subroutine cgesdd(jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, iwork, info)
CGESDD
Definition cgesdd.f:227
cgejsv
subroutine cgejsv(joba, jobu, jobv, jobr, jobt, jobp, m, n, a, lda, sva, u, ldu, v, ldv, cwork, lwork, rwork, lrwork, iwork, info)
CGEJSV
Definition cgejsv.f:568
cgesvdq
subroutine cgesvdq(joba, jobp, jobr, jobu, jobv, m, n, a, lda, s, u, ldu, v, ldv, numrank, iwork, liwork, cwork, lcwork, rwork, lrwork, info)
CGESVDQ computes the singular value decomposition (SVD) with a QR-Preconditioned QR SVD Method for GE...
Definition cgesvdq.f:413
cunt03
subroutine cunt03(rc, mu, mv, n, k, u, ldu, v, ldv, work, lwork, rwork, result, info)
CUNT03
Definition cunt03.f:162
cbdt05
subroutine cbdt05(m, n, a, lda, s, ns, u, ldu, vt, ldvt, work, resid)
CBDT05
Definition cbdt05.f:125

◆ cdrves()

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

CDRVES

Purpose:
!>
!>    CDRVES checks the nonsymmetric eigenvalue (Schur form) problem
!>    driver CGEES.
!>
!>    When CDRVES 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,
!>          CDRVES 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, CDRVES
!>          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 CDRVES to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by CGEES.
!>
[out]HT
!>          HT is COMPLEX array, dimension (LDA, max(NN))
!>          Yet another copy of the test matrix A, modified by CGEES.
!>
[out]W
!>          W is COMPLEX array, dimension (max(NN))
!>          The computed eigenvalues of A.
!>
[out]WT
!>          WT is COMPLEX array, dimension (max(NN))
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when CGEES only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]VS
!>          VS is COMPLEX 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 REAL 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 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 REAL 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  CLATMR, CLATMS, CLATME or CGEES 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 cdrves.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 REAL THRESH
386* ..
387* .. Array Arguments ..
388 LOGICAL BWORK( * ), DOTYPE( * )
389 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
390 REAL RESULT( 13 ), RWORK( * )
391 COMPLEX A( LDA, * ), H( LDA, * ), HT( LDA, * ),
392 $ VS( LDVS, * ), W( * ), WORK( * ), WT( * )
393* ..
394*
395* =====================================================================
396*
397* .. Parameters ..
398 COMPLEX CZERO
399 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
400 COMPLEX CONE
401 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
402 REAL ZERO, ONE
403 parameter( zero = 0.0e+0, one = 1.0e+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,
413 $ NERRS, NFAIL, NMAX, NNWORK, NTEST, NTESTF,
414 $ NTESTT, RSUB, SDIM
415 REAL 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 REAL RES( 2 )
423* ..
424* .. Arrays in Common ..
425 LOGICAL SELVAL( 20 )
426 REAL 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 CSLECT
436 REAL SLAMCH
437 EXTERNAL cslect, slamch
438* ..
439* .. External Subroutines ..
440 EXTERNAL cgees, chst01, clacpy, clatme, clatmr, clatms,
441 $ claset, slabad, slasum, xerbla
442* ..
443* .. Intrinsic Functions ..
444 INTRINSIC abs, cmplx, 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 ) = 'Complex 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( 'CDRVES', -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 = slamch( 'Safe minimum' )
509 ovfl = one / unfl
510 CALL slabad( unfl, ovfl )
511 ulp = slamch( '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 claset( '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 ) = cmplx( 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 ) = cmplx( 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 clatms( 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 clatms( 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 clatme( 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 clatmr( 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 clatmr( 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 clatmr( 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 claset( 'Full', 2, n, czero, czero, a, lda )
668 CALL claset( 'Full', n-3, 1, czero, czero, a( 3, 1 ),
669 $ lda )
670 CALL claset( 'Full', n-3, 2, czero, czero,
671 $ a( 3, n-1 ), lda )
672 CALL claset( '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 clatmr( 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 clacpy( 'F', n, n, a, lda, h, lda )
729 CALL cgees( 'V', sort, cslect, 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 )'CGEES1', 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 chst01( 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 clacpy( 'F', n, n, a, lda, ht, lda )
768 CALL cgees( 'N', sort, cslect, 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 )'CGEES2', 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( cslect( w( i ) ) )
802 $ knteig = knteig + 1
803 IF( i.LT.n ) THEN
804 IF( cslect( w( i+1 ) ) .AND.
805 $ ( .NOT.cslect( 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 slasum( path, nounit, nerrs, ntestt )
857*
858 9999 FORMAT( / 1x, a3, ' -- Complex Schur Form Decomposition Driver',
859 $ / ' Matrix types (see CDRVES 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( ' CDRVES: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
905 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
906*
907 RETURN
908*
909* End of CDRVES
910*
cgees
subroutine cgees(jobvs, sort, select, n, a, lda, sdim, w, vs, ldvs, work, lwork, rwork, bwork, info)
CGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE m...
Definition cgees.f:197
cslect
logical function cslect(z)
CSLECT
Definition cslect.f:56

◆ cdrvev()

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

CDRVEV

Purpose:
!>
!>    CDRVEV  checks the nonsymmetric eigenvalue problem driver CGEEV.
!>
!>    When CDRVEV 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,
!>          CDRVEV 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, CDRVEV
!>          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 CDRVEV to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by CGEEV.
!>
[out]W
!>          W is COMPLEX array, dimension (max(NN))
!>          The eigenvalues of A. On exit, W are the eigenvalues of
!>          the matrix in A.
!>
[out]W1
!>          W1 is COMPLEX array, dimension (max(NN))
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when CGEEV only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is COMPLEX 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 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 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 REAL 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 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 REAL 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  CLATMR, CLATMS, CLATME or CGEEV 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 cdrvev.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 REAL THRESH
400* ..
401* .. Array Arguments ..
402 LOGICAL DOTYPE( * )
403 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
404 REAL RESULT( 7 ), RWORK( * )
405 COMPLEX A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
406 $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ),
407 $ WORK( * )
408* ..
409*
410* =====================================================================
411*
412* .. Parameters ..
413 COMPLEX CZERO
414 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
415 COMPLEX CONE
416 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
417 REAL ZERO, ONE
418 parameter( zero = 0.0e+0, one = 1.0e+0 )
419 REAL TWO
420 parameter( two = 2.0e+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,
429 $ NNWORK, NTEST, NTESTF, NTESTT
430 REAL 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 REAL RES( 2 )
438 COMPLEX DUM( 1 )
439* ..
440* .. External Functions ..
441 REAL SCNRM2, SLAMCH
442 EXTERNAL scnrm2, slamch
443* ..
444* .. External Subroutines ..
445 EXTERNAL cgeev, cget22, clacpy, clatme, clatmr, clatms,
446 $ claset, slabad, slasum, xerbla
447* ..
448* .. Intrinsic Functions ..
449 INTRINSIC abs, aimag, cmplx, max, min, real, 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 ) = 'Complex 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( 'CDRVEV', -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 = slamch( 'Safe minimum' )
517 ovfl = one / unfl
518 CALL slabad( unfl, ovfl )
519 ulp = slamch( '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 claset( '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 ) = cmplx( 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 ) = cmplx( 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 clatms( 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 clatms( 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 clatme( n, 'D', iseed, work, imode, cond, cone,
644 $ 'T', 'T', 'T', rwork, 4, conds, n, n,
645 $ anorm, a, lda, work( 2*n+1 ), iinfo )
646*
647 ELSE IF( itype.EQ.7 ) THEN
648*
649* Diagonal, random eigenvalues
650*
651 CALL clatmr( 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 clatmr( 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 clatmr( 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 claset( 'Full', 2, n, czero, czero, a, lda )
675 CALL claset( 'Full', n-3, 1, czero, czero, a( 3, 1 ),
676 $ lda )
677 CALL claset( 'Full', n-3, 2, czero, czero,
678 $ a( 3, n-1 ), lda )
679 CALL claset( '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 clatmr( 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 clacpy( 'F', n, n, a, lda, h, lda )
725 CALL cgeev( '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 )'CGEEV1', iinfo, n, jtype,
730 $ ioldsd
731 info = abs( iinfo )
732 GO TO 220
733 END IF
734*
735* Do Test (1)
736*
737 CALL cget22( '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 cget22( '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 = scnrm2( 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( aimag( vr( jj, j ) ).EQ.zero .AND.
760 $ abs( real( vr( jj, j ) ) ).GT.vrmx )
761 $ vrmx = abs( real( 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 = scnrm2( 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( aimag( vl( jj, j ) ).EQ.zero .AND.
780 $ abs( real( vl( jj, j ) ) ).GT.vrmx )
781 $ vrmx = abs( real( 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 clacpy( 'F', n, n, a, lda, h, lda )
790 CALL cgeev( '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 )'CGEEV2', 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 clacpy( 'F', n, n, a, lda, h, lda )
810 CALL cgeev( '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 )'CGEEV3', 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 clacpy( 'F', n, n, a, lda, h, lda )
839 CALL cgeev( '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 )'CGEEV4', 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 slasum( path, nounit, nerrs, ntestt )
906*
907 9999 FORMAT( / 1x, a3, ' -- Complex Eigenvalue-Eigenvector ',
908 $ 'Decomposition Driver', /
909 $ ' Matrix types (see CDRVEV 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( ' CDRVEV: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
944 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
945*
946 RETURN
947*
948* End of CDRVEV
949*
cgeev
subroutine cgeev(jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr, work, lwork, rwork, info)
CGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition cgeev.f:180
scnrm2
real(wp) function scnrm2(n, x, incx)
SCNRM2
Definition scnrm2.f90:90

◆ cdrvsg()

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

CDRVSG

Purpose:
!>
!>      CDRVSG checks the complex Hermitian generalized eigenproblem
!>      drivers.
!>
!>              CHEGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem.
!>
!>              CHEGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem using a divide and conquer algorithm.
!>
!>              CHEGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem.
!>
!>              CHPGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage.
!>
!>              CHPGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage using a divide and
!>              conquer algorithm.
!>
!>              CHPGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage.
!>
!>              CHBGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem.
!>
!>              CHBGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem using a divide and conquer
!>              algorithm.
!>
!>              CHBGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem.
!>
!>      When CDRVSG 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) CHEGV with ITYPE = 1 and UPLO ='U':
!>
!>              | A Z - B Z D | / ( |A| |Z| n ulp )
!>
!>      (2) as (1) but calling CHPGV
!>      (3) as (1) but calling CHBGV
!>      (4) as (1) but with UPLO = 'L'
!>      (5) as (4) but calling CHPGV
!>      (6) as (4) but calling CHBGV
!>
!>      (7) CHEGV with ITYPE = 2 and UPLO ='U':
!>
!>              | A B Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (8) as (7) but calling CHPGV
!>      (9) as (7) but with UPLO = 'L'
!>      (10) as (9) but calling CHPGV
!>
!>      (11) CHEGV with ITYPE = 3 and UPLO ='U':
!>
!>              | B A Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (12) as (11) but calling CHPGV
!>      (13) as (11) but with UPLO = 'L'
!>      (14) as (13) but calling CHPGV
!>
!>      CHEGVD, CHPGVD and CHBGVD performed the same 14 tests.
!>
!>      CHEGVX, CHPGVX and CHBGVX 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,
!>          CDRVSG 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, CDRVSG
!>          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 CDRVSG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  REAL
!>          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 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 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       REAL array, dimension (max(NN))
!>          The eigenvalues of A. On exit, the eigenvalues in D
!>          correspond with the matrix in A.
!>          Modified.
!>
!>  Z       COMPLEX 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 array, dimension (LDA, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  BB      COMPLEX array, dimension (LDB, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  AP      COMPLEX array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  BP      COMPLEX array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  WORK    COMPLEX 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   REAL 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  REAL 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  CLATMR, CLATMS, CHEGV, CHPGV, CHBGV, CHEGVD, CHPGVD,
!>              CHPGVD, CHEGVX, CHPGVX, CHBGVX 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 SLAFTS).
!>       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 cdrvsg.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 REAL THRESH
379* ..
380* .. Array Arguments ..
381 LOGICAL DOTYPE( * )
382 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
383 REAL D( * ), RESULT( * ), RWORK( * )
384 COMPLEX A( LDA, * ), AB( LDA, * ), AP( * ),
385 $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ),
386 $ Z( LDZ, * )
387* ..
388*
389* =====================================================================
390*
391* .. Parameters ..
392 REAL ZERO, ONE, TEN
393 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 10.0e+0 )
394 COMPLEX CZERO, CONE
395 parameter( czero = ( 0.0e+0, 0.0e+0 ),
396 $ cone = ( 1.0e+0, 0.0e+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 REAL 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 REAL SLAMCH, SLARND
418 EXTERNAL lsame, slamch, slarnd
419* ..
420* .. External Subroutines ..
421 EXTERNAL chbgv, chbgvd, chbgvx, chegv, chegvd, chegvx,
422 $ chpgv, chpgvd, chpgvx, clacpy, claset, clatmr,
423 $ clatms, csgt01, slabad, slafts, slasum, xerbla
424* ..
425* .. Intrinsic Functions ..
426 INTRINSIC abs, max, min, real, 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( 'CDRVSG', -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 = slamch( 'Safe minimum' )
483 ovfl = slamch( 'Overflow' )
484 CALL slabad( unfl, ovfl )
485 ulp = slamch( 'Epsilon' )*slamch( '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 / real( 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 claset( '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 claset( '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 clatms( 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 clatms( 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 clatmr( 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 clatmr( 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 clatms( 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 )*slarnd( 1, iseed2 )
667 iu = 1 + ( n-1 )*slarnd( 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 CHEGV, CHPGV, CHBGV, CHEGVD, CHPGVD, CHBGVD,
676* CHEGVX, CHPGVX and CHBGVX, 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 clatms( n, n, 'U', iseed, 'P', rwork, 5, ten,
697 $ one, kb, kb, uplo, b, ldb, work( n+1 ),
698 $ iinfo )
699*
700* Test CHEGV
701*
702 ntest = ntest + 1
703*
704 CALL clacpy( ' ', n, n, a, lda, z, ldz )
705 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
706*
707 CALL chegv( 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 )'CHEGV(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
724 $ ldz, d, work, rwork, result( ntest ) )
725*
726* Test CHEGVD
727*
728 ntest = ntest + 1
729*
730 CALL clacpy( ' ', n, n, a, lda, z, ldz )
731 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
732*
733 CALL chegvd( 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 )'CHEGVD(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
751 $ ldz, d, work, rwork, result( ntest ) )
752*
753* Test CHEGVX
754*
755 ntest = ntest + 1
756*
757 CALL clacpy( ' ', n, n, a, lda, ab, lda )
758 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
759*
760 CALL chegvx( 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 )'CHEGVX(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
779 $ ldz, d, work, rwork, result( ntest ) )
780*
781 ntest = ntest + 1
782*
783 CALL clacpy( ' ', n, n, a, lda, ab, lda )
784 CALL clacpy( 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 chegvx( 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 )'CHEGVX(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 csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
812 $ ldz, d, work, rwork, result( ntest ) )
813*
814 ntest = ntest + 1
815*
816 CALL clacpy( ' ', n, n, a, lda, ab, lda )
817 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
818*
819 CALL chegvx( 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 )'CHEGVX(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 csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
838 $ ldz, d, work, rwork, result( ntest ) )
839*
840 100 CONTINUE
841*
842* Test CHPGV
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 chpgv( ibtype, 'V', uplo, n, ap, bp, d, z, ldz,
869 $ work, rwork, iinfo )
870 IF( iinfo.NE.0 ) THEN
871 WRITE( nounit, fmt = 9999 )'CHPGV(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
885 $ ldz, d, work, rwork, result( ntest ) )
886*
887* Test CHPGVD
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 chpgvd( 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 )'CHPGVD(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
931 $ ldz, d, work, rwork, result( ntest ) )
932*
933* Test CHPGVX
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 chpgvx( 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 )'CHPGVX(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 csgt01( 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 chpgvx( 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 )'CHPGVX(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 csgt01( 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 chpgvx( 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 )'CHPGVX(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 csgt01( 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 CHBGV
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 chbgv( '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 )'CHBGV(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1116 $ ldz, d, work, rwork, result( ntest ) )
1117*
1118* TEST CHBGVD
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 chbgvd( '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 )'CHBGVD(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1162 $ ldz, d, work, rwork, result( ntest ) )
1163*
1164* Test CHBGVX
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 chbgvx( '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 )'CHBGVX(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 csgt01( 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 chbgvx( '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 )'CHBGVX(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 csgt01( 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 chbgvx( '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 )'CHBGVX(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 csgt01( 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 slafts( 'CSG', n, n, jtype, ntest, result, ioldsd,
1312 $ thresh, nounit, nerrs )
1313 640 CONTINUE
1314 650 CONTINUE
1315*
1316* Summary
1317*
1318 CALL slasum( 'CSG', nounit, nerrs, ntestt )
1319*
1320 RETURN
1321*
1322 9999 FORMAT( ' CDRVSG: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1323 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1324*
1325* End of CDRVSG
1326*
chegv
subroutine chegv(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, info)
CHEGV
Definition chegv.f:181
chegvx
subroutine chegvx(itype, jobz, range, uplo, n, a, lda, b, ldb, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, rwork, iwork, ifail, info)
CHEGVX
Definition chegvx.f:307
chegvd
subroutine chegvd(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, lrwork, iwork, liwork, info)
CHEGVD
Definition chegvd.f:249
chbgvd
subroutine chbgvd(jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
CHBGVD
Definition chbgvd.f:252
chpgvx
subroutine chpgvx(itype, jobz, range, uplo, n, ap, bp, vl, vu, il, iu, abstol, m, w, z, ldz, work, rwork, iwork, ifail, info)
CHPGVX
Definition chpgvx.f:277
chpgvd
subroutine chpgvd(itype, jobz, uplo, n, ap, bp, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
CHPGVD
Definition chpgvd.f:231
chbgvx
subroutine chbgvx(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)
CHBGVX
Definition chbgvx.f:300
chpgv
subroutine chpgv(itype, jobz, uplo, n, ap, bp, w, z, ldz, work, rwork, info)
CHPGV
Definition chpgv.f:165
chbgv
subroutine chbgv(jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, ldz, work, rwork, info)
CHBGV
Definition chbgv.f:183
csgt01
subroutine csgt01(itype, uplo, n, m, a, lda, b, ldb, z, ldz, d, work, rwork, result)
CSGT01
Definition csgt01.f:152

◆ cdrvsg2stg()

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

CDRVSG2STG

Purpose:
!>
!>      CDRVSG2STG checks the complex Hermitian generalized eigenproblem
!>      drivers.
!>
!>              CHEGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem.
!>
!>              CHEGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem using a divide and conquer algorithm.
!>
!>              CHEGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem.
!>
!>              CHPGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage.
!>
!>              CHPGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage using a divide and
!>              conquer algorithm.
!>
!>              CHPGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite generalized
!>              eigenproblem in packed storage.
!>
!>              CHBGV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem.
!>
!>              CHBGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem using a divide and conquer
!>              algorithm.
!>
!>              CHBGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian-definite banded
!>              generalized eigenproblem.
!>
!>      When CDRVSG2STG 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) CHEGV with ITYPE = 1 and UPLO ='U':
!>
!>              | A Z - B Z D | / ( |A| |Z| n ulp )
!>              | D - D2 | / ( |D| ulp )   where D is computed by
!>                                         CHEGV and  D2 is computed by
!>                                         CHEGV_2STAGE. This test is
!>                                         only performed for DSYGV
!>
!>      (2) as (1) but calling CHPGV
!>      (3) as (1) but calling CHBGV
!>      (4) as (1) but with UPLO = 'L'
!>      (5) as (4) but calling CHPGV
!>      (6) as (4) but calling CHBGV
!>
!>      (7) CHEGV with ITYPE = 2 and UPLO ='U':
!>
!>              | A B Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (8) as (7) but calling CHPGV
!>      (9) as (7) but with UPLO = 'L'
!>      (10) as (9) but calling CHPGV
!>
!>      (11) CHEGV with ITYPE = 3 and UPLO ='U':
!>
!>              | B A Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (12) as (11) but calling CHPGV
!>      (13) as (11) but with UPLO = 'L'
!>      (14) as (13) but calling CHPGV
!>
!>      CHEGVD, CHPGVD and CHBGVD performed the same 14 tests.
!>
!>      CHEGVX, CHPGVX and CHBGVX 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,
!>          CDRVSG2STG 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, CDRVSG2STG
!>          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 CDRVSG2STG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  REAL
!>          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 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 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       REAL             array, dimension (max(NN))
!>          The eigenvalues of A. On exit, the eigenvalues in D
!>          correspond with the matrix in A.
!>          Modified.
!>
!>  Z       COMPLEX 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 array, dimension (LDA, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  BB      COMPLEX array, dimension (LDB, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  AP      COMPLEX array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  BP      COMPLEX array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  WORK    COMPLEX 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   REAL 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  REAL 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  CLATMR, CLATMS, CHEGV, CHPGV, CHBGV, CHEGVD, CHPGVD,
!>              CHPGVD, CHEGVX, CHPGVX, CHBGVX 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 SLAFTS).
!>       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 cdrvsg2stg.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 REAL THRESH
387* ..
388* .. Array Arguments ..
389 LOGICAL DOTYPE( * )
390 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
391 REAL D( * ), D2( * ), RESULT( * ), RWORK( * )
392 COMPLEX A( LDA, * ), AB( LDA, * ), AP( * ),
393 $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ),
394 $ Z( LDZ, * )
395* ..
396*
397* =====================================================================
398*
399* .. Parameters ..
400 REAL ZERO, ONE, TEN
401 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 10.0e+0 )
402 COMPLEX CZERO, CONE
403 parameter( czero = ( 0.0e+0, 0.0e+0 ),
404 $ cone = ( 1.0e+0, 0.0e+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 REAL 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 REAL SLAMCH, SLARND
426 EXTERNAL lsame, slamch, slarnd
427* ..
428* .. External Subroutines ..
429 EXTERNAL slabad, slafts, slasum, xerbla, chbgv, chbgvd,
430 $ chbgvx, chegv, chegvd, chegvx, chpgv, chpgvd,
431 $ chpgvx, clacpy, claset, clatmr, clatms, csgt01,
432 $ chegv_2stage
433* ..
434* .. Intrinsic Functions ..
435 INTRINSIC abs, real, 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( 'CDRVSG2STG', -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 = slamch( 'Safe minimum' )
492 ovfl = slamch( 'Overflow' )
493 CALL slabad( unfl, ovfl )
494 ulp = slamch( 'Epsilon' )*slamch( '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 / real( 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 claset( '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 claset( '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 clatms( 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 clatms( 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 clatmr( 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 clatmr( 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 clatms( 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 )*slarnd( 1, iseed2 ) )
676 iu = 1 + int( ( n-1 )*slarnd( 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 CHEGV, CHPGV, CHBGV, CHEGVD, CHPGVD, CHBGVD,
685* CHEGVX, CHPGVX and CHBGVX, 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 clatms( n, n, 'U', iseed, 'P', rwork, 5, ten,
706 $ one, kb, kb, uplo, b, ldb, work( n+1 ),
707 $ iinfo )
708*
709* Test CHEGV
710*
711 ntest = ntest + 1
712*
713 CALL clacpy( ' ', n, n, a, lda, z, ldz )
714 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
715*
716 CALL chegv( 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 )'CHEGV(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
733 $ ldz, d, work, rwork, result( ntest ) )
734*
735* Test CHEGV_2STAGE
736*
737 ntest = ntest + 1
738*
739 CALL clacpy( ' ', n, n, a, lda, z, ldz )
740 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
741*
742 CALL chegv_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 $ 'CHEGV_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 CSGT01( 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 CHEGVD
779*
780 ntest = ntest + 1
781*
782 CALL clacpy( ' ', n, n, a, lda, z, ldz )
783 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
784*
785 CALL chegvd( 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 )'CHEGVD(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
803 $ ldz, d, work, rwork, result( ntest ) )
804*
805* Test CHEGVX
806*
807 ntest = ntest + 1
808*
809 CALL clacpy( ' ', n, n, a, lda, ab, lda )
810 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
811*
812 CALL chegvx( 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 )'CHEGVX(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
831 $ ldz, d, work, rwork, result( ntest ) )
832*
833 ntest = ntest + 1
834*
835 CALL clacpy( ' ', n, n, a, lda, ab, lda )
836 CALL clacpy( 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 chegvx( 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 )'CHEGVX(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 csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
864 $ ldz, d, work, rwork, result( ntest ) )
865*
866 ntest = ntest + 1
867*
868 CALL clacpy( ' ', n, n, a, lda, ab, lda )
869 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
870*
871 CALL chegvx( 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 )'CHEGVX(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 csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
890 $ ldz, d, work, rwork, result( ntest ) )
891*
892 100 CONTINUE
893*
894* Test CHPGV
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 chpgv( ibtype, 'V', uplo, n, ap, bp, d, z, ldz,
921 $ work, rwork, iinfo )
922 IF( iinfo.NE.0 ) THEN
923 WRITE( nounit, fmt = 9999 )'CHPGV(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
937 $ ldz, d, work, rwork, result( ntest ) )
938*
939* Test CHPGVD
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 chpgvd( 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 )'CHPGVD(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
983 $ ldz, d, work, rwork, result( ntest ) )
984*
985* Test CHPGVX
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 chpgvx( 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 )'CHPGVX(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 csgt01( 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 chpgvx( 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 )'CHPGVX(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 csgt01( 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 chpgvx( 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 )'CHPGVX(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 csgt01( 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 CHBGV
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 chbgv( '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 )'CHBGV(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1168 $ ldz, d, work, rwork, result( ntest ) )
1169*
1170* TEST CHBGVD
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 chbgvd( '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 )'CHBGVD(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 csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1214 $ ldz, d, work, rwork, result( ntest ) )
1215*
1216* Test CHBGVX
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 chbgvx( '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 )'CHBGVX(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 csgt01( 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 chbgvx( '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 )'CHBGVX(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 csgt01( 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 chbgvx( '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 )'CHBGVX(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 csgt01( 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 slafts( 'CSG', n, n, jtype, ntest, result, ioldsd,
1364 $ thresh, nounit, nerrs )
1365 640 CONTINUE
1366 650 CONTINUE
1367*
1368* Summary
1369*
1370 CALL slasum( 'CSG', nounit, nerrs, ntestt )
1371*
1372 RETURN
1373*
1374 9999 FORMAT( ' CDRVSG2STG: ', a, ' returned INFO=', i6, '.', / 9x,
1375 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1376*
1377* End of CDRVSG2STG
1378*
chegv_2stage
subroutine chegv_2stage(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, info)
CHEGV_2STAGE
Definition chegv_2stage.f:232

◆ cdrvst()

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

CDRVST

Purpose:
!>
!>      CDRVST  checks the Hermitian eigenvalue problem drivers.
!>
!>              CHEEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix,
!>              using a divide-and-conquer algorithm.
!>
!>              CHEEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix.
!>
!>              CHEEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              CHPEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage, using a divide-and-conquer algorithm.
!>
!>              CHPEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage.
!>
!>              CHBEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix,
!>              using a divide-and-conquer algorithm.
!>
!>              CHBEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix.
!>
!>              CHEEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix.
!>
!>              CHPEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage.
!>
!>              CHBEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix.
!>
!>      When CDRVST 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,
!>          CDRVST 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, CDRVST
!>          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 CDRVST to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  REAL
!>          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 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      REAL array, dimension (max(NN))
!>          The eigenvalues of A, as computed by CSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>          Modified.
!>
!>  D2      REAL array, dimension (max(NN))
!>          The eigenvalues of A, as computed by CSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>          Modified.
!>
!>  D3      REAL array, dimension (max(NN))
!>          The eigenvalues of A, as computed by SSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>          Modified.
!>
!>  WA1     REAL array, dimension
!>
!>  WA2     REAL array, dimension
!>
!>  WA3     REAL array, dimension
!>
!>  U       COMPLEX array, dimension (LDU, max(NN))
!>          The unitary matrix computed by CHETRD + CUNGC3.
!>          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 array, dimension (LDU, max(NN))
!>          The Housholder vectors computed by CHETRD in reducing A to
!>          tridiagonal form.
!>          Modified.
!>
!>  TAU     COMPLEX array, dimension (max(NN))
!>          The Householder factors computed by CHETRD in reducing A
!>          to tridiagonal form.
!>          Modified.
!>
!>  Z       COMPLEX array, dimension (LDU, max(NN))
!>          The unitary matrix of eigenvectors computed by CHEEVD,
!>          CHEEVX, CHPEVD, CHPEVX, CHBEVD, and CHBEVX.
!>          Modified.
!>
!>  WORK  - COMPLEX 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   REAL 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  REAL 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  SLATMR, SLATMS, CHETRD, SORGC3, CSTEQR, SSTERF,
!>              or SORMC2 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 SLAFTS).
!>       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 cdrvst.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 REAL THRESH
347* ..
348* .. Array Arguments ..
349 LOGICAL DOTYPE( * )
350 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
351 REAL D1( * ), D2( * ), D3( * ), RESULT( * ),
352 $ RWORK( * ), WA1( * ), WA2( * ), WA3( * )
353 COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ),
354 $ V( LDU, * ), WORK( * ), Z( LDU, * )
355* ..
356*
357* =====================================================================
358*
359*
360* .. Parameters ..
361 REAL ZERO, ONE, TWO, TEN
362 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
363 $ ten = 10.0e+0 )
364 REAL HALF
365 parameter( half = one / two )
366 COMPLEX CZERO, CONE
367 parameter( czero = ( 0.0e+0, 0.0e+0 ),
368 $ cone = ( 1.0e+0, 0.0e+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 REAL 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 REAL SLAMCH, SLARND, SSXT1
391 EXTERNAL slamch, slarnd, ssxt1
392* ..
393* .. External Subroutines ..
394 EXTERNAL alasvm, chbev, chbevd, chbevx, cheev, cheevd,
395 $ cheevr, cheevx, chet21, chet22, chpev, chpevd,
396 $ chpevx, clacpy, claset, clatmr, clatms, slabad,
397 $ slafts, xerbla
398* ..
399* .. Intrinsic Functions ..
400 INTRINSIC abs, int, log, max, min, real, 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( 'CDRVST', -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 = slamch( 'Safe minimum' )
453 ovfl = slamch( 'Overflow' )
454 CALL slabad( unfl, ovfl )
455 ulp = slamch( 'Epsilon' )*slamch( '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( real( 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 / real( 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 claset( '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 clatms( 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 clatms( 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 clatmr( 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 clatmr( 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 )*slarnd( 1, iseed3 ) )
599 CALL clatms( 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 claset( '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 )*slarnd( 1, iseed2 ) )
634 iu = 1 + int( ( n-1 )*slarnd( 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 CHEEVD and CHEEVX.
653*
654 CALL clacpy( ' ', n, n, a, lda, v, ldu )
655*
656 ntest = ntest + 1
657 CALL cheevd( '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 )'CHEEVD(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 chet21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
676 $ ldu, tau, work, rwork, result( ntest ) )
677*
678 CALL clacpy( ' ', n, n, v, ldu, a, lda )
679*
680 ntest = ntest + 2
681 CALL cheevd( '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 )'CHEEVD(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 clacpy( ' ', 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 cheevx( '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 )'CHEEVX(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 clacpy( ' ', n, n, v, ldu, a, lda )
753*
754 CALL chet21( 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 cheevx( '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 )'CHEEVX(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 clacpy( ' ', n, n, v, ldu, a, lda )
786*
787 ntest = ntest + 1
788*
789 CALL cheevx( '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 )'CHEEVX(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 clacpy( ' ', n, n, v, ldu, a, lda )
807*
808 CALL chet22( 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 cheevx( '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 )'CHEEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
831 temp2 = ssxt1( 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 clacpy( ' ', n, n, v, ldu, a, lda )
842*
843 ntest = ntest + 1
844*
845 CALL cheevx( '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 )'CHEEVX(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 clacpy( ' ', n, n, v, ldu, a, lda )
863*
864 CALL chet22( 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 cheevx( '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 )'CHEEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
892 temp2 = ssxt1( 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 CHPEVD and CHPEVX.
904*
905 CALL clacpy( ' ', 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 chpevd( '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 )'CHPEVD(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 chet21( 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 chpevd( '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 )'CHPEVD(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 chpevx( '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 )'CHPEVX(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 chet21( 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 chpevx( '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 )'CHPEVX(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 chpevx( '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 )'CHPEVX(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 chet22( 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 chpevx( '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 )'CHPEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1192 temp2 = ssxt1( 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 chpevx( '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 )'CHPEVX(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 chet22( 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 chpevx( '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 )'CHPEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1286 temp2 = ssxt1( 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 CHBEVD 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 chbevd( '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 )'CHBEVD(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 chet21( 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 chbevd( '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 )'CHBEVD(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 chbevx( '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 )'CHBEVX(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 chet21( 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 chbevx( '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 )'CHBEVX(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 chbevx( '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 )'CHBEVX(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 chet22( 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 chbevx( '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 )'CHBEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1543 temp2 = ssxt1( 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 chbevx( '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 )'CHBEVX(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 chet22( 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 chbevx( '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 )'CHBEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1630 temp2 = ssxt1( 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 CHEEV
1642*
1643 CALL clacpy( ' ', n, n, a, lda, v, ldu )
1644*
1645 ntest = ntest + 1
1646 CALL cheev( 'V', uplo, n, a, ldu, d1, work, lwork, rwork,
1647 $ iinfo )
1648 IF( iinfo.NE.0 ) THEN
1649 WRITE( nounit, fmt = 9999 )'CHEEV(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 chet21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
1665 $ ldu, tau, work, rwork, result( ntest ) )
1666*
1667 CALL clacpy( ' ', n, n, v, ldu, a, lda )
1668*
1669 ntest = ntest + 2
1670 CALL cheev( 'N', uplo, n, a, ldu, d3, work, lwork, rwork,
1671 $ iinfo )
1672 IF( iinfo.NE.0 ) THEN
1673 WRITE( nounit, fmt = 9999 )'CHEEV(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 clacpy( ' ', n, n, v, ldu, a, lda )
1698*
1699* Call CHPEV
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 chpev( 'V', uplo, n, work, d1, z, ldu,
1725 $ work( indwrk ), rwork, iinfo )
1726 IF( iinfo.NE.0 ) THEN
1727 WRITE( nounit, fmt = 9999 )'CHPEV(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 chet21( 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 chpev( 'N', uplo, n, work, d3, z, ldu,
1766 $ work( indwrk ), rwork, iinfo )
1767 IF( iinfo.NE.0 ) THEN
1768 WRITE( nounit, fmt = 9999 )'CHPEV(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 CHBEV
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 chbev( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
1821 $ rwork, iinfo )
1822 IF( iinfo.NE.0 ) THEN
1823 WRITE( nounit, fmt = 9998 )'CHBEV(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 chet21( 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 chbev( 'N', uplo, n, kd, v, ldu, d3, z, ldu, work,
1857 $ rwork, iinfo )
1858 IF( iinfo.NE.0 ) THEN
1859 WRITE( nounit, fmt = 9998 )'CHBEV(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 clacpy( ' ', n, n, a, lda, v, ldu )
1884 ntest = ntest + 1
1885 CALL cheevr( '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 )'CHEEVR(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 clacpy( ' ', n, n, v, ldu, a, lda )
1906*
1907 CALL chet21( 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 cheevr( '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 )'CHEEVR(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 clacpy( ' ', n, n, v, ldu, a, lda )
1942 CALL cheevr( '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 )'CHEEVR(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 clacpy( ' ', n, n, v, ldu, a, lda )
1963*
1964 CALL chet22( 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 clacpy( ' ', n, n, v, ldu, a, lda )
1969 CALL cheevr( '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 )'CHEEVR(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1988 temp2 = ssxt1( 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 clacpy( ' ', n, n, v, ldu, a, lda )
1995 CALL cheevr( '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 )'CHEEVR(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 clacpy( ' ', n, n, v, ldu, a, lda )
2016*
2017 CALL chet22( 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 clacpy( ' ', n, n, v, ldu, a, lda )
2022 CALL cheevr( '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 )'CHEEVR(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2046 temp2 = ssxt1( 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 clacpy( ' ', 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 slafts( 'CST', n, n, jtype, ntest, result, ioldsd,
2071 $ thresh, nounit, nerrs )
2072*
2073 1210 CONTINUE
2074 1220 CONTINUE
2075*
2076* Summary
2077*
2078 CALL alasvm( 'CST', nounit, nerrs, ntestt, 0 )
2079*
2080 9999 FORMAT( ' CDRVST: ', a, ' returned INFO=', i6, / 9x, 'N=', i6,
2081 $ ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2082 9998 FORMAT( ' CDRVST: ', a, ' returned INFO=', i6, / 9x, 'N=', i6,
2083 $ ', KD=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5,
2084 $ ')' )
2085*
2086 RETURN
2087*
2088* End of CDRVST
2089*
cheevx
subroutine cheevx(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, rwork, iwork, ifail, info)
CHEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
Definition cheevx.f:259
cheevr
subroutine cheevr(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, rwork, lrwork, iwork, liwork, info)
CHEEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
Definition cheevr.f:357
cheevd
subroutine cheevd(jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork, iwork, liwork, info)
CHEEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
Definition cheevd.f:205
cheev
subroutine cheev(jobz, uplo, n, a, lda, w, work, lwork, rwork, info)
CHEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
Definition cheev.f:140
chbev
subroutine chbev(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, rwork, info)
CHBEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition chbev.f:152
chbevx
subroutine chbevx(jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, ldz, work, rwork, iwork, ifail, info)
CHBEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition chbevx.f:267
chpevx
subroutine chpevx(jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m, w, z, ldz, work, rwork, iwork, ifail, info)
CHPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition chpevx.f:240
chbevd
subroutine chbevd(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
CHBEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition chbevd.f:215
chpev
subroutine chpev(jobz, uplo, n, ap, w, z, ldz, work, rwork, info)
CHPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition chpev.f:138
chpevd
subroutine chpevd(jobz, uplo, n, ap, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
CHPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition chpevd.f:200
chet22
subroutine chet22(itype, uplo, n, m, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
CHET22
Definition chet22.f:161

◆ cdrvst2stg()

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

CDRVST2STG

Purpose:
!>
!>      CDRVST2STG  checks the Hermitian eigenvalue problem drivers.
!>
!>              CHEEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix,
!>              using a divide-and-conquer algorithm.
!>
!>              CHEEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix.
!>
!>              CHEEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              CHPEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage, using a divide-and-conquer algorithm.
!>
!>              CHPEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage.
!>
!>              CHBEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix,
!>              using a divide-and-conquer algorithm.
!>
!>              CHBEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix.
!>
!>              CHEEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix.
!>
!>              CHPEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian matrix in packed
!>              storage.
!>
!>              CHBEV computes all eigenvalues and, optionally,
!>              eigenvectors of a complex Hermitian band matrix.
!>
!>      When CDRVST2STG 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,
!>          CDRVST2STG 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, CDRVST2STG
!>          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 CDRVST2STG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  REAL
!>          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 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      REAL             array, dimension (max(NN))
!>          The eigenvalues of A, as computed by CSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>          Modified.
!>
!>  D2      REAL             array, dimension (max(NN))
!>          The eigenvalues of A, as computed by CSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>          Modified.
!>
!>  D3      REAL             array, dimension (max(NN))
!>          The eigenvalues of A, as computed by SSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>          Modified.
!>
!>  WA1     REAL array, dimension
!>
!>  WA2     REAL array, dimension
!>
!>  WA3     REAL array, dimension
!>
!>  U       COMPLEX array, dimension (LDU, max(NN))
!>          The unitary matrix computed by CHETRD + CUNGC3.
!>          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 array, dimension (LDU, max(NN))
!>          The Housholder vectors computed by CHETRD in reducing A to
!>          tridiagonal form.
!>          Modified.
!>
!>  TAU     COMPLEX array, dimension (max(NN))
!>          The Householder factors computed by CHETRD in reducing A
!>          to tridiagonal form.
!>          Modified.
!>
!>  Z       COMPLEX array, dimension (LDU, max(NN))
!>          The unitary matrix of eigenvectors computed by CHEEVD,
!>          CHEEVX, CHPEVD, CHPEVX, CHBEVD, and CHBEVX.
!>          Modified.
!>
!>  WORK  - COMPLEX 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   REAL 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  REAL 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  SLATMR, SLATMS, CHETRD, SORGC3, CSTEQR, SSTERF,
!>              or SORMC2 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 SLAFTS).
!>       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 cdrvst2stg.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 REAL THRESH
347* ..
348* .. Array Arguments ..
349 LOGICAL DOTYPE( * )
350 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
351 REAL D1( * ), D2( * ), D3( * ), RESULT( * ),
352 $ RWORK( * ), WA1( * ), WA2( * ), WA3( * )
353 COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ),
354 $ V( LDU, * ), WORK( * ), Z( LDU, * )
355* ..
356*
357* =====================================================================
358*
359*
360* .. Parameters ..
361 REAL ZERO, ONE, TWO, TEN
362 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
363 $ ten = 10.0e+0 )
364 REAL HALF
365 parameter( half = one / two )
366 COMPLEX CZERO, CONE
367 parameter( czero = ( 0.0e+0, 0.0e+0 ),
368 $ cone = ( 1.0e+0, 0.0e+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 REAL 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 REAL SLAMCH, SLARND, SSXT1
391 EXTERNAL slamch, slarnd, ssxt1
392* ..
393* .. External Subroutines ..
394 EXTERNAL alasvm, slabad, slafts, xerbla, chbev, chbevd,
395 $ chbevx, cheev, cheevd, cheevr, cheevx, chet21,
396 $ chet22, chpev, chpevd, chpevx, clacpy, claset,
397 $ cheevd_2stage, cheevr_2stage, cheevx_2stage,
398 $ cheev_2stage, chbev_2stage, chbevd_2stage,
399 $ chbevx_2stage, clatmr, clatms
400* ..
401* .. Intrinsic Functions ..
402 INTRINSIC abs, real, 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( 'CDRVST2STG', -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 = slamch( 'Safe minimum' )
455 ovfl = slamch( 'Overflow' )
456 CALL slabad( unfl, ovfl )
457 ulp = slamch( 'Epsilon' )*slamch( '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( real( 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 / real( 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 claset( '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 clatms( 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 clatms( 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 clatmr( 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 clatmr( 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 )*slarnd( 1, iseed3 ) )
601 CALL clatms( 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 claset( '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 )*slarnd( 1, iseed2 ) )
636 iu = 1 + int( ( n-1 )*slarnd( 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 CHEEVD and CHEEVX.
655*
656 CALL clacpy( ' ', n, n, a, lda, v, ldu )
657*
658 ntest = ntest + 1
659 CALL cheevd( '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 )'CHEEVD(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 chet21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
678 $ ldu, tau, work, rwork, result( ntest ) )
679*
680 CALL clacpy( ' ', n, n, v, ldu, a, lda )
681*
682 ntest = ntest + 2
683 CALL cheevd_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 $ 'CHEEVD_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 clacpy( ' ', 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 cheevx( '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 )'CHEEVX(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 clacpy( ' ', n, n, v, ldu, a, lda )
756*
757 CALL chet21( 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 cheevx_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 $ 'CHEEVX_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 clacpy( ' ', n, n, v, ldu, a, lda )
791*
792 ntest = ntest + 1
793*
794 CALL cheevx( '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 )'CHEEVX(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 clacpy( ' ', n, n, v, ldu, a, lda )
812*
813 CALL chet22( 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 cheevx_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 $ 'CHEEVX_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
838 temp2 = ssxt1( 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 clacpy( ' ', n, n, v, ldu, a, lda )
849*
850 ntest = ntest + 1
851*
852 CALL cheevx( '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 )'CHEEVX(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 clacpy( ' ', n, n, v, ldu, a, lda )
870*
871 CALL chet22( 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 cheevx_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 $ 'CHEEVX_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
901 temp2 = ssxt1( 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 CHPEVD and CHPEVX.
913*
914 CALL clacpy( ' ', 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 chpevd( '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 )'CHPEVD(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 chet21( 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 chpevd( '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 )'CHPEVD(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 chpevx( '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 )'CHPEVX(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 chet21( 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 chpevx( '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 )'CHPEVX(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 chpevx( '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 )'CHPEVX(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 chet22( 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 chpevx( '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 )'CHPEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1201 temp2 = ssxt1( 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 chpevx( '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 )'CHPEVX(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 chet22( 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 chpevx( '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 )'CHPEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1295 temp2 = ssxt1( 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 CHBEVD 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 chbevd( '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 )'CHBEVD(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 chet21( 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 chbevd_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 $ 'CHBEVD_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 chbevx( '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 )'CHBEVX(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 chet21( 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 chbevx_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 $ 'CHBEVX_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 chbevx( '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 )'CHBEVX(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 chet22( 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 chbevx_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 $ 'CHBEVX_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1558 temp2 = ssxt1( 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 chbevx( '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 )'CHBEVX(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 chet22( 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 chbevx_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 $ 'CHBEVX_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1647 temp2 = ssxt1( 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 CHEEV
1659*
1660 CALL clacpy( ' ', n, n, a, lda, v, ldu )
1661*
1662 ntest = ntest + 1
1663 CALL cheev( 'V', uplo, n, a, ldu, d1, work, lwork, rwork,
1664 $ iinfo )
1665 IF( iinfo.NE.0 ) THEN
1666 WRITE( nounit, fmt = 9999 )'CHEEV(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 chet21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
1682 $ ldu, tau, work, rwork, result( ntest ) )
1683*
1684 CALL clacpy( ' ', n, n, v, ldu, a, lda )
1685*
1686 ntest = ntest + 2
1687 CALL cheev_2stage( 'N', uplo, n, a, ldu, d3,
1688 $ work, lwork, rwork, iinfo )
1689 IF( iinfo.NE.0 ) THEN
1690 WRITE( nounit, fmt = 9999 )
1691 $ 'CHEEV_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 clacpy( ' ', n, n, v, ldu, a, lda )
1716*
1717* Call CHPEV
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 chpev( 'V', uplo, n, work, d1, z, ldu,
1743 $ work( indwrk ), rwork, iinfo )
1744 IF( iinfo.NE.0 ) THEN
1745 WRITE( nounit, fmt = 9999 )'CHPEV(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 chet21( 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 chpev( 'N', uplo, n, work, d3, z, ldu,
1784 $ work( indwrk ), rwork, iinfo )
1785 IF( iinfo.NE.0 ) THEN
1786 WRITE( nounit, fmt = 9999 )'CHPEV(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 CHBEV
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 chbev( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
1839 $ rwork, iinfo )
1840 IF( iinfo.NE.0 ) THEN
1841 WRITE( nounit, fmt = 9998 )'CHBEV(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 chet21( 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 chbev_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 $ 'CHBEV_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 clacpy( ' ', n, n, a, lda, v, ldu )
1903 ntest = ntest + 1
1904 CALL cheevr( '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 )'CHEEVR(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 clacpy( ' ', n, n, v, ldu, a, lda )
1925*
1926 CALL chet21( 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 cheevr_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 $ 'CHEEVR_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 clacpy( ' ', n, n, v, ldu, a, lda )
1962 CALL cheevr( '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 )'CHEEVR(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 clacpy( ' ', n, n, v, ldu, a, lda )
1983*
1984 CALL chet22( 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 clacpy( ' ', n, n, v, ldu, a, lda )
1989 CALL cheevr_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 $ 'CHEEVR_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2009 temp2 = ssxt1( 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 clacpy( ' ', n, n, v, ldu, a, lda )
2016 CALL cheevr( '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 )'CHEEVR(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 clacpy( ' ', n, n, v, ldu, a, lda )
2037*
2038 CALL chet22( 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 clacpy( ' ', n, n, v, ldu, a, lda )
2043 CALL cheevr_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 $ 'CHEEVR_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2068 temp2 = ssxt1( 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 clacpy( ' ', 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 slafts( 'CST', n, n, jtype, ntest, result, ioldsd,
2093 $ thresh, nounit, nerrs )
2094*
2095 1210 CONTINUE
2096 1220 CONTINUE
2097*
2098* Summary
2099*
2100 CALL alasvm( 'CST', nounit, nerrs, ntestt, 0 )
2101*
2102 9999 FORMAT( ' CDRVST2STG: ', a, ' returned INFO=', i6, / 9x, 'N=', i6,
2103 $ ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2104 9998 FORMAT( ' CDRVST2STG: ', a, ' returned INFO=', i6, / 9x, 'N=', i6,
2105 $ ', KD=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5,
2106 $ ')' )
2107*
2108 RETURN
2109*
2110* End of CDRVST2STG
2111*
cheev_2stage
subroutine cheev_2stage(jobz, uplo, n, a, lda, w, work, lwork, rwork, info)
CHEEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matr...
Definition cheev_2stage.f:189
cheevd_2stage
subroutine cheevd_2stage(jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork, iwork, liwork, info)
CHEEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE mat...
Definition cheevd_2stage.f:253
cheevr_2stage
subroutine cheevr_2stage(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, rwork, lrwork, iwork, liwork, info)
CHEEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE mat...
Definition cheevr_2stage.f:406
cheevx_2stage
subroutine cheevx_2stage(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, rwork, iwork, ifail, info)
CHEEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE mat...
Definition cheevx_2stage.f:306
chbevd_2stage
subroutine chbevd_2stage(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
CHBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER ...
Definition chbevd_2stage.f:260
chbevx_2stage
subroutine chbevx_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)
CHBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER ...
Definition chbevx_2stage.f:327
chbev_2stage
subroutine chbev_2stage(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, rwork, info)
CHBEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER m...
Definition chbev_2stage.f:211

◆ cdrvsx()

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

CDRVSX

Purpose:
!>
!>    CDRVSX checks the nonsymmetric eigenvalue (Schur form) problem
!>    expert driver CGEESX.
!>
!>    CDRVSX 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 CDRVSX 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 CGEESX 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 CGEESX 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 CDRVSX to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by CGEESX.
!>
[out]HT
!>          HT is COMPLEX array, dimension (LDA, max(NN))
!>          Yet another copy of the test matrix A, modified by CGEESX.
!>
[out]W
!>          W is COMPLEX array, dimension (max(NN))
!>          The computed eigenvalues of A.
!>
[out]WT
!>          WT is COMPLEX array, dimension (max(NN))
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when CGEESX only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]WTMP
!>          WTMP is COMPLEX array, dimension (max(NN))
!>          More temporary storage for eigenvalues.
!>
[out]VS
!>          VS is COMPLEX 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 array, dimension (LDVS, max(NN))
!>          VS1 holds another copy of the computed Schur vectors.
!>
[out]RESULT
!>          RESULT is REAL 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 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 REAL 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,  CLATMR, CLATMS, CLATME or CGET24 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 cdrvsx.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 REAL THRESH
444* ..
445* .. Array Arguments ..
446 LOGICAL BWORK( * ), DOTYPE( * )
447 INTEGER ISEED( 4 ), NN( * )
448 REAL RESULT( 17 ), RWORK( * )
449 COMPLEX A( LDA, * ), H( LDA, * ), HT( LDA, * ),
450 $ VS( LDVS, * ), VS1( LDVS, * ), W( * ),
451 $ WORK( * ), WT( * ), WTMP( * )
452* ..
453*
454* =====================================================================
455*
456* .. Parameters ..
457 COMPLEX CZERO
458 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
459 COMPLEX CONE
460 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
461 REAL ZERO, ONE
462 parameter( zero = 0.0e+0, one = 1.0e+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,
471 $ NMAX, NNWORK, NSLCT, NTEST, NTESTF, NTESTT
472 REAL 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 REAL 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 REAL SLAMCH
492 EXTERNAL slamch
493* ..
494* .. External Subroutines ..
495 EXTERNAL cget24, clatme, clatmr, clatms, claset, slabad,
496 $ slasum, xerbla
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 ) = 'Complex 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( 'CDRVSX', -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 = slamch( 'Safe minimum' )
569 ovfl = one / unfl
570 CALL slabad( unfl, ovfl )
571 ulp = slamch( '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 claset( '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 clatms( 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 clatms( 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 clatme( 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 clatmr( 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 clatmr( 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 clatmr( 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 claset( 'Full', 2, n, czero, czero, a, lda )
728 CALL claset( 'Full', n-3, 1, czero, czero, a( 3, 1 ),
729 $ lda )
730 CALL claset( 'Full', n-3, 2, czero, czero,
731 $ a( 3, n-1 ), lda )
732 CALL claset( '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 clatmr( 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 cget24( .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 cget24( .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 slasum( path, nounit, nerrs, ntestt )
870*
871 9999 FORMAT( / 1x, a3, ' -- Complex Schur Form Decomposition Expert ',
872 $ 'Driver', / ' Matrix types (see CDRVSX 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( ' CDRVSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
926 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
927*
928 RETURN
929*
930* End of CDRVSX
931*
cget24
subroutine cget24(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)
CGET24
Definition cget24.f:335

◆ cdrvvx()

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

CDRVVX

Purpose:
!>
!>    CDRVVX  checks the nonsymmetric eigenvalue problem expert driver
!>    CGEEVX.
!>
!>    CDRVVX 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 CDRVVX 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 CGEEVX 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 CGEEVX 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 CDRVVX to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          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 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 array, dimension (LDA, max(NN,12))
!>          Another copy of the test matrix A, modified by CGEEVX.
!>
[out]W
!>          W is COMPLEX array, dimension (max(NN,12))
!>          Contains the eigenvalues of A.
!>
[out]W1
!>          W1 is COMPLEX array, dimension (max(NN,12))
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when CGEEVX only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is COMPLEX 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 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 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 REAL array, dimension (N)
!>          RCONDV holds the computed reciprocal condition numbers
!>          for eigenvectors.
!>
[out]RCNDV1
!>          RCNDV1 is REAL array, dimension (N)
!>          RCNDV1 holds more computed reciprocal condition numbers
!>          for eigenvectors.
!>
[in]RCDVIN
!>          RCDVIN is REAL array, dimension (N)
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition numbers for eigenvectors to be compared with
!>          RCONDV.
!>
[out]RCONDE
!>          RCONDE is REAL array, dimension (N)
!>          RCONDE holds the computed reciprocal condition numbers
!>          for eigenvalues.
!>
[out]RCNDE1
!>          RCNDE1 is REAL array, dimension (N)
!>          RCNDE1 holds more computed reciprocal condition numbers
!>          for eigenvalues.
!>
[in]RCDEIN
!>          RCDEIN is REAL array, dimension (N)
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition numbers for eigenvalues to be compared with
!>          RCONDE.
!>
[out]SCALE
!>          SCALE is REAL array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]SCALE1
!>          SCALE1 is REAL array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]RESULT
!>          RESULT is REAL array, dimension (11)
!>          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 array, dimension (NWORK)
!>
[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 REAL 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, CLATMR, CLATMS, CLATME or CGET23 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 cdrvvx.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 REAL THRESH
505* ..
506* .. Array Arguments ..
507 LOGICAL DOTYPE( * )
508 INTEGER ISEED( 4 ), NN( * )
509 REAL RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
510 $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
511 $ RESULT( 11 ), RWORK( * ), SCALE( * ),
512 $ SCALE1( * )
513 COMPLEX A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
514 $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ),
515 $ WORK( * )
516* ..
517*
518* =====================================================================
519*
520* .. Parameters ..
521 COMPLEX CZERO
522 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
523 COMPLEX CONE
524 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
525 REAL ZERO, ONE
526 parameter( zero = 0.0e+0, one = 1.0e+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,
536 $ NFAIL, NMAX, NNWORK, NTEST, NTESTF, NTESTT
537 REAL 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 REAL SLAMCH
548 EXTERNAL slamch
549* ..
550* .. External Subroutines ..
551 EXTERNAL cget23, clatme, clatmr, clatms, claset, slabad,
552 $ slasum, xerbla
553* ..
554* .. Intrinsic Functions ..
555 INTRINSIC abs, cmplx, 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 ) = 'Complex 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( 'CDRVVX', -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 = slamch( 'Safe minimum' )
626 ovfl = one / unfl
627 CALL slabad( unfl, ovfl )
628 ulp = slamch( '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 claset( '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 clatms( 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 clatms( 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 clatme( 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 clatmr( 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 clatmr( 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 clatmr( 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 claset( 'Full', 2, n, czero, czero, a, lda )
784 CALL claset( 'Full', n-3, 1, czero, czero, a( 3, 1 ),
785 $ lda )
786 CALL claset( 'Full', n-3, 2, czero, czero,
787 $ a( 3, n-1 ), lda )
788 CALL claset( '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 clatmr( 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 cget23( .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 ) = cmplx( wr, wi )
900 190 CONTINUE
901 CALL cget23( .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 slasum( path, nounit, nerrs, ntestt )
943*
944 9999 FORMAT( / 1x, a3, ' -- Complex Eigenvalue-Eigenvector ',
945 $ 'Decomposition Expert Driver',
946 $ / ' Matrix types (see CDRVVX 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( ' CDRVVX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
989 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
990*
991 RETURN
992*
993* End of CDRVVX
994*
cget23
subroutine cget23(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)
CGET23
Definition cget23.f:368

◆ cerrbd()

subroutine cerrbd ( character*3 path,
integer nunit )

CERRBD

Purpose:
!>
!> CERRBD tests the error exits for CGEBRD, CUNGBR, CUNMBR, and CBDSQR.
!>
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 cerrbd.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 REAL D( NMAX ), E( NMAX ), RW( 4*NMAX )
76 COMPLEX 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 cbdsqr, cgebrd, chkxer, cungbr, cunmbr
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 real
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. / real( 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* CGEBRD
119*
120 srnamt = 'CGEBRD'
121 infot = 1
122 CALL cgebrd( -1, 0, a, 1, d, e, tq, tp, w, 1, info )
123 CALL chkxer( 'CGEBRD', infot, nout, lerr, ok )
124 infot = 2
125 CALL cgebrd( 0, -1, a, 1, d, e, tq, tp, w, 1, info )
126 CALL chkxer( 'CGEBRD', infot, nout, lerr, ok )
127 infot = 4
128 CALL cgebrd( 2, 1, a, 1, d, e, tq, tp, w, 2, info )
129 CALL chkxer( 'CGEBRD', infot, nout, lerr, ok )
130 infot = 10
131 CALL cgebrd( 2, 1, a, 2, d, e, tq, tp, w, 1, info )
132 CALL chkxer( 'CGEBRD', infot, nout, lerr, ok )
133 nt = nt + 4
134*
135* CUNGBR
136*
137 srnamt = 'CUNGBR'
138 infot = 1
139 CALL cungbr( '/', 0, 0, 0, a, 1, tq, w, 1, info )
140 CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
141 infot = 2
142 CALL cungbr( 'Q', -1, 0, 0, a, 1, tq, w, 1, info )
143 CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
144 infot = 3
145 CALL cungbr( 'Q', 0, -1, 0, a, 1, tq, w, 1, info )
146 CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
147 infot = 3
148 CALL cungbr( 'Q', 0, 1, 0, a, 1, tq, w, 1, info )
149 CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
150 infot = 3
151 CALL cungbr( 'Q', 1, 0, 1, a, 1, tq, w, 1, info )
152 CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
153 infot = 3
154 CALL cungbr( 'P', 1, 0, 0, a, 1, tq, w, 1, info )
155 CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
156 infot = 3
157 CALL cungbr( 'P', 0, 1, 1, a, 1, tq, w, 1, info )
158 CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
159 infot = 4
160 CALL cungbr( 'Q', 0, 0, -1, a, 1, tq, w, 1, info )
161 CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
162 infot = 6
163 CALL cungbr( 'Q', 2, 1, 1, a, 1, tq, w, 1, info )
164 CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
165 infot = 9
166 CALL cungbr( 'Q', 2, 2, 1, a, 2, tq, w, 1, info )
167 CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
168 nt = nt + 10
169*
170* CUNMBR
171*
172 srnamt = 'CUNMBR'
173 infot = 1
174 CALL cunmbr( '/', 'L', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
175 $ info )
176 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
177 infot = 2
178 CALL cunmbr( 'Q', '/', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
179 $ info )
180 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
181 infot = 3
182 CALL cunmbr( 'Q', 'L', '/', 0, 0, 0, a, 1, tq, u, 1, w, 1,
183 $ info )
184 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
185 infot = 4
186 CALL cunmbr( 'Q', 'L', 'C', -1, 0, 0, a, 1, tq, u, 1, w, 1,
187 $ info )
188 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
189 infot = 5
190 CALL cunmbr( 'Q', 'L', 'C', 0, -1, 0, a, 1, tq, u, 1, w, 1,
191 $ info )
192 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
193 infot = 6
194 CALL cunmbr( 'Q', 'L', 'C', 0, 0, -1, a, 1, tq, u, 1, w, 1,
195 $ info )
196 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
197 infot = 8
198 CALL cunmbr( 'Q', 'L', 'C', 2, 0, 0, a, 1, tq, u, 2, w, 1,
199 $ info )
200 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
201 infot = 8
202 CALL cunmbr( 'Q', 'R', 'C', 0, 2, 0, a, 1, tq, u, 1, w, 1,
203 $ info )
204 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
205 infot = 8
206 CALL cunmbr( 'P', 'L', 'C', 2, 0, 2, a, 1, tq, u, 2, w, 1,
207 $ info )
208 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
209 infot = 8
210 CALL cunmbr( 'P', 'R', 'C', 0, 2, 2, a, 1, tq, u, 1, w, 1,
211 $ info )
212 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
213 infot = 11
214 CALL cunmbr( 'Q', 'R', 'C', 2, 0, 0, a, 1, tq, u, 1, w, 1,
215 $ info )
216 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
217 infot = 13
218 CALL cunmbr( 'Q', 'L', 'C', 0, 2, 0, a, 1, tq, u, 1, w, 0,
219 $ info )
220 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
221 infot = 13
222 CALL cunmbr( 'Q', 'R', 'C', 2, 0, 0, a, 1, tq, u, 2, w, 0,
223 $ info )
224 CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
225 nt = nt + 13
226*
227* CBDSQR
228*
229 srnamt = 'CBDSQR'
230 infot = 1
231 CALL cbdsqr( '/', 0, 0, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
232 $ info )
233 CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
234 infot = 2
235 CALL cbdsqr( 'U', -1, 0, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
236 $ info )
237 CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
238 infot = 3
239 CALL cbdsqr( 'U', 0, -1, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
240 $ info )
241 CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
242 infot = 4
243 CALL cbdsqr( 'U', 0, 0, -1, 0, d, e, v, 1, u, 1, a, 1, rw,
244 $ info )
245 CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
246 infot = 5
247 CALL cbdsqr( 'U', 0, 0, 0, -1, d, e, v, 1, u, 1, a, 1, rw,
248 $ info )
249 CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
250 infot = 9
251 CALL cbdsqr( 'U', 2, 1, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
252 $ info )
253 CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
254 infot = 11
255 CALL cbdsqr( 'U', 0, 0, 2, 0, d, e, v, 1, u, 1, a, 1, rw,
256 $ info )
257 CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
258 infot = 13
259 CALL cbdsqr( 'U', 2, 0, 0, 1, d, e, v, 1, u, 1, a, 1, rw,
260 $ info )
261 CALL chkxer( 'CBDSQR', 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 CERRBD
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
cunmbr
subroutine cunmbr(vect, side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
CUNMBR
Definition cunmbr.f:197

◆ cerrec()

subroutine cerrec ( character*3 path,
integer nunit )

CERREC

Purpose:
!>
!> CERREC tests the error exits for the routines for eigen- condition
!> estimation for REAL matrices:
!>    CTRSYL, CTREXC, CTRSNA and CTRSEN.
!>
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 cerrec.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 REAL ONE, ZERO
72 parameter( one = 1.0e0, zero = 0.0e0 )
73* ..
74* .. Local Scalars ..
75 INTEGER I, IFST, ILST, INFO, J, M, NT
76 REAL SCALE
77* ..
78* .. Local Arrays ..
79 LOGICAL SEL( NMAX )
80 REAL RW( LW ), S( NMAX ), SEP( NMAX )
81 COMPLEX A( NMAX, NMAX ), B( NMAX, NMAX ),
82 $ C( NMAX, NMAX ), WORK( LW ), X( NMAX )
83* ..
84* .. External Subroutines ..
85 EXTERNAL chkxer, ctrexc, ctrsen, ctrsna, ctrsyl
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 CTRSYL
116*
117 srnamt = 'CTRSYL'
118 infot = 1
119 CALL ctrsyl( 'X', 'N', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
120 CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
121 infot = 2
122 CALL ctrsyl( 'N', 'X', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
123 CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
124 infot = 3
125 CALL ctrsyl( 'N', 'N', 0, 0, 0, a, 1, b, 1, c, 1, scale, info )
126 CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
127 infot = 4
128 CALL ctrsyl( 'N', 'N', 1, -1, 0, a, 1, b, 1, c, 1, scale, info )
129 CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
130 infot = 5
131 CALL ctrsyl( 'N', 'N', 1, 0, -1, a, 1, b, 1, c, 1, scale, info )
132 CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
133 infot = 7
134 CALL ctrsyl( 'N', 'N', 1, 2, 0, a, 1, b, 1, c, 2, scale, info )
135 CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
136 infot = 9
137 CALL ctrsyl( 'N', 'N', 1, 0, 2, a, 1, b, 1, c, 1, scale, info )
138 CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
139 infot = 11
140 CALL ctrsyl( 'N', 'N', 1, 2, 0, a, 2, b, 1, c, 1, scale, info )
141 CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
142 nt = nt + 8
143*
144* Test CTREXC
145*
146 srnamt = 'CTREXC'
147 ifst = 1
148 ilst = 1
149 infot = 1
150 CALL ctrexc( 'X', 1, a, 1, b, 1, ifst, ilst, info )
151 CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
152 infot = 2
153 CALL ctrexc( 'N', -1, a, 1, b, 1, ifst, ilst, info )
154 CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
155 infot = 4
156 ilst = 2
157 CALL ctrexc( 'N', 2, a, 1, b, 1, ifst, ilst, info )
158 CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
159 infot = 6
160 CALL ctrexc( 'V', 2, a, 2, b, 1, ifst, ilst, info )
161 CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
162 infot = 7
163 ifst = 0
164 ilst = 1
165 CALL ctrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
166 CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
167 infot = 7
168 ifst = 2
169 CALL ctrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
170 CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
171 infot = 8
172 ifst = 1
173 ilst = 0
174 CALL ctrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
175 CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
176 infot = 8
177 ilst = 2
178 CALL ctrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
179 CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
180 nt = nt + 8
181*
182* Test CTRSNA
183*
184 srnamt = 'CTRSNA'
185 infot = 1
186 CALL ctrsna( 'X', 'A', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
187 $ work, 1, rw, info )
188 CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
189 infot = 2
190 CALL ctrsna( 'B', 'X', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
191 $ work, 1, rw, info )
192 CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
193 infot = 4
194 CALL ctrsna( 'B', 'A', sel, -1, a, 1, b, 1, c, 1, s, sep, 1, m,
195 $ work, 1, rw, info )
196 CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
197 infot = 6
198 CALL ctrsna( 'V', 'A', sel, 2, a, 1, b, 1, c, 1, s, sep, 2, m,
199 $ work, 2, rw, info )
200 CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
201 infot = 8
202 CALL ctrsna( 'B', 'A', sel, 2, a, 2, b, 1, c, 2, s, sep, 2, m,
203 $ work, 2, rw, info )
204 CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
205 infot = 10
206 CALL ctrsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 1, s, sep, 2, m,
207 $ work, 2, rw, info )
208 CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
209 infot = 13
210 CALL ctrsna( 'B', 'A', sel, 1, a, 1, b, 1, c, 1, s, sep, 0, m,
211 $ work, 1, rw, info )
212 CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
213 infot = 13
214 CALL ctrsna( 'B', 'S', sel, 2, a, 2, b, 2, c, 2, s, sep, 1, m,
215 $ work, 1, rw, info )
216 CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
217 infot = 16
218 CALL ctrsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 2, s, sep, 2, m,
219 $ work, 1, rw, info )
220 CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
221 nt = nt + 9
222*
223* Test CTRSEN
224*
225 sel( 1 ) = .false.
226 srnamt = 'CTRSEN'
227 infot = 1
228 CALL ctrsen( 'X', 'N', sel, 0, a, 1, b, 1, x, m, s( 1 ), sep( 1 ),
229 $ work, 1, info )
230 CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
231 infot = 2
232 CALL ctrsen( 'N', 'X', sel, 0, a, 1, b, 1, x, m, s( 1 ), sep( 1 ),
233 $ work, 1, info )
234 CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
235 infot = 4
236 CALL ctrsen( 'N', 'N', sel, -1, a, 1, b, 1, x, m, s( 1 ),
237 $ sep( 1 ), work, 1, info )
238 CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
239 infot = 6
240 CALL ctrsen( 'N', 'N', sel, 2, a, 1, b, 1, x, m, s( 1 ), sep( 1 ),
241 $ work, 2, info )
242 CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
243 infot = 8
244 CALL ctrsen( 'N', 'V', sel, 2, a, 2, b, 1, x, m, s( 1 ), sep( 1 ),
245 $ work, 1, info )
246 CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
247 infot = 14
248 CALL ctrsen( 'N', 'V', sel, 2, a, 2, b, 2, x, m, s( 1 ), sep( 1 ),
249 $ work, 0, info )
250 CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
251 infot = 14
252 CALL ctrsen( 'E', 'V', sel, 3, a, 3, b, 3, x, m, s( 1 ), sep( 1 ),
253 $ work, 1, info )
254 CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
255 infot = 14
256 CALL ctrsen( 'V', 'V', sel, 3, a, 3, b, 3, x, m, s( 1 ), sep( 1 ),
257 $ work, 3, info )
258 CALL chkxer( 'CTRSEN', 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 CERREC
276*
ctrexc
subroutine ctrexc(compq, n, t, ldt, q, ldq, ifst, ilst, info)
CTREXC
Definition ctrexc.f:126
ctrsna
subroutine ctrsna(job, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, s, sep, mm, m, work, ldwork, rwork, info)
CTRSNA
Definition ctrsna.f:249
ctrsen
subroutine ctrsen(job, compq, select, n, t, ldt, q, ldq, w, m, s, sep, work, lwork, info)
CTRSEN
Definition ctrsen.f:264
ctrsyl
subroutine ctrsyl(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
CTRSYL
Definition ctrsyl.f:157

◆ cerred()

subroutine cerred ( character*3 path,
integer nunit )

CERRED

Purpose:
!>
!> CERRED tests the error exits for the eigenvalue driver routines for
!> REAL matrices:
!>
!> PATH  driver   description
!> ----  ------   -----------
!> CEV   CGEEV    find eigenvalues/eigenvectors for nonsymmetric A
!> CES   CGEES    find eigenvalues/Schur form for nonsymmetric A
!> CVX   CGEEVX   CGEEV + balancing and condition estimation
!> CSX   CGEESX   CGEES + balancing and condition estimation
!> CBD   CGESVD   compute SVD of an M-by-N matrix A
!>       CGESDD   compute SVD of an M-by-N matrix A(by divide and
!>                conquer)
!>       CGEJSV   compute SVD of an M-by-N matrix A where M >= N
!>       CGESVDX  compute SVD of an M-by-N matrix A(by bisection
!>                and inverse iteration)
!>       CGESVDQ  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 cerred.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 REAL ONE, ZERO
86 parameter( one = 1.0e0, zero = 0.0e0 )
87* ..
88* .. Local Scalars ..
89 CHARACTER*2 C2
90 INTEGER I, IHI, ILO, INFO, J, NS, NT, SDIM
91 REAL ABNRM
92* ..
93* .. Local Arrays ..
94 LOGICAL B( NMAX )
95 INTEGER IW( 4*NMAX )
96 REAL R1( NMAX ), R2( NMAX ), RW( LW ), S( NMAX )
97 COMPLEX 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, cgees, cgeesx, cgeev, cgeevx, cgejsv,
103 $ cgesdd, cgesvd, cgesvdx, cgesvdq
104* ..
105* .. External Functions ..
106 LOGICAL LSAMEN, CSLECT
107 EXTERNAL lsamen, cslect
108* ..
109* .. Intrinsic Functions ..
110 INTRINSIC len_trim
111* ..
112* .. Arrays in Common ..
113 LOGICAL SELVAL( 20 )
114 REAL 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 CGEEV
148*
149 srnamt = 'CGEEV '
150 infot = 1
151 CALL cgeev( 'X', 'N', 0, a, 1, x, vl, 1, vr, 1, w, 1, rw,
152 $ info )
153 CALL chkxer( 'CGEEV ', infot, nout, lerr, ok )
154 infot = 2
155 CALL cgeev( 'N', 'X', 0, a, 1, x, vl, 1, vr, 1, w, 1, rw,
156 $ info )
157 CALL chkxer( 'CGEEV ', infot, nout, lerr, ok )
158 infot = 3
159 CALL cgeev( 'N', 'N', -1, a, 1, x, vl, 1, vr, 1, w, 1, rw,
160 $ info )
161 CALL chkxer( 'CGEEV ', infot, nout, lerr, ok )
162 infot = 5
163 CALL cgeev( 'N', 'N', 2, a, 1, x, vl, 1, vr, 1, w, 4, rw,
164 $ info )
165 CALL chkxer( 'CGEEV ', infot, nout, lerr, ok )
166 infot = 8
167 CALL cgeev( 'V', 'N', 2, a, 2, x, vl, 1, vr, 1, w, 4, rw,
168 $ info )
169 CALL chkxer( 'CGEEV ', infot, nout, lerr, ok )
170 infot = 10
171 CALL cgeev( 'N', 'V', 2, a, 2, x, vl, 1, vr, 1, w, 4, rw,
172 $ info )
173 CALL chkxer( 'CGEEV ', infot, nout, lerr, ok )
174 infot = 12
175 CALL cgeev( 'V', 'V', 1, a, 1, x, vl, 1, vr, 1, w, 1, rw,
176 $ info )
177 CALL chkxer( 'CGEEV ', infot, nout, lerr, ok )
178 nt = nt + 7
179*
180 ELSE IF( lsamen( 2, c2, 'ES' ) ) THEN
181*
182* Test CGEES
183*
184 srnamt = 'CGEES '
185 infot = 1
186 CALL cgees( 'X', 'N', cslect, 0, a, 1, sdim, x, vl, 1, w, 1,
187 $ rw, b, info )
188 CALL chkxer( 'CGEES ', infot, nout, lerr, ok )
189 infot = 2
190 CALL cgees( 'N', 'X', cslect, 0, a, 1, sdim, x, vl, 1, w, 1,
191 $ rw, b, info )
192 CALL chkxer( 'CGEES ', infot, nout, lerr, ok )
193 infot = 4
194 CALL cgees( 'N', 'S', cslect, -1, a, 1, sdim, x, vl, 1, w, 1,
195 $ rw, b, info )
196 CALL chkxer( 'CGEES ', infot, nout, lerr, ok )
197 infot = 6
198 CALL cgees( 'N', 'S', cslect, 2, a, 1, sdim, x, vl, 1, w, 4,
199 $ rw, b, info )
200 CALL chkxer( 'CGEES ', infot, nout, lerr, ok )
201 infot = 10
202 CALL cgees( 'V', 'S', cslect, 2, a, 2, sdim, x, vl, 1, w, 4,
203 $ rw, b, info )
204 CALL chkxer( 'CGEES ', infot, nout, lerr, ok )
205 infot = 12
206 CALL cgees( 'N', 'S', cslect, 1, a, 1, sdim, x, vl, 1, w, 1,
207 $ rw, b, info )
208 CALL chkxer( 'CGEES ', infot, nout, lerr, ok )
209 nt = nt + 6
210*
211 ELSE IF( lsamen( 2, c2, 'VX' ) ) THEN
212*
213* Test CGEEVX
214*
215 srnamt = 'CGEEVX'
216 infot = 1
217 CALL cgeevx( '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( 'CGEEVX', infot, nout, lerr, ok )
220 infot = 2
221 CALL cgeevx( '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( 'CGEEVX', infot, nout, lerr, ok )
224 infot = 3
225 CALL cgeevx( '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( 'CGEEVX', infot, nout, lerr, ok )
228 infot = 4
229 CALL cgeevx( '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( 'CGEEVX', infot, nout, lerr, ok )
232 infot = 5
233 CALL cgeevx( '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( 'CGEEVX', infot, nout, lerr, ok )
236 infot = 7
237 CALL cgeevx( '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( 'CGEEVX', infot, nout, lerr, ok )
240 infot = 10
241 CALL cgeevx( '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( 'CGEEVX', infot, nout, lerr, ok )
244 infot = 12
245 CALL cgeevx( '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( 'CGEEVX', infot, nout, lerr, ok )
248 infot = 20
249 CALL cgeevx( '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( 'CGEEVX', infot, nout, lerr, ok )
252 infot = 20
253 CALL cgeevx( '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( 'CGEEVX', infot, nout, lerr, ok )
256 nt = nt + 10
257*
258 ELSE IF( lsamen( 2, c2, 'SX' ) ) THEN
259*
260* Test CGEESX
261*
262 srnamt = 'CGEESX'
263 infot = 1
264 CALL cgeesx( 'X', 'N', cslect, 'N', 0, a, 1, sdim, x, vl, 1,
265 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
266 CALL chkxer( 'CGEESX', infot, nout, lerr, ok )
267 infot = 2
268 CALL cgeesx( 'N', 'X', cslect, 'N', 0, a, 1, sdim, x, vl, 1,
269 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
270 CALL chkxer( 'CGEESX', infot, nout, lerr, ok )
271 infot = 4
272 CALL cgeesx( 'N', 'N', cslect, 'X', 0, a, 1, sdim, x, vl, 1,
273 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
274 CALL chkxer( 'CGEESX', infot, nout, lerr, ok )
275 infot = 5
276 CALL cgeesx( 'N', 'N', cslect, 'N', -1, a, 1, sdim, x, vl, 1,
277 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
278 CALL chkxer( 'CGEESX', infot, nout, lerr, ok )
279 infot = 7
280 CALL cgeesx( 'N', 'N', cslect, 'N', 2, a, 1, sdim, x, vl, 1,
281 $ r1( 1 ), r2( 1 ), w, 4, rw, b, info )
282 CALL chkxer( 'CGEESX', infot, nout, lerr, ok )
283 infot = 11
284 CALL cgeesx( 'V', 'N', cslect, 'N', 2, a, 2, sdim, x, vl, 1,
285 $ r1( 1 ), r2( 1 ), w, 4, rw, b, info )
286 CALL chkxer( 'CGEESX', infot, nout, lerr, ok )
287 infot = 15
288 CALL cgeesx( 'N', 'N', cslect, 'N', 1, a, 1, sdim, x, vl, 1,
289 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
290 CALL chkxer( 'CGEESX', infot, nout, lerr, ok )
291 nt = nt + 7
292*
293 ELSE IF( lsamen( 2, c2, 'BD' ) ) THEN
294*
295* Test CGESVD
296*
297 srnamt = 'CGESVD'
298 infot = 1
299 CALL cgesvd( 'X', 'N', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
300 $ info )
301 CALL chkxer( 'CGESVD', infot, nout, lerr, ok )
302 infot = 2
303 CALL cgesvd( 'N', 'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
304 $ info )
305 CALL chkxer( 'CGESVD', infot, nout, lerr, ok )
306 infot = 2
307 CALL cgesvd( 'O', 'O', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
308 $ info )
309 CALL chkxer( 'CGESVD', infot, nout, lerr, ok )
310 infot = 3
311 CALL cgesvd( 'N', 'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
312 $ info )
313 CALL chkxer( 'CGESVD', infot, nout, lerr, ok )
314 infot = 4
315 CALL cgesvd( 'N', 'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, rw,
316 $ info )
317 CALL chkxer( 'CGESVD', infot, nout, lerr, ok )
318 infot = 6
319 CALL cgesvd( 'N', 'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, rw,
320 $ info )
321 CALL chkxer( 'CGESVD', infot, nout, lerr, ok )
322 infot = 9
323 CALL cgesvd( 'A', 'N', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, rw,
324 $ info )
325 CALL chkxer( 'CGESVD', infot, nout, lerr, ok )
326 infot = 11
327 CALL cgesvd( 'N', 'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, rw,
328 $ info )
329 CALL chkxer( 'CGESVD', 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 CGESDD
339*
340 srnamt = 'CGESDD'
341 infot = 1
342 CALL cgesdd( 'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw, iw,
343 $ info )
344 CALL chkxer( 'CGESDD', infot, nout, lerr, ok )
345 infot = 2
346 CALL cgesdd( 'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, rw, iw,
347 $ info )
348 CALL chkxer( 'CGESDD', infot, nout, lerr, ok )
349 infot = 3
350 CALL cgesdd( 'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, rw, iw,
351 $ info )
352 CALL chkxer( 'CGESDD', infot, nout, lerr, ok )
353 infot = 5
354 CALL cgesdd( 'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, rw, iw,
355 $ info )
356 CALL chkxer( 'CGESDD', infot, nout, lerr, ok )
357 infot = 8
358 CALL cgesdd( 'A', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, rw, iw,
359 $ info )
360 CALL chkxer( 'CGESDD', infot, nout, lerr, ok )
361 infot = 10
362 CALL cgesdd( 'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, rw, iw,
363 $ info )
364 CALL chkxer( 'CGESDD', 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 CGEJSV
374*
375 srnamt = 'CGEJSV'
376 infot = 1
377 CALL cgejsv( '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( 'CGEJSV', infot, nout, lerr, ok )
381 infot = 2
382 CALL cgejsv( '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( 'CGEJSV', infot, nout, lerr, ok )
386 infot = 3
387 CALL cgejsv( '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( 'CGEJSV', infot, nout, lerr, ok )
391 infot = 4
392 CALL cgejsv( '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( 'CGEJSV', infot, nout, lerr, ok )
396 infot = 5
397 CALL cgejsv( '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( 'CGEJSV', infot, nout, lerr, ok )
401 infot = 6
402 CALL cgejsv( '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( 'CGEJSV', infot, nout, lerr, ok )
406 infot = 7
407 CALL cgejsv( '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( 'CGEJSV', infot, nout, lerr, ok )
411 infot = 8
412 CALL cgejsv( '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( 'CGEJSV', infot, nout, lerr, ok )
416 infot = 10
417 CALL cgejsv( '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( 'CGEJSV', infot, nout, lerr, ok )
421 infot = 13
422 CALL cgejsv( '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( 'CGEJSV', infot, nout, lerr, ok )
426 infot = 15
427 CALL cgejsv( '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( 'CGEJSV', 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 CGESVDX
440*
441 srnamt = 'CGESVDX'
442 infot = 1
443 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
446 infot = 2
447 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
450 infot = 3
451 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
454 infot = 4
455 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
458 infot = 5
459 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
462 infot = 7
463 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
466 infot = 8
467 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
470 infot = 9
471 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
474 infot = 10
475 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
478 infot = 11
479 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
482 infot = 15
483 CALL cgesvdx( '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( 'CGESVDX', infot, nout, lerr, ok )
486 infot = 17
487 CALL cgesvdx( '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( 'CGESVDX', 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 CGESVDQ
499*
500 srnamt = 'CGESVDQ'
501 infot = 1
502 CALL cgesvdq( '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( 'CGESVDQ', infot, nout, lerr, ok )
505 infot = 2
506 CALL cgesvdq( '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( 'CGESVDQ', infot, nout, lerr, ok )
509 infot = 3
510 CALL cgesvdq( '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( 'CGESVDQ', infot, nout, lerr, ok )
513 infot = 4
514 CALL cgesvdq( '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( 'CGESVDQ', infot, nout, lerr, ok )
517 infot = 5
518 CALL cgesvdq( '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( 'CGESVDQ', infot, nout, lerr, ok )
521 infot = 6
522 CALL cgesvdq( '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( 'CGESVDQ', infot, nout, lerr, ok )
525 infot = 7
526 CALL cgesvdq( '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( 'CGESVDQ', infot, nout, lerr, ok )
529 infot = 9
530 CALL cgesvdq( '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( 'CGESVDQ', infot, nout, lerr, ok )
533 infot = 12
534 CALL cgesvdq( '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( 'CGESVDQ', infot, nout, lerr, ok )
537 infot = 14
538 CALL cgesvdq( '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( 'CGESVDQ', infot, nout, lerr, ok )
541 infot = 17
542 CALL cgesvdq( '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( 'CGESVDQ', 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 CERRED
571*
cgeesx
subroutine cgeesx(jobvs, sort, select, sense, n, a, lda, sdim, w, vs, ldvs, rconde, rcondv, work, lwork, rwork, bwork, info)
CGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition cgeesx.f:239
cgeevx
subroutine cgeevx(balanc, jobvl, jobvr, sense, n, a, lda, w, vl, ldvl, vr, ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, work, lwork, rwork, info)
CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition cgeevx.f:288

◆ cerrgg()

subroutine cerrgg ( character*3 path,
integer nunit )

CERRGG

Purpose:
!>
!> CERRGG tests the error exits for CGGES, CGGESX, CGGEV, CGGEVX,
!> CGGES3, CGGEV3, CGGGLM, CGGHRD, CGGLSE, CGGQRF, CGGRQF,
!> CGGSVD3, CGGSVP3, CHGEQZ, CTGEVC, CTGEXC, CTGSEN, CTGSJA,
!> CTGSNA, CTGSYL, and CUNCSD.
!>
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 cerrgg.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 REAL ONE, ZERO
73 parameter( one = 1.0e+0, zero = 0.0e+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 REAL ANRM, BNRM, DIF, SCALE, TOLA, TOLB
80* ..
81* .. Local Arrays ..
82 LOGICAL BW( NMAX ), SEL( NMAX )
83 INTEGER IW( LW ), IDUM(NMAX)
84 REAL LS( NMAX ), R1( NMAX ), R2( NMAX ),
85 $ RCE( NMAX ), RCV( NMAX ), RS( NMAX ), RW( LW )
86 COMPLEX 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 CLCTES, CLCTSX, LSAMEN
93 EXTERNAL clctes, clctsx, lsamen
94* ..
95* .. External Subroutines ..
96 EXTERNAL cgges, cggesx, cggev, cggevx, cggglm, cgghrd,
97 $ cgglse, cggqrf, cggrqf, chgeqz,
98 $ chkxer, ctgevc, ctgexc, ctgsen, ctgsja, ctgsna,
99 $ ctgsyl, cuncsd, cgges3, cggev3, cgghd3,
100 $ cggsvd3, cggsvp3, 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.0e0
132 tolb = 1.0e0
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* CGGHRD
151*
152 srnamt = 'CGGHRD'
153 infot = 1
154 CALL cgghrd( '/', 'N', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, info )
155 CALL chkxer( 'CGGHRD', infot, nout, lerr, ok )
156 infot = 2
157 CALL cgghrd( 'N', '/', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, info )
158 CALL chkxer( 'CGGHRD', infot, nout, lerr, ok )
159 infot = 3
160 CALL cgghrd( 'N', 'N', -1, 0, 0, a, 1, b, 1, q, 1, z, 1, info )
161 CALL chkxer( 'CGGHRD', infot, nout, lerr, ok )
162 infot = 4
163 CALL cgghrd( 'N', 'N', 0, 0, 0, a, 1, b, 1, q, 1, z, 1, info )
164 CALL chkxer( 'CGGHRD', infot, nout, lerr, ok )
165 infot = 5
166 CALL cgghrd( 'N', 'N', 0, 1, 1, a, 1, b, 1, q, 1, z, 1, info )
167 CALL chkxer( 'CGGHRD', infot, nout, lerr, ok )
168 infot = 7
169 CALL cgghrd( 'N', 'N', 2, 1, 1, a, 1, b, 2, q, 1, z, 1, info )
170 CALL chkxer( 'CGGHRD', infot, nout, lerr, ok )
171 infot = 9
172 CALL cgghrd( 'N', 'N', 2, 1, 1, a, 2, b, 1, q, 1, z, 1, info )
173 CALL chkxer( 'CGGHRD', infot, nout, lerr, ok )
174 infot = 11
175 CALL cgghrd( 'V', 'N', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, info )
176 CALL chkxer( 'CGGHRD', infot, nout, lerr, ok )
177 infot = 13
178 CALL cgghrd( 'N', 'V', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, info )
179 CALL chkxer( 'CGGHRD', infot, nout, lerr, ok )
180 nt = nt + 9
181*
182* CGGHD3
183*
184 srnamt = 'CGGHD3'
185 infot = 1
186 CALL cgghd3( '/', 'N', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
187 $ info )
188 CALL chkxer( 'CGGHD3', infot, nout, lerr, ok )
189 infot = 2
190 CALL cgghd3( 'N', '/', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
191 $ info )
192 CALL chkxer( 'CGGHD3', infot, nout, lerr, ok )
193 infot = 3
194 CALL cgghd3( 'N', 'N', -1, 0, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
195 $ info )
196 CALL chkxer( 'CGGHD3', infot, nout, lerr, ok )
197 infot = 4
198 CALL cgghd3( 'N', 'N', 0, 0, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
199 $ info )
200 CALL chkxer( 'CGGHD3', infot, nout, lerr, ok )
201 infot = 5
202 CALL cgghd3( 'N', 'N', 0, 1, 1, a, 1, b, 1, q, 1, z, 1, w, lw,
203 $ info )
204 CALL chkxer( 'CGGHD3', infot, nout, lerr, ok )
205 infot = 7
206 CALL cgghd3( 'N', 'N', 2, 1, 1, a, 1, b, 2, q, 1, z, 1, w, lw,
207 $ info )
208 CALL chkxer( 'CGGHD3', infot, nout, lerr, ok )
209 infot = 9
210 CALL cgghd3( 'N', 'N', 2, 1, 1, a, 2, b, 1, q, 1, z, 1, w, lw,
211 $ info )
212 CALL chkxer( 'CGGHD3', infot, nout, lerr, ok )
213 infot = 11
214 CALL cgghd3( 'V', 'N', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, w, lw,
215 $ info )
216 CALL chkxer( 'CGGHD3', infot, nout, lerr, ok )
217 infot = 13
218 CALL cgghd3( 'N', 'V', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, w, lw,
219 $ info )
220 CALL chkxer( 'CGGHD3', infot, nout, lerr, ok )
221 nt = nt + 9
222*
223* CHGEQZ
224*
225 srnamt = 'CHGEQZ'
226 infot = 1
227 CALL chgeqz( '/', 'N', 'N', 0, 1, 0, a, 1, b, 1, alpha, beta,
228 $ q, 1, z, 1, w, 1, rw, info )
229 CALL chkxer( 'CHGEQZ', infot, nout, lerr, ok )
230 infot = 2
231 CALL chgeqz( 'E', '/', 'N', 0, 1, 0, a, 1, b, 1, alpha, beta,
232 $ q, 1, z, 1, w, 1, rw, info )
233 CALL chkxer( 'CHGEQZ', infot, nout, lerr, ok )
234 infot = 3
235 CALL chgeqz( 'E', 'N', '/', 0, 1, 0, a, 1, b, 1, alpha, beta,
236 $ q, 1, z, 1, w, 1, rw, info )
237 CALL chkxer( 'CHGEQZ', infot, nout, lerr, ok )
238 infot = 4
239 CALL chgeqz( 'E', 'N', 'N', -1, 0, 0, a, 1, b, 1, alpha, beta,
240 $ q, 1, z, 1, w, 1, rw, info )
241 CALL chkxer( 'CHGEQZ', infot, nout, lerr, ok )
242 infot = 5
243 CALL chgeqz( 'E', 'N', 'N', 0, 0, 0, a, 1, b, 1, alpha, beta,
244 $ q, 1, z, 1, w, 1, rw, info )
245 CALL chkxer( 'CHGEQZ', infot, nout, lerr, ok )
246 infot = 6
247 CALL chgeqz( 'E', 'N', 'N', 0, 1, 1, a, 1, b, 1, alpha, beta,
248 $ q, 1, z, 1, w, 1, rw, info )
249 CALL chkxer( 'CHGEQZ', infot, nout, lerr, ok )
250 infot = 8
251 CALL chgeqz( 'E', 'N', 'N', 2, 1, 1, a, 1, b, 2, alpha, beta,
252 $ q, 1, z, 1, w, 1, rw, info )
253 CALL chkxer( 'CHGEQZ', infot, nout, lerr, ok )
254 infot = 10
255 CALL chgeqz( 'E', 'N', 'N', 2, 1, 1, a, 2, b, 1, alpha, beta,
256 $ q, 1, z, 1, w, 1, rw, info )
257 CALL chkxer( 'CHGEQZ', infot, nout, lerr, ok )
258 infot = 14
259 CALL chgeqz( 'E', 'V', 'N', 2, 1, 1, a, 2, b, 2, alpha, beta,
260 $ q, 1, z, 1, w, 1, rw, info )
261 CALL chkxer( 'CHGEQZ', infot, nout, lerr, ok )
262 infot = 16
263 CALL chgeqz( 'E', 'N', 'V', 2, 1, 1, a, 2, b, 2, alpha, beta,
264 $ q, 1, z, 1, w, 1, rw, info )
265 CALL chkxer( 'CHGEQZ', infot, nout, lerr, ok )
266 nt = nt + 10
267*
268* CTGEVC
269*
270 srnamt = 'CTGEVC'
271 infot = 1
272 CALL ctgevc( '/', 'A', sel, 0, a, 1, b, 1, q, 1, z, 1, 0, m, w,
273 $ rw, info )
274 CALL chkxer( 'CTGEVC', infot, nout, lerr, ok )
275 infot = 2
276 CALL ctgevc( 'R', '/', sel, 0, a, 1, b, 1, q, 1, z, 1, 0, m, w,
277 $ rw, info )
278 CALL chkxer( 'CTGEVC', infot, nout, lerr, ok )
279 infot = 4
280 CALL ctgevc( 'R', 'A', sel, -1, a, 1, b, 1, q, 1, z, 1, 0, m,
281 $ w, rw, info )
282 CALL chkxer( 'CTGEVC', infot, nout, lerr, ok )
283 infot = 6
284 CALL ctgevc( 'R', 'A', sel, 2, a, 1, b, 2, q, 1, z, 2, 0, m, w,
285 $ rw, info )
286 CALL chkxer( 'CTGEVC', infot, nout, lerr, ok )
287 infot = 8
288 CALL ctgevc( 'R', 'A', sel, 2, a, 2, b, 1, q, 1, z, 2, 0, m, w,
289 $ rw, info )
290 CALL chkxer( 'CTGEVC', infot, nout, lerr, ok )
291 infot = 10
292 CALL ctgevc( 'L', 'A', sel, 2, a, 2, b, 2, q, 1, z, 1, 0, m, w,
293 $ rw, info )
294 CALL chkxer( 'CTGEVC', infot, nout, lerr, ok )
295 infot = 12
296 CALL ctgevc( 'R', 'A', sel, 2, a, 2, b, 2, q, 1, z, 1, 0, m, w,
297 $ rw, info )
298 CALL chkxer( 'CTGEVC', infot, nout, lerr, ok )
299 infot = 13
300 CALL ctgevc( 'R', 'A', sel, 2, a, 2, b, 2, q, 1, z, 2, 1, m, w,
301 $ rw, info )
302 CALL chkxer( 'CTGEVC', 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* CGGSVD3
310*
311 srnamt = 'CGGSVD3'
312 infot = 1
313 CALL cggsvd3( '/', '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( 'CGGSVD3', infot, nout, lerr, ok )
317 infot = 2
318 CALL cggsvd3( '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( 'CGGSVD3', infot, nout, lerr, ok )
322 infot = 3
323 CALL cggsvd3( '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( 'CGGSVD3', infot, nout, lerr, ok )
327 infot = 4
328 CALL cggsvd3( '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( 'CGGSVD3', infot, nout, lerr, ok )
332 infot = 5
333 CALL cggsvd3( '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( 'CGGSVD3', infot, nout, lerr, ok )
337 infot = 6
338 CALL cggsvd3( '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( 'CGGSVD3', infot, nout, lerr, ok )
342 infot = 10
343 CALL cggsvd3( '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( 'CGGSVD3', infot, nout, lerr, ok )
347 infot = 12
348 CALL cggsvd3( '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( 'CGGSVD3', infot, nout, lerr, ok )
352 infot = 16
353 CALL cggsvd3( '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( 'CGGSVD3', infot, nout, lerr, ok )
357 infot = 18
358 CALL cggsvd3( '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( 'CGGSVD3', infot, nout, lerr, ok )
362 infot = 20
363 CALL cggsvd3( '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( 'CGGSVD3', infot, nout, lerr, ok )
367 nt = nt + 11
368*
369* CGGSVP3
370*
371 srnamt = 'CGGSVP3'
372 infot = 1
373 CALL cggsvp3( '/', '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( 'CGGSVP3', infot, nout, lerr, ok )
377 infot = 2
378 CALL cggsvp3( '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( 'CGGSVP3', infot, nout, lerr, ok )
382 infot = 3
383 CALL cggsvp3( '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( 'CGGSVP3', infot, nout, lerr, ok )
387 infot = 4
388 CALL cggsvp3( '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( 'CGGSVP3', infot, nout, lerr, ok )
392 infot = 5
393 CALL cggsvp3( '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( 'CGGSVP3', infot, nout, lerr, ok )
397 infot = 6
398 CALL cggsvp3( '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( 'CGGSVP3', infot, nout, lerr, ok )
402 infot = 8
403 CALL cggsvp3( '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( 'CGGSVP3', infot, nout, lerr, ok )
407 infot = 10
408 CALL cggsvp3( '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( 'CGGSVP3', infot, nout, lerr, ok )
412 infot = 16
413 CALL cggsvp3( '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( 'CGGSVP3', infot, nout, lerr, ok )
417 infot = 18
418 CALL cggsvp3( '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( 'CGGSVP3', infot, nout, lerr, ok )
422 infot = 20
423 CALL cggsvp3( '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( 'CGGSVP3', infot, nout, lerr, ok )
427 nt = nt + 11
428*
429* CTGSJA
430*
431 srnamt = 'CTGSJA'
432 infot = 1
433 CALL ctgsja( '/', '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( 'CTGSJA', infot, nout, lerr, ok )
437 infot = 2
438 CALL ctgsja( '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( 'CTGSJA', infot, nout, lerr, ok )
442 infot = 3
443 CALL ctgsja( '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( 'CTGSJA', infot, nout, lerr, ok )
447 infot = 4
448 CALL ctgsja( '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( 'CTGSJA', infot, nout, lerr, ok )
452 infot = 5
453 CALL ctgsja( '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( 'CTGSJA', infot, nout, lerr, ok )
457 infot = 6
458 CALL ctgsja( '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( 'CTGSJA', infot, nout, lerr, ok )
462 infot = 10
463 CALL ctgsja( '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( 'CTGSJA', infot, nout, lerr, ok )
467 infot = 12
468 CALL ctgsja( '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( 'CTGSJA', infot, nout, lerr, ok )
472 infot = 18
473 CALL ctgsja( '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( 'CTGSJA', infot, nout, lerr, ok )
477 infot = 20
478 CALL ctgsja( '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( 'CTGSJA', infot, nout, lerr, ok )
482 infot = 22
483 CALL ctgsja( '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( 'CTGSJA', 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* CGGGLM
494*
495 srnamt = 'CGGGLM'
496 infot = 1
497 CALL cggglm( -1, 0, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
498 $ info )
499 CALL chkxer( 'CGGGLM', infot, nout, lerr, ok )
500 infot = 2
501 CALL cggglm( 0, -1, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
502 $ info )
503 CALL chkxer( 'CGGGLM', infot, nout, lerr, ok )
504 infot = 2
505 CALL cggglm( 0, 1, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
506 $ info )
507 CALL chkxer( 'CGGGLM', infot, nout, lerr, ok )
508 infot = 3
509 CALL cggglm( 0, 0, -1, a, 1, b, 1, tau, alpha, beta, w, lw,
510 $ info )
511 CALL chkxer( 'CGGGLM', infot, nout, lerr, ok )
512 infot = 3
513 CALL cggglm( 1, 0, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
514 $ info )
515 CALL chkxer( 'CGGGLM', infot, nout, lerr, ok )
516 infot = 5
517 CALL cggglm( 0, 0, 0, a, 0, b, 1, tau, alpha, beta, w, lw,
518 $ info )
519 CALL chkxer( 'CGGGLM', infot, nout, lerr, ok )
520 infot = 7
521 CALL cggglm( 0, 0, 0, a, 1, b, 0, tau, alpha, beta, w, lw,
522 $ info )
523 CALL chkxer( 'CGGGLM', infot, nout, lerr, ok )
524 infot = 12
525 CALL cggglm( 1, 1, 1, a, 1, b, 1, tau, alpha, beta, w, 1,
526 $ info )
527 CALL chkxer( 'CGGGLM', 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* CGGLSE
535*
536 srnamt = 'CGGLSE'
537 infot = 1
538 CALL cgglse( -1, 0, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
539 $ info )
540 CALL chkxer( 'CGGLSE', infot, nout, lerr, ok )
541 infot = 2
542 CALL cgglse( 0, -1, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
543 $ info )
544 CALL chkxer( 'CGGLSE', infot, nout, lerr, ok )
545 infot = 3
546 CALL cgglse( 0, 0, -1, a, 1, b, 1, tau, alpha, beta, w, lw,
547 $ info )
548 CALL chkxer( 'CGGLSE', infot, nout, lerr, ok )
549 infot = 3
550 CALL cgglse( 0, 0, 1, a, 1, b, 1, tau, alpha, beta, w, lw,
551 $ info )
552 CALL chkxer( 'CGGLSE', infot, nout, lerr, ok )
553 infot = 3
554 CALL cgglse( 0, 1, 0, a, 1, b, 1, tau, alpha, beta, w, lw,
555 $ info )
556 CALL chkxer( 'CGGLSE', infot, nout, lerr, ok )
557 infot = 5
558 CALL cgglse( 0, 0, 0, a, 0, b, 1, tau, alpha, beta, w, lw,
559 $ info )
560 CALL chkxer( 'CGGLSE', infot, nout, lerr, ok )
561 infot = 7
562 CALL cgglse( 0, 0, 0, a, 1, b, 0, tau, alpha, beta, w, lw,
563 $ info )
564 CALL chkxer( 'CGGLSE', infot, nout, lerr, ok )
565 infot = 12
566 CALL cgglse( 1, 1, 1, a, 1, b, 1, tau, alpha, beta, w, 1,
567 $ info )
568 CALL chkxer( 'CGGLSE', 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* CUNCSD
576*
577 srnamt = 'CUNCSD'
578 infot = 7
579 CALL cuncsd( '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( 'CUNCSD', infot, nout, lerr, ok )
585 infot = 8
586 CALL cuncsd( '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( 'CUNCSD', infot, nout, lerr, ok )
592 infot = 9
593 CALL cuncsd( '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( 'CUNCSD', infot, nout, lerr, ok )
599 infot = 11
600 CALL cuncsd( '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( 'CUNCSD', infot, nout, lerr, ok )
606 infot = 20
607 CALL cuncsd( '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( 'CUNCSD', infot, nout, lerr, ok )
613 infot = 22
614 CALL cuncsd( '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( 'CUNCSD', infot, nout, lerr, ok )
620 infot = 24
621 CALL cuncsd( '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( 'CUNCSD', infot, nout, lerr, ok )
627 infot = 26
628 CALL cuncsd( '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( 'CUNCSD', 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* CGGQRF
641*
642 srnamt = 'CGGQRF'
643 infot = 1
644 CALL cggqrf( -1, 0, 0, a, 1, alpha, b, 1, beta, w, lw, info )
645 CALL chkxer( 'CGGQRF', infot, nout, lerr, ok )
646 infot = 2
647 CALL cggqrf( 0, -1, 0, a, 1, alpha, b, 1, beta, w, lw, info )
648 CALL chkxer( 'CGGQRF', infot, nout, lerr, ok )
649 infot = 3
650 CALL cggqrf( 0, 0, -1, a, 1, alpha, b, 1, beta, w, lw, info )
651 CALL chkxer( 'CGGQRF', infot, nout, lerr, ok )
652 infot = 5
653 CALL cggqrf( 0, 0, 0, a, 0, alpha, b, 1, beta, w, lw, info )
654 CALL chkxer( 'CGGQRF', infot, nout, lerr, ok )
655 infot = 8
656 CALL cggqrf( 0, 0, 0, a, 1, alpha, b, 0, beta, w, lw, info )
657 CALL chkxer( 'CGGQRF', infot, nout, lerr, ok )
658 infot = 11
659 CALL cggqrf( 1, 1, 2, a, 1, alpha, b, 1, beta, w, 1, info )
660 CALL chkxer( 'CGGQRF', infot, nout, lerr, ok )
661 nt = nt + 6
662*
663* CGGRQF
664*
665 srnamt = 'CGGRQF'
666 infot = 1
667 CALL cggrqf( -1, 0, 0, a, 1, alpha, b, 1, beta, w, lw, info )
668 CALL chkxer( 'CGGRQF', infot, nout, lerr, ok )
669 infot = 2
670 CALL cggrqf( 0, -1, 0, a, 1, alpha, b, 1, beta, w, lw, info )
671 CALL chkxer( 'CGGRQF', infot, nout, lerr, ok )
672 infot = 3
673 CALL cggrqf( 0, 0, -1, a, 1, alpha, b, 1, beta, w, lw, info )
674 CALL chkxer( 'CGGRQF', infot, nout, lerr, ok )
675 infot = 5
676 CALL cggrqf( 0, 0, 0, a, 0, alpha, b, 1, beta, w, lw, info )
677 CALL chkxer( 'CGGRQF', infot, nout, lerr, ok )
678 infot = 8
679 CALL cggrqf( 0, 0, 0, a, 1, alpha, b, 0, beta, w, lw, info )
680 CALL chkxer( 'CGGRQF', infot, nout, lerr, ok )
681 infot = 11
682 CALL cggrqf( 1, 1, 2, a, 1, alpha, b, 1, beta, w, 1, info )
683 CALL chkxer( 'CGGRQF', infot, nout, lerr, ok )
684 nt = nt + 6
685*
686* Test error exits for the CGS, CGV, CGX, and CXV paths.
687*
688 ELSE IF( lsamen( 3, path, 'CGS' ) .OR.
689 $ lsamen( 3, path, 'CGV' ) .OR.
690 $ lsamen( 3, path, 'CGX' ) .OR. lsamen( 3, path, 'CXV' ) )
691 $ THEN
692*
693* CGGES
694*
695 srnamt = 'CGGES '
696 infot = 1
697 CALL cgges( '/', 'N', 'S', clctes, 1, a, 1, b, 1, sdim, alpha,
698 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
699 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
700 infot = 2
701 CALL cgges( 'N', '/', 'S', clctes, 1, a, 1, b, 1, sdim, alpha,
702 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
703 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
704 infot = 3
705 CALL cgges( 'N', 'V', '/', clctes, 1, a, 1, b, 1, sdim, alpha,
706 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
707 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
708 infot = 5
709 CALL cgges( 'N', 'V', 'S', clctes, -1, a, 1, b, 1, sdim, alpha,
710 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
711 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
712 infot = 7
713 CALL cgges( 'N', 'V', 'S', clctes, 1, a, 0, b, 1, sdim, alpha,
714 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
715 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
716 infot = 9
717 CALL cgges( 'N', 'V', 'S', clctes, 1, a, 1, b, 0, sdim, alpha,
718 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
719 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
720 infot = 14
721 CALL cgges( 'N', 'V', 'S', clctes, 1, a, 1, b, 1, sdim, alpha,
722 $ beta, q, 0, u, 1, w, 1, rw, bw, info )
723 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
724 infot = 14
725 CALL cgges( 'V', 'V', 'S', clctes, 2, a, 2, b, 2, sdim, alpha,
726 $ beta, q, 1, u, 2, w, 1, rw, bw, info )
727 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
728 infot = 16
729 CALL cgges( 'N', 'V', 'S', clctes, 1, a, 1, b, 1, sdim, alpha,
730 $ beta, q, 1, u, 0, w, 1, rw, bw, info )
731 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
732 infot = 16
733 CALL cgges( 'V', 'V', 'S', clctes, 2, a, 2, b, 2, sdim, alpha,
734 $ beta, q, 2, u, 1, w, 1, rw, bw, info )
735 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
736 infot = 18
737 CALL cgges( 'V', 'V', 'S', clctes, 2, a, 2, b, 2, sdim, alpha,
738 $ beta, q, 2, u, 2, w, 1, rw, bw, info )
739 CALL chkxer( 'CGGES ', infot, nout, lerr, ok )
740 nt = nt + 11
741*
742* CGGES3
743*
744 srnamt = 'CGGES3'
745 infot = 1
746 CALL cgges3( '/', 'N', 'S', clctes, 1, a, 1, b, 1, sdim, alpha,
747 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
748 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
749 infot = 2
750 CALL cgges3( 'N', '/', 'S', clctes, 1, a, 1, b, 1, sdim, alpha,
751 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
752 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
753 infot = 3
754 CALL cgges3( 'N', 'V', '/', clctes, 1, a, 1, b, 1, sdim, alpha,
755 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
756 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
757 infot = 5
758 CALL cgges3( 'N', 'V', 'S', clctes, -1, a, 1, b, 1, sdim,
759 $ alpha, beta, q, 1, u, 1, w, 1, rw, bw, info )
760 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
761 infot = 7
762 CALL cgges3( 'N', 'V', 'S', clctes, 1, a, 0, b, 1, sdim, alpha,
763 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
764 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
765 infot = 9
766 CALL cgges3( 'N', 'V', 'S', clctes, 1, a, 1, b, 0, sdim, alpha,
767 $ beta, q, 1, u, 1, w, 1, rw, bw, info )
768 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
769 infot = 14
770 CALL cgges3( 'N', 'V', 'S', clctes, 1, a, 1, b, 1, sdim, alpha,
771 $ beta, q, 0, u, 1, w, 1, rw, bw, info )
772 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
773 infot = 14
774 CALL cgges3( 'V', 'V', 'S', clctes, 2, a, 2, b, 2, sdim, alpha,
775 $ beta, q, 1, u, 2, w, 1, rw, bw, info )
776 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
777 infot = 16
778 CALL cgges3( 'N', 'V', 'S', clctes, 1, a, 1, b, 1, sdim, alpha,
779 $ beta, q, 1, u, 0, w, 1, rw, bw, info )
780 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
781 infot = 16
782 CALL cgges3( 'V', 'V', 'S', clctes, 2, a, 2, b, 2, sdim, alpha,
783 $ beta, q, 2, u, 1, w, 1, rw, bw, info )
784 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
785 infot = 18
786 CALL cgges3( 'V', 'V', 'S', clctes, 2, a, 2, b, 2, sdim, alpha,
787 $ beta, q, 2, u, 2, w, 1, rw, bw, info )
788 CALL chkxer( 'CGGES3', infot, nout, lerr, ok )
789 nt = nt + 11
790*
791* CGGESX
792*
793 srnamt = 'CGGESX'
794 infot = 1
795 CALL cggesx( '/', 'N', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
799 infot = 2
800 CALL cggesx( 'N', '/', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
804 infot = 3
805 CALL cggesx( 'V', 'V', '/', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
809 infot = 5
810 CALL cggesx( 'V', 'V', 'S', clctsx, '/', 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( 'CGGESX', infot, nout, lerr, ok )
814 infot = 6
815 CALL cggesx( 'V', 'V', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
819 infot = 8
820 CALL cggesx( 'V', 'V', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
824 infot = 10
825 CALL cggesx( 'V', 'V', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
829 infot = 15
830 CALL cggesx( 'V', 'V', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
834 infot = 15
835 CALL cggesx( 'V', 'V', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
839 infot = 17
840 CALL cggesx( 'V', 'V', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
844 infot = 17
845 CALL cggesx( 'V', 'V', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
849 infot = 21
850 CALL cggesx( 'V', 'V', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
854 infot = 24
855 CALL cggesx( 'V', 'V', 'S', clctsx, '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( 'CGGESX', infot, nout, lerr, ok )
859 nt = nt + 13
860*
861* CGGEV
862*
863 srnamt = 'CGGEV '
864 infot = 1
865 CALL cggev( '/', 'N', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
866 $ w, 1, rw, info )
867 CALL chkxer( 'CGGEV ', infot, nout, lerr, ok )
868 infot = 2
869 CALL cggev( 'N', '/', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
870 $ w, 1, rw, info )
871 CALL chkxer( 'CGGEV ', infot, nout, lerr, ok )
872 infot = 3
873 CALL cggev( 'V', 'V', -1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
874 $ w, 1, rw, info )
875 CALL chkxer( 'CGGEV ', infot, nout, lerr, ok )
876 infot = 5
877 CALL cggev( 'V', 'V', 1, a, 0, b, 1, alpha, beta, q, 1, u, 1,
878 $ w, 1, rw, info )
879 CALL chkxer( 'CGGEV ', infot, nout, lerr, ok )
880 infot = 7
881 CALL cggev( 'V', 'V', 1, a, 1, b, 0, alpha, beta, q, 1, u, 1,
882 $ w, 1, rw, info )
883 CALL chkxer( 'CGGEV ', infot, nout, lerr, ok )
884 infot = 11
885 CALL cggev( 'N', 'V', 1, a, 1, b, 1, alpha, beta, q, 0, u, 1,
886 $ w, 1, rw, info )
887 CALL chkxer( 'CGGEV ', infot, nout, lerr, ok )
888 infot = 11
889 CALL cggev( 'V', 'V', 2, a, 2, b, 2, alpha, beta, q, 1, u, 2,
890 $ w, 1, rw, info )
891 CALL chkxer( 'CGGEV ', infot, nout, lerr, ok )
892 infot = 13
893 CALL cggev( 'V', 'N', 2, a, 2, b, 2, alpha, beta, q, 2, u, 0,
894 $ w, 1, rw, info )
895 CALL chkxer( 'CGGEV ', infot, nout, lerr, ok )
896 infot = 13
897 CALL cggev( 'V', 'V', 2, a, 2, b, 2, alpha, beta, q, 2, u, 1,
898 $ w, 1, rw, info )
899 CALL chkxer( 'CGGEV ', infot, nout, lerr, ok )
900 infot = 15
901 CALL cggev( 'V', 'V', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
902 $ w, 1, rw, info )
903 CALL chkxer( 'CGGEV ', infot, nout, lerr, ok )
904 nt = nt + 10
905*
906* CGGEV3
907*
908 srnamt = 'CGGEV3'
909 infot = 1
910 CALL cggev3( '/', 'N', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
911 $ w, 1, rw, info )
912 CALL chkxer( 'CGGEV3', infot, nout, lerr, ok )
913 infot = 2
914 CALL cggev3( 'N', '/', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
915 $ w, 1, rw, info )
916 CALL chkxer( 'CGGEV3', infot, nout, lerr, ok )
917 infot = 3
918 CALL cggev3( 'V', 'V', -1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
919 $ w, 1, rw, info )
920 CALL chkxer( 'CGGEV3', infot, nout, lerr, ok )
921 infot = 5
922 CALL cggev3( 'V', 'V', 1, a, 0, b, 1, alpha, beta, q, 1, u, 1,
923 $ w, 1, rw, info )
924 CALL chkxer( 'CGGEV3', infot, nout, lerr, ok )
925 infot = 7
926 CALL cggev3( 'V', 'V', 1, a, 1, b, 0, alpha, beta, q, 1, u, 1,
927 $ w, 1, rw, info )
928 CALL chkxer( 'CGGEV3', infot, nout, lerr, ok )
929 infot = 11
930 CALL cggev3( 'N', 'V', 1, a, 1, b, 1, alpha, beta, q, 0, u, 1,
931 $ w, 1, rw, info )
932 CALL chkxer( 'CGGEV3', infot, nout, lerr, ok )
933 infot = 11
934 CALL cggev3( 'V', 'V', 2, a, 2, b, 2, alpha, beta, q, 1, u, 2,
935 $ w, 1, rw, info )
936 CALL chkxer( 'CGGEV3', infot, nout, lerr, ok )
937 infot = 13
938 CALL cggev3( 'V', 'N', 2, a, 2, b, 2, alpha, beta, q, 2, u, 0,
939 $ w, 1, rw, info )
940 CALL chkxer( 'CGGEV3', infot, nout, lerr, ok )
941 infot = 13
942 CALL cggev3( 'V', 'V', 2, a, 2, b, 2, alpha, beta, q, 2, u, 1,
943 $ w, 1, rw, info )
944 CALL chkxer( 'CGGEV3', infot, nout, lerr, ok )
945 infot = 15
946 CALL cggev3( 'V', 'V', 1, a, 1, b, 1, alpha, beta, q, 1, u, 1,
947 $ w, 1, rw, info )
948 CALL chkxer( 'CGGEV3', infot, nout, lerr, ok )
949 nt = nt + 10
950*
951* CGGEVX
952*
953 srnamt = 'CGGEVX'
954 infot = 1
955 CALL cggevx( '/', '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( 'CGGEVX', infot, nout, lerr, ok )
959 infot = 2
960 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
964 infot = 3
965 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
969 infot = 4
970 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
974 infot = 5
975 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
979 infot = 7
980 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
984 infot = 9
985 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
989 infot = 13
990 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
994 infot = 13
995 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
999 infot = 15
1000 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
1004 infot = 15
1005 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
1009 infot = 25
1010 CALL cggevx( '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( 'CGGEVX', infot, nout, lerr, ok )
1014 nt = nt + 12
1015*
1016* CTGEXC
1017*
1018 srnamt = 'CTGEXC'
1019 infot = 3
1020 CALL ctgexc( .true., .true., -1, a, 1, b, 1, q, 1, z, 1, ifst,
1021 $ ilst, info )
1022 CALL chkxer( 'CTGEXC', infot, nout, lerr, ok )
1023 infot = 5
1024 CALL ctgexc( .true., .true., 1, a, 0, b, 1, q, 1, z, 1, ifst,
1025 $ ilst, info )
1026 CALL chkxer( 'CTGEXC', infot, nout, lerr, ok )
1027 infot = 7
1028 CALL ctgexc( .true., .true., 1, a, 1, b, 0, q, 1, z, 1, ifst,
1029 $ ilst, info )
1030 CALL chkxer( 'CTGEXC', infot, nout, lerr, ok )
1031 infot = 9
1032 CALL ctgexc( .false., .true., 1, a, 1, b, 1, q, 0, z, 1, ifst,
1033 $ ilst, info )
1034 CALL chkxer( 'CTGEXC', infot, nout, lerr, ok )
1035 infot = 9
1036 CALL ctgexc( .true., .true., 1, a, 1, b, 1, q, 0, z, 1, ifst,
1037 $ ilst, info )
1038 CALL chkxer( 'CTGEXC', infot, nout, lerr, ok )
1039 infot = 11
1040 CALL ctgexc( .true., .false., 1, a, 1, b, 1, q, 1, z, 0, ifst,
1041 $ ilst, info )
1042 CALL chkxer( 'CTGEXC', infot, nout, lerr, ok )
1043 infot = 11
1044 CALL ctgexc( .true., .true., 1, a, 1, b, 1, q, 1, z, 0, ifst,
1045 $ ilst, info )
1046 CALL chkxer( 'CTGEXC', infot, nout, lerr, ok )
1047 nt = nt + 7
1048*
1049* CTGSEN
1050*
1051 srnamt = 'CTGSEN'
1052 infot = 1
1053 CALL ctgsen( -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( 'CTGSEN', infot, nout, lerr, ok )
1057 infot = 5
1058 CALL ctgsen( 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( 'CTGSEN', infot, nout, lerr, ok )
1062 infot = 7
1063 CALL ctgsen( 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( 'CTGSEN', infot, nout, lerr, ok )
1067 infot = 9
1068 CALL ctgsen( 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( 'CTGSEN', infot, nout, lerr, ok )
1072 infot = 13
1073 CALL ctgsen( 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( 'CTGSEN', infot, nout, lerr, ok )
1077 infot = 15
1078 CALL ctgsen( 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( 'CTGSEN', infot, nout, lerr, ok )
1082 infot = 21
1083 CALL ctgsen( 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( 'CTGSEN', infot, nout, lerr, ok )
1087 infot = 23
1088 CALL ctgsen( 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( 'CTGSEN', infot, nout, lerr, ok )
1092 infot = 23
1093 CALL ctgsen( 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( 'CTGSEN', infot, nout, lerr, ok )
1097 infot = 23
1098 CALL ctgsen( 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( 'CTGSEN', infot, nout, lerr, ok )
1102 nt = nt + 11
1103*
1104* CTGSNA
1105*
1106 srnamt = 'CTGSNA'
1107 infot = 1
1108 CALL ctgsna( '/', 'A', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1109 $ 1, m, w, 1, iw, info )
1110 CALL chkxer( 'CTGSNA', infot, nout, lerr, ok )
1111 infot = 2
1112 CALL ctgsna( 'B', '/', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1113 $ 1, m, w, 1, iw, info )
1114 CALL chkxer( 'CTGSNA', infot, nout, lerr, ok )
1115 infot = 4
1116 CALL ctgsna( 'B', 'A', sel, -1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1117 $ 1, m, w, 1, iw, info )
1118 CALL chkxer( 'CTGSNA', infot, nout, lerr, ok )
1119 infot = 6
1120 CALL ctgsna( 'B', 'A', sel, 1, a, 0, b, 1, q, 1, u, 1, r1, r2,
1121 $ 1, m, w, 1, iw, info )
1122 CALL chkxer( 'CTGSNA', infot, nout, lerr, ok )
1123 infot = 8
1124 CALL ctgsna( 'B', 'A', sel, 1, a, 1, b, 0, q, 1, u, 1, r1, r2,
1125 $ 1, m, w, 1, iw, info )
1126 CALL chkxer( 'CTGSNA', infot, nout, lerr, ok )
1127 infot = 10
1128 CALL ctgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 0, u, 1, r1, r2,
1129 $ 1, m, w, 1, iw, info )
1130 CALL chkxer( 'CTGSNA', infot, nout, lerr, ok )
1131 infot = 12
1132 CALL ctgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 1, u, 0, r1, r2,
1133 $ 1, m, w, 1, iw, info )
1134 CALL chkxer( 'CTGSNA', infot, nout, lerr, ok )
1135 infot = 15
1136 CALL ctgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1137 $ 0, m, w, 1, iw, info )
1138 CALL chkxer( 'CTGSNA', infot, nout, lerr, ok )
1139 infot = 18
1140 CALL ctgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1141 $ 1, m, w, 0, iw, info )
1142 CALL chkxer( 'CTGSNA', infot, nout, lerr, ok )
1143 nt = nt + 9
1144*
1145* CTGSYL
1146*
1147 srnamt = 'CTGSYL'
1148 infot = 1
1149 CALL ctgsyl( '/', 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( 'CTGSYL', infot, nout, lerr, ok )
1152 infot = 2
1153 CALL ctgsyl( '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( 'CTGSYL', infot, nout, lerr, ok )
1156 infot = 3
1157 CALL ctgsyl( '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( 'CTGSYL', infot, nout, lerr, ok )
1160 infot = 4
1161 CALL ctgsyl( '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( 'CTGSYL', infot, nout, lerr, ok )
1164 infot = 6
1165 CALL ctgsyl( '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( 'CTGSYL', infot, nout, lerr, ok )
1168 infot = 8
1169 CALL ctgsyl( '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( 'CTGSYL', infot, nout, lerr, ok )
1172 infot = 10
1173 CALL ctgsyl( '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( 'CTGSYL', infot, nout, lerr, ok )
1176 infot = 12
1177 CALL ctgsyl( '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( 'CTGSYL', infot, nout, lerr, ok )
1180 infot = 14
1181 CALL ctgsyl( '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( 'CTGSYL', infot, nout, lerr, ok )
1184 infot = 16
1185 CALL ctgsyl( '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( 'CTGSYL', infot, nout, lerr, ok )
1188 infot = 20
1189 CALL ctgsyl( '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( 'CTGSYL', infot, nout, lerr, ok )
1192 infot = 20
1193 CALL ctgsyl( '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( 'CTGSYL', 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 CERRGG
1215*
ctgexc
subroutine ctgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, info)
CTGEXC
Definition ctgexc.f:200
ctgsna
subroutine ctgsna(job, howmny, select, n, a, lda, b, ldb, vl, ldvl, vr, ldvr, s, dif, mm, m, work, lwork, iwork, info)
CTGSNA
Definition ctgsna.f:311
cggsvp3
subroutine cggsvp3(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)
CGGSVP3
Definition cggsvp3.f:278
cggqrf
subroutine cggqrf(n, m, p, a, lda, taua, b, ldb, taub, work, lwork, info)
CGGQRF
Definition cggqrf.f:215
ctgsja
subroutine ctgsja(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)
CTGSJA
Definition ctgsja.f:379
cgghd3
subroutine cgghd3(compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, work, lwork, info)
CGGHD3
Definition cgghd3.f:231
cggrqf
subroutine cggrqf(m, p, n, a, lda, taua, b, ldb, taub, work, lwork, info)
CGGRQF
Definition cggrqf.f:214
ctgsen
subroutine ctgsen(ijob, wantq, wantz, select, n, a, lda, b, ldb, alpha, beta, q, ldq, z, ldz, m, pl, pr, dif, work, lwork, iwork, liwork, info)
CTGSEN
Definition ctgsen.f:433
cggglm
subroutine cggglm(n, m, p, a, lda, b, ldb, d, x, y, work, lwork, info)
CGGGLM
Definition cggglm.f:185
cgglse
subroutine cgglse(m, n, p, a, lda, b, ldb, c, d, x, work, lwork, info)
CGGLSE solves overdetermined or underdetermined systems for OTHER matrices
Definition cgglse.f:180
ctgsyl
subroutine ctgsyl(trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, dif, work, lwork, iwork, info)
CTGSYL
Definition ctgsyl.f:295

◆ cerrhs()

subroutine cerrhs ( character*3 path,
integer nunit )

CERRHS

Purpose:
!>
!> CERRHS tests the error exits for CGEBAK, CGEBAL, CGEHRD, CUNGHR,
!> CUNMHR, CHSEQR, CHSEIN, and CTREVC.
!>
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 cerrhs.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 REAL RW( NMAX ), S( NMAX )
79 COMPLEX 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, cgebak, cgebal, cgehrd, chsein, chseqr,
89 $ cunghr, cunmhr, ctrevc
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC real
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. / real( 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* CGEBAL
125*
126 srnamt = 'CGEBAL'
127 infot = 1
128 CALL cgebal( '/', 0, a, 1, ilo, ihi, s, info )
129 CALL chkxer( 'CGEBAL', infot, nout, lerr, ok )
130 infot = 2
131 CALL cgebal( 'N', -1, a, 1, ilo, ihi, s, info )
132 CALL chkxer( 'CGEBAL', infot, nout, lerr, ok )
133 infot = 4
134 CALL cgebal( 'N', 2, a, 1, ilo, ihi, s, info )
135 CALL chkxer( 'CGEBAL', infot, nout, lerr, ok )
136 nt = nt + 3
137*
138* CGEBAK
139*
140 srnamt = 'CGEBAK'
141 infot = 1
142 CALL cgebak( '/', 'R', 0, 1, 0, s, 0, a, 1, info )
143 CALL chkxer( 'CGEBAK', infot, nout, lerr, ok )
144 infot = 2
145 CALL cgebak( 'N', '/', 0, 1, 0, s, 0, a, 1, info )
146 CALL chkxer( 'CGEBAK', infot, nout, lerr, ok )
147 infot = 3
148 CALL cgebak( 'N', 'R', -1, 1, 0, s, 0, a, 1, info )
149 CALL chkxer( 'CGEBAK', infot, nout, lerr, ok )
150 infot = 4
151 CALL cgebak( 'N', 'R', 0, 0, 0, s, 0, a, 1, info )
152 CALL chkxer( 'CGEBAK', infot, nout, lerr, ok )
153 infot = 4
154 CALL cgebak( 'N', 'R', 0, 2, 0, s, 0, a, 1, info )
155 CALL chkxer( 'CGEBAK', infot, nout, lerr, ok )
156 infot = 5
157 CALL cgebak( 'N', 'R', 2, 2, 1, s, 0, a, 2, info )
158 CALL chkxer( 'CGEBAK', infot, nout, lerr, ok )
159 infot = 5
160 CALL cgebak( 'N', 'R', 0, 1, 1, s, 0, a, 1, info )
161 CALL chkxer( 'CGEBAK', infot, nout, lerr, ok )
162 infot = 7
163 CALL cgebak( 'N', 'R', 0, 1, 0, s, -1, a, 1, info )
164 CALL chkxer( 'CGEBAK', infot, nout, lerr, ok )
165 infot = 9
166 CALL cgebak( 'N', 'R', 2, 1, 2, s, 0, a, 1, info )
167 CALL chkxer( 'CGEBAK', infot, nout, lerr, ok )
168 nt = nt + 9
169*
170* CGEHRD
171*
172 srnamt = 'CGEHRD'
173 infot = 1
174 CALL cgehrd( -1, 1, 1, a, 1, tau, w, 1, info )
175 CALL chkxer( 'CGEHRD', infot, nout, lerr, ok )
176 infot = 2
177 CALL cgehrd( 0, 0, 0, a, 1, tau, w, 1, info )
178 CALL chkxer( 'CGEHRD', infot, nout, lerr, ok )
179 infot = 2
180 CALL cgehrd( 0, 2, 0, a, 1, tau, w, 1, info )
181 CALL chkxer( 'CGEHRD', infot, nout, lerr, ok )
182 infot = 3
183 CALL cgehrd( 1, 1, 0, a, 1, tau, w, 1, info )
184 CALL chkxer( 'CGEHRD', infot, nout, lerr, ok )
185 infot = 3
186 CALL cgehrd( 0, 1, 1, a, 1, tau, w, 1, info )
187 CALL chkxer( 'CGEHRD', infot, nout, lerr, ok )
188 infot = 5
189 CALL cgehrd( 2, 1, 1, a, 1, tau, w, 2, info )
190 CALL chkxer( 'CGEHRD', infot, nout, lerr, ok )
191 infot = 8
192 CALL cgehrd( 2, 1, 2, a, 2, tau, w, 1, info )
193 CALL chkxer( 'CGEHRD', infot, nout, lerr, ok )
194 nt = nt + 7
195*
196* CUNGHR
197*
198 srnamt = 'CUNGHR'
199 infot = 1
200 CALL cunghr( -1, 1, 1, a, 1, tau, w, 1, info )
201 CALL chkxer( 'CUNGHR', infot, nout, lerr, ok )
202 infot = 2
203 CALL cunghr( 0, 0, 0, a, 1, tau, w, 1, info )
204 CALL chkxer( 'CUNGHR', infot, nout, lerr, ok )
205 infot = 2
206 CALL cunghr( 0, 2, 0, a, 1, tau, w, 1, info )
207 CALL chkxer( 'CUNGHR', infot, nout, lerr, ok )
208 infot = 3
209 CALL cunghr( 1, 1, 0, a, 1, tau, w, 1, info )
210 CALL chkxer( 'CUNGHR', infot, nout, lerr, ok )
211 infot = 3
212 CALL cunghr( 0, 1, 1, a, 1, tau, w, 1, info )
213 CALL chkxer( 'CUNGHR', infot, nout, lerr, ok )
214 infot = 5
215 CALL cunghr( 2, 1, 1, a, 1, tau, w, 1, info )
216 CALL chkxer( 'CUNGHR', infot, nout, lerr, ok )
217 infot = 8
218 CALL cunghr( 3, 1, 3, a, 3, tau, w, 1, info )
219 CALL chkxer( 'CUNGHR', infot, nout, lerr, ok )
220 nt = nt + 7
221*
222* CUNMHR
223*
224 srnamt = 'CUNMHR'
225 infot = 1
226 CALL cunmhr( '/', 'N', 0, 0, 1, 0, a, 1, tau, c, 1, w, 1,
227 $ info )
228 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
229 infot = 2
230 CALL cunmhr( 'L', '/', 0, 0, 1, 0, a, 1, tau, c, 1, w, 1,
231 $ info )
232 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
233 infot = 3
234 CALL cunmhr( 'L', 'N', -1, 0, 1, 0, a, 1, tau, c, 1, w, 1,
235 $ info )
236 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
237 infot = 4
238 CALL cunmhr( 'L', 'N', 0, -1, 1, 0, a, 1, tau, c, 1, w, 1,
239 $ info )
240 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
241 infot = 5
242 CALL cunmhr( 'L', 'N', 0, 0, 0, 0, a, 1, tau, c, 1, w, 1,
243 $ info )
244 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
245 infot = 5
246 CALL cunmhr( 'L', 'N', 0, 0, 2, 0, a, 1, tau, c, 1, w, 1,
247 $ info )
248 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
249 infot = 5
250 CALL cunmhr( 'L', 'N', 1, 2, 2, 1, a, 1, tau, c, 1, w, 2,
251 $ info )
252 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
253 infot = 5
254 CALL cunmhr( 'R', 'N', 2, 1, 2, 1, a, 1, tau, c, 2, w, 2,
255 $ info )
256 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
257 infot = 6
258 CALL cunmhr( 'L', 'N', 1, 1, 1, 0, a, 1, tau, c, 1, w, 1,
259 $ info )
260 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
261 infot = 6
262 CALL cunmhr( 'L', 'N', 0, 1, 1, 1, a, 1, tau, c, 1, w, 1,
263 $ info )
264 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
265 infot = 6
266 CALL cunmhr( 'R', 'N', 1, 0, 1, 1, a, 1, tau, c, 1, w, 1,
267 $ info )
268 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
269 infot = 8
270 CALL cunmhr( 'L', 'N', 2, 1, 1, 1, a, 1, tau, c, 2, w, 1,
271 $ info )
272 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
273 infot = 8
274 CALL cunmhr( 'R', 'N', 1, 2, 1, 1, a, 1, tau, c, 1, w, 1,
275 $ info )
276 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
277 infot = 11
278 CALL cunmhr( 'L', 'N', 2, 1, 1, 1, a, 2, tau, c, 1, w, 1,
279 $ info )
280 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
281 infot = 13
282 CALL cunmhr( 'L', 'N', 1, 2, 1, 1, a, 1, tau, c, 1, w, 1,
283 $ info )
284 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
285 infot = 13
286 CALL cunmhr( 'R', 'N', 2, 1, 1, 1, a, 1, tau, c, 2, w, 1,
287 $ info )
288 CALL chkxer( 'CUNMHR', infot, nout, lerr, ok )
289 nt = nt + 16
290*
291* CHSEQR
292*
293 srnamt = 'CHSEQR'
294 infot = 1
295 CALL chseqr( '/', 'N', 0, 1, 0, a, 1, x, c, 1, w, 1,
296 $ info )
297 CALL chkxer( 'CHSEQR', infot, nout, lerr, ok )
298 infot = 2
299 CALL chseqr( 'E', '/', 0, 1, 0, a, 1, x, c, 1, w, 1,
300 $ info )
301 CALL chkxer( 'CHSEQR', infot, nout, lerr, ok )
302 infot = 3
303 CALL chseqr( 'E', 'N', -1, 1, 0, a, 1, x, c, 1, w, 1,
304 $ info )
305 CALL chkxer( 'CHSEQR', infot, nout, lerr, ok )
306 infot = 4
307 CALL chseqr( 'E', 'N', 0, 0, 0, a, 1, x, c, 1, w, 1,
308 $ info )
309 CALL chkxer( 'CHSEQR', infot, nout, lerr, ok )
310 infot = 4
311 CALL chseqr( 'E', 'N', 0, 2, 0, a, 1, x, c, 1, w, 1,
312 $ info )
313 CALL chkxer( 'CHSEQR', infot, nout, lerr, ok )
314 infot = 5
315 CALL chseqr( 'E', 'N', 1, 1, 0, a, 1, x, c, 1, w, 1,
316 $ info )
317 CALL chkxer( 'CHSEQR', infot, nout, lerr, ok )
318 infot = 5
319 CALL chseqr( 'E', 'N', 1, 1, 2, a, 1, x, c, 1, w, 1,
320 $ info )
321 CALL chkxer( 'CHSEQR', infot, nout, lerr, ok )
322 infot = 7
323 CALL chseqr( 'E', 'N', 2, 1, 2, a, 1, x, c, 2, w, 1,
324 $ info )
325 CALL chkxer( 'CHSEQR', infot, nout, lerr, ok )
326 infot = 10
327 CALL chseqr( 'E', 'V', 2, 1, 2, a, 2, x, c, 1, w, 1,
328 $ info )
329 CALL chkxer( 'CHSEQR', infot, nout, lerr, ok )
330 nt = nt + 9
331*
332* CHSEIN
333*
334 srnamt = 'CHSEIN'
335 infot = 1
336 CALL chsein( '/', 'N', 'N', sel, 0, a, 1, x, vl, 1, vr, 1,
337 $ 0, m, w, rw, ifaill, ifailr, info )
338 CALL chkxer( 'CHSEIN', infot, nout, lerr, ok )
339 infot = 2
340 CALL chsein( 'R', '/', 'N', sel, 0, a, 1, x, vl, 1, vr, 1,
341 $ 0, m, w, rw, ifaill, ifailr, info )
342 CALL chkxer( 'CHSEIN', infot, nout, lerr, ok )
343 infot = 3
344 CALL chsein( 'R', 'N', '/', sel, 0, a, 1, x, vl, 1, vr, 1,
345 $ 0, m, w, rw, ifaill, ifailr, info )
346 CALL chkxer( 'CHSEIN', infot, nout, lerr, ok )
347 infot = 5
348 CALL chsein( 'R', 'N', 'N', sel, -1, a, 1, x, vl, 1, vr,
349 $ 1, 0, m, w, rw, ifaill, ifailr, info )
350 CALL chkxer( 'CHSEIN', infot, nout, lerr, ok )
351 infot = 7
352 CALL chsein( 'R', 'N', 'N', sel, 2, a, 1, x, vl, 1, vr, 2,
353 $ 4, m, w, rw, ifaill, ifailr, info )
354 CALL chkxer( 'CHSEIN', infot, nout, lerr, ok )
355 infot = 10
356 CALL chsein( 'L', 'N', 'N', sel, 2, a, 2, x, vl, 1, vr, 1,
357 $ 4, m, w, rw, ifaill, ifailr, info )
358 CALL chkxer( 'CHSEIN', infot, nout, lerr, ok )
359 infot = 12
360 CALL chsein( 'R', 'N', 'N', sel, 2, a, 2, x, vl, 1, vr, 1,
361 $ 4, m, w, rw, ifaill, ifailr, info )
362 CALL chkxer( 'CHSEIN', infot, nout, lerr, ok )
363 infot = 13
364 CALL chsein( 'R', 'N', 'N', sel, 2, a, 2, x, vl, 1, vr, 2,
365 $ 1, m, w, rw, ifaill, ifailr, info )
366 CALL chkxer( 'CHSEIN', infot, nout, lerr, ok )
367 nt = nt + 8
368*
369* CTREVC
370*
371 srnamt = 'CTREVC'
372 infot = 1
373 CALL ctrevc( '/', 'A', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
374 $ rw, info )
375 CALL chkxer( 'CTREVC', infot, nout, lerr, ok )
376 infot = 2
377 CALL ctrevc( 'L', '/', sel, 0, a, 1, vl, 1, vr, 1, 0, m, w,
378 $ rw, info )
379 CALL chkxer( 'CTREVC', infot, nout, lerr, ok )
380 infot = 4
381 CALL ctrevc( 'L', 'A', sel, -1, a, 1, vl, 1, vr, 1, 0, m, w,
382 $ rw, info )
383 CALL chkxer( 'CTREVC', infot, nout, lerr, ok )
384 infot = 6
385 CALL ctrevc( 'L', 'A', sel, 2, a, 1, vl, 2, vr, 1, 4, m, w,
386 $ rw, info )
387 CALL chkxer( 'CTREVC', infot, nout, lerr, ok )
388 infot = 8
389 CALL ctrevc( 'L', 'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
390 $ rw, info )
391 CALL chkxer( 'CTREVC', infot, nout, lerr, ok )
392 infot = 10
393 CALL ctrevc( 'R', 'A', sel, 2, a, 2, vl, 1, vr, 1, 4, m, w,
394 $ rw, info )
395 CALL chkxer( 'CTREVC', infot, nout, lerr, ok )
396 infot = 11
397 CALL ctrevc( 'L', 'A', sel, 2, a, 2, vl, 2, vr, 1, 1, m, w,
398 $ rw, info )
399 CALL chkxer( 'CTREVC', infot, nout, lerr, ok )
400 nt = nt + 7
401 END IF
402*
403* Print a summary line.
404*
405 IF( ok ) THEN
406 WRITE( nout, fmt = 9999 )path, nt
407 ELSE
408 WRITE( nout, fmt = 9998 )path
409 END IF
410*
411 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits',
412 $ ' (', i3, ' tests done)' )
413 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
414 $ 'exits ***' )
415*
416 RETURN
417*
418* End of CERRHS
419*

◆ cerrst()

subroutine cerrst ( character*3 path,
integer nunit )

CERRST

Purpose:
!>
!> CERRST tests the error exits for CHETRD, CUNGTR, CUNMTR, CHPTRD,
!> CUNGTR, CUPMTR, CSTEQR, CSTEIN, CPTEQR, CHBTRD,
!> CHEEV, CHEEVX, CHEEVD, CHBEV, CHBEVX, CHBEVD,
!> CHPEV, CHPEVX, CHPEVD, and CSTEDC.
!> CHEEVD_2STAGE, CHEEVR_2STAGE, CHEEVX_2STAGE,
!> CHEEV_2STAGE, CHBEV_2STAGE, CHBEVD_2STAGE,
!> CHBEVX_2STAGE, CHETRD_2STAGE, CHETRD_HE2HB,
!> CHETRD_HB2ST
!>
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 60 of file cerrst.f.

61*
62* -- LAPACK test routine --
63* -- LAPACK is a software package provided by Univ. of Tennessee, --
64* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
65*
66* .. Scalar Arguments ..
67 CHARACTER*3 PATH
68 INTEGER NUNIT
69* ..
70*
71* =====================================================================
72*
73* .. Parameters ..
74 INTEGER NMAX, LIW, LW
75 parameter( nmax = 3, liw = 12*nmax, lw = 20*nmax )
76* ..
77* .. Local Scalars ..
78 CHARACTER*2 C2
79 INTEGER I, INFO, J, M, N, NT
80* ..
81* .. Local Arrays ..
82 INTEGER I1( NMAX ), I2( NMAX ), I3( NMAX ), IW( LIW )
83 REAL D( NMAX ), E( NMAX ), R( LW ), RW( LW ),
84 $ X( NMAX )
85 COMPLEX A( NMAX, NMAX ), C( NMAX, NMAX ),
86 $ Q( NMAX, NMAX ), TAU( NMAX ), W( LW ),
87 $ Z( NMAX, NMAX )
88* ..
89* .. External Functions ..
90 LOGICAL LSAMEN
91 EXTERNAL lsamen
92* ..
93* .. External Subroutines ..
94 EXTERNAL chbev, chbevd, chbevx, chbtrd, cheev, cheevd,
95 $ cheevr, cheevx, chetrd, chkxer, chpev, chpevd,
96 $ chpevx, chptrd, cpteqr, cstedc, cstein, csteqr,
97 $ cungtr, cunmtr, cupgtr, cupmtr,
98 $ cheevd_2stage, cheevr_2stage, cheevx_2stage,
99 $ cheev_2stage, chbev_2stage, chbevd_2stage,
100 $ chbevx_2stage, chetrd_2stage, chetrd_he2hb,
101 $ chetrd_hb2st
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 real
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. / real( i+j )
126 10 CONTINUE
127 20 CONTINUE
128 DO 30 j = 1, nmax
129 d( j ) = real( j )
130 e( j ) = 0.0
131 i1( j ) = j
132 i2( j ) = j
133 tau( j ) = 1.
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* CHETRD
143*
144 srnamt = 'CHETRD'
145 infot = 1
146 CALL chetrd( '/', 0, a, 1, d, e, tau, w, 1, info )
147 CALL chkxer( 'CHETRD', infot, nout, lerr, ok )
148 infot = 2
149 CALL chetrd( 'U', -1, a, 1, d, e, tau, w, 1, info )
150 CALL chkxer( 'CHETRD', infot, nout, lerr, ok )
151 infot = 4
152 CALL chetrd( 'U', 2, a, 1, d, e, tau, w, 1, info )
153 CALL chkxer( 'CHETRD', infot, nout, lerr, ok )
154 infot = 9
155 CALL chetrd( 'U', 0, a, 1, d, e, tau, w, 0, info )
156 CALL chkxer( 'CHETRD', infot, nout, lerr, ok )
157 nt = nt + 4
158*
159* CHETRD_2STAGE
160*
161 srnamt = 'CHETRD_2STAGE'
162 infot = 1
163 CALL chetrd_2stage( '/', 'U', 0, a, 1, d, e, tau,
164 $ c, 1, w, 1, info )
165 CALL chkxer( 'CHETRD_2STAGE', infot, nout, lerr, ok )
166 infot = 1
167 CALL chetrd_2stage( 'H', 'U', 0, a, 1, d, e, tau,
168 $ c, 1, w, 1, info )
169 CALL chkxer( 'CHETRD_2STAGE', infot, nout, lerr, ok )
170 infot = 2
171 CALL chetrd_2stage( 'N', '/', 0, a, 1, d, e, tau,
172 $ c, 1, w, 1, info )
173 CALL chkxer( 'CHETRD_2STAGE', infot, nout, lerr, ok )
174 infot = 3
175 CALL chetrd_2stage( 'N', 'U', -1, a, 1, d, e, tau,
176 $ c, 1, w, 1, info )
177 CALL chkxer( 'CHETRD_2STAGE', infot, nout, lerr, ok )
178 infot = 5
179 CALL chetrd_2stage( 'N', 'U', 2, a, 1, d, e, tau,
180 $ c, 1, w, 1, info )
181 CALL chkxer( 'CHETRD_2STAGE', infot, nout, lerr, ok )
182 infot = 10
183 CALL chetrd_2stage( 'N', 'U', 0, a, 1, d, e, tau,
184 $ c, 0, w, 1, info )
185 CALL chkxer( 'CHETRD_2STAGE', infot, nout, lerr, ok )
186 infot = 12
187 CALL chetrd_2stage( 'N', 'U', 0, a, 1, d, e, tau,
188 $ c, 1, w, 0, info )
189 CALL chkxer( 'CHETRD_2STAGE', infot, nout, lerr, ok )
190 nt = nt + 7
191*
192* CHETRD_HE2HB
193*
194 srnamt = 'CHETRD_HE2HB'
195 infot = 1
196 CALL chetrd_he2hb( '/', 0, 0, a, 1, c, 1, tau, w, 1, info )
197 CALL chkxer( 'CHETRD_HE2HB', infot, nout, lerr, ok )
198 infot = 2
199 CALL chetrd_he2hb( 'U', -1, 0, a, 1, c, 1, tau, w, 1, info )
200 CALL chkxer( 'CHETRD_HE2HB', infot, nout, lerr, ok )
201 infot = 3
202 CALL chetrd_he2hb( 'U', 0, -1, a, 1, c, 1, tau, w, 1, info )
203 CALL chkxer( 'CHETRD_HE2HB', infot, nout, lerr, ok )
204 infot = 5
205 CALL chetrd_he2hb( 'U', 2, 0, a, 1, c, 1, tau, w, 1, info )
206 CALL chkxer( 'CHETRD_HE2HB', infot, nout, lerr, ok )
207 infot = 7
208 CALL chetrd_he2hb( 'U', 0, 2, a, 1, c, 1, tau, w, 1, info )
209 CALL chkxer( 'CHETRD_HE2HB', infot, nout, lerr, ok )
210 infot = 10
211 CALL chetrd_he2hb( 'U', 0, 0, a, 1, c, 1, tau, w, 0, info )
212 CALL chkxer( 'CHETRD_HE2HB', infot, nout, lerr, ok )
213 nt = nt + 6
214*
215* CHETRD_HB2ST
216*
217 srnamt = 'CHETRD_HB2ST'
218 infot = 1
219 CALL chetrd_hb2st( '/', 'N', 'U', 0, 0, a, 1, d, e,
220 $ c, 1, w, 1, info )
221 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
222 infot = 2
223 CALL chetrd_hb2st( 'Y', '/', 'U', 0, 0, a, 1, d, e,
224 $ c, 1, w, 1, info )
225 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
226 infot = 2
227 CALL chetrd_hb2st( 'Y', 'H', 'U', 0, 0, a, 1, d, e,
228 $ c, 1, w, 1, info )
229 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
230 infot = 3
231 CALL chetrd_hb2st( 'Y', 'N', '/', 0, 0, a, 1, d, e,
232 $ c, 1, w, 1, info )
233 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
234 infot = 4
235 CALL chetrd_hb2st( 'Y', 'N', 'U', -1, 0, a, 1, d, e,
236 $ c, 1, w, 1, info )
237 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
238 infot = 5
239 CALL chetrd_hb2st( 'Y', 'N', 'U', 0, -1, a, 1, d, e,
240 $ c, 1, w, 1, info )
241 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
242 infot = 7
243 CALL chetrd_hb2st( 'Y', 'N', 'U', 0, 1, a, 1, d, e,
244 $ c, 1, w, 1, info )
245 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
246 infot = 11
247 CALL chetrd_hb2st( 'Y', 'N', 'U', 0, 0, a, 1, d, e,
248 $ c, 0, w, 1, info )
249 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
250 infot = 13
251 CALL chetrd_hb2st( 'Y', 'N', 'U', 0, 0, a, 1, d, e,
252 $ c, 1, w, 0, info )
253 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
254 nt = nt + 9
255*
256* CUNGTR
257*
258 srnamt = 'CUNGTR'
259 infot = 1
260 CALL cungtr( '/', 0, a, 1, tau, w, 1, info )
261 CALL chkxer( 'CUNGTR', infot, nout, lerr, ok )
262 infot = 2
263 CALL cungtr( 'U', -1, a, 1, tau, w, 1, info )
264 CALL chkxer( 'CUNGTR', infot, nout, lerr, ok )
265 infot = 4
266 CALL cungtr( 'U', 2, a, 1, tau, w, 1, info )
267 CALL chkxer( 'CUNGTR', infot, nout, lerr, ok )
268 infot = 7
269 CALL cungtr( 'U', 3, a, 3, tau, w, 1, info )
270 CALL chkxer( 'CUNGTR', infot, nout, lerr, ok )
271 nt = nt + 4
272*
273* CUNMTR
274*
275 srnamt = 'CUNMTR'
276 infot = 1
277 CALL cunmtr( '/', 'U', 'N', 0, 0, a, 1, tau, c, 1, w, 1, info )
278 CALL chkxer( 'CUNMTR', infot, nout, lerr, ok )
279 infot = 2
280 CALL cunmtr( 'L', '/', 'N', 0, 0, a, 1, tau, c, 1, w, 1, info )
281 CALL chkxer( 'CUNMTR', infot, nout, lerr, ok )
282 infot = 3
283 CALL cunmtr( 'L', 'U', '/', 0, 0, a, 1, tau, c, 1, w, 1, info )
284 CALL chkxer( 'CUNMTR', infot, nout, lerr, ok )
285 infot = 4
286 CALL cunmtr( 'L', 'U', 'N', -1, 0, a, 1, tau, c, 1, w, 1,
287 $ info )
288 CALL chkxer( 'CUNMTR', infot, nout, lerr, ok )
289 infot = 5
290 CALL cunmtr( 'L', 'U', 'N', 0, -1, a, 1, tau, c, 1, w, 1,
291 $ info )
292 CALL chkxer( 'CUNMTR', infot, nout, lerr, ok )
293 infot = 7
294 CALL cunmtr( 'L', 'U', 'N', 2, 0, a, 1, tau, c, 2, w, 1, info )
295 CALL chkxer( 'CUNMTR', infot, nout, lerr, ok )
296 infot = 7
297 CALL cunmtr( 'R', 'U', 'N', 0, 2, a, 1, tau, c, 1, w, 1, info )
298 CALL chkxer( 'CUNMTR', infot, nout, lerr, ok )
299 infot = 10
300 CALL cunmtr( 'L', 'U', 'N', 2, 0, a, 2, tau, c, 1, w, 1, info )
301 CALL chkxer( 'CUNMTR', infot, nout, lerr, ok )
302 infot = 12
303 CALL cunmtr( 'L', 'U', 'N', 0, 2, a, 1, tau, c, 1, w, 1, info )
304 CALL chkxer( 'CUNMTR', infot, nout, lerr, ok )
305 infot = 12
306 CALL cunmtr( 'R', 'U', 'N', 2, 0, a, 1, tau, c, 2, w, 1, info )
307 CALL chkxer( 'CUNMTR', infot, nout, lerr, ok )
308 nt = nt + 10
309*
310* CHPTRD
311*
312 srnamt = 'CHPTRD'
313 infot = 1
314 CALL chptrd( '/', 0, a, d, e, tau, info )
315 CALL chkxer( 'CHPTRD', infot, nout, lerr, ok )
316 infot = 2
317 CALL chptrd( 'U', -1, a, d, e, tau, info )
318 CALL chkxer( 'CHPTRD', infot, nout, lerr, ok )
319 nt = nt + 2
320*
321* CUPGTR
322*
323 srnamt = 'CUPGTR'
324 infot = 1
325 CALL cupgtr( '/', 0, a, tau, z, 1, w, info )
326 CALL chkxer( 'CUPGTR', infot, nout, lerr, ok )
327 infot = 2
328 CALL cupgtr( 'U', -1, a, tau, z, 1, w, info )
329 CALL chkxer( 'CUPGTR', infot, nout, lerr, ok )
330 infot = 6
331 CALL cupgtr( 'U', 2, a, tau, z, 1, w, info )
332 CALL chkxer( 'CUPGTR', infot, nout, lerr, ok )
333 nt = nt + 3
334*
335* CUPMTR
336*
337 srnamt = 'CUPMTR'
338 infot = 1
339 CALL cupmtr( '/', 'U', 'N', 0, 0, a, tau, c, 1, w, info )
340 CALL chkxer( 'CUPMTR', infot, nout, lerr, ok )
341 infot = 2
342 CALL cupmtr( 'L', '/', 'N', 0, 0, a, tau, c, 1, w, info )
343 CALL chkxer( 'CUPMTR', infot, nout, lerr, ok )
344 infot = 3
345 CALL cupmtr( 'L', 'U', '/', 0, 0, a, tau, c, 1, w, info )
346 CALL chkxer( 'CUPMTR', infot, nout, lerr, ok )
347 infot = 4
348 CALL cupmtr( 'L', 'U', 'N', -1, 0, a, tau, c, 1, w, info )
349 CALL chkxer( 'CUPMTR', infot, nout, lerr, ok )
350 infot = 5
351 CALL cupmtr( 'L', 'U', 'N', 0, -1, a, tau, c, 1, w, info )
352 CALL chkxer( 'CUPMTR', infot, nout, lerr, ok )
353 infot = 9
354 CALL cupmtr( 'L', 'U', 'N', 2, 0, a, tau, c, 1, w, info )
355 CALL chkxer( 'CUPMTR', infot, nout, lerr, ok )
356 nt = nt + 6
357*
358* CPTEQR
359*
360 srnamt = 'CPTEQR'
361 infot = 1
362 CALL cpteqr( '/', 0, d, e, z, 1, rw, info )
363 CALL chkxer( 'CPTEQR', infot, nout, lerr, ok )
364 infot = 2
365 CALL cpteqr( 'N', -1, d, e, z, 1, rw, info )
366 CALL chkxer( 'CPTEQR', infot, nout, lerr, ok )
367 infot = 6
368 CALL cpteqr( 'V', 2, d, e, z, 1, rw, info )
369 CALL chkxer( 'CPTEQR', infot, nout, lerr, ok )
370 nt = nt + 3
371*
372* CSTEIN
373*
374 srnamt = 'CSTEIN'
375 infot = 1
376 CALL cstein( -1, d, e, 0, x, i1, i2, z, 1, rw, iw, i3, info )
377 CALL chkxer( 'CSTEIN', infot, nout, lerr, ok )
378 infot = 4
379 CALL cstein( 0, d, e, -1, x, i1, i2, z, 1, rw, iw, i3, info )
380 CALL chkxer( 'CSTEIN', infot, nout, lerr, ok )
381 infot = 4
382 CALL cstein( 0, d, e, 1, x, i1, i2, z, 1, rw, iw, i3, info )
383 CALL chkxer( 'CSTEIN', infot, nout, lerr, ok )
384 infot = 9
385 CALL cstein( 2, d, e, 0, x, i1, i2, z, 1, rw, iw, i3, info )
386 CALL chkxer( 'CSTEIN', infot, nout, lerr, ok )
387 nt = nt + 4
388*
389* CSTEQR
390*
391 srnamt = 'CSTEQR'
392 infot = 1
393 CALL csteqr( '/', 0, d, e, z, 1, rw, info )
394 CALL chkxer( 'CSTEQR', infot, nout, lerr, ok )
395 infot = 2
396 CALL csteqr( 'N', -1, d, e, z, 1, rw, info )
397 CALL chkxer( 'CSTEQR', infot, nout, lerr, ok )
398 infot = 6
399 CALL csteqr( 'V', 2, d, e, z, 1, rw, info )
400 CALL chkxer( 'CSTEQR', infot, nout, lerr, ok )
401 nt = nt + 3
402*
403* CSTEDC
404*
405 srnamt = 'CSTEDC'
406 infot = 1
407 CALL cstedc( '/', 0, d, e, z, 1, w, 1, rw, 1, iw, 1, info )
408 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
409 infot = 2
410 CALL cstedc( 'N', -1, d, e, z, 1, w, 1, rw, 1, iw, 1, info )
411 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
412 infot = 6
413 CALL cstedc( 'V', 2, d, e, z, 1, w, 4, rw, 23, iw, 28, info )
414 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
415 infot = 8
416 CALL cstedc( 'N', 2, d, e, z, 1, w, 0, rw, 1, iw, 1, info )
417 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
418 infot = 8
419 CALL cstedc( 'V', 2, d, e, z, 2, w, 0, rw, 23, iw, 28, info )
420 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
421 infot = 10
422 CALL cstedc( 'N', 2, d, e, z, 1, w, 1, rw, 0, iw, 1, info )
423 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
424 infot = 10
425 CALL cstedc( 'I', 2, d, e, z, 2, w, 1, rw, 1, iw, 12, info )
426 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
427 infot = 10
428 CALL cstedc( 'V', 2, d, e, z, 2, w, 4, rw, 1, iw, 28, info )
429 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
430 infot = 12
431 CALL cstedc( 'N', 2, d, e, z, 1, w, 1, rw, 1, iw, 0, info )
432 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
433 infot = 12
434 CALL cstedc( 'I', 2, d, e, z, 2, w, 1, rw, 23, iw, 0, info )
435 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
436 infot = 12
437 CALL cstedc( 'V', 2, d, e, z, 2, w, 4, rw, 23, iw, 0, info )
438 CALL chkxer( 'CSTEDC', infot, nout, lerr, ok )
439 nt = nt + 11
440*
441* CHEEVD
442*
443 srnamt = 'CHEEVD'
444 infot = 1
445 CALL cheevd( '/', 'U', 0, a, 1, x, w, 1, rw, 1, iw, 1, info )
446 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
447 infot = 2
448 CALL cheevd( 'N', '/', 0, a, 1, x, w, 1, rw, 1, iw, 1, info )
449 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
450 infot = 3
451 CALL cheevd( 'N', 'U', -1, a, 1, x, w, 1, rw, 1, iw, 1, info )
452 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
453 infot = 5
454 CALL cheevd( 'N', 'U', 2, a, 1, x, w, 3, rw, 2, iw, 1, info )
455 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
456 infot = 8
457 CALL cheevd( 'N', 'U', 1, a, 1, x, w, 0, rw, 1, iw, 1, info )
458 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
459 infot = 8
460 CALL cheevd( 'N', 'U', 2, a, 2, x, w, 2, rw, 2, iw, 1, info )
461 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
462 infot = 8
463 CALL cheevd( 'V', 'U', 2, a, 2, x, w, 3, rw, 25, iw, 12, info )
464 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
465 infot = 10
466 CALL cheevd( 'N', 'U', 1, a, 1, x, w, 1, rw, 0, iw, 1, info )
467 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
468 infot = 10
469 CALL cheevd( 'N', 'U', 2, a, 2, x, w, 3, rw, 1, iw, 1, info )
470 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
471 infot = 10
472 CALL cheevd( 'V', 'U', 2, a, 2, x, w, 8, rw, 18, iw, 12, info )
473 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
474 infot = 12
475 CALL cheevd( 'N', 'U', 1, a, 1, x, w, 1, rw, 1, iw, 0, info )
476 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
477 infot = 12
478 CALL cheevd( 'V', 'U', 2, a, 2, x, w, 8, rw, 25, iw, 11, info )
479 CALL chkxer( 'CHEEVD', infot, nout, lerr, ok )
480 nt = nt + 12
481*
482* CHEEVD_2STAGE
483*
484 srnamt = 'CHEEVD_2STAGE'
485 infot = 1
486 CALL cheevd_2stage( '/', 'U', 0, a, 1, x, w, 1,
487 $ rw, 1, iw, 1, info )
488 CALL chkxer( 'CHEEVD_2STAGE', infot, nout, lerr, ok )
489 infot = 1
490 CALL cheevd_2stage( 'V', 'U', 0, a, 1, x, w, 1,
491 $ rw, 1, iw, 1, info )
492 CALL chkxer( 'CHEEVD_2STAGE', infot, nout, lerr, ok )
493 infot = 2
494 CALL cheevd_2stage( 'N', '/', 0, a, 1, x, w, 1,
495 $ rw, 1, iw, 1, info )
496 CALL chkxer( 'CHEEVD_2STAGE', infot, nout, lerr, ok )
497 infot = 3
498 CALL cheevd_2stage( 'N', 'U', -1, a, 1, x, w, 1,
499 $ rw, 1, iw, 1, info )
500 CALL chkxer( 'CHEEVD_2STAGE', infot, nout, lerr, ok )
501 infot = 5
502 CALL cheevd_2stage( 'N', 'U', 2, a, 1, x, w, 3,
503 $ rw, 2, iw, 1, info )
504 CALL chkxer( 'CHEEVD_2STAGE', infot, nout, lerr, ok )
505 infot = 8
506 CALL cheevd_2stage( 'N', 'U', 1, a, 1, x, w, 0,
507 $ rw, 1, iw, 1, info )
508 CALL chkxer( 'CHEEVD_2STAGE', infot, nout, lerr, ok )
509 infot = 8
510 CALL cheevd_2stage( 'N', 'U', 2, a, 2, x, w, 2,
511 $ rw, 2, iw, 1, info )
512 CALL chkxer( 'CHEEVD_2STAGE', infot, nout, lerr, ok )
513* INFOT = 8
514* CALL CHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 3,
515* $ RW, 25, IW, 12, INFO )
516* CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK )
517 infot = 10
518 CALL cheevd_2stage( 'N', 'U', 1, a, 1, x, w, 1,
519 $ rw, 0, iw, 1, info )
520 CALL chkxer( 'CHEEVD_2STAGE', infot, nout, lerr, ok )
521 infot = 10
522 CALL cheevd_2stage( 'N', 'U', 2, a, 2, x, w, 25,
523 $ rw, 1, iw, 1, info )
524 CALL chkxer( 'CHEEVD_2STAGE', infot, nout, lerr, ok )
525* INFOT = 10
526* CALL CHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8,
527* $ RW, 18, IW, 12, INFO )
528* CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK )
529 infot = 12
530 CALL cheevd_2stage( 'N', 'U', 1, a, 1, x, w, 1,
531 $ rw, 1, iw, 0, info )
532 CALL chkxer( 'CHEEVD_2STAGE', infot, nout, lerr, ok )
533 infot = 12
534* CALL CHEEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 8,
535* $ RW, 25, IW, 11, INFO )
536* CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK )
537 nt = nt + 10
538*
539* CHEEV
540*
541 srnamt = 'CHEEV '
542 infot = 1
543 CALL cheev( '/', 'U', 0, a, 1, x, w, 1, rw, info )
544 CALL chkxer( 'CHEEV ', infot, nout, lerr, ok )
545 infot = 2
546 CALL cheev( 'N', '/', 0, a, 1, x, w, 1, rw, info )
547 CALL chkxer( 'CHEEV ', infot, nout, lerr, ok )
548 infot = 3
549 CALL cheev( 'N', 'U', -1, a, 1, x, w, 1, rw, info )
550 CALL chkxer( 'CHEEV ', infot, nout, lerr, ok )
551 infot = 5
552 CALL cheev( 'N', 'U', 2, a, 1, x, w, 3, rw, info )
553 CALL chkxer( 'CHEEV ', infot, nout, lerr, ok )
554 infot = 8
555 CALL cheev( 'N', 'U', 2, a, 2, x, w, 2, rw, info )
556 CALL chkxer( 'CHEEV ', infot, nout, lerr, ok )
557 nt = nt + 5
558*
559* CHEEV_2STAGE
560*
561 srnamt = 'CHEEV_2STAGE '
562 infot = 1
563 CALL cheev_2stage( '/', 'U', 0, a, 1, x, w, 1, rw, info )
564 CALL chkxer( 'CHEEV_2STAGE ', infot, nout, lerr, ok )
565 infot = 1
566 CALL cheev_2stage( 'V', 'U', 0, a, 1, x, w, 1, rw, info )
567 CALL chkxer( 'CHEEV_2STAGE ', infot, nout, lerr, ok )
568 infot = 2
569 CALL cheev_2stage( 'N', '/', 0, a, 1, x, w, 1, rw, info )
570 CALL chkxer( 'CHEEV_2STAGE ', infot, nout, lerr, ok )
571 infot = 3
572 CALL cheev_2stage( 'N', 'U', -1, a, 1, x, w, 1, rw, info )
573 CALL chkxer( 'CHEEV_2STAGE ', infot, nout, lerr, ok )
574 infot = 5
575 CALL cheev_2stage( 'N', 'U', 2, a, 1, x, w, 3, rw, info )
576 CALL chkxer( 'CHEEV_2STAGE ', infot, nout, lerr, ok )
577 infot = 8
578 CALL cheev_2stage( 'N', 'U', 2, a, 2, x, w, 2, rw, info )
579 CALL chkxer( 'CHEEV_2STAGE ', infot, nout, lerr, ok )
580 nt = nt + 6
581*
582* CHEEVX
583*
584 srnamt = 'CHEEVX'
585 infot = 1
586 CALL cheevx( '/', 'A', 'U', 0, a, 1, 0.0, 0.0, 0, 0, 0.0, m, x,
587 $ z, 1, w, 1, rw, iw, i3, info )
588 CALL chkxer( 'CHEEVX', infot, nout, lerr, ok )
589 infot = 2
590 CALL cheevx( 'V', '/', 'U', 0, a, 1, 0.0, 1.0, 1, 0, 0.0, m, x,
591 $ z, 1, w, 1, rw, iw, i3, info )
592 CALL chkxer( 'CHEEVX', infot, nout, lerr, ok )
593 infot = 3
594 CALL cheevx( 'V', 'A', '/', 0, a, 1, 0.0, 0.0, 0, 0, 0.0, m, x,
595 $ z, 1, w, 1, rw, iw, i3, info )
596 infot = 4
597 CALL cheevx( 'V', 'A', 'U', -1, a, 1, 0.0, 0.0, 0, 0, 0.0, m,
598 $ x, z, 1, w, 1, rw, iw, i3, info )
599 CALL chkxer( 'CHEEVX', infot, nout, lerr, ok )
600 infot = 6
601 CALL cheevx( 'V', 'A', 'U', 2, a, 1, 0.0, 0.0, 0, 0, 0.0, m, x,
602 $ z, 2, w, 3, rw, iw, i3, info )
603 CALL chkxer( 'CHEEVX', infot, nout, lerr, ok )
604 infot = 8
605 CALL cheevx( 'V', 'V', 'U', 1, a, 1, 0.0, 0.0, 0, 0, 0.0, m, x,
606 $ z, 1, w, 1, rw, iw, i3, info )
607 CALL chkxer( 'CHEEVX', infot, nout, lerr, ok )
608 infot = 9
609 CALL cheevx( 'V', 'I', 'U', 1, a, 1, 0.0, 0.0, 0, 0, 0.0, m, x,
610 $ z, 1, w, 1, rw, iw, i3, info )
611 CALL chkxer( 'CHEEVX', infot, nout, lerr, ok )
612 infot = 10
613 CALL cheevx( 'V', 'I', 'U', 2, a, 2, 0.0, 0.0, 2, 1, 0.0, m, x,
614 $ z, 2, w, 3, rw, iw, i3, info )
615 CALL chkxer( 'CHEEVX', infot, nout, lerr, ok )
616 infot = 15
617 CALL cheevx( 'V', 'A', 'U', 2, a, 2, 0.0, 0.0, 0, 0, 0.0, m, x,
618 $ z, 1, w, 3, rw, iw, i3, info )
619 CALL chkxer( 'CHEEVX', infot, nout, lerr, ok )
620 infot = 17
621 CALL cheevx( 'V', 'A', 'U', 2, a, 2, 0.0, 0.0, 0, 0, 0.0, m, x,
622 $ z, 2, w, 2, rw, iw, i1, info )
623 CALL chkxer( 'CHEEVX', infot, nout, lerr, ok )
624 nt = nt + 10
625*
626* CHEEVX_2STAGE
627*
628 srnamt = 'CHEEVX_2STAGE'
629 infot = 1
630 CALL cheevx_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( 'CHEEVX_2STAGE', infot, nout, lerr, ok )
634 infot = 1
635 CALL cheevx_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( 'CHEEVX_2STAGE', infot, nout, lerr, ok )
639 infot = 2
640 CALL cheevx_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( 'CHEEVX_2STAGE', infot, nout, lerr, ok )
644 infot = 3
645 CALL cheevx_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 cheevx_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( 'CHEEVX_2STAGE', infot, nout, lerr, ok )
653 infot = 6
654 CALL cheevx_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( 'CHEEVX_2STAGE', infot, nout, lerr, ok )
658 infot = 8
659 CALL cheevx_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( 'CHEEVX_2STAGE', infot, nout, lerr, ok )
663 infot = 9
664 CALL cheevx_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( 'CHEEVX_2STAGE', infot, nout, lerr, ok )
668 infot = 10
669 CALL cheevx_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( 'CHEEVX_2STAGE', infot, nout, lerr, ok )
673 infot = 15
674 CALL cheevx_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( 'CHEEVX_2STAGE', infot, nout, lerr, ok )
678 infot = 17
679 CALL cheevx_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( 'CHEEVX_2STAGE', infot, nout, lerr, ok )
683 nt = nt + 11
684*
685* CHEEVR
686*
687 srnamt = 'CHEEVR'
688 n = 1
689 infot = 1
690 CALL cheevr( '/', 'A', 'U', 0, a, 1, 0.0, 0.0, 1, 1, 0.0, m, r,
691 $ z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ), 10*n,
692 $ info )
693 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
694 infot = 2
695 CALL cheevr( 'V', '/', 'U', 0, a, 1, 0.0, 0.0, 1, 1, 0.0, m, r,
696 $ z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ), 10*n,
697 $ info )
698 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
699 infot = 3
700 CALL cheevr( 'V', 'A', '/', -1, a, 1, 0.0, 0.0, 1, 1, 0.0, m,
701 $ r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ), 10*n,
702 $ info )
703 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
704 infot = 4
705 CALL cheevr( 'V', 'A', 'U', -1, a, 1, 0.0, 0.0, 1, 1, 0.0, m,
706 $ r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ), 10*n,
707 $ info )
708 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
709 infot = 6
710 CALL cheevr( 'V', 'A', 'U', 2, a, 1, 0.0, 0.0, 1, 1, 0.0, m, r,
711 $ z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ), 10*n,
712 $ info )
713 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
714 infot = 8
715 CALL cheevr( 'V', 'V', 'U', 1, a, 1, 0.0e0, 0.0e0, 1, 1, 0.0,
716 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
717 $ 10*n, info )
718 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
719 infot = 9
720 CALL cheevr( 'V', 'I', 'U', 1, a, 1, 0.0e0, 0.0e0, 0, 1, 0.0,
721 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
722 $ 10*n, info )
723 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
724 infot = 10
725*
726 CALL cheevr( 'V', 'I', 'U', 2, a, 2, 0.0e0, 0.0e0, 2, 1, 0.0,
727 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
728 $ 10*n, info )
729 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
730 infot = 15
731 CALL cheevr( 'V', 'I', 'U', 1, a, 1, 0.0e0, 0.0e0, 1, 1, 0.0,
732 $ m, r, z, 0, iw, q, 2*n, rw, 24*n, iw( 2*n+1 ),
733 $ 10*n, info )
734 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
735 infot = 18
736 CALL cheevr( 'V', 'I', 'U', 1, a, 1, 0.0e0, 0.0e0, 1, 1, 0.0,
737 $ m, r, z, 1, iw, q, 2*n-1, rw, 24*n, iw( 2*n+1 ),
738 $ 10*n, info )
739 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
740 infot = 20
741 CALL cheevr( 'V', 'I', 'U', 1, a, 1, 0.0e0, 0.0e0, 1, 1, 0.0,
742 $ m, r, z, 1, iw, q, 2*n, rw, 24*n-1, iw( 2*n-1 ),
743 $ 10*n, info )
744 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
745 infot = 22
746 CALL cheevr( 'V', 'I', 'U', 1, a, 1, 0.0e0, 0.0e0, 1, 1, 0.0,
747 $ m, r, z, 1, iw, q, 2*n, rw, 24*n, iw, 10*n-1,
748 $ info )
749 CALL chkxer( 'CHEEVR', infot, nout, lerr, ok )
750 nt = nt + 12
751*
752* CHEEVR_2STAGE
753*
754 srnamt = 'CHEEVR_2STAGE'
755 n = 1
756 infot = 1
757 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
762 infot = 1
763 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
768 infot = 2
769 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
774 infot = 3
775 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
780 infot = 4
781 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
786 infot = 6
787 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
792 infot = 8
793 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
798 infot = 9
799 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
804 infot = 10
805 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
810 infot = 15
811 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
816 infot = 18
817 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
822 infot = 20
823 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
828 infot = 22
829 CALL cheevr_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( 'CHEEVR_2STAGE', infot, nout, lerr, ok )
834 nt = nt + 13
835*
836* CHPEVD
837*
838 srnamt = 'CHPEVD'
839 infot = 1
840 CALL chpevd( '/', 'U', 0, a, x, z, 1, w, 1, rw, 1, iw, 1,
841 $ info )
842 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
843 infot = 2
844 CALL chpevd( 'N', '/', 0, a, x, z, 1, w, 1, rw, 1, iw, 1,
845 $ info )
846 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
847 infot = 3
848 CALL chpevd( 'N', 'U', -1, a, x, z, 1, w, 1, rw, 1, iw, 1,
849 $ info )
850 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
851 infot = 7
852 CALL chpevd( 'V', 'U', 2, a, x, z, 1, w, 4, rw, 25, iw, 12,
853 $ info )
854 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
855 infot = 9
856 CALL chpevd( 'N', 'U', 1, a, x, z, 1, w, 0, rw, 1, iw, 1,
857 $ info )
858 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
859 infot = 9
860 CALL chpevd( 'N', 'U', 2, a, x, z, 2, w, 1, rw, 2, iw, 1,
861 $ info )
862 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
863 infot = 9
864 CALL chpevd( 'V', 'U', 2, a, x, z, 2, w, 2, rw, 25, iw, 12,
865 $ info )
866 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
867 infot = 11
868 CALL chpevd( 'N', 'U', 1, a, x, z, 1, w, 1, rw, 0, iw, 1,
869 $ info )
870 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
871 infot = 11
872 CALL chpevd( 'N', 'U', 2, a, x, z, 2, w, 2, rw, 1, iw, 1,
873 $ info )
874 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
875 infot = 11
876 CALL chpevd( 'V', 'U', 2, a, x, z, 2, w, 4, rw, 18, iw, 12,
877 $ info )
878 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
879 infot = 13
880 CALL chpevd( 'N', 'U', 1, a, x, z, 1, w, 1, rw, 1, iw, 0,
881 $ info )
882 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
883 infot = 13
884 CALL chpevd( 'N', 'U', 2, a, x, z, 2, w, 2, rw, 2, iw, 0,
885 $ info )
886 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
887 infot = 13
888 CALL chpevd( 'V', 'U', 2, a, x, z, 2, w, 4, rw, 25, iw, 2,
889 $ info )
890 CALL chkxer( 'CHPEVD', infot, nout, lerr, ok )
891 nt = nt + 13
892*
893* CHPEV
894*
895 srnamt = 'CHPEV '
896 infot = 1
897 CALL chpev( '/', 'U', 0, a, x, z, 1, w, rw, info )
898 CALL chkxer( 'CHPEV ', infot, nout, lerr, ok )
899 infot = 2
900 CALL chpev( 'N', '/', 0, a, x, z, 1, w, rw, info )
901 CALL chkxer( 'CHPEV ', infot, nout, lerr, ok )
902 infot = 3
903 CALL chpev( 'N', 'U', -1, a, x, z, 1, w, rw, info )
904 CALL chkxer( 'CHPEV ', infot, nout, lerr, ok )
905 infot = 7
906 CALL chpev( 'V', 'U', 2, a, x, z, 1, w, rw, info )
907 CALL chkxer( 'CHPEV ', infot, nout, lerr, ok )
908 nt = nt + 4
909*
910* CHPEVX
911*
912 srnamt = 'CHPEVX'
913 infot = 1
914 CALL chpevx( '/', 'A', 'U', 0, a, 0.0, 0.0, 0, 0, 0.0, m, x, z,
915 $ 1, w, rw, iw, i3, info )
916 CALL chkxer( 'CHPEVX', infot, nout, lerr, ok )
917 infot = 2
918 CALL chpevx( 'V', '/', 'U', 0, a, 0.0, 1.0, 1, 0, 0.0, m, x, z,
919 $ 1, w, rw, iw, i3, info )
920 CALL chkxer( 'CHPEVX', infot, nout, lerr, ok )
921 infot = 3
922 CALL chpevx( 'V', 'A', '/', 0, a, 0.0, 0.0, 0, 0, 0.0, m, x, z,
923 $ 1, w, rw, iw, i3, info )
924 CALL chkxer( 'CHPEVX', infot, nout, lerr, ok )
925 infot = 4
926 CALL chpevx( 'V', 'A', 'U', -1, a, 0.0, 0.0, 0, 0, 0.0, m, x,
927 $ z, 1, w, rw, iw, i3, info )
928 CALL chkxer( 'CHPEVX', infot, nout, lerr, ok )
929 infot = 7
930 CALL chpevx( 'V', 'V', 'U', 1, a, 0.0, 0.0, 0, 0, 0.0, m, x, z,
931 $ 1, w, rw, iw, i3, info )
932 CALL chkxer( 'CHPEVX', infot, nout, lerr, ok )
933 infot = 8
934 CALL chpevx( 'V', 'I', 'U', 1, a, 0.0, 0.0, 0, 0, 0.0, m, x, z,
935 $ 1, w, rw, iw, i3, info )
936 CALL chkxer( 'CHPEVX', infot, nout, lerr, ok )
937 infot = 9
938 CALL chpevx( 'V', 'I', 'U', 2, a, 0.0, 0.0, 2, 1, 0.0, m, x, z,
939 $ 2, w, rw, iw, i3, info )
940 CALL chkxer( 'CHPEVX', infot, nout, lerr, ok )
941 infot = 14
942 CALL chpevx( 'V', 'A', 'U', 2, a, 0.0, 0.0, 0, 0, 0.0, m, x, z,
943 $ 1, w, rw, iw, i3, info )
944 CALL chkxer( 'CHPEVX', 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* CHBTRD
952*
953 srnamt = 'CHBTRD'
954 infot = 1
955 CALL chbtrd( '/', 'U', 0, 0, a, 1, d, e, z, 1, w, info )
956 CALL chkxer( 'CHBTRD', infot, nout, lerr, ok )
957 infot = 2
958 CALL chbtrd( 'N', '/', 0, 0, a, 1, d, e, z, 1, w, info )
959 CALL chkxer( 'CHBTRD', infot, nout, lerr, ok )
960 infot = 3
961 CALL chbtrd( 'N', 'U', -1, 0, a, 1, d, e, z, 1, w, info )
962 CALL chkxer( 'CHBTRD', infot, nout, lerr, ok )
963 infot = 4
964 CALL chbtrd( 'N', 'U', 0, -1, a, 1, d, e, z, 1, w, info )
965 CALL chkxer( 'CHBTRD', infot, nout, lerr, ok )
966 infot = 6
967 CALL chbtrd( 'N', 'U', 1, 1, a, 1, d, e, z, 1, w, info )
968 CALL chkxer( 'CHBTRD', infot, nout, lerr, ok )
969 infot = 10
970 CALL chbtrd( 'V', 'U', 2, 0, a, 1, d, e, z, 1, w, info )
971 CALL chkxer( 'CHBTRD', infot, nout, lerr, ok )
972 nt = nt + 6
973*
974* CHETRD_HB2ST
975*
976 srnamt = 'CHETRD_HB2ST'
977 infot = 1
978 CALL chetrd_hb2st( '/', 'N', 'U', 0, 0, a, 1, d, e,
979 $ c, 1, w, 1, info )
980 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
981 infot = 2
982 CALL chetrd_hb2st( 'N', '/', 'U', 0, 0, a, 1, d, e,
983 $ c, 1, w, 1, info )
984 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
985 infot = 2
986 CALL chetrd_hb2st( 'N', 'H', 'U', 0, 0, a, 1, d, e,
987 $ c, 1, w, 1, info )
988 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
989 infot = 3
990 CALL chetrd_hb2st( 'N', 'N', '/', 0, 0, a, 1, d, e,
991 $ c, 1, w, 1, info )
992 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
993 infot = 4
994 CALL chetrd_hb2st( 'N', 'N', 'U', -1, 0, a, 1, d, e,
995 $ c, 1, w, 1, info )
996 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
997 infot = 5
998 CALL chetrd_hb2st( 'N', 'N', 'U', 0, -1, a, 1, d, e,
999 $ c, 1, w, 1, info )
1000 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
1001 infot = 7
1002 CALL chetrd_hb2st( 'N', 'N', 'U', 0, 1, a, 1, d, e,
1003 $ c, 1, w, 1, info )
1004 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
1005 infot = 11
1006 CALL chetrd_hb2st( 'N', 'N', 'U', 0, 0, a, 1, d, e,
1007 $ c, 0, w, 1, info )
1008 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
1009 infot = 13
1010 CALL chetrd_hb2st( 'N', 'N', 'U', 0, 0, a, 1, d, e,
1011 $ c, 1, w, 0, info )
1012 CALL chkxer( 'CHETRD_HB2ST', infot, nout, lerr, ok )
1013 nt = nt + 9
1014*
1015* CHBEVD
1016*
1017 srnamt = 'CHBEVD'
1018 infot = 1
1019 CALL chbevd( '/', 'U', 0, 0, a, 1, x, z, 1, w, 1, rw, 1, iw, 1,
1020 $ info )
1021 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1022 infot = 2
1023 CALL chbevd( 'N', '/', 0, 0, a, 1, x, z, 1, w, 1, rw, 1, iw, 1,
1024 $ info )
1025 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1026 infot = 3
1027 CALL chbevd( 'N', 'U', -1, 0, a, 1, x, z, 1, w, 1, rw, 1, iw,
1028 $ 1, info )
1029 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1030 infot = 4
1031 CALL chbevd( 'N', 'U', 0, -1, a, 1, x, z, 1, w, 1, rw, 1, iw,
1032 $ 1, info )
1033 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1034 infot = 6
1035 CALL chbevd( 'N', 'U', 2, 1, a, 1, x, z, 1, w, 2, rw, 2, iw, 1,
1036 $ info )
1037 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1038 infot = 9
1039 CALL chbevd( 'V', 'U', 2, 1, a, 2, x, z, 1, w, 8, rw, 25, iw,
1040 $ 12, info )
1041 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1042 infot = 11
1043 CALL chbevd( 'N', 'U', 1, 0, a, 1, x, z, 1, w, 0, rw, 1, iw, 1,
1044 $ info )
1045 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1046 infot = 11
1047 CALL chbevd( 'N', 'U', 2, 1, a, 2, x, z, 2, w, 1, rw, 2, iw, 1,
1048 $ info )
1049 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1050 infot = 11
1051 CALL chbevd( 'V', 'U', 2, 1, a, 2, x, z, 2, w, 2, rw, 25, iw,
1052 $ 12, info )
1053 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1054 infot = 13
1055 CALL chbevd( 'N', 'U', 1, 0, a, 1, x, z, 1, w, 1, rw, 0, iw, 1,
1056 $ info )
1057 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1058 infot = 13
1059 CALL chbevd( 'N', 'U', 2, 1, a, 2, x, z, 2, w, 2, rw, 1, iw, 1,
1060 $ info )
1061 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1062 infot = 13
1063 CALL chbevd( 'V', 'U', 2, 1, a, 2, x, z, 2, w, 8, rw, 2, iw,
1064 $ 12, info )
1065 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1066 infot = 15
1067 CALL chbevd( 'N', 'U', 1, 0, a, 1, x, z, 1, w, 1, rw, 1, iw, 0,
1068 $ info )
1069 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1070 infot = 15
1071 CALL chbevd( 'N', 'U', 2, 1, a, 2, x, z, 2, w, 2, rw, 2, iw, 0,
1072 $ info )
1073 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1074 infot = 15
1075 CALL chbevd( 'V', 'U', 2, 1, a, 2, x, z, 2, w, 8, rw, 25, iw,
1076 $ 2, info )
1077 CALL chkxer( 'CHBEVD', infot, nout, lerr, ok )
1078 nt = nt + 15
1079*
1080* CHBEVD_2STAGE
1081*
1082 srnamt = 'CHBEVD_2STAGE'
1083 infot = 1
1084 CALL chbevd_2stage( '/', 'U', 0, 0, a, 1, x, z, 1,
1085 $ w, 1, rw, 1, iw, 1, info )
1086 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1087 infot = 1
1088 CALL chbevd_2stage( 'V', 'U', 0, 0, a, 1, x, z, 1,
1089 $ w, 1, rw, 1, iw, 1, info )
1090 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1091 infot = 2
1092 CALL chbevd_2stage( 'N', '/', 0, 0, a, 1, x, z, 1,
1093 $ w, 1, rw, 1, iw, 1, info )
1094 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1095 infot = 3
1096 CALL chbevd_2stage( 'N', 'U', -1, 0, a, 1, x, z, 1,
1097 $ w, 1, rw, 1, iw, 1, info )
1098 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1099 infot = 4
1100 CALL chbevd_2stage( 'N', 'U', 0, -1, a, 1, x, z, 1,
1101 $ w, 1, rw, 1, iw, 1, info )
1102 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1103 infot = 6
1104 CALL chbevd_2stage( 'N', 'U', 2, 1, a, 1, x, z, 1,
1105 $ w, 2, rw, 2, iw, 1, info )
1106 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1107 infot = 9
1108 CALL chbevd_2stage( 'N', 'U', 2, 1, a, 2, x, z, 0,
1109 $ w, 8, rw, 25, iw, 12, info )
1110 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1111 infot = 11
1112 CALL chbevd_2stage( 'N', 'U', 1, 0, a, 1, x, z, 1,
1113 $ w, 0, rw, 1, iw, 1, info )
1114 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1115 infot = 11
1116 CALL chbevd_2stage( 'N', 'U', 2, 1, a, 2, x, z, 2,
1117 $ w, 1, rw, 2, iw, 1, info )
1118 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1119* INFOT = 11
1120* CALL CHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2,
1121* $ W, 2, RW, 25, IW, 12, INFO )
1122* CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK )
1123 infot = 13
1124 CALL chbevd_2stage( 'N', 'U', 1, 0, a, 1, x, z, 1,
1125 $ w, 1, rw, 0, iw, 1, info )
1126 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1127 infot = 13
1128 CALL chbevd_2stage( 'N', 'U', 2, 1, a, 2, x, z, 2,
1129 $ w, 25, rw, 1, iw, 1, info )
1130 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1131* INFOT = 13
1132* CALL CHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2,
1133* $ W, 25, RW, 2, IW, 12, INFO )
1134* CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK )
1135 infot = 15
1136 CALL chbevd_2stage( 'N', 'U', 1, 0, a, 1, x, z, 1,
1137 $ w, 1, rw, 1, iw, 0, info )
1138 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1139 infot = 15
1140 CALL chbevd_2stage( 'N', 'U', 2, 1, a, 2, x, z, 2,
1141 $ w, 25, rw, 2, iw, 0, info )
1142 CALL chkxer( 'CHBEVD_2STAGE', infot, nout, lerr, ok )
1143* INFOT = 15
1144* CALL CHBEVD_2STAGE( 'V', 'U', 2, 1, A, 2, X, Z, 2,
1145* $ W, 25, RW, 25, IW, 2, INFO )
1146* CALL CHKXER( 'CHBEVD_2STAGE', INFOT, NOUT, LERR, OK )
1147 nt = nt + 13
1148*
1149* CHBEV
1150*
1151 srnamt = 'CHBEV '
1152 infot = 1
1153 CALL chbev( '/', 'U', 0, 0, a, 1, x, z, 1, w, rw, info )
1154 CALL chkxer( 'CHBEV ', infot, nout, lerr, ok )
1155 infot = 2
1156 CALL chbev( 'N', '/', 0, 0, a, 1, x, z, 1, w, rw, info )
1157 CALL chkxer( 'CHBEV ', infot, nout, lerr, ok )
1158 infot = 3
1159 CALL chbev( 'N', 'U', -1, 0, a, 1, x, z, 1, w, rw, info )
1160 CALL chkxer( 'CHBEV ', infot, nout, lerr, ok )
1161 infot = 4
1162 CALL chbev( 'N', 'U', 0, -1, a, 1, x, z, 1, w, rw, info )
1163 CALL chkxer( 'CHBEV ', infot, nout, lerr, ok )
1164 infot = 6
1165 CALL chbev( 'N', 'U', 2, 1, a, 1, x, z, 1, w, rw, info )
1166 CALL chkxer( 'CHBEV ', infot, nout, lerr, ok )
1167 infot = 9
1168 CALL chbev( 'V', 'U', 2, 0, a, 1, x, z, 1, w, rw, info )
1169 CALL chkxer( 'CHBEV ', infot, nout, lerr, ok )
1170 nt = nt + 6
1171*
1172* CHBEV_2STAGE
1173*
1174 srnamt = 'CHBEV_2STAGE '
1175 infot = 1
1176 CALL chbev_2stage( '/', 'U', 0, 0, a, 1, x,
1177 $ z, 1, w, 0, rw, info )
1178 CALL chkxer( 'CHBEV_2STAGE ', infot, nout, lerr, ok )
1179 infot = 1
1180 CALL chbev_2stage( 'V', 'U', 0, 0, a, 1, x,
1181 $ z, 1, w, 0, rw, info )
1182 CALL chkxer( 'CHBEV_2STAGE ', infot, nout, lerr, ok )
1183 infot = 2
1184 CALL chbev_2stage( 'N', '/', 0, 0, a, 1, x,
1185 $ z, 1, w, 0, rw, info )
1186 CALL chkxer( 'CHBEV_2STAGE ', infot, nout, lerr, ok )
1187 infot = 3
1188 CALL chbev_2stage( 'N', 'U', -1, 0, a, 1, x,
1189 $ z, 1, w, 0, rw, info )
1190 CALL chkxer( 'CHBEV_2STAGE ', infot, nout, lerr, ok )
1191 infot = 4
1192 CALL chbev_2stage( 'N', 'U', 0, -1, a, 1, x,
1193 $ z, 1, w, 0, rw, info )
1194 CALL chkxer( 'CHBEV_2STAGE ', infot, nout, lerr, ok )
1195 infot = 6
1196 CALL chbev_2stage( 'N', 'U', 2, 1, a, 1, x,
1197 $ z, 1, w, 0, rw, info )
1198 CALL chkxer( 'CHBEV_2STAGE ', infot, nout, lerr, ok )
1199 infot = 9
1200 CALL chbev_2stage( 'N', 'U', 2, 0, a, 1, x,
1201 $ z, 0, w, 0, rw, info )
1202 CALL chkxer( 'CHBEV_2STAGE ', infot, nout, lerr, ok )
1203 infot = 11
1204 CALL chbev_2stage( 'N', 'U', 2, 0, a, 1, x,
1205 $ z, 1, w, 0, rw, info )
1206 CALL chkxer( 'CHBEV_2STAGE ', infot, nout, lerr, ok )
1207 nt = nt + 8
1208*
1209* CHBEVX
1210*
1211 srnamt = 'CHBEVX'
1212 infot = 1
1213 CALL chbevx( '/', 'A', 'U', 0, 0, a, 1, q, 1, 0.0, 0.0, 0, 0,
1214 $ 0.0, m, x, z, 1, w, rw, iw, i3, info )
1215 CALL chkxer( 'CHBEVX', infot, nout, lerr, ok )
1216 infot = 2
1217 CALL chbevx( 'V', '/', 'U', 0, 0, a, 1, q, 1, 0.0, 1.0, 1, 0,
1218 $ 0.0, m, x, z, 1, w, rw, iw, i3, info )
1219 CALL chkxer( 'CHBEVX', infot, nout, lerr, ok )
1220 infot = 3
1221 CALL chbevx( 'V', 'A', '/', 0, 0, a, 1, q, 1, 0.0, 0.0, 0, 0,
1222 $ 0.0, m, x, z, 1, w, rw, iw, i3, info )
1223 infot = 4
1224 CALL chbevx( 'V', 'A', 'U', -1, 0, a, 1, q, 1, 0.0, 0.0, 0, 0,
1225 $ 0.0, m, x, z, 1, w, rw, iw, i3, info )
1226 CALL chkxer( 'CHBEVX', infot, nout, lerr, ok )
1227 infot = 5
1228 CALL chbevx( 'V', 'A', 'U', 0, -1, a, 1, q, 1, 0.0, 0.0, 0, 0,
1229 $ 0.0, m, x, z, 1, w, rw, iw, i3, info )
1230 CALL chkxer( 'CHBEVX', infot, nout, lerr, ok )
1231 infot = 7
1232 CALL chbevx( 'V', 'A', 'U', 2, 1, a, 1, q, 2, 0.0, 0.0, 0, 0,
1233 $ 0.0, m, x, z, 2, w, rw, iw, i3, info )
1234 CALL chkxer( 'CHBEVX', infot, nout, lerr, ok )
1235 infot = 9
1236 CALL chbevx( 'V', 'A', 'U', 2, 0, a, 1, q, 1, 0.0, 0.0, 0, 0,
1237 $ 0.0, m, x, z, 2, w, rw, iw, i3, info )
1238 CALL chkxer( 'CHBEVX', infot, nout, lerr, ok )
1239 infot = 11
1240 CALL chbevx( 'V', 'V', 'U', 1, 0, a, 1, q, 1, 0.0, 0.0, 0, 0,
1241 $ 0.0, m, x, z, 1, w, rw, iw, i3, info )
1242 CALL chkxer( 'CHBEVX', infot, nout, lerr, ok )
1243 infot = 12
1244 CALL chbevx( 'V', 'I', 'U', 1, 0, a, 1, q, 1, 0.0, 0.0, 0, 0,
1245 $ 0.0, m, x, z, 1, w, rw, iw, i3, info )
1246 CALL chkxer( 'CHBEVX', infot, nout, lerr, ok )
1247 infot = 13
1248 CALL chbevx( 'V', 'I', 'U', 1, 0, a, 1, q, 1, 0.0, 0.0, 1, 2,
1249 $ 0.0, m, x, z, 1, w, rw, iw, i3, info )
1250 CALL chkxer( 'CHBEVX', infot, nout, lerr, ok )
1251 infot = 18
1252 CALL chbevx( 'V', 'A', 'U', 2, 0, a, 1, q, 2, 0.0, 0.0, 0, 0,
1253 $ 0.0, m, x, z, 1, w, rw, iw, i3, info )
1254 CALL chkxer( 'CHBEVX', infot, nout, lerr, ok )
1255 nt = nt + 11
1256*
1257* CHBEVX_2STAGE
1258*
1259 srnamt = 'CHBEVX_2STAGE'
1260 infot = 1
1261 CALL chbevx_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 chbevx_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( 'CHBEVX_2STAGE', infot, nout, lerr, ok )
1269 infot = 2
1270 CALL chbevx_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( 'CHBEVX_2STAGE', infot, nout, lerr, ok )
1274 infot = 3
1275 CALL chbevx_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 chbevx_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( 'CHBEVX_2STAGE', infot, nout, lerr, ok )
1283 infot = 5
1284 CALL chbevx_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( 'CHBEVX_2STAGE', infot, nout, lerr, ok )
1288 infot = 7
1289 CALL chbevx_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( 'CHBEVX_2STAGE', infot, nout, lerr, ok )
1293* INFOT = 9
1294* CALL CHBEVX_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( 'CHBEVX_2STAGE', INFOT, NOUT, LERR, OK )
1298 infot = 11
1299 CALL chbevx_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( 'CHBEVX_2STAGE', infot, nout, lerr, ok )
1303 infot = 12
1304 CALL chbevx_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( 'CHBEVX_2STAGE', infot, nout, lerr, ok )
1308 infot = 13
1309 CALL chbevx_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( 'CHBEVX_2STAGE', infot, nout, lerr, ok )
1313 infot = 18
1314 CALL chbevx_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( 'CHBEVX_2STAGE', infot, nout, lerr, ok )
1318 infot = 20
1319 CALL chbevx_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( 'CHBEVX_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 CERRST
1342*
chetrd_he2hb
subroutine chetrd_he2hb(uplo, n, kd, a, lda, ab, ldab, tau, work, lwork, info)
CHETRD_HE2HB
Definition chetrd_he2hb.f:243
cunmtr
subroutine cunmtr(side, uplo, trans, m, n, a, lda, tau, c, ldc, work, lwork, info)
CUNMTR
Definition cunmtr.f:172
cupmtr
subroutine cupmtr(side, uplo, trans, m, n, ap, tau, c, ldc, work, info)
CUPMTR
Definition cupmtr.f:150

◆ cget02()

subroutine cget02 ( character trans,
integer m,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real, dimension( * ) rwork,
real resid )

CGET02

Purpose:
!>
!> CGET02 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 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 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 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 REAL array, dimension (M)
!>
[out]RESID
!>          RESID is REAL
!>          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 cget02.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 REAL RESID
143* ..
144* .. Array Arguments ..
145 REAL RWORK( * )
146 COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * )
147* ..
148*
149* =====================================================================
150*
151* .. Parameters ..
152 REAL ZERO, ONE
153 parameter( zero = 0.0e+0, one = 1.0e+0 )
154 COMPLEX CONE
155 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
156* ..
157* .. Local Scalars ..
158 INTEGER J, N1, N2
159 REAL ANORM, BNORM, EPS, XNORM
160* ..
161* .. External Functions ..
162 LOGICAL LSAME
163 REAL CLANGE, SCASUM, SLAMCH
164 EXTERNAL lsame, clange, scasum, slamch
165* ..
166* .. External Subroutines ..
167 EXTERNAL cgemm
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 = slamch( 'Epsilon' )
192 IF( lsame( trans, 'N' ) ) THEN
193 anorm = clange( '1', m, n, a, lda, rwork )
194 ELSE
195 anorm = clange( '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 cgemm( 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 = scasum( n1, b( 1, j ), 1 )
213 xnorm = scasum( 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 CGET02
224*

◆ cget10()

subroutine cget10 ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real result )

CGET10

Purpose:
!>
!> CGET10 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 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 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 array, dimension (M)
!>
[out]RWORK
!>          RWORK is COMPLEX array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL
!>          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 cget10.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 REAL RESULT
107* ..
108* .. Array Arguments ..
109 REAL RWORK( * )
110 COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
111* ..
112*
113* =====================================================================
114*
115* .. Parameters ..
116 REAL ONE, ZERO
117 parameter( one = 1.0e+0, zero = 0.0e+0 )
118* ..
119* .. Local Scalars ..
120 INTEGER J
121 REAL ANORM, EPS, UNFL, WNORM
122* ..
123* .. External Functions ..
124 REAL SCASUM, SLAMCH, CLANGE
125 EXTERNAL scasum, slamch, clange
126* ..
127* .. External Subroutines ..
128 EXTERNAL caxpy, ccopy
129* ..
130* .. Intrinsic Functions ..
131 INTRINSIC max, min, real
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 = slamch( 'Safe minimum' )
143 eps = slamch( 'Precision' )
144*
145 wnorm = zero
146 DO 10 j = 1, n
147 CALL ccopy( m, a( 1, j ), 1, work, 1 )
148 CALL caxpy( m, cmplx( -one ), b( 1, j ), 1, work, 1 )
149 wnorm = max( wnorm, scasum( n, work, 1 ) )
150 10 CONTINUE
151*
152 anorm = max( clange( '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, real( m ) ) / ( m*eps )
161 END IF
162 END IF
163*
164 RETURN
165*
166* End of CGET10
167*
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
Definition caxpy.f:88

◆ cget22()

subroutine cget22 ( character transa,
character transe,
character transw,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( lde, * ) e,
integer lde,
complex, dimension( * ) w,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real, dimension( 2 ) result )

CGET22

Purpose:
!>
!> CGET22 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 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 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 array, dimension (N)
!>          The eigenvalues of A.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (N*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESULT
!>          RESULT is REAL 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 cget22.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 REAL RESULT( 2 ), RWORK( * )
155 COMPLEX A( LDA, * ), E( LDE, * ), W( * ), WORK( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 REAL ZERO, ONE
162 parameter( zero = 0.0e+0, one = 1.0e+0 )
163 COMPLEX CZERO, CONE
164 parameter( czero = ( 0.0e+0, 0.0e+0 ),
165 $ cone = ( 1.0e+0, 0.0e+0 ) )
166* ..
167* .. Local Scalars ..
168 CHARACTER NORMA, NORME
169 INTEGER ITRNSE, ITRNSW, J, JCOL, JOFF, JROW, JVEC
170 REAL ANORM, ENORM, ENRMAX, ENRMIN, ERRNRM, TEMP1,
171 $ ULP, UNFL
172 COMPLEX WTEMP
173* ..
174* .. External Functions ..
175 LOGICAL LSAME
176 REAL CLANGE, SLAMCH
177 EXTERNAL lsame, clange, slamch
178* ..
179* .. External Subroutines ..
180 EXTERNAL cgemm, claset
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC abs, aimag, conjg, max, min, real
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 = slamch( 'Safe minimum' )
195 ulp = slamch( '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( real( e( j, jvec ) ) )+
227 $ abs( aimag( 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( real( e( jvec, j ) ) )+
241 $ abs( aimag( 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( clange( norma, n, n, a, lda, rwork ), unfl )
254*
255* Norm of E:
256*
257 enorm = max( clange( norme, n, n, e, lde, rwork ), ulp )
258*
259* Norm of error:
260*
261* Error = AE - EW
262*
263 CALL claset( '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 = conjg( 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 ) = conjg( e( jcol, jrow ) )*wtemp
284 90 CONTINUE
285 END IF
286 joff = joff + n
287 100 CONTINUE
288*
289 CALL cgemm( transa, transe, n, n, n, cone, a, lda, e, lde, -cone,
290 $ work, n )
291*
292 errnrm = clange( '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 $ ( real( n )*ulp )
310*
311 RETURN
312*
313* End of CGET22
314*

◆ cget23()

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

CGET23

Purpose:
!>
!>    CGET23  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 CGEEVX 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 CGEEVX 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 REAL
!>          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 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 array, dimension (LDA,N)
!>          Another copy of the test matrix A, modified by CGEEVX.
!>
[out]W
!>          W is COMPLEX array, dimension (N)
!>          Contains the eigenvalues of A.
!>
[out]W1
!>          W1 is COMPLEX array, dimension (N)
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when CGEEVX only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is COMPLEX 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 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 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 REAL array, dimension (N)
!>          RCONDV holds the computed reciprocal condition numbers
!>          for eigenvectors.
!>
[out]RCNDV1
!>          RCNDV1 is REAL array, dimension (N)
!>          RCNDV1 holds more computed reciprocal condition numbers
!>          for eigenvectors.
!>
[in]RCDVIN
!>          RCDVIN is REAL array, dimension (N)
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition numbers for eigenvectors to be compared with
!>          RCONDV.
!>
[out]RCONDE
!>          RCONDE is REAL array, dimension (N)
!>          RCONDE holds the computed reciprocal condition numbers
!>          for eigenvalues.
!>
[out]RCNDE1
!>          RCNDE1 is REAL array, dimension (N)
!>          RCNDE1 holds more computed reciprocal condition numbers
!>          for eigenvalues.
!>
[in]RCDEIN
!>          RCDEIN is REAL array, dimension (N)
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition numbers for eigenvalues to be compared with
!>          RCONDE.
!>
[out]SCALE
!>          SCALE is REAL array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]SCALE1
!>          SCALE1 is REAL array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]RESULT
!>          RESULT is REAL 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 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 REAL array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0,  successful exit.
!>          If <0, input parameter -INFO had an incorrect value.
!>          If >0, CGEEVX 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 cget23.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 REAL THRESH
379* ..
380* .. Array Arguments ..
381 INTEGER ISEED( 4 )
382 REAL RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
383 $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
384 $ RESULT( 11 ), RWORK( * ), SCALE( * ),
385 $ SCALE1( * )
386 COMPLEX A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
387 $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ),
388 $ WORK( * )
389* ..
390*
391* =====================================================================
392*
393* .. Parameters ..
394 REAL ZERO, ONE, TWO
395 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
396 REAL EPSIN
397 parameter( epsin = 5.9605e-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 REAL ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN,
405 $ ULP, ULPINV, V, VMAX, VMX, VRICMP, VRIMIN,
406 $ VRMX, VTST
407 COMPLEX CTMP
408* ..
409* .. Local Arrays ..
410 CHARACTER SENS( 2 )
411 REAL RES( 2 )
412 COMPLEX CDUM( 1 )
413* ..
414* .. External Functions ..
415 LOGICAL LSAME
416 REAL SCNRM2, SLAMCH
417 EXTERNAL lsame, scnrm2, slamch
418* ..
419* .. External Subroutines ..
420 EXTERNAL cgeevx, cget22, clacpy, xerbla
421* ..
422* .. Intrinsic Functions ..
423 INTRINSIC abs, aimag, max, min, real
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( 'CGET23', -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 = slamch( 'Precision' )
475 smlnum = slamch( '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 clacpy( 'F', n, n, a, lda, h, lda )
488 CALL cgeevx( 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 )'CGEEVX1', iinfo, n, jtype,
495 $ balanc, iseed
496 ELSE
497 WRITE( nounit, fmt = 9999 )'CGEEVX1', iinfo, n, iseed( 1 )
498 END IF
499 info = abs( iinfo )
500 RETURN
501 END IF
502*
503* Do Test (1)
504*
505 CALL cget22( '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 cget22( '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 = scnrm2( 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( aimag( vr( jj, j ) ).EQ.zero .AND.
528 $ abs( real( vr( jj, j ) ) ).GT.vrmx )
529 $ vrmx = abs( real( 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 = scnrm2( 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( aimag( vl( jj, j ) ).EQ.zero .AND.
548 $ abs( real( vl( jj, j ) ) ).GT.vrmx )
549 $ vrmx = abs( real( 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 clacpy( 'F', n, n, a, lda, h, lda )
564 CALL cgeevx( 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 )'CGEEVX2', iinfo, n, jtype,
571 $ balanc, iseed
572 ELSE
573 WRITE( nounit, fmt = 9999 )'CGEEVX2', 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 clacpy( 'F', n, n, a, lda, h, lda )
614 CALL cgeevx( 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 )'CGEEVX3', iinfo, n, jtype,
621 $ balanc, iseed
622 ELSE
623 WRITE( nounit, fmt = 9999 )'CGEEVX3', 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 clacpy( 'F', n, n, a, lda, h, lda )
673 CALL cgeevx( 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 )'CGEEVX4', iinfo, n, jtype,
680 $ balanc, iseed
681 ELSE
682 WRITE( nounit, fmt = 9999 )'CGEEVX4', 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 clacpy( 'F', n, n, a, lda, h, lda )
737 CALL cgeevx( '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 )'CGEEVX5', 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 = real( w( i ) )
754 ELSE
755 vrimin = aimag( w( i ) )
756 END IF
757 DO 210 j = i + 1, n
758 IF( isrt.EQ.0 ) THEN
759 vricmp = real( w( j ) )
760 ELSE
761 vricmp = aimag( 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( real( 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( ' CGET23: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
849 $ i6, ', INPUT EXAMPLE NUMBER = ', i4 )
850 9998 FORMAT( ' CGET23: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
851 $ i6, ', JTYPE=', i6, ', BALANC = ', a, ', ISEED=(',
852 $ 3( i5, ',' ), i5, ')' )
853*
854 RETURN
855*
856* End of CGET23
857*
comp
int comp(int a, int b)
Definition set_surface_lines.cpp:102

◆ cget24()

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

CGET24

Purpose:
!>
!>    CGET24 checks the nonsymmetric eigenvalue (Schur form) problem
!>    expert driver CGEESX.
!>
!>    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 CGEESX 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 CGEESX 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 REAL
!>          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 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 array, dimension (LDA, N)
!>          Another copy of the test matrix A, modified by CGEESX.
!>
[out]HT
!>          HT is COMPLEX array, dimension (LDA, N)
!>          Yet another copy of the test matrix A, modified by CGEESX.
!>
[out]W
!>          W is COMPLEX array, dimension (N)
!>          The computed eigenvalues of A.
!>
[out]WT
!>          WT is COMPLEX array, dimension (N)
!>          Like W, this array contains the eigenvalues of A,
!>          but those computed when CGEESX only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]WTMP
!>          WTMP is COMPLEX 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 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 array, dimension (LDVS, N)
!>          VS1 holds another copy of the computed Schur vectors.
!>
[in]RCDEIN
!>          RCDEIN is REAL
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition number for the average of selected eigenvalues.
!>
[in]RCDVIN
!>          RCDVIN is REAL
!>          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 REAL 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 array, dimension (2*N*N)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK to be passed to CGEESX. This
!>          must be at least 2*N, and N*(N+1)/2 if tests 14--16 are to
!>          be performed.
!>
[out]RWORK
!>          RWORK is REAL 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, CGEESX 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 cget24.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 REAL RCDEIN, RCDVIN, THRESH
345* ..
346* .. Array Arguments ..
347 LOGICAL BWORK( * )
348 INTEGER ISEED( 4 ), ISLCT( * )
349 REAL RESULT( 17 ), RWORK( * )
350 COMPLEX A( LDA, * ), H( LDA, * ), HT( LDA, * ),
351 $ VS( LDVS, * ), VS1( LDVS, * ), W( * ),
352 $ WORK( * ), WT( * ), WTMP( * )
353* ..
354*
355* =====================================================================
356*
357* .. Parameters ..
358 COMPLEX CZERO, CONE
359 parameter( czero = ( 0.0e+0, 0.0e+0 ),
360 $ cone = ( 1.0e+0, 0.0e+0 ) )
361 REAL ZERO, ONE
362 parameter( zero = 0.0e+0, one = 1.0e+0 )
363 REAL EPSIN
364 parameter( epsin = 5.9605e-8 )
365* ..
366* .. Local Scalars ..
367 CHARACTER SORT
368 INTEGER I, IINFO, ISORT, ITMP, J, KMIN, KNTEIG, RSUB,
369 $ SDIM, SDIM1
370 REAL ANORM, EPS, RCNDE1, RCNDV1, RCONDE, RCONDV,
371 $ SMLNUM, TOL, TOLIN, ULP, ULPINV, V, VRICMP,
372 $ VRIMIN, WNORM
373 COMPLEX CTMP
374* ..
375* .. Local Arrays ..
376 INTEGER IPNT( 20 )
377* ..
378* .. External Functions ..
379 LOGICAL CSLECT
380 REAL CLANGE, SLAMCH
381 EXTERNAL cslect, clange, slamch
382* ..
383* .. External Subroutines ..
384 EXTERNAL ccopy, cgeesx, cgemm, clacpy, cunt01, xerbla
385* ..
386* .. Intrinsic Functions ..
387 INTRINSIC abs, aimag, max, min, real
388* ..
389* .. Arrays in Common ..
390 LOGICAL SELVAL( 20 )
391 REAL 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( 'CGET24', -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 = slamch( 'Safe minimum' )
435 ulp = slamch( '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 clacpy( 'F', n, n, a, lda, h, lda )
453 CALL cgeesx( 'V', sort, cslect, '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 )'CGEESX1', iinfo, n, jtype,
460 $ iseed
461 ELSE
462 WRITE( nounit, fmt = 9999 )'CGEESX1', 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 ccopy( 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 clacpy( ' ', n, n, a, lda, vs1, ldvs )
487*
488* Compute Q*H and store in HT.
489*
490 CALL cgemm( '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 cgemm( 'No transpose', 'Conjugate transpose', n, n, n,
496 $ -cone, ht, lda, vs, ldvs, cone, vs1, ldvs )
497*
498 anorm = max( clange( '1', n, n, a, lda, rwork ), smlnum )
499 wnorm = clange( '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, real( 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 cunt01( '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 clacpy( 'F', n, n, a, lda, ht, lda )
529 CALL cgeesx( 'N', sort, cslect, '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 )'CGEESX2', iinfo, n, jtype,
536 $ iseed
537 ELSE
538 WRITE( nounit, fmt = 9999 )'CGEESX2', 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( cslect( w( i ) ) )
568 $ knteig = knteig + 1
569 IF( i.LT.n ) THEN
570 IF( cslect( w( i+1 ) ) .AND.
571 $ ( .NOT.cslect( 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 clacpy( 'F', n, n, a, lda, ht, lda )
591 CALL cgeesx( 'V', sort, cslect, '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 )'CGEESX3', iinfo, n, jtype,
599 $ iseed
600 ELSE
601 WRITE( nounit, fmt = 9999 )'CGEESX3', 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 clacpy( 'F', n, n, a, lda, ht, lda )
626 CALL cgeesx( 'N', sort, cslect, '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 )'CGEESX4', iinfo, n, jtype,
634 $ iseed
635 ELSE
636 WRITE( nounit, fmt = 9999 )'CGEESX4', 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 clacpy( 'F', n, n, a, lda, ht, lda )
668 CALL cgeesx( 'V', sort, cslect, '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 )'CGEESX5', iinfo, n, jtype,
675 $ iseed
676 ELSE
677 WRITE( nounit, fmt = 9999 )'CGEESX5', 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 clacpy( 'F', n, n, a, lda, ht, lda )
707 CALL cgeesx( 'N', sort, cslect, '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 )'CGEESX6', iinfo, n, jtype,
714 $ iseed
715 ELSE
716 WRITE( nounit, fmt = 9999 )'CGEESX6', 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 clacpy( 'F', n, n, a, lda, ht, lda )
746 CALL cgeesx( 'V', sort, cslect, '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 )'CGEESX7', iinfo, n, jtype,
753 $ iseed
754 ELSE
755 WRITE( nounit, fmt = 9999 )'CGEESX7', 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 clacpy( 'F', n, n, a, lda, ht, lda )
785 CALL cgeesx( 'N', sort, cslect, '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 )'CGEESX8', iinfo, n, jtype,
792 $ iseed
793 ELSE
794 WRITE( nounit, fmt = 9999 )'CGEESX8', 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 CSLECT 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 ) = real( wtmp( i ) )
841 selwi( i ) = aimag( wtmp( i ) )
842 230 CONTINUE
843 DO 250 i = 1, n - 1
844 kmin = i
845 IF( isrt.EQ.0 ) THEN
846 vrimin = real( wtmp( i ) )
847 ELSE
848 vrimin = aimag( wtmp( i ) )
849 END IF
850 DO 240 j = i + 1, n
851 IF( isrt.EQ.0 ) THEN
852 vricmp = real( wtmp( j ) )
853 ELSE
854 vricmp = aimag( 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 clacpy( 'F', n, n, a, lda, ht, lda )
875 CALL cgeesx( 'N', 'S', cslect, '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 )'CGEESX9', 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 = clange( '1', n, n, a, lda, rwork )
890 v = max( real( 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( ' CGET24: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
949 $ i6, ', INPUT EXAMPLE NUMBER = ', i4 )
950 9998 FORMAT( ' CGET24: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
951 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
952*
953 RETURN
954*
955* End of CGET24
956*

◆ cget35()

subroutine cget35 ( real rmax,
integer lmax,
integer ninfo,
integer knt,
integer nin )

CGET35

Purpose:
!>
!> CGET35 tests CTRSYL, 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 REAL
!>          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 cget35.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 REAL RMAX
92* ..
93*
94* =====================================================================
95*
96* .. Parameters ..
97 INTEGER LDT
98 parameter( ldt = 10 )
99 REAL ZERO, ONE, TWO
100 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
101 REAL LARGE
102 parameter( large = 1.0e6 )
103 COMPLEX CONE
104 parameter( cone = 1.0e0 )
105* ..
106* .. Local Scalars ..
107 CHARACTER TRANA, TRANB
108 INTEGER I, IMLA, IMLAD, IMLB, IMLC, INFO, ISGN, ITRANA,
109 $ ITRANB, J, M, N
110 REAL BIGNUM, EPS, RES, RES1, SCALE, SMLNUM, TNRM,
111 $ XNRM
112 COMPLEX RMUL
113* ..
114* .. Local Arrays ..
115 REAL DUM( 1 ), VM1( 3 ), VM2( 3 )
116 COMPLEX 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 REAL CLANGE, SLAMCH
122 EXTERNAL clange, slamch
123* ..
124* .. External Subroutines ..
125 EXTERNAL cgemm, ctrsyl
126* ..
127* .. Intrinsic Functions ..
128 INTRINSIC abs, max, real, sqrt
129* ..
130* .. Executable Statements ..
131*
132* Get machine parameters
133*
134 eps = slamch( 'P' )
135 smlnum = slamch( 'S' ) / eps
136 bignum = one / smlnum
137 CALL slabad( 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 ctrsyl( 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 = clange( '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 cgemm( trana, 'N', m, n, m, rmul, a,
221 $ ldt, c, ldt, -scale*rmul, csav,
222 $ ldt )
223 CALL cgemm( 'N', tranb, m, n, n,
224 $ real( isgn )*rmul, c, ldt, b,
225 $ ldt, cone, csav, ldt )
226 res1 = clange( '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 CGET35
243*

◆ cget36()

subroutine cget36 ( real rmax,
integer lmax,
integer ninfo,
integer knt,
integer nin )

CGET36

Purpose:
!>
!> CGET36 tests CTREXC, a routine for reordering diagonal entries of a
!> matrix in complex Schur form. Thus, CLAEXC 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 REAL
!>          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 cget36.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 REAL RMAX
93* ..
94*
95* =====================================================================
96*
97* .. Parameters ..
98 REAL ZERO, ONE
99 parameter( zero = 0.0e+0, one = 1.0e+0 )
100 COMPLEX CZERO, CONE
101 parameter( czero = ( 0.0e+0, 0.0e+0 ),
102 $ cone = ( 1.0e+0, 0.0e+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 REAL EPS, RES
109 COMPLEX CTEMP
110* ..
111* .. Local Arrays ..
112 REAL RESULT( 2 ), RWORK( LDT )
113 COMPLEX DIAG( LDT ), Q( LDT, LDT ), T1( LDT, LDT ),
114 $ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
115* ..
116* .. External Functions ..
117 REAL SLAMCH
118 EXTERNAL slamch
119* ..
120* .. External Subroutines ..
121 EXTERNAL ccopy, chst01, clacpy, claset, ctrexc
122* ..
123* .. Executable Statements ..
124*
125 eps = slamch( '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 clacpy( 'F', n, n, tmp, ldt, t1, ldt )
142 CALL clacpy( 'F', n, n, tmp, ldt, t2, ldt )
143 res = zero
144*
145* Test without accumulating Q
146*
147 CALL claset( 'Full', n, n, czero, cone, q, ldt )
148 CALL ctrexc( '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 claset( 'Full', n, n, czero, cone, q, ldt )
161 CALL ctrexc( '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 ccopy( 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 chst01( 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 CGET36
218*

◆ cget37()

subroutine cget37 ( real, dimension( 3 ) rmax,
integer, dimension( 3 ) lmax,
integer, dimension( 3 ) ninfo,
integer knt,
integer nin )

CGET37

Purpose:
!>
!> CGET37 tests CTRSNA, 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 REAL array, dimension (3)
!>          Value of the largest test ratio.
!>          RMAX(1) = largest ratio comparing different calls to CTRSNA
!>          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 CGEHRD returns INFO nonzero on example i, LMAX(1)=i
!>          If CHSEQR returns INFO nonzero on example i, LMAX(2)=i
!>          If CTRSNA returns INFO nonzero on example i, LMAX(3)=i
!>
[out]NINFO
!>          NINFO is INTEGER array, dimension (3)
!>          NINFO(1) = No. of times CGEHRD returned INFO nonzero
!>          NINFO(2) = No. of times CHSEQR returned INFO nonzero
!>          NINFO(3) = No. of times CTRSNA 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 cget37.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 REAL RMAX( 3 )
101* ..
102*
103* =====================================================================
104*
105* .. Parameters ..
106 REAL ZERO, ONE, TWO
107 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
108 REAL EPSIN
109 parameter( epsin = 5.9605e-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 REAL 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 REAL 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 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 REAL CLANGE, SLAMCH
131 EXTERNAL clange, slamch
132* ..
133* .. External Subroutines ..
134 EXTERNAL ccopy, cgehrd, chseqr, clacpy, csscal, ctrevc,
135 $ ctrsna, scopy, slabad, sscal
136* ..
137* .. Intrinsic Functions ..
138 INTRINSIC aimag, max, real, sqrt
139* ..
140* .. Executable Statements ..
141*
142 eps = slamch( 'P' )
143 smlnum = slamch( 'S' ) / eps
144 bignum = one / smlnum
145 CALL slabad( 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 = clange( 'M', n, n, tmp, ldt, rwork )
179 DO 260 iscl = 1, 3
180*
181* Scale input matrix
182*
183 knt = knt + 1
184 CALL clacpy( 'F', n, n, tmp, ldt, t, ldt )
185 vmul = val( iscl )
186 DO 40 i = 1, n
187 CALL csscal( 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 cgehrd( 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 chseqr( '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 ctrevc( 'B', 'A', SELECT, n, t, ldt, le, ldt, re, ldt, n,
223 $ m, work, rwork, info )
224*
225* Compute condition numbers
226*
227 CALL ctrsna( '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 ccopy( 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 ) = real( w( i ) )
245 80 CONTINUE
246 ELSE
247*
248* Sort by increasing imaginary part
249*
250 DO 90 i = 1, n
251 wsrt( i ) = aimag( w( i ) )
252 90 CONTINUE
253 END IF
254 CALL scopy( n, s, 1, stmp, 1 )
255 CALL scopy( n, sep, 1, septmp, 1 )
256 CALL sscal( 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*real( 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.real( 2*n )*eps .AND. stmp( i ).LE.
355 $ real( 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 scopy( n, dum, 0, stmp, 1 )
404 CALL scopy( n, dum, 0, septmp, 1 )
405 CALL ctrsna( '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 scopy( n, dum, 0, stmp, 1 )
422 CALL scopy( n, dum, 0, septmp, 1 )
423 CALL ctrsna( '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 scopy( n, dum, 0, stmp, 1 )
443 CALL scopy( n, dum, 0, septmp, 1 )
444 CALL ctrsna( '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 scopy( n, dum, 0, stmp, 1 )
461 CALL scopy( n, dum, 0, septmp, 1 )
462 CALL ctrsna( '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 scopy( n, dum, 0, stmp, 1 )
479 CALL scopy( n, dum, 0, septmp, 1 )
480 CALL ctrsna( '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 ccopy( n, re( 1, 2 ), 1, re( 1, 1 ), 1 )
510 CALL ccopy( 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 ccopy( n, re( 1, n-1 ), 1, re( 1, 2 ), 1 )
517 CALL ccopy( n, le( 1, n-1 ), 1, le( 1, 2 ), 1 )
518 END IF
519*
520* Compute all selected condition numbers
521*
522 CALL scopy( icmp, dum, 0, stmp, 1 )
523 CALL scopy( icmp, dum, 0, septmp, 1 )
524 CALL ctrsna( '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 scopy( icmp, dum, 0, stmp, 1 )
542 CALL scopy( icmp, dum, 0, septmp, 1 )
543 CALL ctrsna( '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 scopy( icmp, dum, 0, stmp, 1 )
561 CALL scopy( icmp, dum, 0, septmp, 1 )
562 CALL ctrsna( '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 CGET37
585*
csscal
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79

◆ cget38()

subroutine cget38 ( real, dimension( 3 ) rmax,
integer, dimension( 3 ) lmax,
integer, dimension( 3 ) ninfo,
integer knt,
integer nin )

CGET38

Purpose:
!>
!> CGET38 tests CTRSEN, 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 REAL array, dimension (3)
!>          Values of the largest test ratios.
!>          RMAX(1) = largest residuals from CHST01 or comparing
!>                    different calls to CTRSEN
!>          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 CGEHRD returns INFO nonzero on example i, LMAX(1)=i
!>          If CHSEQR returns INFO nonzero on example i, LMAX(2)=i
!>          If CTRSEN returns INFO nonzero on example i, LMAX(3)=i
!>
[out]NINFO
!>          NINFO is INTEGER array, dimension (3)
!>          NINFO(1) = No. of times CGEHRD returned INFO nonzero
!>          NINFO(2) = No. of times CHSEQR returned INFO nonzero
!>          NINFO(3) = No. of times CTRSEN 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 cget38.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 REAL RMAX( 3 )
102* ..
103*
104* =====================================================================
105*
106* .. Parameters ..
107 INTEGER LDT, LWORK
108 parameter( ldt = 20, lwork = 2*ldt*( 10+ldt ) )
109 REAL ZERO, ONE, TWO
110 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0 )
111 REAL EPSIN
112 parameter( epsin = 5.9605e-8 )
113 COMPLEX CZERO
114 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
115* ..
116* .. Local Scalars ..
117 INTEGER I, INFO, ISCL, ISRT, ITMP, J, KMIN, M, N, NDIM
118 REAL 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 REAL RESULT( 2 ), RWORK( LDT ), VAL( 3 ),
126 $ WSRT( LDT )
127 COMPLEX 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 REAL CLANGE, SLAMCH
135 EXTERNAL clange, slamch
136* ..
137* .. External Subroutines ..
138 EXTERNAL cgehrd, chseqr, chst01, clacpy, csscal, ctrsen,
139 $ cunghr, slabad
140* ..
141* .. Intrinsic Functions ..
142 INTRINSIC aimag, max, real, sqrt
143* ..
144* .. Executable Statements ..
145*
146 eps = slamch( 'P' )
147 smlnum = slamch( 'S' ) / eps
148 bignum = one / smlnum
149 CALL slabad( 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 = clange( 'M', n, n, tmp, ldt, rwork )
183 DO 200 iscl = 1, 3
184*
185* Scale input matrix
186*
187 knt = knt + 1
188 CALL clacpy( 'F', n, n, tmp, ldt, t, ldt )
189 vmul = val( iscl )
190 DO 30 i = 1, n
191 CALL csscal( n, vmul, t( 1, i ), 1 )
192 30 CONTINUE
193 IF( tnrm.EQ.zero )
194 $ vmul = one
195 CALL clacpy( 'F', n, n, t, ldt, tsav, ldt )
196*
197* Compute Schur form
198*
199 CALL cgehrd( 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 clacpy( 'L', n, n, t, ldt, q, ldt )
210 CALL cunghr( 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 chseqr( '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 ) = real( w( i ) )
237 70 CONTINUE
238 ELSE
239 DO 80 i = 1, n
240 wsrt( i ) = aimag( 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 clacpy( 'F', n, n, q, ldt, qsav, ldt )
265 CALL clacpy( 'F', n, n, t, ldt, tsav1, ldt )
266 CALL ctrsen( '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 chst01( 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*real( 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.real( 2*n )*eps .AND. stmp.LE.real( 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 clacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
403 CALL clacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
404 septmp = -one
405 stmp = -one
406 CALL ctrsen( '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 clacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
430 CALL clacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
431 septmp = -one
432 stmp = -one
433 CALL ctrsen( '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 clacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
457 CALL clacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
458 septmp = -one
459 stmp = -one
460 CALL ctrsen( '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 clacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
484 CALL clacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
485 septmp = -one
486 stmp = -one
487 CALL ctrsen( '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 CGET38
515*

◆ cget51()

subroutine cget51 ( integer itype,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldu, * ) u,
integer ldu,
complex, dimension( ldv, * ) v,
integer ldv,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real result )

CGET51

Purpose:
!>
!>      CGET51  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, CGET51 does nothing.
!>          It must be at least zero.
!>
[in]A
!>          A is COMPLEX 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 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 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 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 array, dimension (2*N**2)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESULT
!>          RESULT is REAL
!>          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 cget51.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 REAL RESULT
163* ..
164* .. Array Arguments ..
165 REAL RWORK( * )
166 COMPLEX A( LDA, * ), B( LDB, * ), U( LDU, * ),
167 $ V( LDV, * ), WORK( * )
168* ..
169*
170* =====================================================================
171*
172* .. Parameters ..
173 REAL ZERO, ONE, TEN
174 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 10.0e+0 )
175 COMPLEX CZERO, CONE
176 parameter( czero = ( 0.0e+0, 0.0e+0 ),
177 $ cone = ( 1.0e+0, 0.0e+0 ) )
178* ..
179* .. Local Scalars ..
180 INTEGER JCOL, JDIAG, JROW
181 REAL ANORM, ULP, UNFL, WNORM
182* ..
183* .. External Functions ..
184 REAL CLANGE, SLAMCH
185 EXTERNAL clange, slamch
186* ..
187* .. External Subroutines ..
188 EXTERNAL cgemm, clacpy
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC max, min, real
192* ..
193* .. Executable Statements ..
194*
195 result = zero
196 IF( n.LE.0 )
197 $ RETURN
198*
199* Constants
200*
201 unfl = slamch( 'Safe minimum' )
202 ulp = slamch( 'Epsilon' )*slamch( '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( clange( '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 clacpy( ' ', n, n, a, lda, work, n )
222 CALL cgemm( 'N', 'N', n, n, n, cone, u, ldu, b, ldb, czero,
223 $ work( n**2+1 ), n )
224*
225 CALL cgemm( '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 clacpy( ' ', 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 = clange( '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, real( 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 cgemm( '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( clange( '1', n, n, work, n, rwork ),
271 $ real( n ) ) / ( n*ulp )
272 END IF
273*
274 RETURN
275*
276* End of CGET51
277*

◆ cget52()

subroutine cget52 ( logical left,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( lde, * ) e,
integer lde,
complex, dimension( * ) alpha,
complex, dimension( * ) beta,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real, dimension( 2 ) result )

CGET52

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

◆ cget54()

subroutine cget54 ( integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( lds, * ) s,
integer lds,
complex, dimension( ldt, * ) t,
integer ldt,
complex, dimension( ldu, * ) u,
integer ldu,
complex, dimension( ldv, * ) v,
integer ldv,
complex, dimension( * ) work,
real result )

CGET54

Purpose:
!>
!> CGET54 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, SGET54 does nothing.
!>          It must be at least zero.
!>
[in]A
!>          A is COMPLEX 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 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 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 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 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 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 array, dimension (3*N**2)
!>
[out]RESULT
!>          RESULT is REAL
!>          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 cget54.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 REAL RESULT
164* ..
165* .. Array Arguments ..
166 COMPLEX A( LDA, * ), B( LDB, * ), S( LDS, * ),
167 $ T( LDT, * ), U( LDU, * ), V( LDV, * ),
168 $ WORK( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ZERO, ONE
175 parameter( zero = 0.0e+0, one = 1.0e+0 )
176 COMPLEX CZERO, CONE
177 parameter( czero = ( 0.0e+0, 0.0e+0 ),
178 $ cone = ( 1.0e+0, 0.0e+0 ) )
179* ..
180* .. Local Scalars ..
181 REAL ABNORM, ULP, UNFL, WNORM
182* ..
183* .. Local Arrays ..
184 REAL DUM( 1 )
185* ..
186* .. External Functions ..
187 REAL CLANGE, SLAMCH
188 EXTERNAL clange, slamch
189* ..
190* .. External Subroutines ..
191 EXTERNAL cgemm, clacpy
192* ..
193* .. Intrinsic Functions ..
194 INTRINSIC max, min, real
195* ..
196* .. Executable Statements ..
197*
198 result = zero
199 IF( n.LE.0 )
200 $ RETURN
201*
202* Constants
203*
204 unfl = slamch( 'Safe minimum' )
205 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
206*
207* compute the norm of (A,B)
208*
209 CALL clacpy( 'Full', n, n, a, lda, work, n )
210 CALL clacpy( 'Full', n, n, b, ldb, work( n*n+1 ), n )
211 abnorm = max( clange( '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 clacpy( ' ', n, n, a, lda, work, n )
216 CALL cgemm( 'N', 'N', n, n, n, cone, u, ldu, s, lds, czero,
217 $ work( n*n+1 ), n )
218*
219 CALL cgemm( '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 clacpy( ' ', n, n, b, ldb, work( n*n+1 ), n )
225 CALL cgemm( 'N', 'N', n, n, n, cone, u, ldu, t, ldt, czero,
226 $ work( 2*n*n+1 ), n )
227*
228 CALL cgemm( '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 = clange( '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, real( 2*n ) ) / ( 2*n*ulp )
242 END IF
243 END IF
244*
245 RETURN
246*
247* End of CGET54
248*

◆ cglmts()

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

CGLMTS

Purpose:
!>
!> CGLMTS tests CGGGLM - 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 array, dimension (LDA,M)
!>          The N-by-M matrix A.
!>
[out]AF
!>          AF is COMPLEX 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 array, dimension (LDB,P)
!>          The N-by-P matrix A.
!>
[out]BF
!>          BF is COMPLEX 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 array, dimension( N )
!>          On input, the left hand side of the GLM.
!>
[out]DF
!>          DF is COMPLEX array, dimension( N )
!>
[out]X
!>          X is COMPLEX array, dimension( M )
!>          solution vector X in the GLM problem.
!>
[out]U
!>          U is COMPLEX array, dimension( P )
!>          solution vector U in the GLM problem.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL
!>          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 148 of file cglmts.f.

150*
151* -- LAPACK test routine --
152* -- LAPACK is a software package provided by Univ. of Tennessee, --
153* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
154*
155* .. Scalar Arguments ..
156 INTEGER LDA, LDB, LWORK, M, P, N
157 REAL RESULT
158* ..
159* .. Array Arguments ..
160 REAL RWORK( * )
161 COMPLEX A( LDA, * ), AF( LDA, * ), B( LDB, * ),
162 $ BF( LDB, * ), D( * ), DF( * ), U( * ),
163 $ WORK( LWORK ), X( * )
164*
165* ====================================================================
166*
167* .. Parameters ..
168 REAL ZERO
169 parameter( zero = 0.0e+0 )
170 COMPLEX CONE
171 parameter( cone = 1.0e+0 )
172* ..
173* .. Local Scalars ..
174 INTEGER INFO
175 REAL ANORM, BNORM, EPS, XNORM, YNORM, DNORM, UNFL
176* ..
177* .. External Functions ..
178 REAL SCASUM, SLAMCH, CLANGE
179 EXTERNAL scasum, slamch, clange
180* ..
181* .. External Subroutines ..
182 EXTERNAL clacpy
183*
184* .. Intrinsic Functions ..
185 INTRINSIC max
186* ..
187* .. Executable Statements ..
188*
189 eps = slamch( 'Epsilon' )
190 unfl = slamch( 'Safe minimum' )
191 anorm = max( clange( '1', n, m, a, lda, rwork ), unfl )
192 bnorm = max( clange( '1', n, p, b, ldb, rwork ), unfl )
193*
194* Copy the matrices A and B to the arrays AF and BF,
195* and the vector D the array DF.
196*
197 CALL clacpy( 'Full', n, m, a, lda, af, lda )
198 CALL clacpy( 'Full', n, p, b, ldb, bf, ldb )
199 CALL ccopy( n, d, 1, df, 1 )
200*
201* Solve GLM problem
202*
203 CALL cggglm( n, m, p, af, lda, bf, ldb, df, x, u, work, lwork,
204 $ info )
205*
206* Test the residual for the solution of LSE
207*
208* norm( d - A*x - B*u )
209* RESULT = -----------------------------------------
210* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
211*
212 CALL ccopy( n, d, 1, df, 1 )
213 CALL cgemv( 'No transpose', n, m, -cone, a, lda, x, 1, cone,
214 $ df, 1 )
215*
216 CALL cgemv( 'No transpose', n, p, -cone, b, ldb, u, 1, cone,
217 $ df, 1 )
218*
219 dnorm = scasum( n, df, 1 )
220 xnorm = scasum( m, x, 1 ) + scasum( p, u, 1 )
221 ynorm = anorm + bnorm
222*
223 IF( xnorm.LE.zero ) THEN
224 result = zero
225 ELSE
226 result = ( ( dnorm / ynorm ) / xnorm ) /eps
227 END IF
228*
229 RETURN
230*
231* End of CGLMTS
232*

◆ cgqrts()

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

CGQRTS

Purpose:
!>
!> CGQRTS tests CGGQRF, 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 array, dimension (LDA,M)
!>          The N-by-M matrix A.
!>
[out]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the GQR factorization of A and B, as returned
!>          by CGGQRF, see CGGQRF for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,N)
!>          The M-by-M unitary matrix Q.
!>
[out]R
!>          R is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by CGGQRF.
!>
[in]B
!>          B is COMPLEX array, dimension (LDB,P)
!>          On entry, the N-by-P matrix A.
!>
[out]BF
!>          BF is COMPLEX array, dimension (LDB,N)
!>          Details of the GQR factorization of A and B, as returned
!>          by CGGQRF, see CGGQRF for further details.
!>
[out]Z
!>          Z is COMPLEX array, dimension (LDB,P)
!>          The P-by-P unitary matrix Z.
!>
[out]T
!>          T is COMPLEX array, dimension (LDB,max(P,N))
!>
[out]BWK
!>          BWK is COMPLEX 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 array, dimension (min(P,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by SGGRQF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK, LWORK >= max(N,M,P)**2.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (max(N,M,P))
!>
[out]RESULT
!>          RESULT is REAL 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 cgqrts.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, P, N
183* ..
184* .. Array Arguments ..
185 REAL RWORK( * ), RESULT( 4 )
186 COMPLEX A( LDA, * ), AF( LDA, * ), R( LDA, * ),
187 $ Q( LDA, * ), B( LDB, * ), BF( LDB, * ),
188 $ T( LDB, * ), Z( LDB, * ), BWK( LDB, * ),
189 $ TAUA( * ), TAUB( * ), WORK( LWORK )
190* ..
191*
192* =====================================================================
193*
194* .. Parameters ..
195 REAL ZERO, ONE
196 parameter( zero = 0.0e+0, one = 1.0e+0 )
197 COMPLEX CZERO, CONE
198 parameter( czero = ( 0.0e+0, 0.0e+0 ),
199 $ cone = ( 1.0e+0, 0.0e+0 ) )
200 COMPLEX CROGUE
201 parameter( crogue = ( -1.0e+10, 0.0e+0 ) )
202* ..
203* .. Local Scalars ..
204 INTEGER INFO
205 REAL ANORM, BNORM, ULP, UNFL, RESID
206* ..
207* .. External Functions ..
208 REAL SLAMCH, CLANGE, CLANHE
209 EXTERNAL slamch, clange, clanhe
210* ..
211* .. External Subroutines ..
212 EXTERNAL cgemm, clacpy, claset, cungqr,
213 $ cungrq, cherk
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC max, min, real
217* ..
218* .. Executable Statements ..
219*
220 ulp = slamch( 'Precision' )
221 unfl = slamch( 'Safe minimum' )
222*
223* Copy the matrix A to the array AF.
224*
225 CALL clacpy( 'Full', n, m, a, lda, af, lda )
226 CALL clacpy( 'Full', n, p, b, ldb, bf, ldb )
227*
228 anorm = max( clange( '1', n, m, a, lda, rwork ), unfl )
229 bnorm = max( clange( '1', n, p, b, ldb, rwork ), unfl )
230*
231* Factorize the matrices A and B in the arrays AF and BF.
232*
233 CALL cggqrf( n, m, p, af, lda, taua, bf, ldb, taub, work,
234 $ lwork, info )
235*
236* Generate the N-by-N matrix Q
237*
238 CALL claset( 'Full', n, n, crogue, crogue, q, lda )
239 CALL clacpy( 'Lower', n-1, m, af( 2,1 ), lda, q( 2,1 ), lda )
240 CALL cungqr( n, n, min( n, m ), q, lda, taua, work, lwork, info )
241*
242* Generate the P-by-P matrix Z
243*
244 CALL claset( 'Full', p, p, crogue, crogue, z, ldb )
245 IF( n.LE.p ) THEN
246 IF( n.GT.0 .AND. n.LT.p )
247 $ CALL clacpy( 'Full', n, p-n, bf, ldb, z( p-n+1, 1 ), ldb )
248 IF( n.GT.1 )
249 $ CALL clacpy( '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 clacpy( 'Lower', p-1, p-1, bf( n-p+2, 1 ), ldb,
254 $ z( 2, 1 ), ldb )
255 END IF
256 CALL cungrq( p, p, min( n, p ), z, ldb, taub, work, lwork, info )
257*
258* Copy R
259*
260 CALL claset( 'Full', n, m, czero, czero, r, lda )
261 CALL clacpy( 'Upper', n, m, af, lda, r, lda )
262*
263* Copy T
264*
265 CALL claset( 'Full', n, p, czero, czero, t, ldb )
266 IF( n.LE.p ) THEN
267 CALL clacpy( 'Upper', n, n, bf( 1, p-n+1 ), ldb, t( 1, p-n+1 ),
268 $ ldb )
269 ELSE
270 CALL clacpy( 'Full', n-p, p, bf, ldb, t, ldb )
271 CALL clacpy( '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 cgemm( '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 = clange( '1', n, m, r, lda, rwork )
283 IF( anorm.GT.zero ) THEN
284 result( 1 ) = ( ( resid / real( max(1,m,n) ) ) / anorm ) / ulp
285 ELSE
286 result( 1 ) = zero
287 END IF
288*
289* Compute T*Z - Q'*B
290*
291 CALL cgemm( 'No Transpose', 'No transpose', n, p, p, cone, t, ldb,
292 $ z, ldb, czero, bwk, ldb )
293 CALL cgemm( 'Conjugate transpose', 'No transpose', n, p, n, -cone,
294 $ q, lda, b, ldb, cone, bwk, ldb )
295*
296* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) .
297*
298 resid = clange( '1', n, p, bwk, ldb, rwork )
299 IF( bnorm.GT.zero ) THEN
300 result( 2 ) = ( ( resid / real( max(1,p,n ) ) )/bnorm ) / ulp
301 ELSE
302 result( 2 ) = zero
303 END IF
304*
305* Compute I - Q'*Q
306*
307 CALL claset( 'Full', n, n, czero, cone, r, lda )
308 CALL cherk( 'Upper', 'Conjugate transpose', n, n, -one, q, lda,
309 $ one, r, lda )
310*
311* Compute norm( I - Q'*Q ) / ( N * ULP ) .
312*
313 resid = clanhe( '1', 'Upper', n, r, lda, rwork )
314 result( 3 ) = ( resid / real( max( 1, n ) ) ) / ulp
315*
316* Compute I - Z'*Z
317*
318 CALL claset( 'Full', p, p, czero, cone, t, ldb )
319 CALL cherk( 'Upper', 'Conjugate transpose', p, p, -one, z, ldb,
320 $ one, t, ldb )
321*
322* Compute norm( I - Z'*Z ) / ( P*ULP ) .
323*
324 resid = clanhe( '1', 'Upper', p, t, ldb, rwork )
325 result( 4 ) = ( resid / real( max( 1, p ) ) ) / ulp
326*
327 RETURN
328*
329* End of CGQRTS
330*
cungqr
subroutine cungqr(m, n, k, a, lda, tau, work, lwork, info)
CUNGQR
Definition cungqr.f:128
cungrq
subroutine cungrq(m, n, k, a, lda, tau, work, lwork, info)
CUNGRQ
Definition cungrq.f:128

◆ cgrqts()

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

CGRQTS

Purpose:
!>
!> CGRQTS tests CGGRQF, 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 array, dimension (LDA,N)
!>          The M-by-N matrix A.
!>
[out]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the GRQ factorization of A and B, as returned
!>          by CGGRQF, see CGGRQF for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,N)
!>          The N-by-N unitary matrix Q.
!>
[out]R
!>          R is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by SGGQRC.
!>
[in]B
!>          B is COMPLEX array, dimension (LDB,N)
!>          On entry, the P-by-N matrix A.
!>
[out]BF
!>          BF is COMPLEX array, dimension (LDB,N)
!>          Details of the GQR factorization of A and B, as returned
!>          by CGGRQF, see CGGRQF for further details.
!>
[out]Z
!>          Z is REAL array, dimension (LDB,P)
!>          The P-by-P unitary matrix Z.
!>
[out]T
!>          T is COMPLEX array, dimension (LDB,max(P,N))
!>
[out]BWK
!>          BWK is COMPLEX 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 array, dimension (min(P,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by SGGRQF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK, LWORK >= max(M,P,N)**2.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 cgrqts.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, P, N
183* ..
184* .. Array Arguments ..
185 REAL RESULT( 4 ), RWORK( * )
186 COMPLEX A( LDA, * ), AF( LDA, * ), R( LDA, * ),
187 $ Q( LDA, * ), B( LDB, * ), BF( LDB, * ),
188 $ T( LDB, * ), Z( LDB, * ), BWK( LDB, * ),
189 $ TAUA( * ), TAUB( * ), WORK( LWORK )
190* ..
191*
192* =====================================================================
193*
194* .. Parameters ..
195 REAL ZERO, ONE
196 parameter( zero = 0.0e+0, one = 1.0e+0 )
197 COMPLEX CZERO, CONE
198 parameter( czero = ( 0.0e+0, 0.0e+0 ),
199 $ cone = ( 1.0e+0, 0.0e+0 ) )
200 COMPLEX CROGUE
201 parameter( crogue = ( -1.0e+10, 0.0e+0 ) )
202* ..
203* .. Local Scalars ..
204 INTEGER INFO
205 REAL ANORM, BNORM, ULP, UNFL, RESID
206* ..
207* .. External Functions ..
208 REAL SLAMCH, CLANGE, CLANHE
209 EXTERNAL slamch, clange, clanhe
210* ..
211* .. External Subroutines ..
212 EXTERNAL cgemm, cggrqf, clacpy, claset, cungqr,
213 $ cungrq, cherk
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC max, min, real
217* ..
218* .. Executable Statements ..
219*
220 ulp = slamch( 'Precision' )
221 unfl = slamch( 'Safe minimum' )
222*
223* Copy the matrix A to the array AF.
224*
225 CALL clacpy( 'Full', m, n, a, lda, af, lda )
226 CALL clacpy( 'Full', p, n, b, ldb, bf, ldb )
227*
228 anorm = max( clange( '1', m, n, a, lda, rwork ), unfl )
229 bnorm = max( clange( '1', p, n, b, ldb, rwork ), unfl )
230*
231* Factorize the matrices A and B in the arrays AF and BF.
232*
233 CALL cggrqf( m, p, n, af, lda, taua, bf, ldb, taub, work,
234 $ lwork, info )
235*
236* Generate the N-by-N matrix Q
237*
238 CALL claset( 'Full', n, n, crogue, crogue, q, lda )
239 IF( m.LE.n ) THEN
240 IF( m.GT.0 .AND. m.LT.n )
241 $ CALL clacpy( 'Full', m, n-m, af, lda, q( n-m+1, 1 ), lda )
242 IF( m.GT.1 )
243 $ CALL clacpy( '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 clacpy( 'Lower', n-1, n-1, af( m-n+2, 1 ), lda,
248 $ q( 2, 1 ), lda )
249 END IF
250 CALL cungrq( n, n, min( m, n ), q, lda, taua, work, lwork, info )
251*
252* Generate the P-by-P matrix Z
253*
254 CALL claset( 'Full', p, p, crogue, crogue, z, ldb )
255 IF( p.GT.1 )
256 $ CALL clacpy( 'Lower', p-1, n, bf( 2,1 ), ldb, z( 2,1 ), ldb )
257 CALL cungqr( p, p, min( p,n ), z, ldb, taub, work, lwork, info )
258*
259* Copy R
260*
261 CALL claset( 'Full', m, n, czero, czero, r, lda )
262 IF( m.LE.n )THEN
263 CALL clacpy( 'Upper', m, m, af( 1, n-m+1 ), lda, r( 1, n-m+1 ),
264 $ lda )
265 ELSE
266 CALL clacpy( 'Full', m-n, n, af, lda, r, lda )
267 CALL clacpy( '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 claset( 'Full', p, n, czero, czero, t, ldb )
274 CALL clacpy( 'Upper', p, n, bf, ldb, t, ldb )
275*
276* Compute R - A*Q'
277*
278 CALL cgemm( '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 = clange( '1', m, n, r, lda, rwork )
284 IF( anorm.GT.zero ) THEN
285 result( 1 ) = ( ( resid / real(max(1,m,n) ) ) / anorm ) / ulp
286 ELSE
287 result( 1 ) = zero
288 END IF
289*
290* Compute T*Q - Z'*B
291*
292 CALL cgemm( 'Conjugate transpose', 'No transpose', p, n, p, cone,
293 $ z, ldb, b, ldb, czero, bwk, ldb )
294 CALL cgemm( 'No transpose', 'No transpose', p, n, n, cone, t, ldb,
295 $ q, lda, -cone, bwk, ldb )
296*
297* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) .
298*
299 resid = clange( '1', p, n, bwk, ldb, rwork )
300 IF( bnorm.GT.zero ) THEN
301 result( 2 ) = ( ( resid / real( max( 1,p,m ) ) )/bnorm ) / ulp
302 ELSE
303 result( 2 ) = zero
304 END IF
305*
306* Compute I - Q*Q'
307*
308 CALL claset( 'Full', n, n, czero, cone, r, lda )
309 CALL cherk( 'Upper', 'No Transpose', n, n, -one, q, lda, one, r,
310 $ lda )
311*
312* Compute norm( I - Q'*Q ) / ( N * ULP ) .
313*
314 resid = clanhe( '1', 'Upper', n, r, lda, rwork )
315 result( 3 ) = ( resid / real( max( 1,n ) ) ) / ulp
316*
317* Compute I - Z'*Z
318*
319 CALL claset( 'Full', p, p, czero, cone, t, ldb )
320 CALL cherk( 'Upper', 'Conjugate transpose', p, p, -one, z, ldb,
321 $ one, t, ldb )
322*
323* Compute norm( I - Z'*Z ) / ( P*ULP ) .
324*
325 resid = clanhe( '1', 'Upper', p, t, ldb, rwork )
326 result( 4 ) = ( resid / real( max( 1,p ) ) ) / ulp
327*
328 RETURN
329*
330* End of CGRQTS
331*

◆ cgsvts3()

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

CGSVTS3

Purpose:
!>
!> CGSVTS3 tests CGGSVD3, 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 array, dimension (LDA,M)
!>          The M-by-N matrix A.
!>
[out]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the GSVD of A and B, as returned by CGGSVD3,
!>          see CGGSVD3 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 array, dimension (LDB,P)
!>          On entry, the P-by-N matrix B.
!>
[out]BF
!>          BF is COMPLEX array, dimension (LDB,N)
!>          Details of the GSVD of A and B, as returned by CGGSVD3,
!>          see CGGSVD3 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 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 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 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 REAL array, dimension (N)
!>
[out]BETA
!>          BETA is REAL 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 CGGSVD3 for details.
!>
[out]R
!>          R is COMPLEX 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 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 REAL array, dimension (max(M,P,N))
!>
[out]RESULT
!>          RESULT is REAL 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 cgsvts3.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 REAL ALPHA( * ), BETA( * ), RESULT( 6 ), RWORK( * )
220 COMPLEX 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 REAL ZERO, ONE
229 parameter( zero = 0.0e+0, one = 1.0e+0 )
230 COMPLEX CZERO, CONE
231 parameter( czero = ( 0.0e+0, 0.0e+0 ),
232 $ cone = ( 1.0e+0, 0.0e+0 ) )
233* ..
234* .. Local Scalars ..
235 INTEGER I, INFO, J, K, L
236 REAL ANORM, BNORM, RESID, TEMP, ULP, ULPINV, UNFL
237* ..
238* .. External Functions ..
239 REAL CLANGE, CLANHE, SLAMCH
240 EXTERNAL clange, clanhe, slamch
241* ..
242* .. External Subroutines ..
243 EXTERNAL cgemm, cggsvd3, cherk, clacpy, claset, scopy
244* ..
245* .. Intrinsic Functions ..
246 INTRINSIC max, min, real
247* ..
248* .. Executable Statements ..
249*
250 ulp = slamch( 'Precision' )
251 ulpinv = one / ulp
252 unfl = slamch( 'Safe minimum' )
253*
254* Copy the matrix A to the array AF.
255*
256 CALL clacpy( 'Full', m, n, a, lda, af, lda )
257 CALL clacpy( 'Full', p, n, b, ldb, bf, ldb )
258*
259 anorm = max( clange( '1', m, n, a, lda, rwork ), unfl )
260 bnorm = max( clange( '1', p, n, b, ldb, rwork ), unfl )
261*
262* Factorize the matrices A and B in the arrays AF and BF.
263*
264 CALL cggsvd3( '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 cgemm( 'No transpose', 'No transpose', m, n, n, cone, a, lda,
287 $ q, ldq, czero, work, lda )
288*
289 CALL cgemm( '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 = clange( '1', m, n, a, lda, rwork )
307 IF( anorm.GT.zero ) THEN
308 result( 1 ) = ( ( resid / real( 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 cgemm( 'No transpose', 'No transpose', p, n, n, cone, b, ldb,
317 $ q, ldq, czero, work, ldb )
318*
319 CALL cgemm( '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 = clange( '1', p, n, b, ldb, rwork )
331 IF( bnorm.GT.zero ) THEN
332 result( 2 ) = ( ( resid / real( 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 claset( 'Full', m, m, czero, cone, work, ldq )
341 CALL cherk( 'Upper', 'Conjugate transpose', m, m, -one, u, ldu,
342 $ one, work, ldu )
343*
344* Compute norm( I - U'*U ) / ( M * ULP ) .
345*
346 resid = clanhe( '1', 'Upper', m, work, ldu, rwork )
347 result( 3 ) = ( resid / real( max( 1, m ) ) ) / ulp
348*
349* Compute I - V'*V
350*
351 CALL claset( 'Full', p, p, czero, cone, work, ldv )
352 CALL cherk( 'Upper', 'Conjugate transpose', p, p, -one, v, ldv,
353 $ one, work, ldv )
354*
355* Compute norm( I - V'*V ) / ( P * ULP ) .
356*
357 resid = clanhe( '1', 'Upper', p, work, ldv, rwork )
358 result( 4 ) = ( resid / real( max( 1, p ) ) ) / ulp
359*
360* Compute I - Q'*Q
361*
362 CALL claset( 'Full', n, n, czero, cone, work, ldq )
363 CALL cherk( 'Upper', 'Conjugate transpose', n, n, -one, q, ldq,
364 $ one, work, ldq )
365*
366* Compute norm( I - Q'*Q ) / ( N * ULP ) .
367*
368 resid = clanhe( '1', 'Upper', n, work, ldq, rwork )
369 result( 5 ) = ( resid / real( max( 1, n ) ) ) / ulp
370*
371* Check sorting
372*
373 CALL scopy( 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 CGSVTS3
392*

◆ chbt21()

subroutine chbt21 ( character uplo,
integer n,
integer ka,
integer ks,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( ldu, * ) u,
integer ldu,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real, dimension( 2 ) result )

CHBT21

Purpose:
!>
!> CHBT21  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, CHBT21 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 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 REAL array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix S.
!>
[in]E
!>          E is REAL 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 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 array, dimension (N**2)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESULT
!>          RESULT is REAL 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 chbt21.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 REAL D( * ), E( * ), RESULT( 2 ), RWORK( * )
163 COMPLEX A( LDA, * ), U( LDU, * ), WORK( * )
164* ..
165*
166* =====================================================================
167*
168* .. Parameters ..
169 COMPLEX CZERO, CONE
170 parameter( czero = ( 0.0e+0, 0.0e+0 ),
171 $ cone = ( 1.0e+0, 0.0e+0 ) )
172 REAL ZERO, ONE
173 parameter( zero = 0.0e+0, one = 1.0e+0 )
174* ..
175* .. Local Scalars ..
176 LOGICAL LOWER
177 CHARACTER CUPLO
178 INTEGER IKA, J, JC, JR
179 REAL ANORM, ULP, UNFL, WNORM
180* ..
181* .. External Functions ..
182 LOGICAL LSAME
183 REAL CLANGE, CLANHB, CLANHP, SLAMCH
184 EXTERNAL lsame, clange, clanhb, clanhp, slamch
185* ..
186* .. External Subroutines ..
187 EXTERNAL cgemm, chpr, chpr2
188* ..
189* .. Intrinsic Functions ..
190 INTRINSIC cmplx, max, min, real
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 = slamch( 'Safe minimum' )
212 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
213*
214* Some Error Checks
215*
216* Do Test 1
217*
218* Norm of A:
219*
220 anorm = max( clanhb( '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 chpr( 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 chpr2( cuplo, n, -cmplx( e( j ) ), u( 1, j ), 1,
256 $ u( 1, j+1 ), 1, work )
257 70 CONTINUE
258 END IF
259 wnorm = clanhp( '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, real( n ) ) / ( n*ulp )
268 END IF
269 END IF
270*
271* Do Test 2
272*
273* Compute U U**H - I
274*
275 CALL cgemm( '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( clange( '1', n, n, work, n, rwork ),
283 $ real( n ) ) / ( n*ulp )
284*
285 RETURN
286*
287* End of CHBT21
288*
clanhp
real function clanhp(norm, uplo, n, ap, work)
CLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanhp.f:117
clanhb
real function clanhb(norm, uplo, n, k, ab, ldab, work)
CLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanhb.f:132
chpr2
subroutine chpr2(uplo, n, alpha, x, incx, y, incy, ap)
CHPR2
Definition chpr2.f:145
chpr
subroutine chpr(uplo, n, alpha, x, incx, ap)
CHPR
Definition chpr.f:130

◆ chet21()

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

CHET21

Purpose:
!>
!> CHET21 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, CHET21 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 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 REAL array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>
[in]E
!>          E is REAL 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 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 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 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 array, dimension (2*N**2)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESULT
!>          RESULT is REAL 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 chet21.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 REAL D( * ), E( * ), RESULT( 2 ), RWORK( * )
225 COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ),
226 $ V( LDV, * ), WORK( * )
227* ..
228*
229* =====================================================================
230*
231* .. Parameters ..
232 REAL ZERO, ONE, TEN
233 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 10.0e+0 )
234 COMPLEX CZERO, CONE
235 parameter( czero = ( 0.0e+0, 0.0e+0 ),
236 $ cone = ( 1.0e+0, 0.0e+0 ) )
237* ..
238* .. Local Scalars ..
239 LOGICAL LOWER
240 CHARACTER CUPLO
241 INTEGER IINFO, J, JCOL, JR, JROW
242 REAL ANORM, ULP, UNFL, WNORM
243 COMPLEX VSAVE
244* ..
245* .. External Functions ..
246 LOGICAL LSAME
247 REAL CLANGE, CLANHE, SLAMCH
248 EXTERNAL lsame, clange, clanhe, slamch
249* ..
250* .. External Subroutines ..
251 EXTERNAL cgemm, cher, cher2, clacpy, clarfy, claset,
252 $ cunm2l, cunm2r
253* ..
254* .. Intrinsic Functions ..
255 INTRINSIC cmplx, max, min, real
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 = slamch( 'Safe minimum' )
274 ulp = slamch( 'Epsilon' )*slamch( '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( clanhe( '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 claset( 'Full', n, n, czero, czero, work, n )
300 CALL clacpy( cuplo, n, n, a, lda, work, n )
301*
302 DO 10 j = 1, n
303 CALL cher( 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 cher2( cuplo, n, -cmplx( e( j ) ), u( 1, j ), 1,
309 $ u( 1, j-1 ), 1, work, n )
310 20 CONTINUE
311 END IF
312 wnorm = clanhe( '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 claset( '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 clarfy( '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 clarfy( '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 = clanhe( '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 clacpy( ' ', n, n, u, ldu, work, n )
378 IF( lower ) THEN
379 CALL cunm2r( '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 cunm2l( '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 = clange( '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, real( 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 cgemm( '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( clange( '1', n, n, work, n, rwork ),
420 $ real( n ) ) / ( n*ulp )
421 END IF
422*
423 RETURN
424*
425* End of CHET21
426*
clarfy
subroutine clarfy(uplo, n, v, incv, tau, c, ldc, work)
CLARFY
Definition clarfy.f:108
cunm2l
subroutine cunm2l(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
CUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf...
Definition cunm2l.f:159
cher
subroutine cher(uplo, n, alpha, x, incx, a, lda)
CHER
Definition cher.f:135
cher2
subroutine cher2(uplo, n, alpha, x, incx, y, incy, a, lda)
CHER2
Definition cher2.f:150

◆ chet22()

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

CHET22

Purpose:
!>
!>      CHET22  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, CHET22 does nothing.
!>          It must be at least zero.
!>          Not modified.
!>
!>  M       INTEGER
!>          The number of columns of U.  If it is zero, CHET22 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 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       REAL array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>          Not modified.
!>
!>  E       REAL 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 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 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 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 array, dimension (2*N**2)
!>          Workspace.
!>          Modified.
!>
!>  RWORK   REAL array, dimension (N)
!>          Workspace.
!>          Modified.
!>
!>  RESULT  REAL 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 chet22.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 REAL D( * ), E( * ), RESULT( 2 ), RWORK( * )
172 COMPLEX A( LDA, * ), TAU( * ), U( LDU, * ),
173 $ V( LDV, * ), WORK( * )
174* ..
175*
176* =====================================================================
177*
178* .. Parameters ..
179 REAL ZERO, ONE
180 parameter( zero = 0.0e0, one = 1.0e0 )
181 COMPLEX CZERO, CONE
182 parameter( czero = ( 0.0e0, 0.0e0 ),
183 $ cone = ( 1.0e0, 0.0e0 ) )
184* ..
185* .. Local Scalars ..
186 INTEGER J, JJ, JJ1, JJ2, NN, NNP1
187 REAL ANORM, ULP, UNFL, WNORM
188* ..
189* .. External Functions ..
190 REAL CLANHE, SLAMCH
191 EXTERNAL clanhe, slamch
192* ..
193* .. External Subroutines ..
194 EXTERNAL cgemm, chemm
195* ..
196* .. Intrinsic Functions ..
197 INTRINSIC max, min, real
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 = slamch( 'Safe minimum' )
207 ulp = slamch( 'Precision' )
208*
209* Do Test 1
210*
211* Norm of A:
212*
213 anorm = max( clanhe( '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 chemm( 'L', uplo, n, m, cone, a, lda, u, ldu, czero, work,
220 $ n )
221 nn = n*n
222 nnp1 = nn + 1
223 CALL cgemm( '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 = clanhe( '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, real( 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 cunt01( 'Columns', n, m, u, ldu, work, 2*n*n, rwork,
255 $ result( 2 ) )
256*
257 RETURN
258*
259* End of CHET22
260*
chemm
subroutine chemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
CHEMM
Definition chemm.f:191

◆ chkxer()

subroutine chkxer ( character*(*) srnamt,
integer infot,
integer nout,
logical lerr,
logical ok )

CHKXER

Purpose:
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 40 of file chkxer.f.

41*
42* -- LAPACK test routine --
43* -- LAPACK is a software package provided by Univ. of Tennessee, --
44* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
45*
46* .. Scalar Arguments ..
47 LOGICAL LERR, OK
48 CHARACTER*(*) SRNAMT
49 INTEGER INFOT, NOUT
50* ..
51* .. Intrinsic Functions ..
52 INTRINSIC len_trim
53* ..
54* .. Executable Statements ..
55 IF( .NOT.lerr ) THEN
56 WRITE( nout, fmt = 9999 )infot,
57 $ srnamt( 1:len_trim( srnamt ) )
58 ok = .false.
59 END IF
60 lerr = .false.
61 RETURN
62*
63 9999 FORMAT( ' *** Illegal value of parameter number ', i2,
64 $ ' not detected by ', a6, ' ***' )
65*
66* End of CHKXER
67*

◆ chpt21()

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

CHPT21

Purpose:
!>
!> CHPT21  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, CHPT21 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 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 REAL array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>
[in]E
!>          E is REAL 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 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 REAL 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 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 array, dimension (N**2)
!>          Workspace.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>          Workspace.
!>
[out]RESULT
!>          RESULT is REAL 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 chpt21.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 REAL D( * ), E( * ), RESULT( 2 ), RWORK( * )
239 COMPLEX AP( * ), TAU( * ), U( LDU, * ), VP( * ),
240 $ WORK( * )
241* ..
242*
243* =====================================================================
244*
245* .. Parameters ..
246 REAL ZERO, ONE, TEN
247 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 10.0e+0 )
248 REAL HALF
249 parameter( half = 1.0e+0 / 2.0e+0 )
250 COMPLEX CZERO, CONE
251 parameter( czero = ( 0.0e+0, 0.0e+0 ),
252 $ cone = ( 1.0e+0, 0.0e+0 ) )
253* ..
254* .. Local Scalars ..
255 LOGICAL LOWER
256 CHARACTER CUPLO
257 INTEGER IINFO, J, JP, JP1, JR, LAP
258 REAL ANORM, ULP, UNFL, WNORM
259 COMPLEX TEMP, VSAVE
260* ..
261* .. External Functions ..
262 LOGICAL LSAME
263 REAL CLANGE, CLANHP, SLAMCH
264 COMPLEX CDOTC
265 EXTERNAL lsame, clange, clanhp, slamch, cdotc
266* ..
267* .. External Subroutines ..
268 EXTERNAL caxpy, ccopy, cgemm, chpmv, chpr, chpr2,
269 $ clacpy, claset, cupmtr
270* ..
271* .. Intrinsic Functions ..
272 INTRINSIC cmplx, max, min, real
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 = slamch( 'Safe minimum' )
295 ulp = slamch( 'Epsilon' )*slamch( '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( clanhp( '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 claset( 'Full', n, n, czero, czero, work, n )
321 CALL ccopy( lap, ap, 1, work, 1 )
322*
323 DO 10 j = 1, n
324 CALL chpr( 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 chpr2( cuplo, n, -cmplx( e( j ) ), u( 1, j ), 1,
330 $ u( 1, j-1 ), 1, work )
331 20 CONTINUE
332 END IF
333 wnorm = clanhp( '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 claset( '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 chpmv( 'L', n-j, cone, work( jp1+j+1 ),
357 $ vp( jp+j+1 ), 1, czero, work( lap+1 ), 1 )
358 temp = -half*tau( j )*cdotc( n-j, work( lap+1 ), 1,
359 $ vp( jp+j+1 ), 1 )
360 CALL caxpy( n-j, temp, vp( jp+j+1 ), 1, work( lap+1 ),
361 $ 1 )
362 CALL chpr2( '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 chpmv( 'U', j, cone, work, vp( jp1+1 ), 1, czero,
385 $ work( lap+1 ), 1 )
386 temp = -half*tau( j )*cdotc( j, work( lap+1 ), 1,
387 $ vp( jp1+1 ), 1 )
388 CALL caxpy( j, temp, vp( jp1+1 ), 1, work( lap+1 ),
389 $ 1 )
390 CALL chpr2( '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 = clanhp( '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 clacpy( ' ', n, n, u, ldu, work, n )
410 CALL cupmtr( '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 = clange( '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, real( 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 cgemm( '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( clange( '1', n, n, work, n, rwork ),
447 $ real( n ) ) / ( n*ulp )
448 END IF
449*
450 RETURN
451*
452* End of CHPT21
453*
cdotc
complex function cdotc(n, cx, incx, cy, incy)
CDOTC
Definition cdotc.f:83
chpmv
subroutine chpmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
CHPMV
Definition chpmv.f:149

◆ chst01()

subroutine chst01 ( integer n,
integer ilo,
integer ihi,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldh, * ) h,
integer ldh,
complex, dimension( ldq, * ) q,
integer ldq,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( 2 ) result )

CHST01

Purpose:
!>
!> CHST01 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 CGEHRD + CUNGHR.
!>
!> 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 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 array, dimension (LDH,N)
!>          The upper Hessenberg matrix H from the reduction A = Q*H*Q'
!>          as computed by CGEHRD.  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 array, dimension (LDQ,N)
!>          The orthogonal matrix Q from the reduction A = Q*H*Q' as
!>          computed by CGEHRD + CUNGHR.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= 2*N*N.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESULT
!>          RESULT is REAL 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 chst01.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 REAL RESULT( 2 ), RWORK( * )
150 COMPLEX A( LDA, * ), H( LDH, * ), Q( LDQ, * ),
151 $ WORK( LWORK )
152* ..
153*
154* =====================================================================
155*
156* .. Parameters ..
157 REAL ONE, ZERO
158 parameter( one = 1.0e+0, zero = 0.0e+0 )
159* ..
160* .. Local Scalars ..
161 INTEGER LDWORK
162 REAL ANORM, EPS, OVFL, SMLNUM, UNFL, WNORM
163* ..
164* .. External Functions ..
165 REAL CLANGE, SLAMCH
166 EXTERNAL clange, slamch
167* ..
168* .. External Subroutines ..
169 EXTERNAL cgemm, clacpy, cunt01, slabad
170* ..
171* .. Intrinsic Functions ..
172 INTRINSIC cmplx, 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 = slamch( 'Safe minimum' )
185 eps = slamch( 'Precision' )
186 ovfl = one / unfl
187 CALL slabad( 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 clacpy( ' ', n, n, a, lda, work, ldwork )
196*
197* Compute Q*H
198*
199 CALL cgemm( 'No transpose', 'No transpose', n, n, n, cmplx( one ),
200 $ q, ldq, h, ldh, cmplx( zero ), work( ldwork*n+1 ),
201 $ ldwork )
202*
203* Compute A - Q*H*Q'
204*
205 CALL cgemm( 'No transpose', 'Conjugate transpose', n, n, n,
206 $ cmplx( -one ), work( ldwork*n+1 ), ldwork, q, ldq,
207 $ cmplx( one ), work, ldwork )
208*
209 anorm = max( clange( '1', n, n, a, lda, rwork ), unfl )
210 wnorm = clange( '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 cunt01( 'Columns', n, n, q, ldq, work, lwork, rwork,
219 $ result( 2 ) )
220*
221 RETURN
222*
223* End of CHST01
224*

◆ clarfy()

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

CLARFY

Purpose:
!>
!> CLARFY 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 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
!>          The value tau as described above.
!>
[in,out]C
!>          C is COMPLEX 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 array, dimension (N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file clarfy.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 TAU
117* ..
118* .. Array Arguments ..
119 COMPLEX C( LDC, * ), V( * ), WORK( * )
120* ..
121*
122* =====================================================================
123*
124* .. Parameters ..
125 COMPLEX ONE, ZERO, HALF
126 parameter( one = ( 1.0e+0, 0.0e+0 ),
127 $ zero = ( 0.0e+0, 0.0e+0 ),
128 $ half = ( 0.5e+0, 0.0e+0 ) )
129* ..
130* .. Local Scalars ..
131 COMPLEX ALPHA
132* ..
133* .. External Subroutines ..
134 EXTERNAL caxpy, chemv, cher2
135* ..
136* .. External Functions ..
137 COMPLEX CDOTC
138 EXTERNAL cdotc
139* ..
140* .. Executable Statements ..
141*
142 IF( tau.EQ.zero )
143 $ RETURN
144*
145* Form w:= C * v
146*
147 CALL chemv( uplo, n, one, c, ldc, v, incv, zero, work, 1 )
148*
149 alpha = -half*tau*cdotc( n, work, 1, v, incv )
150 CALL caxpy( n, alpha, v, incv, work, 1 )
151*
152* C := C - v * w' - w * v'
153*
154 CALL cher2( uplo, n, -tau, v, incv, work, 1, c, ldc )
155*
156 RETURN
157*
158* End of CLARFY
159*
chemv
subroutine chemv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
CHEMV
Definition chemv.f:154

◆ clarhs()

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

CLARHS

Purpose:
!>
!> CLARHS 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 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 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 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
!>          CLATMS).  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 clarhs.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 A( LDA, * ), B( LDB, * ), X( LDX, * )
221* ..
222*
223* =====================================================================
224*
225* .. Parameters ..
226 COMPLEX ONE, ZERO
227 parameter( one = ( 1.0e+0, 0.0e+0 ),
228 $ zero = ( 0.0e+0, 0.0e+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 cgbmv, cgemm, chbmv, chemm, chpmv, clacpy,
242 $ clarnv, csbmv, cspmv, csymm, ctbmv, ctpmv,
243 $ ctrmm, xerbla
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, 'Complex 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.
272 $ .NOT.( 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( 'CLARHS', -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 clarnv( 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 cgemm( 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 chemm( '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 csymm( '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 cgbmv( 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 chbmv( 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 csbmv( 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 chpmv( 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 cspmv( 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 clacpy( '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 ctrmm( '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 clacpy( '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 ctpmv( 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 clacpy( '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 ctbmv( 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( 'CLARHS', -info )
435 END IF
436*
437 RETURN
438*
439* End of CLARHS
440*
cspmv
subroutine cspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
CSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix
Definition cspmv.f:151
clarnv
subroutine clarnv(idist, iseed, n, x)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition clarnv.f:99
cgbmv
subroutine cgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
CGBMV
Definition cgbmv.f:187
ctpmv
subroutine ctpmv(uplo, trans, diag, n, ap, x, incx)
CTPMV
Definition ctpmv.f:142
ctbmv
subroutine ctbmv(uplo, trans, diag, n, k, a, lda, x, incx)
CTBMV
Definition ctbmv.f:186
chbmv
subroutine chbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
CHBMV
Definition chbmv.f:187
ctrmm
subroutine ctrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRMM
Definition ctrmm.f:177
csymm
subroutine csymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
CSYMM
Definition csymm.f:189
csbmv
subroutine csbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
CSBMV
Definition csbmv.f:152

◆ clatm4()

subroutine clatm4 ( integer itype,
integer n,
integer nz1,
integer nz2,
logical rsign,
real amagn,
real rcond,
real triang,
integer idist,
integer, dimension( 4 ) iseed,
complex, dimension( lda, * ) a,
integer lda )

CLATM4

Purpose:
!>
!> CLATM4 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 CLARND.)
!>
[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 REAL
!>          The diagonal and subdiagonal entries will be multiplied by
!>          AMAGN.
!>
[in]RCOND
!>          RCOND is REAL
!>          If abs(ITYPE) > 4, then the smallest diagonal entry will be
!>          RCOND.  RCOND must be between 0 and 1.
!>
[in]TRIANG
!>          TRIANG is REAL
!>          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 CLATM4 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 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 clatm4.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 REAL AMAGN, RCOND, TRIANG
180* ..
181* .. Array Arguments ..
182 INTEGER ISEED( 4 )
183 COMPLEX A( LDA, * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 REAL ZERO, ONE
190 parameter( zero = 0.0e+0, one = 1.0e+0 )
191 COMPLEX CZERO, CONE
192 parameter( czero = ( 0.0e+0, 0.0e+0 ),
193 $ cone = ( 1.0e+0, 0.0e+0 ) )
194* ..
195* .. Local Scalars ..
196 INTEGER I, ISDB, ISDE, JC, JD, JR, K, KBEG, KEND, KLEN
197 REAL ALPHA
198 COMPLEX CTEMP
199* ..
200* .. External Functions ..
201 REAL SLARAN
202 COMPLEX CLARND
203 EXTERNAL slaran, clarnd
204* ..
205* .. External Subroutines ..
206 EXTERNAL claset
207* ..
208* .. Intrinsic Functions ..
209 INTRINSIC abs, cmplx, exp, log, max, min, mod, real
210* ..
211* .. Executable Statements ..
212*
213 IF( n.LE.0 )
214 $ RETURN
215 CALL claset( '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 ) = cmplx( 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 ) = cmplx( 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 ) = cmplx( 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 / real( klen-1 ) )
305 DO 150 i = 2, klen
306 a( nz1+i, nz1+i ) = cmplx( alpha**real( 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 ) / real( klen-1 )
317 DO 170 i = 2, klen
318 a( nz1+i, nz1+i ) = cmplx( real( 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*slaran( 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 ) = clarnd( 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*real( a( jd, jd ) )
345 230 CONTINUE
346 DO 240 jd = isdb, isde
347 a( jd+1, jd ) = amagn*real( 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( real( a( jd, jd ) ).NE.zero ) THEN
356 ctemp = clarnd( 3, iseed )
357 ctemp = ctemp / abs( ctemp )
358 a( jd, jd ) = ctemp*real( a( jd, jd ) )
359 END IF
360 250 CONTINUE
361 DO 260 jd = isdb, isde
362 IF( real( a( jd+1, jd ) ).NE.zero ) THEN
363 ctemp = clarnd( 3, iseed )
364 ctemp = ctemp / abs( ctemp )
365 a( jd+1, jd ) = ctemp*real( 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*clarnd( idist, iseed )
393 290 CONTINUE
394 300 CONTINUE
395 END IF
396*
397 RETURN
398*
399* End of CLATM4
400*

◆ clctes()

logical function clctes ( complex z,
complex d )

CLCTES

Purpose:
!>
!> CLCTES 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 CDRGES to test whether the driver
!> routine CGGES successfully sorts eigenvalues.
!>
Parameters
[in]Z
!>          Z is COMPLEX
!>          The numerator part of a complex eigenvalue Z/D.
!>
[in]D
!>          D is COMPLEX
!>          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 clctes.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 D, Z
65* ..
66*
67* =====================================================================
68*
69* .. Parameters ..
70*
71 REAL ZERO, ONE
72 parameter( zero = 0.0e+0, one = 1.0e+0 )
73 COMPLEX CZERO
74 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
75* ..
76* .. Local Scalars ..
77 REAL ZMAX
78* ..
79* .. Intrinsic Functions ..
80 INTRINSIC abs, aimag, max, real, sign
81* ..
82* .. Executable Statements ..
83*
84 IF( d.EQ.czero ) THEN
85 clctes = ( real( z ).LT.zero )
86 ELSE
87 IF( real( z ).EQ.zero .OR. real( d ).EQ.zero ) THEN
88 clctes = ( sign( one, aimag( z ) ).NE.
89 $ sign( one, aimag( d ) ) )
90 ELSE IF( aimag( z ).EQ.zero .OR. aimag( d ).EQ.zero ) THEN
91 clctes = ( sign( one, real( z ) ).NE.
92 $ sign( one, real( d ) ) )
93 ELSE
94 zmax = max( abs( real( z ) ), abs( aimag( z ) ) )
95 clctes = ( ( real( z ) / zmax )*real( d )+
96 $ ( aimag( z ) / zmax )*aimag( d ).LT.zero )
97 END IF
98 END IF
99*
100 RETURN
101*
102* End of CLCTES
103*

◆ clctsx()

logical function clctsx ( complex alpha,
complex beta )

CLCTSX

Purpose:
!>
!> This function is used to determine what eigenvalues will be
!> selected.  If this is part of the test driver CDRGSX, do not
!> change the code UNLESS you are testing input examples and not
!> using the built-in examples.
!>
Parameters
[in]ALPHA
!>          ALPHA is COMPLEX
!>
[in]BETA
!>          BETA is COMPLEX
!>
!>          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 clctsx.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 ALPHA, BETA
64* ..
65*
66* =====================================================================
67*
68* .. Parameters ..
69* REAL ZERO
70* PARAMETER ( ZERO = 0.0E+0 )
71* COMPLEX 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 clctsx = .false.
90 ELSE
91 clctsx = .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 clctsx = .true.
101 ELSE
102 clctsx = .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* CLCTSX = ( REAL( ALPHA ).GT.ZERO )
112* ELSE
113* CLCTSX = ( REAL( ALPHA/BETA ).GT.ZERO )
114* END IF
115*
116 RETURN
117*
118* End of CLCTSX
119*

◆ clsets()

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

CLSETS

Purpose:
!>
!> CLSETS tests CGGLSE - 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 array, dimension (LDA,N)
!>          The M-by-N matrix A.
!>
[out]AF
!>          AF is COMPLEX 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 array, dimension (LDB,N)
!>          The P-by-N matrix A.
!>
[out]BF
!>          BF is COMPLEX 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 array, dimension( M )
!>          the vector C in the LSE problem.
!>
[out]CF
!>          CF is COMPLEX array, dimension( M )
!>
[in]D
!>          D is COMPLEX array, dimension( P )
!>          the vector D in the LSE problem.
!>
[out]DF
!>          DF is COMPLEX array, dimension( P )
!>
[out]X
!>          X is COMPLEX array, dimension( N )
!>          solution vector X in the LSE problem.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 153 of file clsets.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 LDA, LDB, LWORK, M, P, N
162* ..
163* .. Array Arguments ..
164 REAL RESULT( 2 ), RWORK( * )
165 COMPLEX A( LDA, * ), AF( LDA, * ), B( LDB, * ),
166 $ BF( LDB, * ), C( * ), D( * ), CF( * ),
167 $ DF( * ), WORK( LWORK ), X( * )
168*
169* ====================================================================
170*
171* ..
172* .. Local Scalars ..
173 INTEGER INFO
174* ..
175* .. External Subroutines ..
176 EXTERNAL cgglse, clacpy, cget02
177* ..
178* .. Executable Statements ..
179*
180* Copy the matrices A and B to the arrays AF and BF,
181* and the vectors C and D to the arrays CF and DF,
182*
183 CALL clacpy( 'Full', m, n, a, lda, af, lda )
184 CALL clacpy( 'Full', p, n, b, ldb, bf, ldb )
185 CALL ccopy( m, c, 1, cf, 1 )
186 CALL ccopy( p, d, 1, df, 1 )
187*
188* Solve LSE problem
189*
190 CALL cgglse( m, n, p, af, lda, bf, ldb, cf, df, x,
191 $ work, lwork, info )
192*
193* Test the residual for the solution of LSE
194*
195* Compute RESULT(1) = norm( A*x - c ) / norm(A)*norm(X)*EPS
196*
197 CALL ccopy( m, c, 1, cf, 1 )
198 CALL ccopy( p, d, 1, df, 1 )
199 CALL cget02( 'No transpose', m, n, 1, a, lda, x, n, cf, m,
200 $ rwork, result( 1 ) )
201*
202* Compute result(2) = norm( B*x - d ) / norm(B)*norm(X)*EPS
203*
204 CALL cget02( 'No transpose', p, n, 1, b, ldb, x, n, df, p,
205 $ rwork, result( 2 ) )
206*
207 RETURN
208*
209* End of CLSETS
210*
cget02
subroutine cget02(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CGET02
Definition cget02.f:134

◆ csbmv()

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

CSBMV

Purpose:
!>
!> CSBMV  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
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
!>  A      - COMPLEX 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 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
!>           On entry, BETA specifies the scalar beta.
!>           Unchanged on exit.
!>
!>  Y      - COMPLEX 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 csbmv.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 ALPHA, BETA
161* ..
162* .. Array Arguments ..
163 COMPLEX A( LDA, * ), X( * ), Y( * )
164* ..
165*
166* =====================================================================
167*
168* .. Parameters ..
169 COMPLEX ONE
170 parameter( one = ( 1.0e+0, 0.0e+0 ) )
171 COMPLEX ZERO
172 parameter( zero = ( 0.0e+0, 0.0e+0 ) )
173* ..
174* .. Local Scalars ..
175 INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L
176 COMPLEX 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( 'CSBMV ', 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 CSBMV
344*

◆ csgt01()

subroutine csgt01 ( integer itype,
character uplo,
integer n,
integer m,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldz, * ) z,
integer ldz,
real, dimension( * ) d,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real, dimension( * ) result )

CSGT01

Purpose:
!>
!> CSGT01 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 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 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 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 REAL array, dimension (M)
!>          The computed eigenvalues of the generalized eigenproblem.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (N*N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESULT
!>          RESULT is REAL 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 csgt01.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 REAL D( * ), RESULT( * ), RWORK( * )
163 COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ),
164 $ Z( LDZ, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 REAL ZERO, ONE
171 parameter( zero = 0.0e+0, one = 1.0e+0 )
172 COMPLEX CZERO, CONE
173 parameter( czero = ( 0.0e+0, 0.0e+0 ),
174 $ cone = ( 1.0e+0, 0.0e+0 ) )
175* ..
176* .. Local Scalars ..
177 INTEGER I
178 REAL ANORM, ULP
179* ..
180* .. External Functions ..
181 REAL CLANGE, CLANHE, SLAMCH
182 EXTERNAL clange, clanhe, slamch
183* ..
184* .. External Subroutines ..
185 EXTERNAL chemm, csscal
186* ..
187* .. Executable Statements ..
188*
189 result( 1 ) = zero
190 IF( n.LE.0 )
191 $ RETURN
192*
193 ulp = slamch( 'Epsilon' )
194*
195* Compute product of 1-norms of A and Z.
196*
197 anorm = clanhe( '1', uplo, n, a, lda, rwork )*
198 $ clange( '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 chemm( 'Left', uplo, n, m, cone, a, lda, z, ldz, czero,
207 $ work, n )
208 DO 10 i = 1, m
209 CALL csscal( n, d( i ), z( 1, i ), 1 )
210 10 CONTINUE
211 CALL chemm( 'Left', uplo, n, m, cone, b, ldb, z, ldz, -cone,
212 $ work, n )
213*
214 result( 1 ) = ( clange( '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 chemm( 'Left', uplo, n, m, cone, b, ldb, z, ldz, czero,
222 $ work, n )
223 DO 20 i = 1, m
224 CALL csscal( n, d( i ), z( 1, i ), 1 )
225 20 CONTINUE
226 CALL chemm( 'Left', uplo, n, m, cone, a, lda, work, n, -cone,
227 $ z, ldz )
228*
229 result( 1 ) = ( clange( '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 chemm( 'Left', uplo, n, m, cone, a, lda, z, ldz, czero,
237 $ work, n )
238 DO 30 i = 1, m
239 CALL csscal( n, d( i ), z( 1, i ), 1 )
240 30 CONTINUE
241 CALL chemm( 'Left', uplo, n, m, cone, b, ldb, work, n, -cone,
242 $ z, ldz )
243*
244 result( 1 ) = ( clange( '1', n, m, z, ldz, rwork ) / anorm ) /
245 $ ( n*ulp )
246 END IF
247*
248 RETURN
249*
250* End of CSGT01
251*

◆ cslect()

logical function cslect ( complex z)

CSLECT

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

Definition at line 55 of file cslect.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 Z
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 REAL ZERO
69 parameter( zero = 0.0e0 )
70* ..
71* .. Local Scalars ..
72 INTEGER I
73 REAL RMIN, X
74* ..
75* .. Scalars in Common ..
76 INTEGER SELDIM, SELOPT
77* ..
78* .. Arrays in Common ..
79 LOGICAL SELVAL( 20 )
80 REAL SELWI( 20 ), SELWR( 20 )
81* ..
82* .. Common blocks ..
83 COMMON / sslct / selopt, seldim, selval, selwr, selwi
84* ..
85* .. Intrinsic Functions ..
86 INTRINSIC abs, cmplx, real
87* ..
88* .. Executable Statements ..
89*
90 IF( selopt.EQ.0 ) THEN
91 cslect = ( real( z ).LT.zero )
92 ELSE
93 rmin = abs( z-cmplx( selwr( 1 ), selwi( 1 ) ) )
94 cslect = selval( 1 )
95 DO 10 i = 2, seldim
96 x = abs( z-cmplx( selwr( i ), selwi( i ) ) )
97 IF( x.LE.rmin ) THEN
98 rmin = x
99 cslect = selval( i )
100 END IF
101 10 CONTINUE
102 END IF
103 RETURN
104*
105* End of CSLECT
106*

◆ cstt21()

subroutine cstt21 ( integer n,
integer kband,
real, dimension( * ) ad,
real, dimension( * ) ae,
real, dimension( * ) sd,
real, dimension( * ) se,
complex, dimension( ldu, * ) u,
integer ldu,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real, dimension( 2 ) result )

CSTT21

Purpose:
!>
!> CSTT21  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, CSTT21 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 REAL array, dimension (N)
!>          The diagonal of the original (unfactored) matrix A.  A is
!>          assumed to be real symmetric tridiagonal.
!>
[in]AE
!>          AE is REAL 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 REAL array, dimension (N)
!>          The diagonal of the real (symmetric tri-) diagonal matrix S.
!>
[in]SE
!>          SE is REAL 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 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 array, dimension (N**2)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESULT
!>          RESULT is REAL 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 cstt21.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 REAL AD( * ), AE( * ), RESULT( 2 ), RWORK( * ),
143 $ SD( * ), SE( * )
144 COMPLEX U( LDU, * ), WORK( * )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 REAL ZERO, ONE
151 parameter( zero = 0.0e+0, one = 1.0e+0 )
152 COMPLEX CZERO, CONE
153 parameter( czero = ( 0.0e+0, 0.0e+0 ),
154 $ cone = ( 1.0e+0, 0.0e+0 ) )
155* ..
156* .. Local Scalars ..
157 INTEGER J
158 REAL ANORM, TEMP1, TEMP2, ULP, UNFL, WNORM
159* ..
160* .. External Functions ..
161 REAL CLANGE, CLANHE, SLAMCH
162 EXTERNAL clange, clanhe, slamch
163* ..
164* .. External Subroutines ..
165 EXTERNAL cgemm, cher, cher2, claset
166* ..
167* .. Intrinsic Functions ..
168 INTRINSIC abs, cmplx, max, min, real
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 = slamch( 'Safe minimum' )
180 ulp = slamch( 'Precision' )
181*
182* Do Test 1
183*
184* Copy A & Compute its 1-Norm:
185*
186 CALL claset( '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 - U S U**H
203*
204 DO 20 j = 1, n
205 CALL cher( '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 cher2( 'L', n, -cmplx( se( j ) ), u( 1, j ), 1,
211 $ u( 1, j+1 ), 1, work, n )
212 30 CONTINUE
213 END IF
214*
215 wnorm = clanhe( '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, real( n ) ) / ( n*ulp )
224 END IF
225 END IF
226*
227* Do Test 2
228*
229* Compute U U**H - I
230*
231 CALL cgemm( '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( real( n ), clange( '1', n, n, work, n,
239 $ rwork ) ) / ( n*ulp )
240*
241 RETURN
242*
243* End of CSTT21
244*

◆ cstt22()

subroutine cstt22 ( integer n,
integer m,
integer kband,
real, dimension( * ) ad,
real, dimension( * ) ae,
real, dimension( * ) sd,
real, dimension( * ) se,
complex, dimension( ldu, * ) u,
integer ldu,
complex, dimension( ldwork, * ) work,
integer ldwork,
real, dimension( * ) rwork,
real, dimension( 2 ) result )

CSTT22

Purpose:
!>
!> CSTT22  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, CSTT22 does nothing.
!>          It must be at least zero.
!>
[in]M
!>          M is INTEGER
!>          The number of eigenpairs to check.  If it is zero, CSTT22
!>          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 REAL array, dimension (N)
!>          The diagonal of the original (unfactored) matrix A.  A is
!>          assumed to be Hermitian tridiagonal.
!>
[in]AE
!>          AE is REAL 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 REAL array, dimension (N)
!>          The diagonal of the (Hermitian tri-) diagonal matrix S.
!>
[in]SE
!>          SE is REAL 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 REAL 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 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 REAL array, dimension (N)
!>
[out]RESULT
!>          RESULT is REAL 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 cstt22.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 REAL AD( * ), AE( * ), RESULT( 2 ), RWORK( * ),
155 $ SD( * ), SE( * )
156 COMPLEX U( LDU, * ), WORK( LDWORK, * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameters ..
162 REAL ZERO, ONE
163 parameter( zero = 0.0e0, one = 1.0e0 )
164 COMPLEX CZERO, CONE
165 parameter( czero = ( 0.0e+0, 0.0e+0 ),
166 $ cone = ( 1.0e+0, 0.0e+0 ) )
167* ..
168* .. Local Scalars ..
169 INTEGER I, J, K
170 REAL ANORM, ULP, UNFL, WNORM
171 COMPLEX AUKJ
172* ..
173* .. External Functions ..
174 REAL CLANGE, CLANSY, SLAMCH
175 EXTERNAL clange, clansy, slamch
176* ..
177* .. External Subroutines ..
178 EXTERNAL cgemm
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC abs, max, min, real
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 = slamch( 'Safe minimum' )
191 ulp = slamch( '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 = clansy( '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, real( m ) ) / ( m*ulp )
241 END IF
242 END IF
243*
244* Do Test 2
245*
246* Compute U*U - I
247*
248 CALL cgemm( '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( real( m ), clange( '1', m, m, work, m,
256 $ rwork ) ) / ( m*ulp )
257*
258 RETURN
259*
260* End of CSTT22
261*
clansy
real function clansy(norm, uplo, n, a, lda, work)
CLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clansy.f:123

◆ cunt01()

subroutine cunt01 ( character rowcol,
integer m,
integer n,
complex, dimension( ldu, * ) u,
integer ldu,
complex, dimension( * ) work,
integer lwork,
real, dimension( * ) rwork,
real resid )

CUNT01

Purpose:
!>
!> CUNT01 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 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 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 REAL array, dimension (min(M,N))
!>          Used only if LWORK is large enough to use the Level 3 BLAS
!>          code.
!>
[out]RESID
!>          RESID is REAL
!>          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 cunt01.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 REAL RESID
135* ..
136* .. Array Arguments ..
137 REAL RWORK( * )
138 COMPLEX U( LDU, * ), WORK( * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 REAL ZERO, ONE
145 parameter( zero = 0.0e+0, one = 1.0e+0 )
146* ..
147* .. Local Scalars ..
148 CHARACTER TRANSU
149 INTEGER I, J, K, LDWORK, MNMIN
150 REAL EPS
151 COMPLEX TMP, ZDUM
152* ..
153* .. External Functions ..
154 LOGICAL LSAME
155 REAL CLANSY, SLAMCH
156 COMPLEX CDOTC
157 EXTERNAL lsame, clansy, slamch, cdotc
158* ..
159* .. External Subroutines ..
160 EXTERNAL cherk, claset
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC abs, aimag, cmplx, max, min, real
164* ..
165* .. Statement Functions ..
166 REAL CABS1
167* ..
168* .. Statement Function definitions ..
169 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( '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 claset( 'Upper', mnmin, mnmin, cmplx( zero ),
200 $ cmplx( one ), work, ldwork )
201 CALL cherk( 'Upper', transu, mnmin, k, -one, u, ldu, one, work,
202 $ ldwork )
203*
204* Compute norm( I - U*U' ) / ( K * EPS ) .
205*
206 resid = clansy( '1', 'Upper', mnmin, work, ldwork, rwork )
207 resid = ( resid / real( 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 - cdotc( m, u( 1, i ), 1, u( 1, j ), 1 )
220 resid = max( resid, cabs1( tmp ) )
221 10 CONTINUE
222 20 CONTINUE
223 resid = ( resid / real( 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 - cdotc( n, u( j, 1 ), ldu, u( i, 1 ), ldu )
236 resid = max( resid, cabs1( tmp ) )
237 30 CONTINUE
238 40 CONTINUE
239 resid = ( resid / real( n ) ) / eps
240 END IF
241 RETURN
242*
243* End of CUNT01
244*

◆ cunt03()

subroutine cunt03 ( character*( * ) rc,
integer mu,
integer mv,
integer n,
integer k,
complex, dimension( ldu, * ) u,
integer ldu,
complex, dimension( ldv, * ) v,
integer ldv,
complex, dimension( * ) work,
integer lwork,
real, dimension( * ) rwork,
real result,
integer info )

CUNT03

Purpose:
!>
!> CUNT03 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 CUNT03 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 CUNT03 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
!>          CUNT03 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 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 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 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 REAL array, dimension (max(MV,N))
!>
[out]RESULT
!>          RESULT is REAL
!>          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 cunt03.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 REAL RESULT
171* ..
172* .. Array Arguments ..
173 REAL RWORK( * )
174 COMPLEX U( LDU, * ), V( LDV, * ), WORK( * )
175* ..
176*
177* =====================================================================
178*
179*
180* .. Parameters ..
181 REAL ZERO, ONE
182 parameter( zero = 0.0e0, one = 1.0e0 )
183* ..
184* .. Local Scalars ..
185 INTEGER I, IRC, J, LMX
186 REAL RES1, RES2, ULP
187 COMPLEX S, SU, SV
188* ..
189* .. External Functions ..
190 LOGICAL LSAME
191 INTEGER ICAMAX
192 REAL SLAMCH
193 EXTERNAL lsame, icamax, slamch
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC abs, cmplx, max, min, real
197* ..
198* .. External Subroutines ..
199 EXTERNAL cunt01, xerbla
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( 'CUNT03', -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 = slamch( 'Precision' )
244*
245 IF( irc.EQ.0 ) THEN
246*
247* Compare rows
248*
249 res1 = zero
250 DO 20 i = 1, k
251 lmx = icamax( n, u( i, 1 ), ldu )
252 IF( v( i, lmx ).EQ.cmplx( 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.cmplx( 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 / ( real( n )*ulp )
268*
269* Compute orthogonality of rows of V.
270*
271 CALL cunt01( '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 = icamax( n, u( 1, i ), 1 )
280 IF( v( lmx, i ).EQ.cmplx( 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.cmplx( 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 / ( real( n )*ulp )
296*
297* Compute orthogonality of columns of V.
298*
299 CALL cunt01( '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 CUNT03
307*
icamax
integer function icamax(n, cx, incx)
ICAMAX
Definition icamax.f:71