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

Functions

subroutine cbdt05 (m, n, a, lda, s, ns, u, ldu, vt, ldvt, work, resid)
 CBDT05
subroutine dbdt01 (m, n, kd, a, lda, q, ldq, d, e, pt, ldpt, work, resid)
 DBDT01
subroutine dbdt02 (m, n, b, ldb, c, ldc, u, ldu, work, resid)
 DBDT02
subroutine dbdt03 (uplo, n, kd, d, e, u, ldu, s, vt, ldvt, work, resid)
 DBDT03
subroutine dbdt04 (uplo, n, d, e, s, ns, u, ldu, vt, ldvt, work, resid)
 DBDT04
subroutine dbdt05 (m, n, a, lda, s, ns, u, ldu, vt, ldvt, work, resid)
 DBDT05
subroutine dchkbb (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, result, info)
 DCHKBB
subroutine dchkbd (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, iwork, nout, info)
 DCHKBD
subroutine dchkbk (nin, nout)
 DCHKBK
subroutine dchkbl (nin, nout)
 DCHKBL
subroutine dchkec (thresh, tsterr, nin, nout)
 DCHKEC
program dchkee
 DCHKEE
subroutine dchkgg (nsizes, nn, ntypes, dotype, iseed, thresh, tstdif, thrshn, nounit, a, lda, b, h, t, s1, s2, p1, p2, u, ldu, v, q, z, alphr1, alphi1, beta1, alphr3, alphi3, beta3, evectl, evectr, work, lwork, llwork, result, info)
 DCHKGG
subroutine dchkgk (nin, nout)
 DCHKGK
subroutine dchkgl (nin, nout)
 DCHKGL
subroutine dchkhs (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, h, t1, t2, u, ldu, z, uz, wr1, wi1, wr2, wi2, wr3, wi3, evectl, evectr, evecty, evectx, uu, tau, work, nwork, iwork, select, result, info)
 DCHKHS
subroutine dchksb (nsizes, nn, nwdths, kk, ntypes, dotype, iseed, thresh, nounit, a, lda, sd, se, u, ldu, work, lwork, result, info)
 DCHKSB
subroutine dchksb2stg (nsizes, nn, nwdths, kk, ntypes, dotype, iseed, thresh, nounit, a, lda, sd, se, d1, d2, d3, u, ldu, work, lwork, result, info)
 DCHKSB2STG
subroutine dchkst (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, iwork, liwork, result, info)
 DCHKST
subroutine dchkst2stg (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, iwork, liwork, result, info)
 DCHKST2STG
subroutine dckcsd (nm, mval, pval, qval, nmats, iseed, thresh, mmax, x, xf, u1, u2, v1t, v2t, theta, iwork, work, rwork, nin, nout, info)
 DCKCSD
subroutine dckglm (nn, mval, pval, nval, nmats, iseed, thresh, nmax, a, af, b, bf, x, work, rwork, nin, nout, info)
 DCKGLM
subroutine dckgqr (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)
 DCKGQR
subroutine dckgsv (nm, mval, pval, nval, nmats, iseed, thresh, nmax, a, af, b, bf, u, v, q, alpha, beta, r, iwork, work, rwork, nin, nout, info)
 DCKGSV
subroutine dcklse (nn, mval, pval, nval, nmats, iseed, thresh, nmax, a, af, b, bf, x, work, rwork, nin, nout, info)
 DCKLSE
subroutine dcsdts (m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, theta, iwork, work, lwork, rwork, result)
 DCSDTS
subroutine ddrges (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, alphar, alphai, beta, work, lwork, result, bwork, info)
 DDRGES
subroutine ddrges3 (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, alphar, alphai, beta, work, lwork, result, bwork, info)
 DDRGES3
subroutine ddrgev (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, qe, ldqe, alphar, alphai, beta, alphr1, alphi1, beta1, work, lwork, result, info)
 DDRGEV
subroutine ddrgev3 (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, qe, ldqe, alphar, alphai, beta, alphr1, alphi1, beta1, work, lwork, result, info)
 DDRGEV3
subroutine ddrgsx (nsize, ncmax, thresh, nin, nout, a, lda, b, ai, bi, z, q, alphar, alphai, beta, c, ldc, s, work, lwork, iwork, liwork, bwork, info)
 DDRGSX
subroutine ddrgvx (nsize, thresh, nin, nout, a, lda, b, ai, bi, alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, s, dtru, dif, diftru, work, lwork, iwork, liwork, result, bwork, info)
 DDRGVX
subroutine ddrvbd (nsizes, mm, nn, ntypes, dotype, iseed, thresh, a, lda, u, ldu, vt, ldvt, asav, usav, vtsav, s, ssav, e, work, lwork, iwork, nout, info)
 DDRVBD
subroutine ddrves (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, h, ht, wr, wi, wrt, wit, vs, ldvs, result, work, nwork, iwork, bwork, info)
 DDRVES
subroutine ddrvev (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, h, wr, wi, wr1, wi1, vl, ldvl, vr, ldvr, lre, ldlre, result, work, nwork, iwork, info)
 DDRVEV
subroutine ddrvsg (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, ldb, d, z, ldz, ab, bb, ap, bp, work, nwork, iwork, liwork, result, info)
 DDRVSG
subroutine ddrvsg2stg (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, ldb, d, d2, z, ldz, ab, bb, ap, bp, work, nwork, iwork, liwork, result, info)
 DDRVSG2STG
subroutine ddrvst (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, d1, d2, d3, d4, eveigs, wa1, wa2, wa3, u, ldu, v, tau, z, work, lwork, iwork, liwork, result, info)
 DDRVST
subroutine ddrvst2stg (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, d1, d2, d3, d4, eveigs, wa1, wa2, wa3, u, ldu, v, tau, z, work, lwork, iwork, liwork, result, info)
 DDRVST2STG
subroutine ddrvsx (nsizes, nn, ntypes, dotype, iseed, thresh, niunit, nounit, a, lda, h, ht, wr, wi, wrt, wit, wrtmp, witmp, vs, ldvs, vs1, result, work, lwork, iwork, bwork, info)
 DDRVSX
subroutine ddrvvx (nsizes, nn, ntypes, dotype, iseed, thresh, niunit, nounit, a, lda, h, wr, wi, wr1, wi1, vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein, scale, scale1, result, work, nwork, iwork, info)
 DDRVVX
subroutine derrbd (path, nunit)
 DERRBD
subroutine derrec (path, nunit)
 DERREC
subroutine derred (path, nunit)
 DERRED
subroutine derrgg (path, nunit)
 DERRGG
subroutine derrhs (path, nunit)
 DERRHS
subroutine derrst (path, nunit)
 DERRST
subroutine dget02 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 DGET02
subroutine dget10 (m, n, a, lda, b, ldb, work, result)
 DGET10
subroutine dget22 (transa, transe, transw, n, a, lda, e, lde, wr, wi, work, result)
 DGET22
subroutine dget23 (comp, balanc, jtype, thresh, iseed, nounit, n, a, lda, h, wr, wi, wr1, wi1, vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein, scale, scale1, result, work, lwork, iwork, info)
 DGET23
subroutine dget24 (comp, jtype, thresh, iseed, nounit, n, a, lda, h, ht, wr, wi, wrt, wit, wrtmp, witmp, vs, ldvs, vs1, rcdein, rcdvin, nslct, islct, result, work, lwork, iwork, bwork, info)
 DGET24
subroutine dget31 (rmax, lmax, ninfo, knt)
 DGET31
subroutine dget32 (rmax, lmax, ninfo, knt)
 DGET32
subroutine dget33 (rmax, lmax, ninfo, knt)
 DGET33
subroutine dget34 (rmax, lmax, ninfo, knt)
 DGET34
subroutine dget35 (rmax, lmax, ninfo, knt)
 DGET35
subroutine dget36 (rmax, lmax, ninfo, knt, nin)
 DGET36
subroutine dget37 (rmax, lmax, ninfo, knt, nin)
 DGET37
subroutine dget38 (rmax, lmax, ninfo, knt, nin)
 DGET38
subroutine dget39 (rmax, lmax, ninfo, knt)
 DGET39
subroutine dget40 (rmax, lmax, ninfo, knt, nin)
 DGET40
subroutine dget51 (itype, n, a, lda, b, ldb, u, ldu, v, ldv, work, result)
 DGET51
subroutine dget52 (left, n, a, lda, b, ldb, e, lde, alphar, alphai, beta, work, result)
 DGET52
subroutine dget53 (a, lda, b, ldb, scale, wr, wi, result, info)
 DGET53
subroutine dget54 (n, a, lda, b, ldb, s, lds, t, ldt, u, ldu, v, ldv, work, result)
 DGET54
subroutine dglmts (n, m, p, a, af, lda, b, bf, ldb, d, df, x, u, work, lwork, rwork, result)
 DGLMTS
subroutine dgqrts (n, m, p, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
 DGQRTS
subroutine dgrqts (m, p, n, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
 DGRQTS
subroutine dgsvts3 (m, p, n, a, af, lda, b, bf, ldb, u, ldu, v, ldv, q, ldq, alpha, beta, r, ldr, iwork, work, lwork, rwork, result)
 DGSVTS3
subroutine dhst01 (n, ilo, ihi, a, lda, h, ldh, q, ldq, work, lwork, result)
 DHST01
subroutine dlafts (type, m, n, imat, ntests, result, iseed, thresh, iounit, ie)
 DLAFTS
subroutine dlahd2 (iounit, path)
 DLAHD2
subroutine dlarfy (uplo, n, v, incv, tau, c, ldc, work)
 DLARFY
subroutine dlarhs (path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
 DLARHS
subroutine dlasum (type, iounit, ie, nrun)
 DLASUM
subroutine dlatb9 (path, imat, m, p, n, type, kla, kua, klb, kub, anorm, bnorm, modea, modeb, cndnma, cndnmb, dista, distb)
 DLATB9
subroutine dlatm4 (itype, n, nz1, nz2, isign, amagn, rcond, triang, idist, iseed, a, lda)
 DLATM4
logical function dlctes (zr, zi, d)
 DLCTES
logical function dlctsx (ar, ai, beta)
 DLCTSX
subroutine dlsets (m, p, n, a, af, lda, b, bf, ldb, c, cf, d, df, x, work, lwork, rwork, result)
 DLSETS
subroutine dort01 (rowcol, m, n, u, ldu, work, lwork, resid)
 DORT01
subroutine dort03 (rc, mu, mv, n, k, u, ldu, v, ldv, work, lwork, result, info)
 DORT03
subroutine dsbt21 (uplo, n, ka, ks, a, lda, d, e, u, ldu, work, result)
 DSBT21
subroutine dsgt01 (itype, uplo, n, m, a, lda, b, ldb, z, ldz, d, work, result)
 DSGT01
logical function dslect (zr, zi)
 DSLECT
subroutine dspt21 (itype, uplo, n, kband, ap, d, e, u, ldu, vp, tau, work, result)
 DSPT21
subroutine dstech (n, a, b, eig, tol, work, info)
 DSTECH
subroutine dstect (n, a, b, shift, num)
 DSTECT
subroutine dstt21 (n, kband, ad, ae, sd, se, u, ldu, work, result)
 DSTT21
subroutine dstt22 (n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, result)
 DSTT22
subroutine dsvdch (n, s, e, svd, tol, info)
 DSVDCH
subroutine dsvdct (n, s, e, shift, num)
 DSVDCT
double precision function dsxt1 (ijob, d1, n1, d2, n2, abstol, ulp, unfl)
 DSXT1
subroutine dsyt21 (itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, result)
 DSYT21
subroutine dsyt22 (itype, uplo, n, m, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, result)
 DSYT22
subroutine sbdt04 (uplo, n, d, e, s, ns, u, ldu, vt, ldvt, work, resid)
 SBDT04
subroutine sbdt05 (m, n, a, lda, s, ns, u, ldu, vt, ldvt, work, resid)
 SBDT05
subroutine sget40 (rmax, lmax, ninfo, knt, nin)
 SGET40
subroutine zbdt05 (m, n, a, lda, s, ns, u, ldu, vt, ldvt, work, resid)
 ZBDT05

Detailed Description

This is the group of double LAPACK TESTING EIG routines.

Function Documentation

◆ cbdt05()

subroutine cbdt05 ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) s,
integer ns,
complex, dimension( * ) u,
integer ldu,
complex, dimension( ldvt, * ) vt,
integer ldvt,
complex, dimension( * ) work,
real resid )

CBDT05

Purpose:
!>
!> CBDT05 reconstructs a bidiagonal matrix B from its (partial) 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( S - U' * B * V ) / ( n * norm(B) * EPS )
!> where VT = V' and EPS is the machine precision.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrices A and U.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and VT.
!>
[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]S
!>          S is REAL array, dimension (NS)
!>          The singular values from the (partial) SVD of B, sorted in
!>          decreasing order.
!>
[in]NS
!>          NS is INTEGER
!>          The number of singular values/vectors from the (partial)
!>          SVD of B.
!>
[in]U
!>          U is COMPLEX array, dimension (LDU,NS)
!>          The n by ns orthogonal matrix U in S = U' * B * V.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,N)
!>
[in]VT
!>          VT is COMPLEX array, dimension (LDVT,N)
!>          The n by ns orthogonal matrix V in S = U' * B * V.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (M,N)
!>
[out]RESID
!>          RESID is REAL
!>          The test ratio:  norm(S - U' * A * V) / ( n * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file cbdt05.f.

125*
126* -- LAPACK test routine --
127* -- LAPACK is a software package provided by Univ. of Tennessee, --
128* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
129*
130* .. Scalar Arguments ..
131 INTEGER LDA, LDU, LDVT, M, N, NS
132 REAL RESID
133* ..
134* .. Array Arguments ..
135 REAL S( * )
136 COMPLEX A( LDA, * ), U( * ), VT( LDVT, * ), WORK( * )
137* ..
138*
139* ======================================================================
140*
141* .. Parameters ..
142 REAL ZERO, ONE
143 parameter( zero = 0.0e+0, one = 1.0e+0 )
144 COMPLEX CZERO, CONE
145 parameter( czero = ( 0.0e+0, 0.0e+0 ),
146 $ cone = ( 1.0e+0, 0.0e+0 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER I, J
150 REAL ANORM, EPS
151* ..
152* .. Local Arrays ..
153 REAL DUM( 1 )
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 INTEGER ISAMAX
158 REAL SASUM, SCASUM, SLAMCH, CLANGE
159 EXTERNAL lsame, isamax, sasum, scasum, slamch, clange
160* ..
161* .. External Subroutines ..
162 EXTERNAL cgemm
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC abs, real, max, min
166* ..
167* .. Executable Statements ..
168*
169* Quick return if possible.
170*
171 resid = zero
172 IF( min( m, n ).LE.0 .OR. ns.LE.0 )
173 $ RETURN
174*
175 eps = slamch( 'Precision' )
176 anorm = clange( 'M', m, n, a, lda, dum )
177*
178* Compute U' * A * V.
179*
180 CALL cgemm( 'N', 'C', m, ns, n, cone, a, lda, vt,
181 $ ldvt, czero, work( 1+ns*ns ), m )
182 CALL cgemm( 'C', 'N', ns, ns, m, -cone, u, ldu, work( 1+ns*ns ),
183 $ m, czero, work, ns )
184*
185* norm(S - U' * B * V)
186*
187 j = 0
188 DO 10 i = 1, ns
189 work( j+i ) = work( j+i ) + cmplx( s( i ), zero )
190 resid = max( resid, scasum( ns, work( j+1 ), 1 ) )
191 j = j + ns
192 10 CONTINUE
193*
194 IF( anorm.LE.zero ) THEN
195 IF( resid.NE.zero )
196 $ resid = one / eps
197 ELSE
198 IF( anorm.GE.resid ) THEN
199 resid = ( resid / anorm ) / ( real( n )*eps )
200 ELSE
201 IF( anorm.LT.one ) THEN
202 resid = ( min( resid, real( n )*anorm ) / anorm ) /
203 $ ( real( n )*eps )
204 ELSE
205 resid = min( resid / anorm, real( n ) ) /
206 $ ( real( n )*eps )
207 END IF
208 END IF
209 END IF
210*
211 RETURN
212*
213* End of CBDT05
214*
cmplx
float cmplx[2]
Definition pblas.h:136
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
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
cgemm
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:187
sasum
real function sasum(n, sx, incx)
SASUM
Definition sasum.f:72
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

◆ dbdt01()

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

DBDT01

Purpose:
!>
!> DBDT01 reconstructs a general matrix A from its bidiagonal form
!>    A = Q * B * P**T
!> where Q (m by min(m,n)) and P**T (min(m,n) by n) are orthogonal
!> matrices and B is bidiagonal.
!>
!> The test ratio to test the reduction is
!>    RESID = norm(A - Q * B * P**T) / ( 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**T.
!>
[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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDQ,N)
!>          The m by min(m,n) orthogonal matrix Q in the reduction
!>          A = Q * B * P**T.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,M).
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (min(M,N)-1)
!>          The superdiagonal elements of the bidiagonal matrix B if
!>          m >= n, or the subdiagonal elements of B if m < n.
!>
[in]PT
!>          PT is DOUBLE PRECISION array, dimension (LDPT,N)
!>          The min(m,n) by n orthogonal matrix P**T in the reduction
!>          A = Q * B * P**T.
!>
[in]LDPT
!>          LDPT is INTEGER
!>          The leading dimension of the array PT.
!>          LDPT >= max(1,min(M,N)).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (M+N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The test ratio:
!>          norm(A - Q * B * P**T) / ( n * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 139 of file dbdt01.f.

141*
142* -- LAPACK test routine --
143* -- LAPACK is a software package provided by Univ. of Tennessee, --
144* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
145*
146* .. Scalar Arguments ..
147 INTEGER KD, LDA, LDPT, LDQ, M, N
148 DOUBLE PRECISION RESID
149* ..
150* .. Array Arguments ..
151 DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), PT( LDPT, * ),
152 $ Q( LDQ, * ), WORK( * )
153* ..
154*
155* =====================================================================
156*
157* .. Parameters ..
158 DOUBLE PRECISION ZERO, ONE
159 parameter( zero = 0.0d+0, one = 1.0d+0 )
160* ..
161* .. Local Scalars ..
162 INTEGER I, J
163 DOUBLE PRECISION ANORM, EPS
164* ..
165* .. External Functions ..
166 DOUBLE PRECISION DASUM, DLAMCH, DLANGE
167 EXTERNAL dasum, dlamch, dlange
168* ..
169* .. External Subroutines ..
170 EXTERNAL dcopy, dgemv
171* ..
172* .. Intrinsic Functions ..
173 INTRINSIC dble, max, min
174* ..
175* .. Executable Statements ..
176*
177* Quick return if possible
178*
179 IF( m.LE.0 .OR. n.LE.0 ) THEN
180 resid = zero
181 RETURN
182 END IF
183*
184* Compute A - Q * B * P**T one column at a time.
185*
186 resid = zero
187 IF( kd.NE.0 ) THEN
188*
189* B is bidiagonal.
190*
191 IF( kd.NE.0 .AND. m.GE.n ) THEN
192*
193* B is upper bidiagonal and M >= N.
194*
195 DO 20 j = 1, n
196 CALL dcopy( m, a( 1, j ), 1, work, 1 )
197 DO 10 i = 1, n - 1
198 work( m+i ) = d( i )*pt( i, j ) + e( i )*pt( i+1, j )
199 10 CONTINUE
200 work( m+n ) = d( n )*pt( n, j )
201 CALL dgemv( 'No transpose', m, n, -one, q, ldq,
202 $ work( m+1 ), 1, one, work, 1 )
203 resid = max( resid, dasum( m, work, 1 ) )
204 20 CONTINUE
205 ELSE IF( kd.LT.0 ) THEN
206*
207* B is upper bidiagonal and M < N.
208*
209 DO 40 j = 1, n
210 CALL dcopy( m, a( 1, j ), 1, work, 1 )
211 DO 30 i = 1, m - 1
212 work( m+i ) = d( i )*pt( i, j ) + e( i )*pt( i+1, j )
213 30 CONTINUE
214 work( m+m ) = d( m )*pt( m, j )
215 CALL dgemv( 'No transpose', m, m, -one, q, ldq,
216 $ work( m+1 ), 1, one, work, 1 )
217 resid = max( resid, dasum( m, work, 1 ) )
218 40 CONTINUE
219 ELSE
220*
221* B is lower bidiagonal.
222*
223 DO 60 j = 1, n
224 CALL dcopy( m, a( 1, j ), 1, work, 1 )
225 work( m+1 ) = d( 1 )*pt( 1, j )
226 DO 50 i = 2, m
227 work( m+i ) = e( i-1 )*pt( i-1, j ) +
228 $ d( i )*pt( i, j )
229 50 CONTINUE
230 CALL dgemv( 'No transpose', m, m, -one, q, ldq,
231 $ work( m+1 ), 1, one, work, 1 )
232 resid = max( resid, dasum( m, work, 1 ) )
233 60 CONTINUE
234 END IF
235 ELSE
236*
237* B is diagonal.
238*
239 IF( m.GE.n ) THEN
240 DO 80 j = 1, n
241 CALL dcopy( m, a( 1, j ), 1, work, 1 )
242 DO 70 i = 1, n
243 work( m+i ) = d( i )*pt( i, j )
244 70 CONTINUE
245 CALL dgemv( 'No transpose', m, n, -one, q, ldq,
246 $ work( m+1 ), 1, one, work, 1 )
247 resid = max( resid, dasum( m, work, 1 ) )
248 80 CONTINUE
249 ELSE
250 DO 100 j = 1, n
251 CALL dcopy( m, a( 1, j ), 1, work, 1 )
252 DO 90 i = 1, m
253 work( m+i ) = d( i )*pt( i, j )
254 90 CONTINUE
255 CALL dgemv( 'No transpose', m, m, -one, q, ldq,
256 $ work( m+1 ), 1, one, work, 1 )
257 resid = max( resid, dasum( m, work, 1 ) )
258 100 CONTINUE
259 END IF
260 END IF
261*
262* Compute norm(A - Q * B * P**T) / ( n * norm(A) * EPS )
263*
264 anorm = dlange( '1', m, n, a, lda, work )
265 eps = dlamch( 'Precision' )
266*
267 IF( anorm.LE.zero ) THEN
268 IF( resid.NE.zero )
269 $ resid = one / eps
270 ELSE
271 IF( anorm.GE.resid ) THEN
272 resid = ( resid / anorm ) / ( dble( n )*eps )
273 ELSE
274 IF( anorm.LT.one ) THEN
275 resid = ( min( resid, dble( n )*anorm ) / anorm ) /
276 $ ( dble( n )*eps )
277 ELSE
278 resid = min( resid / anorm, dble( n ) ) /
279 $ ( dble( n )*eps )
280 END IF
281 END IF
282 END IF
283*
284 RETURN
285*
286* End of DBDT01
287*
dlange
double precision function dlange(norm, m, n, a, lda, work)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition dlange.f:114
dasum
double precision function dasum(n, dx, incx)
DASUM
Definition dasum.f:71
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82
dgemv
subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
DGEMV
Definition dgemv.f:156
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69

◆ dbdt02()

subroutine dbdt02 ( integer m,
integer n,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( ldu, * ) u,
integer ldu,
double precision, dimension( * ) work,
double precision resid )

DBDT02

Purpose:
!>
!> DBDT02 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          RESID = norm(B - U * C) / ( max(m,n) * norm(B) * EPS ),
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 111 of file dbdt02.f.

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

◆ dbdt03()

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

DBDT03

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

Definition at line 133 of file dbdt03.f.

135*
136* -- LAPACK test routine --
137* -- LAPACK is a software package provided by Univ. of Tennessee, --
138* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
139*
140* .. Scalar Arguments ..
141 CHARACTER UPLO
142 INTEGER KD, LDU, LDVT, N
143 DOUBLE PRECISION RESID
144* ..
145* .. Array Arguments ..
146 DOUBLE PRECISION D( * ), E( * ), S( * ), U( LDU, * ),
147 $ VT( LDVT, * ), WORK( * )
148* ..
149*
150* ======================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d+0, one = 1.0d+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER I, J
158 DOUBLE PRECISION BNORM, EPS
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 INTEGER IDAMAX
163 DOUBLE PRECISION DASUM, DLAMCH
164 EXTERNAL lsame, idamax, dasum, dlamch
165* ..
166* .. External Subroutines ..
167 EXTERNAL dgemv
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, dble, max, min
171* ..
172* .. Executable Statements ..
173*
174* Quick return if possible
175*
176 resid = zero
177 IF( n.LE.0 )
178 $ RETURN
179*
180* Compute B - U * S * V' one column at a time.
181*
182 bnorm = zero
183 IF( kd.GE.1 ) THEN
184*
185* B is bidiagonal.
186*
187 IF( lsame( uplo, 'U' ) ) THEN
188*
189* B is upper bidiagonal.
190*
191 DO 20 j = 1, n
192 DO 10 i = 1, n
193 work( n+i ) = s( i )*vt( i, j )
194 10 CONTINUE
195 CALL dgemv( 'No transpose', n, n, -one, u, ldu,
196 $ work( n+1 ), 1, 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, dasum( 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 dgemv( 'No transpose', n, n, -one, u, ldu,
215 $ work( n+1 ), 1, 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, dasum( 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 dgemv( 'No transpose', n, n, -one, u, ldu, work( n+1 ),
235 $ 1, zero, work, 1 )
236 work( j ) = work( j ) + d( j )
237 resid = max( resid, dasum( n, work, 1 ) )
238 60 CONTINUE
239 j = idamax( n, d, 1 )
240 bnorm = abs( d( j ) )
241 END IF
242*
243* Compute norm(B - U * S * V') / ( n * norm(B) * EPS )
244*
245 eps = dlamch( 'Precision' )
246*
247 IF( bnorm.LE.zero ) THEN
248 IF( resid.NE.zero )
249 $ resid = one / eps
250 ELSE
251 IF( bnorm.GE.resid ) THEN
252 resid = ( resid / bnorm ) / ( dble( n )*eps )
253 ELSE
254 IF( bnorm.LT.one ) THEN
255 resid = ( min( resid, dble( n )*bnorm ) / bnorm ) /
256 $ ( dble( n )*eps )
257 ELSE
258 resid = min( resid / bnorm, dble( n ) ) /
259 $ ( dble( n )*eps )
260 END IF
261 END IF
262 END IF
263*
264 RETURN
265*
266* End of DBDT03
267*
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71

◆ dbdt04()

subroutine dbdt04 ( character uplo,
integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision, dimension( * ) s,
integer ns,
double precision, dimension( ldu, * ) u,
integer ldu,
double precision, dimension( ldvt, * ) vt,
integer ldvt,
double precision, dimension( * ) work,
double precision resid )

DBDT04

Purpose:
!>
!> DBDT04 reconstructs a bidiagonal matrix B from its (partial) 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( S - U' * B * V ) / ( 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]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the bidiagonal matrix B.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) superdiagonal elements of the bidiagonal matrix B
!>          if UPLO = 'U', or the (n-1) subdiagonal elements of B if
!>          UPLO = 'L'.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (NS)
!>          The singular values from the (partial) SVD of B, sorted in
!>          decreasing order.
!>
[in]NS
!>          NS is INTEGER
!>          The number of singular values/vectors from the (partial)
!>          SVD of B.
!>
[in]U
!>          U is DOUBLE PRECISION array, dimension (LDU,NS)
!>          The n by ns orthogonal matrix U in S = U' * B * V.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,N)
!>
[in]VT
!>          VT is DOUBLE PRECISION array, dimension (LDVT,N)
!>          The n by ns orthogonal matrix V in S = U' * B * V.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (2*N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The test ratio:  norm(S - U' * B * V) / ( n * norm(B) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file dbdt04.f.

131*
132* -- LAPACK test routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136* .. Scalar Arguments ..
137 CHARACTER UPLO
138 INTEGER LDU, LDVT, N, NS
139 DOUBLE PRECISION RESID
140* ..
141* .. Array Arguments ..
142 DOUBLE PRECISION D( * ), E( * ), S( * ), U( LDU, * ),
143 $ VT( LDVT, * ), WORK( * )
144* ..
145*
146* ======================================================================
147*
148* .. Parameters ..
149 DOUBLE PRECISION ZERO, ONE
150 parameter( zero = 0.0d+0, one = 1.0d+0 )
151* ..
152* .. Local Scalars ..
153 INTEGER I, J, K
154 DOUBLE PRECISION BNORM, EPS
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 INTEGER IDAMAX
159 DOUBLE PRECISION DASUM, DLAMCH
160 EXTERNAL lsame, idamax, dasum, dlamch
161* ..
162* .. External Subroutines ..
163 EXTERNAL dgemm
164* ..
165* .. Intrinsic Functions ..
166 INTRINSIC abs, dble, max, min
167* ..
168* .. Executable Statements ..
169*
170* Quick return if possible.
171*
172 resid = zero
173 IF( n.LE.0 .OR. ns.LE.0 )
174 $ RETURN
175*
176 eps = dlamch( 'Precision' )
177*
178* Compute S - U' * B * V.
179*
180 bnorm = zero
181*
182 IF( lsame( uplo, 'U' ) ) THEN
183*
184* B is upper bidiagonal.
185*
186 k = 0
187 DO 20 i = 1, ns
188 DO 10 j = 1, n-1
189 k = k + 1
190 work( k ) = d( j )*vt( i, j ) + e( j )*vt( i, j+1 )
191 10 CONTINUE
192 k = k + 1
193 work( k ) = d( n )*vt( i, n )
194 20 CONTINUE
195 bnorm = abs( d( 1 ) )
196 DO 30 i = 2, n
197 bnorm = max( bnorm, abs( d( i ) )+abs( e( i-1 ) ) )
198 30 CONTINUE
199 ELSE
200*
201* B is lower bidiagonal.
202*
203 k = 0
204 DO 50 i = 1, ns
205 k = k + 1
206 work( k ) = d( 1 )*vt( i, 1 )
207 DO 40 j = 1, n-1
208 k = k + 1
209 work( k ) = e( j )*vt( i, j ) + d( j+1 )*vt( i, j+1 )
210 40 CONTINUE
211 50 CONTINUE
212 bnorm = abs( d( n ) )
213 DO 60 i = 1, n-1
214 bnorm = max( bnorm, abs( d( i ) )+abs( e( i ) ) )
215 60 CONTINUE
216 END IF
217*
218 CALL dgemm( 'T', 'N', ns, ns, n, -one, u, ldu, work( 1 ),
219 $ n, zero, work( 1+n*ns ), ns )
220*
221* norm(S - U' * B * V)
222*
223 k = n*ns
224 DO 70 i = 1, ns
225 work( k+i ) = work( k+i ) + s( i )
226 resid = max( resid, dasum( ns, work( k+1 ), 1 ) )
227 k = k + ns
228 70 CONTINUE
229*
230 IF( bnorm.LE.zero ) THEN
231 IF( resid.NE.zero )
232 $ resid = one / eps
233 ELSE
234 IF( bnorm.GE.resid ) THEN
235 resid = ( resid / bnorm ) / ( dble( n )*eps )
236 ELSE
237 IF( bnorm.LT.one ) THEN
238 resid = ( min( resid, dble( n )*bnorm ) / bnorm ) /
239 $ ( dble( n )*eps )
240 ELSE
241 resid = min( resid / bnorm, dble( n ) ) /
242 $ ( dble( n )*eps )
243 END IF
244 END IF
245 END IF
246*
247 RETURN
248*
249* End of DBDT04
250*
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187

◆ dbdt05()

subroutine dbdt05 ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) s,
integer ns,
double precision, dimension( ldu, * ) u,
integer ldu,
double precision, dimension( ldvt, * ) vt,
integer ldvt,
double precision, dimension( * ) work,
double precision resid )

DBDT05

Purpose:
!>
!> DBDT05 reconstructs a bidiagonal matrix B from its (partial) 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( S - U' * B * V ) / ( n * norm(B) * EPS )
!> where VT = V' and EPS is the machine precision.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrices A and U.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and VT.
!>
[in]A
!>          A is DOUBLE PRECISION 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]S
!>          S is DOUBLE PRECISION array, dimension (NS)
!>          The singular values from the (partial) SVD of B, sorted in
!>          decreasing order.
!>
[in]NS
!>          NS is INTEGER
!>          The number of singular values/vectors from the (partial)
!>          SVD of B.
!>
[in]U
!>          U is DOUBLE PRECISION array, dimension (LDU,NS)
!>          The n by ns orthogonal matrix U in S = U' * B * V.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,N)
!>
[in]VT
!>          VT is DOUBLE PRECISION array, dimension (LDVT,N)
!>          The n by ns orthogonal matrix V in S = U' * B * V.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (M,N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The test ratio:  norm(S - U' * A * V) / ( n * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 125 of file dbdt05.f.

127*
128* -- LAPACK test routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 INTEGER LDA, LDU, LDVT, M, N, NS
134 DOUBLE PRECISION RESID
135* ..
136* .. Array Arguments ..
137 DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),
138 $ VT( LDVT, * ), WORK( * )
139* ..
140*
141* ======================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ZERO, ONE
145 parameter( zero = 0.0d+0, one = 1.0d+0 )
146* ..
147* .. Local Scalars ..
148 INTEGER I, J
149 DOUBLE PRECISION ANORM, EPS
150* ..
151* .. External Functions ..
152 LOGICAL LSAME
153 INTEGER IDAMAX
154 DOUBLE PRECISION DASUM, DLAMCH, DLANGE
155 EXTERNAL lsame, idamax, dasum, dlamch, dlange
156* ..
157* .. External Subroutines ..
158 EXTERNAL dgemm
159* ..
160* .. Intrinsic Functions ..
161 INTRINSIC abs, dble, max, min
162* ..
163* .. Executable Statements ..
164*
165* Quick return if possible.
166*
167 resid = zero
168 IF( min( m, n ).LE.0 .OR. ns.LE.0 )
169 $ RETURN
170*
171 eps = dlamch( 'Precision' )
172 anorm = dlange( 'M', m, n, a, lda, work )
173*
174* Compute U' * A * V.
175*
176 CALL dgemm( 'N', 'T', m, ns, n, one, a, lda, vt,
177 $ ldvt, zero, work( 1+ns*ns ), m )
178 CALL dgemm( 'T', 'N', ns, ns, m, -one, u, ldu, work( 1+ns*ns ),
179 $ m, zero, work, ns )
180*
181* norm(S - U' * B * V)
182*
183 j = 0
184 DO 10 i = 1, ns
185 work( j+i ) = work( j+i ) + s( i )
186 resid = max( resid, dasum( ns, work( j+1 ), 1 ) )
187 j = j + ns
188 10 CONTINUE
189*
190 IF( anorm.LE.zero ) THEN
191 IF( resid.NE.zero )
192 $ resid = one / eps
193 ELSE
194 IF( anorm.GE.resid ) THEN
195 resid = ( resid / anorm ) / ( dble( n )*eps )
196 ELSE
197 IF( anorm.LT.one ) THEN
198 resid = ( min( resid, dble( n )*anorm ) / anorm ) /
199 $ ( dble( n )*eps )
200 ELSE
201 resid = min( resid / anorm, dble( n ) ) /
202 $ ( dble( n )*eps )
203 END IF
204 END IF
205 END IF
206*
207 RETURN
208*
209* End of DBDT05
210*

◆ dchkbb()

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

DCHKBB

Purpose:
!>
!> DCHKBB tests the reduction of a general real rectangular band
!> matrix to bidiagonal form.
!>
!> DGBBRD factors a general band matrix A as  Q B P* , where * means
!> transpose, B is upper bidiagonal, and Q and P are orthogonal;
!> DGBBRD 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, DCHKBB 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,
!>          DCHKBB 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, DCHKBB
!>          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 DCHKBB to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension
!>                            (LDA, max(NN))
!>          Used to hold the matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least max( NN ).
!>
[out]AB
!>          AB is DOUBLE PRECISION array, dimension (LDAB, max(NN))
!>          Used to hold A in band storage format.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of AB.  It must be at least 2 (not 1!)
!>          and at least max( KK )+1.
!>
[out]BD
!>          BD is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the diagonal of the bidiagonal matrix computed
!>          by DGBBRD.
!>
[out]BE
!>          BE is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the off-diagonal of the bidiagonal matrix
!>          computed by DGBBRD.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ, max(NN))
!>          Used to hold the orthogonal matrix Q computed by DGBBRD.
!>
[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 DOUBLE PRECISION array, dimension (LDP, max(NN))
!>          Used to hold the orthogonal matrix P computed by DGBBRD.
!>
[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 DOUBLE PRECISION array, dimension (LDC, max(NN))
!>          Used to hold the matrix C updated by DGBBRD.
!>
[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 DOUBLE PRECISION array, dimension (LDC, max(NN))
!>          Used to hold a copy of the matrix C.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far.
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 351 of file dchkbb.f.

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

◆ dchkbd()

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

DCHKBD

Purpose:
!>
!> DCHKBD checks the singular value decomposition (SVD) routines.
!>
!> DGEBRD reduces a real general m by n matrix A to upper or lower
!> bidiagonal form B 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.
!>
!> DORGBR generates the orthogonal matrices Q and P' from DGEBRD.
!> Note that Q and P are not necessarily square.
!>
!> DBDSQR 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, DBDSQR has an option to apply the left orthogonal matrix
!> U to a matrix X, useful in least squares applications.
!>
!> DBDSDC computes the singular value decomposition of the bidiagonal
!> matrix B as B = U S V' using divide-and-conquer. It is called twice
!> 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.
!>
!>  DBDSVDX computes the singular value decomposition of the bidiagonal
!>  matrix B as B = U S V' using bisection and inverse iteration. It is
!>  called six times to compute
!>     1) B = U S1 V', RANGE='A', 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) B = U S1 V', RANGE='I', with 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
!>     4) Same as 3), but the singular values are stored in S2 and the
!>         singular vectors are not computed.
!>     5) B = U S1 V', RANGE='V', with 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
!>     6) Same as 5), but the singular values are stored in S2 and the
!>         singular vectors are not computed.
!>
!> 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 DGEBRD and DORGBR
!>
!> (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 DBDSQR 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)   | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
!>                                   computing U and V.
!>
!> (10)  0 if the true singular values of B are within THRESH of
!>       those in S1.  2*THRESH if they are not.  (Tested using
!>       DSVDCH)
!>
!> Test DBDSQR 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 )
!>
!> Test DBDSDC on bidiagonal matrix B
!>
!> (15)  | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
!>
!> (16)  | I - U' U | / ( min(M,N) ulp )
!>
!> (17)  | I - VT VT' | / ( min(M,N) ulp )
!>
!> (18)  S1 contains min(M,N) nonnegative values in decreasing order.
!>       (Return 0 if true, 1/ULP if false.)
!>
!> (19)  | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
!>                                   computing U and V.
!>  Test DBDSVDX on bidiagonal matrix B
!>
!>  (20)  | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
!>
!>  (21)  | I - U' U | / ( min(M,N) ulp )
!>
!>  (22)  | I - VT VT' | / ( min(M,N) ulp )
!>
!>  (23)  S1 contains min(M,N) nonnegative values in decreasing order.
!>        (Return 0 if true, 1/ULP if false.)
!>
!>  (24)  | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
!>                                    computing U and V.
!>
!>  (25)  | S1 - U' B VT' | / ( |S| n ulp )    DBDSVDX('V', 'I')
!>
!>  (26)  | I - U' U | / ( min(M,N) ulp )
!>
!>  (27)  | I - VT VT' | / ( min(M,N) ulp )
!>
!>  (28)  S1 contains min(M,N) nonnegative values in decreasing order.
!>        (Return 0 if true, 1/ULP if false.)
!>
!>  (29)  | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
!>                                    computing U and V.
!>
!>  (30)  | S1 - U' B VT' | / ( |S1| n ulp )   DBDSVDX('V', 'V')
!>
!>  (31)  | I - U' U | / ( min(M,N) ulp )
!>
!>  (32)  | I - VT VT' | / ( min(M,N) ulp )
!>
!>  (33)  S1 contains min(M,N) nonnegative values in decreasing order.
!>        (Return 0 if true, 1/ULP if false.)
!>
!>  (34)  | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
!>                                    computing U and V.
!>
!> 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) DGEBRD 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, DCHKBD
!>          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 DBDSQR.  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 DCHKBD to continue the same random
!>          number sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.  Note that the
!>          expected value of the test ratios is O(1), so THRESH should
!>          be a reasonably small multiple of 1, e.g., 10 or 100.
!>
[out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,NMAX)
!>          where NMAX is the maximum value of N in NVAL.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,MMAX),
!>          where MMAX is the maximum value of M in MVAL.
!>
[out]BD
!>          BD is DOUBLE PRECISION array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]BE
!>          BE is DOUBLE PRECISION array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]S1
!>          S1 is DOUBLE PRECISION array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]S2
!>          S2 is DOUBLE PRECISION array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]X
!>          X is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>
[out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDX,NRHS)
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ,MMAX)
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,MMAX).
!>
[out]PT
!>          PT is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension
!>                      (LDPT,max(min(MVAL(j),NVAL(j))))
!>
[out]VT
!>          VT is DOUBLE PRECISION array, dimension
!>                      (LDPT,max(min(MVAL(j),NVAL(j))))
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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]IWORK
!>          IWORK is INTEGER array, dimension at least 8*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: LDPT< 1 or LDPT< MNMAX.
!>          -27: LWORK too small.
!>          If  DLATMR, SLATMS, DGEBRD, DORGBR, or DBDSQR,
!>              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 489 of file dchkbd.f.

493*
494* -- LAPACK test routine --
495* -- LAPACK is a software package provided by Univ. of Tennessee, --
496* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
497*
498* .. Scalar Arguments ..
499 INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS,
500 $ NSIZES, NTYPES
501 DOUBLE PRECISION THRESH
502* ..
503* .. Array Arguments ..
504 LOGICAL DOTYPE( * )
505 INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * )
506 DOUBLE PRECISION A( LDA, * ), BD( * ), BE( * ), PT( LDPT, * ),
507 $ Q( LDQ, * ), S1( * ), S2( * ), U( LDPT, * ),
508 $ VT( LDPT, * ), WORK( * ), X( LDX, * ),
509 $ Y( LDX, * ), Z( LDX, * )
510* ..
511*
512* ======================================================================
513*
514* .. Parameters ..
515 DOUBLE PRECISION ZERO, ONE, TWO, HALF
516 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
517 $ half = 0.5d0 )
518 INTEGER MAXTYP
519 parameter( maxtyp = 16 )
520* ..
521* .. Local Scalars ..
522 LOGICAL BADMM, BADNN, BIDIAG
523 CHARACTER UPLO
524 CHARACTER*3 PATH
525 INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, IWBD,
526 $ IWBE, IWBS, IWBZ, IWWORK, J, JCOL, JSIZE,
527 $ JTYPE, LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN,
528 $ MNMIN2, MQ, MTYPES, N, NFAIL, NMAX,
529 $ NS1, NS2, NTEST
530 DOUBLE PRECISION ABSTOL, AMNINV, ANORM, COND, OVFL, RTOVFL,
531 $ RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL,
532 $ VL, VU
533* ..
534* .. Local Arrays ..
535 INTEGER IDUM( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
536 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
537 $ KTYPE( MAXTYP )
538 DOUBLE PRECISION DUM( 1 ), DUMMA( 1 ), RESULT( 40 )
539* ..
540* .. External Functions ..
541 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
542 EXTERNAL dlamch, dlarnd, dsxt1
543* ..
544* .. External Subroutines ..
545 EXTERNAL alasum, dbdsdc, dbdsqr, dbdsvdx, dbdt01,
546 $ dbdt02, dbdt03, dbdt04, dcopy, dgebrd,
547 $ dgemm, dlabad, dlacpy, dlahd2, dlaset,
548 $ dlatmr, dlatms, dorgbr, dort01, xerbla
549* ..
550* .. Intrinsic Functions ..
551 INTRINSIC abs, exp, int, log, max, min, sqrt
552* ..
553* .. Scalars in Common ..
554 LOGICAL LERR, OK
555 CHARACTER*32 SRNAMT
556 INTEGER INFOT, NUNIT
557* ..
558* .. Common blocks ..
559 COMMON / infoc / infot, nunit, ok, lerr
560 COMMON / srnamc / srnamt
561* ..
562* .. Data statements ..
563 DATA ktype / 1, 2, 5*4, 5*6, 3*9, 10 /
564 DATA kmagn / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 /
565 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
566 $ 0, 0, 0 /
567* ..
568* .. Executable Statements ..
569*
570* Check for errors
571*
572 info = 0
573*
574 badmm = .false.
575 badnn = .false.
576 mmax = 1
577 nmax = 1
578 mnmax = 1
579 minwrk = 1
580 DO 10 j = 1, nsizes
581 mmax = max( mmax, mval( j ) )
582 IF( mval( j ).LT.0 )
583 $ badmm = .true.
584 nmax = max( nmax, nval( j ) )
585 IF( nval( j ).LT.0 )
586 $ badnn = .true.
587 mnmax = max( mnmax, min( mval( j ), nval( j ) ) )
588 minwrk = max( minwrk, 3*( mval( j )+nval( j ) ),
589 $ mval( j )*( mval( j )+max( mval( j ), nval( j ),
590 $ nrhs )+1 )+nval( j )*min( nval( j ), mval( j ) ) )
591 10 CONTINUE
592*
593* Check for errors
594*
595 IF( nsizes.LT.0 ) THEN
596 info = -1
597 ELSE IF( badmm ) THEN
598 info = -2
599 ELSE IF( badnn ) THEN
600 info = -3
601 ELSE IF( ntypes.LT.0 ) THEN
602 info = -4
603 ELSE IF( nrhs.LT.0 ) THEN
604 info = -6
605 ELSE IF( lda.LT.mmax ) THEN
606 info = -11
607 ELSE IF( ldx.LT.mmax ) THEN
608 info = -17
609 ELSE IF( ldq.LT.mmax ) THEN
610 info = -21
611 ELSE IF( ldpt.LT.mnmax ) THEN
612 info = -23
613 ELSE IF( minwrk.GT.lwork ) THEN
614 info = -27
615 END IF
616*
617 IF( info.NE.0 ) THEN
618 CALL xerbla( 'DCHKBD', -info )
619 RETURN
620 END IF
621*
622* Initialize constants
623*
624 path( 1: 1 ) = 'Double precision'
625 path( 2: 3 ) = 'BD'
626 nfail = 0
627 ntest = 0
628 unfl = dlamch( 'Safe minimum' )
629 ovfl = dlamch( 'Overflow' )
630 CALL dlabad( unfl, ovfl )
631 ulp = dlamch( 'Precision' )
632 ulpinv = one / ulp
633 log2ui = int( log( ulpinv ) / log( two ) )
634 rtunfl = sqrt( unfl )
635 rtovfl = sqrt( ovfl )
636 infot = 0
637 abstol = 2*unfl
638*
639* Loop over sizes, types
640*
641 DO 300 jsize = 1, nsizes
642 m = mval( jsize )
643 n = nval( jsize )
644 mnmin = min( m, n )
645 amninv = one / max( m, n, 1 )
646*
647 IF( nsizes.NE.1 ) THEN
648 mtypes = min( maxtyp, ntypes )
649 ELSE
650 mtypes = min( maxtyp+1, ntypes )
651 END IF
652*
653 DO 290 jtype = 1, mtypes
654 IF( .NOT.dotype( jtype ) )
655 $ GO TO 290
656*
657 DO 20 j = 1, 4
658 ioldsd( j ) = iseed( j )
659 20 CONTINUE
660*
661 DO 30 j = 1, 34
662 result( j ) = -one
663 30 CONTINUE
664*
665 uplo = ' '
666*
667* Compute "A"
668*
669* Control parameters:
670*
671* KMAGN KMODE KTYPE
672* =1 O(1) clustered 1 zero
673* =2 large clustered 2 identity
674* =3 small exponential (none)
675* =4 arithmetic diagonal, (w/ eigenvalues)
676* =5 random symmetric, w/ eigenvalues
677* =6 nonsymmetric, w/ singular values
678* =7 random diagonal
679* =8 random symmetric
680* =9 random nonsymmetric
681* =10 random bidiagonal (log. distrib.)
682*
683 IF( mtypes.GT.maxtyp )
684 $ GO TO 100
685*
686 itype = ktype( jtype )
687 imode = kmode( jtype )
688*
689* Compute norm
690*
691 GO TO ( 40, 50, 60 )kmagn( jtype )
692*
693 40 CONTINUE
694 anorm = one
695 GO TO 70
696*
697 50 CONTINUE
698 anorm = ( rtovfl*ulp )*amninv
699 GO TO 70
700*
701 60 CONTINUE
702 anorm = rtunfl*max( m, n )*ulpinv
703 GO TO 70
704*
705 70 CONTINUE
706*
707 CALL dlaset( 'Full', lda, n, zero, zero, a, lda )
708 iinfo = 0
709 cond = ulpinv
710*
711 bidiag = .false.
712 IF( itype.EQ.1 ) THEN
713*
714* Zero matrix
715*
716 iinfo = 0
717*
718 ELSE IF( itype.EQ.2 ) THEN
719*
720* Identity
721*
722 DO 80 jcol = 1, mnmin
723 a( jcol, jcol ) = anorm
724 80 CONTINUE
725*
726 ELSE IF( itype.EQ.4 ) THEN
727*
728* Diagonal Matrix, [Eigen]values Specified
729*
730 CALL dlatms( mnmin, mnmin, 'S', iseed, 'N', work, imode,
731 $ cond, anorm, 0, 0, 'N', a, lda,
732 $ work( mnmin+1 ), iinfo )
733*
734 ELSE IF( itype.EQ.5 ) THEN
735*
736* Symmetric, eigenvalues specified
737*
738 CALL dlatms( mnmin, mnmin, 'S', iseed, 'S', work, imode,
739 $ cond, anorm, m, n, 'N', a, lda,
740 $ work( mnmin+1 ), iinfo )
741*
742 ELSE IF( itype.EQ.6 ) THEN
743*
744* Nonsymmetric, singular values specified
745*
746 CALL dlatms( m, n, 'S', iseed, 'N', work, imode, cond,
747 $ anorm, m, n, 'N', a, lda, work( mnmin+1 ),
748 $ iinfo )
749*
750 ELSE IF( itype.EQ.7 ) THEN
751*
752* Diagonal, random entries
753*
754 CALL dlatmr( mnmin, mnmin, 'S', iseed, 'N', work, 6, one,
755 $ one, 'T', 'N', work( mnmin+1 ), 1, one,
756 $ work( 2*mnmin+1 ), 1, one, 'N', iwork, 0, 0,
757 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
758*
759 ELSE IF( itype.EQ.8 ) THEN
760*
761* Symmetric, random entries
762*
763 CALL dlatmr( mnmin, mnmin, 'S', iseed, 'S', work, 6, one,
764 $ one, 'T', 'N', work( mnmin+1 ), 1, one,
765 $ work( m+mnmin+1 ), 1, one, 'N', iwork, m, n,
766 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
767*
768 ELSE IF( itype.EQ.9 ) THEN
769*
770* Nonsymmetric, random entries
771*
772 CALL dlatmr( m, n, 'S', iseed, 'N', work, 6, one, one,
773 $ 'T', 'N', work( mnmin+1 ), 1, one,
774 $ work( m+mnmin+1 ), 1, one, 'N', iwork, m, n,
775 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
776*
777 ELSE IF( itype.EQ.10 ) THEN
778*
779* Bidiagonal, random entries
780*
781 temp1 = -two*log( ulp )
782 DO 90 j = 1, mnmin
783 bd( j ) = exp( temp1*dlarnd( 2, iseed ) )
784 IF( j.LT.mnmin )
785 $ be( j ) = exp( temp1*dlarnd( 2, iseed ) )
786 90 CONTINUE
787*
788 iinfo = 0
789 bidiag = .true.
790 IF( m.GE.n ) THEN
791 uplo = 'U'
792 ELSE
793 uplo = 'L'
794 END IF
795 ELSE
796 iinfo = 1
797 END IF
798*
799 IF( iinfo.EQ.0 ) THEN
800*
801* Generate Right-Hand Side
802*
803 IF( bidiag ) THEN
804 CALL dlatmr( mnmin, nrhs, 'S', iseed, 'N', work, 6,
805 $ one, one, 'T', 'N', work( mnmin+1 ), 1,
806 $ one, work( 2*mnmin+1 ), 1, one, 'N',
807 $ iwork, mnmin, nrhs, zero, one, 'NO', y,
808 $ ldx, iwork, iinfo )
809 ELSE
810 CALL dlatmr( m, nrhs, 'S', iseed, 'N', work, 6, one,
811 $ one, 'T', 'N', work( m+1 ), 1, one,
812 $ work( 2*m+1 ), 1, one, 'N', iwork, m,
813 $ nrhs, zero, one, 'NO', x, ldx, iwork,
814 $ iinfo )
815 END IF
816 END IF
817*
818* Error Exit
819*
820 IF( iinfo.NE.0 ) THEN
821 WRITE( nout, fmt = 9998 )'Generator', iinfo, m, n,
822 $ jtype, ioldsd
823 info = abs( iinfo )
824 RETURN
825 END IF
826*
827 100 CONTINUE
828*
829* Call DGEBRD and DORGBR to compute B, Q, and P, do tests.
830*
831 IF( .NOT.bidiag ) THEN
832*
833* Compute transformations to reduce A to bidiagonal form:
834* B := Q' * A * P.
835*
836 CALL dlacpy( ' ', m, n, a, lda, q, ldq )
837 CALL dgebrd( m, n, q, ldq, bd, be, work, work( mnmin+1 ),
838 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
839*
840* Check error code from DGEBRD.
841*
842 IF( iinfo.NE.0 ) THEN
843 WRITE( nout, fmt = 9998 )'DGEBRD', iinfo, m, n,
844 $ jtype, ioldsd
845 info = abs( iinfo )
846 RETURN
847 END IF
848*
849 CALL dlacpy( ' ', m, n, q, ldq, pt, ldpt )
850 IF( m.GE.n ) THEN
851 uplo = 'U'
852 ELSE
853 uplo = 'L'
854 END IF
855*
856* Generate Q
857*
858 mq = m
859 IF( nrhs.LE.0 )
860 $ mq = mnmin
861 CALL dorgbr( 'Q', m, mq, n, q, ldq, work,
862 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
863*
864* Check error code from DORGBR.
865*
866 IF( iinfo.NE.0 ) THEN
867 WRITE( nout, fmt = 9998 )'DORGBR(Q)', iinfo, m, n,
868 $ jtype, ioldsd
869 info = abs( iinfo )
870 RETURN
871 END IF
872*
873* Generate P'
874*
875 CALL dorgbr( 'P', mnmin, n, m, pt, ldpt, work( mnmin+1 ),
876 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
877*
878* Check error code from DORGBR.
879*
880 IF( iinfo.NE.0 ) THEN
881 WRITE( nout, fmt = 9998 )'DORGBR(P)', iinfo, m, n,
882 $ jtype, ioldsd
883 info = abs( iinfo )
884 RETURN
885 END IF
886*
887* Apply Q' to an M by NRHS matrix X: Y := Q' * X.
888*
889 CALL dgemm( 'Transpose', 'No transpose', m, nrhs, m, one,
890 $ q, ldq, x, ldx, zero, y, ldx )
891*
892* Test 1: Check the decomposition A := Q * B * PT
893* 2: Check the orthogonality of Q
894* 3: Check the orthogonality of PT
895*
896 CALL dbdt01( m, n, 1, a, lda, q, ldq, bd, be, pt, ldpt,
897 $ work, result( 1 ) )
898 CALL dort01( 'Columns', m, mq, q, ldq, work, lwork,
899 $ result( 2 ) )
900 CALL dort01( 'Rows', mnmin, n, pt, ldpt, work, lwork,
901 $ result( 3 ) )
902 END IF
903*
904* Use DBDSQR to form the SVD of the bidiagonal matrix B:
905* B := U * S1 * VT, and compute Z = U' * Y.
906*
907 CALL dcopy( mnmin, bd, 1, s1, 1 )
908 IF( mnmin.GT.0 )
909 $ CALL dcopy( mnmin-1, be, 1, work, 1 )
910 CALL dlacpy( ' ', m, nrhs, y, ldx, z, ldx )
911 CALL dlaset( 'Full', mnmin, mnmin, zero, one, u, ldpt )
912 CALL dlaset( 'Full', mnmin, mnmin, zero, one, vt, ldpt )
913*
914 CALL dbdsqr( uplo, mnmin, mnmin, mnmin, nrhs, s1, work, vt,
915 $ ldpt, u, ldpt, z, ldx, work( mnmin+1 ), iinfo )
916*
917* Check error code from DBDSQR.
918*
919 IF( iinfo.NE.0 ) THEN
920 WRITE( nout, fmt = 9998 )'DBDSQR(vects)', iinfo, m, n,
921 $ jtype, ioldsd
922 info = abs( iinfo )
923 IF( iinfo.LT.0 ) THEN
924 RETURN
925 ELSE
926 result( 4 ) = ulpinv
927 GO TO 270
928 END IF
929 END IF
930*
931* Use DBDSQR to compute only the singular values of the
932* bidiagonal matrix B; U, VT, and Z should not be modified.
933*
934 CALL dcopy( mnmin, bd, 1, s2, 1 )
935 IF( mnmin.GT.0 )
936 $ CALL dcopy( mnmin-1, be, 1, work, 1 )
937*
938 CALL dbdsqr( uplo, mnmin, 0, 0, 0, s2, work, vt, ldpt, u,
939 $ ldpt, z, ldx, work( mnmin+1 ), iinfo )
940*
941* Check error code from DBDSQR.
942*
943 IF( iinfo.NE.0 ) THEN
944 WRITE( nout, fmt = 9998 )'DBDSQR(values)', iinfo, m, n,
945 $ jtype, ioldsd
946 info = abs( iinfo )
947 IF( iinfo.LT.0 ) THEN
948 RETURN
949 ELSE
950 result( 9 ) = ulpinv
951 GO TO 270
952 END IF
953 END IF
954*
955* Test 4: Check the decomposition B := U * S1 * VT
956* 5: Check the computation Z := U' * Y
957* 6: Check the orthogonality of U
958* 7: Check the orthogonality of VT
959*
960 CALL dbdt03( uplo, mnmin, 1, bd, be, u, ldpt, s1, vt, ldpt,
961 $ work, result( 4 ) )
962 CALL dbdt02( mnmin, nrhs, y, ldx, z, ldx, u, ldpt, work,
963 $ result( 5 ) )
964 CALL dort01( 'Columns', mnmin, mnmin, u, ldpt, work, lwork,
965 $ result( 6 ) )
966 CALL dort01( 'Rows', mnmin, mnmin, vt, ldpt, work, lwork,
967 $ result( 7 ) )
968*
969* Test 8: Check that the singular values are sorted in
970* non-increasing order and are non-negative
971*
972 result( 8 ) = zero
973 DO 110 i = 1, mnmin - 1
974 IF( s1( i ).LT.s1( i+1 ) )
975 $ result( 8 ) = ulpinv
976 IF( s1( i ).LT.zero )
977 $ result( 8 ) = ulpinv
978 110 CONTINUE
979 IF( mnmin.GE.1 ) THEN
980 IF( s1( mnmin ).LT.zero )
981 $ result( 8 ) = ulpinv
982 END IF
983*
984* Test 9: Compare DBDSQR with and without singular vectors
985*
986 temp2 = zero
987*
988 DO 120 j = 1, mnmin
989 temp1 = abs( s1( j )-s2( j ) ) /
990 $ max( sqrt( unfl )*max( s1( 1 ), one ),
991 $ ulp*max( abs( s1( j ) ), abs( s2( j ) ) ) )
992 temp2 = max( temp1, temp2 )
993 120 CONTINUE
994*
995 result( 9 ) = temp2
996*
997* Test 10: Sturm sequence test of singular values
998* Go up by factors of two until it succeeds
999*
1000 temp1 = thresh*( half-ulp )
1001*
1002 DO 130 j = 0, log2ui
1003* CALL DSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO )
1004 IF( iinfo.EQ.0 )
1005 $ GO TO 140
1006 temp1 = temp1*two
1007 130 CONTINUE
1008*
1009 140 CONTINUE
1010 result( 10 ) = temp1
1011*
1012* Use DBDSQR to form the decomposition A := (QU) S (VT PT)
1013* from the bidiagonal form A := Q B PT.
1014*
1015 IF( .NOT.bidiag ) THEN
1016 CALL dcopy( mnmin, bd, 1, s2, 1 )
1017 IF( mnmin.GT.0 )
1018 $ CALL dcopy( mnmin-1, be, 1, work, 1 )
1019*
1020 CALL dbdsqr( uplo, mnmin, n, m, nrhs, s2, work, pt, ldpt,
1021 $ q, ldq, y, ldx, work( mnmin+1 ), iinfo )
1022*
1023* Test 11: Check the decomposition A := Q*U * S2 * VT*PT
1024* 12: Check the computation Z := U' * Q' * X
1025* 13: Check the orthogonality of Q*U
1026* 14: Check the orthogonality of VT*PT
1027*
1028 CALL dbdt01( m, n, 0, a, lda, q, ldq, s2, dumma, pt,
1029 $ ldpt, work, result( 11 ) )
1030 CALL dbdt02( m, nrhs, x, ldx, y, ldx, q, ldq, work,
1031 $ result( 12 ) )
1032 CALL dort01( 'Columns', m, mq, q, ldq, work, lwork,
1033 $ result( 13 ) )
1034 CALL dort01( 'Rows', mnmin, n, pt, ldpt, work, lwork,
1035 $ result( 14 ) )
1036 END IF
1037*
1038* Use DBDSDC to form the SVD of the bidiagonal matrix B:
1039* B := U * S1 * VT
1040*
1041 CALL dcopy( mnmin, bd, 1, s1, 1 )
1042 IF( mnmin.GT.0 )
1043 $ CALL dcopy( mnmin-1, be, 1, work, 1 )
1044 CALL dlaset( 'Full', mnmin, mnmin, zero, one, u, ldpt )
1045 CALL dlaset( 'Full', mnmin, mnmin, zero, one, vt, ldpt )
1046*
1047 CALL dbdsdc( uplo, 'I', mnmin, s1, work, u, ldpt, vt, ldpt,
1048 $ dum, idum, work( mnmin+1 ), iwork, iinfo )
1049*
1050* Check error code from DBDSDC.
1051*
1052 IF( iinfo.NE.0 ) THEN
1053 WRITE( nout, fmt = 9998 )'DBDSDC(vects)', iinfo, m, n,
1054 $ jtype, ioldsd
1055 info = abs( iinfo )
1056 IF( iinfo.LT.0 ) THEN
1057 RETURN
1058 ELSE
1059 result( 15 ) = ulpinv
1060 GO TO 270
1061 END IF
1062 END IF
1063*
1064* Use DBDSDC to compute only the singular values of the
1065* bidiagonal matrix B; U and VT should not be modified.
1066*
1067 CALL dcopy( mnmin, bd, 1, s2, 1 )
1068 IF( mnmin.GT.0 )
1069 $ CALL dcopy( mnmin-1, be, 1, work, 1 )
1070*
1071 CALL dbdsdc( uplo, 'N', mnmin, s2, work, dum, 1, dum, 1,
1072 $ dum, idum, work( mnmin+1 ), iwork, iinfo )
1073*
1074* Check error code from DBDSDC.
1075*
1076 IF( iinfo.NE.0 ) THEN
1077 WRITE( nout, fmt = 9998 )'DBDSDC(values)', iinfo, m, n,
1078 $ jtype, ioldsd
1079 info = abs( iinfo )
1080 IF( iinfo.LT.0 ) THEN
1081 RETURN
1082 ELSE
1083 result( 18 ) = ulpinv
1084 GO TO 270
1085 END IF
1086 END IF
1087*
1088* Test 15: Check the decomposition B := U * S1 * VT
1089* 16: Check the orthogonality of U
1090* 17: Check the orthogonality of VT
1091*
1092 CALL dbdt03( uplo, mnmin, 1, bd, be, u, ldpt, s1, vt, ldpt,
1093 $ work, result( 15 ) )
1094 CALL dort01( 'Columns', mnmin, mnmin, u, ldpt, work, lwork,
1095 $ result( 16 ) )
1096 CALL dort01( 'Rows', mnmin, mnmin, vt, ldpt, work, lwork,
1097 $ result( 17 ) )
1098*
1099* Test 18: Check that the singular values are sorted in
1100* non-increasing order and are non-negative
1101*
1102 result( 18 ) = zero
1103 DO 150 i = 1, mnmin - 1
1104 IF( s1( i ).LT.s1( i+1 ) )
1105 $ result( 18 ) = ulpinv
1106 IF( s1( i ).LT.zero )
1107 $ result( 18 ) = ulpinv
1108 150 CONTINUE
1109 IF( mnmin.GE.1 ) THEN
1110 IF( s1( mnmin ).LT.zero )
1111 $ result( 18 ) = ulpinv
1112 END IF
1113*
1114* Test 19: Compare DBDSQR with and without singular vectors
1115*
1116 temp2 = zero
1117*
1118 DO 160 j = 1, mnmin
1119 temp1 = abs( s1( j )-s2( j ) ) /
1120 $ max( sqrt( unfl )*max( s1( 1 ), one ),
1121 $ ulp*max( abs( s1( 1 ) ), abs( s2( 1 ) ) ) )
1122 temp2 = max( temp1, temp2 )
1123 160 CONTINUE
1124*
1125 result( 19 ) = temp2
1126*
1127*
1128* Use DBDSVDX to compute the SVD of the bidiagonal matrix B:
1129* B := U * S1 * VT
1130*
1131 IF( jtype.EQ.10 .OR. jtype.EQ.16 ) THEN
1132* =================================
1133* Matrix types temporarily disabled
1134* =================================
1135 result( 20:34 ) = zero
1136 GO TO 270
1137 END IF
1138*
1139 iwbs = 1
1140 iwbd = iwbs + mnmin
1141 iwbe = iwbd + mnmin
1142 iwbz = iwbe + mnmin
1143 iwwork = iwbz + 2*mnmin*(mnmin+1)
1144 mnmin2 = max( 1,mnmin*2 )
1145*
1146 CALL dcopy( mnmin, bd, 1, work( iwbd ), 1 )
1147 IF( mnmin.GT.0 )
1148 $ CALL dcopy( mnmin-1, be, 1, work( iwbe ), 1 )
1149*
1150 CALL dbdsvdx( uplo, 'V', 'A', mnmin, work( iwbd ),
1151 $ work( iwbe ), zero, zero, 0, 0, ns1, s1,
1152 $ work( iwbz ), mnmin2, work( iwwork ),
1153 $ iwork, iinfo)
1154*
1155* Check error code from DBDSVDX.
1156*
1157 IF( iinfo.NE.0 ) THEN
1158 WRITE( nout, fmt = 9998 )'DBDSVDX(vects,A)', iinfo, m, n,
1159 $ jtype, ioldsd
1160 info = abs( iinfo )
1161 IF( iinfo.LT.0 ) THEN
1162 RETURN
1163 ELSE
1164 result( 20 ) = ulpinv
1165 GO TO 270
1166 END IF
1167 END IF
1168*
1169 j = iwbz
1170 DO 170 i = 1, ns1
1171 CALL dcopy( mnmin, work( j ), 1, u( 1,i ), 1 )
1172 j = j + mnmin
1173 CALL dcopy( mnmin, work( j ), 1, vt( i,1 ), ldpt )
1174 j = j + mnmin
1175 170 CONTINUE
1176*
1177* Use DBDSVDX to compute only the singular values of the
1178* bidiagonal matrix B; U and VT should not be modified.
1179*
1180 IF( jtype.EQ.9 ) THEN
1181* =================================
1182* Matrix types temporarily disabled
1183* =================================
1184 result( 24 ) = zero
1185 GO TO 270
1186 END IF
1187*
1188 CALL dcopy( mnmin, bd, 1, work( iwbd ), 1 )
1189 IF( mnmin.GT.0 )
1190 $ CALL dcopy( mnmin-1, be, 1, work( iwbe ), 1 )
1191*
1192 CALL dbdsvdx( uplo, 'N', 'A', mnmin, work( iwbd ),
1193 $ work( iwbe ), zero, zero, 0, 0, ns2, s2,
1194 $ work( iwbz ), mnmin2, work( iwwork ),
1195 $ iwork, iinfo )
1196*
1197* Check error code from DBDSVDX.
1198*
1199 IF( iinfo.NE.0 ) THEN
1200 WRITE( nout, fmt = 9998 )'DBDSVDX(values,A)', iinfo,
1201 $ m, n, jtype, ioldsd
1202 info = abs( iinfo )
1203 IF( iinfo.LT.0 ) THEN
1204 RETURN
1205 ELSE
1206 result( 24 ) = ulpinv
1207 GO TO 270
1208 END IF
1209 END IF
1210*
1211* Save S1 for tests 30-34.
1212*
1213 CALL dcopy( mnmin, s1, 1, work( iwbs ), 1 )
1214*
1215* Test 20: Check the decomposition B := U * S1 * VT
1216* 21: Check the orthogonality of U
1217* 22: Check the orthogonality of VT
1218* 23: Check that the singular values are sorted in
1219* non-increasing order and are non-negative
1220* 24: Compare DBDSVDX with and without singular vectors
1221*
1222 CALL dbdt03( uplo, mnmin, 1, bd, be, u, ldpt, s1, vt,
1223 $ ldpt, work( iwbs+mnmin ), result( 20 ) )
1224 CALL dort01( 'Columns', mnmin, mnmin, u, ldpt,
1225 $ work( iwbs+mnmin ), lwork-mnmin,
1226 $ result( 21 ) )
1227 CALL dort01( 'Rows', mnmin, mnmin, vt, ldpt,
1228 $ work( iwbs+mnmin ), lwork-mnmin,
1229 $ result( 22) )
1230*
1231 result( 23 ) = zero
1232 DO 180 i = 1, mnmin - 1
1233 IF( s1( i ).LT.s1( i+1 ) )
1234 $ result( 23 ) = ulpinv
1235 IF( s1( i ).LT.zero )
1236 $ result( 23 ) = ulpinv
1237 180 CONTINUE
1238 IF( mnmin.GE.1 ) THEN
1239 IF( s1( mnmin ).LT.zero )
1240 $ result( 23 ) = ulpinv
1241 END IF
1242*
1243 temp2 = zero
1244 DO 190 j = 1, mnmin
1245 temp1 = abs( s1( j )-s2( j ) ) /
1246 $ max( sqrt( unfl )*max( s1( 1 ), one ),
1247 $ ulp*max( abs( s1( 1 ) ), abs( s2( 1 ) ) ) )
1248 temp2 = max( temp1, temp2 )
1249 190 CONTINUE
1250 result( 24 ) = temp2
1251 anorm = s1( 1 )
1252*
1253* Use DBDSVDX with RANGE='I': choose random values for IL and
1254* IU, and ask for the IL-th through IU-th singular values
1255* and corresponding vectors.
1256*
1257 DO 200 i = 1, 4
1258 iseed2( i ) = iseed( i )
1259 200 CONTINUE
1260 IF( mnmin.LE.1 ) THEN
1261 il = 1
1262 iu = mnmin
1263 ELSE
1264 il = 1 + int( ( mnmin-1 )*dlarnd( 1, iseed2 ) )
1265 iu = 1 + int( ( mnmin-1 )*dlarnd( 1, iseed2 ) )
1266 IF( iu.LT.il ) THEN
1267 itemp = iu
1268 iu = il
1269 il = itemp
1270 END IF
1271 END IF
1272*
1273 CALL dcopy( mnmin, bd, 1, work( iwbd ), 1 )
1274 IF( mnmin.GT.0 )
1275 $ CALL dcopy( mnmin-1, be, 1, work( iwbe ), 1 )
1276*
1277 CALL dbdsvdx( uplo, 'V', 'I', mnmin, work( iwbd ),
1278 $ work( iwbe ), zero, zero, il, iu, ns1, s1,
1279 $ work( iwbz ), mnmin2, work( iwwork ),
1280 $ iwork, iinfo)
1281*
1282* Check error code from DBDSVDX.
1283*
1284 IF( iinfo.NE.0 ) THEN
1285 WRITE( nout, fmt = 9998 )'DBDSVDX(vects,I)', iinfo,
1286 $ m, n, jtype, ioldsd
1287 info = abs( iinfo )
1288 IF( iinfo.LT.0 ) THEN
1289 RETURN
1290 ELSE
1291 result( 25 ) = ulpinv
1292 GO TO 270
1293 END IF
1294 END IF
1295*
1296 j = iwbz
1297 DO 210 i = 1, ns1
1298 CALL dcopy( mnmin, work( j ), 1, u( 1,i ), 1 )
1299 j = j + mnmin
1300 CALL dcopy( mnmin, work( j ), 1, vt( i,1 ), ldpt )
1301 j = j + mnmin
1302 210 CONTINUE
1303*
1304* Use DBDSVDX to compute only the singular values of the
1305* bidiagonal matrix B; U and VT should not be modified.
1306*
1307 CALL dcopy( mnmin, bd, 1, work( iwbd ), 1 )
1308 IF( mnmin.GT.0 )
1309 $ CALL dcopy( mnmin-1, be, 1, work( iwbe ), 1 )
1310*
1311 CALL dbdsvdx( uplo, 'N', 'I', mnmin, work( iwbd ),
1312 $ work( iwbe ), zero, zero, il, iu, ns2, s2,
1313 $ work( iwbz ), mnmin2, work( iwwork ),
1314 $ iwork, iinfo )
1315*
1316* Check error code from DBDSVDX.
1317*
1318 IF( iinfo.NE.0 ) THEN
1319 WRITE( nout, fmt = 9998 )'DBDSVDX(values,I)', iinfo,
1320 $ m, n, jtype, ioldsd
1321 info = abs( iinfo )
1322 IF( iinfo.LT.0 ) THEN
1323 RETURN
1324 ELSE
1325 result( 29 ) = ulpinv
1326 GO TO 270
1327 END IF
1328 END IF
1329*
1330* Test 25: Check S1 - U' * B * VT'
1331* 26: Check the orthogonality of U
1332* 27: Check the orthogonality of VT
1333* 28: Check that the singular values are sorted in
1334* non-increasing order and are non-negative
1335* 29: Compare DBDSVDX with and without singular vectors
1336*
1337 CALL dbdt04( uplo, mnmin, bd, be, s1, ns1, u,
1338 $ ldpt, vt, ldpt, work( iwbs+mnmin ),
1339 $ result( 25 ) )
1340 CALL dort01( 'Columns', mnmin, ns1, u, ldpt,
1341 $ work( iwbs+mnmin ), lwork-mnmin,
1342 $ result( 26 ) )
1343 CALL dort01( 'Rows', ns1, mnmin, vt, ldpt,
1344 $ work( iwbs+mnmin ), lwork-mnmin,
1345 $ result( 27 ) )
1346*
1347 result( 28 ) = zero
1348 DO 220 i = 1, ns1 - 1
1349 IF( s1( i ).LT.s1( i+1 ) )
1350 $ result( 28 ) = ulpinv
1351 IF( s1( i ).LT.zero )
1352 $ result( 28 ) = ulpinv
1353 220 CONTINUE
1354 IF( ns1.GE.1 ) THEN
1355 IF( s1( ns1 ).LT.zero )
1356 $ result( 28 ) = ulpinv
1357 END IF
1358*
1359 temp2 = zero
1360 DO 230 j = 1, ns1
1361 temp1 = abs( s1( j )-s2( j ) ) /
1362 $ max( sqrt( unfl )*max( s1( 1 ), one ),
1363 $ ulp*max( abs( s1( 1 ) ), abs( s2( 1 ) ) ) )
1364 temp2 = max( temp1, temp2 )
1365 230 CONTINUE
1366 result( 29 ) = temp2
1367*
1368* Use DBDSVDX with RANGE='V': determine the values VL and VU
1369* of the IL-th and IU-th singular values and ask for all
1370* singular values in this range.
1371*
1372 CALL dcopy( mnmin, work( iwbs ), 1, s1, 1 )
1373*
1374 IF( mnmin.GT.0 ) THEN
1375 IF( il.NE.1 ) THEN
1376 vu = s1( il ) + max( half*abs( s1( il )-s1( il-1 ) ),
1377 $ ulp*anorm, two*rtunfl )
1378 ELSE
1379 vu = s1( 1 ) + max( half*abs( s1( mnmin )-s1( 1 ) ),
1380 $ ulp*anorm, two*rtunfl )
1381 END IF
1382 IF( iu.NE.ns1 ) THEN
1383 vl = s1( iu ) - max( ulp*anorm, two*rtunfl,
1384 $ half*abs( s1( iu+1 )-s1( iu ) ) )
1385 ELSE
1386 vl = s1( ns1 ) - max( ulp*anorm, two*rtunfl,
1387 $ half*abs( s1( mnmin )-s1( 1 ) ) )
1388 END IF
1389 vl = max( vl,zero )
1390 vu = max( vu,zero )
1391 IF( vl.GE.vu ) vu = max( vu*2, vu+vl+half )
1392 ELSE
1393 vl = zero
1394 vu = one
1395 END IF
1396*
1397 CALL dcopy( mnmin, bd, 1, work( iwbd ), 1 )
1398 IF( mnmin.GT.0 )
1399 $ CALL dcopy( mnmin-1, be, 1, work( iwbe ), 1 )
1400*
1401 CALL dbdsvdx( uplo, 'V', 'V', mnmin, work( iwbd ),
1402 $ work( iwbe ), vl, vu, 0, 0, ns1, s1,
1403 $ work( iwbz ), mnmin2, work( iwwork ),
1404 $ iwork, iinfo )
1405*
1406* Check error code from DBDSVDX.
1407*
1408 IF( iinfo.NE.0 ) THEN
1409 WRITE( nout, fmt = 9998 )'DBDSVDX(vects,V)', iinfo,
1410 $ m, n, jtype, ioldsd
1411 info = abs( iinfo )
1412 IF( iinfo.LT.0 ) THEN
1413 RETURN
1414 ELSE
1415 result( 30 ) = ulpinv
1416 GO TO 270
1417 END IF
1418 END IF
1419*
1420 j = iwbz
1421 DO 240 i = 1, ns1
1422 CALL dcopy( mnmin, work( j ), 1, u( 1,i ), 1 )
1423 j = j + mnmin
1424 CALL dcopy( mnmin, work( j ), 1, vt( i,1 ), ldpt )
1425 j = j + mnmin
1426 240 CONTINUE
1427*
1428* Use DBDSVDX to compute only the singular values of the
1429* bidiagonal matrix B; U and VT should not be modified.
1430*
1431 CALL dcopy( mnmin, bd, 1, work( iwbd ), 1 )
1432 IF( mnmin.GT.0 )
1433 $ CALL dcopy( mnmin-1, be, 1, work( iwbe ), 1 )
1434*
1435 CALL dbdsvdx( uplo, 'N', 'V', mnmin, work( iwbd ),
1436 $ work( iwbe ), vl, vu, 0, 0, ns2, s2,
1437 $ work( iwbz ), mnmin2, work( iwwork ),
1438 $ iwork, iinfo )
1439*
1440* Check error code from DBDSVDX.
1441*
1442 IF( iinfo.NE.0 ) THEN
1443 WRITE( nout, fmt = 9998 )'DBDSVDX(values,V)', iinfo,
1444 $ m, n, jtype, ioldsd
1445 info = abs( iinfo )
1446 IF( iinfo.LT.0 ) THEN
1447 RETURN
1448 ELSE
1449 result( 34 ) = ulpinv
1450 GO TO 270
1451 END IF
1452 END IF
1453*
1454* Test 30: Check S1 - U' * B * VT'
1455* 31: Check the orthogonality of U
1456* 32: Check the orthogonality of VT
1457* 33: Check that the singular values are sorted in
1458* non-increasing order and are non-negative
1459* 34: Compare DBDSVDX with and without singular vectors
1460*
1461 CALL dbdt04( uplo, mnmin, bd, be, s1, ns1, u,
1462 $ ldpt, vt, ldpt, work( iwbs+mnmin ),
1463 $ result( 30 ) )
1464 CALL dort01( 'Columns', mnmin, ns1, u, ldpt,
1465 $ work( iwbs+mnmin ), lwork-mnmin,
1466 $ result( 31 ) )
1467 CALL dort01( 'Rows', ns1, mnmin, vt, ldpt,
1468 $ work( iwbs+mnmin ), lwork-mnmin,
1469 $ result( 32 ) )
1470*
1471 result( 33 ) = zero
1472 DO 250 i = 1, ns1 - 1
1473 IF( s1( i ).LT.s1( i+1 ) )
1474 $ result( 28 ) = ulpinv
1475 IF( s1( i ).LT.zero )
1476 $ result( 28 ) = ulpinv
1477 250 CONTINUE
1478 IF( ns1.GE.1 ) THEN
1479 IF( s1( ns1 ).LT.zero )
1480 $ result( 28 ) = ulpinv
1481 END IF
1482*
1483 temp2 = zero
1484 DO 260 j = 1, ns1
1485 temp1 = abs( s1( j )-s2( j ) ) /
1486 $ max( sqrt( unfl )*max( s1( 1 ), one ),
1487 $ ulp*max( abs( s1( 1 ) ), abs( s2( 1 ) ) ) )
1488 temp2 = max( temp1, temp2 )
1489 260 CONTINUE
1490 result( 34 ) = temp2
1491*
1492* End of Loop -- Check for RESULT(j) > THRESH
1493*
1494 270 CONTINUE
1495*
1496 DO 280 j = 1, 34
1497 IF( result( j ).GE.thresh ) THEN
1498 IF( nfail.EQ.0 )
1499 $ CALL dlahd2( nout, path )
1500 WRITE( nout, fmt = 9999 )m, n, jtype, ioldsd, j,
1501 $ result( j )
1502 nfail = nfail + 1
1503 END IF
1504 280 CONTINUE
1505 IF( .NOT.bidiag ) THEN
1506 ntest = ntest + 34
1507 ELSE
1508 ntest = ntest + 30
1509 END IF
1510*
1511 290 CONTINUE
1512 300 CONTINUE
1513*
1514* Summary
1515*
1516 CALL alasum( path, nout, nfail, ntest, 0 )
1517*
1518 RETURN
1519*
1520* End of DCHKBD
1521*
1522 9999 FORMAT( ' M=', i5, ', N=', i5, ', type ', i2, ', seed=',
1523 $ 4( i4, ',' ), ' test(', i2, ')=', g11.4 )
1524 9998 FORMAT( ' DCHKBD: ', a, ' returned INFO=', i6, '.', / 9x, 'M=',
1525 $ i6, ', N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ),
1526 $ i5, ')' )
1527*
dlabad
subroutine dlabad(small, large)
DLABAD
Definition dlabad.f:74
dbdsdc
subroutine dbdsdc(uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq, work, iwork, info)
DBDSDC
Definition dbdsdc.f:205
dbdsqr
subroutine dbdsqr(uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
DBDSQR
Definition dbdsqr.f:241
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
dorgbr
subroutine dorgbr(vect, m, n, k, a, lda, tau, work, lwork, info)
DORGBR
Definition dorgbr.f:157
dgebrd
subroutine dgebrd(m, n, a, lda, d, e, tauq, taup, work, lwork, info)
DGEBRD
Definition dgebrd.f:205
dbdsvdx
subroutine dbdsvdx(uplo, jobz, range, n, d, e, vl, vu, il, iu, ns, s, z, ldz, work, iwork, info)
DBDSVDX
Definition dbdsvdx.f:226
dsxt1
double precision function dsxt1(ijob, d1, n1, d2, n2, abstol, ulp, unfl)
DSXT1
Definition dsxt1.f:106
dbdt04
subroutine dbdt04(uplo, n, d, e, s, ns, u, ldu, vt, ldvt, work, resid)
DBDT04
Definition dbdt04.f:131
dbdt03
subroutine dbdt03(uplo, n, kd, d, e, u, ldu, s, vt, ldvt, work, resid)
DBDT03
Definition dbdt03.f:135
dlarnd
double precision function dlarnd(idist, iseed)
DLARND
Definition dlarnd.f:73

◆ dchkbk()

subroutine dchkbk ( integer nin,
integer nout )

DCHKBK

Purpose:
!>
!> DCHKBK tests DGEBAK, a routine for backward transformation of
!> the computed right or left eigenvectors if the original matrix
!> was preprocessed by balance subroutine DGEBAL.
!>
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 dchkbk.f.

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

◆ dchkbl()

subroutine dchkbl ( integer nin,
integer nout )

DCHKBL

Purpose:
!>
!> DCHKBL tests DGEBAL, a routine for balancing a general real
!> 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 dchkbl.f.

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

◆ dchkec()

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

DCHKEC

Purpose:
!>
!> DCHKEC tests eigen- condition estimation routines
!>        DLALN2, DLASY2, DLANV2, DLAQTR, DLAEXC,
!>        DTRSYL, DTREXC, DTRSNA, DTRSEN, DTGEXC
!>
!> 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, DTREXC, DTRSNA and DTRSEN
!> are tested by reading in precomputed examples from a file (on input
!> unit NIN).  Output is written to output unit NOUT.
!>
Parameters
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          Threshold for residual tests.  A computed test ratio passes
!>          the threshold if it is less than THRESH.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NIN
!>          NIN is INTEGER
!>          The logical unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The logical unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 75 of file dchkec.f.

76*
77* -- LAPACK test routine --
78* -- LAPACK is a software package provided by Univ. of Tennessee, --
79* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
80*
81* .. Scalar Arguments ..
82 LOGICAL TSTERR
83 INTEGER NIN, NOUT
84 DOUBLE PRECISION THRESH
85* ..
86*
87* =====================================================================
88*
89* .. Local Scalars ..
90 LOGICAL OK
91 CHARACTER*3 PATH
92 INTEGER KLAEXC, KLALN2, KLANV2, KLAQTR, KLASY2, KTREXC,
93 $ KTRSEN, KTRSNA, KTRSYL, LLAEXC, LLALN2, LLANV2,
94 $ LLAQTR, LLASY2, LTREXC, LTRSYL, NLANV2, NLAQTR,
95 $ NLASY2, NTESTS, NTRSYL, KTGEXC, NTGEXC, LTGEXC
96 DOUBLE PRECISION EPS, RLAEXC, RLALN2, RLANV2, RLAQTR, RLASY2,
97 $ RTREXC, RTRSYL, SFMIN, RTGEXC
98* ..
99* .. Local Arrays ..
100 INTEGER LTRSEN( 3 ), LTRSNA( 3 ), NLAEXC( 2 ),
101 $ NLALN2( 2 ), NTREXC( 3 ), NTRSEN( 3 ),
102 $ NTRSNA( 3 )
103 DOUBLE PRECISION RTRSEN( 3 ), RTRSNA( 3 )
104* ..
105* .. External Subroutines ..
106 EXTERNAL derrec, dget31, dget32, dget33, dget34, dget35,
107 $ dget36, dget37, dget38, dget39, dget40
108* ..
109* .. External Functions ..
110 DOUBLE PRECISION DLAMCH
111 EXTERNAL dlamch
112* ..
113* .. Executable Statements ..
114*
115 path( 1: 1 ) = 'Double precision'
116 path( 2: 3 ) = 'EC'
117 eps = dlamch( 'P' )
118 sfmin = dlamch( 'S' )
119*
120* Print header information
121*
122 WRITE( nout, fmt = 9989 )
123 WRITE( nout, fmt = 9988 )eps, sfmin
124 WRITE( nout, fmt = 9987 )thresh
125*
126* Test error exits if TSTERR is .TRUE.
127*
128 IF( tsterr )
129 $ CALL derrec( path, nout )
130*
131 ok = .true.
132 CALL dget31( rlaln2, llaln2, nlaln2, klaln2 )
133 IF( rlaln2.GT.thresh .OR. nlaln2( 1 ).NE.0 ) THEN
134 ok = .false.
135 WRITE( nout, fmt = 9999 )rlaln2, llaln2, nlaln2, klaln2
136 END IF
137*
138 CALL dget32( rlasy2, llasy2, nlasy2, klasy2 )
139 IF( rlasy2.GT.thresh ) THEN
140 ok = .false.
141 WRITE( nout, fmt = 9998 )rlasy2, llasy2, nlasy2, klasy2
142 END IF
143*
144 CALL dget33( rlanv2, llanv2, nlanv2, klanv2 )
145 IF( rlanv2.GT.thresh .OR. nlanv2.NE.0 ) THEN
146 ok = .false.
147 WRITE( nout, fmt = 9997 )rlanv2, llanv2, nlanv2, klanv2
148 END IF
149*
150 CALL dget34( rlaexc, llaexc, nlaexc, klaexc )
151 IF( rlaexc.GT.thresh .OR. nlaexc( 2 ).NE.0 ) THEN
152 ok = .false.
153 WRITE( nout, fmt = 9996 )rlaexc, llaexc, nlaexc, klaexc
154 END IF
155*
156 CALL dget35( rtrsyl, ltrsyl, ntrsyl, ktrsyl )
157 IF( rtrsyl.GT.thresh ) THEN
158 ok = .false.
159 WRITE( nout, fmt = 9995 )rtrsyl, ltrsyl, ntrsyl, ktrsyl
160 END IF
161*
162 CALL dget36( rtrexc, ltrexc, ntrexc, ktrexc, nin )
163 IF( rtrexc.GT.thresh .OR. ntrexc( 3 ).GT.0 ) THEN
164 ok = .false.
165 WRITE( nout, fmt = 9994 )rtrexc, ltrexc, ntrexc, ktrexc
166 END IF
167*
168 CALL dget37( rtrsna, ltrsna, ntrsna, ktrsna, nin )
169 IF( rtrsna( 1 ).GT.thresh .OR. rtrsna( 2 ).GT.thresh .OR.
170 $ ntrsna( 1 ).NE.0 .OR. ntrsna( 2 ).NE.0 .OR. ntrsna( 3 ).NE.0 )
171 $ THEN
172 ok = .false.
173 WRITE( nout, fmt = 9993 )rtrsna, ltrsna, ntrsna, ktrsna
174 END IF
175*
176 CALL dget38( rtrsen, ltrsen, ntrsen, ktrsen, nin )
177 IF( rtrsen( 1 ).GT.thresh .OR. rtrsen( 2 ).GT.thresh .OR.
178 $ ntrsen( 1 ).NE.0 .OR. ntrsen( 2 ).NE.0 .OR. ntrsen( 3 ).NE.0 )
179 $ THEN
180 ok = .false.
181 WRITE( nout, fmt = 9992 )rtrsen, ltrsen, ntrsen, ktrsen
182 END IF
183*
184 CALL dget39( rlaqtr, llaqtr, nlaqtr, klaqtr )
185 IF( rlaqtr.GT.thresh ) THEN
186 ok = .false.
187 WRITE( nout, fmt = 9991 )rlaqtr, llaqtr, nlaqtr, klaqtr
188 END IF
189*
190 CALL dget40( rtgexc, ltgexc, ntgexc, ktgexc, nin )
191 IF( rtgexc.GT.thresh ) THEN
192 ok = .false.
193 WRITE( nout, fmt = 9986 )rtgexc, ltgexc, ntgexc, ktgexc
194 END IF
195*
196 ntests = klaln2 + klasy2 + klanv2 + klaexc + ktrsyl + ktrexc +
197 $ ktrsna + ktrsen + klaqtr + ktgexc
198 IF( ok )
199 $ WRITE( nout, fmt = 9990 )path, ntests
200*
201 RETURN
202 9999 FORMAT( ' Error in DLALN2: RMAX =', d12.3, / ' LMAX = ', i8, ' N',
203 $ 'INFO=', 2i8, ' KNT=', i8 )
204 9998 FORMAT( ' Error in DLASY2: RMAX =', d12.3, / ' LMAX = ', i8, ' N',
205 $ 'INFO=', i8, ' KNT=', i8 )
206 9997 FORMAT( ' Error in DLANV2: RMAX =', d12.3, / ' LMAX = ', i8, ' N',
207 $ 'INFO=', i8, ' KNT=', i8 )
208 9996 FORMAT( ' Error in DLAEXC: RMAX =', d12.3, / ' LMAX = ', i8, ' N',
209 $ 'INFO=', 2i8, ' KNT=', i8 )
210 9995 FORMAT( ' Error in DTRSYL: RMAX =', d12.3, / ' LMAX = ', i8, ' N',
211 $ 'INFO=', i8, ' KNT=', i8 )
212 9994 FORMAT( ' Error in DTREXC: RMAX =', d12.3, / ' LMAX = ', i8, ' N',
213 $ 'INFO=', 3i8, ' KNT=', i8 )
214 9993 FORMAT( ' Error in DTRSNA: RMAX =', 3d12.3, / ' LMAX = ', 3i8,
215 $ ' NINFO=', 3i8, ' KNT=', i8 )
216 9992 FORMAT( ' Error in DTRSEN: RMAX =', 3d12.3, / ' LMAX = ', 3i8,
217 $ ' NINFO=', 3i8, ' KNT=', i8 )
218 9991 FORMAT( ' Error in DLAQTR: RMAX =', d12.3, / ' LMAX = ', i8, ' N',
219 $ 'INFO=', i8, ' KNT=', i8 )
220 9990 FORMAT( / 1x, 'All tests for ', a3, ' routines passed the thresh',
221 $ 'old ( ', i6, ' tests run)' )
222 9989 FORMAT( ' Tests of the Nonsymmetric eigenproblem condition estim',
223 $ 'ation routines', / ' DLALN2, DLASY2, DLANV2, DLAEXC, DTRS',
224 $ 'YL, DTREXC, DTRSNA, DTRSEN, DLAQTR, DTGEXC', / )
225 9988 FORMAT( ' Relative machine precision (EPS) = ', d16.6, / ' Safe ',
226 $ 'minimum (SFMIN) = ', d16.6, / )
227 9987 FORMAT( ' Routines pass computational tests if test ratio is les',
228 $ 's than', f8.2, / / )
229 9986 FORMAT( ' Error in DTGEXC: RMAX =', d12.3, / ' LMAX = ', i8, ' N',
230 $ 'INFO=', i8, ' KNT=', i8 )
231*
232* End of DCHKEC
233*
derrec
subroutine derrec(path, nunit)
DERREC
Definition derrec.f:56
dget39
subroutine dget39(rmax, lmax, ninfo, knt)
DGET39
Definition dget39.f:103
dget32
subroutine dget32(rmax, lmax, ninfo, knt)
DGET32
Definition dget32.f:82
dget34
subroutine dget34(rmax, lmax, ninfo, knt)
DGET34
Definition dget34.f:82
dget38
subroutine dget38(rmax, lmax, ninfo, knt, nin)
DGET38
Definition dget38.f:91
dget36
subroutine dget36(rmax, lmax, ninfo, knt, nin)
DGET36
Definition dget36.f:88
dget40
subroutine dget40(rmax, lmax, ninfo, knt, nin)
DGET40
Definition dget40.f:83
dget31
subroutine dget31(rmax, lmax, ninfo, knt)
DGET31
Definition dget31.f:91
dget33
subroutine dget33(rmax, lmax, ninfo, knt)
DGET33
Definition dget33.f:76
dget37
subroutine dget37(rmax, lmax, ninfo, knt, nin)
DGET37
Definition dget37.f:90
dget35
subroutine dget35(rmax, lmax, ninfo, knt)
DGET35
Definition dget35.f:78

◆ dchkee()

program dchkee

DCHKEE

Purpose:
!>
!> DCHKEE tests the DOUBLE PRECISION LAPACK subroutines for the matrix
!> eigenvalue problem.  The test paths in this version are
!>
!> NEP (Nonsymmetric Eigenvalue Problem):
!>     Test DGEHRD, DORGHR, DHSEQR, DTREVC, DHSEIN, and DORMHR
!>
!> SEP (Symmetric Eigenvalue Problem):
!>     Test DSYTRD, DORGTR, DSTEQR, DSTERF, DSTEIN, DSTEDC,
!>     and drivers DSYEV(X), DSBEV(X), DSPEV(X), DSTEV(X),
!>                 DSYEVD,   DSBEVD,   DSPEVD,   DSTEVD
!>
!> SVD (Singular Value Decomposition):
!>     Test DGEBRD, DORGBR, DBDSQR, DBDSDC
!>     and the drivers DGESVD, DGESDD
!>
!> DEV (Nonsymmetric Eigenvalue/eigenvector Driver):
!>     Test DGEEV
!>
!> DES (Nonsymmetric Schur form Driver):
!>     Test DGEES
!>
!> DVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver):
!>     Test DGEEVX
!>
!> DSX (Nonsymmetric Schur form Expert Driver):
!>     Test DGEESX
!>
!> DGG (Generalized Nonsymmetric Eigenvalue Problem):
!>     Test DGGHD3, DGGBAL, DGGBAK, DHGEQZ, and DTGEVC
!>
!> DGS (Generalized Nonsymmetric Schur form Driver):
!>     Test DGGES
!>
!> DGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver):
!>     Test DGGEV
!>
!> DGX (Generalized Nonsymmetric Schur form Expert Driver):
!>     Test DGGESX
!>
!> DXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver):
!>     Test DGGEVX
!>
!> DSG (Symmetric Generalized Eigenvalue Problem):
!>     Test DSYGST, DSYGV, DSYGVD, DSYGVX, DSPGST, DSPGV, DSPGVD,
!>     DSPGVX, DSBGST, DSBGV, DSBGVD, and DSBGVX
!>
!> DSB (Symmetric Band Eigenvalue Problem):
!>     Test DSBTRD
!>
!> DBB (Band Singular Value Decomposition):
!>     Test DGBBRD
!>
!> DEC (Eigencondition estimation):
!>     Test DLALN2, DLASY2, DLAEQU, DLAEXC, DTRSYL, DTREXC, DTRSNA,
!>     DTRSEN, and DLAQTR
!>
!> DBL (Balancing a general matrix)
!>     Test DGEBAL
!>
!> DBK (Back transformation on a balanced matrix)
!>     Test DGEBAK
!>
!> DGL (Balancing a matrix pair)
!>     Test DGGBAL
!>
!> DGK (Back transformation on a matrix pair)
!>     Test DGGBAK
!>
!> GLM (Generalized Linear Regression Model):
!>     Tests DGGGLM
!>
!> GQR (Generalized QR and RQ factorizations):
!>     Tests DGGQRF and DGGRQF
!>
!> GSV (Generalized Singular Value Decomposition):
!>     Tests DGGSVD, DGGSVP, DTGSJA, DLAGS2, DLAPLL, and DLAPMT
!>
!> CSD (CS decomposition):
!>     Tests DORCSD
!>
!> LSE (Constrained Linear Least Squares):
!>     Tests DGGLSE
!>
!> 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
!>
!> DHS or NEP      21     DCHKHS
!> DST or SEP      21     DCHKST (routines)
!>                 18     DDRVST (drivers)
!> DBD or SVD      16     DCHKBD (routines)
!>                  5     DDRVBD (drivers)
!> DEV             21     DDRVEV
!> DES             21     DDRVES
!> DVX             21     DDRVVX
!> DSX             21     DDRVSX
!> DGG             26     DCHKGG (routines)
!> DGS             26     DDRGES
!> DGX              5     DDRGSX
!> DGV             26     DDRGEV
!> DXV              2     DDRGVX
!> DSG             21     DDRVSG
!> DSB             15     DCHKSB
!> DBB             15     DCHKBB
!> DEC              -     DCHKEC
!> DBL              -     DCHKBL
!> DBK              -     DCHKBK
!> DGL              -     DCHKGL
!> DGK              -     DCHKGK
!> GLM              8     DCKGLM
!> GQR              8     DCKGQR
!> GSV              8     DCKGSV
!> CSD              3     DCKCSD
!> LSE              8     DCKLSE
!>
!>-----------------------------------------------------------------------
!>
!> 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 'SHS' for the
!>          nonsymmetric eigenvalue routines.
!>
!>-----------------------------------------------------------------------
!>
!> SEP or DSG 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 3-character path names are 'SEP' or 'SST' for the
!>          symmetric eigenvalue routines and driver routines, and
!>          'DSG' for the routines for the symmetric 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 'SBD' for both the
!>          SVD routines and the SVD driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> DEV and DES data files:
!>
!> line 1:  'DEV' or 'DES' 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:  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 7 was 2:
!>
!> line 8:  INTEGER array, dimension (4)
!>          Four integer values for the random number seed.
!>
!> lines 9 and following:  Lines specifying matrix types, as for NEP.
!>          The 3-character path name is 'DEV' to test SGEEV, or
!>          'DES' to test SGEES.
!>
!>-----------------------------------------------------------------------
!>
!> The DVX data has two parts. The first part is identical to DEV,
!> and the second part consists of test matrices with precomputed
!> solutions.
!>
!> line 1:  'DVX' 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:  TSTERR, LOGICAL
!>
!> line 7:  NEWSD, INTEGER
!>
!> If line 7 was 2:
!>
!> line 8:  INTEGER array, dimension (4)
!>
!> lines 9 and following: The first line contains 'DVX' 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+2*N lines, where N is
!>          its dimension. The first line contains the dimension (a
!>          single integer). The next N lines contain the matrix, one
!>          row 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 eigenvalue, the imaginary
!>          part of the eigenvalue, the reciprocal condition number of
!>          the eigenvalues, and the reciprocal condition number of the
!>          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 DSX data is like DVX. The first part is identical to DEV, and the
!> second part consists of test matrices with precomputed solutions.
!>
!> line 1:  'DSX' 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:  TSTERR, LOGICAL
!>
!> line 7:  NEWSD, INTEGER
!>
!> If line 7 was 2:
!>
!> line 8:  INTEGER array, dimension (4)
!>
!> lines 9 and following: The first line contains 'DSX' 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 lines, where N is its
!>          dimension. The first line contains the dimension N and the
!>          dimension M of an invariant subspace. 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). The next N
!>          lines contain the matrix. 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 is
!>          indicated by a line containing N=0 and M=0. Even if no data
!>          is to be tested, there must be at least one line containing
!>          N=0 and M=0.
!>
!>-----------------------------------------------------------------------
!>
!> DGG 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, NS, MAXB, and
!>          NBCOL.
!>
!> 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 'DGG' for the generalized
!>          eigenvalue problem routines and driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> DGS and DGV input files:
!>
!> line 1:  'DGS' or 'DGV' 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 'DGS' for the generalized
!>          eigenvalue problem routines and driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> DXV input files:
!>
!> line 1:  'DXV' 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 lines, where N is
!>          its dimension. The first line contains the dimension (a
!>          single integer). The next N lines contain the matrix A, one
!>          row per line. The next 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.
!>
!>-----------------------------------------------------------------------
!>
!> DGX input files:
!>
!> line 1:  'DGX' 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 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
!>          lines contain the matrix A, one row per line.  The next 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.
!>
!>-----------------------------------------------------------------------
!>
!> DSB 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 'DSB'.
!>
!>-----------------------------------------------------------------------
!>
!> DBB 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 'DBB'.
!>
!>-----------------------------------------------------------------------
!>
!> DEC 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.
!>
!>-----------------------------------------------------------------------
!>
!> DBL and DBK input files:
!>
!> line 1:  'DBL' in columns 1-3 to test SGEBAL, or 'DBK' in
!>          columns 1-3 to test SGEBAK.
!>
!> The remaining lines consist of specially constructed test cases.
!>
!>-----------------------------------------------------------------------
!>
!> DGL and DGK input files:
!>
!> line 1:  'DGL' in columns 1-3 to test DGGBAL, or 'DGK' in
!>          columns 1-3 to test DGGBAK.
!>
!> 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+5)+1 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 DGG.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 1039 of file dchkee.F.

◆ dchkgg()

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

DCHKGG

Purpose:
!>
!> DCHKGG  checks the nonsymmetric generalized eigenvalue problem
!> routines.
!>                                T          T        T
!> DGGHRD factors A and B as U H V  and U T V , where   means
!> transpose, H is hessenberg, T is triangular and U and V are
!> orthogonal.
!>                                 T          T
!> DHGEQZ factors H and T as  Q S Z  and Q P Z , where P is upper
!> triangular, S is in generalized Schur form (block upper triangular,
!> with 1x1 and 2x2 blocks on the diagonal, the 2x2 blocks
!> corresponding to complex conjugate pairs of generalized
!> eigenvalues), and Q and Z are orthogonal.  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
!>
!> DTGEVC 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 DCHKGG 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.  The first twelve  should be
!> small -- O(1).  They will be compared with the threshold THRESH:
!>
!>                  T
!> (1)   | A - U H V  | / ( |A| n ulp )
!>
!>                  T
!> (2)   | B - U T V  | / ( |B| n ulp )
!>
!>               T
!> (3)   | I - UU  | / ( n ulp )
!>
!>               T
!> (4)   | I - VV  | / ( n ulp )
!>
!>                  T
!> (5)   | H - Q S Z  | / ( |H| n ulp )
!>
!>                  T
!> (6)   | T - Q P Z  | / ( |T| n ulp )
!>
!>               T
!> (7)   | I - QQ  | / ( n ulp )
!>
!>               T
!> (8)   | I - ZZ  | / ( n ulp )
!>
!> (9)   max over all left eigenvalue/-vector pairs (beta/alpha,l) of
!>
!>    | l**H * (beta S - alpha P) | / ( ulp max( |beta S|, |alpha P| ) )
!>
!> (10)  max over all left eigenvalue/-vector pairs (beta/alpha,l') of
!>                           T
!>   | l'**H * (beta H - alpha T) | / ( ulp max( |beta H|, |alpha T| ) )
!>
!>       where the eigenvectors l' are the result of passing Q to
!>       DTGEVC and back transforming (HOWMNY='B').
!>
!> (11)  max over all right eigenvalue/-vector pairs (beta/alpha,r) of
!>
!>       | (beta S - alpha T) r | / ( ulp max( |beta S|, |alpha T| ) )
!>
!> (12)  max over all right eigenvalue/-vector pairs (beta/alpha,r') of
!>
!>       | (beta H - alpha T) r' | / ( ulp max( |beta H|, |alpha T| ) )
!>
!>       where the eigenvectors r' are the result of passing Z to
!>       DTGEVC and back transforming (HOWMNY='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 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) U ( J , J ) V     where U and V are random orthogonal 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) =
!>                        ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
!>                        ( 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) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (23) U ( small*T1, big*T2 ) V    diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (24) U ( small*T1, small*T2 ) V  diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
!>                                  diag(T2) = ( 0, 1, ..., 1, 0, 0 )
!>
!> (25) U ( big*T1, big*T2 ) V      diag(T1) = ( 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,
!>          DCHKGG 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, DCHKGG
!>          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 DCHKGG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error is
!>          scaled to be O(1), so THRESH should be a reasonably small
!>          multiple of 1, e.g., 10 or 100.  In particular, it should
!>          not depend on the precision (single vs. double) or the size
!>          of the matrix.  It must be at least zero.
!>
[in]TSTDIF
!>          TSTDIF is LOGICAL
!>          Specifies whether test ratios 13-15 will be computed and
!>          compared with THRESH.
!>          = .FALSE.: Only test ratios 1-12 will be computed and tested.
!>                     Ratios 13-15 will be set to zero.
!>          = .TRUE.:  All the test ratios 1-15 will be computed and
!>                     tested.
!>
[in]THRSHN
!>          THRSHN is DOUBLE PRECISION
!>          Threshold for reporting eigenvector normalization error.
!>          If the normalization of any eigenvector differs from 1 by
!>          more than THRSHN*ulp, then a special error message will be
!>          printed.  (This is handled separately from the other tests,
!>          since only a compiler or programming error should cause an
!>          error message, at least if THRSHN is at least 5--10.)
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          The upper Hessenberg matrix computed from A by DGGHRD.
!>
[out]T
!>          T is DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by DGGHRD.
!>
[out]S1
!>          S1 is DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          The Schur (block upper triangular) matrix computed from H by
!>          DHGEQZ when Q and Z are also computed.
!>
[out]S2
!>          S2 is DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          The Schur (block upper triangular) matrix computed from H by
!>          DHGEQZ when Q and Z are not computed.
!>
[out]P1
!>          P1 is DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from T by DHGEQZ
!>          when Q and Z are also computed.
!>
[out]P2
!>          P2 is DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from T by DHGEQZ
!>          when Q and Z are not computed.
!>
[out]U
!>          U is DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The (left) orthogonal matrix computed by DGGHRD.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U, V, Q, Z, EVECTL, and EVEZTR.  It
!>          must be at least 1 and at least max( NN ).
!>
[out]V
!>          V is DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The (right) orthogonal matrix computed by DGGHRD.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The (left) orthogonal matrix computed by DHGEQZ.
!>
[out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The (left) orthogonal matrix computed by DHGEQZ.
!>
[out]ALPHR1
!>          ALPHR1 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]ALPHI1
!>          ALPHI1 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]BETA1
!>          BETA1 is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by DHGEQZ
!>          when Q, Z, and the full Schur matrices are computed.
!>          On exit, ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th
!>          generalized eigenvalue of the matrices in A and B.
!>
[out]ALPHR3
!>          ALPHR3 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]ALPHI3
!>          ALPHI3 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]BETA3
!>          BETA3 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]EVECTL
!>          EVECTL is DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The (block lower triangular) left eigenvector matrix for
!>          the matrices in S1 and P1.  (See DTGEVC for the format.)
!>
[out]EVECTR
!>          EVECTR is DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The (block upper triangular) right eigenvector matrix for
!>          the matrices in S1 and P1.  (See DTGEVC for the format.)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          max( 2 * N**2, 6*N, 1 ), for all N=NN(j).
!>
[out]LLWORK
!>          LLWORK is LOGICAL array, dimension (max(NN))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (15)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  A routine returned an error code.  INFO is the
!>                absolute value of the INFO value returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 506 of file dchkgg.f.

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

◆ dchkgk()

subroutine dchkgk ( integer nin,
integer nout )

DCHKGK

Purpose:
!>
!> DCHKGK tests DGGBAK, 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 dchkgk.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
69 parameter( lde = 50, ldf = 50, ldwork = 50 )
70 DOUBLE PRECISION ZERO, ONE
71 parameter( zero = 0.0d+0, one = 1.0d+0 )
72* ..
73* .. Local Scalars ..
74 INTEGER I, IHI, ILO, INFO, J, KNT, M, N, NINFO
75 DOUBLE PRECISION ANORM, BNORM, EPS, RMAX, VMAX
76* ..
77* .. Local Arrays ..
78 INTEGER LMAX( 4 )
79 DOUBLE PRECISION A( LDA, LDA ), AF( LDA, LDA ), B( LDB, LDB ),
80 $ BF( LDB, LDB ), E( LDE, LDE ), F( LDF, LDF ),
81 $ LSCALE( LDA ), RSCALE( LDA ), VL( LDVL, LDVL ),
82 $ VLF( LDVL, LDVL ), VR( LDVR, LDVR ),
83 $ VRF( LDVR, LDVR ), WORK( LDWORK, LDWORK )
84* ..
85* .. External Functions ..
86 DOUBLE PRECISION DLAMCH, DLANGE
87 EXTERNAL dlamch, dlange
88* ..
89* .. External Subroutines ..
90 EXTERNAL dgemm, dggbak, dggbal, dlacpy
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC abs, max
94* ..
95* .. Executable Statements ..
96*
97* Initialization
98*
99 lmax( 1 ) = 0
100 lmax( 2 ) = 0
101 lmax( 3 ) = 0
102 lmax( 4 ) = 0
103 ninfo = 0
104 knt = 0
105 rmax = zero
106*
107 eps = dlamch( 'Precision' )
108*
109 10 CONTINUE
110 READ( nin, fmt = * )n, m
111 IF( n.EQ.0 )
112 $ GO TO 100
113*
114 DO 20 i = 1, n
115 READ( nin, fmt = * )( a( i, j ), j = 1, n )
116 20 CONTINUE
117*
118 DO 30 i = 1, n
119 READ( nin, fmt = * )( b( i, j ), j = 1, n )
120 30 CONTINUE
121*
122 DO 40 i = 1, n
123 READ( nin, fmt = * )( vl( i, j ), j = 1, m )
124 40 CONTINUE
125*
126 DO 50 i = 1, n
127 READ( nin, fmt = * )( vr( i, j ), j = 1, m )
128 50 CONTINUE
129*
130 knt = knt + 1
131*
132 anorm = dlange( 'M', n, n, a, lda, work )
133 bnorm = dlange( 'M', n, n, b, ldb, work )
134*
135 CALL dlacpy( 'FULL', n, n, a, lda, af, lda )
136 CALL dlacpy( 'FULL', n, n, b, ldb, bf, ldb )
137*
138 CALL dggbal( 'B', n, a, lda, b, ldb, ilo, ihi, lscale, rscale,
139 $ work, info )
140 IF( info.NE.0 ) THEN
141 ninfo = ninfo + 1
142 lmax( 1 ) = knt
143 END IF
144*
145 CALL dlacpy( 'FULL', n, m, vl, ldvl, vlf, ldvl )
146 CALL dlacpy( 'FULL', n, m, vr, ldvr, vrf, ldvr )
147*
148 CALL dggbak( 'B', 'L', n, ilo, ihi, lscale, rscale, m, vl, ldvl,
149 $ info )
150 IF( info.NE.0 ) THEN
151 ninfo = ninfo + 1
152 lmax( 2 ) = knt
153 END IF
154*
155 CALL dggbak( 'B', 'R', n, ilo, ihi, lscale, rscale, m, vr, ldvr,
156 $ info )
157 IF( info.NE.0 ) THEN
158 ninfo = ninfo + 1
159 lmax( 3 ) = knt
160 END IF
161*
162* Test of DGGBAK
163*
164* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
165* where tilde(A) denotes the transformed matrix.
166*
167 CALL dgemm( 'N', 'N', n, m, n, one, af, lda, vr, ldvr, zero, work,
168 $ ldwork )
169 CALL dgemm( 'T', 'N', m, m, n, one, vl, ldvl, work, ldwork, zero,
170 $ e, lde )
171*
172 CALL dgemm( 'N', 'N', n, m, n, one, a, lda, vrf, ldvr, zero, work,
173 $ ldwork )
174 CALL dgemm( 'T', 'N', m, m, n, one, vlf, ldvl, work, ldwork, zero,
175 $ f, ldf )
176*
177 vmax = zero
178 DO 70 j = 1, m
179 DO 60 i = 1, m
180 vmax = max( vmax, abs( e( i, j )-f( i, j ) ) )
181 60 CONTINUE
182 70 CONTINUE
183 vmax = vmax / ( eps*max( anorm, bnorm ) )
184 IF( vmax.GT.rmax ) THEN
185 lmax( 4 ) = knt
186 rmax = vmax
187 END IF
188*
189* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR
190*
191 CALL dgemm( 'N', 'N', n, m, n, one, bf, ldb, vr, ldvr, zero, work,
192 $ ldwork )
193 CALL dgemm( 'T', 'N', m, m, n, one, vl, ldvl, work, ldwork, zero,
194 $ e, lde )
195*
196 CALL dgemm( 'N', 'N', n, m, n, one, b, ldb, vrf, ldvr, zero, work,
197 $ ldwork )
198 CALL dgemm( 'T', 'N', m, m, n, one, vlf, ldvl, work, ldwork, zero,
199 $ f, ldf )
200*
201 vmax = zero
202 DO 90 j = 1, m
203 DO 80 i = 1, m
204 vmax = max( vmax, abs( e( i, j )-f( i, j ) ) )
205 80 CONTINUE
206 90 CONTINUE
207 vmax = vmax / ( eps*max( anorm, bnorm ) )
208 IF( vmax.GT.rmax ) THEN
209 lmax( 4 ) = knt
210 rmax = vmax
211 END IF
212*
213 GO TO 10
214*
215 100 CONTINUE
216*
217 WRITE( nout, fmt = 9999 )
218 9999 FORMAT( 1x, '.. test output of DGGBAK .. ' )
219*
220 WRITE( nout, fmt = 9998 )rmax
221 9998 FORMAT( ' value of largest test error =', d12.3 )
222 WRITE( nout, fmt = 9997 )lmax( 1 )
223 9997 FORMAT( ' example number where DGGBAL info is not 0 =', i4 )
224 WRITE( nout, fmt = 9996 )lmax( 2 )
225 9996 FORMAT( ' example number where DGGBAK(L) info is not 0 =', i4 )
226 WRITE( nout, fmt = 9995 )lmax( 3 )
227 9995 FORMAT( ' example number where DGGBAK(R) info is not 0 =', i4 )
228 WRITE( nout, fmt = 9994 )lmax( 4 )
229 9994 FORMAT( ' example number having largest error =', i4 )
230 WRITE( nout, fmt = 9993 )ninfo
231 9993 FORMAT( ' number of examples where info is not 0 =', i4 )
232 WRITE( nout, fmt = 9992 )knt
233 9992 FORMAT( ' total number of examples tested =', i4 )
234*
235 RETURN
236*
237* End of DCHKGK
238*
dggbal
subroutine dggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, work, info)
DGGBAL
Definition dggbal.f:177
dggbak
subroutine dggbak(job, side, n, ilo, ihi, lscale, rscale, m, v, ldv, info)
DGGBAK
Definition dggbak.f:147

◆ dchkgl()

subroutine dchkgl ( integer nin,
integer nout )

DCHKGL

Purpose:
!>
!> DCHKGL tests DGGBAL, 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 dchkgl.f.

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

◆ dchkhs()

subroutine dchkhs ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( lda, * ) h,
double precision, dimension( lda, * ) t1,
double precision, dimension( lda, * ) t2,
double precision, dimension( ldu, * ) u,
integer ldu,
double precision, dimension( ldu, * ) z,
double precision, dimension( ldu, * ) uz,
double precision, dimension( * ) wr1,
double precision, dimension( * ) wi1,
double precision, dimension( * ) wr2,
double precision, dimension( * ) wi2,
double precision, dimension( * ) wr3,
double precision, dimension( * ) wi3,
double precision, dimension( ldu, * ) evectl,
double precision, dimension( ldu, * ) evectr,
double precision, dimension( ldu, * ) evecty,
double precision, dimension( ldu, * ) evectx,
double precision, dimension( ldu, * ) uu,
double precision, dimension( * ) tau,
double precision, dimension( * ) work,
integer nwork,
integer, dimension( * ) iwork,
logical, dimension( * ) select,
double precision, dimension( 14 ) result,
integer info )

DCHKHS

Purpose:
!>
!>    DCHKHS  checks the nonsymmetric eigenvalue problem routines.
!>
!>            DGEHRD factors A as  U H U' , where ' means transpose,
!>            H is hessenberg, and U is an orthogonal matrix.
!>
!>            DORGHR generates the orthogonal matrix U.
!>
!>            DORMHR multiplies a matrix by the orthogonal matrix U.
!>
!>            DHSEQR factors H as  Z T Z' , where Z is orthogonal and
!>            T is , and the eigenvalue vector W.
!>
!>            DTREVC computes the left and right eigenvector matrices
!>            L and R for T.
!>
!>            DHSEIN computes the left and right eigenvector matrices
!>            Y and X for H, using inverse iteration.
!>
!>    When DCHKHS 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**T | / ( |A| n ulp )
!>
!>    (2)     | I - UU**T | / ( n ulp )
!>
!>    (3)     | H - Z T Z**T | / ( |H| n ulp )
!>
!>    (4)     | I - ZZ**T | / ( n ulp )
!>
!>    (5)     | A - UZ H (UZ)**T | / ( |A| n ulp )
!>
!>    (6)     | I - UZ (UZ)**T | / ( 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 signs.
!>         (ULP = (first number larger than 1) - 1 )
!>    (5)  A diagonal matrix with geometrically spaced entries
!>         1, ..., ULP  and random signs.
!>    (6)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>         and random signs.
!>
!>    (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 orthogonal and
!>         T has evenly spaced entries 1, ..., ULP with random signs
!>         on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (10) A matrix of the form  U' T U, where U is orthogonal and
!>         T has geometrically spaced entries 1, ..., ULP with random
!>         signs 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
!>         signs on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (12) A matrix of the form  U' T U, where U is orthogonal and
!>         T has real or complex conjugate paired eigenvalues randomly
!>         chosen from ( ULP, 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 signs 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 signs 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 signs 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 real or complex conjugate paired
!>         eigenvalues randomly chosen from ( ULP, 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 (-1,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,
!>           DCHKHS 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, DCHKHS
!>           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 DCHKHS to continue the same random number
!>           sequence.
!>           Modified.
!>
!>  THRESH - DOUBLE PRECISION
!>           A test will count as  if the , computed as
!>           described above, exceeds THRESH.  Note that the error
!>           is scaled to be O(1), so THRESH should be a reasonably
!>           small multiple of 1, e.g., 10 or 100.  In particular,
!>           it should not depend on the precision (single vs. double)
!>           or the size of the matrix.  It must be at least zero.
!>           Not modified.
!>
!>  NOUNIT - INTEGER
!>           The FORTRAN unit number for printing out error messages
!>           (e.g., if a routine returns IINFO not equal to 0.)
!>           Not modified.
!>
!>  A      - DOUBLE PRECISION 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      - DOUBLE PRECISION array, dimension (LDA,max(NN))
!>           The upper hessenberg matrix computed by DGEHRD.  On exit,
!>           H contains the Hessenberg form of the matrix in A.
!>           Modified.
!>
!>  T1     - DOUBLE PRECISION array, dimension (LDA,max(NN))
!>           The Schur (=) matrix computed by DHSEQR
!>           if Z is computed.  On exit, T1 contains the Schur form of
!>           the matrix in A.
!>           Modified.
!>
!>  T2     - DOUBLE PRECISION array, dimension (LDA,max(NN))
!>           The Schur matrix computed by DHSEQR 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      - DOUBLE PRECISION array, dimension (LDU,max(NN))
!>           The orthogonal matrix computed by DGEHRD.
!>           Modified.
!>
!>  Z      - DOUBLE PRECISION array, dimension (LDU,max(NN))
!>           The orthogonal matrix computed by DHSEQR.
!>           Modified.
!>
!>  UZ     - DOUBLE PRECISION array, dimension (LDU,max(NN))
!>           The product of U times Z.
!>           Modified.
!>
!>  WR1    - DOUBLE PRECISION array, dimension (max(NN))
!>  WI1    - DOUBLE PRECISION array, dimension (max(NN))
!>           The real and imaginary parts of the eigenvalues of A,
!>           as computed when Z is computed.
!>           On exit, WR1 + WI1*i are the eigenvalues of the matrix in A.
!>           Modified.
!>
!>  WR2    - DOUBLE PRECISION array, dimension (max(NN))
!>  WI2    - DOUBLE PRECISION array, dimension (max(NN))
!>           The real and imaginary parts of the eigenvalues of A,
!>           as computed when T is computed but not Z.
!>           On exit, WR2 + WI2*i are the eigenvalues of the matrix in A.
!>           Modified.
!>
!>  WR3    - DOUBLE PRECISION array, dimension (max(NN))
!>  WI3    - DOUBLE PRECISION array, dimension (max(NN))
!>           Like WR1, WI1, these arrays contain the eigenvalues of A,
!>           but those computed when DHSEQR only computes the
!>           eigenvalues, i.e., not the Schur vectors and no more of the
!>           Schur form than is necessary for computing the
!>           eigenvalues.
!>           Modified.
!>
!>  EVECTL - DOUBLE PRECISION array, dimension (LDU,max(NN))
!>           The (upper triangular) left eigenvector matrix for the
!>           matrix in T1.  For complex conjugate pairs, the real part
!>           is stored in one row and the imaginary part in the next.
!>           Modified.
!>
!>  EVEZTR - DOUBLE PRECISION array, dimension (LDU,max(NN))
!>           The (upper triangular) right eigenvector matrix for the
!>           matrix in T1.  For complex conjugate pairs, the real part
!>           is stored in one column and the imaginary part in the next.
!>           Modified.
!>
!>  EVECTY - DOUBLE PRECISION array, dimension (LDU,max(NN))
!>           The left eigenvector matrix for the
!>           matrix in H.  For complex conjugate pairs, the real part
!>           is stored in one row and the imaginary part in the next.
!>           Modified.
!>
!>  EVECTX - DOUBLE PRECISION array, dimension (LDU,max(NN))
!>           The right eigenvector matrix for the
!>           matrix in H.  For complex conjugate pairs, the real part
!>           is stored in one column and the imaginary part in the next.
!>           Modified.
!>
!>  UU     - DOUBLE PRECISION array, dimension (LDU,max(NN))
!>           Details of the orthogonal matrix computed by DGEHRD.
!>           Modified.
!>
!>  TAU    - DOUBLE PRECISION array, dimension(max(NN))
!>           Further details of the orthogonal matrix computed by DGEHRD.
!>           Modified.
!>
!>  WORK   - DOUBLE PRECISION array, dimension (NWORK)
!>           Workspace.
!>           Modified.
!>
!>  NWORK  - INTEGER
!>           The number of entries in WORK.  NWORK >= 4*NN(j)*NN(j) + 2.
!>
!>  IWORK  - INTEGER array, dimension (max(NN))
!>           Workspace.
!>           Modified.
!>
!>  SELECT - LOGICAL array, dimension (max(NN))
!>           Workspace.
!>           Modified.
!>
!>  RESULT - DOUBLE PRECISION array, dimension (14)
!>           The values computed by the fourteen tests described above.
!>           The values are currently limited to 1/ulp, to avoid
!>           overflow.
!>           Modified.
!>
!>  INFO   - INTEGER
!>           If 0, then everything ran OK.
!>            -1: NSIZES < 0
!>            -2: Some NN(j) < 0
!>            -3: NTYPES < 0
!>            -6: THRESH < 0
!>            -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>           -14: LDU < 1 or LDU < NMAX.
!>           -28: NWORK too small.
!>           If  DLATMR, SLATMS, or SLATME returns an error code, the
!>               absolute value of it is returned.
!>           If 1, then DHSEQR could not find all the shifts.
!>           If 2, then the EISPACK code (for small blocks) failed.
!>           If >2, then 30*N iterations were not enough to find an
!>               eigenvalue or to decompose the problem.
!>           Modified.
!>
!>-----------------------------------------------------------------------
!>
!>     Some Local Variables and Parameters:
!>     ---- ----- --------- --- ----------
!>
!>     ZERO, ONE       Real 0 and 1.
!>     MAXTYP          The number of types defined.
!>     MTEST           The number of tests defined: care must be taken
!>                     that (1) the size of RESULT, (2) the number of
!>                     tests actually performed, and (3) MTEST agree.
!>     NTEST           The number of tests performed on this matrix
!>                     so far.  This should be less than MTEST, and
!>                     equal to it by the last test.  It will be less
!>                     if any of the routines being tested indicates
!>                     that it could not compute the matrices that
!>                     would be tested.
!>     NMAX            Largest value in NN.
!>     NMATS           The number of matrices generated so far.
!>     NERRS           The number of tests which have exceeded THRESH
!>                     so far (computed by DLAFTS).
!>     COND, CONDS,
!>     IMODE           Values to be passed to the matrix generators.
!>     ANORM           Norm of A; passed to matrix generators.
!>
!>     OVFL, UNFL      Overflow and underflow thresholds.
!>     ULP, ULPINV     Finest relative precision and its inverse.
!>     RTOVFL, RTUNFL,
!>     RTULP, RTULPI   Square roots of the previous 4 values.
!>
!>             The following four arrays decode JTYPE:
!>     KTYPE(j)        The general type (1-10) for type .
!>     KMODE(j)        The MODE value to be passed to the matrix
!>                     generator for type .
!>     KMAGN(j)        The order of magnitude ( O(1),
!>                     O(overflow^(1/2) ), O(underflow^(1/2) )
!>     KCONDS(j)       Selects whether CONDS is to be 1 or
!>                     1/sqrt(ulp).  (0 means irrelevant.)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 407 of file dchkhs.f.

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

◆ dchksb()

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

DCHKSB

Purpose:
!>
!> DCHKSB tests the reduction of a symmetric band matrix to tridiagonal
!> form, used with the symmetric eigenvalue problem.
!>
!> DSBTRD factors a symmetric band matrix A as  U S U' , where ' means
!> transpose, S is symmetric tridiagonal, and U is orthogonal.
!> DSBTRD can use either just the lower or just the upper triangle
!> of A; DCHKSB checks both cases.
!>
!> When DCHKSB 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 symmetric banded reduction routine.  For each
!> matrix, a number of tests will be performed:
!>
!> (1)     | A - V S V' | / ( |A| n ulp )  computed by DSBTRD with
!>                                         UPLO='U'
!>
!> (2)     | I - UU' | / ( n ulp )
!>
!> (3)     | A - V S V' | / ( |A| n ulp )  computed by DSBTRD 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 orthogonal 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 orthogonal 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 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) 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 )
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          DCHKSB 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,
!>          DCHKSB 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, DCHKSB
!>          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 DCHKSB to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension
!>                            (LDA, max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 2 (not 1!)
!>          and at least max( KK )+1.
!>
[out]SD
!>          SD is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the diagonal of the tridiagonal matrix computed
!>          by DSBTRD.
!>
[out]SE
!>          SE is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the off-diagonal of the tridiagonal matrix
!>          computed by DSBTRD.
!>
[out]U
!>          U is DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          Used to hold the orthogonal matrix computed by DSBTRD.
!>
[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 DOUBLE PRECISION 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]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far.
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 290 of file dchksb.f.

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

◆ dchksb2stg()

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

DCHKSB2STG

Purpose:
!>
!> DCHKSB2STG tests the reduction of a symmetric band matrix to tridiagonal
!> form, used with the symmetric eigenvalue problem.
!>
!> DSBTRD factors a symmetric band matrix A as  U S U' , where ' means
!> transpose, S is symmetric tridiagonal, and U is orthogonal.
!> DSBTRD can use either just the lower or just the upper triangle
!> of A; DCHKSB2STG checks both cases.
!>
!> DSYTRD_SB2ST factors a symmetric band matrix A as  U S U' ,
!> where ' means transpose, S is symmetric tridiagonal, and U is
!> orthogonal. DSYTRD_SB2ST can use either just the lower or just
!> the upper triangle of A; DCHKSB2STG 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 DCHKSB2STG 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 symmetric banded reduction routine.  For each
!> matrix, a number of tests will be performed:
!>
!> (1)     | A - V S V' | / ( |A| n ulp )  computed by DSBTRD with
!>                                         UPLO='U'
!>
!> (2)     | I - UU' | / ( n ulp )
!>
!> (3)     | A - V S V' | / ( |A| n ulp )  computed by DSBTRD 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
!>                                         DSYTRD_SB2ST with UPLO='U'
!>
!> (6)     | D1 - D3 | / ( |D1| ulp )      where D1 is computed by
!>                                         DSBTRD with UPLO='U' and
!>                                         D3 is computed by
!>                                         DSYTRD_SB2ST 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 orthogonal 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 orthogonal 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 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) 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 )
!>
Parameters
[in]NSIZES
!>          NSIZES is INTEGER
!>          The number of sizes of matrices to use.  If it is zero,
!>          DCHKSB2STG 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,
!>          DCHKSB2STG 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, DCHKSB2STG
!>          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 DCHKSB2STG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension
!>                            (LDA, max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 2 (not 1!)
!>          and at least max( KK )+1.
!>
[out]SD
!>          SD is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the diagonal of the tridiagonal matrix computed
!>          by DSBTRD.
!>
[out]SE
!>          SE is DOUBLE PRECISION array, dimension (max(NN))
!>          Used to hold the off-diagonal of the tridiagonal matrix
!>          computed by DSBTRD.
!>
[out]D1
!>          D1 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]D2
!>          D2 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]D3
!>          D3 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]U
!>          U is DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          Used to hold the orthogonal matrix computed by DSBTRD.
!>
[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 DOUBLE PRECISION 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]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far.
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 329 of file dchksb2stg.f.

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

◆ dchkst()

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

DCHKST

Purpose:
!>
!> DCHKST  checks the symmetric eigenvalue problem routines.
!>
!>    DSYTRD factors A as  U S U' , where ' means transpose,
!>    S is symmetric tridiagonal, and U is orthogonal.
!>    DSYTRD can use either just the lower or just the upper triangle
!>    of A; DCHKST 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.
!>
!>    DSPTRD does the same as DSYTRD, except that A and V are stored
!>    in  format.
!>
!>    DORGTR constructs the matrix U from the contents of V and TAU.
!>
!>    DOPGTR constructs the matrix U from the contents of VP and TAU.
!>
!>    DSTEQR factors S as  Z D1 Z' , where Z is the orthogonal
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal.  D2 is the matrix of
!>    eigenvalues computed when Z is not computed.
!>
!>    DSTERF computes D3, the matrix of eigenvalues, by the
!>    PWK method, which does not yield eigenvectors.
!>
!>    DPTEQR factors S as  Z4 D4 Z4' , for a
!>    symmetric positive definite tridiagonal matrix.
!>    D5 is the matrix of eigenvalues computed when Z is not
!>    computed.
!>
!>    DSTEBZ computes selected eigenvalues.  WA1, WA2, and
!>    WA3 will denote eigenvalues computed to high
!>    absolute accuracy, with different range options.
!>    WR will denote eigenvalues computed to high relative
!>    accuracy.
!>
!>    DSTEIN computes Y, the eigenvectors of S, given the
!>    eigenvalues.
!>
!>    DSTEDC factors S as Z D1 Z' , where Z is the orthogonal
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal ('I' option). It may also
!>    update an input orthogonal matrix, usually the output
!>    from DSYTRD/DORGTR or DSPTRD/DOPGTR ('V' option). It may
!>    also just compute eigenvalues ('N' option).
!>
!>    DSTEMR factors S as Z D1 Z' , where Z is the orthogonal
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal ('I' option).  DSTEMR
!>    uses the Relatively Robust Representation whenever possible.
!>
!> When DCHKST 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 symmetric eigenroutines.  For each matrix, a number
!> of tests will be performed:
!>
!> (1)     | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='U', ... )
!>
!> (2)     | I - UV' | / ( n ulp )        DORGTR( UPLO='U', ... )
!>
!> (3)     | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='L', ... )
!>
!> (4)     | I - UV' | / ( n ulp )        DORGTR( UPLO='L', ... )
!>
!> (5-8)   Same as 1-4, but for DSPTRD and DOPGTR.
!>
!> (9)     | S - Z D Z' | / ( |S| n ulp ) DSTEQR('V',...)
!>
!> (10)    | I - ZZ' | / ( n ulp )        DSTEQR('V',...)
!>
!> (11)    | D1 - D2 | / ( |D1| ulp )        DSTEQR('N',...)
!>
!> (12)    | D1 - D3 | / ( |D1| ulp )        DSTERF
!>
!> (13)    0 if the true eigenvalues (computed by sturm count)
!>         of S are within THRESH of
!>         those in D1.  2*THRESH if they are not.  (Tested using
!>         DSTECH)
!>
!> For S positive definite,
!>
!> (14)    | S - Z4 D4 Z4' | / ( |S| n ulp ) DPTEQR('V',...)
!>
!> (15)    | I - Z4 Z4' | / ( n ulp )        DPTEQR('V',...)
!>
!> (16)    | D4 - D5 | / ( 100 |D4| ulp )       DPTEQR('N',...)
!>
!> When S is also diagonally dominant by the factor gamma < 1,
!>
!> (17)    max | D4(i) - WR(i) | / ( |D4(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              DSTEBZ( 'A', 'E', ...)
!>
!> (18)    | WA1 - D3 | / ( |D3| ulp )          DSTEBZ( 'A', 'E', ...)
!>
!> (19)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>                                              DSTEBZ( 'I', 'E', ...)
!>
!> (20)    | S - Y WA1 Y' | / ( |S| n ulp )  DSTEBZ, SSTEIN
!>
!> (21)    | I - Y Y' | / ( n ulp )          DSTEBZ, SSTEIN
!>
!> (22)    | S - Z D Z' | / ( |S| n ulp )    DSTEDC('I')
!>
!> (23)    | I - ZZ' | / ( n ulp )           DSTEDC('I')
!>
!> (24)    | S - Z D Z' | / ( |S| n ulp )    DSTEDC('V')
!>
!> (25)    | I - ZZ' | / ( n ulp )           DSTEDC('V')
!>
!> (26)    | D1 - D2 | / ( |D1| ulp )           DSTEDC('V') and
!>                                              DSTEDC('N')
!>
!> Test 27 is disabled at the moment because DSTEMR 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
!>                                              DSTEMR('V', 'A')
!>
!> (28)    max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              DSTEMR('V', 'I')
!>
!> Tests 29 through 34 are disable at present because DSTEMR
!> does not handle partial spectrum requests.
!>
!> (29)    | S - Z D Z' | / ( |S| n ulp )    DSTEMR('V', 'I')
!>
!> (30)    | I - ZZ' | / ( n ulp )           DSTEMR('V', 'I')
!>
!> (31)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         DSTEMR('N', 'I') vs. SSTEMR('V', 'I')
!>
!> (32)    | S - Z D Z' | / ( |S| n ulp )    DSTEMR('V', 'V')
!>
!> (33)    | I - ZZ' | / ( n ulp )           DSTEMR('V', 'V')
!>
!> (34)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         DSTEMR('N', 'V') vs. SSTEMR('V', 'V')
!>
!> (35)    | S - Z D Z' | / ( |S| n ulp )    DSTEMR('V', 'A')
!>
!> (36)    | I - ZZ' | / ( n ulp )           DSTEMR('V', 'A')
!>
!> (37)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         DSTEMR('N', 'A') vs. SSTEMR('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 orthogonal 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 orthogonal 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 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) 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) 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,
!>          DCHKST 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, DCHKST
!>          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 DCHKST to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is DOUBLE PRECISION array 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 DOUBLE PRECISION array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix A stored in packed format.
!>
[out]SD
!>          SD is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The diagonal of the tridiagonal matrix computed by DSYTRD.
!>          On exit, SD and SE contain the tridiagonal form of the
!>          matrix in A.
!>
[out]SE
!>          SE is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The off-diagonal of the tridiagonal matrix computed by
!>          DSYTRD.  On exit, SD and SE contain the tridiagonal form of
!>          the matrix in A.
!>
[out]D1
!>          D1 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>
[out]D2
!>          D2 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>
[out]D3
!>          D3 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>
[out]D4
!>          D4 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DPTEQR(V).
!>          DPTEQR factors S as  Z4 D4 Z4*
!>          On exit, the eigenvalues in D4 correspond with the matrix in A.
!>
[out]D5
!>          D5 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DPTEQR(N)
!>          when Z is not computed. On exit, the
!>          eigenvalues in D4 correspond with the matrix in A.
!>
[out]WA1
!>          WA1 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>
[out]WA2
!>          WA2 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>          Choose random values for IL and IU, and ask for the
!>          IL-th through IU-th eigenvalues.
!>
[out]WA3
!>          WA3 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>          Determine the values VL and VU of the IL-th and IU-th
!>          eigenvalues and ask for all eigenvalues in this range.
!>
[out]WR
!>          WR is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different options.
!>          as computed by DSTEBZ.
!>
[out]U
!>          U is DOUBLE PRECISION array of
!>                             dimension( LDU, max(NN) ).
!>          The orthogonal matrix computed by DSYTRD + DORGTR.
!>
[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 DOUBLE PRECISION array of
!>                             dimension( LDU, max(NN) ).
!>          The Housholder vectors computed by DSYTRD 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 DSYTRD, 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 DORGTR, set those entries to
!>          1 before using them, and then restore them later.)
!>
[out]VP
!>          VP is DOUBLE PRECISION array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix V stored in packed format.
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The Householder factors computed by DSYTRD in reducing A
!>          to tridiagonal form.
!>
[out]Z
!>          Z is DOUBLE PRECISION array of
!>                             dimension( LDU, max(NN) ).
!>          The orthogonal matrix of eigenvectors computed by DSTEQR,
!>          DPTEQR, and DSTEIN.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (26)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -23: LDU < 1 or LDU < NMAX.
!>          -29: LWORK too small.
!>          If  DLATMR, SLATMS, DSYTRD, DORGTR, DSTEQR, SSTERF,
!>              or DORMC2 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 587 of file dchkst.f.

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

◆ dchkst2stg()

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

DCHKST2STG

Purpose:
!>
!> DCHKST2STG  checks the symmetric 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
!> DSYTRD. For that, we call the standard DSYTRD and compute D1 using 
!> DSTEQR, then we call the 2-stage DSYTRD_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 DCHKST in the next 
!> release when vectors and generation of Q will be implemented.
!>
!>    DSYTRD factors A as  U S U' , where ' means transpose,
!>    S is symmetric tridiagonal, and U is orthogonal.
!>    DSYTRD can use either just the lower or just the upper triangle
!>    of A; DCHKST2STG 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.
!>
!>    DSPTRD does the same as DSYTRD, except that A and V are stored
!>    in  format.
!>
!>    DORGTR constructs the matrix U from the contents of V and TAU.
!>
!>    DOPGTR constructs the matrix U from the contents of VP and TAU.
!>
!>    DSTEQR factors S as  Z D1 Z' , where Z is the orthogonal
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal.  D2 is the matrix of
!>    eigenvalues computed when Z is not computed.
!>
!>    DSTERF computes D3, the matrix of eigenvalues, by the
!>    PWK method, which does not yield eigenvectors.
!>
!>    DPTEQR factors S as  Z4 D4 Z4' , for a
!>    symmetric positive definite tridiagonal matrix.
!>    D5 is the matrix of eigenvalues computed when Z is not
!>    computed.
!>
!>    DSTEBZ computes selected eigenvalues.  WA1, WA2, and
!>    WA3 will denote eigenvalues computed to high
!>    absolute accuracy, with different range options.
!>    WR will denote eigenvalues computed to high relative
!>    accuracy.
!>
!>    DSTEIN computes Y, the eigenvectors of S, given the
!>    eigenvalues.
!>
!>    DSTEDC factors S as Z D1 Z' , where Z is the orthogonal
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal ('I' option). It may also
!>    update an input orthogonal matrix, usually the output
!>    from DSYTRD/DORGTR or DSPTRD/DOPGTR ('V' option). It may
!>    also just compute eigenvalues ('N' option).
!>
!>    DSTEMR factors S as Z D1 Z' , where Z is the orthogonal
!>    matrix of eigenvectors and D1 is a diagonal matrix with
!>    the eigenvalues on the diagonal ('I' option).  DSTEMR
!>    uses the Relatively Robust Representation whenever possible.
!>
!> When DCHKST2STG 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 symmetric eigenroutines.  For each matrix, a number
!> of tests will be performed:
!>
!> (1)     | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='U', ... )
!>
!> (2)     | I - UV' | / ( n ulp )        DORGTR( UPLO='U', ... )
!>
!> (3)     | A - V S V' | / ( |A| n ulp ) DSYTRD( 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
!>         DSYTRD_2STAGE(, ,....). D1 and D2 are computed 
!>         via DSTEQR('N',...)  
!>
!> (4)     | I - UV' | / ( n ulp )        DORGTR( 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
!>         DSYTRD_2STAGE(, ,....). D1 and D3 are computed 
!>         via DSTEQR('N',...)  
!>
!> (5-8)   Same as 1-4, but for DSPTRD and DOPGTR.
!>
!> (9)     | S - Z D Z' | / ( |S| n ulp ) DSTEQR('V',...)
!>
!> (10)    | I - ZZ' | / ( n ulp )        DSTEQR('V',...)
!>
!> (11)    | D1 - D2 | / ( |D1| ulp )        DSTEQR('N',...)
!>
!> (12)    | D1 - D3 | / ( |D1| ulp )        DSTERF
!>
!> (13)    0 if the true eigenvalues (computed by sturm count)
!>         of S are within THRESH of
!>         those in D1.  2*THRESH if they are not.  (Tested using
!>         DSTECH)
!>
!> For S positive definite,
!>
!> (14)    | S - Z4 D4 Z4' | / ( |S| n ulp ) DPTEQR('V',...)
!>
!> (15)    | I - Z4 Z4' | / ( n ulp )        DPTEQR('V',...)
!>
!> (16)    | D4 - D5 | / ( 100 |D4| ulp )       DPTEQR('N',...)
!>
!> When S is also diagonally dominant by the factor gamma < 1,
!>
!> (17)    max | D4(i) - WR(i) | / ( |D4(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              DSTEBZ( 'A', 'E', ...)
!>
!> (18)    | WA1 - D3 | / ( |D3| ulp )          DSTEBZ( 'A', 'E', ...)
!>
!> (19)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>                                              DSTEBZ( 'I', 'E', ...)
!>
!> (20)    | S - Y WA1 Y' | / ( |S| n ulp )  DSTEBZ, SSTEIN
!>
!> (21)    | I - Y Y' | / ( n ulp )          DSTEBZ, SSTEIN
!>
!> (22)    | S - Z D Z' | / ( |S| n ulp )    DSTEDC('I')
!>
!> (23)    | I - ZZ' | / ( n ulp )           DSTEDC('I')
!>
!> (24)    | S - Z D Z' | / ( |S| n ulp )    DSTEDC('V')
!>
!> (25)    | I - ZZ' | / ( n ulp )           DSTEDC('V')
!>
!> (26)    | D1 - D2 | / ( |D1| ulp )           DSTEDC('V') and
!>                                              DSTEDC('N')
!>
!> Test 27 is disabled at the moment because DSTEMR 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
!>                                              DSTEMR('V', 'A')
!>
!> (28)    max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              DSTEMR('V', 'I')
!>
!> Tests 29 through 34 are disable at present because DSTEMR
!> does not handle partial spectrum requests.
!>
!> (29)    | S - Z D Z' | / ( |S| n ulp )    DSTEMR('V', 'I')
!>
!> (30)    | I - ZZ' | / ( n ulp )           DSTEMR('V', 'I')
!>
!> (31)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         DSTEMR('N', 'I') vs. SSTEMR('V', 'I')
!>
!> (32)    | S - Z D Z' | / ( |S| n ulp )    DSTEMR('V', 'V')
!>
!> (33)    | I - ZZ' | / ( n ulp )           DSTEMR('V', 'V')
!>
!> (34)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         DSTEMR('N', 'V') vs. SSTEMR('V', 'V')
!>
!> (35)    | S - Z D Z' | / ( |S| n ulp )    DSTEMR('V', 'A')
!>
!> (36)    | I - ZZ' | / ( n ulp )           DSTEMR('V', 'A')
!>
!> (37)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         DSTEMR('N', 'A') vs. SSTEMR('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 orthogonal 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 orthogonal 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 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) 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) 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,
!>          DCHKST2STG 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, DCHKST2STG
!>          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 DCHKST2STG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is DOUBLE PRECISION array 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 DOUBLE PRECISION array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix A stored in packed format.
!>
[out]SD
!>          SD is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The diagonal of the tridiagonal matrix computed by DSYTRD.
!>          On exit, SD and SE contain the tridiagonal form of the
!>          matrix in A.
!>
[out]SE
!>          SE is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The off-diagonal of the tridiagonal matrix computed by
!>          DSYTRD.  On exit, SD and SE contain the tridiagonal form of
!>          the matrix in A.
!>
[out]D1
!>          D1 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>
[out]D2
!>          D2 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>
[out]D3
!>          D3 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>
[out]D4
!>          D4 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DPTEQR(V).
!>          DPTEQR factors S as  Z4 D4 Z4*
!>          On exit, the eigenvalues in D4 correspond with the matrix in A.
!>
[out]D5
!>          D5 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by DPTEQR(N)
!>          when Z is not computed. On exit, the
!>          eigenvalues in D4 correspond with the matrix in A.
!>
[out]WA1
!>          WA1 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>
[out]WA2
!>          WA2 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>          Choose random values for IL and IU, and ask for the
!>          IL-th through IU-th eigenvalues.
!>
[out]WA3
!>          WA3 is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by DSTEBZ.
!>          Determine the values VL and VU of the IL-th and IU-th
!>          eigenvalues and ask for all eigenvalues in this range.
!>
[out]WR
!>          WR is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different options.
!>          as computed by DSTEBZ.
!>
[out]U
!>          U is DOUBLE PRECISION array of
!>                             dimension( LDU, max(NN) ).
!>          The orthogonal matrix computed by DSYTRD + DORGTR.
!>
[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 DOUBLE PRECISION array of
!>                             dimension( LDU, max(NN) ).
!>          The Housholder vectors computed by DSYTRD 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 DSYTRD, 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 DORGTR, set those entries to
!>          1 before using them, and then restore them later.)
!>
[out]VP
!>          VP is DOUBLE PRECISION array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix V stored in packed format.
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array of
!>                             dimension( max(NN) )
!>          The Householder factors computed by DSYTRD in reducing A
!>          to tridiagonal form.
!>
[out]Z
!>          Z is DOUBLE PRECISION array of
!>                             dimension( LDU, max(NN) ).
!>          The orthogonal matrix of eigenvectors computed by DSTEQR,
!>          DPTEQR, and DSTEIN.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (26)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -23: LDU < 1 or LDU < NMAX.
!>          -29: LWORK too small.
!>          If  DLATMR, SLATMS, DSYTRD, DORGTR, DSTEQR, SSTERF,
!>              or DORMC2 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 608 of file dchkst2stg.f.

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

◆ dckcsd()

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

DCKCSD

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

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

◆ dckglm()

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

DCKGLM

Purpose:
!>
!> DCKGLM tests DGGGLM - 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]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]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix row dimension N.
!>
[in]NMATS
!>          NMATS is INTEGER
!>          The number of matrix types to be tested for each combination
!>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
!>          number of matrix types), then all the different types are
!>          generated for testing.  If NMATS < NTYPES, another input line
!>          is read to get the numbers of the matrix types to be used.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator.  The array
!>          elements should be between 0 and 4095, otherwise they will be
!>          reduced mod 4096, and ISEED(4) must be odd.
!>          On exit, the next seed in the random number sequence after
!>          all the test matrices have been generated.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if 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 DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (4*NMAX)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 DLATMS 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 164 of file dckglm.f.

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

◆ dckgqr()

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

DCKGQR

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

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

◆ dckgsv()

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

DCKGSV

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

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

◆ dcklse()

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

DCKLSE

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

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

◆ dcsdts()

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

DCSDTS

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

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

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

Definition at line 226 of file dcsdts.f.

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

◆ ddrges()

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

DDRGES

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

Definition at line 399 of file ddrges.f.

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

◆ ddrges3()

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

DDRGES3

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

Definition at line 399 of file ddrges3.f.

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

◆ ddrgev()

subroutine ddrgev ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( lda, * ) b,
double precision, dimension( lda, * ) s,
double precision, dimension( lda, * ) t,
double precision, dimension( ldq, * ) q,
integer ldq,
double precision, dimension( ldq, * ) z,
double precision, dimension( ldqe, * ) qe,
integer ldqe,
double precision, dimension( * ) alphar,
double precision, dimension( * ) alphai,
double precision, dimension( * ) beta,
double precision, dimension( * ) alphr1,
double precision, dimension( * ) alphi1,
double precision, dimension( * ) beta1,
double precision, dimension( * ) work,
integer lwork,
double precision, dimension( * ) result,
integer info )

DDRGEV

Purpose:
!>
!> DDRGEV checks the nonsymmetric generalized eigenvalue problem driver
!> routine DGGEV.
!>
!> DGGEV 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 DDRGEV 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 DGGEV:
!>
!> (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,
!>          DDRGES does nothing.  NSIZES >= 0.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          An array containing the sizes to be used for the matrices.
!>          Zero values will be skipped.  NN >= 0.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, DDRGES
!>          does nothing.  It must be at least zero.  If it is MAXTYP+1
!>          and NSIZES is 1, then an additional type, MAXTYP+1 is
!>          defined, which is to use whatever matrix is in A.  This
!>          is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
!>          DOTYPE(MAXTYP+1) is .TRUE. .
!>
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          If DOTYPE(j) is .TRUE., then for each size in NN a
!>          matrix of that size and of type j will be generated.
!>          If NTYPES is smaller than the maximum number of types
!>          defined (PARAMETER MAXTYP), then types NTYPES+1 through
!>          MAXTYP will not be generated. If NTYPES is larger
!>          than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
!>          will be ignored.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry ISEED specifies the seed of the random number
!>          generator. The array elements should be between 0 and 4095;
!>          if not they will be reduced mod 4096. Also, ISEED(4) must
!>          be odd.  The random number generator uses a linear
!>          congruential sequence limited to small integers, and so
!>          should produce machine independent random numbers. The
!>          values of ISEED are changed on exit, and can be used in the
!>          next call to DDRGES to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error is
!>          scaled to be O(1), so THRESH should be a reasonably small
!>          multiple of 1, e.g., 10 or 100.  In particular, it should
!>          not depend on the precision (single vs. double) or the size
!>          of the matrix.  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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array,
!>                                 dimension (LDA, max(NN))
!>          The Schur form matrix computed from A by DGGES.  On exit, S
!>          contains the Schur form matrix corresponding to the matrix
!>          in A.
!>
[out]T
!>          T is DOUBLE PRECISION array,
!>                                 dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by DGGES.
!>
[out]Q
!>          Q is DOUBLE PRECISION array,
!>                                 dimension (LDQ, max(NN))
!>          The (left) eigenvectors matrix computed by DGGEV.
!>
[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 DOUBLE PRECISION array, dimension( LDQ, max(NN) )
!>          The (right) orthogonal matrix computed by DGGES.
!>
[out]QE
!>          QE is DOUBLE PRECISION 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]ALPHAR
!>          ALPHAR is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]ALPHAI
!>          ALPHAI is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by DGGEV.
!>          ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
!>          generalized eigenvalue of A and B.
!>
[out]ALPHR1
!>          ALPHR1 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]ALPHI1
!>          ALPHI1 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]BETA1
!>          BETA1 is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          Like ALPHAR, ALPHAI, BETA, these arrays contain the
!>          eigenvalues of A and B, but those computed when DGGEV only
!>          computes a partial eigendecomposition, i.e. not the
!>          eigenvalues and left and right eigenvectors.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  LWORK >= MAX( 8*N, N*(N+1) ).
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  A routine returned an error code.  INFO is the
!>                absolute value of the INFO value returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 404 of file ddrgev.f.

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

◆ ddrgev3()

subroutine ddrgev3 ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( lda, * ) b,
double precision, dimension( lda, * ) s,
double precision, dimension( lda, * ) t,
double precision, dimension( ldq, * ) q,
integer ldq,
double precision, dimension( ldq, * ) z,
double precision, dimension( ldqe, * ) qe,
integer ldqe,
double precision, dimension( * ) alphar,
double precision, dimension( * ) alphai,
double precision, dimension( * ) beta,
double precision, dimension( * ) alphr1,
double precision, dimension( * ) alphi1,
double precision, dimension( * ) beta1,
double precision, dimension( * ) work,
integer lwork,
double precision, dimension( * ) result,
integer info )

DDRGEV3

Purpose:
!>
!> DDRGEV3 checks the nonsymmetric generalized eigenvalue problem driver
!> routine DGGEV3.
!>
!> DGGEV3 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 DDRGEV3 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 DGGEV3:
!>
!> (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,
!>          DDRGEV3 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, DDRGEV3
!>          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 DDRGEV3 to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error is
!>          scaled to be O(1), so THRESH should be a reasonably small
!>          multiple of 1, e.g., 10 or 100.  In particular, it should
!>          not depend on the precision (single vs. double) or the size
!>          of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IERR not equal to 0.)
!>
[in,out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array,
!>                                 dimension (LDA, max(NN))
!>          The Schur form matrix computed from A by DGGEV3.  On exit, S
!>          contains the Schur form matrix corresponding to the matrix
!>          in A.
!>
[out]T
!>          T is DOUBLE PRECISION array,
!>                                 dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by DGGEV3.
!>
[out]Q
!>          Q is DOUBLE PRECISION array,
!>                                 dimension (LDQ, max(NN))
!>          The (left) eigenvectors matrix computed by DGGEV3.
!>
[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 DOUBLE PRECISION array, dimension( LDQ, max(NN) )
!>          The (right) orthogonal matrix computed by DGGEV3.
!>
[out]QE
!>          QE is DOUBLE PRECISION 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]ALPHAR
!>          ALPHAR is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]ALPHAI
!>          ALPHAI is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by DGGEV3.
!>          ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
!>          generalized eigenvalue of A and B.
!>
[out]ALPHR1
!>          ALPHR1 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]ALPHI1
!>          ALPHI1 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]BETA1
!>          BETA1 is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          Like ALPHAR, ALPHAI, BETA, these arrays contain the
!>          eigenvalues of A and B, but those computed when DGGEV3 only
!>          computes a partial eigendecomposition, i.e. not the
!>          eigenvalues and left and right eigenvectors.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  LWORK >= MAX( 8*N, N*(N+1) ).
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  A routine returned an error code.  INFO is the
!>                absolute value of the INFO value returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 404 of file ddrgev3.f.

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

◆ ddrgsx()

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

DDRGSX

Purpose:
!>
!> DDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
!> problem expert driver DGGESX.
!>
!> DGGESX factors A and B as Q S Z' and Q T Z', where ' means
!> transpose, T is upper triangular, S is in generalized Schur form
!> (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
!> the 2x2 blocks corresponding to complex conjugate pairs of
!> generalized eigenvalues), and Q and Z are orthogonal.  It also
!> computes the generalized eigenvalues (alpha(1),beta(1)), ...,
!> (alpha(n),beta(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 DDRGSX is called with NSIZE > 0, five (5) types of built-in
!> matrix pairs are used to test the routine DGGESX.
!>
!> When DDRGSX is called with NSIZE = 0, it reads in test matrix data
!> to test DGGESX.
!>
!> 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. quasi-triangular form)
!>
!> (6)   maximum over j of D(j)  where:
!>
!>       if alpha(j) is real:
!>                     |alpha(j) - S(j,j)|        |beta(j) - T(j,j)|
!>           D(j) = ------------------------ + -----------------------
!>                  max(|alpha(j)|,|S(j,j)|)   max(|beta(j)|,|T(j,j)|)
!>
!>       if alpha(j) is complex:
!>                                 | det( s S - w T ) |
!>           D(j) = ---------------------------------------------------
!>                  ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
!>
!>           and S and T are here the 2 x 2 diagonal blocks of S and T
!>           corresponding to the j-th and j+1-th eigenvalues.
!>
!> (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 DGGESX, 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 above 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 DGESVD) is used for computing the true value of DIF_u
!> and DIF_l when testing the built-in test problems.
!>
!> Built-in Test Matrices
!> ======================
!>
!> All built-in test matrices are the 2 by 2 block of triangular
!> matrices
!>
!>          A = [ A11 A12 ]    and      B = [ B11 B12 ]
!>              [     A22 ]                 [     B22 ]
!>
!> where for different type of A11 and A22 are given as the following.
!> A12 and B12 are chosen so that the generalized Sylvester equation
!>
!>          A11*R - L*A22 = -A12
!>          B11*R - L*B22 = -B12
!>
!> have prescribed solution R and L.
!>
!> Type 1:  A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
!>          B11 = I_m, B22 = I_k
!>          where J_k(a,b) is the k-by-k Jordan block with ``a'' on
!>          diagonal and ``b'' on superdiagonal.
!>
!> Type 2:  A11 = (a_ij) = ( 2(.5-sin(i)) ) and
!>          B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
!>          A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
!>          B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
!>
!> Type 3:  A11, A22 and B11, B22 are chosen as for Type 2, but each
!>          second diagonal block in A_11 and each third diagonal block
!>          in A_22 are made as 2 by 2 blocks.
!>
!> Type 4:  A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
!>             for i=1,...,m,  j=1,...,m and
!>          A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
!>             for i=m+1,...,k,  j=m+1,...,k
!>
!> Type 5:  (A,B) and have potentially close or common eigenvalues and
!>          very large departure from block diagonality A_11 is chosen
!>          as the m x m leading submatrix of A_1:
!>                  |  1  b                            |
!>                  | -b  1                            |
!>                  |        1+d  b                    |
!>                  |         -b 1+d                   |
!>           A_1 =  |                  d  1            |
!>                  |                 -1  d            |
!>                  |                        -d  1     |
!>                  |                        -1 -d     |
!>                  |                               1  |
!>          and A_22 is chosen as the k x k leading submatrix of A_2:
!>                  | -1  b                            |
!>                  | -b -1                            |
!>                  |       1-d  b                     |
!>                  |       -b  1-d                    |
!>           A_2 =  |                 d 1+b            |
!>                  |               -1-b d             |
!>                  |                       -d  1+b    |
!>                  |                      -1+b  -d    |
!>                  |                              1-d |
!>          and matrix B are chosen as identity matrices (see DLATM5).
!>
!>
Parameters
[in]NSIZE
!>          NSIZE is INTEGER
!>          The maximum size of the matrices to use. NSIZE >= 0.
!>          If NSIZE = 0, no built-in tests matrices are used, but
!>          read-in test matrices are used to test DGGESX.
!>
[in]NCMAX
!>          NCMAX is INTEGER
!>          Maximum allowable NMAX for generating Kroneker matrix
!>          in call to DLAKF2
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  THRESH >= 0.
!>
[in]NIN
!>          NIN is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDA, NSIZE)
!>          Copy of A, modified by DGGESX.
!>
[out]BI
!>          BI is DOUBLE PRECISION array, dimension (LDA, NSIZE)
!>          Copy of B, modified by DGGESX.
!>
[out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDA, NSIZE)
!>          Z holds the left Schur vectors computed by DGGESX.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA, NSIZE)
!>          Q holds the right Schur vectors computed by DGGESX.
!>
[out]ALPHAR
!>          ALPHAR is DOUBLE PRECISION array, dimension (NSIZE)
!>
[out]ALPHAI
!>          ALPHAI is DOUBLE PRECISION array, dimension (NSIZE)
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (NSIZE)
!>
!>          On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDC, LDC)
!>          Store the matrix generated by subroutine DLAKF2, this is the
!>          matrix formed by Kronecker products used for estimating
!>          DIF.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (LDC)
!>          Singular values of C
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) )
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (LIWORK)
!>
[in]LIWORK
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK. LIWORK >= NSIZE + 6.
!>
[out]BWORK
!>          BWORK is LOGICAL array, dimension (LDA)
!>
[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 356 of file ddrgsx.f.

359*
360* -- LAPACK test routine --
361* -- LAPACK is a software package provided by Univ. of Tennessee, --
362* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
363*
364* .. Scalar Arguments ..
365 INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN,
366 $ NOUT, NSIZE
367 DOUBLE PRECISION THRESH
368* ..
369* .. Array Arguments ..
370 LOGICAL BWORK( * )
371 INTEGER IWORK( * )
372 DOUBLE PRECISION A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
373 $ ALPHAR( * ), B( LDA, * ), BETA( * ),
374 $ BI( LDA, * ), C( LDC, * ), Q( LDA, * ), S( * ),
375 $ WORK( * ), Z( LDA, * )
376* ..
377*
378* =====================================================================
379*
380* .. Parameters ..
381 DOUBLE PRECISION ZERO, ONE, TEN
382 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 1.0d+1 )
383* ..
384* .. Local Scalars ..
385 LOGICAL ILABAD
386 CHARACTER SENSE
387 INTEGER BDSPAC, I, I1, IFUNC, IINFO, J, LINFO, MAXWRK,
388 $ MINWRK, MM, MN2, NERRS, NPTKNT, NTEST, NTESTT,
389 $ PRTYPE, QBA, QBB
390 DOUBLE PRECISION ABNRM, BIGNUM, DIFTRU, PLTRU, SMLNUM, TEMP1,
391 $ TEMP2, THRSH2, ULP, ULPINV, WEIGHT
392* ..
393* .. Local Arrays ..
394 DOUBLE PRECISION DIFEST( 2 ), PL( 2 ), RESULT( 10 )
395* ..
396* .. External Functions ..
397 LOGICAL DLCTSX
398 INTEGER ILAENV
399 DOUBLE PRECISION DLAMCH, DLANGE
400 EXTERNAL dlctsx, ilaenv, dlamch, dlange
401* ..
402* .. External Subroutines ..
403 EXTERNAL alasvm, dgesvd, dget51, dget53, dggesx, dlabad,
404 $ dlacpy, dlakf2, dlaset, dlatm5, xerbla
405* ..
406* .. Intrinsic Functions ..
407 INTRINSIC abs, max, sqrt
408* ..
409* .. Scalars in Common ..
410 LOGICAL FS
411 INTEGER K, M, MPLUSN, N
412* ..
413* .. Common blocks ..
414 COMMON / mn / m, n, mplusn, k, fs
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 = -17
432 ELSE IF( liwork.LT.nsize+6 ) 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 = max( 10*( nsize+1 ), 5*nsize*nsize / 2 )
446*
447* workspace for sggesx
448*
449 maxwrk = 9*( nsize+1 ) + nsize*
450 $ ilaenv( 1, 'DGEQRF', ' ', nsize, 1, nsize, 0 )
451 maxwrk = max( maxwrk, 9*( nsize+1 )+nsize*
452 $ ilaenv( 1, 'DORGQR', ' ', nsize, 1, nsize, -1 ) )
453*
454* workspace for dgesvd
455*
456 bdspac = 5*nsize*nsize / 2
457 maxwrk = max( maxwrk, 3*nsize*nsize / 2+nsize*nsize*
458 $ ilaenv( 1, 'DGEBRD', ' ', 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 = -19
469*
470 IF( info.NE.0 ) THEN
471 CALL xerbla( 'DDRGSX', -info )
472 RETURN
473 END IF
474*
475* Important constants
476*
477 ulp = dlamch( 'P' )
478 ulpinv = one / ulp
479 smlnum = dlamch( 'S' ) / ulp
480 bignum = one / smlnum
481 CALL dlabad( 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 DGGESX, 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 dlaset( 'Full', mplusn, mplusn, zero, zero, ai,
515 $ lda )
516 CALL dlaset( 'Full', mplusn, mplusn, zero, zero, bi,
517 $ lda )
518*
519 CALL dlatm5( 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 DLCTSX
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 dlacpy( 'Full', mplusn, mplusn, ai, lda, a, lda )
540 CALL dlacpy( 'Full', mplusn, mplusn, bi, lda, b, lda )
541*
542 CALL dggesx( 'V', 'V', 'S', dlctsx, sense, mplusn, ai,
543 $ lda, bi, lda, mm, alphar, alphai, beta,
544 $ q, lda, z, lda, pl, difest, work, lwork,
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 )'DGGESX', linfo, mplusn,
550 $ prtype
551 info = linfo
552 GO TO 30
553 END IF
554*
555* Compute the norm(A, B)
556*
557 CALL dlacpy( 'Full', mplusn, mplusn, ai, lda, work,
558 $ mplusn )
559 CALL dlacpy( 'Full', mplusn, mplusn, bi, lda,
560 $ work( mplusn*mplusn+1 ), mplusn )
561 abnrm = dlange( 'Fro', mplusn, 2*mplusn, work, mplusn,
562 $ work )
563*
564* Do tests (1) to (4)
565*
566 CALL dget51( 1, mplusn, a, lda, ai, lda, q, lda, z,
567 $ lda, work, result( 1 ) )
568 CALL dget51( 1, mplusn, b, lda, bi, lda, q, lda, z,
569 $ lda, work, result( 2 ) )
570 CALL dget51( 3, mplusn, b, lda, bi, lda, q, lda, q,
571 $ lda, work, result( 3 ) )
572 CALL dget51( 3, mplusn, b, lda, bi, lda, z, lda, z,
573 $ lda, work, result( 4 ) )
574 ntest = 4
575*
576* Do tests (5) and (6): check Schur form of A and
577* compare eigenvalues with diagonals.
578*
579 temp1 = zero
580 result( 5 ) = zero
581 result( 6 ) = zero
582*
583 DO 10 j = 1, mplusn
584 ilabad = .false.
585 IF( alphai( j ).EQ.zero ) THEN
586 temp2 = ( abs( alphar( j )-ai( j, j ) ) /
587 $ max( smlnum, abs( alphar( j ) ),
588 $ abs( ai( j, j ) ) )+
589 $ abs( beta( j )-bi( j, j ) ) /
590 $ max( smlnum, abs( beta( j ) ),
591 $ abs( 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 ELSE
605 IF( alphai( j ).GT.zero ) THEN
606 i1 = j
607 ELSE
608 i1 = j - 1
609 END IF
610 IF( i1.LE.0 .OR. i1.GE.mplusn ) THEN
611 ilabad = .true.
612 ELSE IF( i1.LT.mplusn-1 ) THEN
613 IF( ai( i1+2, i1+1 ).NE.zero ) THEN
614 ilabad = .true.
615 result( 5 ) = ulpinv
616 END IF
617 ELSE IF( i1.GT.1 ) THEN
618 IF( ai( i1, i1-1 ).NE.zero ) THEN
619 ilabad = .true.
620 result( 5 ) = ulpinv
621 END IF
622 END IF
623 IF( .NOT.ilabad ) THEN
624 CALL dget53( ai( i1, i1 ), lda, bi( i1, i1 ),
625 $ lda, beta( j ), alphar( j ),
626 $ alphai( j ), temp2, iinfo )
627 IF( iinfo.GE.3 ) THEN
628 WRITE( nout, fmt = 9997 )iinfo, j,
629 $ mplusn, prtype
630 info = abs( iinfo )
631 END IF
632 ELSE
633 temp2 = ulpinv
634 END IF
635 END IF
636 temp1 = max( temp1, temp2 )
637 IF( ilabad ) THEN
638 WRITE( nout, fmt = 9996 )j, mplusn, prtype
639 END IF
640 10 CONTINUE
641 result( 6 ) = temp1
642 ntest = ntest + 2
643*
644* Test (7) (if sorting worked)
645*
646 result( 7 ) = zero
647 IF( linfo.EQ.mplusn+3 ) THEN
648 result( 7 ) = ulpinv
649 ELSE IF( mm.NE.n ) THEN
650 result( 7 ) = ulpinv
651 END IF
652 ntest = ntest + 1
653*
654* Test (8): compare the estimated value DIF and its
655* value. first, compute the exact DIF.
656*
657 result( 8 ) = zero
658 mn2 = mm*( mplusn-mm )*2
659 IF( ifunc.GE.2 .AND. mn2.LE.ncmax*ncmax ) THEN
660*
661* Note: for either following two causes, there are
662* almost same number of test cases fail the test.
663*
664 CALL dlakf2( mm, mplusn-mm, ai, lda,
665 $ ai( mm+1, mm+1 ), bi,
666 $ bi( mm+1, mm+1 ), c, ldc )
667*
668 CALL dgesvd( 'N', 'N', mn2, mn2, c, ldc, s, work,
669 $ 1, work( 2 ), 1, work( 3 ), lwork-2,
670 $ info )
671 diftru = s( mn2 )
672*
673 IF( difest( 2 ).EQ.zero ) THEN
674 IF( diftru.GT.abnrm*ulp )
675 $ result( 8 ) = ulpinv
676 ELSE IF( diftru.EQ.zero ) THEN
677 IF( difest( 2 ).GT.abnrm*ulp )
678 $ result( 8 ) = ulpinv
679 ELSE IF( ( diftru.GT.thrsh2*difest( 2 ) ) .OR.
680 $ ( diftru*thrsh2.LT.difest( 2 ) ) ) THEN
681 result( 8 ) = max( diftru / difest( 2 ),
682 $ difest( 2 ) / diftru )
683 END IF
684 ntest = ntest + 1
685 END IF
686*
687* Test (9)
688*
689 result( 9 ) = zero
690 IF( linfo.EQ.( mplusn+2 ) ) THEN
691 IF( diftru.GT.abnrm*ulp )
692 $ result( 9 ) = ulpinv
693 IF( ( ifunc.GT.1 ) .AND. ( difest( 2 ).NE.zero ) )
694 $ result( 9 ) = ulpinv
695 IF( ( ifunc.EQ.1 ) .AND. ( pl( 1 ).NE.zero ) )
696 $ result( 9 ) = ulpinv
697 ntest = ntest + 1
698 END IF
699*
700 ntestt = ntestt + ntest
701*
702* Print out tests which fail.
703*
704 DO 20 j = 1, 9
705 IF( result( j ).GE.thresh ) THEN
706*
707* If this is the first test to fail,
708* print a header to the data file.
709*
710 IF( nerrs.EQ.0 ) THEN
711 WRITE( nout, fmt = 9995 )'DGX'
712*
713* Matrix types
714*
715 WRITE( nout, fmt = 9993 )
716*
717* Tests performed
718*
719 WRITE( nout, fmt = 9992 )'orthogonal', '''',
720 $ 'transpose', ( '''', i = 1, 4 )
721*
722 END IF
723 nerrs = nerrs + 1
724 IF( result( j ).LT.10000.0d0 ) THEN
725 WRITE( nout, fmt = 9991 )mplusn, prtype,
726 $ weight, m, j, result( j )
727 ELSE
728 WRITE( nout, fmt = 9990 )mplusn, prtype,
729 $ weight, m, j, result( j )
730 END IF
731 END IF
732 20 CONTINUE
733*
734 30 CONTINUE
735 40 CONTINUE
736 50 CONTINUE
737 60 CONTINUE
738*
739 GO TO 150
740*
741 70 CONTINUE
742*
743* Read in data from file to check accuracy of condition estimation
744* Read input data until N=0
745*
746 nptknt = 0
747*
748 80 CONTINUE
749 READ( nin, fmt = *, END = 140 )mplusn
750 IF( mplusn.EQ.0 )
751 $ GO TO 140
752 READ( nin, fmt = *, END = 140 )n
753 DO 90 i = 1, mplusn
754 READ( nin, fmt = * )( ai( i, j ), j = 1, mplusn )
755 90 CONTINUE
756 DO 100 i = 1, mplusn
757 READ( nin, fmt = * )( bi( i, j ), j = 1, mplusn )
758 100 CONTINUE
759 READ( nin, fmt = * )pltru, diftru
760*
761 nptknt = nptknt + 1
762 fs = .true.
763 k = 0
764 m = mplusn - n
765*
766 CALL dlacpy( 'Full', mplusn, mplusn, ai, lda, a, lda )
767 CALL dlacpy( 'Full', mplusn, mplusn, bi, lda, b, lda )
768*
769* Compute the Schur factorization while swapping the
770* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
771*
772 CALL dggesx( 'V', 'V', 'S', dlctsx, 'B', mplusn, ai, lda, bi, lda,
773 $ mm, alphar, alphai, beta, q, lda, z, lda, pl, difest,
774 $ work, lwork, iwork, liwork, bwork, linfo )
775*
776 IF( linfo.NE.0 .AND. linfo.NE.mplusn+2 ) THEN
777 result( 1 ) = ulpinv
778 WRITE( nout, fmt = 9998 )'DGGESX', linfo, mplusn, nptknt
779 GO TO 130
780 END IF
781*
782* Compute the norm(A, B)
783* (should this be norm of (A,B) or (AI,BI)?)
784*
785 CALL dlacpy( 'Full', mplusn, mplusn, ai, lda, work, mplusn )
786 CALL dlacpy( 'Full', mplusn, mplusn, bi, lda,
787 $ work( mplusn*mplusn+1 ), mplusn )
788 abnrm = dlange( 'Fro', mplusn, 2*mplusn, work, mplusn, work )
789*
790* Do tests (1) to (4)
791*
792 CALL dget51( 1, mplusn, a, lda, ai, lda, q, lda, z, lda, work,
793 $ result( 1 ) )
794 CALL dget51( 1, mplusn, b, lda, bi, lda, q, lda, z, lda, work,
795 $ result( 2 ) )
796 CALL dget51( 3, mplusn, b, lda, bi, lda, q, lda, q, lda, work,
797 $ result( 3 ) )
798 CALL dget51( 3, mplusn, b, lda, bi, lda, z, lda, z, lda, work,
799 $ result( 4 ) )
800*
801* Do tests (5) and (6): check Schur form of A and compare
802* eigenvalues with diagonals.
803*
804 ntest = 6
805 temp1 = zero
806 result( 5 ) = zero
807 result( 6 ) = zero
808*
809 DO 110 j = 1, mplusn
810 ilabad = .false.
811 IF( alphai( j ).EQ.zero ) THEN
812 temp2 = ( abs( alphar( j )-ai( j, j ) ) /
813 $ max( smlnum, abs( alphar( j ) ), abs( ai( j,
814 $ j ) ) )+abs( beta( j )-bi( j, j ) ) /
815 $ max( smlnum, abs( beta( j ) ), abs( bi( j, j ) ) ) )
816 $ / ulp
817 IF( j.LT.mplusn ) THEN
818 IF( ai( j+1, j ).NE.zero ) THEN
819 ilabad = .true.
820 result( 5 ) = ulpinv
821 END IF
822 END IF
823 IF( j.GT.1 ) THEN
824 IF( ai( j, j-1 ).NE.zero ) THEN
825 ilabad = .true.
826 result( 5 ) = ulpinv
827 END IF
828 END IF
829 ELSE
830 IF( alphai( j ).GT.zero ) THEN
831 i1 = j
832 ELSE
833 i1 = j - 1
834 END IF
835 IF( i1.LE.0 .OR. i1.GE.mplusn ) THEN
836 ilabad = .true.
837 ELSE IF( i1.LT.mplusn-1 ) THEN
838 IF( ai( i1+2, i1+1 ).NE.zero ) THEN
839 ilabad = .true.
840 result( 5 ) = ulpinv
841 END IF
842 ELSE IF( i1.GT.1 ) THEN
843 IF( ai( i1, i1-1 ).NE.zero ) THEN
844 ilabad = .true.
845 result( 5 ) = ulpinv
846 END IF
847 END IF
848 IF( .NOT.ilabad ) THEN
849 CALL dget53( ai( i1, i1 ), lda, bi( i1, i1 ), lda,
850 $ beta( j ), alphar( j ), alphai( j ), temp2,
851 $ iinfo )
852 IF( iinfo.GE.3 ) THEN
853 WRITE( nout, fmt = 9997 )iinfo, j, mplusn, nptknt
854 info = abs( iinfo )
855 END IF
856 ELSE
857 temp2 = ulpinv
858 END IF
859 END IF
860 temp1 = max( temp1, temp2 )
861 IF( ilabad ) THEN
862 WRITE( nout, fmt = 9996 )j, mplusn, nptknt
863 END IF
864 110 CONTINUE
865 result( 6 ) = temp1
866*
867* Test (7) (if sorting worked) <--------- need to be checked.
868*
869 ntest = 7
870 result( 7 ) = zero
871 IF( linfo.EQ.mplusn+3 )
872 $ result( 7 ) = ulpinv
873*
874* Test (8): compare the estimated value of DIF and its true value.
875*
876 ntest = 8
877 result( 8 ) = zero
878 IF( difest( 2 ).EQ.zero ) THEN
879 IF( diftru.GT.abnrm*ulp )
880 $ result( 8 ) = ulpinv
881 ELSE IF( diftru.EQ.zero ) THEN
882 IF( difest( 2 ).GT.abnrm*ulp )
883 $ result( 8 ) = ulpinv
884 ELSE IF( ( diftru.GT.thrsh2*difest( 2 ) ) .OR.
885 $ ( diftru*thrsh2.LT.difest( 2 ) ) ) THEN
886 result( 8 ) = max( diftru / difest( 2 ), difest( 2 ) / diftru )
887 END IF
888*
889* Test (9)
890*
891 ntest = 9
892 result( 9 ) = zero
893 IF( linfo.EQ.( mplusn+2 ) ) THEN
894 IF( diftru.GT.abnrm*ulp )
895 $ result( 9 ) = ulpinv
896 IF( ( ifunc.GT.1 ) .AND. ( difest( 2 ).NE.zero ) )
897 $ result( 9 ) = ulpinv
898 IF( ( ifunc.EQ.1 ) .AND. ( pl( 1 ).NE.zero ) )
899 $ result( 9 ) = ulpinv
900 END IF
901*
902* Test (10): compare the estimated value of PL and it true value.
903*
904 ntest = 10
905 result( 10 ) = zero
906 IF( pl( 1 ).EQ.zero ) THEN
907 IF( pltru.GT.abnrm*ulp )
908 $ result( 10 ) = ulpinv
909 ELSE IF( pltru.EQ.zero ) THEN
910 IF( pl( 1 ).GT.abnrm*ulp )
911 $ result( 10 ) = ulpinv
912 ELSE IF( ( pltru.GT.thresh*pl( 1 ) ) .OR.
913 $ ( pltru*thresh.LT.pl( 1 ) ) ) THEN
914 result( 10 ) = ulpinv
915 END IF
916*
917 ntestt = ntestt + ntest
918*
919* Print out tests which fail.
920*
921 DO 120 j = 1, ntest
922 IF( result( j ).GE.thresh ) THEN
923*
924* If this is the first test to fail,
925* print a header to the data file.
926*
927 IF( nerrs.EQ.0 ) THEN
928 WRITE( nout, fmt = 9995 )'DGX'
929*
930* Matrix types
931*
932 WRITE( nout, fmt = 9994 )
933*
934* Tests performed
935*
936 WRITE( nout, fmt = 9992 )'orthogonal', '''',
937 $ 'transpose', ( '''', i = 1, 4 )
938*
939 END IF
940 nerrs = nerrs + 1
941 IF( result( j ).LT.10000.0d0 ) THEN
942 WRITE( nout, fmt = 9989 )nptknt, mplusn, j, result( j )
943 ELSE
944 WRITE( nout, fmt = 9988 )nptknt, mplusn, j, result( j )
945 END IF
946 END IF
947*
948 120 CONTINUE
949*
950 130 CONTINUE
951 GO TO 80
952 140 CONTINUE
953*
954 150 CONTINUE
955*
956* Summary
957*
958 CALL alasvm( 'DGX', nout, nerrs, ntestt, 0 )
959*
960 work( 1 ) = maxwrk
961*
962 RETURN
963*
964 9999 FORMAT( ' DDRGSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
965 $ i6, ', JTYPE=', i6, ')' )
966*
967 9998 FORMAT( ' DDRGSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
968 $ i6, ', Input Example #', i2, ')' )
969*
970 9997 FORMAT( ' DDRGSX: DGET53 returned INFO=', i1, ' for eigenvalue ',
971 $ i6, '.', / 9x, 'N=', i6, ', JTYPE=', i6, ')' )
972*
973 9996 FORMAT( ' DDRGSX: S not in Schur form at eigenvalue ', i6, '.',
974 $ / 9x, 'N=', i6, ', JTYPE=', i6, ')' )
975*
976 9995 FORMAT( / 1x, a3, ' -- Real Expert Generalized Schur form',
977 $ ' problem driver' )
978*
979 9994 FORMAT( 'Input Example' )
980*
981 9993 FORMAT( ' Matrix types: ', /
982 $ ' 1: A is a block diagonal matrix of Jordan blocks ',
983 $ 'and B is the identity ', / ' matrix, ',
984 $ / ' 2: A and B are upper triangular matrices, ',
985 $ / ' 3: A and B are as type 2, but each second diagonal ',
986 $ 'block in A_11 and ', /
987 $ ' each third diaongal block in A_22 are 2x2 blocks,',
988 $ / ' 4: A and B are block diagonal matrices, ',
989 $ / ' 5: (A,B) has potentially close or common ',
990 $ 'eigenvalues.', / )
991*
992 9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
993 $ 'Q and Z are ', a, ',', / 19x,
994 $ ' a is alpha, b is beta, and ', a, ' means ', a, '.)',
995 $ / ' 1 = | A - Q S Z', a,
996 $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', a,
997 $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', a,
998 $ ' | / ( n ulp ) 4 = | I - ZZ', a,
999 $ ' | / ( n ulp )', / ' 5 = 1/ULP if A is not in ',
1000 $ 'Schur form S', / ' 6 = difference between (alpha,beta)',
1001 $ ' and diagonals of (S,T)', /
1002 $ ' 7 = 1/ULP if SDIM is not the correct number of ',
1003 $ 'selected eigenvalues', /
1004 $ ' 8 = 1/ULP if DIFEST/DIFTRU > 10*THRESH or ',
1005 $ 'DIFTRU/DIFEST > 10*THRESH',
1006 $ / ' 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B) ',
1007 $ 'when reordering fails', /
1008 $ ' 10 = 1/ULP if PLEST/PLTRU > THRESH or ',
1009 $ 'PLTRU/PLEST > THRESH', /
1010 $ ' ( Test 10 is only for input examples )', / )
1011 9991 FORMAT( ' Matrix order=', i2, ', type=', i2, ', a=', d10.3,
1012 $ ', order(A_11)=', i2, ', result ', i2, ' is ', 0p, f8.2 )
1013 9990 FORMAT( ' Matrix order=', i2, ', type=', i2, ', a=', d10.3,
1014 $ ', order(A_11)=', i2, ', result ', i2, ' is ', 0p, d10.3 )
1015 9989 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
1016 $ ' result ', i2, ' is', 0p, f8.2 )
1017 9988 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
1018 $ ' result ', i2, ' is', 1p, d10.3 )
1019*
1020* End of DDRGSX
1021*
dggesx
subroutine dggesx(jobvsl, jobvsr, sort, selctg, sense, n, a, lda, b, ldb, sdim, alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, rconde, rcondv, work, lwork, iwork, liwork, bwork, info)
DGGESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition dggesx.f:365
dgesvd
subroutine dgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, info)
DGESVD computes the singular value decomposition (SVD) for GE matrices
Definition dgesvd.f:211
dlctsx
logical function dlctsx(ar, ai, beta)
DLCTSX
Definition dlctsx.f:65
dlakf2
subroutine dlakf2(m, n, a, lda, b, d, e, z, ldz)
DLAKF2
Definition dlakf2.f:105
dlatm5
subroutine dlatm5(prtype, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, r, ldr, l, ldl, alpha, qblcka, qblckb)
DLATM5
Definition dlatm5.f:268

◆ ddrgvx()

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

DDRGVX

Purpose:
!>
!> DDRGVX checks the nonsymmetric generalized eigenvalue problem
!> expert driver DGGEVX.
!>
!> DGGEVX 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 DDRGVX is called with NSIZE > 0, two types of test matrix pairs
!> are generated by the subroutine DLATM6 and test the driver DGGEVX.
!> 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 DLATM6).
!>
!> 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 DGGEVX
!>     differs less than a factor THRESH from the exact S(i) (see
!>     DLATM6).
!>
!> (4) DIF(i) computed by DTGSNA 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.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NIN
!>          NIN is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDA, NSIZE)
!>          Copy of A, modified by DGGEVX.
!>
[out]BI
!>          BI is DOUBLE PRECISION array, dimension (LDA, NSIZE)
!>          Copy of B, modified by DGGEVX.
!>
[out]ALPHAR
!>          ALPHAR is DOUBLE PRECISION array, dimension (NSIZE)
!>
[out]ALPHAI
!>          ALPHAI is DOUBLE PRECISION array, dimension (NSIZE)
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (NSIZE)
!>
!>          On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
!>
[out]VL
!>          VL is DOUBLE PRECISION array, dimension (LDA, NSIZE)
!>          VL holds the left eigenvectors computed by DGGEVX.
!>
[out]VR
!>          VR is DOUBLE PRECISION array, dimension (LDA, NSIZE)
!>          VR holds the right eigenvectors computed by DGGEVX.
!>
[out]ILO
!>          ILO is INTEGER
!>
[out]IHI
!>          IHI is INTEGER
!>
[out]LSCALE
!>          LSCALE is DOUBLE PRECISION array, dimension (N)
!>
[out]RSCALE
!>          RSCALE is DOUBLE PRECISION array, dimension (N)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (N)
!>
[out]DTRU
!>          DTRU is DOUBLE PRECISION array, dimension (N)
!>
[out]DIF
!>          DIF is DOUBLE PRECISION array, dimension (N)
!>
[out]DIFTRU
!>          DIFTRU is DOUBLE PRECISION array, dimension (N)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          Leading dimension of WORK.  LWORK >= 2*N*N+12*N+16.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (LIWORK)
!>
[in]LIWORK
!>          LIWORK is INTEGER
!>          Leading dimension of IWORK.  Must be at least N+6.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>
[out]BWORK
!>          BWORK is LOGICAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  A routine returned an error code.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 296 of file ddrgvx.f.

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

◆ ddrvbd()

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

DDRVBD

Purpose:
!>
!> DDRVBD checks the singular value decomposition (SVD) drivers
!> DGESVD, DGESDD, DGESVDQ, DGESVJ, DGEJSV, and DGESVDX.
!>
!> Both DGESVD and DGESDD factor A = U diag(S) VT, where U and VT are
!> orthogonal 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 DDRVBD 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 DGESVD:
!>
!> (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 DGESDD:
!>
!> (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 DGESVDQ:
!>
!> (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 DGESVJ:
!>
!> (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 DGEJSV:
!>
!> (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 DGESVDX( 'V', 'V', 'A' )/DGESVDX( '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 DGESVDX( '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 DGESVDX( '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 orthogonal 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 matrix sizes (M,N) contained in the vectors
!>          MM and NN.
!>
[in]MM
!>          MM is INTEGER array, dimension (NSIZES)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER array, dimension (NSIZES)
!>          The values of the matrix column dimension N.
!>
[in]NTYPES
!>          NTYPES is INTEGER
!>          The number of elements in DOTYPE.   If it is zero, DDRVBD
!>          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, 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.
!>          On exit, ISEED is changed and can be used in the next call to
!>          DDRVBD to continue the same random number sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  The test
!>          ratios are scaled to be O(1), so THRESH should be a small
!>          multiple of 1, e.g., 10 or 100.  To have every test ratio
!>          printed, use THRESH = 0.
!>
[out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,NMAX)
!>          where NMAX is the maximum value of N in NN.
!>
[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 MM.
!>
[out]U
!>          U is DOUBLE PRECISION array, dimension (LDU,MMAX)
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,MMAX).
!>
[out]VT
!>          VT is DOUBLE PRECISION array, dimension (LDVT,NMAX)
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.  LDVT >= max(1,NMAX).
!>
[out]ASAV
!>          ASAV is DOUBLE PRECISION array, dimension (LDA,NMAX)
!>
[out]USAV
!>          USAV is DOUBLE PRECISION array, dimension (LDU,MMAX)
!>
[out]VTSAV
!>          VTSAV is DOUBLE PRECISION array, dimension (LDVT,NMAX)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension
!>                      (max(min(MM,NN)))
!>
[out]SSAV
!>          SSAV is DOUBLE PRECISION array, dimension
!>                      (max(min(MM,NN)))
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension
!>                      (max(min(MM,NN)))
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          max(3*MN+MX,5*MN-4)+2*MN**2 for all pairs
!>          pairs  (MN,MX)=( min(MM(j),NN(j), max(MM(j),NN(j)) )
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension at least 8*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
!>           -7: THRESH < 0
!>          -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
!>          -12: LDU < 1 or LDU < MMAX.
!>          -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ).
!>          -21: LWORK too small.
!>          If  DLATMS, or DGESVD 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 363 of file ddrvbd.f.

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

◆ ddrves()

subroutine ddrves ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( lda, * ) h,
double precision, dimension( lda, * ) ht,
double precision, dimension( * ) wr,
double precision, dimension( * ) wi,
double precision, dimension( * ) wrt,
double precision, dimension( * ) wit,
double precision, dimension( ldvs, * ) vs,
integer ldvs,
double precision, dimension( 13 ) result,
double precision, dimension( * ) work,
integer nwork,
integer, dimension( * ) iwork,
logical, dimension( * ) bwork,
integer info )

DDRVES

Purpose:
!>
!>    DDRVES checks the nonsymmetric eigenvalue (Schur form) problem
!>    driver DGEES.
!>
!>    When DDRVES 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 WR+sqrt(-1)*WI 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 WR+sqrt(-1)*WI 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 signs.
!>         (ULP = (first number larger than 1) - 1 )
!>    (5)  A diagonal matrix with geometrically spaced entries
!>         1, ..., ULP  and random signs.
!>    (6)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>         and random signs.
!>
!>    (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 orthogonal and
!>         T has evenly spaced entries 1, ..., ULP with random signs
!>         on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (10) A matrix of the form  U' T U, where U is orthogonal and
!>         T has geometrically spaced entries 1, ..., ULP with random
!>         signs 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
!>         signs on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (12) A matrix of the form  U' T U, where U is orthogonal and
!>         T has real or complex conjugate paired eigenvalues randomly
!>         chosen from ( ULP, 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 signs 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 signs 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 signs 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 real or complex conjugate paired
!>         eigenvalues randomly chosen from ( ULP, 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,
!>          DDRVES 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, DDRVES
!>          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 DDRVES to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by DGEES.
!>
[out]HT
!>          HT is DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          Yet another copy of the test matrix A, modified by DGEES.
!>
[out]WR
!>          WR is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]WI
!>          WI is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          The real and imaginary parts of the eigenvalues of A.
!>          On exit, WR + WI*i are the eigenvalues of the matrix in A.
!>
[out]WRT
!>          WRT is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]WIT
!>          WIT is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when DGEES only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]VS
!>          VS is DOUBLE PRECISION array, dimension (LDVS, max(NN))
!>          VS holds the computed Schur vectors.
!>
[in]LDVS
!>          LDVS is INTEGER
!>          Leading dimension of VS. Must be at least max(1,max(NN)).
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (13)
!>          The values computed by the 13 tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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]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) ).
!>          -17: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ).
!>          -20: NWORK too small.
!>          If  DLATMR, SLATMS, SLATME or DGEES 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 385 of file ddrves.f.

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

◆ ddrvev()

subroutine ddrvev ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer nounit,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( lda, * ) h,
double precision, dimension( * ) wr,
double precision, dimension( * ) wi,
double precision, dimension( * ) wr1,
double precision, dimension( * ) wi1,
double precision, dimension( ldvl, * ) vl,
integer ldvl,
double precision, dimension( ldvr, * ) vr,
integer ldvr,
double precision, dimension( ldlre, * ) lre,
integer ldlre,
double precision, dimension( 7 ) result,
double precision, dimension( * ) work,
integer nwork,
integer, dimension( * ) iwork,
integer info )

DDRVEV

Purpose:
!>
!>    DDRVEV  checks the nonsymmetric eigenvalue problem driver DGEEV.
!>
!>    When DDRVEV 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 block diagonal matrix, with a 1x1 block for each
!>      real eigenvalue and a 2x2 block for each complex conjugate
!>      pair.  If eigenvalues j and j+1 are a complex conjugate pair,
!>      so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
!>      2 x 2 block corresponding to the pair will be:
!>
!>              (  wr  wi  )
!>              ( -wi  wr  )
!>
!>      Such a block multiplying an n x 2 matrix  ( ur ui ) on the
!>      right will be the same as multiplying  ur + i*ui  by  wr + i*wi.
!>
!>    (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 signs.
!>         (ULP = (first number larger than 1) - 1 )
!>    (5)  A diagonal matrix with geometrically spaced entries
!>         1, ..., ULP  and random signs.
!>    (6)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>         and random signs.
!>
!>    (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 orthogonal and
!>         T has evenly spaced entries 1, ..., ULP with random signs
!>         on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (10) A matrix of the form  U' T U, where U is orthogonal and
!>         T has geometrically spaced entries 1, ..., ULP with random
!>         signs 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
!>         signs on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (12) A matrix of the form  U' T U, where U is orthogonal and
!>         T has real or complex conjugate paired eigenvalues randomly
!>         chosen from ( ULP, 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 signs 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 signs 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 signs 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 real or complex conjugate paired
!>         eigenvalues randomly chosen from ( ULP, 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,
!>          DDRVEV 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, DDRVEV
!>          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 DDRVEV to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by DGEEV.
!>
[out]WR
!>          WR is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]WI
!>          WI is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          The real and imaginary parts of the eigenvalues of A.
!>          On exit, WR + WI*i are the eigenvalues of the matrix in A.
!>
[out]WR1
!>          WR1 is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]WI1
!>          WI1 is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when DGEEV only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDLRE,max(NN))
!>          LRE holds the computed right or left eigenvectors.
!>
[in]LDLRE
!>          LDLRE is INTEGER
!>          Leading dimension of LRE. Must be at least max(1,max(NN)).
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (7)
!>          The values computed by the seven tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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]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) ).
!>          -16: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ).
!>          -18: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ).
!>          -20: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ).
!>          -23: NWORK too small.
!>          If  DLATMR, SLATMS, SLATME or DGEEV 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 402 of file ddrvev.f.

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

◆ ddrvsg()

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

DDRVSG

Purpose:
!>
!>      DDRVSG checks the real symmetric generalized eigenproblem
!>      drivers.
!>
!>              DSYGV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem.
!>
!>              DSYGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem using a divide and conquer algorithm.
!>
!>              DSYGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem.
!>
!>              DSPGV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem in packed storage.
!>
!>              DSPGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem in packed storage using a divide and
!>              conquer algorithm.
!>
!>              DSPGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem in packed storage.
!>
!>              DSBGV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite banded
!>              generalized eigenproblem.
!>
!>              DSBGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite banded
!>              generalized eigenproblem using a divide and conquer
!>              algorithm.
!>
!>              DSBGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite banded
!>              generalized eigenproblem.
!>
!>      When DDRVSG 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) DSYGV with ITYPE = 1 and UPLO ='U':
!>
!>              | A Z - B Z D | / ( |A| |Z| n ulp )
!>
!>      (2) as (1) but calling DSPGV
!>      (3) as (1) but calling DSBGV
!>      (4) as (1) but with UPLO = 'L'
!>      (5) as (4) but calling DSPGV
!>      (6) as (4) but calling DSBGV
!>
!>      (7) DSYGV with ITYPE = 2 and UPLO ='U':
!>
!>              | A B Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (8) as (7) but calling DSPGV
!>      (9) as (7) but with UPLO = 'L'
!>      (10) as (9) but calling DSPGV
!>
!>      (11) DSYGV with ITYPE = 3 and UPLO ='U':
!>
!>              | B A Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (12) as (11) but calling DSPGV
!>      (13) as (11) but with UPLO = 'L'
!>      (14) as (13) but calling DSPGV
!>
!>      DSYGVD, DSPGVD and DSBGVD performed the same 14 tests.
!>
!>      DSYGVX, DSPGVX and DSBGVX 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 orthogonal 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 orthogonal 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 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) 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) 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,
!>          DDRVSG 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, DDRVSG
!>          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 DDRVSG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       DOUBLE PRECISION 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 and AB.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  B       DOUBLE PRECISION array, dimension (LDB , max(NN))
!>          Used to hold the symmetric positive definite matrix for
!>          the generailzed problem.
!>          On exit, B contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDB     INTEGER
!>          The leading dimension of B and BB.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  D       DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A. On exit, the eigenvalues in D
!>          correspond with the matrix in A.
!>          Modified.
!>
!>  Z       DOUBLE PRECISION array, dimension (LDZ, max(NN))
!>          The matrix of eigenvectors.
!>          Modified.
!>
!>  LDZ     INTEGER
!>          The leading dimension of Z.  It must be at least 1 and
!>          at least max( NN ).
!>          Not modified.
!>
!>  AB      DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  BB      DOUBLE PRECISION array, dimension (LDB, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  AP      DOUBLE PRECISION array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  BP      DOUBLE PRECISION array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  WORK    DOUBLE PRECISION array, dimension (NWORK)
!>          Workspace.
!>          Modified.
!>
!>  NWORK   INTEGER
!>          The number of entries in WORK.  This must be at least
!>          1+5*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 WORK.  This must be at least 6*N.
!>          Not modified.
!>
!>  RESULT  DOUBLE PRECISION array, dimension (70)
!>          The values computed by the 70 tests described above.
!>          Modified.
!>
!>  INFO    INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -16: LDZ < 1 or LDZ < NMAX.
!>          -21: NWORK too small.
!>          -23: LIWORK too small.
!>          If  DLATMR, SLATMS, DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD,
!>              DSBGVD, DSYGVX, DSPGVX or SSBGVX returns an error code,
!>              the absolute value of it is returned.
!>          Modified.
!>
!> ----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests that have been run
!>                       on this matrix.
!>       NTESTT          The total number of tests for this call.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far (computed by DLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 352 of file ddrvsg.f.

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

◆ ddrvsg2stg()

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

DDRVSG2STG

Purpose:
!>
!>      DDRVSG2STG checks the real symmetric generalized eigenproblem
!>      drivers.
!>
!>              DSYGV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem.
!>
!>              DSYGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem using a divide and conquer algorithm.
!>
!>              DSYGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem.
!>
!>              DSPGV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem in packed storage.
!>
!>              DSPGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem in packed storage using a divide and
!>              conquer algorithm.
!>
!>              DSPGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem in packed storage.
!>
!>              DSBGV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite banded
!>              generalized eigenproblem.
!>
!>              DSBGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite banded
!>              generalized eigenproblem using a divide and conquer
!>              algorithm.
!>
!>              DSBGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite banded
!>              generalized eigenproblem.
!>
!>      When DDRVSG2STG 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) DSYGV with ITYPE = 1 and UPLO ='U':
!>
!>              | A Z - B Z D | / ( |A| |Z| n ulp )
!>              | D - D2 | / ( |D| ulp )   where D is computed by
!>                                         DSYGV and  D2 is computed by
!>                                         DSYGV_2STAGE. This test is
!>                                         only performed for DSYGV
!>
!>      (2) as (1) but calling DSPGV
!>      (3) as (1) but calling DSBGV
!>      (4) as (1) but with UPLO = 'L'
!>      (5) as (4) but calling DSPGV
!>      (6) as (4) but calling DSBGV
!>
!>      (7) DSYGV with ITYPE = 2 and UPLO ='U':
!>
!>              | A B Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (8) as (7) but calling DSPGV
!>      (9) as (7) but with UPLO = 'L'
!>      (10) as (9) but calling DSPGV
!>
!>      (11) DSYGV with ITYPE = 3 and UPLO ='U':
!>
!>              | B A Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (12) as (11) but calling DSPGV
!>      (13) as (11) but with UPLO = 'L'
!>      (14) as (13) but calling DSPGV
!>
!>      DSYGVD, DSPGVD and DSBGVD performed the same 14 tests.
!>
!>      DSYGVX, DSPGVX and DSBGVX 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 orthogonal 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 orthogonal 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 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) 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) 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,
!>          DDRVSG2STG 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, DDRVSG2STG
!>          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 DDRVSG2STG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       DOUBLE PRECISION 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 and AB.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  B       DOUBLE PRECISION array, dimension (LDB , max(NN))
!>          Used to hold the symmetric positive definite matrix for
!>          the generailzed problem.
!>          On exit, B contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDB     INTEGER
!>          The leading dimension of B and BB.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  D       DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A. On exit, the eigenvalues in D
!>          correspond with the matrix in A.
!>          Modified.
!>
!>  Z       DOUBLE PRECISION array, dimension (LDZ, max(NN))
!>          The matrix of eigenvectors.
!>          Modified.
!>
!>  LDZ     INTEGER
!>          The leading dimension of Z.  It must be at least 1 and
!>          at least max( NN ).
!>          Not modified.
!>
!>  AB      DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  BB      DOUBLE PRECISION array, dimension (LDB, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  AP      DOUBLE PRECISION array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  BP      DOUBLE PRECISION array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  WORK    DOUBLE PRECISION array, dimension (NWORK)
!>          Workspace.
!>          Modified.
!>
!>  NWORK   INTEGER
!>          The number of entries in WORK.  This must be at least
!>          1+5*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 WORK.  This must be at least 6*N.
!>          Not modified.
!>
!>  RESULT  DOUBLE PRECISION array, dimension (70)
!>          The values computed by the 70 tests described above.
!>          Modified.
!>
!>  INFO    INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -16: LDZ < 1 or LDZ < NMAX.
!>          -21: NWORK too small.
!>          -23: LIWORK too small.
!>          If  DLATMR, SLATMS, DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD,
!>              DSBGVD, DSYGVX, DSPGVX or SSBGVX returns an error code,
!>              the absolute value of it is returned.
!>          Modified.
!>
!> ----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests that have been run
!>                       on this matrix.
!>       NTESTT          The total number of tests for this call.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far (computed by DLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 358 of file ddrvsg2stg.f.

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

◆ ddrvst()

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

DDRVST

Purpose:
!>
!>      DDRVST  checks the symmetric eigenvalue problem drivers.
!>
!>              DSTEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix.
!>
!>              DSTEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix.
!>
!>              DSTEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              DSYEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix.
!>
!>              DSYEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix.
!>
!>              DSYEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              DSPEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage.
!>
!>              DSPEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage.
!>
!>              DSBEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix.
!>
!>              DSBEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix.
!>
!>              DSYEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix using
!>              a divide and conquer algorithm.
!>
!>              DSPEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage, using a divide and conquer algorithm.
!>
!>              DSBEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix,
!>              using a divide and conquer algorithm.
!>
!>      When DDRVST 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 eigenvalues
!>           1, ..., ULP  and random signs.
!>           (ULP = (first number larger than 1) - 1 )
!>      (4)  A diagonal matrix with geometrically spaced eigenvalues
!>           1, ..., ULP  and random signs.
!>      (5)  A diagonal matrix with  eigenvalues
!>           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 orthogonal 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 orthogonal 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 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) 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,
!>          DDRVST 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, DDRVST
!>          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 DDRVST to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       DOUBLE PRECISION array, dimension (LDA , max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  D1      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by DSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>          Modified.
!>
!>  D2      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by DSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>          Modified.
!>
!>  D3      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by DSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>          Modified.
!>
!>  D4      DOUBLE PRECISION array, dimension
!>
!>  EVEIGS  DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues as computed by DSTEV('N', ... )
!>          (I reserve the right to change this to the output of
!>          whichever algorithm computes the most accurate eigenvalues).
!>
!>  WA1     DOUBLE PRECISION array, dimension
!>
!>  WA2     DOUBLE PRECISION array, dimension
!>
!>  WA3     DOUBLE PRECISION array, dimension
!>
!>  U       DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The orthogonal matrix computed by DSYTRD + DORGTR.
!>          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       DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The Housholder vectors computed by DSYTRD in reducing A to
!>          tridiagonal form.
!>          Modified.
!>
!>  TAU     DOUBLE PRECISION array, dimension (max(NN))
!>          The Householder factors computed by DSYTRD in reducing A
!>          to tridiagonal form.
!>          Modified.
!>
!>  Z       DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The orthogonal matrix of eigenvectors computed by DSTEQR,
!>          DPTEQR, and DSTEIN.
!>          Modified.
!>
!>  WORK    DOUBLE PRECISION array, dimension (LWORK)
!>          Workspace.
!>          Modified.
!>
!>  LWORK   INTEGER
!>          The number of entries in WORK.  This must be at least
!>          1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2
!>          where Nmax = max( NN(j), 2 ) and lg = log base 2.
!>          Not modified.
!>
!>  IWORK   INTEGER array,
!>             dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax )
!>          where Nmax = max( NN(j), 2 ) and lg = log base 2.
!>          Workspace.
!>          Modified.
!>
!>  RESULT  DOUBLE PRECISION array, dimension (105)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>          Modified.
!>
!>  INFO    INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -16: LDU < 1 or LDU < NMAX.
!>          -21: LWORK too small.
!>          If  DLATMR, DLATMS, DSYTRD, DORGTR, DSTEQR, DSTERF,
!>              or DORMTR returns an error code, the
!>              absolute value of it is returned.
!>          Modified.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far (computed by DLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
!>     The tests performed are:                 Routine tested
!>    1= | A - U S U' | / ( |A| n ulp )         DSTEV('V', ... )
!>    2= | I - U U' | / ( n ulp )               DSTEV('V', ... )
!>    3= |D(with Z) - D(w/o Z)| / (|D| ulp)     DSTEV('N', ... )
!>    4= | A - U S U' | / ( |A| n ulp )         DSTEVX('V','A', ... )
!>    5= | I - U U' | / ( n ulp )               DSTEVX('V','A', ... )
!>    6= |D(with Z) - EVEIGS| / (|D| ulp)       DSTEVX('N','A', ... )
!>    7= | A - U S U' | / ( |A| n ulp )         DSTEVR('V','A', ... )
!>    8= | I - U U' | / ( n ulp )               DSTEVR('V','A', ... )
!>    9= |D(with Z) - EVEIGS| / (|D| ulp)       DSTEVR('N','A', ... )
!>    10= | A - U S U' | / ( |A| n ulp )        DSTEVX('V','I', ... )
!>    11= | I - U U' | / ( n ulp )              DSTEVX('V','I', ... )
!>    12= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSTEVX('N','I', ... )
!>    13= | A - U S U' | / ( |A| n ulp )        DSTEVX('V','V', ... )
!>    14= | I - U U' | / ( n ulp )              DSTEVX('V','V', ... )
!>    15= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSTEVX('N','V', ... )
!>    16= | A - U S U' | / ( |A| n ulp )        DSTEVD('V', ... )
!>    17= | I - U U' | / ( n ulp )              DSTEVD('V', ... )
!>    18= |D(with Z) - EVEIGS| / (|D| ulp)      DSTEVD('N', ... )
!>    19= | A - U S U' | / ( |A| n ulp )        DSTEVR('V','I', ... )
!>    20= | I - U U' | / ( n ulp )              DSTEVR('V','I', ... )
!>    21= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSTEVR('N','I', ... )
!>    22= | A - U S U' | / ( |A| n ulp )        DSTEVR('V','V', ... )
!>    23= | I - U U' | / ( n ulp )              DSTEVR('V','V', ... )
!>    24= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSTEVR('N','V', ... )
!>
!>    25= | A - U S U' | / ( |A| n ulp )        DSYEV('L','V', ... )
!>    26= | I - U U' | / ( n ulp )              DSYEV('L','V', ... )
!>    27= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEV('L','N', ... )
!>    28= | A - U S U' | / ( |A| n ulp )        DSYEVX('L','V','A', ... )
!>    29= | I - U U' | / ( n ulp )              DSYEVX('L','V','A', ... )
!>    30= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVX('L','N','A', ... )
!>    31= | A - U S U' | / ( |A| n ulp )        DSYEVX('L','V','I', ... )
!>    32= | I - U U' | / ( n ulp )              DSYEVX('L','V','I', ... )
!>    33= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVX('L','N','I', ... )
!>    34= | A - U S U' | / ( |A| n ulp )        DSYEVX('L','V','V', ... )
!>    35= | I - U U' | / ( n ulp )              DSYEVX('L','V','V', ... )
!>    36= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVX('L','N','V', ... )
!>    37= | A - U S U' | / ( |A| n ulp )        DSPEV('L','V', ... )
!>    38= | I - U U' | / ( n ulp )              DSPEV('L','V', ... )
!>    39= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEV('L','N', ... )
!>    40= | A - U S U' | / ( |A| n ulp )        DSPEVX('L','V','A', ... )
!>    41= | I - U U' | / ( n ulp )              DSPEVX('L','V','A', ... )
!>    42= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVX('L','N','A', ... )
!>    43= | A - U S U' | / ( |A| n ulp )        DSPEVX('L','V','I', ... )
!>    44= | I - U U' | / ( n ulp )              DSPEVX('L','V','I', ... )
!>    45= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVX('L','N','I', ... )
!>    46= | A - U S U' | / ( |A| n ulp )        DSPEVX('L','V','V', ... )
!>    47= | I - U U' | / ( n ulp )              DSPEVX('L','V','V', ... )
!>    48= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVX('L','N','V', ... )
!>    49= | A - U S U' | / ( |A| n ulp )        DSBEV('L','V', ... )
!>    50= | I - U U' | / ( n ulp )              DSBEV('L','V', ... )
!>    51= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEV('L','N', ... )
!>    52= | A - U S U' | / ( |A| n ulp )        DSBEVX('L','V','A', ... )
!>    53= | I - U U' | / ( n ulp )              DSBEVX('L','V','A', ... )
!>    54= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVX('L','N','A', ... )
!>    55= | A - U S U' | / ( |A| n ulp )        DSBEVX('L','V','I', ... )
!>    56= | I - U U' | / ( n ulp )              DSBEVX('L','V','I', ... )
!>    57= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVX('L','N','I', ... )
!>    58= | A - U S U' | / ( |A| n ulp )        DSBEVX('L','V','V', ... )
!>    59= | I - U U' | / ( n ulp )              DSBEVX('L','V','V', ... )
!>    60= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVX('L','N','V', ... )
!>    61= | A - U S U' | / ( |A| n ulp )        DSYEVD('L','V', ... )
!>    62= | I - U U' | / ( n ulp )              DSYEVD('L','V', ... )
!>    63= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVD('L','N', ... )
!>    64= | A - U S U' | / ( |A| n ulp )        DSPEVD('L','V', ... )
!>    65= | I - U U' | / ( n ulp )              DSPEVD('L','V', ... )
!>    66= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVD('L','N', ... )
!>    67= | A - U S U' | / ( |A| n ulp )        DSBEVD('L','V', ... )
!>    68= | I - U U' | / ( n ulp )              DSBEVD('L','V', ... )
!>    69= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVD('L','N', ... )
!>    70= | A - U S U' | / ( |A| n ulp )        DSYEVR('L','V','A', ... )
!>    71= | I - U U' | / ( n ulp )              DSYEVR('L','V','A', ... )
!>    72= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVR('L','N','A', ... )
!>    73= | A - U S U' | / ( |A| n ulp )        DSYEVR('L','V','I', ... )
!>    74= | I - U U' | / ( n ulp )              DSYEVR('L','V','I', ... )
!>    75= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVR('L','N','I', ... )
!>    76= | A - U S U' | / ( |A| n ulp )        DSYEVR('L','V','V', ... )
!>    77= | I - U U' | / ( n ulp )              DSYEVR('L','V','V', ... )
!>    78= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVR('L','N','V', ... )
!>
!>    Tests 25 through 78 are repeated (as tests 79 through 132)
!>    with UPLO='U'
!>
!>    To be added in 1999
!>
!>    79= | A - U S U' | / ( |A| n ulp )        DSPEVR('L','V','A', ... )
!>    80= | I - U U' | / ( n ulp )              DSPEVR('L','V','A', ... )
!>    81= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVR('L','N','A', ... )
!>    82= | A - U S U' | / ( |A| n ulp )        DSPEVR('L','V','I', ... )
!>    83= | I - U U' | / ( n ulp )              DSPEVR('L','V','I', ... )
!>    84= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVR('L','N','I', ... )
!>    85= | A - U S U' | / ( |A| n ulp )        DSPEVR('L','V','V', ... )
!>    86= | I - U U' | / ( n ulp )              DSPEVR('L','V','V', ... )
!>    87= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVR('L','N','V', ... )
!>    88= | A - U S U' | / ( |A| n ulp )        DSBEVR('L','V','A', ... )
!>    89= | I - U U' | / ( n ulp )              DSBEVR('L','V','A', ... )
!>    90= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVR('L','N','A', ... )
!>    91= | A - U S U' | / ( |A| n ulp )        DSBEVR('L','V','I', ... )
!>    92= | I - U U' | / ( n ulp )              DSBEVR('L','V','I', ... )
!>    93= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVR('L','N','I', ... )
!>    94= | A - U S U' | / ( |A| n ulp )        DSBEVR('L','V','V', ... )
!>    95= | I - U U' | / ( n ulp )              DSBEVR('L','V','V', ... )
!>    96= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVR('L','N','V', ... )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 449 of file ddrvst.f.

453*
454* -- LAPACK test routine --
455* -- LAPACK is a software package provided by Univ. of Tennessee, --
456* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
457*
458* .. Scalar Arguments ..
459 INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
460 $ NTYPES
461 DOUBLE PRECISION THRESH
462* ..
463* .. Array Arguments ..
464 LOGICAL DOTYPE( * )
465 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
466 DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ),
467 $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ),
468 $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ),
469 $ WA3( * ), WORK( * ), Z( LDU, * )
470* ..
471*
472* =====================================================================
473*
474* .. Parameters ..
475 DOUBLE PRECISION ZERO, ONE, TWO, TEN
476 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
477 $ ten = 10.0d0 )
478 DOUBLE PRECISION HALF
479 parameter( half = 0.5d0 )
480 INTEGER MAXTYP
481 parameter( maxtyp = 18 )
482* ..
483* .. Local Scalars ..
484 LOGICAL BADNN
485 CHARACTER UPLO
486 INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW,
487 $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL,
488 $ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2,
489 $ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
490 $ NTESTT
491 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
492 $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL,
493 $ VL, VU
494* ..
495* .. Local Arrays ..
496 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
497 $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
498 $ KTYPE( MAXTYP )
499* ..
500* .. External Functions ..
501 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
502 EXTERNAL dlamch, dlarnd, dsxt1
503* ..
504* .. External Subroutines ..
505 EXTERNAL alasvm, dlabad, dlacpy, dlafts, dlaset, dlatmr,
506 $ dlatms, dsbev, dsbevd, dsbevx, dspev, dspevd,
507 $ dspevx, dstev, dstevd, dstevr, dstevx, dstt21,
508 $ dstt22, dsyev, dsyevd, dsyevr, dsyevx, dsyt21,
509 $ dsyt22, xerbla
510* ..
511* .. Scalars in Common ..
512 CHARACTER*32 SRNAMT
513* ..
514* .. Common blocks ..
515 COMMON / srnamc / srnamt
516* ..
517* .. Intrinsic Functions ..
518 INTRINSIC abs, dble, int, log, max, min, sqrt
519* ..
520* .. Data statements ..
521 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 3*9 /
522 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
523 $ 2, 3, 1, 2, 3 /
524 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
525 $ 0, 0, 4, 4, 4 /
526* ..
527* .. Executable Statements ..
528*
529* Keep ftrnchek happy
530*
531 vl = zero
532 vu = zero
533*
534* 1) Check for errors
535*
536 ntestt = 0
537 info = 0
538*
539 badnn = .false.
540 nmax = 1
541 DO 10 j = 1, nsizes
542 nmax = max( nmax, nn( j ) )
543 IF( nn( j ).LT.0 )
544 $ badnn = .true.
545 10 CONTINUE
546*
547* Check for errors
548*
549 IF( nsizes.LT.0 ) THEN
550 info = -1
551 ELSE IF( badnn ) THEN
552 info = -2
553 ELSE IF( ntypes.LT.0 ) THEN
554 info = -3
555 ELSE IF( lda.LT.nmax ) THEN
556 info = -9
557 ELSE IF( ldu.LT.nmax ) THEN
558 info = -16
559 ELSE IF( 2*max( 2, nmax )**2.GT.lwork ) THEN
560 info = -21
561 END IF
562*
563 IF( info.NE.0 ) THEN
564 CALL xerbla( 'DDRVST', -info )
565 RETURN
566 END IF
567*
568* Quick return if nothing to do
569*
570 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
571 $ RETURN
572*
573* More Important constants
574*
575 unfl = dlamch( 'Safe minimum' )
576 ovfl = dlamch( 'Overflow' )
577 CALL dlabad( unfl, ovfl )
578 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
579 ulpinv = one / ulp
580 rtunfl = sqrt( unfl )
581 rtovfl = sqrt( ovfl )
582*
583* Loop over sizes, types
584*
585 DO 20 i = 1, 4
586 iseed2( i ) = iseed( i )
587 iseed3( i ) = iseed( i )
588 20 CONTINUE
589*
590 nerrs = 0
591 nmats = 0
592*
593*
594 DO 1740 jsize = 1, nsizes
595 n = nn( jsize )
596 IF( n.GT.0 ) THEN
597 lgn = int( log( dble( n ) ) / log( two ) )
598 IF( 2**lgn.LT.n )
599 $ lgn = lgn + 1
600 IF( 2**lgn.LT.n )
601 $ lgn = lgn + 1
602 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
603c LIWEDC = 6 + 6*N + 5*N*LGN
604 liwedc = 3 + 5*n
605 ELSE
606 lwedc = 9
607c LIWEDC = 12
608 liwedc = 8
609 END IF
610 aninv = one / dble( max( 1, n ) )
611*
612 IF( nsizes.NE.1 ) THEN
613 mtypes = min( maxtyp, ntypes )
614 ELSE
615 mtypes = min( maxtyp+1, ntypes )
616 END IF
617*
618 DO 1730 jtype = 1, mtypes
619*
620 IF( .NOT.dotype( jtype ) )
621 $ GO TO 1730
622 nmats = nmats + 1
623 ntest = 0
624*
625 DO 30 j = 1, 4
626 ioldsd( j ) = iseed( j )
627 30 CONTINUE
628*
629* 2) Compute "A"
630*
631* Control parameters:
632*
633* KMAGN KMODE KTYPE
634* =1 O(1) clustered 1 zero
635* =2 large clustered 2 identity
636* =3 small exponential (none)
637* =4 arithmetic diagonal, (w/ eigenvalues)
638* =5 random log symmetric, w/ eigenvalues
639* =6 random (none)
640* =7 random diagonal
641* =8 random symmetric
642* =9 band symmetric, w/ eigenvalues
643*
644 IF( mtypes.GT.maxtyp )
645 $ GO TO 110
646*
647 itype = ktype( jtype )
648 imode = kmode( jtype )
649*
650* Compute norm
651*
652 GO TO ( 40, 50, 60 )kmagn( jtype )
653*
654 40 CONTINUE
655 anorm = one
656 GO TO 70
657*
658 50 CONTINUE
659 anorm = ( rtovfl*ulp )*aninv
660 GO TO 70
661*
662 60 CONTINUE
663 anorm = rtunfl*n*ulpinv
664 GO TO 70
665*
666 70 CONTINUE
667*
668 CALL dlaset( 'Full', lda, n, zero, zero, a, lda )
669 iinfo = 0
670 cond = ulpinv
671*
672* Special Matrices -- Identity & Jordan block
673*
674* Zero
675*
676 IF( itype.EQ.1 ) THEN
677 iinfo = 0
678*
679 ELSE IF( itype.EQ.2 ) THEN
680*
681* Identity
682*
683 DO 80 jcol = 1, n
684 a( jcol, jcol ) = anorm
685 80 CONTINUE
686*
687 ELSE IF( itype.EQ.4 ) THEN
688*
689* Diagonal Matrix, [Eigen]values Specified
690*
691 CALL dlatms( n, n, 'S', iseed, 'S', work, imode, cond,
692 $ anorm, 0, 0, 'N', a, lda, work( n+1 ),
693 $ iinfo )
694*
695 ELSE IF( itype.EQ.5 ) THEN
696*
697* Symmetric, eigenvalues specified
698*
699 CALL dlatms( n, n, 'S', iseed, 'S', work, imode, cond,
700 $ anorm, n, n, 'N', a, lda, work( n+1 ),
701 $ iinfo )
702*
703 ELSE IF( itype.EQ.7 ) THEN
704*
705* Diagonal, random eigenvalues
706*
707 idumma( 1 ) = 1
708 CALL dlatmr( n, n, 'S', iseed, 'S', work, 6, one, one,
709 $ 'T', 'N', work( n+1 ), 1, one,
710 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
711 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
712*
713 ELSE IF( itype.EQ.8 ) THEN
714*
715* Symmetric, random eigenvalues
716*
717 idumma( 1 ) = 1
718 CALL dlatmr( n, n, 'S', iseed, 'S', work, 6, one, one,
719 $ 'T', 'N', work( n+1 ), 1, one,
720 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
721 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
722*
723 ELSE IF( itype.EQ.9 ) THEN
724*
725* Symmetric banded, eigenvalues specified
726*
727 ihbw = int( ( n-1 )*dlarnd( 1, iseed3 ) )
728 CALL dlatms( n, n, 'S', iseed, 'S', work, imode, cond,
729 $ anorm, ihbw, ihbw, 'Z', u, ldu, work( n+1 ),
730 $ iinfo )
731*
732* Store as dense matrix for most routines.
733*
734 CALL dlaset( 'Full', lda, n, zero, zero, a, lda )
735 DO 100 idiag = -ihbw, ihbw
736 irow = ihbw - idiag + 1
737 j1 = max( 1, idiag+1 )
738 j2 = min( n, n+idiag )
739 DO 90 j = j1, j2
740 i = j - idiag
741 a( i, j ) = u( irow, j )
742 90 CONTINUE
743 100 CONTINUE
744 ELSE
745 iinfo = 1
746 END IF
747*
748 IF( iinfo.NE.0 ) THEN
749 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
750 $ ioldsd
751 info = abs( iinfo )
752 RETURN
753 END IF
754*
755 110 CONTINUE
756*
757 abstol = unfl + unfl
758 IF( n.LE.1 ) THEN
759 il = 1
760 iu = n
761 ELSE
762 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
763 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
764 IF( il.GT.iu ) THEN
765 itemp = il
766 il = iu
767 iu = itemp
768 END IF
769 END IF
770*
771* 3) If matrix is tridiagonal, call DSTEV and DSTEVX.
772*
773 IF( jtype.LE.7 ) THEN
774 ntest = 1
775 DO 120 i = 1, n
776 d1( i ) = dble( a( i, i ) )
777 120 CONTINUE
778 DO 130 i = 1, n - 1
779 d2( i ) = dble( a( i+1, i ) )
780 130 CONTINUE
781 srnamt = 'DSTEV'
782 CALL dstev( 'V', n, d1, d2, z, ldu, work, iinfo )
783 IF( iinfo.NE.0 ) THEN
784 WRITE( nounit, fmt = 9999 )'DSTEV(V)', iinfo, n,
785 $ jtype, ioldsd
786 info = abs( iinfo )
787 IF( iinfo.LT.0 ) THEN
788 RETURN
789 ELSE
790 result( 1 ) = ulpinv
791 result( 2 ) = ulpinv
792 result( 3 ) = ulpinv
793 GO TO 180
794 END IF
795 END IF
796*
797* Do tests 1 and 2.
798*
799 DO 140 i = 1, n
800 d3( i ) = dble( a( i, i ) )
801 140 CONTINUE
802 DO 150 i = 1, n - 1
803 d4( i ) = dble( a( i+1, i ) )
804 150 CONTINUE
805 CALL dstt21( n, 0, d3, d4, d1, d2, z, ldu, work,
806 $ result( 1 ) )
807*
808 ntest = 3
809 DO 160 i = 1, n - 1
810 d4( i ) = dble( a( i+1, i ) )
811 160 CONTINUE
812 srnamt = 'DSTEV'
813 CALL dstev( 'N', n, d3, d4, z, ldu, work, iinfo )
814 IF( iinfo.NE.0 ) THEN
815 WRITE( nounit, fmt = 9999 )'DSTEV(N)', iinfo, n,
816 $ jtype, ioldsd
817 info = abs( iinfo )
818 IF( iinfo.LT.0 ) THEN
819 RETURN
820 ELSE
821 result( 3 ) = ulpinv
822 GO TO 180
823 END IF
824 END IF
825*
826* Do test 3.
827*
828 temp1 = zero
829 temp2 = zero
830 DO 170 j = 1, n
831 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
832 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
833 170 CONTINUE
834 result( 3 ) = temp2 / max( unfl,
835 $ ulp*max( temp1, temp2 ) )
836*
837 180 CONTINUE
838*
839 ntest = 4
840 DO 190 i = 1, n
841 eveigs( i ) = d3( i )
842 d1( i ) = dble( a( i, i ) )
843 190 CONTINUE
844 DO 200 i = 1, n - 1
845 d2( i ) = dble( a( i+1, i ) )
846 200 CONTINUE
847 srnamt = 'DSTEVX'
848 CALL dstevx( 'V', 'A', n, d1, d2, vl, vu, il, iu, abstol,
849 $ m, wa1, z, ldu, work, iwork, iwork( 5*n+1 ),
850 $ iinfo )
851 IF( iinfo.NE.0 ) THEN
852 WRITE( nounit, fmt = 9999 )'DSTEVX(V,A)', iinfo, n,
853 $ jtype, ioldsd
854 info = abs( iinfo )
855 IF( iinfo.LT.0 ) THEN
856 RETURN
857 ELSE
858 result( 4 ) = ulpinv
859 result( 5 ) = ulpinv
860 result( 6 ) = ulpinv
861 GO TO 250
862 END IF
863 END IF
864 IF( n.GT.0 ) THEN
865 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
866 ELSE
867 temp3 = zero
868 END IF
869*
870* Do tests 4 and 5.
871*
872 DO 210 i = 1, n
873 d3( i ) = dble( a( i, i ) )
874 210 CONTINUE
875 DO 220 i = 1, n - 1
876 d4( i ) = dble( a( i+1, i ) )
877 220 CONTINUE
878 CALL dstt21( n, 0, d3, d4, wa1, d2, z, ldu, work,
879 $ result( 4 ) )
880*
881 ntest = 6
882 DO 230 i = 1, n - 1
883 d4( i ) = dble( a( i+1, i ) )
884 230 CONTINUE
885 srnamt = 'DSTEVX'
886 CALL dstevx( 'N', 'A', n, d3, d4, vl, vu, il, iu, abstol,
887 $ m2, wa2, z, ldu, work, iwork,
888 $ iwork( 5*n+1 ), iinfo )
889 IF( iinfo.NE.0 ) THEN
890 WRITE( nounit, fmt = 9999 )'DSTEVX(N,A)', iinfo, n,
891 $ jtype, ioldsd
892 info = abs( iinfo )
893 IF( iinfo.LT.0 ) THEN
894 RETURN
895 ELSE
896 result( 6 ) = ulpinv
897 GO TO 250
898 END IF
899 END IF
900*
901* Do test 6.
902*
903 temp1 = zero
904 temp2 = zero
905 DO 240 j = 1, n
906 temp1 = max( temp1, abs( wa2( j ) ),
907 $ abs( eveigs( j ) ) )
908 temp2 = max( temp2, abs( wa2( j )-eveigs( j ) ) )
909 240 CONTINUE
910 result( 6 ) = temp2 / max( unfl,
911 $ ulp*max( temp1, temp2 ) )
912*
913 250 CONTINUE
914*
915 ntest = 7
916 DO 260 i = 1, n
917 d1( i ) = dble( a( i, i ) )
918 260 CONTINUE
919 DO 270 i = 1, n - 1
920 d2( i ) = dble( a( i+1, i ) )
921 270 CONTINUE
922 srnamt = 'DSTEVR'
923 CALL dstevr( 'V', 'A', n, d1, d2, vl, vu, il, iu, abstol,
924 $ m, wa1, z, ldu, iwork, work, lwork,
925 $ iwork(2*n+1), liwork-2*n, iinfo )
926 IF( iinfo.NE.0 ) THEN
927 WRITE( nounit, fmt = 9999 )'DSTEVR(V,A)', iinfo, n,
928 $ jtype, ioldsd
929 info = abs( iinfo )
930 IF( iinfo.LT.0 ) THEN
931 RETURN
932 ELSE
933 result( 7 ) = ulpinv
934 result( 8 ) = ulpinv
935 GO TO 320
936 END IF
937 END IF
938 IF( n.GT.0 ) THEN
939 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
940 ELSE
941 temp3 = zero
942 END IF
943*
944* Do tests 7 and 8.
945*
946 DO 280 i = 1, n
947 d3( i ) = dble( a( i, i ) )
948 280 CONTINUE
949 DO 290 i = 1, n - 1
950 d4( i ) = dble( a( i+1, i ) )
951 290 CONTINUE
952 CALL dstt21( n, 0, d3, d4, wa1, d2, z, ldu, work,
953 $ result( 7 ) )
954*
955 ntest = 9
956 DO 300 i = 1, n - 1
957 d4( i ) = dble( a( i+1, i ) )
958 300 CONTINUE
959 srnamt = 'DSTEVR'
960 CALL dstevr( 'N', 'A', n, d3, d4, vl, vu, il, iu, abstol,
961 $ m2, wa2, z, ldu, iwork, work, lwork,
962 $ iwork(2*n+1), liwork-2*n, iinfo )
963 IF( iinfo.NE.0 ) THEN
964 WRITE( nounit, fmt = 9999 )'DSTEVR(N,A)', iinfo, n,
965 $ jtype, ioldsd
966 info = abs( iinfo )
967 IF( iinfo.LT.0 ) THEN
968 RETURN
969 ELSE
970 result( 9 ) = ulpinv
971 GO TO 320
972 END IF
973 END IF
974*
975* Do test 9.
976*
977 temp1 = zero
978 temp2 = zero
979 DO 310 j = 1, n
980 temp1 = max( temp1, abs( wa2( j ) ),
981 $ abs( eveigs( j ) ) )
982 temp2 = max( temp2, abs( wa2( j )-eveigs( j ) ) )
983 310 CONTINUE
984 result( 9 ) = temp2 / max( unfl,
985 $ ulp*max( temp1, temp2 ) )
986*
987 320 CONTINUE
988*
989*
990 ntest = 10
991 DO 330 i = 1, n
992 d1( i ) = dble( a( i, i ) )
993 330 CONTINUE
994 DO 340 i = 1, n - 1
995 d2( i ) = dble( a( i+1, i ) )
996 340 CONTINUE
997 srnamt = 'DSTEVX'
998 CALL dstevx( 'V', 'I', n, d1, d2, vl, vu, il, iu, abstol,
999 $ m2, wa2, z, ldu, work, iwork,
1000 $ iwork( 5*n+1 ), iinfo )
1001 IF( iinfo.NE.0 ) THEN
1002 WRITE( nounit, fmt = 9999 )'DSTEVX(V,I)', iinfo, n,
1003 $ jtype, ioldsd
1004 info = abs( iinfo )
1005 IF( iinfo.LT.0 ) THEN
1006 RETURN
1007 ELSE
1008 result( 10 ) = ulpinv
1009 result( 11 ) = ulpinv
1010 result( 12 ) = ulpinv
1011 GO TO 380
1012 END IF
1013 END IF
1014*
1015* Do tests 10 and 11.
1016*
1017 DO 350 i = 1, n
1018 d3( i ) = dble( a( i, i ) )
1019 350 CONTINUE
1020 DO 360 i = 1, n - 1
1021 d4( i ) = dble( a( i+1, i ) )
1022 360 CONTINUE
1023 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1024 $ max( 1, m2 ), result( 10 ) )
1025*
1026*
1027 ntest = 12
1028 DO 370 i = 1, n - 1
1029 d4( i ) = dble( a( i+1, i ) )
1030 370 CONTINUE
1031 srnamt = 'DSTEVX'
1032 CALL dstevx( 'N', 'I', n, d3, d4, vl, vu, il, iu, abstol,
1033 $ m3, wa3, z, ldu, work, iwork,
1034 $ iwork( 5*n+1 ), iinfo )
1035 IF( iinfo.NE.0 ) THEN
1036 WRITE( nounit, fmt = 9999 )'DSTEVX(N,I)', iinfo, n,
1037 $ jtype, ioldsd
1038 info = abs( iinfo )
1039 IF( iinfo.LT.0 ) THEN
1040 RETURN
1041 ELSE
1042 result( 12 ) = ulpinv
1043 GO TO 380
1044 END IF
1045 END IF
1046*
1047* Do test 12.
1048*
1049 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1050 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1051 result( 12 ) = ( temp1+temp2 ) / max( unfl, ulp*temp3 )
1052*
1053 380 CONTINUE
1054*
1055 ntest = 12
1056 IF( n.GT.0 ) THEN
1057 IF( il.NE.1 ) THEN
1058 vl = wa1( il ) - max( half*
1059 $ ( wa1( il )-wa1( il-1 ) ), ten*ulp*temp3,
1060 $ ten*rtunfl )
1061 ELSE
1062 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1063 $ ten*ulp*temp3, ten*rtunfl )
1064 END IF
1065 IF( iu.NE.n ) THEN
1066 vu = wa1( iu ) + max( half*
1067 $ ( wa1( iu+1 )-wa1( iu ) ), ten*ulp*temp3,
1068 $ ten*rtunfl )
1069 ELSE
1070 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1071 $ ten*ulp*temp3, ten*rtunfl )
1072 END IF
1073 ELSE
1074 vl = zero
1075 vu = one
1076 END IF
1077*
1078 DO 390 i = 1, n
1079 d1( i ) = dble( a( i, i ) )
1080 390 CONTINUE
1081 DO 400 i = 1, n - 1
1082 d2( i ) = dble( a( i+1, i ) )
1083 400 CONTINUE
1084 srnamt = 'DSTEVX'
1085 CALL dstevx( 'V', 'V', n, d1, d2, vl, vu, il, iu, abstol,
1086 $ m2, wa2, z, ldu, work, iwork,
1087 $ iwork( 5*n+1 ), iinfo )
1088 IF( iinfo.NE.0 ) THEN
1089 WRITE( nounit, fmt = 9999 )'DSTEVX(V,V)', iinfo, n,
1090 $ jtype, ioldsd
1091 info = abs( iinfo )
1092 IF( iinfo.LT.0 ) THEN
1093 RETURN
1094 ELSE
1095 result( 13 ) = ulpinv
1096 result( 14 ) = ulpinv
1097 result( 15 ) = ulpinv
1098 GO TO 440
1099 END IF
1100 END IF
1101*
1102 IF( m2.EQ.0 .AND. n.GT.0 ) THEN
1103 result( 13 ) = ulpinv
1104 result( 14 ) = ulpinv
1105 result( 15 ) = ulpinv
1106 GO TO 440
1107 END IF
1108*
1109* Do tests 13 and 14.
1110*
1111 DO 410 i = 1, n
1112 d3( i ) = dble( a( i, i ) )
1113 410 CONTINUE
1114 DO 420 i = 1, n - 1
1115 d4( i ) = dble( a( i+1, i ) )
1116 420 CONTINUE
1117 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1118 $ max( 1, m2 ), result( 13 ) )
1119*
1120 ntest = 15
1121 DO 430 i = 1, n - 1
1122 d4( i ) = dble( a( i+1, i ) )
1123 430 CONTINUE
1124 srnamt = 'DSTEVX'
1125 CALL dstevx( 'N', 'V', n, d3, d4, vl, vu, il, iu, abstol,
1126 $ m3, wa3, z, ldu, work, iwork,
1127 $ iwork( 5*n+1 ), iinfo )
1128 IF( iinfo.NE.0 ) THEN
1129 WRITE( nounit, fmt = 9999 )'DSTEVX(N,V)', iinfo, n,
1130 $ jtype, ioldsd
1131 info = abs( iinfo )
1132 IF( iinfo.LT.0 ) THEN
1133 RETURN
1134 ELSE
1135 result( 15 ) = ulpinv
1136 GO TO 440
1137 END IF
1138 END IF
1139*
1140* Do test 15.
1141*
1142 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1143 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1144 result( 15 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1145*
1146 440 CONTINUE
1147*
1148 ntest = 16
1149 DO 450 i = 1, n
1150 d1( i ) = dble( a( i, i ) )
1151 450 CONTINUE
1152 DO 460 i = 1, n - 1
1153 d2( i ) = dble( a( i+1, i ) )
1154 460 CONTINUE
1155 srnamt = 'DSTEVD'
1156 CALL dstevd( 'V', n, d1, d2, z, ldu, work, lwedc, iwork,
1157 $ liwedc, iinfo )
1158 IF( iinfo.NE.0 ) THEN
1159 WRITE( nounit, fmt = 9999 )'DSTEVD(V)', iinfo, n,
1160 $ jtype, ioldsd
1161 info = abs( iinfo )
1162 IF( iinfo.LT.0 ) THEN
1163 RETURN
1164 ELSE
1165 result( 16 ) = ulpinv
1166 result( 17 ) = ulpinv
1167 result( 18 ) = ulpinv
1168 GO TO 510
1169 END IF
1170 END IF
1171*
1172* Do tests 16 and 17.
1173*
1174 DO 470 i = 1, n
1175 d3( i ) = dble( a( i, i ) )
1176 470 CONTINUE
1177 DO 480 i = 1, n - 1
1178 d4( i ) = dble( a( i+1, i ) )
1179 480 CONTINUE
1180 CALL dstt21( n, 0, d3, d4, d1, d2, z, ldu, work,
1181 $ result( 16 ) )
1182*
1183 ntest = 18
1184 DO 490 i = 1, n - 1
1185 d4( i ) = dble( a( i+1, i ) )
1186 490 CONTINUE
1187 srnamt = 'DSTEVD'
1188 CALL dstevd( 'N', n, d3, d4, z, ldu, work, lwedc, iwork,
1189 $ liwedc, iinfo )
1190 IF( iinfo.NE.0 ) THEN
1191 WRITE( nounit, fmt = 9999 )'DSTEVD(N)', iinfo, n,
1192 $ jtype, ioldsd
1193 info = abs( iinfo )
1194 IF( iinfo.LT.0 ) THEN
1195 RETURN
1196 ELSE
1197 result( 18 ) = ulpinv
1198 GO TO 510
1199 END IF
1200 END IF
1201*
1202* Do test 18.
1203*
1204 temp1 = zero
1205 temp2 = zero
1206 DO 500 j = 1, n
1207 temp1 = max( temp1, abs( eveigs( j ) ),
1208 $ abs( d3( j ) ) )
1209 temp2 = max( temp2, abs( eveigs( j )-d3( j ) ) )
1210 500 CONTINUE
1211 result( 18 ) = temp2 / max( unfl,
1212 $ ulp*max( temp1, temp2 ) )
1213*
1214 510 CONTINUE
1215*
1216 ntest = 19
1217 DO 520 i = 1, n
1218 d1( i ) = dble( a( i, i ) )
1219 520 CONTINUE
1220 DO 530 i = 1, n - 1
1221 d2( i ) = dble( a( i+1, i ) )
1222 530 CONTINUE
1223 srnamt = 'DSTEVR'
1224 CALL dstevr( 'V', 'I', n, d1, d2, vl, vu, il, iu, abstol,
1225 $ m2, wa2, z, ldu, iwork, work, lwork,
1226 $ iwork(2*n+1), liwork-2*n, iinfo )
1227 IF( iinfo.NE.0 ) THEN
1228 WRITE( nounit, fmt = 9999 )'DSTEVR(V,I)', iinfo, n,
1229 $ jtype, ioldsd
1230 info = abs( iinfo )
1231 IF( iinfo.LT.0 ) THEN
1232 RETURN
1233 ELSE
1234 result( 19 ) = ulpinv
1235 result( 20 ) = ulpinv
1236 result( 21 ) = ulpinv
1237 GO TO 570
1238 END IF
1239 END IF
1240*
1241* DO tests 19 and 20.
1242*
1243 DO 540 i = 1, n
1244 d3( i ) = dble( a( i, i ) )
1245 540 CONTINUE
1246 DO 550 i = 1, n - 1
1247 d4( i ) = dble( a( i+1, i ) )
1248 550 CONTINUE
1249 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1250 $ max( 1, m2 ), result( 19 ) )
1251*
1252*
1253 ntest = 21
1254 DO 560 i = 1, n - 1
1255 d4( i ) = dble( a( i+1, i ) )
1256 560 CONTINUE
1257 srnamt = 'DSTEVR'
1258 CALL dstevr( 'N', 'I', n, d3, d4, vl, vu, il, iu, abstol,
1259 $ m3, wa3, z, ldu, iwork, work, lwork,
1260 $ iwork(2*n+1), liwork-2*n, iinfo )
1261 IF( iinfo.NE.0 ) THEN
1262 WRITE( nounit, fmt = 9999 )'DSTEVR(N,I)', iinfo, n,
1263 $ jtype, ioldsd
1264 info = abs( iinfo )
1265 IF( iinfo.LT.0 ) THEN
1266 RETURN
1267 ELSE
1268 result( 21 ) = ulpinv
1269 GO TO 570
1270 END IF
1271 END IF
1272*
1273* Do test 21.
1274*
1275 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1276 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1277 result( 21 ) = ( temp1+temp2 ) / max( unfl, ulp*temp3 )
1278*
1279 570 CONTINUE
1280*
1281 ntest = 21
1282 IF( n.GT.0 ) THEN
1283 IF( il.NE.1 ) THEN
1284 vl = wa1( il ) - max( half*
1285 $ ( wa1( il )-wa1( il-1 ) ), ten*ulp*temp3,
1286 $ ten*rtunfl )
1287 ELSE
1288 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1289 $ ten*ulp*temp3, ten*rtunfl )
1290 END IF
1291 IF( iu.NE.n ) THEN
1292 vu = wa1( iu ) + max( half*
1293 $ ( wa1( iu+1 )-wa1( iu ) ), ten*ulp*temp3,
1294 $ ten*rtunfl )
1295 ELSE
1296 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1297 $ ten*ulp*temp3, ten*rtunfl )
1298 END IF
1299 ELSE
1300 vl = zero
1301 vu = one
1302 END IF
1303*
1304 DO 580 i = 1, n
1305 d1( i ) = dble( a( i, i ) )
1306 580 CONTINUE
1307 DO 590 i = 1, n - 1
1308 d2( i ) = dble( a( i+1, i ) )
1309 590 CONTINUE
1310 srnamt = 'DSTEVR'
1311 CALL dstevr( 'V', 'V', n, d1, d2, vl, vu, il, iu, abstol,
1312 $ m2, wa2, z, ldu, iwork, work, lwork,
1313 $ iwork(2*n+1), liwork-2*n, iinfo )
1314 IF( iinfo.NE.0 ) THEN
1315 WRITE( nounit, fmt = 9999 )'DSTEVR(V,V)', iinfo, n,
1316 $ jtype, ioldsd
1317 info = abs( iinfo )
1318 IF( iinfo.LT.0 ) THEN
1319 RETURN
1320 ELSE
1321 result( 22 ) = ulpinv
1322 result( 23 ) = ulpinv
1323 result( 24 ) = ulpinv
1324 GO TO 630
1325 END IF
1326 END IF
1327*
1328 IF( m2.EQ.0 .AND. n.GT.0 ) THEN
1329 result( 22 ) = ulpinv
1330 result( 23 ) = ulpinv
1331 result( 24 ) = ulpinv
1332 GO TO 630
1333 END IF
1334*
1335* Do tests 22 and 23.
1336*
1337 DO 600 i = 1, n
1338 d3( i ) = dble( a( i, i ) )
1339 600 CONTINUE
1340 DO 610 i = 1, n - 1
1341 d4( i ) = dble( a( i+1, i ) )
1342 610 CONTINUE
1343 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1344 $ max( 1, m2 ), result( 22 ) )
1345*
1346 ntest = 24
1347 DO 620 i = 1, n - 1
1348 d4( i ) = dble( a( i+1, i ) )
1349 620 CONTINUE
1350 srnamt = 'DSTEVR'
1351 CALL dstevr( 'N', 'V', n, d3, d4, vl, vu, il, iu, abstol,
1352 $ m3, wa3, z, ldu, iwork, work, lwork,
1353 $ iwork(2*n+1), liwork-2*n, iinfo )
1354 IF( iinfo.NE.0 ) THEN
1355 WRITE( nounit, fmt = 9999 )'DSTEVR(N,V)', iinfo, n,
1356 $ jtype, ioldsd
1357 info = abs( iinfo )
1358 IF( iinfo.LT.0 ) THEN
1359 RETURN
1360 ELSE
1361 result( 24 ) = ulpinv
1362 GO TO 630
1363 END IF
1364 END IF
1365*
1366* Do test 24.
1367*
1368 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1369 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1370 result( 24 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1371*
1372 630 CONTINUE
1373*
1374*
1375*
1376 ELSE
1377*
1378 DO 640 i = 1, 24
1379 result( i ) = zero
1380 640 CONTINUE
1381 ntest = 24
1382 END IF
1383*
1384* Perform remaining tests storing upper or lower triangular
1385* part of matrix.
1386*
1387 DO 1720 iuplo = 0, 1
1388 IF( iuplo.EQ.0 ) THEN
1389 uplo = 'L'
1390 ELSE
1391 uplo = 'U'
1392 END IF
1393*
1394* 4) Call DSYEV and DSYEVX.
1395*
1396 CALL dlacpy( ' ', n, n, a, lda, v, ldu )
1397*
1398 ntest = ntest + 1
1399 srnamt = 'DSYEV'
1400 CALL dsyev( 'V', uplo, n, a, ldu, d1, work, lwork,
1401 $ iinfo )
1402 IF( iinfo.NE.0 ) THEN
1403 WRITE( nounit, fmt = 9999 )'DSYEV(V,' // uplo // ')',
1404 $ iinfo, n, jtype, ioldsd
1405 info = abs( iinfo )
1406 IF( iinfo.LT.0 ) THEN
1407 RETURN
1408 ELSE
1409 result( ntest ) = ulpinv
1410 result( ntest+1 ) = ulpinv
1411 result( ntest+2 ) = ulpinv
1412 GO TO 660
1413 END IF
1414 END IF
1415*
1416* Do tests 25 and 26 (or +54)
1417*
1418 CALL dsyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
1419 $ ldu, tau, work, result( ntest ) )
1420*
1421 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1422*
1423 ntest = ntest + 2
1424 srnamt = 'DSYEV'
1425 CALL dsyev( 'N', uplo, n, a, ldu, d3, work, lwork,
1426 $ iinfo )
1427 IF( iinfo.NE.0 ) THEN
1428 WRITE( nounit, fmt = 9999 )'DSYEV(N,' // uplo // ')',
1429 $ iinfo, n, jtype, ioldsd
1430 info = abs( iinfo )
1431 IF( iinfo.LT.0 ) THEN
1432 RETURN
1433 ELSE
1434 result( ntest ) = ulpinv
1435 GO TO 660
1436 END IF
1437 END IF
1438*
1439* Do test 27 (or +54)
1440*
1441 temp1 = zero
1442 temp2 = zero
1443 DO 650 j = 1, n
1444 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1445 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1446 650 CONTINUE
1447 result( ntest ) = temp2 / max( unfl,
1448 $ ulp*max( temp1, temp2 ) )
1449*
1450 660 CONTINUE
1451 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1452*
1453 ntest = ntest + 1
1454*
1455 IF( n.GT.0 ) THEN
1456 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
1457 IF( il.NE.1 ) THEN
1458 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
1459 $ ten*ulp*temp3, ten*rtunfl )
1460 ELSE IF( n.GT.0 ) THEN
1461 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
1462 $ ten*ulp*temp3, ten*rtunfl )
1463 END IF
1464 IF( iu.NE.n ) THEN
1465 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
1466 $ ten*ulp*temp3, ten*rtunfl )
1467 ELSE IF( n.GT.0 ) THEN
1468 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
1469 $ ten*ulp*temp3, ten*rtunfl )
1470 END IF
1471 ELSE
1472 temp3 = zero
1473 vl = zero
1474 vu = one
1475 END IF
1476*
1477 srnamt = 'DSYEVX'
1478 CALL dsyevx( 'V', 'A', uplo, n, a, ldu, vl, vu, il, iu,
1479 $ abstol, m, wa1, z, ldu, work, lwork, iwork,
1480 $ iwork( 5*n+1 ), iinfo )
1481 IF( iinfo.NE.0 ) THEN
1482 WRITE( nounit, fmt = 9999 )'DSYEVX(V,A,' // uplo //
1483 $ ')', iinfo, n, jtype, ioldsd
1484 info = abs( iinfo )
1485 IF( iinfo.LT.0 ) THEN
1486 RETURN
1487 ELSE
1488 result( ntest ) = ulpinv
1489 result( ntest+1 ) = ulpinv
1490 result( ntest+2 ) = ulpinv
1491 GO TO 680
1492 END IF
1493 END IF
1494*
1495* Do tests 28 and 29 (or +54)
1496*
1497 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1498*
1499 CALL dsyt21( 1, uplo, n, 0, a, ldu, d1, d2, z, ldu, v,
1500 $ ldu, tau, work, result( ntest ) )
1501*
1502 ntest = ntest + 2
1503 srnamt = 'DSYEVX'
1504 CALL dsyevx( 'N', 'A', uplo, n, a, ldu, vl, vu, il, iu,
1505 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1506 $ iwork( 5*n+1 ), iinfo )
1507 IF( iinfo.NE.0 ) THEN
1508 WRITE( nounit, fmt = 9999 )'DSYEVX(N,A,' // uplo //
1509 $ ')', iinfo, n, jtype, ioldsd
1510 info = abs( iinfo )
1511 IF( iinfo.LT.0 ) THEN
1512 RETURN
1513 ELSE
1514 result( ntest ) = ulpinv
1515 GO TO 680
1516 END IF
1517 END IF
1518*
1519* Do test 30 (or +54)
1520*
1521 temp1 = zero
1522 temp2 = zero
1523 DO 670 j = 1, n
1524 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1525 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1526 670 CONTINUE
1527 result( ntest ) = temp2 / max( unfl,
1528 $ ulp*max( temp1, temp2 ) )
1529*
1530 680 CONTINUE
1531*
1532 ntest = ntest + 1
1533 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1534 srnamt = 'DSYEVX'
1535 CALL dsyevx( 'V', 'I', uplo, n, a, ldu, vl, vu, il, iu,
1536 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1537 $ iwork( 5*n+1 ), iinfo )
1538 IF( iinfo.NE.0 ) THEN
1539 WRITE( nounit, fmt = 9999 )'DSYEVX(V,I,' // uplo //
1540 $ ')', iinfo, n, jtype, ioldsd
1541 info = abs( iinfo )
1542 IF( iinfo.LT.0 ) THEN
1543 RETURN
1544 ELSE
1545 result( ntest ) = ulpinv
1546 result( ntest+1 ) = ulpinv
1547 result( ntest+2 ) = ulpinv
1548 GO TO 690
1549 END IF
1550 END IF
1551*
1552* Do tests 31 and 32 (or +54)
1553*
1554 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1555*
1556 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1557 $ v, ldu, tau, work, result( ntest ) )
1558*
1559 ntest = ntest + 2
1560 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1561 srnamt = 'DSYEVX'
1562 CALL dsyevx( 'N', 'I', uplo, n, a, ldu, vl, vu, il, iu,
1563 $ abstol, m3, wa3, z, ldu, work, lwork, iwork,
1564 $ iwork( 5*n+1 ), iinfo )
1565 IF( iinfo.NE.0 ) THEN
1566 WRITE( nounit, fmt = 9999 )'DSYEVX(N,I,' // uplo //
1567 $ ')', iinfo, n, jtype, ioldsd
1568 info = abs( iinfo )
1569 IF( iinfo.LT.0 ) THEN
1570 RETURN
1571 ELSE
1572 result( ntest ) = ulpinv
1573 GO TO 690
1574 END IF
1575 END IF
1576*
1577* Do test 33 (or +54)
1578*
1579 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1580 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1581 result( ntest ) = ( temp1+temp2 ) /
1582 $ max( unfl, ulp*temp3 )
1583 690 CONTINUE
1584*
1585 ntest = ntest + 1
1586 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1587 srnamt = 'DSYEVX'
1588 CALL dsyevx( 'V', 'V', uplo, n, a, ldu, vl, vu, il, iu,
1589 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1590 $ iwork( 5*n+1 ), iinfo )
1591 IF( iinfo.NE.0 ) THEN
1592 WRITE( nounit, fmt = 9999 )'DSYEVX(V,V,' // uplo //
1593 $ ')', iinfo, n, jtype, ioldsd
1594 info = abs( iinfo )
1595 IF( iinfo.LT.0 ) THEN
1596 RETURN
1597 ELSE
1598 result( ntest ) = ulpinv
1599 result( ntest+1 ) = ulpinv
1600 result( ntest+2 ) = ulpinv
1601 GO TO 700
1602 END IF
1603 END IF
1604*
1605* Do tests 34 and 35 (or +54)
1606*
1607 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1608*
1609 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1610 $ v, ldu, tau, work, result( ntest ) )
1611*
1612 ntest = ntest + 2
1613 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1614 srnamt = 'DSYEVX'
1615 CALL dsyevx( 'N', 'V', uplo, n, a, ldu, vl, vu, il, iu,
1616 $ abstol, m3, wa3, z, ldu, work, lwork, iwork,
1617 $ iwork( 5*n+1 ), iinfo )
1618 IF( iinfo.NE.0 ) THEN
1619 WRITE( nounit, fmt = 9999 )'DSYEVX(N,V,' // uplo //
1620 $ ')', iinfo, n, jtype, ioldsd
1621 info = abs( iinfo )
1622 IF( iinfo.LT.0 ) THEN
1623 RETURN
1624 ELSE
1625 result( ntest ) = ulpinv
1626 GO TO 700
1627 END IF
1628 END IF
1629*
1630 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1631 result( ntest ) = ulpinv
1632 GO TO 700
1633 END IF
1634*
1635* Do test 36 (or +54)
1636*
1637 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1638 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1639 IF( n.GT.0 ) THEN
1640 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1641 ELSE
1642 temp3 = zero
1643 END IF
1644 result( ntest ) = ( temp1+temp2 ) /
1645 $ max( unfl, temp3*ulp )
1646*
1647 700 CONTINUE
1648*
1649* 5) Call DSPEV and DSPEVX.
1650*
1651 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1652*
1653* Load array WORK with the upper or lower triangular
1654* part of the matrix in packed form.
1655*
1656 IF( iuplo.EQ.1 ) THEN
1657 indx = 1
1658 DO 720 j = 1, n
1659 DO 710 i = 1, j
1660 work( indx ) = a( i, j )
1661 indx = indx + 1
1662 710 CONTINUE
1663 720 CONTINUE
1664 ELSE
1665 indx = 1
1666 DO 740 j = 1, n
1667 DO 730 i = j, n
1668 work( indx ) = a( i, j )
1669 indx = indx + 1
1670 730 CONTINUE
1671 740 CONTINUE
1672 END IF
1673*
1674 ntest = ntest + 1
1675 srnamt = 'DSPEV'
1676 CALL dspev( 'V', uplo, n, work, d1, z, ldu, v, iinfo )
1677 IF( iinfo.NE.0 ) THEN
1678 WRITE( nounit, fmt = 9999 )'DSPEV(V,' // uplo // ')',
1679 $ iinfo, n, jtype, ioldsd
1680 info = abs( iinfo )
1681 IF( iinfo.LT.0 ) THEN
1682 RETURN
1683 ELSE
1684 result( ntest ) = ulpinv
1685 result( ntest+1 ) = ulpinv
1686 result( ntest+2 ) = ulpinv
1687 GO TO 800
1688 END IF
1689 END IF
1690*
1691* Do tests 37 and 38 (or +54)
1692*
1693 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
1694 $ ldu, tau, work, result( ntest ) )
1695*
1696 IF( iuplo.EQ.1 ) THEN
1697 indx = 1
1698 DO 760 j = 1, n
1699 DO 750 i = 1, j
1700 work( indx ) = a( i, j )
1701 indx = indx + 1
1702 750 CONTINUE
1703 760 CONTINUE
1704 ELSE
1705 indx = 1
1706 DO 780 j = 1, n
1707 DO 770 i = j, n
1708 work( indx ) = a( i, j )
1709 indx = indx + 1
1710 770 CONTINUE
1711 780 CONTINUE
1712 END IF
1713*
1714 ntest = ntest + 2
1715 srnamt = 'DSPEV'
1716 CALL dspev( 'N', uplo, n, work, d3, z, ldu, v, iinfo )
1717 IF( iinfo.NE.0 ) THEN
1718 WRITE( nounit, fmt = 9999 )'DSPEV(N,' // uplo // ')',
1719 $ iinfo, n, jtype, ioldsd
1720 info = abs( iinfo )
1721 IF( iinfo.LT.0 ) THEN
1722 RETURN
1723 ELSE
1724 result( ntest ) = ulpinv
1725 GO TO 800
1726 END IF
1727 END IF
1728*
1729* Do test 39 (or +54)
1730*
1731 temp1 = zero
1732 temp2 = zero
1733 DO 790 j = 1, n
1734 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1735 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1736 790 CONTINUE
1737 result( ntest ) = temp2 / max( unfl,
1738 $ ulp*max( temp1, temp2 ) )
1739*
1740* Load array WORK with the upper or lower triangular part
1741* of the matrix in packed form.
1742*
1743 800 CONTINUE
1744 IF( iuplo.EQ.1 ) THEN
1745 indx = 1
1746 DO 820 j = 1, n
1747 DO 810 i = 1, j
1748 work( indx ) = a( i, j )
1749 indx = indx + 1
1750 810 CONTINUE
1751 820 CONTINUE
1752 ELSE
1753 indx = 1
1754 DO 840 j = 1, n
1755 DO 830 i = j, n
1756 work( indx ) = a( i, j )
1757 indx = indx + 1
1758 830 CONTINUE
1759 840 CONTINUE
1760 END IF
1761*
1762 ntest = ntest + 1
1763*
1764 IF( n.GT.0 ) THEN
1765 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
1766 IF( il.NE.1 ) THEN
1767 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
1768 $ ten*ulp*temp3, ten*rtunfl )
1769 ELSE IF( n.GT.0 ) THEN
1770 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
1771 $ ten*ulp*temp3, ten*rtunfl )
1772 END IF
1773 IF( iu.NE.n ) THEN
1774 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
1775 $ ten*ulp*temp3, ten*rtunfl )
1776 ELSE IF( n.GT.0 ) THEN
1777 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
1778 $ ten*ulp*temp3, ten*rtunfl )
1779 END IF
1780 ELSE
1781 temp3 = zero
1782 vl = zero
1783 vu = one
1784 END IF
1785*
1786 srnamt = 'DSPEVX'
1787 CALL dspevx( 'V', 'A', uplo, n, work, vl, vu, il, iu,
1788 $ abstol, m, wa1, z, ldu, v, iwork,
1789 $ iwork( 5*n+1 ), iinfo )
1790 IF( iinfo.NE.0 ) THEN
1791 WRITE( nounit, fmt = 9999 )'DSPEVX(V,A,' // uplo //
1792 $ ')', iinfo, n, jtype, ioldsd
1793 info = abs( iinfo )
1794 IF( iinfo.LT.0 ) THEN
1795 RETURN
1796 ELSE
1797 result( ntest ) = ulpinv
1798 result( ntest+1 ) = ulpinv
1799 result( ntest+2 ) = ulpinv
1800 GO TO 900
1801 END IF
1802 END IF
1803*
1804* Do tests 40 and 41 (or +54)
1805*
1806 CALL dsyt21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
1807 $ ldu, tau, work, result( ntest ) )
1808*
1809 ntest = ntest + 2
1810*
1811 IF( iuplo.EQ.1 ) THEN
1812 indx = 1
1813 DO 860 j = 1, n
1814 DO 850 i = 1, j
1815 work( indx ) = a( i, j )
1816 indx = indx + 1
1817 850 CONTINUE
1818 860 CONTINUE
1819 ELSE
1820 indx = 1
1821 DO 880 j = 1, n
1822 DO 870 i = j, n
1823 work( indx ) = a( i, j )
1824 indx = indx + 1
1825 870 CONTINUE
1826 880 CONTINUE
1827 END IF
1828*
1829 srnamt = 'DSPEVX'
1830 CALL dspevx( 'N', 'A', uplo, n, work, vl, vu, il, iu,
1831 $ abstol, m2, wa2, z, ldu, v, iwork,
1832 $ iwork( 5*n+1 ), iinfo )
1833 IF( iinfo.NE.0 ) THEN
1834 WRITE( nounit, fmt = 9999 )'DSPEVX(N,A,' // uplo //
1835 $ ')', iinfo, n, jtype, ioldsd
1836 info = abs( iinfo )
1837 IF( iinfo.LT.0 ) THEN
1838 RETURN
1839 ELSE
1840 result( ntest ) = ulpinv
1841 GO TO 900
1842 END IF
1843 END IF
1844*
1845* Do test 42 (or +54)
1846*
1847 temp1 = zero
1848 temp2 = zero
1849 DO 890 j = 1, n
1850 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1851 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1852 890 CONTINUE
1853 result( ntest ) = temp2 / max( unfl,
1854 $ ulp*max( temp1, temp2 ) )
1855*
1856 900 CONTINUE
1857 IF( iuplo.EQ.1 ) THEN
1858 indx = 1
1859 DO 920 j = 1, n
1860 DO 910 i = 1, j
1861 work( indx ) = a( i, j )
1862 indx = indx + 1
1863 910 CONTINUE
1864 920 CONTINUE
1865 ELSE
1866 indx = 1
1867 DO 940 j = 1, n
1868 DO 930 i = j, n
1869 work( indx ) = a( i, j )
1870 indx = indx + 1
1871 930 CONTINUE
1872 940 CONTINUE
1873 END IF
1874*
1875 ntest = ntest + 1
1876*
1877 srnamt = 'DSPEVX'
1878 CALL dspevx( 'V', 'I', uplo, n, work, vl, vu, il, iu,
1879 $ abstol, m2, wa2, z, ldu, v, iwork,
1880 $ iwork( 5*n+1 ), iinfo )
1881 IF( iinfo.NE.0 ) THEN
1882 WRITE( nounit, fmt = 9999 )'DSPEVX(V,I,' // uplo //
1883 $ ')', iinfo, n, jtype, ioldsd
1884 info = abs( iinfo )
1885 IF( iinfo.LT.0 ) THEN
1886 RETURN
1887 ELSE
1888 result( ntest ) = ulpinv
1889 result( ntest+1 ) = ulpinv
1890 result( ntest+2 ) = ulpinv
1891 GO TO 990
1892 END IF
1893 END IF
1894*
1895* Do tests 43 and 44 (or +54)
1896*
1897 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1898 $ v, ldu, tau, work, result( ntest ) )
1899*
1900 ntest = ntest + 2
1901*
1902 IF( iuplo.EQ.1 ) THEN
1903 indx = 1
1904 DO 960 j = 1, n
1905 DO 950 i = 1, j
1906 work( indx ) = a( i, j )
1907 indx = indx + 1
1908 950 CONTINUE
1909 960 CONTINUE
1910 ELSE
1911 indx = 1
1912 DO 980 j = 1, n
1913 DO 970 i = j, n
1914 work( indx ) = a( i, j )
1915 indx = indx + 1
1916 970 CONTINUE
1917 980 CONTINUE
1918 END IF
1919*
1920 srnamt = 'DSPEVX'
1921 CALL dspevx( 'N', 'I', uplo, n, work, vl, vu, il, iu,
1922 $ abstol, m3, wa3, z, ldu, v, iwork,
1923 $ iwork( 5*n+1 ), iinfo )
1924 IF( iinfo.NE.0 ) THEN
1925 WRITE( nounit, fmt = 9999 )'DSPEVX(N,I,' // uplo //
1926 $ ')', iinfo, n, jtype, ioldsd
1927 info = abs( iinfo )
1928 IF( iinfo.LT.0 ) THEN
1929 RETURN
1930 ELSE
1931 result( ntest ) = ulpinv
1932 GO TO 990
1933 END IF
1934 END IF
1935*
1936 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1937 result( ntest ) = ulpinv
1938 GO TO 990
1939 END IF
1940*
1941* Do test 45 (or +54)
1942*
1943 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1944 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1945 IF( n.GT.0 ) THEN
1946 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1947 ELSE
1948 temp3 = zero
1949 END IF
1950 result( ntest ) = ( temp1+temp2 ) /
1951 $ max( unfl, temp3*ulp )
1952*
1953 990 CONTINUE
1954 IF( iuplo.EQ.1 ) THEN
1955 indx = 1
1956 DO 1010 j = 1, n
1957 DO 1000 i = 1, j
1958 work( indx ) = a( i, j )
1959 indx = indx + 1
1960 1000 CONTINUE
1961 1010 CONTINUE
1962 ELSE
1963 indx = 1
1964 DO 1030 j = 1, n
1965 DO 1020 i = j, n
1966 work( indx ) = a( i, j )
1967 indx = indx + 1
1968 1020 CONTINUE
1969 1030 CONTINUE
1970 END IF
1971*
1972 ntest = ntest + 1
1973*
1974 srnamt = 'DSPEVX'
1975 CALL dspevx( 'V', 'V', uplo, n, work, vl, vu, il, iu,
1976 $ abstol, m2, wa2, z, ldu, v, iwork,
1977 $ iwork( 5*n+1 ), iinfo )
1978 IF( iinfo.NE.0 ) THEN
1979 WRITE( nounit, fmt = 9999 )'DSPEVX(V,V,' // uplo //
1980 $ ')', iinfo, n, jtype, ioldsd
1981 info = abs( iinfo )
1982 IF( iinfo.LT.0 ) THEN
1983 RETURN
1984 ELSE
1985 result( ntest ) = ulpinv
1986 result( ntest+1 ) = ulpinv
1987 result( ntest+2 ) = ulpinv
1988 GO TO 1080
1989 END IF
1990 END IF
1991*
1992* Do tests 46 and 47 (or +54)
1993*
1994 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1995 $ v, ldu, tau, work, result( ntest ) )
1996*
1997 ntest = ntest + 2
1998*
1999 IF( iuplo.EQ.1 ) THEN
2000 indx = 1
2001 DO 1050 j = 1, n
2002 DO 1040 i = 1, j
2003 work( indx ) = a( i, j )
2004 indx = indx + 1
2005 1040 CONTINUE
2006 1050 CONTINUE
2007 ELSE
2008 indx = 1
2009 DO 1070 j = 1, n
2010 DO 1060 i = j, n
2011 work( indx ) = a( i, j )
2012 indx = indx + 1
2013 1060 CONTINUE
2014 1070 CONTINUE
2015 END IF
2016*
2017 srnamt = 'DSPEVX'
2018 CALL dspevx( 'N', 'V', uplo, n, work, vl, vu, il, iu,
2019 $ abstol, m3, wa3, z, ldu, v, iwork,
2020 $ iwork( 5*n+1 ), iinfo )
2021 IF( iinfo.NE.0 ) THEN
2022 WRITE( nounit, fmt = 9999 )'DSPEVX(N,V,' // uplo //
2023 $ ')', iinfo, n, jtype, ioldsd
2024 info = abs( iinfo )
2025 IF( iinfo.LT.0 ) THEN
2026 RETURN
2027 ELSE
2028 result( ntest ) = ulpinv
2029 GO TO 1080
2030 END IF
2031 END IF
2032*
2033 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2034 result( ntest ) = ulpinv
2035 GO TO 1080
2036 END IF
2037*
2038* Do test 48 (or +54)
2039*
2040 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2041 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2042 IF( n.GT.0 ) THEN
2043 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2044 ELSE
2045 temp3 = zero
2046 END IF
2047 result( ntest ) = ( temp1+temp2 ) /
2048 $ max( unfl, temp3*ulp )
2049*
2050 1080 CONTINUE
2051*
2052* 6) Call DSBEV and DSBEVX.
2053*
2054 IF( jtype.LE.7 ) THEN
2055 kd = 1
2056 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
2057 kd = max( n-1, 0 )
2058 ELSE
2059 kd = ihbw
2060 END IF
2061*
2062* Load array V with the upper or lower triangular part
2063* of the matrix in band form.
2064*
2065 IF( iuplo.EQ.1 ) THEN
2066 DO 1100 j = 1, n
2067 DO 1090 i = max( 1, j-kd ), j
2068 v( kd+1+i-j, j ) = a( i, j )
2069 1090 CONTINUE
2070 1100 CONTINUE
2071 ELSE
2072 DO 1120 j = 1, n
2073 DO 1110 i = j, min( n, j+kd )
2074 v( 1+i-j, j ) = a( i, j )
2075 1110 CONTINUE
2076 1120 CONTINUE
2077 END IF
2078*
2079 ntest = ntest + 1
2080 srnamt = 'DSBEV'
2081 CALL dsbev( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
2082 $ iinfo )
2083 IF( iinfo.NE.0 ) THEN
2084 WRITE( nounit, fmt = 9999 )'DSBEV(V,' // uplo // ')',
2085 $ iinfo, n, jtype, ioldsd
2086 info = abs( iinfo )
2087 IF( iinfo.LT.0 ) THEN
2088 RETURN
2089 ELSE
2090 result( ntest ) = ulpinv
2091 result( ntest+1 ) = ulpinv
2092 result( ntest+2 ) = ulpinv
2093 GO TO 1180
2094 END IF
2095 END IF
2096*
2097* Do tests 49 and 50 (or ... )
2098*
2099 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2100 $ ldu, tau, work, result( ntest ) )
2101*
2102 IF( iuplo.EQ.1 ) THEN
2103 DO 1140 j = 1, n
2104 DO 1130 i = max( 1, j-kd ), j
2105 v( kd+1+i-j, j ) = a( i, j )
2106 1130 CONTINUE
2107 1140 CONTINUE
2108 ELSE
2109 DO 1160 j = 1, n
2110 DO 1150 i = j, min( n, j+kd )
2111 v( 1+i-j, j ) = a( i, j )
2112 1150 CONTINUE
2113 1160 CONTINUE
2114 END IF
2115*
2116 ntest = ntest + 2
2117 srnamt = 'DSBEV'
2118 CALL dsbev( 'N', uplo, n, kd, v, ldu, d3, z, ldu, work,
2119 $ iinfo )
2120 IF( iinfo.NE.0 ) THEN
2121 WRITE( nounit, fmt = 9999 )'DSBEV(N,' // uplo // ')',
2122 $ iinfo, n, jtype, ioldsd
2123 info = abs( iinfo )
2124 IF( iinfo.LT.0 ) THEN
2125 RETURN
2126 ELSE
2127 result( ntest ) = ulpinv
2128 GO TO 1180
2129 END IF
2130 END IF
2131*
2132* Do test 51 (or +54)
2133*
2134 temp1 = zero
2135 temp2 = zero
2136 DO 1170 j = 1, n
2137 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2138 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2139 1170 CONTINUE
2140 result( ntest ) = temp2 / max( unfl,
2141 $ ulp*max( temp1, temp2 ) )
2142*
2143* Load array V with the upper or lower triangular part
2144* of the matrix in band form.
2145*
2146 1180 CONTINUE
2147 IF( iuplo.EQ.1 ) THEN
2148 DO 1200 j = 1, n
2149 DO 1190 i = max( 1, j-kd ), j
2150 v( kd+1+i-j, j ) = a( i, j )
2151 1190 CONTINUE
2152 1200 CONTINUE
2153 ELSE
2154 DO 1220 j = 1, n
2155 DO 1210 i = j, min( n, j+kd )
2156 v( 1+i-j, j ) = a( i, j )
2157 1210 CONTINUE
2158 1220 CONTINUE
2159 END IF
2160*
2161 ntest = ntest + 1
2162 srnamt = 'DSBEVX'
2163 CALL dsbevx( 'V', 'A', uplo, n, kd, v, ldu, u, ldu, vl,
2164 $ vu, il, iu, abstol, m, wa2, z, ldu, work,
2165 $ iwork, iwork( 5*n+1 ), iinfo )
2166 IF( iinfo.NE.0 ) THEN
2167 WRITE( nounit, fmt = 9999 )'DSBEVX(V,A,' // uplo //
2168 $ ')', iinfo, n, jtype, ioldsd
2169 info = abs( iinfo )
2170 IF( iinfo.LT.0 ) THEN
2171 RETURN
2172 ELSE
2173 result( ntest ) = ulpinv
2174 result( ntest+1 ) = ulpinv
2175 result( ntest+2 ) = ulpinv
2176 GO TO 1280
2177 END IF
2178 END IF
2179*
2180* Do tests 52 and 53 (or +54)
2181*
2182 CALL dsyt21( 1, uplo, n, 0, a, ldu, wa2, d2, z, ldu, v,
2183 $ ldu, tau, work, result( ntest ) )
2184*
2185 ntest = ntest + 2
2186*
2187 IF( iuplo.EQ.1 ) THEN
2188 DO 1240 j = 1, n
2189 DO 1230 i = max( 1, j-kd ), j
2190 v( kd+1+i-j, j ) = a( i, j )
2191 1230 CONTINUE
2192 1240 CONTINUE
2193 ELSE
2194 DO 1260 j = 1, n
2195 DO 1250 i = j, min( n, j+kd )
2196 v( 1+i-j, j ) = a( i, j )
2197 1250 CONTINUE
2198 1260 CONTINUE
2199 END IF
2200*
2201 srnamt = 'DSBEVX'
2202 CALL dsbevx( 'N', 'A', uplo, n, kd, v, ldu, u, ldu, vl,
2203 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
2204 $ iwork, iwork( 5*n+1 ), iinfo )
2205 IF( iinfo.NE.0 ) THEN
2206 WRITE( nounit, fmt = 9999 )'DSBEVX(N,A,' // uplo //
2207 $ ')', iinfo, n, jtype, ioldsd
2208 info = abs( iinfo )
2209 IF( iinfo.LT.0 ) THEN
2210 RETURN
2211 ELSE
2212 result( ntest ) = ulpinv
2213 GO TO 1280
2214 END IF
2215 END IF
2216*
2217* Do test 54 (or +54)
2218*
2219 temp1 = zero
2220 temp2 = zero
2221 DO 1270 j = 1, n
2222 temp1 = max( temp1, abs( wa2( j ) ), abs( wa3( j ) ) )
2223 temp2 = max( temp2, abs( wa2( j )-wa3( j ) ) )
2224 1270 CONTINUE
2225 result( ntest ) = temp2 / max( unfl,
2226 $ ulp*max( temp1, temp2 ) )
2227*
2228 1280 CONTINUE
2229 ntest = ntest + 1
2230 IF( iuplo.EQ.1 ) THEN
2231 DO 1300 j = 1, n
2232 DO 1290 i = max( 1, j-kd ), j
2233 v( kd+1+i-j, j ) = a( i, j )
2234 1290 CONTINUE
2235 1300 CONTINUE
2236 ELSE
2237 DO 1320 j = 1, n
2238 DO 1310 i = j, min( n, j+kd )
2239 v( 1+i-j, j ) = a( i, j )
2240 1310 CONTINUE
2241 1320 CONTINUE
2242 END IF
2243*
2244 srnamt = 'DSBEVX'
2245 CALL dsbevx( 'V', 'I', uplo, n, kd, v, ldu, u, ldu, vl,
2246 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
2247 $ iwork, iwork( 5*n+1 ), iinfo )
2248 IF( iinfo.NE.0 ) THEN
2249 WRITE( nounit, fmt = 9999 )'DSBEVX(V,I,' // uplo //
2250 $ ')', iinfo, n, jtype, ioldsd
2251 info = abs( iinfo )
2252 IF( iinfo.LT.0 ) THEN
2253 RETURN
2254 ELSE
2255 result( ntest ) = ulpinv
2256 result( ntest+1 ) = ulpinv
2257 result( ntest+2 ) = ulpinv
2258 GO TO 1370
2259 END IF
2260 END IF
2261*
2262* Do tests 55 and 56 (or +54)
2263*
2264 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2265 $ v, ldu, tau, work, result( ntest ) )
2266*
2267 ntest = ntest + 2
2268*
2269 IF( iuplo.EQ.1 ) THEN
2270 DO 1340 j = 1, n
2271 DO 1330 i = max( 1, j-kd ), j
2272 v( kd+1+i-j, j ) = a( i, j )
2273 1330 CONTINUE
2274 1340 CONTINUE
2275 ELSE
2276 DO 1360 j = 1, n
2277 DO 1350 i = j, min( n, j+kd )
2278 v( 1+i-j, j ) = a( i, j )
2279 1350 CONTINUE
2280 1360 CONTINUE
2281 END IF
2282*
2283 srnamt = 'DSBEVX'
2284 CALL dsbevx( 'N', 'I', uplo, n, kd, v, ldu, u, ldu, vl,
2285 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
2286 $ iwork, iwork( 5*n+1 ), iinfo )
2287 IF( iinfo.NE.0 ) THEN
2288 WRITE( nounit, fmt = 9999 )'DSBEVX(N,I,' // uplo //
2289 $ ')', iinfo, n, jtype, ioldsd
2290 info = abs( iinfo )
2291 IF( iinfo.LT.0 ) THEN
2292 RETURN
2293 ELSE
2294 result( ntest ) = ulpinv
2295 GO TO 1370
2296 END IF
2297 END IF
2298*
2299* Do test 57 (or +54)
2300*
2301 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2302 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2303 IF( n.GT.0 ) THEN
2304 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2305 ELSE
2306 temp3 = zero
2307 END IF
2308 result( ntest ) = ( temp1+temp2 ) /
2309 $ max( unfl, temp3*ulp )
2310*
2311 1370 CONTINUE
2312 ntest = ntest + 1
2313 IF( iuplo.EQ.1 ) THEN
2314 DO 1390 j = 1, n
2315 DO 1380 i = max( 1, j-kd ), j
2316 v( kd+1+i-j, j ) = a( i, j )
2317 1380 CONTINUE
2318 1390 CONTINUE
2319 ELSE
2320 DO 1410 j = 1, n
2321 DO 1400 i = j, min( n, j+kd )
2322 v( 1+i-j, j ) = a( i, j )
2323 1400 CONTINUE
2324 1410 CONTINUE
2325 END IF
2326*
2327 srnamt = 'DSBEVX'
2328 CALL dsbevx( 'V', 'V', uplo, n, kd, v, ldu, u, ldu, vl,
2329 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
2330 $ iwork, iwork( 5*n+1 ), iinfo )
2331 IF( iinfo.NE.0 ) THEN
2332 WRITE( nounit, fmt = 9999 )'DSBEVX(V,V,' // uplo //
2333 $ ')', iinfo, n, jtype, ioldsd
2334 info = abs( iinfo )
2335 IF( iinfo.LT.0 ) THEN
2336 RETURN
2337 ELSE
2338 result( ntest ) = ulpinv
2339 result( ntest+1 ) = ulpinv
2340 result( ntest+2 ) = ulpinv
2341 GO TO 1460
2342 END IF
2343 END IF
2344*
2345* Do tests 58 and 59 (or +54)
2346*
2347 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2348 $ v, ldu, tau, work, result( ntest ) )
2349*
2350 ntest = ntest + 2
2351*
2352 IF( iuplo.EQ.1 ) THEN
2353 DO 1430 j = 1, n
2354 DO 1420 i = max( 1, j-kd ), j
2355 v( kd+1+i-j, j ) = a( i, j )
2356 1420 CONTINUE
2357 1430 CONTINUE
2358 ELSE
2359 DO 1450 j = 1, n
2360 DO 1440 i = j, min( n, j+kd )
2361 v( 1+i-j, j ) = a( i, j )
2362 1440 CONTINUE
2363 1450 CONTINUE
2364 END IF
2365*
2366 srnamt = 'DSBEVX'
2367 CALL dsbevx( 'N', 'V', uplo, n, kd, v, ldu, u, ldu, vl,
2368 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
2369 $ iwork, iwork( 5*n+1 ), iinfo )
2370 IF( iinfo.NE.0 ) THEN
2371 WRITE( nounit, fmt = 9999 )'DSBEVX(N,V,' // uplo //
2372 $ ')', iinfo, n, jtype, ioldsd
2373 info = abs( iinfo )
2374 IF( iinfo.LT.0 ) THEN
2375 RETURN
2376 ELSE
2377 result( ntest ) = ulpinv
2378 GO TO 1460
2379 END IF
2380 END IF
2381*
2382 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2383 result( ntest ) = ulpinv
2384 GO TO 1460
2385 END IF
2386*
2387* Do test 60 (or +54)
2388*
2389 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2390 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2391 IF( n.GT.0 ) THEN
2392 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2393 ELSE
2394 temp3 = zero
2395 END IF
2396 result( ntest ) = ( temp1+temp2 ) /
2397 $ max( unfl, temp3*ulp )
2398*
2399 1460 CONTINUE
2400*
2401* 7) Call DSYEVD
2402*
2403 CALL dlacpy( ' ', n, n, a, lda, v, ldu )
2404*
2405 ntest = ntest + 1
2406 srnamt = 'DSYEVD'
2407 CALL dsyevd( 'V', uplo, n, a, ldu, d1, work, lwedc,
2408 $ iwork, liwedc, iinfo )
2409 IF( iinfo.NE.0 ) THEN
2410 WRITE( nounit, fmt = 9999 )'DSYEVD(V,' // uplo //
2411 $ ')', iinfo, n, jtype, ioldsd
2412 info = abs( iinfo )
2413 IF( iinfo.LT.0 ) THEN
2414 RETURN
2415 ELSE
2416 result( ntest ) = ulpinv
2417 result( ntest+1 ) = ulpinv
2418 result( ntest+2 ) = ulpinv
2419 GO TO 1480
2420 END IF
2421 END IF
2422*
2423* Do tests 61 and 62 (or +54)
2424*
2425 CALL dsyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
2426 $ ldu, tau, work, result( ntest ) )
2427*
2428 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2429*
2430 ntest = ntest + 2
2431 srnamt = 'DSYEVD'
2432 CALL dsyevd( 'N', uplo, n, a, ldu, d3, work, lwedc,
2433 $ iwork, liwedc, iinfo )
2434 IF( iinfo.NE.0 ) THEN
2435 WRITE( nounit, fmt = 9999 )'DSYEVD(N,' // uplo //
2436 $ ')', iinfo, n, jtype, ioldsd
2437 info = abs( iinfo )
2438 IF( iinfo.LT.0 ) THEN
2439 RETURN
2440 ELSE
2441 result( ntest ) = ulpinv
2442 GO TO 1480
2443 END IF
2444 END IF
2445*
2446* Do test 63 (or +54)
2447*
2448 temp1 = zero
2449 temp2 = zero
2450 DO 1470 j = 1, n
2451 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2452 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2453 1470 CONTINUE
2454 result( ntest ) = temp2 / max( unfl,
2455 $ ulp*max( temp1, temp2 ) )
2456*
2457 1480 CONTINUE
2458*
2459* 8) Call DSPEVD.
2460*
2461 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2462*
2463* Load array WORK with the upper or lower triangular
2464* part of the matrix in packed form.
2465*
2466 IF( iuplo.EQ.1 ) THEN
2467 indx = 1
2468 DO 1500 j = 1, n
2469 DO 1490 i = 1, j
2470 work( indx ) = a( i, j )
2471 indx = indx + 1
2472 1490 CONTINUE
2473 1500 CONTINUE
2474 ELSE
2475 indx = 1
2476 DO 1520 j = 1, n
2477 DO 1510 i = j, n
2478 work( indx ) = a( i, j )
2479 indx = indx + 1
2480 1510 CONTINUE
2481 1520 CONTINUE
2482 END IF
2483*
2484 ntest = ntest + 1
2485 srnamt = 'DSPEVD'
2486 CALL dspevd( 'V', uplo, n, work, d1, z, ldu,
2487 $ work( indx ), lwedc-indx+1, iwork, liwedc,
2488 $ iinfo )
2489 IF( iinfo.NE.0 ) THEN
2490 WRITE( nounit, fmt = 9999 )'DSPEVD(V,' // uplo //
2491 $ ')', iinfo, n, jtype, ioldsd
2492 info = abs( iinfo )
2493 IF( iinfo.LT.0 ) THEN
2494 RETURN
2495 ELSE
2496 result( ntest ) = ulpinv
2497 result( ntest+1 ) = ulpinv
2498 result( ntest+2 ) = ulpinv
2499 GO TO 1580
2500 END IF
2501 END IF
2502*
2503* Do tests 64 and 65 (or +54)
2504*
2505 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2506 $ ldu, tau, work, result( ntest ) )
2507*
2508 IF( iuplo.EQ.1 ) THEN
2509 indx = 1
2510 DO 1540 j = 1, n
2511 DO 1530 i = 1, j
2512*
2513 work( indx ) = a( i, j )
2514 indx = indx + 1
2515 1530 CONTINUE
2516 1540 CONTINUE
2517 ELSE
2518 indx = 1
2519 DO 1560 j = 1, n
2520 DO 1550 i = j, n
2521 work( indx ) = a( i, j )
2522 indx = indx + 1
2523 1550 CONTINUE
2524 1560 CONTINUE
2525 END IF
2526*
2527 ntest = ntest + 2
2528 srnamt = 'DSPEVD'
2529 CALL dspevd( 'N', uplo, n, work, d3, z, ldu,
2530 $ work( indx ), lwedc-indx+1, iwork, liwedc,
2531 $ iinfo )
2532 IF( iinfo.NE.0 ) THEN
2533 WRITE( nounit, fmt = 9999 )'DSPEVD(N,' // uplo //
2534 $ ')', iinfo, n, jtype, ioldsd
2535 info = abs( iinfo )
2536 IF( iinfo.LT.0 ) THEN
2537 RETURN
2538 ELSE
2539 result( ntest ) = ulpinv
2540 GO TO 1580
2541 END IF
2542 END IF
2543*
2544* Do test 66 (or +54)
2545*
2546 temp1 = zero
2547 temp2 = zero
2548 DO 1570 j = 1, n
2549 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2550 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2551 1570 CONTINUE
2552 result( ntest ) = temp2 / max( unfl,
2553 $ ulp*max( temp1, temp2 ) )
2554 1580 CONTINUE
2555*
2556* 9) Call DSBEVD.
2557*
2558 IF( jtype.LE.7 ) THEN
2559 kd = 1
2560 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
2561 kd = max( n-1, 0 )
2562 ELSE
2563 kd = ihbw
2564 END IF
2565*
2566* Load array V with the upper or lower triangular part
2567* of the matrix in band form.
2568*
2569 IF( iuplo.EQ.1 ) THEN
2570 DO 1600 j = 1, n
2571 DO 1590 i = max( 1, j-kd ), j
2572 v( kd+1+i-j, j ) = a( i, j )
2573 1590 CONTINUE
2574 1600 CONTINUE
2575 ELSE
2576 DO 1620 j = 1, n
2577 DO 1610 i = j, min( n, j+kd )
2578 v( 1+i-j, j ) = a( i, j )
2579 1610 CONTINUE
2580 1620 CONTINUE
2581 END IF
2582*
2583 ntest = ntest + 1
2584 srnamt = 'DSBEVD'
2585 CALL dsbevd( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
2586 $ lwedc, iwork, liwedc, iinfo )
2587 IF( iinfo.NE.0 ) THEN
2588 WRITE( nounit, fmt = 9999 )'DSBEVD(V,' // uplo //
2589 $ ')', iinfo, n, jtype, ioldsd
2590 info = abs( iinfo )
2591 IF( iinfo.LT.0 ) THEN
2592 RETURN
2593 ELSE
2594 result( ntest ) = ulpinv
2595 result( ntest+1 ) = ulpinv
2596 result( ntest+2 ) = ulpinv
2597 GO TO 1680
2598 END IF
2599 END IF
2600*
2601* Do tests 67 and 68 (or +54)
2602*
2603 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2604 $ ldu, tau, work, result( ntest ) )
2605*
2606 IF( iuplo.EQ.1 ) THEN
2607 DO 1640 j = 1, n
2608 DO 1630 i = max( 1, j-kd ), j
2609 v( kd+1+i-j, j ) = a( i, j )
2610 1630 CONTINUE
2611 1640 CONTINUE
2612 ELSE
2613 DO 1660 j = 1, n
2614 DO 1650 i = j, min( n, j+kd )
2615 v( 1+i-j, j ) = a( i, j )
2616 1650 CONTINUE
2617 1660 CONTINUE
2618 END IF
2619*
2620 ntest = ntest + 2
2621 srnamt = 'DSBEVD'
2622 CALL dsbevd( 'N', uplo, n, kd, v, ldu, d3, z, ldu, work,
2623 $ lwedc, iwork, liwedc, iinfo )
2624 IF( iinfo.NE.0 ) THEN
2625 WRITE( nounit, fmt = 9999 )'DSBEVD(N,' // uplo //
2626 $ ')', iinfo, n, jtype, ioldsd
2627 info = abs( iinfo )
2628 IF( iinfo.LT.0 ) THEN
2629 RETURN
2630 ELSE
2631 result( ntest ) = ulpinv
2632 GO TO 1680
2633 END IF
2634 END IF
2635*
2636* Do test 69 (or +54)
2637*
2638 temp1 = zero
2639 temp2 = zero
2640 DO 1670 j = 1, n
2641 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2642 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2643 1670 CONTINUE
2644 result( ntest ) = temp2 / max( unfl,
2645 $ ulp*max( temp1, temp2 ) )
2646*
2647 1680 CONTINUE
2648*
2649*
2650 CALL dlacpy( ' ', n, n, a, lda, v, ldu )
2651 ntest = ntest + 1
2652 srnamt = 'DSYEVR'
2653 CALL dsyevr( 'V', 'A', uplo, n, a, ldu, vl, vu, il, iu,
2654 $ abstol, m, wa1, z, ldu, iwork, work, lwork,
2655 $ iwork(2*n+1), liwork-2*n, iinfo )
2656 IF( iinfo.NE.0 ) THEN
2657 WRITE( nounit, fmt = 9999 )'DSYEVR(V,A,' // uplo //
2658 $ ')', iinfo, n, jtype, ioldsd
2659 info = abs( iinfo )
2660 IF( iinfo.LT.0 ) THEN
2661 RETURN
2662 ELSE
2663 result( ntest ) = ulpinv
2664 result( ntest+1 ) = ulpinv
2665 result( ntest+2 ) = ulpinv
2666 GO TO 1700
2667 END IF
2668 END IF
2669*
2670* Do tests 70 and 71 (or ... )
2671*
2672 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2673*
2674 CALL dsyt21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
2675 $ ldu, tau, work, result( ntest ) )
2676*
2677 ntest = ntest + 2
2678 srnamt = 'DSYEVR'
2679 CALL dsyevr( 'N', 'A', uplo, n, a, ldu, vl, vu, il, iu,
2680 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2681 $ iwork(2*n+1), liwork-2*n, iinfo )
2682 IF( iinfo.NE.0 ) THEN
2683 WRITE( nounit, fmt = 9999 )'DSYEVR(N,A,' // uplo //
2684 $ ')', iinfo, n, jtype, ioldsd
2685 info = abs( iinfo )
2686 IF( iinfo.LT.0 ) THEN
2687 RETURN
2688 ELSE
2689 result( ntest ) = ulpinv
2690 GO TO 1700
2691 END IF
2692 END IF
2693*
2694* Do test 72 (or ... )
2695*
2696 temp1 = zero
2697 temp2 = zero
2698 DO 1690 j = 1, n
2699 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
2700 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
2701 1690 CONTINUE
2702 result( ntest ) = temp2 / max( unfl,
2703 $ ulp*max( temp1, temp2 ) )
2704*
2705 1700 CONTINUE
2706*
2707 ntest = ntest + 1
2708 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2709 srnamt = 'DSYEVR'
2710 CALL dsyevr( 'V', 'I', uplo, n, a, ldu, vl, vu, il, iu,
2711 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2712 $ iwork(2*n+1), liwork-2*n, iinfo )
2713 IF( iinfo.NE.0 ) THEN
2714 WRITE( nounit, fmt = 9999 )'DSYEVR(V,I,' // uplo //
2715 $ ')', iinfo, n, jtype, ioldsd
2716 info = abs( iinfo )
2717 IF( iinfo.LT.0 ) THEN
2718 RETURN
2719 ELSE
2720 result( ntest ) = ulpinv
2721 result( ntest+1 ) = ulpinv
2722 result( ntest+2 ) = ulpinv
2723 GO TO 1710
2724 END IF
2725 END IF
2726*
2727* Do tests 73 and 74 (or +54)
2728*
2729 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2730*
2731 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2732 $ v, ldu, tau, work, result( ntest ) )
2733*
2734 ntest = ntest + 2
2735 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2736 srnamt = 'DSYEVR'
2737 CALL dsyevr( 'N', 'I', uplo, n, a, ldu, vl, vu, il, iu,
2738 $ abstol, m3, wa3, z, ldu, iwork, work, lwork,
2739 $ iwork(2*n+1), liwork-2*n, iinfo )
2740 IF( iinfo.NE.0 ) THEN
2741 WRITE( nounit, fmt = 9999 )'DSYEVR(N,I,' // uplo //
2742 $ ')', iinfo, n, jtype, ioldsd
2743 info = abs( iinfo )
2744 IF( iinfo.LT.0 ) THEN
2745 RETURN
2746 ELSE
2747 result( ntest ) = ulpinv
2748 GO TO 1710
2749 END IF
2750 END IF
2751*
2752* Do test 75 (or +54)
2753*
2754 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2755 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2756 result( ntest ) = ( temp1+temp2 ) /
2757 $ max( unfl, ulp*temp3 )
2758 1710 CONTINUE
2759*
2760 ntest = ntest + 1
2761 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2762 srnamt = 'DSYEVR'
2763 CALL dsyevr( 'V', 'V', uplo, n, a, ldu, vl, vu, il, iu,
2764 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2765 $ iwork(2*n+1), liwork-2*n, iinfo )
2766 IF( iinfo.NE.0 ) THEN
2767 WRITE( nounit, fmt = 9999 )'DSYEVR(V,V,' // uplo //
2768 $ ')', iinfo, n, jtype, ioldsd
2769 info = abs( iinfo )
2770 IF( iinfo.LT.0 ) THEN
2771 RETURN
2772 ELSE
2773 result( ntest ) = ulpinv
2774 result( ntest+1 ) = ulpinv
2775 result( ntest+2 ) = ulpinv
2776 GO TO 700
2777 END IF
2778 END IF
2779*
2780* Do tests 76 and 77 (or +54)
2781*
2782 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2783*
2784 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2785 $ v, ldu, tau, work, result( ntest ) )
2786*
2787 ntest = ntest + 2
2788 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2789 srnamt = 'DSYEVR'
2790 CALL dsyevr( 'N', 'V', uplo, n, a, ldu, vl, vu, il, iu,
2791 $ abstol, m3, wa3, z, ldu, iwork, work, lwork,
2792 $ iwork(2*n+1), liwork-2*n, iinfo )
2793 IF( iinfo.NE.0 ) THEN
2794 WRITE( nounit, fmt = 9999 )'DSYEVR(N,V,' // uplo //
2795 $ ')', iinfo, n, jtype, ioldsd
2796 info = abs( iinfo )
2797 IF( iinfo.LT.0 ) THEN
2798 RETURN
2799 ELSE
2800 result( ntest ) = ulpinv
2801 GO TO 700
2802 END IF
2803 END IF
2804*
2805 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2806 result( ntest ) = ulpinv
2807 GO TO 700
2808 END IF
2809*
2810* Do test 78 (or +54)
2811*
2812 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2813 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2814 IF( n.GT.0 ) THEN
2815 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2816 ELSE
2817 temp3 = zero
2818 END IF
2819 result( ntest ) = ( temp1+temp2 ) /
2820 $ max( unfl, temp3*ulp )
2821*
2822 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2823*
2824 1720 CONTINUE
2825*
2826* End of Loop -- Check for RESULT(j) > THRESH
2827*
2828 ntestt = ntestt + ntest
2829*
2830 CALL dlafts( 'DST', n, n, jtype, ntest, result, ioldsd,
2831 $ thresh, nounit, nerrs )
2832*
2833 1730 CONTINUE
2834 1740 CONTINUE
2835*
2836* Summary
2837*
2838 CALL alasvm( 'DST', nounit, nerrs, ntestt, 0 )
2839*
2840 9999 FORMAT( ' DDRVST: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
2841 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2842*
2843 RETURN
2844*
2845* End of DDRVST
2846*
dspevd
subroutine dspevd(jobz, uplo, n, ap, w, z, ldz, work, lwork, iwork, liwork, info)
DSPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition dspevd.f:178
dsbevd
subroutine dsbevd(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, iwork, liwork, info)
DSBEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition dsbevd.f:193
dsbevx
subroutine dsbevx(jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
DSBEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition dsbevx.f:265
dspev
subroutine dspev(jobz, uplo, n, ap, w, z, ldz, work, info)
DSPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition dspev.f:130
dstevx
subroutine dstevx(jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
DSTEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition dstevx.f:227
dstev
subroutine dstev(jobz, n, d, e, z, ldz, work, info)
DSTEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition dstev.f:116
dspevx
subroutine dspevx(jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
DSPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition dspevx.f:234
dsbev
subroutine dsbev(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, info)
DSBEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition dsbev.f:146
dstevr
subroutine dstevr(jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
DSTEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition dstevr.f:304
dstevd
subroutine dstevd(jobz, n, d, e, z, ldz, work, lwork, iwork, liwork, info)
DSTEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition dstevd.f:163
dsyevd
subroutine dsyevd(jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork, info)
DSYEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition dsyevd.f:185
dsyev
subroutine dsyev(jobz, uplo, n, a, lda, w, work, lwork, info)
DSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition dsyev.f:132
dsyevr
subroutine dsyevr(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
DSYEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition dsyevr.f:334
dsyevx
subroutine dsyevx(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, iwork, ifail, info)
DSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition dsyevx.f:253
dsyt22
subroutine dsyt22(itype, uplo, n, m, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, result)
DSYT22
Definition dsyt22.f:157

◆ ddrvst2stg()

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

DDRVST2STG

Purpose:
!>
!>      DDRVST2STG  checks the symmetric eigenvalue problem drivers.
!>
!>              DSTEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix.
!>
!>              DSTEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix.
!>
!>              DSTEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              DSYEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix.
!>
!>              DSYEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix.
!>
!>              DSYEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              DSPEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage.
!>
!>              DSPEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage.
!>
!>              DSBEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix.
!>
!>              DSBEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix.
!>
!>              DSYEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix using
!>              a divide and conquer algorithm.
!>
!>              DSPEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage, using a divide and conquer algorithm.
!>
!>              DSBEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix,
!>              using a divide and conquer algorithm.
!>
!>      When DDRVST2STG 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 eigenvalues
!>           1, ..., ULP  and random signs.
!>           (ULP = (first number larger than 1) - 1 )
!>      (4)  A diagonal matrix with geometrically spaced eigenvalues
!>           1, ..., ULP  and random signs.
!>      (5)  A diagonal matrix with  eigenvalues
!>           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 orthogonal 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 orthogonal 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 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) 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,
!>          DDRVST2STG 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, DDRVST2STG
!>          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 DDRVST2STG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       DOUBLE PRECISION array, dimension (LDA , max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  D1      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by DSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>          Modified.
!>
!>  D2      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by DSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>          Modified.
!>
!>  D3      DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues of A, as computed by DSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>          Modified.
!>
!>  D4      DOUBLE PRECISION array, dimension
!>
!>  EVEIGS  DOUBLE PRECISION array, dimension (max(NN))
!>          The eigenvalues as computed by DSTEV('N', ... )
!>          (I reserve the right to change this to the output of
!>          whichever algorithm computes the most accurate eigenvalues).
!>
!>  WA1     DOUBLE PRECISION array, dimension
!>
!>  WA2     DOUBLE PRECISION array, dimension
!>
!>  WA3     DOUBLE PRECISION array, dimension
!>
!>  U       DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The orthogonal matrix computed by DSYTRD + DORGTR.
!>          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       DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The Housholder vectors computed by DSYTRD in reducing A to
!>          tridiagonal form.
!>          Modified.
!>
!>  TAU     DOUBLE PRECISION array, dimension (max(NN))
!>          The Householder factors computed by DSYTRD in reducing A
!>          to tridiagonal form.
!>          Modified.
!>
!>  Z       DOUBLE PRECISION array, dimension (LDU, max(NN))
!>          The orthogonal matrix of eigenvectors computed by DSTEQR,
!>          DPTEQR, and DSTEIN.
!>          Modified.
!>
!>  WORK    DOUBLE PRECISION array, dimension (LWORK)
!>          Workspace.
!>          Modified.
!>
!>  LWORK   INTEGER
!>          The number of entries in WORK.  This must be at least
!>          1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2
!>          where Nmax = max( NN(j), 2 ) and lg = log base 2.
!>          Not modified.
!>
!>  IWORK   INTEGER array,
!>             dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax )
!>          where Nmax = max( NN(j), 2 ) and lg = log base 2.
!>          Workspace.
!>          Modified.
!>
!>  RESULT  DOUBLE PRECISION array, dimension (105)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>          Modified.
!>
!>  INFO    INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -16: LDU < 1 or LDU < NMAX.
!>          -21: LWORK too small.
!>          If  DLATMR, DLATMS, DSYTRD, DORGTR, DSTEQR, DSTERF,
!>              or DORMTR returns an error code, the
!>              absolute value of it is returned.
!>          Modified.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far (computed by DLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
!>     The tests performed are:                 Routine tested
!>    1= | A - U S U' | / ( |A| n ulp )         DSTEV('V', ... )
!>    2= | I - U U' | / ( n ulp )               DSTEV('V', ... )
!>    3= |D(with Z) - D(w/o Z)| / (|D| ulp)     DSTEV('N', ... )
!>    4= | A - U S U' | / ( |A| n ulp )         DSTEVX('V','A', ... )
!>    5= | I - U U' | / ( n ulp )               DSTEVX('V','A', ... )
!>    6= |D(with Z) - EVEIGS| / (|D| ulp)       DSTEVX('N','A', ... )
!>    7= | A - U S U' | / ( |A| n ulp )         DSTEVR('V','A', ... )
!>    8= | I - U U' | / ( n ulp )               DSTEVR('V','A', ... )
!>    9= |D(with Z) - EVEIGS| / (|D| ulp)       DSTEVR('N','A', ... )
!>    10= | A - U S U' | / ( |A| n ulp )        DSTEVX('V','I', ... )
!>    11= | I - U U' | / ( n ulp )              DSTEVX('V','I', ... )
!>    12= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSTEVX('N','I', ... )
!>    13= | A - U S U' | / ( |A| n ulp )        DSTEVX('V','V', ... )
!>    14= | I - U U' | / ( n ulp )              DSTEVX('V','V', ... )
!>    15= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSTEVX('N','V', ... )
!>    16= | A - U S U' | / ( |A| n ulp )        DSTEVD('V', ... )
!>    17= | I - U U' | / ( n ulp )              DSTEVD('V', ... )
!>    18= |D(with Z) - EVEIGS| / (|D| ulp)      DSTEVD('N', ... )
!>    19= | A - U S U' | / ( |A| n ulp )        DSTEVR('V','I', ... )
!>    20= | I - U U' | / ( n ulp )              DSTEVR('V','I', ... )
!>    21= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSTEVR('N','I', ... )
!>    22= | A - U S U' | / ( |A| n ulp )        DSTEVR('V','V', ... )
!>    23= | I - U U' | / ( n ulp )              DSTEVR('V','V', ... )
!>    24= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSTEVR('N','V', ... )
!>
!>    25= | A - U S U' | / ( |A| n ulp )        DSYEV('L','V', ... )
!>    26= | I - U U' | / ( n ulp )              DSYEV('L','V', ... )
!>    27= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEV_2STAGE('L','N', ... )
!>    28= | A - U S U' | / ( |A| n ulp )        DSYEVX('L','V','A', ... )
!>    29= | I - U U' | / ( n ulp )              DSYEVX('L','V','A', ... )
!>    30= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVX_2STAGE('L','N','A', ... )
!>    31= | A - U S U' | / ( |A| n ulp )        DSYEVX('L','V','I', ... )
!>    32= | I - U U' | / ( n ulp )              DSYEVX('L','V','I', ... )
!>    33= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVX_2STAGE('L','N','I', ... )
!>    34= | A - U S U' | / ( |A| n ulp )        DSYEVX('L','V','V', ... )
!>    35= | I - U U' | / ( n ulp )              DSYEVX('L','V','V', ... )
!>    36= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVX_2STAGE('L','N','V', ... )
!>    37= | A - U S U' | / ( |A| n ulp )        DSPEV('L','V', ... )
!>    38= | I - U U' | / ( n ulp )              DSPEV('L','V', ... )
!>    39= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEV('L','N', ... )
!>    40= | A - U S U' | / ( |A| n ulp )        DSPEVX('L','V','A', ... )
!>    41= | I - U U' | / ( n ulp )              DSPEVX('L','V','A', ... )
!>    42= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVX('L','N','A', ... )
!>    43= | A - U S U' | / ( |A| n ulp )        DSPEVX('L','V','I', ... )
!>    44= | I - U U' | / ( n ulp )              DSPEVX('L','V','I', ... )
!>    45= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVX('L','N','I', ... )
!>    46= | A - U S U' | / ( |A| n ulp )        DSPEVX('L','V','V', ... )
!>    47= | I - U U' | / ( n ulp )              DSPEVX('L','V','V', ... )
!>    48= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVX('L','N','V', ... )
!>    49= | A - U S U' | / ( |A| n ulp )        DSBEV('L','V', ... )
!>    50= | I - U U' | / ( n ulp )              DSBEV('L','V', ... )
!>    51= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEV_2STAGE('L','N', ... )
!>    52= | A - U S U' | / ( |A| n ulp )        DSBEVX('L','V','A', ... )
!>    53= | I - U U' | / ( n ulp )              DSBEVX('L','V','A', ... )
!>    54= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVX_2STAGE('L','N','A', ... )
!>    55= | A - U S U' | / ( |A| n ulp )        DSBEVX('L','V','I', ... )
!>    56= | I - U U' | / ( n ulp )              DSBEVX('L','V','I', ... )
!>    57= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVX_2STAGE('L','N','I', ... )
!>    58= | A - U S U' | / ( |A| n ulp )        DSBEVX('L','V','V', ... )
!>    59= | I - U U' | / ( n ulp )              DSBEVX('L','V','V', ... )
!>    60= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVX_2STAGE('L','N','V', ... )
!>    61= | A - U S U' | / ( |A| n ulp )        DSYEVD('L','V', ... )
!>    62= | I - U U' | / ( n ulp )              DSYEVD('L','V', ... )
!>    63= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVD_2STAGE('L','N', ... )
!>    64= | A - U S U' | / ( |A| n ulp )        DSPEVD('L','V', ... )
!>    65= | I - U U' | / ( n ulp )              DSPEVD('L','V', ... )
!>    66= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVD('L','N', ... )
!>    67= | A - U S U' | / ( |A| n ulp )        DSBEVD('L','V', ... )
!>    68= | I - U U' | / ( n ulp )              DSBEVD('L','V', ... )
!>    69= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVD_2STAGE('L','N', ... )
!>    70= | A - U S U' | / ( |A| n ulp )        DSYEVR('L','V','A', ... )
!>    71= | I - U U' | / ( n ulp )              DSYEVR('L','V','A', ... )
!>    72= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVR_2STAGE('L','N','A', ... )
!>    73= | A - U S U' | / ( |A| n ulp )        DSYEVR('L','V','I', ... )
!>    74= | I - U U' | / ( n ulp )              DSYEVR('L','V','I', ... )
!>    75= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVR_2STAGE('L','N','I', ... )
!>    76= | A - U S U' | / ( |A| n ulp )        DSYEVR('L','V','V', ... )
!>    77= | I - U U' | / ( n ulp )              DSYEVR('L','V','V', ... )
!>    78= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSYEVR_2STAGE('L','N','V', ... )
!>
!>    Tests 25 through 78 are repeated (as tests 79 through 132)
!>    with UPLO='U'
!>
!>    To be added in 1999
!>
!>    79= | A - U S U' | / ( |A| n ulp )        DSPEVR('L','V','A', ... )
!>    80= | I - U U' | / ( n ulp )              DSPEVR('L','V','A', ... )
!>    81= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVR('L','N','A', ... )
!>    82= | A - U S U' | / ( |A| n ulp )        DSPEVR('L','V','I', ... )
!>    83= | I - U U' | / ( n ulp )              DSPEVR('L','V','I', ... )
!>    84= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVR('L','N','I', ... )
!>    85= | A - U S U' | / ( |A| n ulp )        DSPEVR('L','V','V', ... )
!>    86= | I - U U' | / ( n ulp )              DSPEVR('L','V','V', ... )
!>    87= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSPEVR('L','N','V', ... )
!>    88= | A - U S U' | / ( |A| n ulp )        DSBEVR('L','V','A', ... )
!>    89= | I - U U' | / ( n ulp )              DSBEVR('L','V','A', ... )
!>    90= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVR('L','N','A', ... )
!>    91= | A - U S U' | / ( |A| n ulp )        DSBEVR('L','V','I', ... )
!>    92= | I - U U' | / ( n ulp )              DSBEVR('L','V','I', ... )
!>    93= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVR('L','N','I', ... )
!>    94= | A - U S U' | / ( |A| n ulp )        DSBEVR('L','V','V', ... )
!>    95= | I - U U' | / ( n ulp )              DSBEVR('L','V','V', ... )
!>    96= |D(with Z) - D(w/o Z)| / (|D| ulp)    DSBEVR('L','N','V', ... )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 449 of file ddrvst2stg.f.

453*
454* -- LAPACK test routine --
455* -- LAPACK is a software package provided by Univ. of Tennessee, --
456* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
457*
458* .. Scalar Arguments ..
459 INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
460 $ NTYPES
461 DOUBLE PRECISION THRESH
462* ..
463* .. Array Arguments ..
464 LOGICAL DOTYPE( * )
465 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
466 DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ),
467 $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ),
468 $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ),
469 $ WA3( * ), WORK( * ), Z( LDU, * )
470* ..
471*
472* =====================================================================
473*
474* .. Parameters ..
475 DOUBLE PRECISION ZERO, ONE, TWO, TEN
476 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
477 $ ten = 10.0d0 )
478 DOUBLE PRECISION HALF
479 parameter( half = 0.5d0 )
480 INTEGER MAXTYP
481 parameter( maxtyp = 18 )
482* ..
483* .. Local Scalars ..
484 LOGICAL BADNN
485 CHARACTER UPLO
486 INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW,
487 $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL,
488 $ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2,
489 $ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
490 $ NTESTT
491 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
492 $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL,
493 $ VL, VU
494* ..
495* .. Local Arrays ..
496 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
497 $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
498 $ KTYPE( MAXTYP )
499* ..
500* .. External Functions ..
501 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
502 EXTERNAL dlamch, dlarnd, dsxt1
503* ..
504* .. External Subroutines ..
505 EXTERNAL alasvm, dlabad, dlacpy, dlafts, dlaset, dlatmr,
506 $ dlatms, dsbev, dsbevd, dsbevx, dspev, dspevd,
507 $ dspevx, dstev, dstevd, dstevr, dstevx, dstt21,
508 $ dstt22, dsyev, dsyevd, dsyevr, dsyevx, dsyt21,
509 $ dsyevd_2stage, dsyevr_2stage, dsyevx_2stage,
510 $ dsyev_2stage, dsbev_2stage, dsbevd_2stage,
511 $ dsbevx_2stage, dsytrd_2stage, dsytrd_sy2sb,
512 $ dsytrd_sb2st, dsyt22, xerbla
513* ..
514* .. Scalars in Common ..
515 CHARACTER*32 SRNAMT
516* ..
517* .. Common blocks ..
518 COMMON / srnamc / srnamt
519* ..
520* .. Intrinsic Functions ..
521 INTRINSIC abs, dble, int, log, max, min, sqrt
522* ..
523* .. Data statements ..
524 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 3*9 /
525 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
526 $ 2, 3, 1, 2, 3 /
527 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
528 $ 0, 0, 4, 4, 4 /
529* ..
530* .. Executable Statements ..
531*
532* Keep ftrnchek happy
533*
534 vl = zero
535 vu = zero
536*
537* 1) Check for errors
538*
539 ntestt = 0
540 info = 0
541*
542 badnn = .false.
543 nmax = 1
544 DO 10 j = 1, nsizes
545 nmax = max( nmax, nn( j ) )
546 IF( nn( j ).LT.0 )
547 $ badnn = .true.
548 10 CONTINUE
549*
550* Check for errors
551*
552 IF( nsizes.LT.0 ) THEN
553 info = -1
554 ELSE IF( badnn ) THEN
555 info = -2
556 ELSE IF( ntypes.LT.0 ) THEN
557 info = -3
558 ELSE IF( lda.LT.nmax ) THEN
559 info = -9
560 ELSE IF( ldu.LT.nmax ) THEN
561 info = -16
562 ELSE IF( 2*max( 2, nmax )**2.GT.lwork ) THEN
563 info = -21
564 END IF
565*
566 IF( info.NE.0 ) THEN
567 CALL xerbla( 'DDRVST2STG', -info )
568 RETURN
569 END IF
570*
571* Quick return if nothing to do
572*
573 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
574 $ RETURN
575*
576* More Important constants
577*
578 unfl = dlamch( 'Safe minimum' )
579 ovfl = dlamch( 'Overflow' )
580 CALL dlabad( unfl, ovfl )
581 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
582 ulpinv = one / ulp
583 rtunfl = sqrt( unfl )
584 rtovfl = sqrt( ovfl )
585*
586* Loop over sizes, types
587*
588 DO 20 i = 1, 4
589 iseed2( i ) = iseed( i )
590 iseed3( i ) = iseed( i )
591 20 CONTINUE
592*
593 nerrs = 0
594 nmats = 0
595*
596*
597 DO 1740 jsize = 1, nsizes
598 n = nn( jsize )
599 IF( n.GT.0 ) THEN
600 lgn = int( log( dble( n ) ) / log( two ) )
601 IF( 2**lgn.LT.n )
602 $ lgn = lgn + 1
603 IF( 2**lgn.LT.n )
604 $ lgn = lgn + 1
605 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
606c LIWEDC = 6 + 6*N + 5*N*LGN
607 liwedc = 3 + 5*n
608 ELSE
609 lwedc = 9
610c LIWEDC = 12
611 liwedc = 8
612 END IF
613 aninv = one / dble( max( 1, n ) )
614*
615 IF( nsizes.NE.1 ) THEN
616 mtypes = min( maxtyp, ntypes )
617 ELSE
618 mtypes = min( maxtyp+1, ntypes )
619 END IF
620*
621 DO 1730 jtype = 1, mtypes
622*
623 IF( .NOT.dotype( jtype ) )
624 $ GO TO 1730
625 nmats = nmats + 1
626 ntest = 0
627*
628 DO 30 j = 1, 4
629 ioldsd( j ) = iseed( j )
630 30 CONTINUE
631*
632* 2) Compute "A"
633*
634* Control parameters:
635*
636* KMAGN KMODE KTYPE
637* =1 O(1) clustered 1 zero
638* =2 large clustered 2 identity
639* =3 small exponential (none)
640* =4 arithmetic diagonal, (w/ eigenvalues)
641* =5 random log symmetric, w/ eigenvalues
642* =6 random (none)
643* =7 random diagonal
644* =8 random symmetric
645* =9 band symmetric, w/ eigenvalues
646*
647 IF( mtypes.GT.maxtyp )
648 $ GO TO 110
649*
650 itype = ktype( jtype )
651 imode = kmode( jtype )
652*
653* Compute norm
654*
655 GO TO ( 40, 50, 60 )kmagn( jtype )
656*
657 40 CONTINUE
658 anorm = one
659 GO TO 70
660*
661 50 CONTINUE
662 anorm = ( rtovfl*ulp )*aninv
663 GO TO 70
664*
665 60 CONTINUE
666 anorm = rtunfl*n*ulpinv
667 GO TO 70
668*
669 70 CONTINUE
670*
671 CALL dlaset( 'Full', lda, n, zero, zero, a, lda )
672 iinfo = 0
673 cond = ulpinv
674*
675* Special Matrices -- Identity & Jordan block
676*
677* Zero
678*
679 IF( itype.EQ.1 ) THEN
680 iinfo = 0
681*
682 ELSE IF( itype.EQ.2 ) THEN
683*
684* Identity
685*
686 DO 80 jcol = 1, n
687 a( jcol, jcol ) = anorm
688 80 CONTINUE
689*
690 ELSE IF( itype.EQ.4 ) THEN
691*
692* Diagonal Matrix, [Eigen]values Specified
693*
694 CALL dlatms( n, n, 'S', iseed, 'S', work, imode, cond,
695 $ anorm, 0, 0, 'N', a, lda, work( n+1 ),
696 $ iinfo )
697*
698 ELSE IF( itype.EQ.5 ) THEN
699*
700* Symmetric, eigenvalues specified
701*
702 CALL dlatms( n, n, 'S', iseed, 'S', work, imode, cond,
703 $ anorm, n, n, 'N', a, lda, work( n+1 ),
704 $ iinfo )
705*
706 ELSE IF( itype.EQ.7 ) THEN
707*
708* Diagonal, random eigenvalues
709*
710 idumma( 1 ) = 1
711 CALL dlatmr( n, n, 'S', iseed, 'S', work, 6, one, one,
712 $ 'T', 'N', work( n+1 ), 1, one,
713 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
714 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
715*
716 ELSE IF( itype.EQ.8 ) THEN
717*
718* Symmetric, random eigenvalues
719*
720 idumma( 1 ) = 1
721 CALL dlatmr( n, n, 'S', iseed, 'S', work, 6, one, one,
722 $ 'T', 'N', work( n+1 ), 1, one,
723 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
724 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
725*
726 ELSE IF( itype.EQ.9 ) THEN
727*
728* Symmetric banded, eigenvalues specified
729*
730 ihbw = int( ( n-1 )*dlarnd( 1, iseed3 ) )
731 CALL dlatms( n, n, 'S', iseed, 'S', work, imode, cond,
732 $ anorm, ihbw, ihbw, 'Z', u, ldu, work( n+1 ),
733 $ iinfo )
734*
735* Store as dense matrix for most routines.
736*
737 CALL dlaset( 'Full', lda, n, zero, zero, a, lda )
738 DO 100 idiag = -ihbw, ihbw
739 irow = ihbw - idiag + 1
740 j1 = max( 1, idiag+1 )
741 j2 = min( n, n+idiag )
742 DO 90 j = j1, j2
743 i = j - idiag
744 a( i, j ) = u( irow, j )
745 90 CONTINUE
746 100 CONTINUE
747 ELSE
748 iinfo = 1
749 END IF
750*
751 IF( iinfo.NE.0 ) THEN
752 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
753 $ ioldsd
754 info = abs( iinfo )
755 RETURN
756 END IF
757*
758 110 CONTINUE
759*
760 abstol = unfl + unfl
761 IF( n.LE.1 ) THEN
762 il = 1
763 iu = n
764 ELSE
765 il = 1 + int( ( n-1 )*dlarnd( 1, iseed2 ) )
766 iu = 1 + int( ( n-1 )*dlarnd( 1, iseed2 ) )
767 IF( il.GT.iu ) THEN
768 itemp = il
769 il = iu
770 iu = itemp
771 END IF
772 END IF
773*
774* 3) If matrix is tridiagonal, call DSTEV and DSTEVX.
775*
776 IF( jtype.LE.7 ) THEN
777 ntest = 1
778 DO 120 i = 1, n
779 d1( i ) = dble( a( i, i ) )
780 120 CONTINUE
781 DO 130 i = 1, n - 1
782 d2( i ) = dble( a( i+1, i ) )
783 130 CONTINUE
784 srnamt = 'DSTEV'
785 CALL dstev( 'V', n, d1, d2, z, ldu, work, iinfo )
786 IF( iinfo.NE.0 ) THEN
787 WRITE( nounit, fmt = 9999 )'DSTEV(V)', iinfo, n,
788 $ jtype, ioldsd
789 info = abs( iinfo )
790 IF( iinfo.LT.0 ) THEN
791 RETURN
792 ELSE
793 result( 1 ) = ulpinv
794 result( 2 ) = ulpinv
795 result( 3 ) = ulpinv
796 GO TO 180
797 END IF
798 END IF
799*
800* Do tests 1 and 2.
801*
802 DO 140 i = 1, n
803 d3( i ) = dble( a( i, i ) )
804 140 CONTINUE
805 DO 150 i = 1, n - 1
806 d4( i ) = dble( a( i+1, i ) )
807 150 CONTINUE
808 CALL dstt21( n, 0, d3, d4, d1, d2, z, ldu, work,
809 $ result( 1 ) )
810*
811 ntest = 3
812 DO 160 i = 1, n - 1
813 d4( i ) = dble( a( i+1, i ) )
814 160 CONTINUE
815 srnamt = 'DSTEV'
816 CALL dstev( 'N', n, d3, d4, z, ldu, work, iinfo )
817 IF( iinfo.NE.0 ) THEN
818 WRITE( nounit, fmt = 9999 )'DSTEV(N)', iinfo, n,
819 $ jtype, ioldsd
820 info = abs( iinfo )
821 IF( iinfo.LT.0 ) THEN
822 RETURN
823 ELSE
824 result( 3 ) = ulpinv
825 GO TO 180
826 END IF
827 END IF
828*
829* Do test 3.
830*
831 temp1 = zero
832 temp2 = zero
833 DO 170 j = 1, n
834 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
835 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
836 170 CONTINUE
837 result( 3 ) = temp2 / max( unfl,
838 $ ulp*max( temp1, temp2 ) )
839*
840 180 CONTINUE
841*
842 ntest = 4
843 DO 190 i = 1, n
844 eveigs( i ) = d3( i )
845 d1( i ) = dble( a( i, i ) )
846 190 CONTINUE
847 DO 200 i = 1, n - 1
848 d2( i ) = dble( a( i+1, i ) )
849 200 CONTINUE
850 srnamt = 'DSTEVX'
851 CALL dstevx( 'V', 'A', n, d1, d2, vl, vu, il, iu, abstol,
852 $ m, wa1, z, ldu, work, iwork, iwork( 5*n+1 ),
853 $ iinfo )
854 IF( iinfo.NE.0 ) THEN
855 WRITE( nounit, fmt = 9999 )'DSTEVX(V,A)', iinfo, n,
856 $ jtype, ioldsd
857 info = abs( iinfo )
858 IF( iinfo.LT.0 ) THEN
859 RETURN
860 ELSE
861 result( 4 ) = ulpinv
862 result( 5 ) = ulpinv
863 result( 6 ) = ulpinv
864 GO TO 250
865 END IF
866 END IF
867 IF( n.GT.0 ) THEN
868 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
869 ELSE
870 temp3 = zero
871 END IF
872*
873* Do tests 4 and 5.
874*
875 DO 210 i = 1, n
876 d3( i ) = dble( a( i, i ) )
877 210 CONTINUE
878 DO 220 i = 1, n - 1
879 d4( i ) = dble( a( i+1, i ) )
880 220 CONTINUE
881 CALL dstt21( n, 0, d3, d4, wa1, d2, z, ldu, work,
882 $ result( 4 ) )
883*
884 ntest = 6
885 DO 230 i = 1, n - 1
886 d4( i ) = dble( a( i+1, i ) )
887 230 CONTINUE
888 srnamt = 'DSTEVX'
889 CALL dstevx( 'N', 'A', n, d3, d4, vl, vu, il, iu, abstol,
890 $ m2, wa2, z, ldu, work, iwork,
891 $ iwork( 5*n+1 ), iinfo )
892 IF( iinfo.NE.0 ) THEN
893 WRITE( nounit, fmt = 9999 )'DSTEVX(N,A)', iinfo, n,
894 $ jtype, ioldsd
895 info = abs( iinfo )
896 IF( iinfo.LT.0 ) THEN
897 RETURN
898 ELSE
899 result( 6 ) = ulpinv
900 GO TO 250
901 END IF
902 END IF
903*
904* Do test 6.
905*
906 temp1 = zero
907 temp2 = zero
908 DO 240 j = 1, n
909 temp1 = max( temp1, abs( wa2( j ) ),
910 $ abs( eveigs( j ) ) )
911 temp2 = max( temp2, abs( wa2( j )-eveigs( j ) ) )
912 240 CONTINUE
913 result( 6 ) = temp2 / max( unfl,
914 $ ulp*max( temp1, temp2 ) )
915*
916 250 CONTINUE
917*
918 ntest = 7
919 DO 260 i = 1, n
920 d1( i ) = dble( a( i, i ) )
921 260 CONTINUE
922 DO 270 i = 1, n - 1
923 d2( i ) = dble( a( i+1, i ) )
924 270 CONTINUE
925 srnamt = 'DSTEVR'
926 CALL dstevr( 'V', 'A', n, d1, d2, vl, vu, il, iu, abstol,
927 $ m, wa1, z, ldu, iwork, work, lwork,
928 $ iwork(2*n+1), liwork-2*n, iinfo )
929 IF( iinfo.NE.0 ) THEN
930 WRITE( nounit, fmt = 9999 )'DSTEVR(V,A)', iinfo, n,
931 $ jtype, ioldsd
932 info = abs( iinfo )
933 IF( iinfo.LT.0 ) THEN
934 RETURN
935 ELSE
936 result( 7 ) = ulpinv
937 result( 8 ) = ulpinv
938 GO TO 320
939 END IF
940 END IF
941 IF( n.GT.0 ) THEN
942 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
943 ELSE
944 temp3 = zero
945 END IF
946*
947* Do tests 7 and 8.
948*
949 DO 280 i = 1, n
950 d3( i ) = dble( a( i, i ) )
951 280 CONTINUE
952 DO 290 i = 1, n - 1
953 d4( i ) = dble( a( i+1, i ) )
954 290 CONTINUE
955 CALL dstt21( n, 0, d3, d4, wa1, d2, z, ldu, work,
956 $ result( 7 ) )
957*
958 ntest = 9
959 DO 300 i = 1, n - 1
960 d4( i ) = dble( a( i+1, i ) )
961 300 CONTINUE
962 srnamt = 'DSTEVR'
963 CALL dstevr( 'N', 'A', n, d3, d4, vl, vu, il, iu, abstol,
964 $ m2, wa2, z, ldu, iwork, work, lwork,
965 $ iwork(2*n+1), liwork-2*n, iinfo )
966 IF( iinfo.NE.0 ) THEN
967 WRITE( nounit, fmt = 9999 )'DSTEVR(N,A)', iinfo, n,
968 $ jtype, ioldsd
969 info = abs( iinfo )
970 IF( iinfo.LT.0 ) THEN
971 RETURN
972 ELSE
973 result( 9 ) = ulpinv
974 GO TO 320
975 END IF
976 END IF
977*
978* Do test 9.
979*
980 temp1 = zero
981 temp2 = zero
982 DO 310 j = 1, n
983 temp1 = max( temp1, abs( wa2( j ) ),
984 $ abs( eveigs( j ) ) )
985 temp2 = max( temp2, abs( wa2( j )-eveigs( j ) ) )
986 310 CONTINUE
987 result( 9 ) = temp2 / max( unfl,
988 $ ulp*max( temp1, temp2 ) )
989*
990 320 CONTINUE
991*
992*
993 ntest = 10
994 DO 330 i = 1, n
995 d1( i ) = dble( a( i, i ) )
996 330 CONTINUE
997 DO 340 i = 1, n - 1
998 d2( i ) = dble( a( i+1, i ) )
999 340 CONTINUE
1000 srnamt = 'DSTEVX'
1001 CALL dstevx( 'V', 'I', n, d1, d2, vl, vu, il, iu, abstol,
1002 $ m2, wa2, z, ldu, work, iwork,
1003 $ iwork( 5*n+1 ), iinfo )
1004 IF( iinfo.NE.0 ) THEN
1005 WRITE( nounit, fmt = 9999 )'DSTEVX(V,I)', iinfo, n,
1006 $ jtype, ioldsd
1007 info = abs( iinfo )
1008 IF( iinfo.LT.0 ) THEN
1009 RETURN
1010 ELSE
1011 result( 10 ) = ulpinv
1012 result( 11 ) = ulpinv
1013 result( 12 ) = ulpinv
1014 GO TO 380
1015 END IF
1016 END IF
1017*
1018* Do tests 10 and 11.
1019*
1020 DO 350 i = 1, n
1021 d3( i ) = dble( a( i, i ) )
1022 350 CONTINUE
1023 DO 360 i = 1, n - 1
1024 d4( i ) = dble( a( i+1, i ) )
1025 360 CONTINUE
1026 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1027 $ max( 1, m2 ), result( 10 ) )
1028*
1029*
1030 ntest = 12
1031 DO 370 i = 1, n - 1
1032 d4( i ) = dble( a( i+1, i ) )
1033 370 CONTINUE
1034 srnamt = 'DSTEVX'
1035 CALL dstevx( 'N', 'I', n, d3, d4, vl, vu, il, iu, abstol,
1036 $ m3, wa3, z, ldu, work, iwork,
1037 $ iwork( 5*n+1 ), iinfo )
1038 IF( iinfo.NE.0 ) THEN
1039 WRITE( nounit, fmt = 9999 )'DSTEVX(N,I)', iinfo, n,
1040 $ jtype, ioldsd
1041 info = abs( iinfo )
1042 IF( iinfo.LT.0 ) THEN
1043 RETURN
1044 ELSE
1045 result( 12 ) = ulpinv
1046 GO TO 380
1047 END IF
1048 END IF
1049*
1050* Do test 12.
1051*
1052 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1053 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1054 result( 12 ) = ( temp1+temp2 ) / max( unfl, ulp*temp3 )
1055*
1056 380 CONTINUE
1057*
1058 ntest = 12
1059 IF( n.GT.0 ) THEN
1060 IF( il.NE.1 ) THEN
1061 vl = wa1( il ) - max( half*
1062 $ ( wa1( il )-wa1( il-1 ) ), ten*ulp*temp3,
1063 $ ten*rtunfl )
1064 ELSE
1065 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1066 $ ten*ulp*temp3, ten*rtunfl )
1067 END IF
1068 IF( iu.NE.n ) THEN
1069 vu = wa1( iu ) + max( half*
1070 $ ( wa1( iu+1 )-wa1( iu ) ), ten*ulp*temp3,
1071 $ ten*rtunfl )
1072 ELSE
1073 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1074 $ ten*ulp*temp3, ten*rtunfl )
1075 END IF
1076 ELSE
1077 vl = zero
1078 vu = one
1079 END IF
1080*
1081 DO 390 i = 1, n
1082 d1( i ) = dble( a( i, i ) )
1083 390 CONTINUE
1084 DO 400 i = 1, n - 1
1085 d2( i ) = dble( a( i+1, i ) )
1086 400 CONTINUE
1087 srnamt = 'DSTEVX'
1088 CALL dstevx( 'V', 'V', n, d1, d2, vl, vu, il, iu, abstol,
1089 $ m2, wa2, z, ldu, work, iwork,
1090 $ iwork( 5*n+1 ), iinfo )
1091 IF( iinfo.NE.0 ) THEN
1092 WRITE( nounit, fmt = 9999 )'DSTEVX(V,V)', iinfo, n,
1093 $ jtype, ioldsd
1094 info = abs( iinfo )
1095 IF( iinfo.LT.0 ) THEN
1096 RETURN
1097 ELSE
1098 result( 13 ) = ulpinv
1099 result( 14 ) = ulpinv
1100 result( 15 ) = ulpinv
1101 GO TO 440
1102 END IF
1103 END IF
1104*
1105 IF( m2.EQ.0 .AND. n.GT.0 ) THEN
1106 result( 13 ) = ulpinv
1107 result( 14 ) = ulpinv
1108 result( 15 ) = ulpinv
1109 GO TO 440
1110 END IF
1111*
1112* Do tests 13 and 14.
1113*
1114 DO 410 i = 1, n
1115 d3( i ) = dble( a( i, i ) )
1116 410 CONTINUE
1117 DO 420 i = 1, n - 1
1118 d4( i ) = dble( a( i+1, i ) )
1119 420 CONTINUE
1120 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1121 $ max( 1, m2 ), result( 13 ) )
1122*
1123 ntest = 15
1124 DO 430 i = 1, n - 1
1125 d4( i ) = dble( a( i+1, i ) )
1126 430 CONTINUE
1127 srnamt = 'DSTEVX'
1128 CALL dstevx( 'N', 'V', n, d3, d4, vl, vu, il, iu, abstol,
1129 $ m3, wa3, z, ldu, work, iwork,
1130 $ iwork( 5*n+1 ), iinfo )
1131 IF( iinfo.NE.0 ) THEN
1132 WRITE( nounit, fmt = 9999 )'DSTEVX(N,V)', iinfo, n,
1133 $ jtype, ioldsd
1134 info = abs( iinfo )
1135 IF( iinfo.LT.0 ) THEN
1136 RETURN
1137 ELSE
1138 result( 15 ) = ulpinv
1139 GO TO 440
1140 END IF
1141 END IF
1142*
1143* Do test 15.
1144*
1145 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1146 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1147 result( 15 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1148*
1149 440 CONTINUE
1150*
1151 ntest = 16
1152 DO 450 i = 1, n
1153 d1( i ) = dble( a( i, i ) )
1154 450 CONTINUE
1155 DO 460 i = 1, n - 1
1156 d2( i ) = dble( a( i+1, i ) )
1157 460 CONTINUE
1158 srnamt = 'DSTEVD'
1159 CALL dstevd( 'V', n, d1, d2, z, ldu, work, lwedc, iwork,
1160 $ liwedc, iinfo )
1161 IF( iinfo.NE.0 ) THEN
1162 WRITE( nounit, fmt = 9999 )'DSTEVD(V)', iinfo, n,
1163 $ jtype, ioldsd
1164 info = abs( iinfo )
1165 IF( iinfo.LT.0 ) THEN
1166 RETURN
1167 ELSE
1168 result( 16 ) = ulpinv
1169 result( 17 ) = ulpinv
1170 result( 18 ) = ulpinv
1171 GO TO 510
1172 END IF
1173 END IF
1174*
1175* Do tests 16 and 17.
1176*
1177 DO 470 i = 1, n
1178 d3( i ) = dble( a( i, i ) )
1179 470 CONTINUE
1180 DO 480 i = 1, n - 1
1181 d4( i ) = dble( a( i+1, i ) )
1182 480 CONTINUE
1183 CALL dstt21( n, 0, d3, d4, d1, d2, z, ldu, work,
1184 $ result( 16 ) )
1185*
1186 ntest = 18
1187 DO 490 i = 1, n - 1
1188 d4( i ) = dble( a( i+1, i ) )
1189 490 CONTINUE
1190 srnamt = 'DSTEVD'
1191 CALL dstevd( 'N', n, d3, d4, z, ldu, work, lwedc, iwork,
1192 $ liwedc, iinfo )
1193 IF( iinfo.NE.0 ) THEN
1194 WRITE( nounit, fmt = 9999 )'DSTEVD(N)', iinfo, n,
1195 $ jtype, ioldsd
1196 info = abs( iinfo )
1197 IF( iinfo.LT.0 ) THEN
1198 RETURN
1199 ELSE
1200 result( 18 ) = ulpinv
1201 GO TO 510
1202 END IF
1203 END IF
1204*
1205* Do test 18.
1206*
1207 temp1 = zero
1208 temp2 = zero
1209 DO 500 j = 1, n
1210 temp1 = max( temp1, abs( eveigs( j ) ),
1211 $ abs( d3( j ) ) )
1212 temp2 = max( temp2, abs( eveigs( j )-d3( j ) ) )
1213 500 CONTINUE
1214 result( 18 ) = temp2 / max( unfl,
1215 $ ulp*max( temp1, temp2 ) )
1216*
1217 510 CONTINUE
1218*
1219 ntest = 19
1220 DO 520 i = 1, n
1221 d1( i ) = dble( a( i, i ) )
1222 520 CONTINUE
1223 DO 530 i = 1, n - 1
1224 d2( i ) = dble( a( i+1, i ) )
1225 530 CONTINUE
1226 srnamt = 'DSTEVR'
1227 CALL dstevr( 'V', 'I', n, d1, d2, vl, vu, il, iu, abstol,
1228 $ m2, wa2, z, ldu, iwork, work, lwork,
1229 $ iwork(2*n+1), liwork-2*n, iinfo )
1230 IF( iinfo.NE.0 ) THEN
1231 WRITE( nounit, fmt = 9999 )'DSTEVR(V,I)', iinfo, n,
1232 $ jtype, ioldsd
1233 info = abs( iinfo )
1234 IF( iinfo.LT.0 ) THEN
1235 RETURN
1236 ELSE
1237 result( 19 ) = ulpinv
1238 result( 20 ) = ulpinv
1239 result( 21 ) = ulpinv
1240 GO TO 570
1241 END IF
1242 END IF
1243*
1244* DO tests 19 and 20.
1245*
1246 DO 540 i = 1, n
1247 d3( i ) = dble( a( i, i ) )
1248 540 CONTINUE
1249 DO 550 i = 1, n - 1
1250 d4( i ) = dble( a( i+1, i ) )
1251 550 CONTINUE
1252 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1253 $ max( 1, m2 ), result( 19 ) )
1254*
1255*
1256 ntest = 21
1257 DO 560 i = 1, n - 1
1258 d4( i ) = dble( a( i+1, i ) )
1259 560 CONTINUE
1260 srnamt = 'DSTEVR'
1261 CALL dstevr( 'N', 'I', n, d3, d4, vl, vu, il, iu, abstol,
1262 $ m3, wa3, z, ldu, iwork, work, lwork,
1263 $ iwork(2*n+1), liwork-2*n, iinfo )
1264 IF( iinfo.NE.0 ) THEN
1265 WRITE( nounit, fmt = 9999 )'DSTEVR(N,I)', iinfo, n,
1266 $ jtype, ioldsd
1267 info = abs( iinfo )
1268 IF( iinfo.LT.0 ) THEN
1269 RETURN
1270 ELSE
1271 result( 21 ) = ulpinv
1272 GO TO 570
1273 END IF
1274 END IF
1275*
1276* Do test 21.
1277*
1278 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1279 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1280 result( 21 ) = ( temp1+temp2 ) / max( unfl, ulp*temp3 )
1281*
1282 570 CONTINUE
1283*
1284 ntest = 21
1285 IF( n.GT.0 ) THEN
1286 IF( il.NE.1 ) THEN
1287 vl = wa1( il ) - max( half*
1288 $ ( wa1( il )-wa1( il-1 ) ), ten*ulp*temp3,
1289 $ ten*rtunfl )
1290 ELSE
1291 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1292 $ ten*ulp*temp3, ten*rtunfl )
1293 END IF
1294 IF( iu.NE.n ) THEN
1295 vu = wa1( iu ) + max( half*
1296 $ ( wa1( iu+1 )-wa1( iu ) ), ten*ulp*temp3,
1297 $ ten*rtunfl )
1298 ELSE
1299 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1300 $ ten*ulp*temp3, ten*rtunfl )
1301 END IF
1302 ELSE
1303 vl = zero
1304 vu = one
1305 END IF
1306*
1307 DO 580 i = 1, n
1308 d1( i ) = dble( a( i, i ) )
1309 580 CONTINUE
1310 DO 590 i = 1, n - 1
1311 d2( i ) = dble( a( i+1, i ) )
1312 590 CONTINUE
1313 srnamt = 'DSTEVR'
1314 CALL dstevr( 'V', 'V', n, d1, d2, vl, vu, il, iu, abstol,
1315 $ m2, wa2, z, ldu, iwork, work, lwork,
1316 $ iwork(2*n+1), liwork-2*n, iinfo )
1317 IF( iinfo.NE.0 ) THEN
1318 WRITE( nounit, fmt = 9999 )'DSTEVR(V,V)', iinfo, n,
1319 $ jtype, ioldsd
1320 info = abs( iinfo )
1321 IF( iinfo.LT.0 ) THEN
1322 RETURN
1323 ELSE
1324 result( 22 ) = ulpinv
1325 result( 23 ) = ulpinv
1326 result( 24 ) = ulpinv
1327 GO TO 630
1328 END IF
1329 END IF
1330*
1331 IF( m2.EQ.0 .AND. n.GT.0 ) THEN
1332 result( 22 ) = ulpinv
1333 result( 23 ) = ulpinv
1334 result( 24 ) = ulpinv
1335 GO TO 630
1336 END IF
1337*
1338* Do tests 22 and 23.
1339*
1340 DO 600 i = 1, n
1341 d3( i ) = dble( a( i, i ) )
1342 600 CONTINUE
1343 DO 610 i = 1, n - 1
1344 d4( i ) = dble( a( i+1, i ) )
1345 610 CONTINUE
1346 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1347 $ max( 1, m2 ), result( 22 ) )
1348*
1349 ntest = 24
1350 DO 620 i = 1, n - 1
1351 d4( i ) = dble( a( i+1, i ) )
1352 620 CONTINUE
1353 srnamt = 'DSTEVR'
1354 CALL dstevr( 'N', 'V', n, d3, d4, vl, vu, il, iu, abstol,
1355 $ m3, wa3, z, ldu, iwork, work, lwork,
1356 $ iwork(2*n+1), liwork-2*n, iinfo )
1357 IF( iinfo.NE.0 ) THEN
1358 WRITE( nounit, fmt = 9999 )'DSTEVR(N,V)', iinfo, n,
1359 $ jtype, ioldsd
1360 info = abs( iinfo )
1361 IF( iinfo.LT.0 ) THEN
1362 RETURN
1363 ELSE
1364 result( 24 ) = ulpinv
1365 GO TO 630
1366 END IF
1367 END IF
1368*
1369* Do test 24.
1370*
1371 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1372 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1373 result( 24 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1374*
1375 630 CONTINUE
1376*
1377*
1378*
1379 ELSE
1380*
1381 DO 640 i = 1, 24
1382 result( i ) = zero
1383 640 CONTINUE
1384 ntest = 24
1385 END IF
1386*
1387* Perform remaining tests storing upper or lower triangular
1388* part of matrix.
1389*
1390 DO 1720 iuplo = 0, 1
1391 IF( iuplo.EQ.0 ) THEN
1392 uplo = 'L'
1393 ELSE
1394 uplo = 'U'
1395 END IF
1396*
1397* 4) Call DSYEV and DSYEVX.
1398*
1399 CALL dlacpy( ' ', n, n, a, lda, v, ldu )
1400*
1401 ntest = ntest + 1
1402 srnamt = 'DSYEV'
1403 CALL dsyev( 'V', uplo, n, a, ldu, d1, work, lwork,
1404 $ iinfo )
1405 IF( iinfo.NE.0 ) THEN
1406 WRITE( nounit, fmt = 9999 )'DSYEV(V,' // uplo // ')',
1407 $ iinfo, n, jtype, ioldsd
1408 info = abs( iinfo )
1409 IF( iinfo.LT.0 ) THEN
1410 RETURN
1411 ELSE
1412 result( ntest ) = ulpinv
1413 result( ntest+1 ) = ulpinv
1414 result( ntest+2 ) = ulpinv
1415 GO TO 660
1416 END IF
1417 END IF
1418*
1419* Do tests 25 and 26 (or +54)
1420*
1421 CALL dsyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
1422 $ ldu, tau, work, result( ntest ) )
1423*
1424 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1425*
1426 ntest = ntest + 2
1427 srnamt = 'DSYEV_2STAGE'
1428 CALL dsyev_2stage( 'N', uplo, n, a, ldu, d3, work, lwork,
1429 $ iinfo )
1430 IF( iinfo.NE.0 ) THEN
1431 WRITE( nounit, fmt = 9999 )
1432 $ 'DSYEV_2STAGE(N,' // uplo // ')',
1433 $ iinfo, n, jtype, ioldsd
1434 info = abs( iinfo )
1435 IF( iinfo.LT.0 ) THEN
1436 RETURN
1437 ELSE
1438 result( ntest ) = ulpinv
1439 GO TO 660
1440 END IF
1441 END IF
1442*
1443* Do test 27 (or +54)
1444*
1445 temp1 = zero
1446 temp2 = zero
1447 DO 650 j = 1, n
1448 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1449 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1450 650 CONTINUE
1451 result( ntest ) = temp2 / max( unfl,
1452 $ ulp*max( temp1, temp2 ) )
1453*
1454 660 CONTINUE
1455 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1456*
1457 ntest = ntest + 1
1458*
1459 IF( n.GT.0 ) THEN
1460 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
1461 IF( il.NE.1 ) THEN
1462 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
1463 $ ten*ulp*temp3, ten*rtunfl )
1464 ELSE IF( n.GT.0 ) THEN
1465 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
1466 $ ten*ulp*temp3, ten*rtunfl )
1467 END IF
1468 IF( iu.NE.n ) THEN
1469 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
1470 $ ten*ulp*temp3, ten*rtunfl )
1471 ELSE IF( n.GT.0 ) THEN
1472 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
1473 $ ten*ulp*temp3, ten*rtunfl )
1474 END IF
1475 ELSE
1476 temp3 = zero
1477 vl = zero
1478 vu = one
1479 END IF
1480*
1481 srnamt = 'DSYEVX'
1482 CALL dsyevx( 'V', 'A', uplo, n, a, ldu, vl, vu, il, iu,
1483 $ abstol, m, wa1, z, ldu, work, lwork, iwork,
1484 $ iwork( 5*n+1 ), iinfo )
1485 IF( iinfo.NE.0 ) THEN
1486 WRITE( nounit, fmt = 9999 )'DSYEVX(V,A,' // uplo //
1487 $ ')', iinfo, n, jtype, ioldsd
1488 info = abs( iinfo )
1489 IF( iinfo.LT.0 ) THEN
1490 RETURN
1491 ELSE
1492 result( ntest ) = ulpinv
1493 result( ntest+1 ) = ulpinv
1494 result( ntest+2 ) = ulpinv
1495 GO TO 680
1496 END IF
1497 END IF
1498*
1499* Do tests 28 and 29 (or +54)
1500*
1501 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1502*
1503 CALL dsyt21( 1, uplo, n, 0, a, ldu, d1, d2, z, ldu, v,
1504 $ ldu, tau, work, result( ntest ) )
1505*
1506 ntest = ntest + 2
1507 srnamt = 'DSYEVX_2STAGE'
1508 CALL dsyevx_2stage( 'N', 'A', uplo, n, a, ldu, vl, vu,
1509 $ il, iu, abstol, m2, wa2, z, ldu, work,
1510 $ lwork, iwork, iwork( 5*n+1 ), iinfo )
1511 IF( iinfo.NE.0 ) THEN
1512 WRITE( nounit, fmt = 9999 )
1513 $ 'DSYEVX_2STAGE(N,A,' // uplo //
1514 $ ')', iinfo, n, jtype, ioldsd
1515 info = abs( iinfo )
1516 IF( iinfo.LT.0 ) THEN
1517 RETURN
1518 ELSE
1519 result( ntest ) = ulpinv
1520 GO TO 680
1521 END IF
1522 END IF
1523*
1524* Do test 30 (or +54)
1525*
1526 temp1 = zero
1527 temp2 = zero
1528 DO 670 j = 1, n
1529 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1530 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1531 670 CONTINUE
1532 result( ntest ) = temp2 / max( unfl,
1533 $ ulp*max( temp1, temp2 ) )
1534*
1535 680 CONTINUE
1536*
1537 ntest = ntest + 1
1538 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1539 srnamt = 'DSYEVX'
1540 CALL dsyevx( 'V', 'I', uplo, n, a, ldu, vl, vu, il, iu,
1541 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1542 $ iwork( 5*n+1 ), iinfo )
1543 IF( iinfo.NE.0 ) THEN
1544 WRITE( nounit, fmt = 9999 )'DSYEVX(V,I,' // uplo //
1545 $ ')', iinfo, n, jtype, ioldsd
1546 info = abs( iinfo )
1547 IF( iinfo.LT.0 ) THEN
1548 RETURN
1549 ELSE
1550 result( ntest ) = ulpinv
1551 result( ntest+1 ) = ulpinv
1552 result( ntest+2 ) = ulpinv
1553 GO TO 690
1554 END IF
1555 END IF
1556*
1557* Do tests 31 and 32 (or +54)
1558*
1559 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1560*
1561 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1562 $ v, ldu, tau, work, result( ntest ) )
1563*
1564 ntest = ntest + 2
1565 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1566 srnamt = 'DSYEVX_2STAGE'
1567 CALL dsyevx_2stage( 'N', 'I', uplo, n, a, ldu, vl, vu,
1568 $ il, iu, abstol, m3, wa3, z, ldu, work,
1569 $ lwork, iwork, iwork( 5*n+1 ), iinfo )
1570 IF( iinfo.NE.0 ) THEN
1571 WRITE( nounit, fmt = 9999 )
1572 $ 'DSYEVX_2STAGE(N,I,' // uplo //
1573 $ ')', iinfo, n, jtype, ioldsd
1574 info = abs( iinfo )
1575 IF( iinfo.LT.0 ) THEN
1576 RETURN
1577 ELSE
1578 result( ntest ) = ulpinv
1579 GO TO 690
1580 END IF
1581 END IF
1582*
1583* Do test 33 (or +54)
1584*
1585 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1586 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1587 result( ntest ) = ( temp1+temp2 ) /
1588 $ max( unfl, ulp*temp3 )
1589 690 CONTINUE
1590*
1591 ntest = ntest + 1
1592 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1593 srnamt = 'DSYEVX'
1594 CALL dsyevx( 'V', 'V', uplo, n, a, ldu, vl, vu, il, iu,
1595 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1596 $ iwork( 5*n+1 ), iinfo )
1597 IF( iinfo.NE.0 ) THEN
1598 WRITE( nounit, fmt = 9999 )'DSYEVX(V,V,' // uplo //
1599 $ ')', iinfo, n, jtype, ioldsd
1600 info = abs( iinfo )
1601 IF( iinfo.LT.0 ) THEN
1602 RETURN
1603 ELSE
1604 result( ntest ) = ulpinv
1605 result( ntest+1 ) = ulpinv
1606 result( ntest+2 ) = ulpinv
1607 GO TO 700
1608 END IF
1609 END IF
1610*
1611* Do tests 34 and 35 (or +54)
1612*
1613 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1614*
1615 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1616 $ v, ldu, tau, work, result( ntest ) )
1617*
1618 ntest = ntest + 2
1619 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1620 srnamt = 'DSYEVX_2STAGE'
1621 CALL dsyevx_2stage( 'N', 'V', uplo, n, a, ldu, vl, vu,
1622 $ il, iu, abstol, m3, wa3, z, ldu, work,
1623 $ lwork, iwork, iwork( 5*n+1 ), iinfo )
1624 IF( iinfo.NE.0 ) THEN
1625 WRITE( nounit, fmt = 9999 )
1626 $ 'DSYEVX_2STAGE(N,V,' // uplo //
1627 $ ')', iinfo, n, jtype, ioldsd
1628 info = abs( iinfo )
1629 IF( iinfo.LT.0 ) THEN
1630 RETURN
1631 ELSE
1632 result( ntest ) = ulpinv
1633 GO TO 700
1634 END IF
1635 END IF
1636*
1637 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1638 result( ntest ) = ulpinv
1639 GO TO 700
1640 END IF
1641*
1642* Do test 36 (or +54)
1643*
1644 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1645 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1646 IF( n.GT.0 ) THEN
1647 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1648 ELSE
1649 temp3 = zero
1650 END IF
1651 result( ntest ) = ( temp1+temp2 ) /
1652 $ max( unfl, temp3*ulp )
1653*
1654 700 CONTINUE
1655*
1656* 5) Call DSPEV and DSPEVX.
1657*
1658 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
1659*
1660* Load array WORK with the upper or lower triangular
1661* part of the matrix in packed form.
1662*
1663 IF( iuplo.EQ.1 ) THEN
1664 indx = 1
1665 DO 720 j = 1, n
1666 DO 710 i = 1, j
1667 work( indx ) = a( i, j )
1668 indx = indx + 1
1669 710 CONTINUE
1670 720 CONTINUE
1671 ELSE
1672 indx = 1
1673 DO 740 j = 1, n
1674 DO 730 i = j, n
1675 work( indx ) = a( i, j )
1676 indx = indx + 1
1677 730 CONTINUE
1678 740 CONTINUE
1679 END IF
1680*
1681 ntest = ntest + 1
1682 srnamt = 'DSPEV'
1683 CALL dspev( 'V', uplo, n, work, d1, z, ldu, v, iinfo )
1684 IF( iinfo.NE.0 ) THEN
1685 WRITE( nounit, fmt = 9999 )'DSPEV(V,' // uplo // ')',
1686 $ iinfo, n, jtype, ioldsd
1687 info = abs( iinfo )
1688 IF( iinfo.LT.0 ) THEN
1689 RETURN
1690 ELSE
1691 result( ntest ) = ulpinv
1692 result( ntest+1 ) = ulpinv
1693 result( ntest+2 ) = ulpinv
1694 GO TO 800
1695 END IF
1696 END IF
1697*
1698* Do tests 37 and 38 (or +54)
1699*
1700 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
1701 $ ldu, tau, work, result( ntest ) )
1702*
1703 IF( iuplo.EQ.1 ) THEN
1704 indx = 1
1705 DO 760 j = 1, n
1706 DO 750 i = 1, j
1707 work( indx ) = a( i, j )
1708 indx = indx + 1
1709 750 CONTINUE
1710 760 CONTINUE
1711 ELSE
1712 indx = 1
1713 DO 780 j = 1, n
1714 DO 770 i = j, n
1715 work( indx ) = a( i, j )
1716 indx = indx + 1
1717 770 CONTINUE
1718 780 CONTINUE
1719 END IF
1720*
1721 ntest = ntest + 2
1722 srnamt = 'DSPEV'
1723 CALL dspev( 'N', uplo, n, work, d3, z, ldu, v, iinfo )
1724 IF( iinfo.NE.0 ) THEN
1725 WRITE( nounit, fmt = 9999 )'DSPEV(N,' // uplo // ')',
1726 $ iinfo, n, jtype, ioldsd
1727 info = abs( iinfo )
1728 IF( iinfo.LT.0 ) THEN
1729 RETURN
1730 ELSE
1731 result( ntest ) = ulpinv
1732 GO TO 800
1733 END IF
1734 END IF
1735*
1736* Do test 39 (or +54)
1737*
1738 temp1 = zero
1739 temp2 = zero
1740 DO 790 j = 1, n
1741 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1742 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1743 790 CONTINUE
1744 result( ntest ) = temp2 / max( unfl,
1745 $ ulp*max( temp1, temp2 ) )
1746*
1747* Load array WORK with the upper or lower triangular part
1748* of the matrix in packed form.
1749*
1750 800 CONTINUE
1751 IF( iuplo.EQ.1 ) THEN
1752 indx = 1
1753 DO 820 j = 1, n
1754 DO 810 i = 1, j
1755 work( indx ) = a( i, j )
1756 indx = indx + 1
1757 810 CONTINUE
1758 820 CONTINUE
1759 ELSE
1760 indx = 1
1761 DO 840 j = 1, n
1762 DO 830 i = j, n
1763 work( indx ) = a( i, j )
1764 indx = indx + 1
1765 830 CONTINUE
1766 840 CONTINUE
1767 END IF
1768*
1769 ntest = ntest + 1
1770*
1771 IF( n.GT.0 ) THEN
1772 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
1773 IF( il.NE.1 ) THEN
1774 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
1775 $ ten*ulp*temp3, ten*rtunfl )
1776 ELSE IF( n.GT.0 ) THEN
1777 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
1778 $ ten*ulp*temp3, ten*rtunfl )
1779 END IF
1780 IF( iu.NE.n ) THEN
1781 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
1782 $ ten*ulp*temp3, ten*rtunfl )
1783 ELSE IF( n.GT.0 ) THEN
1784 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
1785 $ ten*ulp*temp3, ten*rtunfl )
1786 END IF
1787 ELSE
1788 temp3 = zero
1789 vl = zero
1790 vu = one
1791 END IF
1792*
1793 srnamt = 'DSPEVX'
1794 CALL dspevx( 'V', 'A', uplo, n, work, vl, vu, il, iu,
1795 $ abstol, m, wa1, z, ldu, v, iwork,
1796 $ iwork( 5*n+1 ), iinfo )
1797 IF( iinfo.NE.0 ) THEN
1798 WRITE( nounit, fmt = 9999 )'DSPEVX(V,A,' // uplo //
1799 $ ')', iinfo, n, jtype, ioldsd
1800 info = abs( iinfo )
1801 IF( iinfo.LT.0 ) THEN
1802 RETURN
1803 ELSE
1804 result( ntest ) = ulpinv
1805 result( ntest+1 ) = ulpinv
1806 result( ntest+2 ) = ulpinv
1807 GO TO 900
1808 END IF
1809 END IF
1810*
1811* Do tests 40 and 41 (or +54)
1812*
1813 CALL dsyt21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
1814 $ ldu, tau, work, result( ntest ) )
1815*
1816 ntest = ntest + 2
1817*
1818 IF( iuplo.EQ.1 ) THEN
1819 indx = 1
1820 DO 860 j = 1, n
1821 DO 850 i = 1, j
1822 work( indx ) = a( i, j )
1823 indx = indx + 1
1824 850 CONTINUE
1825 860 CONTINUE
1826 ELSE
1827 indx = 1
1828 DO 880 j = 1, n
1829 DO 870 i = j, n
1830 work( indx ) = a( i, j )
1831 indx = indx + 1
1832 870 CONTINUE
1833 880 CONTINUE
1834 END IF
1835*
1836 srnamt = 'DSPEVX'
1837 CALL dspevx( 'N', 'A', uplo, n, work, vl, vu, il, iu,
1838 $ abstol, m2, wa2, z, ldu, v, iwork,
1839 $ iwork( 5*n+1 ), iinfo )
1840 IF( iinfo.NE.0 ) THEN
1841 WRITE( nounit, fmt = 9999 )'DSPEVX(N,A,' // uplo //
1842 $ ')', iinfo, n, jtype, ioldsd
1843 info = abs( iinfo )
1844 IF( iinfo.LT.0 ) THEN
1845 RETURN
1846 ELSE
1847 result( ntest ) = ulpinv
1848 GO TO 900
1849 END IF
1850 END IF
1851*
1852* Do test 42 (or +54)
1853*
1854 temp1 = zero
1855 temp2 = zero
1856 DO 890 j = 1, n
1857 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1858 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1859 890 CONTINUE
1860 result( ntest ) = temp2 / max( unfl,
1861 $ ulp*max( temp1, temp2 ) )
1862*
1863 900 CONTINUE
1864 IF( iuplo.EQ.1 ) THEN
1865 indx = 1
1866 DO 920 j = 1, n
1867 DO 910 i = 1, j
1868 work( indx ) = a( i, j )
1869 indx = indx + 1
1870 910 CONTINUE
1871 920 CONTINUE
1872 ELSE
1873 indx = 1
1874 DO 940 j = 1, n
1875 DO 930 i = j, n
1876 work( indx ) = a( i, j )
1877 indx = indx + 1
1878 930 CONTINUE
1879 940 CONTINUE
1880 END IF
1881*
1882 ntest = ntest + 1
1883*
1884 srnamt = 'DSPEVX'
1885 CALL dspevx( 'V', 'I', uplo, n, work, vl, vu, il, iu,
1886 $ abstol, m2, wa2, z, ldu, v, iwork,
1887 $ iwork( 5*n+1 ), iinfo )
1888 IF( iinfo.NE.0 ) THEN
1889 WRITE( nounit, fmt = 9999 )'DSPEVX(V,I,' // uplo //
1890 $ ')', iinfo, n, jtype, ioldsd
1891 info = abs( iinfo )
1892 IF( iinfo.LT.0 ) THEN
1893 RETURN
1894 ELSE
1895 result( ntest ) = ulpinv
1896 result( ntest+1 ) = ulpinv
1897 result( ntest+2 ) = ulpinv
1898 GO TO 990
1899 END IF
1900 END IF
1901*
1902* Do tests 43 and 44 (or +54)
1903*
1904 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1905 $ v, ldu, tau, work, result( ntest ) )
1906*
1907 ntest = ntest + 2
1908*
1909 IF( iuplo.EQ.1 ) THEN
1910 indx = 1
1911 DO 960 j = 1, n
1912 DO 950 i = 1, j
1913 work( indx ) = a( i, j )
1914 indx = indx + 1
1915 950 CONTINUE
1916 960 CONTINUE
1917 ELSE
1918 indx = 1
1919 DO 980 j = 1, n
1920 DO 970 i = j, n
1921 work( indx ) = a( i, j )
1922 indx = indx + 1
1923 970 CONTINUE
1924 980 CONTINUE
1925 END IF
1926*
1927 srnamt = 'DSPEVX'
1928 CALL dspevx( 'N', 'I', uplo, n, work, vl, vu, il, iu,
1929 $ abstol, m3, wa3, z, ldu, v, iwork,
1930 $ iwork( 5*n+1 ), iinfo )
1931 IF( iinfo.NE.0 ) THEN
1932 WRITE( nounit, fmt = 9999 )'DSPEVX(N,I,' // uplo //
1933 $ ')', iinfo, n, jtype, ioldsd
1934 info = abs( iinfo )
1935 IF( iinfo.LT.0 ) THEN
1936 RETURN
1937 ELSE
1938 result( ntest ) = ulpinv
1939 GO TO 990
1940 END IF
1941 END IF
1942*
1943 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1944 result( ntest ) = ulpinv
1945 GO TO 990
1946 END IF
1947*
1948* Do test 45 (or +54)
1949*
1950 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1951 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1952 IF( n.GT.0 ) THEN
1953 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1954 ELSE
1955 temp3 = zero
1956 END IF
1957 result( ntest ) = ( temp1+temp2 ) /
1958 $ max( unfl, temp3*ulp )
1959*
1960 990 CONTINUE
1961 IF( iuplo.EQ.1 ) THEN
1962 indx = 1
1963 DO 1010 j = 1, n
1964 DO 1000 i = 1, j
1965 work( indx ) = a( i, j )
1966 indx = indx + 1
1967 1000 CONTINUE
1968 1010 CONTINUE
1969 ELSE
1970 indx = 1
1971 DO 1030 j = 1, n
1972 DO 1020 i = j, n
1973 work( indx ) = a( i, j )
1974 indx = indx + 1
1975 1020 CONTINUE
1976 1030 CONTINUE
1977 END IF
1978*
1979 ntest = ntest + 1
1980*
1981 srnamt = 'DSPEVX'
1982 CALL dspevx( 'V', 'V', uplo, n, work, vl, vu, il, iu,
1983 $ abstol, m2, wa2, z, ldu, v, iwork,
1984 $ iwork( 5*n+1 ), iinfo )
1985 IF( iinfo.NE.0 ) THEN
1986 WRITE( nounit, fmt = 9999 )'DSPEVX(V,V,' // uplo //
1987 $ ')', iinfo, n, jtype, ioldsd
1988 info = abs( iinfo )
1989 IF( iinfo.LT.0 ) THEN
1990 RETURN
1991 ELSE
1992 result( ntest ) = ulpinv
1993 result( ntest+1 ) = ulpinv
1994 result( ntest+2 ) = ulpinv
1995 GO TO 1080
1996 END IF
1997 END IF
1998*
1999* Do tests 46 and 47 (or +54)
2000*
2001 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2002 $ v, ldu, tau, work, result( ntest ) )
2003*
2004 ntest = ntest + 2
2005*
2006 IF( iuplo.EQ.1 ) THEN
2007 indx = 1
2008 DO 1050 j = 1, n
2009 DO 1040 i = 1, j
2010 work( indx ) = a( i, j )
2011 indx = indx + 1
2012 1040 CONTINUE
2013 1050 CONTINUE
2014 ELSE
2015 indx = 1
2016 DO 1070 j = 1, n
2017 DO 1060 i = j, n
2018 work( indx ) = a( i, j )
2019 indx = indx + 1
2020 1060 CONTINUE
2021 1070 CONTINUE
2022 END IF
2023*
2024 srnamt = 'DSPEVX'
2025 CALL dspevx( 'N', 'V', uplo, n, work, vl, vu, il, iu,
2026 $ abstol, m3, wa3, z, ldu, v, iwork,
2027 $ iwork( 5*n+1 ), iinfo )
2028 IF( iinfo.NE.0 ) THEN
2029 WRITE( nounit, fmt = 9999 )'DSPEVX(N,V,' // uplo //
2030 $ ')', iinfo, n, jtype, ioldsd
2031 info = abs( iinfo )
2032 IF( iinfo.LT.0 ) THEN
2033 RETURN
2034 ELSE
2035 result( ntest ) = ulpinv
2036 GO TO 1080
2037 END IF
2038 END IF
2039*
2040 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2041 result( ntest ) = ulpinv
2042 GO TO 1080
2043 END IF
2044*
2045* Do test 48 (or +54)
2046*
2047 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2048 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2049 IF( n.GT.0 ) THEN
2050 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2051 ELSE
2052 temp3 = zero
2053 END IF
2054 result( ntest ) = ( temp1+temp2 ) /
2055 $ max( unfl, temp3*ulp )
2056*
2057 1080 CONTINUE
2058*
2059* 6) Call DSBEV and DSBEVX.
2060*
2061 IF( jtype.LE.7 ) THEN
2062 kd = 1
2063 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
2064 kd = max( n-1, 0 )
2065 ELSE
2066 kd = ihbw
2067 END IF
2068*
2069* Load array V with the upper or lower triangular part
2070* of the matrix in band form.
2071*
2072 IF( iuplo.EQ.1 ) THEN
2073 DO 1100 j = 1, n
2074 DO 1090 i = max( 1, j-kd ), j
2075 v( kd+1+i-j, j ) = a( i, j )
2076 1090 CONTINUE
2077 1100 CONTINUE
2078 ELSE
2079 DO 1120 j = 1, n
2080 DO 1110 i = j, min( n, j+kd )
2081 v( 1+i-j, j ) = a( i, j )
2082 1110 CONTINUE
2083 1120 CONTINUE
2084 END IF
2085*
2086 ntest = ntest + 1
2087 srnamt = 'DSBEV'
2088 CALL dsbev( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
2089 $ iinfo )
2090 IF( iinfo.NE.0 ) THEN
2091 WRITE( nounit, fmt = 9999 )'DSBEV(V,' // uplo // ')',
2092 $ iinfo, n, jtype, ioldsd
2093 info = abs( iinfo )
2094 IF( iinfo.LT.0 ) THEN
2095 RETURN
2096 ELSE
2097 result( ntest ) = ulpinv
2098 result( ntest+1 ) = ulpinv
2099 result( ntest+2 ) = ulpinv
2100 GO TO 1180
2101 END IF
2102 END IF
2103*
2104* Do tests 49 and 50 (or ... )
2105*
2106 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2107 $ ldu, tau, work, result( ntest ) )
2108*
2109 IF( iuplo.EQ.1 ) THEN
2110 DO 1140 j = 1, n
2111 DO 1130 i = max( 1, j-kd ), j
2112 v( kd+1+i-j, j ) = a( i, j )
2113 1130 CONTINUE
2114 1140 CONTINUE
2115 ELSE
2116 DO 1160 j = 1, n
2117 DO 1150 i = j, min( n, j+kd )
2118 v( 1+i-j, j ) = a( i, j )
2119 1150 CONTINUE
2120 1160 CONTINUE
2121 END IF
2122*
2123 ntest = ntest + 2
2124 srnamt = 'DSBEV_2STAGE'
2125 CALL dsbev_2stage( 'N', uplo, n, kd, v, ldu, d3, z, ldu,
2126 $ work, lwork, iinfo )
2127 IF( iinfo.NE.0 ) THEN
2128 WRITE( nounit, fmt = 9999 )
2129 $ 'DSBEV_2STAGE(N,' // uplo // ')',
2130 $ iinfo, n, jtype, ioldsd
2131 info = abs( iinfo )
2132 IF( iinfo.LT.0 ) THEN
2133 RETURN
2134 ELSE
2135 result( ntest ) = ulpinv
2136 GO TO 1180
2137 END IF
2138 END IF
2139*
2140* Do test 51 (or +54)
2141*
2142 temp1 = zero
2143 temp2 = zero
2144 DO 1170 j = 1, n
2145 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2146 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2147 1170 CONTINUE
2148 result( ntest ) = temp2 / max( unfl,
2149 $ ulp*max( temp1, temp2 ) )
2150*
2151* Load array V with the upper or lower triangular part
2152* of the matrix in band form.
2153*
2154 1180 CONTINUE
2155 IF( iuplo.EQ.1 ) THEN
2156 DO 1200 j = 1, n
2157 DO 1190 i = max( 1, j-kd ), j
2158 v( kd+1+i-j, j ) = a( i, j )
2159 1190 CONTINUE
2160 1200 CONTINUE
2161 ELSE
2162 DO 1220 j = 1, n
2163 DO 1210 i = j, min( n, j+kd )
2164 v( 1+i-j, j ) = a( i, j )
2165 1210 CONTINUE
2166 1220 CONTINUE
2167 END IF
2168*
2169 ntest = ntest + 1
2170 srnamt = 'DSBEVX'
2171 CALL dsbevx( 'V', 'A', uplo, n, kd, v, ldu, u, ldu, vl,
2172 $ vu, il, iu, abstol, m, wa2, z, ldu, work,
2173 $ iwork, iwork( 5*n+1 ), iinfo )
2174 IF( iinfo.NE.0 ) THEN
2175 WRITE( nounit, fmt = 9999 )'DSBEVX(V,A,' // uplo //
2176 $ ')', iinfo, n, jtype, ioldsd
2177 info = abs( iinfo )
2178 IF( iinfo.LT.0 ) THEN
2179 RETURN
2180 ELSE
2181 result( ntest ) = ulpinv
2182 result( ntest+1 ) = ulpinv
2183 result( ntest+2 ) = ulpinv
2184 GO TO 1280
2185 END IF
2186 END IF
2187*
2188* Do tests 52 and 53 (or +54)
2189*
2190 CALL dsyt21( 1, uplo, n, 0, a, ldu, wa2, d2, z, ldu, v,
2191 $ ldu, tau, work, result( ntest ) )
2192*
2193 ntest = ntest + 2
2194*
2195 IF( iuplo.EQ.1 ) THEN
2196 DO 1240 j = 1, n
2197 DO 1230 i = max( 1, j-kd ), j
2198 v( kd+1+i-j, j ) = a( i, j )
2199 1230 CONTINUE
2200 1240 CONTINUE
2201 ELSE
2202 DO 1260 j = 1, n
2203 DO 1250 i = j, min( n, j+kd )
2204 v( 1+i-j, j ) = a( i, j )
2205 1250 CONTINUE
2206 1260 CONTINUE
2207 END IF
2208*
2209 srnamt = 'DSBEVX_2STAGE'
2210 CALL dsbevx_2stage( 'N', 'A', uplo, n, kd, v, ldu,
2211 $ u, ldu, vl, vu, il, iu, abstol, m3, wa3,
2212 $ z, ldu, work, lwork, iwork, iwork( 5*n+1 ),
2213 $ iinfo )
2214 IF( iinfo.NE.0 ) THEN
2215 WRITE( nounit, fmt = 9999 )
2216 $ 'DSBEVX_2STAGE(N,A,' // uplo //
2217 $ ')', iinfo, n, jtype, ioldsd
2218 info = abs( iinfo )
2219 IF( iinfo.LT.0 ) THEN
2220 RETURN
2221 ELSE
2222 result( ntest ) = ulpinv
2223 GO TO 1280
2224 END IF
2225 END IF
2226*
2227* Do test 54 (or +54)
2228*
2229 temp1 = zero
2230 temp2 = zero
2231 DO 1270 j = 1, n
2232 temp1 = max( temp1, abs( wa2( j ) ), abs( wa3( j ) ) )
2233 temp2 = max( temp2, abs( wa2( j )-wa3( j ) ) )
2234 1270 CONTINUE
2235 result( ntest ) = temp2 / max( unfl,
2236 $ ulp*max( temp1, temp2 ) )
2237*
2238 1280 CONTINUE
2239 ntest = ntest + 1
2240 IF( iuplo.EQ.1 ) THEN
2241 DO 1300 j = 1, n
2242 DO 1290 i = max( 1, j-kd ), j
2243 v( kd+1+i-j, j ) = a( i, j )
2244 1290 CONTINUE
2245 1300 CONTINUE
2246 ELSE
2247 DO 1320 j = 1, n
2248 DO 1310 i = j, min( n, j+kd )
2249 v( 1+i-j, j ) = a( i, j )
2250 1310 CONTINUE
2251 1320 CONTINUE
2252 END IF
2253*
2254 srnamt = 'DSBEVX'
2255 CALL dsbevx( 'V', 'I', uplo, n, kd, v, ldu, u, ldu, vl,
2256 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
2257 $ iwork, iwork( 5*n+1 ), iinfo )
2258 IF( iinfo.NE.0 ) THEN
2259 WRITE( nounit, fmt = 9999 )'DSBEVX(V,I,' // uplo //
2260 $ ')', iinfo, n, jtype, ioldsd
2261 info = abs( iinfo )
2262 IF( iinfo.LT.0 ) THEN
2263 RETURN
2264 ELSE
2265 result( ntest ) = ulpinv
2266 result( ntest+1 ) = ulpinv
2267 result( ntest+2 ) = ulpinv
2268 GO TO 1370
2269 END IF
2270 END IF
2271*
2272* Do tests 55 and 56 (or +54)
2273*
2274 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2275 $ v, ldu, tau, work, result( ntest ) )
2276*
2277 ntest = ntest + 2
2278*
2279 IF( iuplo.EQ.1 ) THEN
2280 DO 1340 j = 1, n
2281 DO 1330 i = max( 1, j-kd ), j
2282 v( kd+1+i-j, j ) = a( i, j )
2283 1330 CONTINUE
2284 1340 CONTINUE
2285 ELSE
2286 DO 1360 j = 1, n
2287 DO 1350 i = j, min( n, j+kd )
2288 v( 1+i-j, j ) = a( i, j )
2289 1350 CONTINUE
2290 1360 CONTINUE
2291 END IF
2292*
2293 srnamt = 'DSBEVX_2STAGE'
2294 CALL dsbevx_2stage( 'N', 'I', uplo, n, kd, v, ldu,
2295 $ u, ldu, vl, vu, il, iu, abstol, m3, wa3,
2296 $ z, ldu, work, lwork, iwork, iwork( 5*n+1 ),
2297 $ iinfo )
2298 IF( iinfo.NE.0 ) THEN
2299 WRITE( nounit, fmt = 9999 )
2300 $ 'DSBEVX_2STAGE(N,I,' // uplo //
2301 $ ')', iinfo, n, jtype, ioldsd
2302 info = abs( iinfo )
2303 IF( iinfo.LT.0 ) THEN
2304 RETURN
2305 ELSE
2306 result( ntest ) = ulpinv
2307 GO TO 1370
2308 END IF
2309 END IF
2310*
2311* Do test 57 (or +54)
2312*
2313 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2314 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2315 IF( n.GT.0 ) THEN
2316 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2317 ELSE
2318 temp3 = zero
2319 END IF
2320 result( ntest ) = ( temp1+temp2 ) /
2321 $ max( unfl, temp3*ulp )
2322*
2323 1370 CONTINUE
2324 ntest = ntest + 1
2325 IF( iuplo.EQ.1 ) THEN
2326 DO 1390 j = 1, n
2327 DO 1380 i = max( 1, j-kd ), j
2328 v( kd+1+i-j, j ) = a( i, j )
2329 1380 CONTINUE
2330 1390 CONTINUE
2331 ELSE
2332 DO 1410 j = 1, n
2333 DO 1400 i = j, min( n, j+kd )
2334 v( 1+i-j, j ) = a( i, j )
2335 1400 CONTINUE
2336 1410 CONTINUE
2337 END IF
2338*
2339 srnamt = 'DSBEVX'
2340 CALL dsbevx( 'V', 'V', uplo, n, kd, v, ldu, u, ldu, vl,
2341 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
2342 $ iwork, iwork( 5*n+1 ), iinfo )
2343 IF( iinfo.NE.0 ) THEN
2344 WRITE( nounit, fmt = 9999 )'DSBEVX(V,V,' // uplo //
2345 $ ')', iinfo, n, jtype, ioldsd
2346 info = abs( iinfo )
2347 IF( iinfo.LT.0 ) THEN
2348 RETURN
2349 ELSE
2350 result( ntest ) = ulpinv
2351 result( ntest+1 ) = ulpinv
2352 result( ntest+2 ) = ulpinv
2353 GO TO 1460
2354 END IF
2355 END IF
2356*
2357* Do tests 58 and 59 (or +54)
2358*
2359 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2360 $ v, ldu, tau, work, result( ntest ) )
2361*
2362 ntest = ntest + 2
2363*
2364 IF( iuplo.EQ.1 ) THEN
2365 DO 1430 j = 1, n
2366 DO 1420 i = max( 1, j-kd ), j
2367 v( kd+1+i-j, j ) = a( i, j )
2368 1420 CONTINUE
2369 1430 CONTINUE
2370 ELSE
2371 DO 1450 j = 1, n
2372 DO 1440 i = j, min( n, j+kd )
2373 v( 1+i-j, j ) = a( i, j )
2374 1440 CONTINUE
2375 1450 CONTINUE
2376 END IF
2377*
2378 srnamt = 'DSBEVX_2STAGE'
2379 CALL dsbevx_2stage( 'N', 'V', uplo, n, kd, v, ldu,
2380 $ u, ldu, vl, vu, il, iu, abstol, m3, wa3,
2381 $ z, ldu, work, lwork, iwork, iwork( 5*n+1 ),
2382 $ iinfo )
2383 IF( iinfo.NE.0 ) THEN
2384 WRITE( nounit, fmt = 9999 )
2385 $ 'DSBEVX_2STAGE(N,V,' // uplo //
2386 $ ')', iinfo, n, jtype, ioldsd
2387 info = abs( iinfo )
2388 IF( iinfo.LT.0 ) THEN
2389 RETURN
2390 ELSE
2391 result( ntest ) = ulpinv
2392 GO TO 1460
2393 END IF
2394 END IF
2395*
2396 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2397 result( ntest ) = ulpinv
2398 GO TO 1460
2399 END IF
2400*
2401* Do test 60 (or +54)
2402*
2403 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2404 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2405 IF( n.GT.0 ) THEN
2406 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2407 ELSE
2408 temp3 = zero
2409 END IF
2410 result( ntest ) = ( temp1+temp2 ) /
2411 $ max( unfl, temp3*ulp )
2412*
2413 1460 CONTINUE
2414*
2415* 7) Call DSYEVD
2416*
2417 CALL dlacpy( ' ', n, n, a, lda, v, ldu )
2418*
2419 ntest = ntest + 1
2420 srnamt = 'DSYEVD'
2421 CALL dsyevd( 'V', uplo, n, a, ldu, d1, work, lwedc,
2422 $ iwork, liwedc, iinfo )
2423 IF( iinfo.NE.0 ) THEN
2424 WRITE( nounit, fmt = 9999 )'DSYEVD(V,' // uplo //
2425 $ ')', iinfo, n, jtype, ioldsd
2426 info = abs( iinfo )
2427 IF( iinfo.LT.0 ) THEN
2428 RETURN
2429 ELSE
2430 result( ntest ) = ulpinv
2431 result( ntest+1 ) = ulpinv
2432 result( ntest+2 ) = ulpinv
2433 GO TO 1480
2434 END IF
2435 END IF
2436*
2437* Do tests 61 and 62 (or +54)
2438*
2439 CALL dsyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
2440 $ ldu, tau, work, result( ntest ) )
2441*
2442 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2443*
2444 ntest = ntest + 2
2445 srnamt = 'DSYEVD_2STAGE'
2446 CALL dsyevd_2stage( 'N', uplo, n, a, ldu, d3, work,
2447 $ lwork, iwork, liwedc, iinfo )
2448 IF( iinfo.NE.0 ) THEN
2449 WRITE( nounit, fmt = 9999 )
2450 $ 'DSYEVD_2STAGE(N,' // uplo //
2451 $ ')', iinfo, n, jtype, ioldsd
2452 info = abs( iinfo )
2453 IF( iinfo.LT.0 ) THEN
2454 RETURN
2455 ELSE
2456 result( ntest ) = ulpinv
2457 GO TO 1480
2458 END IF
2459 END IF
2460*
2461* Do test 63 (or +54)
2462*
2463 temp1 = zero
2464 temp2 = zero
2465 DO 1470 j = 1, n
2466 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2467 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2468 1470 CONTINUE
2469 result( ntest ) = temp2 / max( unfl,
2470 $ ulp*max( temp1, temp2 ) )
2471*
2472 1480 CONTINUE
2473*
2474* 8) Call DSPEVD.
2475*
2476 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2477*
2478* Load array WORK with the upper or lower triangular
2479* part of the matrix in packed form.
2480*
2481 IF( iuplo.EQ.1 ) THEN
2482 indx = 1
2483 DO 1500 j = 1, n
2484 DO 1490 i = 1, j
2485 work( indx ) = a( i, j )
2486 indx = indx + 1
2487 1490 CONTINUE
2488 1500 CONTINUE
2489 ELSE
2490 indx = 1
2491 DO 1520 j = 1, n
2492 DO 1510 i = j, n
2493 work( indx ) = a( i, j )
2494 indx = indx + 1
2495 1510 CONTINUE
2496 1520 CONTINUE
2497 END IF
2498*
2499 ntest = ntest + 1
2500 srnamt = 'DSPEVD'
2501 CALL dspevd( 'V', uplo, n, work, d1, z, ldu,
2502 $ work( indx ), lwedc-indx+1, iwork, liwedc,
2503 $ iinfo )
2504 IF( iinfo.NE.0 ) THEN
2505 WRITE( nounit, fmt = 9999 )'DSPEVD(V,' // uplo //
2506 $ ')', iinfo, n, jtype, ioldsd
2507 info = abs( iinfo )
2508 IF( iinfo.LT.0 ) THEN
2509 RETURN
2510 ELSE
2511 result( ntest ) = ulpinv
2512 result( ntest+1 ) = ulpinv
2513 result( ntest+2 ) = ulpinv
2514 GO TO 1580
2515 END IF
2516 END IF
2517*
2518* Do tests 64 and 65 (or +54)
2519*
2520 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2521 $ ldu, tau, work, result( ntest ) )
2522*
2523 IF( iuplo.EQ.1 ) THEN
2524 indx = 1
2525 DO 1540 j = 1, n
2526 DO 1530 i = 1, j
2527*
2528 work( indx ) = a( i, j )
2529 indx = indx + 1
2530 1530 CONTINUE
2531 1540 CONTINUE
2532 ELSE
2533 indx = 1
2534 DO 1560 j = 1, n
2535 DO 1550 i = j, n
2536 work( indx ) = a( i, j )
2537 indx = indx + 1
2538 1550 CONTINUE
2539 1560 CONTINUE
2540 END IF
2541*
2542 ntest = ntest + 2
2543 srnamt = 'DSPEVD'
2544 CALL dspevd( 'N', uplo, n, work, d3, z, ldu,
2545 $ work( indx ), lwedc-indx+1, iwork, liwedc,
2546 $ iinfo )
2547 IF( iinfo.NE.0 ) THEN
2548 WRITE( nounit, fmt = 9999 )'DSPEVD(N,' // uplo //
2549 $ ')', iinfo, n, jtype, ioldsd
2550 info = abs( iinfo )
2551 IF( iinfo.LT.0 ) THEN
2552 RETURN
2553 ELSE
2554 result( ntest ) = ulpinv
2555 GO TO 1580
2556 END IF
2557 END IF
2558*
2559* Do test 66 (or +54)
2560*
2561 temp1 = zero
2562 temp2 = zero
2563 DO 1570 j = 1, n
2564 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2565 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2566 1570 CONTINUE
2567 result( ntest ) = temp2 / max( unfl,
2568 $ ulp*max( temp1, temp2 ) )
2569 1580 CONTINUE
2570*
2571* 9) Call DSBEVD.
2572*
2573 IF( jtype.LE.7 ) THEN
2574 kd = 1
2575 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
2576 kd = max( n-1, 0 )
2577 ELSE
2578 kd = ihbw
2579 END IF
2580*
2581* Load array V with the upper or lower triangular part
2582* of the matrix in band form.
2583*
2584 IF( iuplo.EQ.1 ) THEN
2585 DO 1600 j = 1, n
2586 DO 1590 i = max( 1, j-kd ), j
2587 v( kd+1+i-j, j ) = a( i, j )
2588 1590 CONTINUE
2589 1600 CONTINUE
2590 ELSE
2591 DO 1620 j = 1, n
2592 DO 1610 i = j, min( n, j+kd )
2593 v( 1+i-j, j ) = a( i, j )
2594 1610 CONTINUE
2595 1620 CONTINUE
2596 END IF
2597*
2598 ntest = ntest + 1
2599 srnamt = 'DSBEVD'
2600 CALL dsbevd( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
2601 $ lwedc, iwork, liwedc, iinfo )
2602 IF( iinfo.NE.0 ) THEN
2603 WRITE( nounit, fmt = 9999 )'DSBEVD(V,' // uplo //
2604 $ ')', iinfo, n, jtype, ioldsd
2605 info = abs( iinfo )
2606 IF( iinfo.LT.0 ) THEN
2607 RETURN
2608 ELSE
2609 result( ntest ) = ulpinv
2610 result( ntest+1 ) = ulpinv
2611 result( ntest+2 ) = ulpinv
2612 GO TO 1680
2613 END IF
2614 END IF
2615*
2616* Do tests 67 and 68 (or +54)
2617*
2618 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2619 $ ldu, tau, work, result( ntest ) )
2620*
2621 IF( iuplo.EQ.1 ) THEN
2622 DO 1640 j = 1, n
2623 DO 1630 i = max( 1, j-kd ), j
2624 v( kd+1+i-j, j ) = a( i, j )
2625 1630 CONTINUE
2626 1640 CONTINUE
2627 ELSE
2628 DO 1660 j = 1, n
2629 DO 1650 i = j, min( n, j+kd )
2630 v( 1+i-j, j ) = a( i, j )
2631 1650 CONTINUE
2632 1660 CONTINUE
2633 END IF
2634*
2635 ntest = ntest + 2
2636 srnamt = 'DSBEVD_2STAGE'
2637 CALL dsbevd_2stage( 'N', uplo, n, kd, v, ldu, d3, z, ldu,
2638 $ work, lwork, iwork, liwedc, iinfo )
2639 IF( iinfo.NE.0 ) THEN
2640 WRITE( nounit, fmt = 9999 )
2641 $ 'DSBEVD_2STAGE(N,' // uplo //
2642 $ ')', iinfo, n, jtype, ioldsd
2643 info = abs( iinfo )
2644 IF( iinfo.LT.0 ) THEN
2645 RETURN
2646 ELSE
2647 result( ntest ) = ulpinv
2648 GO TO 1680
2649 END IF
2650 END IF
2651*
2652* Do test 69 (or +54)
2653*
2654 temp1 = zero
2655 temp2 = zero
2656 DO 1670 j = 1, n
2657 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2658 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2659 1670 CONTINUE
2660 result( ntest ) = temp2 / max( unfl,
2661 $ ulp*max( temp1, temp2 ) )
2662*
2663 1680 CONTINUE
2664*
2665*
2666 CALL dlacpy( ' ', n, n, a, lda, v, ldu )
2667 ntest = ntest + 1
2668 srnamt = 'DSYEVR'
2669 CALL dsyevr( 'V', 'A', uplo, n, a, ldu, vl, vu, il, iu,
2670 $ abstol, m, wa1, z, ldu, iwork, work, lwork,
2671 $ iwork(2*n+1), liwork-2*n, iinfo )
2672 IF( iinfo.NE.0 ) THEN
2673 WRITE( nounit, fmt = 9999 )'DSYEVR(V,A,' // uplo //
2674 $ ')', iinfo, n, jtype, ioldsd
2675 info = abs( iinfo )
2676 IF( iinfo.LT.0 ) THEN
2677 RETURN
2678 ELSE
2679 result( ntest ) = ulpinv
2680 result( ntest+1 ) = ulpinv
2681 result( ntest+2 ) = ulpinv
2682 GO TO 1700
2683 END IF
2684 END IF
2685*
2686* Do tests 70 and 71 (or ... )
2687*
2688 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2689*
2690 CALL dsyt21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
2691 $ ldu, tau, work, result( ntest ) )
2692*
2693 ntest = ntest + 2
2694 srnamt = 'DSYEVR_2STAGE'
2695 CALL dsyevr_2stage( 'N', 'A', uplo, n, a, ldu, vl, vu,
2696 $ il, iu, abstol, m2, wa2, z, ldu, iwork,
2697 $ work, lwork, iwork(2*n+1), liwork-2*n,
2698 $ iinfo )
2699 IF( iinfo.NE.0 ) THEN
2700 WRITE( nounit, fmt = 9999 )
2701 $ 'DSYEVR_2STAGE(N,A,' // uplo //
2702 $ ')', iinfo, n, jtype, ioldsd
2703 info = abs( iinfo )
2704 IF( iinfo.LT.0 ) THEN
2705 RETURN
2706 ELSE
2707 result( ntest ) = ulpinv
2708 GO TO 1700
2709 END IF
2710 END IF
2711*
2712* Do test 72 (or ... )
2713*
2714 temp1 = zero
2715 temp2 = zero
2716 DO 1690 j = 1, n
2717 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
2718 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
2719 1690 CONTINUE
2720 result( ntest ) = temp2 / max( unfl,
2721 $ ulp*max( temp1, temp2 ) )
2722*
2723 1700 CONTINUE
2724*
2725 ntest = ntest + 1
2726 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2727 srnamt = 'DSYEVR'
2728 CALL dsyevr( 'V', 'I', uplo, n, a, ldu, vl, vu, il, iu,
2729 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2730 $ iwork(2*n+1), liwork-2*n, iinfo )
2731 IF( iinfo.NE.0 ) THEN
2732 WRITE( nounit, fmt = 9999 )'DSYEVR(V,I,' // uplo //
2733 $ ')', iinfo, n, jtype, ioldsd
2734 info = abs( iinfo )
2735 IF( iinfo.LT.0 ) THEN
2736 RETURN
2737 ELSE
2738 result( ntest ) = ulpinv
2739 result( ntest+1 ) = ulpinv
2740 result( ntest+2 ) = ulpinv
2741 GO TO 1710
2742 END IF
2743 END IF
2744*
2745* Do tests 73 and 74 (or +54)
2746*
2747 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2748*
2749 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2750 $ v, ldu, tau, work, result( ntest ) )
2751*
2752 ntest = ntest + 2
2753 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2754 srnamt = 'DSYEVR_2STAGE'
2755 CALL dsyevr_2stage( 'N', 'I', uplo, n, a, ldu, vl, vu,
2756 $ il, iu, abstol, m3, wa3, z, ldu, iwork,
2757 $ work, lwork, iwork(2*n+1), liwork-2*n,
2758 $ iinfo )
2759 IF( iinfo.NE.0 ) THEN
2760 WRITE( nounit, fmt = 9999 )
2761 $ 'DSYEVR_2STAGE(N,I,' // uplo //
2762 $ ')', iinfo, n, jtype, ioldsd
2763 info = abs( iinfo )
2764 IF( iinfo.LT.0 ) THEN
2765 RETURN
2766 ELSE
2767 result( ntest ) = ulpinv
2768 GO TO 1710
2769 END IF
2770 END IF
2771*
2772* Do test 75 (or +54)
2773*
2774 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2775 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2776 result( ntest ) = ( temp1+temp2 ) /
2777 $ max( unfl, ulp*temp3 )
2778 1710 CONTINUE
2779*
2780 ntest = ntest + 1
2781 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2782 srnamt = 'DSYEVR'
2783 CALL dsyevr( 'V', 'V', uplo, n, a, ldu, vl, vu, il, iu,
2784 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2785 $ iwork(2*n+1), liwork-2*n, iinfo )
2786 IF( iinfo.NE.0 ) THEN
2787 WRITE( nounit, fmt = 9999 )'DSYEVR(V,V,' // uplo //
2788 $ ')', iinfo, n, jtype, ioldsd
2789 info = abs( iinfo )
2790 IF( iinfo.LT.0 ) THEN
2791 RETURN
2792 ELSE
2793 result( ntest ) = ulpinv
2794 result( ntest+1 ) = ulpinv
2795 result( ntest+2 ) = ulpinv
2796 GO TO 1720
2797 END IF
2798 END IF
2799*
2800* Do tests 76 and 77 (or +54)
2801*
2802 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2803*
2804 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2805 $ v, ldu, tau, work, result( ntest ) )
2806*
2807 ntest = ntest + 2
2808 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2809 srnamt = 'DSYEVR_2STAGE'
2810 CALL dsyevr_2stage( 'N', 'V', uplo, n, a, ldu, vl, vu,
2811 $ il, iu, abstol, m3, wa3, z, ldu, iwork,
2812 $ work, lwork, iwork(2*n+1), liwork-2*n,
2813 $ iinfo )
2814 IF( iinfo.NE.0 ) THEN
2815 WRITE( nounit, fmt = 9999 )
2816 $ 'DSYEVR_2STAGE(N,V,' // uplo //
2817 $ ')', iinfo, n, jtype, ioldsd
2818 info = abs( iinfo )
2819 IF( iinfo.LT.0 ) THEN
2820 RETURN
2821 ELSE
2822 result( ntest ) = ulpinv
2823 GO TO 1720
2824 END IF
2825 END IF
2826*
2827 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2828 result( ntest ) = ulpinv
2829 GO TO 1720
2830 END IF
2831*
2832* Do test 78 (or +54)
2833*
2834 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2835 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2836 IF( n.GT.0 ) THEN
2837 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2838 ELSE
2839 temp3 = zero
2840 END IF
2841 result( ntest ) = ( temp1+temp2 ) /
2842 $ max( unfl, temp3*ulp )
2843*
2844 CALL dlacpy( ' ', n, n, v, ldu, a, lda )
2845*
2846 1720 CONTINUE
2847*
2848* End of Loop -- Check for RESULT(j) > THRESH
2849*
2850 ntestt = ntestt + ntest
2851*
2852 CALL dlafts( 'DST', n, n, jtype, ntest, result, ioldsd,
2853 $ thresh, nounit, nerrs )
2854*
2855 1730 CONTINUE
2856 1740 CONTINUE
2857*
2858* Summary
2859*
2860 CALL alasvm( 'DST', nounit, nerrs, ntestt, 0 )
2861*
2862 9999 FORMAT( ' DDRVST2STG: ', a, ' returned INFO=', i6, '.', / 9x,
2863 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2864*
2865 RETURN
2866*
2867* End of DDRVST2STG
2868*
dsbevd_2stage
subroutine dsbevd_2stage(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, iwork, liwork, info)
DSBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER ...
Definition dsbevd_2stage.f:234
dsbevx_2stage
subroutine dsbevx_2stage(jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, iwork, ifail, info)
DSBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER ...
Definition dsbevx_2stage.f:322
dsbev_2stage
subroutine dsbev_2stage(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, info)
DSBEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER m...
Definition dsbev_2stage.f:204
dsytrd_sy2sb
subroutine dsytrd_sy2sb(uplo, n, kd, a, lda, ab, ldab, tau, work, lwork, info)
DSYTRD_SY2SB
Definition dsytrd_sy2sb.f:243
dsyevr_2stage
subroutine dsyevr_2stage(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
DSYEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY mat...
Definition dsyevr_2stage.f:381
dsyevx_2stage
subroutine dsyevx_2stage(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, iwork, ifail, info)
DSYEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY mat...
Definition dsyevx_2stage.f:300
dsyev_2stage
subroutine dsyev_2stage(jobz, uplo, n, a, lda, w, work, lwork, info)
DSYEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matr...
Definition dsyev_2stage.f:183
dsyevd_2stage
subroutine dsyevd_2stage(jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork, info)
DSYEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY mat...
Definition dsyevd_2stage.f:227

◆ ddrvsx()

subroutine ddrvsx ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer niunit,
integer nounit,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( lda, * ) h,
double precision, dimension( lda, * ) ht,
double precision, dimension( * ) wr,
double precision, dimension( * ) wi,
double precision, dimension( * ) wrt,
double precision, dimension( * ) wit,
double precision, dimension( * ) wrtmp,
double precision, dimension( * ) witmp,
double precision, dimension( ldvs, * ) vs,
integer ldvs,
double precision, dimension( ldvs, * ) vs1,
double precision, dimension( 17 ) result,
double precision, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
logical, dimension( * ) bwork,
integer info )

DDRVSX

Purpose:
!>
!>    DDRVSX checks the nonsymmetric eigenvalue (Schur form) problem
!>    expert driver DGEESX.
!>
!>    DDRVSX 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 DDRVSX 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 WR+sqrt(-1)*WI 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 WR+sqrt(-1)*WI are eigenvalues of T
!>            1/ulp otherwise
!>            If workspace sufficient, also compare WR, WI 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 signs.
!>         (ULP = (first number larger than 1) - 1 )
!>    (5)  A diagonal matrix with geometrically spaced entries
!>         1, ..., ULP  and random signs.
!>    (6)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>         and random signs.
!>
!>    (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 orthogonal and
!>         T has evenly spaced entries 1, ..., ULP with random signs
!>         on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (10) A matrix of the form  U' T U, where U is orthogonal and
!>         T has geometrically spaced entries 1, ..., ULP with random
!>         signs 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
!>         signs on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (12) A matrix of the form  U' T U, where U is orthogonal and
!>         T has real or complex conjugate paired eigenvalues randomly
!>         chosen from ( ULP, 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 signs 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 signs 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 signs 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 real or complex conjugate paired
!>         eigenvalues randomly chosen from ( ULP, 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 DGEESX 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 DGEESX 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 DDRVSX to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NIUNIT
!>          NIUNIT is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by DGEESX.
!>
[out]HT
!>          HT is DOUBLE PRECISION array, dimension (LDA, max(NN))
!>          Yet another copy of the test matrix A, modified by DGEESX.
!>
[out]WR
!>          WR is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]WI
!>          WI is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          The real and imaginary parts of the eigenvalues of A.
!>          On exit, WR + WI*i are the eigenvalues of the matrix in A.
!>
[out]WRT
!>          WRT is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]WIT
!>          WIT is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when DGEESX only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]WRTMP
!>          WRTMP is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]WITMP
!>          WITMP is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          More temporary storage for eigenvalues.
!>
[out]VS
!>          VS is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDVS, max(NN))
!>          VS1 holds another copy of the computed Schur vectors.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (17)
!>          The values computed by the 17 tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          max(3*NN(j),2*NN(j)**2) for all j.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (max(NN)*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,  DLATMR, SLATMS, SLATME or DGET24 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 450 of file ddrvsx.f.

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

◆ ddrvvx()

subroutine ddrvvx ( integer nsizes,
integer, dimension( * ) nn,
integer ntypes,
logical, dimension( * ) dotype,
integer, dimension( 4 ) iseed,
double precision thresh,
integer niunit,
integer nounit,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( lda, * ) h,
double precision, dimension( * ) wr,
double precision, dimension( * ) wi,
double precision, dimension( * ) wr1,
double precision, dimension( * ) wi1,
double precision, dimension( ldvl, * ) vl,
integer ldvl,
double precision, dimension( ldvr, * ) vr,
integer ldvr,
double precision, dimension( ldlre, * ) lre,
integer ldlre,
double precision, dimension( * ) rcondv,
double precision, dimension( * ) rcndv1,
double precision, dimension( * ) rcdvin,
double precision, dimension( * ) rconde,
double precision, dimension( * ) rcnde1,
double precision, dimension( * ) rcdein,
double precision, dimension( * ) scale,
double precision, dimension( * ) scale1,
double precision, dimension( 11 ) result,
double precision, dimension( * ) work,
integer nwork,
integer, dimension( * ) iwork,
integer info )

DDRVVX

Purpose:
!>
!>    DDRVVX  checks the nonsymmetric eigenvalue problem expert driver
!>    DGEEVX.
!>
!>    DDRVVX 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 DDRVVX 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 block diagonal matrix, with a 1x1 block for each
!>      real eigenvalue and a 2x2 block for each complex conjugate
!>      pair.  If eigenvalues j and j+1 are a complex conjugate pair,
!>      so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
!>      2 x 2 block corresponding to the pair will be:
!>
!>              (  wr  wi  )
!>              ( -wi  wr  )
!>
!>      Such a block multiplying an n x 2 matrix  ( ur ui ) on the
!>      right will be the same as multiplying  ur + i*ui  by  wr + i*wi.
!>
!>    (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 signs.
!>         (ULP = (first number larger than 1) - 1 )
!>    (5)  A diagonal matrix with geometrically spaced entries
!>         1, ..., ULP  and random signs.
!>    (6)  A diagonal matrix with  entries 1, ULP, ..., ULP
!>         and random signs.
!>
!>    (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 orthogonal and
!>         T has evenly spaced entries 1, ..., ULP with random signs
!>         on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (10) A matrix of the form  U' T U, where U is orthogonal and
!>         T has geometrically spaced entries 1, ..., ULP with random
!>         signs 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
!>         signs on the diagonal and random O(1) entries in the upper
!>         triangle.
!>
!>    (12) A matrix of the form  U' T U, where U is orthogonal and
!>         T has real or complex conjugate paired eigenvalues randomly
!>         chosen from ( ULP, 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 signs 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 signs 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 signs 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 real or complex conjugate paired
!>         eigenvalues randomly chosen from ( ULP, 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 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 DGEEVX 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 DGEEVX 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 DDRVVX to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NIUNIT
!>          NIUNIT is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is DOUBLE PRECISION 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 the arrays A and H.
!>          LDA >= max(NN,12), since 12 is the dimension of the largest
!>          matrix in the precomputed input file.
!>
[out]H
!>          H is DOUBLE PRECISION array, dimension
!>                      (LDA, max(NN,12))
!>          Another copy of the test matrix A, modified by DGEEVX.
!>
[out]WR
!>          WR is DOUBLE PRECISION array, dimension (max(NN))
!>
[out]WI
!>          WI is DOUBLE PRECISION array, dimension (max(NN))
!>
!>          The real and imaginary parts of the eigenvalues of A.
!>          On exit, WR + WI*i are the eigenvalues of the matrix in A.
!>
[out]WR1
!>          WR1 is DOUBLE PRECISION array, dimension (max(NN,12))
!>
[out]WI1
!>          WI1 is DOUBLE PRECISION array, dimension (max(NN,12))
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when DGEEVX only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension
!>                      (LDLRE, max(NN,12))
!>          LRE holds the computed right or left eigenvectors.
!>
[in]LDLRE
!>          LDLRE is INTEGER
!>          Leading dimension of LRE. Must be at least max(1,max(NN,12))
!>
[out]RCONDV
!>          RCONDV is DOUBLE PRECISION array, dimension (N)
!>          RCONDV holds the computed reciprocal condition numbers
!>          for eigenvectors.
!>
[out]RCNDV1
!>          RCNDV1 is DOUBLE PRECISION array, dimension (N)
!>          RCNDV1 holds more computed reciprocal condition numbers
!>          for eigenvectors.
!>
[out]RCDVIN
!>          RCDVIN is DOUBLE PRECISION array, dimension (N)
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition numbers for eigenvectors to be compared with
!>          RCONDV.
!>
[out]RCONDE
!>          RCONDE is DOUBLE PRECISION array, dimension (N)
!>          RCONDE holds the computed reciprocal condition numbers
!>          for eigenvalues.
!>
[out]RCNDE1
!>          RCNDE1 is DOUBLE PRECISION array, dimension (N)
!>          RCNDE1 holds more computed reciprocal condition numbers
!>          for eigenvalues.
!>
[out]RCDEIN
!>          RCDEIN is DOUBLE PRECISION array, dimension (N)
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition numbers for eigenvalues to be compared with
!>          RCONDE.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]SCALE1
!>          SCALE1 is DOUBLE PRECISION array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (11)
!>          The values computed by the seven tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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]IWORK
!>          IWORK is INTEGER 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, DLATMR, SLATMS, SLATME or DGET23 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 516 of file ddrvvx.f.

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

◆ derrbd()

subroutine derrbd ( character*3 path,
integer nunit )

DERRBD

Purpose:
!>
!> DERRBD tests the error exits for DGEBD2, DGEBRD, DORGBR, DORMBR,
!> DBDSQR, DBDSDC and DBDSVDX.
!>
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 derrbd.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 = 4, lw = nmax )
70 DOUBLE PRECISION ZERO, ONE
71 parameter( zero = 0.0d0, one = 1.0d0 )
72* ..
73* .. Local Scalars ..
74 CHARACTER*2 C2
75 INTEGER I, INFO, J, NS, NT
76* ..
77* .. Local Arrays ..
78 INTEGER IQ( NMAX, NMAX ), IW( NMAX )
79 DOUBLE PRECISION A( NMAX, NMAX ), D( NMAX ), E( NMAX ),
80 $ Q( NMAX, NMAX ), S( NMAX ), TP( NMAX ),
81 $ TQ( NMAX ), U( NMAX, NMAX ),
82 $ V( NMAX, NMAX ), W( LW )
83* ..
84* .. External Functions ..
85 LOGICAL LSAMEN
86 EXTERNAL lsamen
87* ..
88* .. External Subroutines ..
89 EXTERNAL chkxer, dbdsdc, dbdsqr, dbdsvdx, dgebd2,
90 $ dgebrd, dorgbr, dormbr
91* ..
92* .. Scalars in Common ..
93 LOGICAL LERR, OK
94 CHARACTER*32 SRNAMT
95 INTEGER INFOT, NOUT
96* ..
97* .. Common blocks ..
98 COMMON / infoc / infot, nout, ok, lerr
99 COMMON / srnamc / srnamt
100* ..
101* .. Intrinsic Functions ..
102 INTRINSIC dble
103* ..
104* .. Executable Statements ..
105*
106 nout = nunit
107 WRITE( nout, fmt = * )
108 c2 = path( 2: 3 )
109*
110* Set the variables to innocuous values.
111*
112 DO 20 j = 1, nmax
113 DO 10 i = 1, nmax
114 a( i, j ) = 1.d0 / dble( i+j )
115 10 CONTINUE
116 20 CONTINUE
117 ok = .true.
118 nt = 0
119*
120* Test error exits of the SVD routines.
121*
122 IF( lsamen( 2, c2, 'BD' ) ) THEN
123*
124* DGEBRD
125*
126 srnamt = 'DGEBRD'
127 infot = 1
128 CALL dgebrd( -1, 0, a, 1, d, e, tq, tp, w, 1, info )
129 CALL chkxer( 'DGEBRD', infot, nout, lerr, ok )
130 infot = 2
131 CALL dgebrd( 0, -1, a, 1, d, e, tq, tp, w, 1, info )
132 CALL chkxer( 'DGEBRD', infot, nout, lerr, ok )
133 infot = 4
134 CALL dgebrd( 2, 1, a, 1, d, e, tq, tp, w, 2, info )
135 CALL chkxer( 'DGEBRD', infot, nout, lerr, ok )
136 infot = 10
137 CALL dgebrd( 2, 1, a, 2, d, e, tq, tp, w, 1, info )
138 CALL chkxer( 'DGEBRD', infot, nout, lerr, ok )
139 nt = nt + 4
140*
141* DGEBD2
142*
143 srnamt = 'DGEBD2'
144 infot = 1
145 CALL dgebd2( -1, 0, a, 1, d, e, tq, tp, w, info )
146 CALL chkxer( 'DGEBD2', infot, nout, lerr, ok )
147 infot = 2
148 CALL dgebd2( 0, -1, a, 1, d, e, tq, tp, w, info )
149 CALL chkxer( 'DGEBD2', infot, nout, lerr, ok )
150 infot = 4
151 CALL dgebd2( 2, 1, a, 1, d, e, tq, tp, w, info )
152 CALL chkxer( 'DGEBD2', infot, nout, lerr, ok )
153 nt = nt + 3
154*
155* DORGBR
156*
157 srnamt = 'DORGBR'
158 infot = 1
159 CALL dorgbr( '/', 0, 0, 0, a, 1, tq, w, 1, info )
160 CALL chkxer( 'DORGBR', infot, nout, lerr, ok )
161 infot = 2
162 CALL dorgbr( 'Q', -1, 0, 0, a, 1, tq, w, 1, info )
163 CALL chkxer( 'DORGBR', infot, nout, lerr, ok )
164 infot = 3
165 CALL dorgbr( 'Q', 0, -1, 0, a, 1, tq, w, 1, info )
166 CALL chkxer( 'DORGBR', infot, nout, lerr, ok )
167 infot = 3
168 CALL dorgbr( 'Q', 0, 1, 0, a, 1, tq, w, 1, info )
169 CALL chkxer( 'DORGBR', infot, nout, lerr, ok )
170 infot = 3
171 CALL dorgbr( 'Q', 1, 0, 1, a, 1, tq, w, 1, info )
172 CALL chkxer( 'DORGBR', infot, nout, lerr, ok )
173 infot = 3
174 CALL dorgbr( 'P', 1, 0, 0, a, 1, tq, w, 1, info )
175 CALL chkxer( 'DORGBR', infot, nout, lerr, ok )
176 infot = 3
177 CALL dorgbr( 'P', 0, 1, 1, a, 1, tq, w, 1, info )
178 CALL chkxer( 'DORGBR', infot, nout, lerr, ok )
179 infot = 4
180 CALL dorgbr( 'Q', 0, 0, -1, a, 1, tq, w, 1, info )
181 CALL chkxer( 'DORGBR', infot, nout, lerr, ok )
182 infot = 6
183 CALL dorgbr( 'Q', 2, 1, 1, a, 1, tq, w, 1, info )
184 CALL chkxer( 'DORGBR', infot, nout, lerr, ok )
185 infot = 9
186 CALL dorgbr( 'Q', 2, 2, 1, a, 2, tq, w, 1, info )
187 CALL chkxer( 'DORGBR', infot, nout, lerr, ok )
188 nt = nt + 10
189*
190* DORMBR
191*
192 srnamt = 'DORMBR'
193 infot = 1
194 CALL dormbr( '/', 'L', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
195 $ info )
196 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
197 infot = 2
198 CALL dormbr( 'Q', '/', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
199 $ info )
200 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
201 infot = 3
202 CALL dormbr( 'Q', 'L', '/', 0, 0, 0, a, 1, tq, u, 1, w, 1,
203 $ info )
204 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
205 infot = 4
206 CALL dormbr( 'Q', 'L', 'T', -1, 0, 0, a, 1, tq, u, 1, w, 1,
207 $ info )
208 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
209 infot = 5
210 CALL dormbr( 'Q', 'L', 'T', 0, -1, 0, a, 1, tq, u, 1, w, 1,
211 $ info )
212 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
213 infot = 6
214 CALL dormbr( 'Q', 'L', 'T', 0, 0, -1, a, 1, tq, u, 1, w, 1,
215 $ info )
216 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
217 infot = 8
218 CALL dormbr( 'Q', 'L', 'T', 2, 0, 0, a, 1, tq, u, 2, w, 1,
219 $ info )
220 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
221 infot = 8
222 CALL dormbr( 'Q', 'R', 'T', 0, 2, 0, a, 1, tq, u, 1, w, 1,
223 $ info )
224 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
225 infot = 8
226 CALL dormbr( 'P', 'L', 'T', 2, 0, 2, a, 1, tq, u, 2, w, 1,
227 $ info )
228 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
229 infot = 8
230 CALL dormbr( 'P', 'R', 'T', 0, 2, 2, a, 1, tq, u, 1, w, 1,
231 $ info )
232 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
233 infot = 11
234 CALL dormbr( 'Q', 'R', 'T', 2, 0, 0, a, 1, tq, u, 1, w, 1,
235 $ info )
236 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
237 infot = 13
238 CALL dormbr( 'Q', 'L', 'T', 0, 2, 0, a, 1, tq, u, 1, w, 1,
239 $ info )
240 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
241 infot = 13
242 CALL dormbr( 'Q', 'R', 'T', 2, 0, 0, a, 1, tq, u, 2, w, 1,
243 $ info )
244 CALL chkxer( 'DORMBR', infot, nout, lerr, ok )
245 nt = nt + 13
246*
247* DBDSQR
248*
249 srnamt = 'DBDSQR'
250 infot = 1
251 CALL dbdsqr( '/', 0, 0, 0, 0, d, e, v, 1, u, 1, a, 1, w, info )
252 CALL chkxer( 'DBDSQR', infot, nout, lerr, ok )
253 infot = 2
254 CALL dbdsqr( 'U', -1, 0, 0, 0, d, e, v, 1, u, 1, a, 1, w,
255 $ info )
256 CALL chkxer( 'DBDSQR', infot, nout, lerr, ok )
257 infot = 3
258 CALL dbdsqr( 'U', 0, -1, 0, 0, d, e, v, 1, u, 1, a, 1, w,
259 $ info )
260 CALL chkxer( 'DBDSQR', infot, nout, lerr, ok )
261 infot = 4
262 CALL dbdsqr( 'U', 0, 0, -1, 0, d, e, v, 1, u, 1, a, 1, w,
263 $ info )
264 CALL chkxer( 'DBDSQR', infot, nout, lerr, ok )
265 infot = 5
266 CALL dbdsqr( 'U', 0, 0, 0, -1, d, e, v, 1, u, 1, a, 1, w,
267 $ info )
268 CALL chkxer( 'DBDSQR', infot, nout, lerr, ok )
269 infot = 9
270 CALL dbdsqr( 'U', 2, 1, 0, 0, d, e, v, 1, u, 1, a, 1, w, info )
271 CALL chkxer( 'DBDSQR', infot, nout, lerr, ok )
272 infot = 11
273 CALL dbdsqr( 'U', 0, 0, 2, 0, d, e, v, 1, u, 1, a, 1, w, info )
274 CALL chkxer( 'DBDSQR', infot, nout, lerr, ok )
275 infot = 13
276 CALL dbdsqr( 'U', 2, 0, 0, 1, d, e, v, 1, u, 1, a, 1, w, info )
277 CALL chkxer( 'DBDSQR', infot, nout, lerr, ok )
278 nt = nt + 8
279*
280* DBDSDC
281*
282 srnamt = 'DBDSDC'
283 infot = 1
284 CALL dbdsdc( '/', 'N', 0, d, e, u, 1, v, 1, q, iq, w, iw,
285 $ info )
286 CALL chkxer( 'DBDSDC', infot, nout, lerr, ok )
287 infot = 2
288 CALL dbdsdc( 'U', '/', 0, d, e, u, 1, v, 1, q, iq, w, iw,
289 $ info )
290 CALL chkxer( 'DBDSDC', infot, nout, lerr, ok )
291 infot = 3
292 CALL dbdsdc( 'U', 'N', -1, d, e, u, 1, v, 1, q, iq, w, iw,
293 $ info )
294 CALL chkxer( 'DBDSDC', infot, nout, lerr, ok )
295 infot = 7
296 CALL dbdsdc( 'U', 'I', 2, d, e, u, 1, v, 1, q, iq, w, iw,
297 $ info )
298 CALL chkxer( 'DBDSDC', infot, nout, lerr, ok )
299 infot = 9
300 CALL dbdsdc( 'U', 'I', 2, d, e, u, 2, v, 1, q, iq, w, iw,
301 $ info )
302 CALL chkxer( 'DBDSDC', infot, nout, lerr, ok )
303 nt = nt + 5
304*
305* DBDSVDX
306*
307 srnamt = 'DBDSVDX'
308 infot = 1
309 CALL dbdsvdx( 'X', 'N', 'A', 1, d, e, zero, one, 0, 0,
310 $ ns, s, q, 1, w, iw, info)
311 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
312 infot = 2
313 CALL dbdsvdx( 'U', 'X', 'A', 1, d, e, zero, one, 0, 0,
314 $ ns, s, q, 1, w, iw, info)
315 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
316 infot = 3
317 CALL dbdsvdx( 'U', 'V', 'X', 1, d, e, zero, one, 0, 0,
318 $ ns, s, q, 1, w, iw, info)
319 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
320 infot = 4
321 CALL dbdsvdx( 'U', 'V', 'A', -1, d, e, zero, one, 0, 0,
322 $ ns, s, q, 1, w, iw, info)
323 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
324 infot = 7
325 CALL dbdsvdx( 'U', 'V', 'V', 2, d, e, -one, zero, 0, 0,
326 $ ns, s, q, 1, w, iw, info)
327 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
328 infot = 8
329 CALL dbdsvdx( 'U', 'V', 'V', 2, d, e, one, zero, 0, 0,
330 $ ns, s, q, 1, w, iw, info)
331 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
332 infot = 9
333 CALL dbdsvdx( 'L', 'V', 'I', 2, d, e, zero, zero, 0, 2,
334 $ ns, s, q, 1, w, iw, info)
335 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
336 infot = 9
337 CALL dbdsvdx( 'L', 'V', 'I', 4, d, e, zero, zero, 5, 2,
338 $ ns, s, q, 1, w, iw, info)
339 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
340 infot = 10
341 CALL dbdsvdx( 'L', 'V', 'I', 4, d, e, zero, zero, 3, 2,
342 $ ns, s, q, 1, w, iw, info)
343 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
344 infot = 10
345 CALL dbdsvdx( 'L', 'V', 'I', 4, d, e, zero, zero, 3, 5,
346 $ ns, s, q, 1, w, iw, info)
347 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
348 infot = 14
349 CALL dbdsvdx( 'L', 'V', 'A', 4, d, e, zero, zero, 0, 0,
350 $ ns, s, q, 0, w, iw, info)
351 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
352 infot = 14
353 CALL dbdsvdx( 'L', 'V', 'A', 4, d, e, zero, zero, 0, 0,
354 $ ns, s, q, 2, w, iw, info)
355 CALL chkxer( 'DBDSVDX', infot, nout, lerr, ok )
356 nt = nt + 12
357 END IF
358*
359* Print a summary line.
360*
361 IF( ok ) THEN
362 WRITE( nout, fmt = 9999 )path, nt
363 ELSE
364 WRITE( nout, fmt = 9998 )path
365 END IF
366*
367 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits',
368 $ ' (', i3, ' tests done)' )
369 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
370 $ 'exits ***' )
371*
372 RETURN
373*
374* End of DERRBD
375*
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3196
lsamen
logical function lsamen(n, ca, cb)
LSAMEN
Definition lsamen.f:74
dgebd2
subroutine dgebd2(m, n, a, lda, d, e, tauq, taup, work, info)
DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
Definition dgebd2.f:189
dormbr
subroutine dormbr(vect, side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
DORMBR
Definition dormbr.f:195

◆ derrec()

subroutine derrec ( character*3 path,
integer nunit )

DERREC

Purpose:
!>
!> DERREC tests the error exits for the routines for eigen- condition
!> estimation for DOUBLE PRECISION matrices:
!>    DTRSYL, DTREXC, DTRSNA and DTRSEN.
!>
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 derrec.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
70 DOUBLE PRECISION ONE, ZERO
71 parameter( nmax = 4, one = 1.0d0, zero = 0.0d0 )
72* ..
73* .. Local Scalars ..
74 INTEGER I, IFST, ILST, INFO, J, M, NT
75 DOUBLE PRECISION SCALE
76* ..
77* .. Local Arrays ..
78 LOGICAL SEL( NMAX )
79 INTEGER IWORK( NMAX )
80 DOUBLE PRECISION A( NMAX, NMAX ), B( NMAX, NMAX ),
81 $ C( NMAX, NMAX ), S( NMAX ), SEP( NMAX ),
82 $ WI( NMAX ), WORK( NMAX ), WR( NMAX )
83* ..
84* .. External Subroutines ..
85 EXTERNAL chkxer, dtrexc, dtrsen, dtrsna, dtrsyl
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 DTRSYL
116*
117 srnamt = 'DTRSYL'
118 infot = 1
119 CALL dtrsyl( 'X', 'N', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
120 CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
121 infot = 2
122 CALL dtrsyl( 'N', 'X', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
123 CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
124 infot = 3
125 CALL dtrsyl( 'N', 'N', 0, 0, 0, a, 1, b, 1, c, 1, scale, info )
126 CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
127 infot = 4
128 CALL dtrsyl( 'N', 'N', 1, -1, 0, a, 1, b, 1, c, 1, scale, info )
129 CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
130 infot = 5
131 CALL dtrsyl( 'N', 'N', 1, 0, -1, a, 1, b, 1, c, 1, scale, info )
132 CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
133 infot = 7
134 CALL dtrsyl( 'N', 'N', 1, 2, 0, a, 1, b, 1, c, 2, scale, info )
135 CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
136 infot = 9
137 CALL dtrsyl( 'N', 'N', 1, 0, 2, a, 1, b, 1, c, 1, scale, info )
138 CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
139 infot = 11
140 CALL dtrsyl( 'N', 'N', 1, 2, 0, a, 2, b, 1, c, 1, scale, info )
141 CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
142 nt = nt + 8
143*
144* Test DTREXC
145*
146 srnamt = 'DTREXC'
147 ifst = 1
148 ilst = 1
149 infot = 1
150 CALL dtrexc( 'X', 1, a, 1, b, 1, ifst, ilst, work, info )
151 CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
152 infot = 2
153 CALL dtrexc( 'N', -1, a, 1, b, 1, ifst, ilst, work, info )
154 CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
155 infot = 4
156 ilst = 2
157 CALL dtrexc( 'N', 2, a, 1, b, 1, ifst, ilst, work, info )
158 CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
159 infot = 6
160 CALL dtrexc( 'V', 2, a, 2, b, 1, ifst, ilst, work, info )
161 CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
162 infot = 7
163 ifst = 0
164 ilst = 1
165 CALL dtrexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
166 CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
167 infot = 7
168 ifst = 2
169 CALL dtrexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
170 CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
171 infot = 8
172 ifst = 1
173 ilst = 0
174 CALL dtrexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
175 CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
176 infot = 8
177 ilst = 2
178 CALL dtrexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
179 CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
180 nt = nt + 8
181*
182* Test DTRSNA
183*
184 srnamt = 'DTRSNA'
185 infot = 1
186 CALL dtrsna( 'X', 'A', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
187 $ work, 1, iwork, info )
188 CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
189 infot = 2
190 CALL dtrsna( 'B', 'X', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
191 $ work, 1, iwork, info )
192 CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
193 infot = 4
194 CALL dtrsna( 'B', 'A', sel, -1, a, 1, b, 1, c, 1, s, sep, 1, m,
195 $ work, 1, iwork, info )
196 CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
197 infot = 6
198 CALL dtrsna( 'V', 'A', sel, 2, a, 1, b, 1, c, 1, s, sep, 2, m,
199 $ work, 2, iwork, info )
200 CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
201 infot = 8
202 CALL dtrsna( 'B', 'A', sel, 2, a, 2, b, 1, c, 2, s, sep, 2, m,
203 $ work, 2, iwork, info )
204 CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
205 infot = 10
206 CALL dtrsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 1, s, sep, 2, m,
207 $ work, 2, iwork, info )
208 CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
209 infot = 13
210 CALL dtrsna( 'B', 'A', sel, 1, a, 1, b, 1, c, 1, s, sep, 0, m,
211 $ work, 1, iwork, info )
212 CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
213 infot = 13
214 CALL dtrsna( 'B', 'S', sel, 2, a, 2, b, 2, c, 2, s, sep, 1, m,
215 $ work, 2, iwork, info )
216 CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
217 infot = 16
218 CALL dtrsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 2, s, sep, 2, m,
219 $ work, 1, iwork, info )
220 CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
221 nt = nt + 9
222*
223* Test DTRSEN
224*
225 sel( 1 ) = .false.
226 srnamt = 'DTRSEN'
227 infot = 1
228 CALL dtrsen( 'X', 'N', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
229 $ sep( 1 ), work, 1, iwork, 1, info )
230 CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
231 infot = 2
232 CALL dtrsen( 'N', 'X', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
233 $ sep( 1 ), work, 1, iwork, 1, info )
234 CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
235 infot = 4
236 CALL dtrsen( 'N', 'N', sel, -1, a, 1, b, 1, wr, wi, m, s( 1 ),
237 $ sep( 1 ), work, 1, iwork, 1, info )
238 CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
239 infot = 6
240 CALL dtrsen( 'N', 'N', sel, 2, a, 1, b, 1, wr, wi, m, s( 1 ),
241 $ sep( 1 ), work, 2, iwork, 1, info )
242 CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
243 infot = 8
244 CALL dtrsen( 'N', 'V', sel, 2, a, 2, b, 1, wr, wi, m, s( 1 ),
245 $ sep( 1 ), work, 1, iwork, 1, info )
246 CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
247 infot = 15
248 CALL dtrsen( 'N', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
249 $ sep( 1 ), work, 0, iwork, 1, info )
250 CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
251 infot = 15
252 CALL dtrsen( 'E', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
253 $ sep( 1 ), work, 1, iwork, 1, info )
254 CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
255 infot = 15
256 CALL dtrsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
257 $ sep( 1 ), work, 3, iwork, 2, info )
258 CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
259 infot = 17
260 CALL dtrsen( 'E', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
261 $ sep( 1 ), work, 1, iwork, 0, info )
262 CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
263 infot = 17
264 CALL dtrsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
265 $ sep( 1 ), work, 4, iwork, 1, info )
266 CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
267 nt = nt + 10
268*
269* Print a summary line.
270*
271 IF( ok ) THEN
272 WRITE( nout, fmt = 9999 )path, nt
273 ELSE
274 WRITE( nout, fmt = 9998 )path
275 END IF
276*
277 RETURN
278 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits (',
279 $ i3, ' tests done)' )
280 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ex',
281 $ 'its ***' )
282*
283* End of DERREC
284*
dtrexc
subroutine dtrexc(compq, n, t, ldt, q, ldq, ifst, ilst, work, info)
DTREXC
Definition dtrexc.f:148
dtrsna
subroutine dtrsna(job, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, s, sep, mm, m, work, ldwork, iwork, info)
DTRSNA
Definition dtrsna.f:265
dtrsen
subroutine dtrsen(job, compq, select, n, t, ldt, q, ldq, wr, wi, m, s, sep, work, lwork, iwork, liwork, info)
DTRSEN
Definition dtrsen.f:313
dtrsyl
subroutine dtrsyl(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
DTRSYL
Definition dtrsyl.f:164

◆ derred()

subroutine derred ( character*3 path,
integer nunit )

DERRED

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

◆ derrgg()

subroutine derrgg ( character*3 path,
integer nunit )

DERRGG

Purpose:
!>
!> DERRGG tests the error exits for DGGES, DGGESX, DGGEV,  DGGEVX,
!> DGGGLM, DGGHRD, DGGLSE, DGGQRF, DGGRQF, DGGSVD3,
!> DGGSVP3, DHGEQZ, DORCSD, DTGEVC, DTGEXC, DTGSEN, DTGSJA, DTGSNA,
!> DGGES3, DGGEV3, and DTGSYL.
!>
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 derrgg.f.

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

◆ derrhs()

subroutine derrhs ( character*3 path,
integer nunit )

DERRHS

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

◆ derrst()

subroutine derrst ( character*3 path,
integer nunit )

DERRST

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

◆ dget02()

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

DGET02

Purpose:
!>
!> DGET02 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 or A**T, depending on TRANS, and EPS is the
!> machine epsilon.
!> The norm used is the 1-norm.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A    * X = B  (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!>
[in]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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

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

◆ dget10()

subroutine dget10 ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) work,
double precision result )

DGET10

Purpose:
!>
!> DGET10 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION
!>          RESULT = norm( A - B ) / ( norm(A) * M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 92 of file dget10.f.

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

◆ dget22()

subroutine dget22 ( character transa,
character transe,
character transw,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( lde, * ) e,
integer lde,
double precision, dimension( * ) wr,
double precision, dimension( * ) wi,
double precision, dimension( * ) work,
double precision, dimension( 2 ) result )

DGET22

Purpose:
!>
!> DGET22 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.  If an eigenvector is complex, as determined from WI(j)
!> nonzero, then the max-norm of the vector ( er + i*ei ) is the maximum
!> of
!>    |er(1)| + |ei(1)|, ... , |er(n)| + |ei(n)|
!>
!> W is a block diagonal matrix, with a 1 by 1 block for each real
!> eigenvalue and a 2 by 2 block for each complex conjugate pair.
!> If eigenvalues j and j+1 are a complex conjugate pair, so that
!> WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the 2 by 2
!> block corresponding to the pair will be:
!>
!>    (  wr  wi  )
!>    ( -wi  wr  )
!>
!> Such a block multiplying an n by 2 matrix ( ur ui ) on the right
!> will be the same as multiplying  ur + i*ui  by  wr + i*wi.
!>
!> To handle various schemes for storage of left eigenvectors, there are
!> options to use A-transpose instead of A, E-transpose instead of E,
!> and/or W-transpose instead of W.
!>
Parameters
[in]TRANSA
!>          TRANSA is CHARACTER*1
!>          Specifies whether or not A is transposed.
!>          = 'N':  No transpose
!>          = 'T':  Transpose
!>          = 'C':  Conjugate transpose (= 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 (= Transpose)
!>
[in]TRANSW
!>          TRANSW is CHARACTER*1
!>          Specifies whether or not W is transposed.
!>          = 'N':  No transpose
!>          = 'T':  Transpose, use -WI(j) instead of WI(j)
!>          = '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 DOUBLE PRECISION 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 DOUBLE PRECISION 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]WR
!>          WR is DOUBLE PRECISION array, dimension (N)
!>
[in]WI
!>          WI is DOUBLE PRECISION array, dimension (N)
!>
!>          The real and imaginary parts of the eigenvalues of A.
!>          Purely real eigenvalues are indicated by WI(j) = 0.
!>          Complex conjugate pairs are indicated by WR(j)=WR(j+1) and
!>          WI(j) = - WI(j+1) non-zero; the real part is assumed to be
!>          stored in the j-th row/column and the imaginary part in
!>          the (j+1)-th row/column.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N*(N+1))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          RESULT(1) = | A E  -  E W | / ( |A| |E| ulp )
!>          RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
!>                       j
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 166 of file dget22.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 CHARACTER TRANSA, TRANSE, TRANSW
175 INTEGER LDA, LDE, N
176* ..
177* .. Array Arguments ..
178 DOUBLE PRECISION A( LDA, * ), E( LDE, * ), RESULT( 2 ), WI( * ),
179 $ WORK( * ), WR( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 DOUBLE PRECISION ZERO, ONE
186 parameter( zero = 0.0d0, one = 1.0d0 )
187* ..
188* .. Local Scalars ..
189 CHARACTER NORMA, NORME
190 INTEGER IECOL, IEROW, INCE, IPAIR, ITRNSE, J, JCOL,
191 $ JVEC
192 DOUBLE PRECISION ANORM, ENORM, ENRMAX, ENRMIN, ERRNRM, TEMP1,
193 $ ULP, UNFL
194* ..
195* .. Local Arrays ..
196 DOUBLE PRECISION WMAT( 2, 2 )
197* ..
198* .. External Functions ..
199 LOGICAL LSAME
200 DOUBLE PRECISION DLAMCH, DLANGE
201 EXTERNAL lsame, dlamch, dlange
202* ..
203* .. External Subroutines ..
204 EXTERNAL daxpy, dgemm, dlaset
205* ..
206* .. Intrinsic Functions ..
207 INTRINSIC abs, dble, max, min
208* ..
209* .. Executable Statements ..
210*
211* Initialize RESULT (in case N=0)
212*
213 result( 1 ) = zero
214 result( 2 ) = zero
215 IF( n.LE.0 )
216 $ RETURN
217*
218 unfl = dlamch( 'Safe minimum' )
219 ulp = dlamch( 'Precision' )
220*
221 itrnse = 0
222 ince = 1
223 norma = 'O'
224 norme = 'O'
225*
226 IF( lsame( transa, 'T' ) .OR. lsame( transa, 'C' ) ) THEN
227 norma = 'I'
228 END IF
229 IF( lsame( transe, 'T' ) .OR. lsame( transe, 'C' ) ) THEN
230 norme = 'I'
231 itrnse = 1
232 ince = lde
233 END IF
234*
235* Check normalization of E
236*
237 enrmin = one / ulp
238 enrmax = zero
239 IF( itrnse.EQ.0 ) THEN
240*
241* Eigenvectors are column vectors.
242*
243 ipair = 0
244 DO 30 jvec = 1, n
245 temp1 = zero
246 IF( ipair.EQ.0 .AND. jvec.LT.n .AND. wi( jvec ).NE.zero )
247 $ ipair = 1
248 IF( ipair.EQ.1 ) THEN
249*
250* Complex eigenvector
251*
252 DO 10 j = 1, n
253 temp1 = max( temp1, abs( e( j, jvec ) )+
254 $ abs( e( j, jvec+1 ) ) )
255 10 CONTINUE
256 enrmin = min( enrmin, temp1 )
257 enrmax = max( enrmax, temp1 )
258 ipair = 2
259 ELSE IF( ipair.EQ.2 ) THEN
260 ipair = 0
261 ELSE
262*
263* Real eigenvector
264*
265 DO 20 j = 1, n
266 temp1 = max( temp1, abs( e( j, jvec ) ) )
267 20 CONTINUE
268 enrmin = min( enrmin, temp1 )
269 enrmax = max( enrmax, temp1 )
270 ipair = 0
271 END IF
272 30 CONTINUE
273*
274 ELSE
275*
276* Eigenvectors are row vectors.
277*
278 DO 40 jvec = 1, n
279 work( jvec ) = zero
280 40 CONTINUE
281*
282 DO 60 j = 1, n
283 ipair = 0
284 DO 50 jvec = 1, n
285 IF( ipair.EQ.0 .AND. jvec.LT.n .AND. wi( jvec ).NE.zero )
286 $ ipair = 1
287 IF( ipair.EQ.1 ) THEN
288 work( jvec ) = max( work( jvec ),
289 $ abs( e( j, jvec ) )+abs( e( j,
290 $ jvec+1 ) ) )
291 work( jvec+1 ) = work( jvec )
292 ELSE IF( ipair.EQ.2 ) THEN
293 ipair = 0
294 ELSE
295 work( jvec ) = max( work( jvec ),
296 $ abs( e( j, jvec ) ) )
297 ipair = 0
298 END IF
299 50 CONTINUE
300 60 CONTINUE
301*
302 DO 70 jvec = 1, n
303 enrmin = min( enrmin, work( jvec ) )
304 enrmax = max( enrmax, work( jvec ) )
305 70 CONTINUE
306 END IF
307*
308* Norm of A:
309*
310 anorm = max( dlange( norma, n, n, a, lda, work ), unfl )
311*
312* Norm of E:
313*
314 enorm = max( dlange( norme, n, n, e, lde, work ), ulp )
315*
316* Norm of error:
317*
318* Error = AE - EW
319*
320 CALL dlaset( 'Full', n, n, zero, zero, work, n )
321*
322 ipair = 0
323 ierow = 1
324 iecol = 1
325*
326 DO 80 jcol = 1, n
327 IF( itrnse.EQ.1 ) THEN
328 ierow = jcol
329 ELSE
330 iecol = jcol
331 END IF
332*
333 IF( ipair.EQ.0 .AND. wi( jcol ).NE.zero )
334 $ ipair = 1
335*
336 IF( ipair.EQ.1 ) THEN
337 wmat( 1, 1 ) = wr( jcol )
338 wmat( 2, 1 ) = -wi( jcol )
339 wmat( 1, 2 ) = wi( jcol )
340 wmat( 2, 2 ) = wr( jcol )
341 CALL dgemm( transe, transw, n, 2, 2, one, e( ierow, iecol ),
342 $ lde, wmat, 2, zero, work( n*( jcol-1 )+1 ), n )
343 ipair = 2
344 ELSE IF( ipair.EQ.2 ) THEN
345 ipair = 0
346*
347 ELSE
348*
349 CALL daxpy( n, wr( jcol ), e( ierow, iecol ), ince,
350 $ work( n*( jcol-1 )+1 ), 1 )
351 ipair = 0
352 END IF
353*
354 80 CONTINUE
355*
356 CALL dgemm( transa, transe, n, n, n, one, a, lda, e, lde, -one,
357 $ work, n )
358*
359 errnrm = dlange( 'One', n, n, work, n, work( n*n+1 ) ) / enorm
360*
361* Compute RESULT(1) (avoiding under/overflow)
362*
363 IF( anorm.GT.errnrm ) THEN
364 result( 1 ) = ( errnrm / anorm ) / ulp
365 ELSE
366 IF( anorm.LT.one ) THEN
367 result( 1 ) = one / ulp
368 ELSE
369 result( 1 ) = min( errnrm / anorm, one ) / ulp
370 END IF
371 END IF
372*
373* Compute RESULT(2) : the normalization error in E.
374*
375 result( 2 ) = max( abs( enrmax-one ), abs( enrmin-one ) ) /
376 $ ( dble( n )*ulp )
377*
378 RETURN
379*
380* End of DGET22
381*

◆ dget23()

subroutine dget23 ( logical comp,
character balanc,
integer jtype,
double precision thresh,
integer, dimension( 4 ) iseed,
integer nounit,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( lda, * ) h,
double precision, dimension( * ) wr,
double precision, dimension( * ) wi,
double precision, dimension( * ) wr1,
double precision, dimension( * ) wi1,
double precision, dimension( ldvl, * ) vl,
integer ldvl,
double precision, dimension( ldvr, * ) vr,
integer ldvr,
double precision, dimension( ldlre, * ) lre,
integer ldlre,
double precision, dimension( * ) rcondv,
double precision, dimension( * ) rcndv1,
double precision, dimension( * ) rcdvin,
double precision, dimension( * ) rconde,
double precision, dimension( * ) rcnde1,
double precision, dimension( * ) rcdein,
double precision, dimension( * ) scale,
double precision, dimension( * ) scale1,
double precision, dimension( 11 ) result,
double precision, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer info )

DGET23

Purpose:
!>
!>    DGET23  checks the nonsymmetric eigenvalue problem driver SGEEVX.
!>    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 block diagonal matrix, with a 1x1 block for each
!>      real eigenvalue and a 2x2 block for each complex conjugate
!>      pair.  If eigenvalues j and j+1 are a complex conjugate pair,
!>      so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
!>      2 x 2 block corresponding to the pair will be:
!>
!>              (  wr  wi  )
!>              ( -wi  wr  )
!>
!>      Such a block multiplying an n x 2 matrix  ( ur ui ) on the
!>      right will be the same as multiplying  ur + i*ui  by  wr + i*wi.
!>
!>    (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 DGEEVX 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 DGEEVX 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]BALANC
!>          BALANC is CHARACTER
!>          Describes the balancing option to be tested.
!>            = 'N' for no permuting or diagonal scaling
!>            = 'P' for permuting but no diagonal scaling
!>            = 'S' for no permuting but diagonal scaling
!>            = 'B' for permuting and diagonal scaling
!>
[in]JTYPE
!>          JTYPE is INTEGER
!>          Type of input matrix. Used to label output if error occurs.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          If COMP = .FALSE., the random number generator seed
!>          used to produce matrix.
!>          If COMP = .TRUE., ISEED(1) = the number of the example.
!>          Used to label output if error occurs.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[in]N
!>          N is INTEGER
!>          The dimension of A. N must be at least 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          Another copy of the test matrix A, modified by DGEEVX.
!>
[out]WR
!>          WR is DOUBLE PRECISION array, dimension (N)
!>
[out]WI
!>          WI is DOUBLE PRECISION array, dimension (N)
!>
!>          The real and imaginary parts of the eigenvalues of A.
!>          On exit, WR + WI*i are the eigenvalues of the matrix in A.
!>
[out]WR1
!>          WR1 is DOUBLE PRECISION array, dimension (N)
!>
[out]WI1
!>          WI1 is DOUBLE PRECISION array, dimension (N)
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when DGEEVX only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDLRE,N)
!>          LRE holds the computed right or left eigenvectors.
!>
[in]LDLRE
!>          LDLRE is INTEGER
!>          Leading dimension of LRE. Must be at least max(1,N).
!>
[out]RCONDV
!>          RCONDV is DOUBLE PRECISION array, dimension (N)
!>          RCONDV holds the computed reciprocal condition numbers
!>          for eigenvectors.
!>
[out]RCNDV1
!>          RCNDV1 is DOUBLE PRECISION array, dimension (N)
!>          RCNDV1 holds more computed reciprocal condition numbers
!>          for eigenvectors.
!>
[in]RCDVIN
!>          RCDVIN is DOUBLE PRECISION array, dimension (N)
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition numbers for eigenvectors to be compared with
!>          RCONDV.
!>
[out]RCONDE
!>          RCONDE is DOUBLE PRECISION array, dimension (N)
!>          RCONDE holds the computed reciprocal condition numbers
!>          for eigenvalues.
!>
[out]RCNDE1
!>          RCNDE1 is DOUBLE PRECISION array, dimension (N)
!>          RCNDE1 holds more computed reciprocal condition numbers
!>          for eigenvalues.
!>
[in]RCDEIN
!>          RCDEIN is DOUBLE PRECISION array, dimension (N)
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition numbers for eigenvalues to be compared with
!>          RCONDE.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]SCALE1
!>          SCALE1 is DOUBLE PRECISION array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (11)
!>          The values computed by the 11 tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK.  This must be at least
!>          3*N, and 6*N+N**2 if tests 9, 10 or 11 are to be performed.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0,  successful exit.
!>          If <0, input parameter -INFO had an incorrect value.
!>          If >0, DGEEVX 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 373 of file dget23.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 LOGICAL COMP
385 CHARACTER BALANC
386 INTEGER INFO, JTYPE, LDA, LDLRE, LDVL, LDVR, LWORK, N,
387 $ NOUNIT
388 DOUBLE PRECISION THRESH
389* ..
390* .. Array Arguments ..
391 INTEGER ISEED( 4 ), IWORK( * )
392 DOUBLE PRECISION A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
393 $ RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
394 $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
395 $ RESULT( 11 ), SCALE( * ), SCALE1( * ),
396 $ VL( LDVL, * ), VR( LDVR, * ), WI( * ),
397 $ WI1( * ), WORK( * ), WR( * ), WR1( * )
398* ..
399*
400* =====================================================================
401*
402*
403* .. Parameters ..
404 DOUBLE PRECISION ZERO, ONE, TWO
405 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
406 DOUBLE PRECISION EPSIN
407 parameter( epsin = 5.9605d-8 )
408* ..
409* .. Local Scalars ..
410 LOGICAL BALOK, NOBAL
411 CHARACTER SENSE
412 INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM,
413 $ J, JJ, KMIN
414 DOUBLE PRECISION ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN,
415 $ ULP, ULPINV, V, VIMIN, VMAX, VMX, VRMIN, VRMX,
416 $ VTST
417* ..
418* .. Local Arrays ..
419 CHARACTER SENS( 2 )
420 DOUBLE PRECISION DUM( 1 ), RES( 2 )
421* ..
422* .. External Functions ..
423 LOGICAL LSAME
424 DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
425 EXTERNAL lsame, dlamch, dlapy2, dnrm2
426* ..
427* .. External Subroutines ..
428 EXTERNAL dgeevx, dget22, dlacpy, xerbla
429* ..
430* .. Intrinsic Functions ..
431 INTRINSIC abs, dble, max, min
432* ..
433* .. Data statements ..
434 DATA sens / 'N', 'V' /
435* ..
436* .. Executable Statements ..
437*
438* Check for errors
439*
440 nobal = lsame( balanc, 'N' )
441 balok = nobal .OR. lsame( balanc, 'P' ) .OR.
442 $ lsame( balanc, 'S' ) .OR. lsame( balanc, 'B' )
443 info = 0
444 IF( .NOT.balok ) THEN
445 info = -2
446 ELSE IF( thresh.LT.zero ) THEN
447 info = -4
448 ELSE IF( nounit.LE.0 ) THEN
449 info = -6
450 ELSE IF( n.LT.0 ) THEN
451 info = -7
452 ELSE IF( lda.LT.1 .OR. lda.LT.n ) THEN
453 info = -9
454 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.n ) THEN
455 info = -16
456 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.n ) THEN
457 info = -18
458 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.n ) THEN
459 info = -20
460 ELSE IF( lwork.LT.3*n .OR. ( comp .AND. lwork.LT.6*n+n*n ) ) THEN
461 info = -31
462 END IF
463*
464 IF( info.NE.0 ) THEN
465 CALL xerbla( 'DGET23', -info )
466 RETURN
467 END IF
468*
469* Quick return if nothing to do
470*
471 DO 10 i = 1, 11
472 result( i ) = -one
473 10 CONTINUE
474*
475 IF( n.EQ.0 )
476 $ RETURN
477*
478* More Important constants
479*
480 ulp = dlamch( 'Precision' )
481 smlnum = dlamch( 'S' )
482 ulpinv = one / ulp
483*
484* Compute eigenvalues and eigenvectors, and test them
485*
486 IF( lwork.GE.6*n+n*n ) THEN
487 sense = 'B'
488 isensm = 2
489 ELSE
490 sense = 'E'
491 isensm = 1
492 END IF
493 CALL dlacpy( 'F', n, n, a, lda, h, lda )
494 CALL dgeevx( balanc, 'V', 'V', sense, n, h, lda, wr, wi, vl, ldvl,
495 $ vr, ldvr, ilo, ihi, scale, abnrm, rconde, rcondv,
496 $ work, lwork, iwork, iinfo )
497 IF( iinfo.NE.0 ) THEN
498 result( 1 ) = ulpinv
499 IF( jtype.NE.22 ) THEN
500 WRITE( nounit, fmt = 9998 )'DGEEVX1', iinfo, n, jtype,
501 $ balanc, iseed
502 ELSE
503 WRITE( nounit, fmt = 9999 )'DGEEVX1', iinfo, n, iseed( 1 )
504 END IF
505 info = abs( iinfo )
506 RETURN
507 END IF
508*
509* Do Test (1)
510*
511 CALL dget22( 'N', 'N', 'N', n, a, lda, vr, ldvr, wr, wi, work,
512 $ res )
513 result( 1 ) = res( 1 )
514*
515* Do Test (2)
516*
517 CALL dget22( 'T', 'N', 'T', n, a, lda, vl, ldvl, wr, wi, work,
518 $ res )
519 result( 2 ) = res( 1 )
520*
521* Do Test (3)
522*
523 DO 30 j = 1, n
524 tnrm = one
525 IF( wi( j ).EQ.zero ) THEN
526 tnrm = dnrm2( n, vr( 1, j ), 1 )
527 ELSE IF( wi( j ).GT.zero ) THEN
528 tnrm = dlapy2( dnrm2( n, vr( 1, j ), 1 ),
529 $ dnrm2( n, vr( 1, j+1 ), 1 ) )
530 END IF
531 result( 3 ) = max( result( 3 ),
532 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
533 IF( wi( j ).GT.zero ) THEN
534 vmx = zero
535 vrmx = zero
536 DO 20 jj = 1, n
537 vtst = dlapy2( vr( jj, j ), vr( jj, j+1 ) )
538 IF( vtst.GT.vmx )
539 $ vmx = vtst
540 IF( vr( jj, j+1 ).EQ.zero .AND. abs( vr( jj, j ) ).GT.
541 $ vrmx )vrmx = abs( vr( jj, j ) )
542 20 CONTINUE
543 IF( vrmx / vmx.LT.one-two*ulp )
544 $ result( 3 ) = ulpinv
545 END IF
546 30 CONTINUE
547*
548* Do Test (4)
549*
550 DO 50 j = 1, n
551 tnrm = one
552 IF( wi( j ).EQ.zero ) THEN
553 tnrm = dnrm2( n, vl( 1, j ), 1 )
554 ELSE IF( wi( j ).GT.zero ) THEN
555 tnrm = dlapy2( dnrm2( n, vl( 1, j ), 1 ),
556 $ dnrm2( n, vl( 1, j+1 ), 1 ) )
557 END IF
558 result( 4 ) = max( result( 4 ),
559 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
560 IF( wi( j ).GT.zero ) THEN
561 vmx = zero
562 vrmx = zero
563 DO 40 jj = 1, n
564 vtst = dlapy2( vl( jj, j ), vl( jj, j+1 ) )
565 IF( vtst.GT.vmx )
566 $ vmx = vtst
567 IF( vl( jj, j+1 ).EQ.zero .AND. abs( vl( jj, j ) ).GT.
568 $ vrmx )vrmx = abs( vl( jj, j ) )
569 40 CONTINUE
570 IF( vrmx / vmx.LT.one-two*ulp )
571 $ result( 4 ) = ulpinv
572 END IF
573 50 CONTINUE
574*
575* Test for all options of computing condition numbers
576*
577 DO 200 isens = 1, isensm
578*
579 sense = sens( isens )
580*
581* Compute eigenvalues only, and test them
582*
583 CALL dlacpy( 'F', n, n, a, lda, h, lda )
584 CALL dgeevx( balanc, 'N', 'N', sense, n, h, lda, wr1, wi1, dum,
585 $ 1, dum, 1, ilo1, ihi1, scale1, abnrm1, rcnde1,
586 $ rcndv1, work, lwork, iwork, iinfo )
587 IF( iinfo.NE.0 ) THEN
588 result( 1 ) = ulpinv
589 IF( jtype.NE.22 ) THEN
590 WRITE( nounit, fmt = 9998 )'DGEEVX2', iinfo, n, jtype,
591 $ balanc, iseed
592 ELSE
593 WRITE( nounit, fmt = 9999 )'DGEEVX2', iinfo, n,
594 $ iseed( 1 )
595 END IF
596 info = abs( iinfo )
597 GO TO 190
598 END IF
599*
600* Do Test (5)
601*
602 DO 60 j = 1, n
603 IF( wr( j ).NE.wr1( j ) .OR. wi( j ).NE.wi1( j ) )
604 $ result( 5 ) = ulpinv
605 60 CONTINUE
606*
607* Do Test (8)
608*
609 IF( .NOT.nobal ) THEN
610 DO 70 j = 1, n
611 IF( scale( j ).NE.scale1( j ) )
612 $ result( 8 ) = ulpinv
613 70 CONTINUE
614 IF( ilo.NE.ilo1 )
615 $ result( 8 ) = ulpinv
616 IF( ihi.NE.ihi1 )
617 $ result( 8 ) = ulpinv
618 IF( abnrm.NE.abnrm1 )
619 $ result( 8 ) = ulpinv
620 END IF
621*
622* Do Test (9)
623*
624 IF( isens.EQ.2 .AND. n.GT.1 ) THEN
625 DO 80 j = 1, n
626 IF( rcondv( j ).NE.rcndv1( j ) )
627 $ result( 9 ) = ulpinv
628 80 CONTINUE
629 END IF
630*
631* Compute eigenvalues and right eigenvectors, and test them
632*
633 CALL dlacpy( 'F', n, n, a, lda, h, lda )
634 CALL dgeevx( balanc, 'N', 'V', sense, n, h, lda, wr1, wi1, dum,
635 $ 1, lre, ldlre, ilo1, ihi1, scale1, abnrm1, rcnde1,
636 $ rcndv1, work, lwork, iwork, iinfo )
637 IF( iinfo.NE.0 ) THEN
638 result( 1 ) = ulpinv
639 IF( jtype.NE.22 ) THEN
640 WRITE( nounit, fmt = 9998 )'DGEEVX3', iinfo, n, jtype,
641 $ balanc, iseed
642 ELSE
643 WRITE( nounit, fmt = 9999 )'DGEEVX3', iinfo, n,
644 $ iseed( 1 )
645 END IF
646 info = abs( iinfo )
647 GO TO 190
648 END IF
649*
650* Do Test (5) again
651*
652 DO 90 j = 1, n
653 IF( wr( j ).NE.wr1( j ) .OR. wi( j ).NE.wi1( j ) )
654 $ result( 5 ) = ulpinv
655 90 CONTINUE
656*
657* Do Test (6)
658*
659 DO 110 j = 1, n
660 DO 100 jj = 1, n
661 IF( vr( j, jj ).NE.lre( j, jj ) )
662 $ result( 6 ) = ulpinv
663 100 CONTINUE
664 110 CONTINUE
665*
666* Do Test (8) again
667*
668 IF( .NOT.nobal ) THEN
669 DO 120 j = 1, n
670 IF( scale( j ).NE.scale1( j ) )
671 $ result( 8 ) = ulpinv
672 120 CONTINUE
673 IF( ilo.NE.ilo1 )
674 $ result( 8 ) = ulpinv
675 IF( ihi.NE.ihi1 )
676 $ result( 8 ) = ulpinv
677 IF( abnrm.NE.abnrm1 )
678 $ result( 8 ) = ulpinv
679 END IF
680*
681* Do Test (9) again
682*
683 IF( isens.EQ.2 .AND. n.GT.1 ) THEN
684 DO 130 j = 1, n
685 IF( rcondv( j ).NE.rcndv1( j ) )
686 $ result( 9 ) = ulpinv
687 130 CONTINUE
688 END IF
689*
690* Compute eigenvalues and left eigenvectors, and test them
691*
692 CALL dlacpy( 'F', n, n, a, lda, h, lda )
693 CALL dgeevx( balanc, 'V', 'N', sense, n, h, lda, wr1, wi1, lre,
694 $ ldlre, dum, 1, ilo1, ihi1, scale1, abnrm1, rcnde1,
695 $ rcndv1, work, lwork, iwork, iinfo )
696 IF( iinfo.NE.0 ) THEN
697 result( 1 ) = ulpinv
698 IF( jtype.NE.22 ) THEN
699 WRITE( nounit, fmt = 9998 )'DGEEVX4', iinfo, n, jtype,
700 $ balanc, iseed
701 ELSE
702 WRITE( nounit, fmt = 9999 )'DGEEVX4', iinfo, n,
703 $ iseed( 1 )
704 END IF
705 info = abs( iinfo )
706 GO TO 190
707 END IF
708*
709* Do Test (5) again
710*
711 DO 140 j = 1, n
712 IF( wr( j ).NE.wr1( j ) .OR. wi( j ).NE.wi1( j ) )
713 $ result( 5 ) = ulpinv
714 140 CONTINUE
715*
716* Do Test (7)
717*
718 DO 160 j = 1, n
719 DO 150 jj = 1, n
720 IF( vl( j, jj ).NE.lre( j, jj ) )
721 $ result( 7 ) = ulpinv
722 150 CONTINUE
723 160 CONTINUE
724*
725* Do Test (8) again
726*
727 IF( .NOT.nobal ) THEN
728 DO 170 j = 1, n
729 IF( scale( j ).NE.scale1( j ) )
730 $ result( 8 ) = ulpinv
731 170 CONTINUE
732 IF( ilo.NE.ilo1 )
733 $ result( 8 ) = ulpinv
734 IF( ihi.NE.ihi1 )
735 $ result( 8 ) = ulpinv
736 IF( abnrm.NE.abnrm1 )
737 $ result( 8 ) = ulpinv
738 END IF
739*
740* Do Test (9) again
741*
742 IF( isens.EQ.2 .AND. n.GT.1 ) THEN
743 DO 180 j = 1, n
744 IF( rcondv( j ).NE.rcndv1( j ) )
745 $ result( 9 ) = ulpinv
746 180 CONTINUE
747 END IF
748*
749 190 CONTINUE
750*
751 200 CONTINUE
752*
753* If COMP, compare condition numbers to precomputed ones
754*
755 IF( comp ) THEN
756 CALL dlacpy( 'F', n, n, a, lda, h, lda )
757 CALL dgeevx( 'N', 'V', 'V', 'B', n, h, lda, wr, wi, vl, ldvl,
758 $ vr, ldvr, ilo, ihi, scale, abnrm, rconde, rcondv,
759 $ work, lwork, iwork, iinfo )
760 IF( iinfo.NE.0 ) THEN
761 result( 1 ) = ulpinv
762 WRITE( nounit, fmt = 9999 )'DGEEVX5', iinfo, n, iseed( 1 )
763 info = abs( iinfo )
764 GO TO 250
765 END IF
766*
767* Sort eigenvalues and condition numbers lexicographically
768* to compare with inputs
769*
770 DO 220 i = 1, n - 1
771 kmin = i
772 vrmin = wr( i )
773 vimin = wi( i )
774 DO 210 j = i + 1, n
775 IF( wr( j ).LT.vrmin ) THEN
776 kmin = j
777 vrmin = wr( j )
778 vimin = wi( j )
779 END IF
780 210 CONTINUE
781 wr( kmin ) = wr( i )
782 wi( kmin ) = wi( i )
783 wr( i ) = vrmin
784 wi( i ) = vimin
785 vrmin = rconde( kmin )
786 rconde( kmin ) = rconde( i )
787 rconde( i ) = vrmin
788 vrmin = rcondv( kmin )
789 rcondv( kmin ) = rcondv( i )
790 rcondv( i ) = vrmin
791 220 CONTINUE
792*
793* Compare condition numbers for eigenvectors
794* taking their condition numbers into account
795*
796 result( 10 ) = zero
797 eps = max( epsin, ulp )
798 v = max( dble( n )*eps*abnrm, smlnum )
799 IF( abnrm.EQ.zero )
800 $ v = one
801 DO 230 i = 1, n
802 IF( v.GT.rcondv( i )*rconde( i ) ) THEN
803 tol = rcondv( i )
804 ELSE
805 tol = v / rconde( i )
806 END IF
807 IF( v.GT.rcdvin( i )*rcdein( i ) ) THEN
808 tolin = rcdvin( i )
809 ELSE
810 tolin = v / rcdein( i )
811 END IF
812 tol = max( tol, smlnum / eps )
813 tolin = max( tolin, smlnum / eps )
814 IF( eps*( rcdvin( i )-tolin ).GT.rcondv( i )+tol ) THEN
815 vmax = one / eps
816 ELSE IF( rcdvin( i )-tolin.GT.rcondv( i )+tol ) THEN
817 vmax = ( rcdvin( i )-tolin ) / ( rcondv( i )+tol )
818 ELSE IF( rcdvin( i )+tolin.LT.eps*( rcondv( i )-tol ) ) THEN
819 vmax = one / eps
820 ELSE IF( rcdvin( i )+tolin.LT.rcondv( i )-tol ) THEN
821 vmax = ( rcondv( i )-tol ) / ( rcdvin( i )+tolin )
822 ELSE
823 vmax = one
824 END IF
825 result( 10 ) = max( result( 10 ), vmax )
826 230 CONTINUE
827*
828* Compare condition numbers for eigenvalues
829* taking their condition numbers into account
830*
831 result( 11 ) = zero
832 DO 240 i = 1, n
833 IF( v.GT.rcondv( i ) ) THEN
834 tol = one
835 ELSE
836 tol = v / rcondv( i )
837 END IF
838 IF( v.GT.rcdvin( i ) ) THEN
839 tolin = one
840 ELSE
841 tolin = v / rcdvin( i )
842 END IF
843 tol = max( tol, smlnum / eps )
844 tolin = max( tolin, smlnum / eps )
845 IF( eps*( rcdein( i )-tolin ).GT.rconde( i )+tol ) THEN
846 vmax = one / eps
847 ELSE IF( rcdein( i )-tolin.GT.rconde( i )+tol ) THEN
848 vmax = ( rcdein( i )-tolin ) / ( rconde( i )+tol )
849 ELSE IF( rcdein( i )+tolin.LT.eps*( rconde( i )-tol ) ) THEN
850 vmax = one / eps
851 ELSE IF( rcdein( i )+tolin.LT.rconde( i )-tol ) THEN
852 vmax = ( rconde( i )-tol ) / ( rcdein( i )+tolin )
853 ELSE
854 vmax = one
855 END IF
856 result( 11 ) = max( result( 11 ), vmax )
857 240 CONTINUE
858 250 CONTINUE
859*
860 END IF
861*
862 9999 FORMAT( ' DGET23: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
863 $ i6, ', INPUT EXAMPLE NUMBER = ', i4 )
864 9998 FORMAT( ' DGET23: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
865 $ i6, ', JTYPE=', i6, ', BALANC = ', a, ', ISEED=(',
866 $ 3( i5, ',' ), i5, ')' )
867*
868 RETURN
869*
870* End of DGET23
871*
comp
int comp(int a, int b)
Definition set_surface_lines.cpp:102

◆ dget24()

subroutine dget24 ( logical comp,
integer jtype,
double precision thresh,
integer, dimension( 4 ) iseed,
integer nounit,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( lda, * ) h,
double precision, dimension( lda, * ) ht,
double precision, dimension( * ) wr,
double precision, dimension( * ) wi,
double precision, dimension( * ) wrt,
double precision, dimension( * ) wit,
double precision, dimension( * ) wrtmp,
double precision, dimension( * ) witmp,
double precision, dimension( ldvs, * ) vs,
integer ldvs,
double precision, dimension( ldvs, * ) vs1,
double precision rcdein,
double precision rcdvin,
integer nslct,
integer, dimension( * ) islct,
double precision, dimension( 17 ) result,
double precision, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
logical, dimension( * ) bwork,
integer info )

DGET24

Purpose:
!>
!>    DGET24 checks the nonsymmetric eigenvalue (Schur form) problem
!>    expert driver DGEESX.
!>
!>    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 WR+sqrt(-1)*WI 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 WR+sqrt(-1)*WI are eigenvalues of T
!>            1/ulp otherwise
!>            If workspace sufficient, also compare WR, WI 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 DGEESX 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 DGEESX and RCDVIN (the precomputed true
!>       value) is supplied as input. cond(RCONDV) is the condition
!>       number of RCONDV, and takes errors in computing RCONDV into
!>       account, so that the resulting quantity should be O(ULP).
!>       cond(RCONDV) is essentially given by norm(A)/RCONDE.
!>
Parameters
[in]COMP
!>          COMP is LOGICAL
!>          COMP describes which input tests to perform:
!>            = .FALSE. if the computed condition numbers are not to
!>                      be tested against RCDVIN and RCDEIN
!>            = .TRUE.  if they are to be compared
!>
[in]JTYPE
!>          JTYPE is INTEGER
!>          Type of input matrix. Used to label output if error occurs.
!>
[in]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          If COMP = .FALSE., the random number generator seed
!>          used to produce matrix.
!>          If COMP = .TRUE., ISEED(1) = the number of the example.
!>          Used to label output if error occurs.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[in]N
!>          N is INTEGER
!>          The dimension of A. N must be at least 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDA, N)
!>          Another copy of the test matrix A, modified by DGEESX.
!>
[out]HT
!>          HT is DOUBLE PRECISION array, dimension (LDA, N)
!>          Yet another copy of the test matrix A, modified by DGEESX.
!>
[out]WR
!>          WR is DOUBLE PRECISION array, dimension (N)
!>
[out]WI
!>          WI is DOUBLE PRECISION array, dimension (N)
!>
!>          The real and imaginary parts of the eigenvalues of A.
!>          On exit, WR + WI*i are the eigenvalues of the matrix in A.
!>
[out]WRT
!>          WRT is DOUBLE PRECISION array, dimension (N)
!>
[out]WIT
!>          WIT is DOUBLE PRECISION array, dimension (N)
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when DGEESX only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]WRTMP
!>          WRTMP is DOUBLE PRECISION array, dimension (N)
!>
[out]WITMP
!>          WITMP is DOUBLE PRECISION array, dimension (N)
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but sorted by increasing real part.
!>
[out]VS
!>          VS is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDVS, N)
!>          VS1 holds another copy of the computed Schur vectors.
!>
[in]RCDEIN
!>          RCDEIN is DOUBLE PRECISION
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition number for the average of selected eigenvalues.
!>
[in]RCDVIN
!>          RCDVIN is DOUBLE PRECISION
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition number for the selected right invariant subspace.
!>
[in]NSLCT
!>          NSLCT is INTEGER
!>          When COMP = .TRUE. the number of selected eigenvalues
!>          corresponding to the precomputed values RCDEIN and RCDVIN.
!>
[in]ISLCT
!>          ISLCT is INTEGER array, dimension (NSLCT)
!>          When COMP = .TRUE. ISLCT selects the eigenvalues of the
!>          input matrix corresponding to the precomputed values RCDEIN
!>          and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the
!>          eigenvalue with the J-th largest real part is selected.
!>          Not referenced if COMP = .FALSE.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (17)
!>          The values computed by the 17 tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK to be passed to DGEESX. This
!>          must be at least 3*N, and N+N**2 if tests 14--16 are to
!>          be performed.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N*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, DGEESX 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 339 of file dget24.f.

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

◆ dget31()

subroutine dget31 ( double precision rmax,
integer lmax,
integer, dimension( 2 ) ninfo,
integer knt )

DGET31

Purpose:
!>
!> DGET31 tests DLALN2, a routine for solving
!>
!>    (ca A - w D)X = sB
!>
!> where A is an NA by NA matrix (NA=1 or 2 only), w is a real (NW=1) or
!> complex (NW=2) constant, ca is a real constant, D is an NA by NA real
!> diagonal matrix, and B is an NA by NW matrix (when NW=2 the second
!> column of B contains the imaginary part of the solution).  The code
!> returns X and s, where s is a scale factor, less than or equal to 1,
!> which is chosen to avoid overflow in X.
!>
!> If any singular values of ca A-w D are less than another input
!> parameter SMIN, they are perturbed up to SMIN.
!>
!> The test condition is that the scaled residual
!>
!>     norm( (ca A-w D)*X - s*B ) /
!>           ( max( ulp*norm(ca A-w D), SMIN )*norm(X) )
!>
!> should be on the order of 1.  Here, ulp is the machine precision.
!> Also, it is verified that SCALE is less than or equal to 1, and that
!> XNORM = infinity-norm(X).
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION
!>          Value of the largest test ratio.
!>
[out]LMAX
!>          LMAX is INTEGER
!>          Example number where largest test ratio achieved.
!>
[out]NINFO
!>          NINFO is INTEGER array, dimension (3)
!>          NINFO(1) = number of examples with INFO less than 0
!>          NINFO(2) = number of examples with INFO greater than 0
!>
[out]KNT
!>          KNT is INTEGER
!>          Total number of examples tested.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 90 of file dget31.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, LMAX
98 DOUBLE PRECISION RMAX
99* ..
100* .. Array Arguments ..
101 INTEGER NINFO( 2 )
102* ..
103*
104* =====================================================================
105*
106* .. Parameters ..
107 DOUBLE PRECISION ZERO, HALF, ONE
108 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
109 DOUBLE PRECISION TWO, THREE, FOUR
110 parameter( two = 2.0d0, three = 3.0d0, four = 4.0d0 )
111 DOUBLE PRECISION SEVEN, TEN
112 parameter( seven = 7.0d0, ten = 10.0d0 )
113 DOUBLE PRECISION TWNONE
114 parameter( twnone = 21.0d0 )
115* ..
116* .. Local Scalars ..
117 INTEGER IA, IB, ICA, ID1, ID2, INFO, ISMIN, ITRANS,
118 $ IWI, IWR, NA, NW
119 DOUBLE PRECISION BIGNUM, CA, D1, D2, DEN, EPS, RES, SCALE, SMIN,
120 $ SMLNUM, TMP, UNFL, WI, WR, XNORM
121* ..
122* .. Local Arrays ..
123 LOGICAL LTRANS( 0: 1 )
124 DOUBLE PRECISION A( 2, 2 ), B( 2, 2 ), VAB( 3 ), VCA( 5 ),
125 $ VDD( 4 ), VSMIN( 4 ), VWI( 4 ), VWR( 4 ),
126 $ X( 2, 2 )
127* ..
128* .. External Functions ..
129 DOUBLE PRECISION DLAMCH
130 EXTERNAL dlamch
131* ..
132* .. External Subroutines ..
133 EXTERNAL dlabad, dlaln2
134* ..
135* .. Intrinsic Functions ..
136 INTRINSIC abs, max, sqrt
137* ..
138* .. Data statements ..
139 DATA ltrans / .false., .true. /
140* ..
141* .. Executable Statements ..
142*
143* Get machine parameters
144*
145 eps = dlamch( 'P' )
146 unfl = dlamch( 'U' )
147 smlnum = dlamch( 'S' ) / eps
148 bignum = one / smlnum
149 CALL dlabad( smlnum, bignum )
150*
151* Set up test case parameters
152*
153 vsmin( 1 ) = smlnum
154 vsmin( 2 ) = eps
155 vsmin( 3 ) = one / ( ten*ten )
156 vsmin( 4 ) = one / eps
157 vab( 1 ) = sqrt( smlnum )
158 vab( 2 ) = one
159 vab( 3 ) = sqrt( bignum )
160 vwr( 1 ) = zero
161 vwr( 2 ) = half
162 vwr( 3 ) = two
163 vwr( 4 ) = one
164 vwi( 1 ) = smlnum
165 vwi( 2 ) = eps
166 vwi( 3 ) = one
167 vwi( 4 ) = two
168 vdd( 1 ) = sqrt( smlnum )
169 vdd( 2 ) = one
170 vdd( 3 ) = two
171 vdd( 4 ) = sqrt( bignum )
172 vca( 1 ) = zero
173 vca( 2 ) = sqrt( smlnum )
174 vca( 3 ) = eps
175 vca( 4 ) = half
176 vca( 5 ) = one
177*
178 knt = 0
179 ninfo( 1 ) = 0
180 ninfo( 2 ) = 0
181 lmax = 0
182 rmax = zero
183*
184* Begin test loop
185*
186 DO 190 id1 = 1, 4
187 d1 = vdd( id1 )
188 DO 180 id2 = 1, 4
189 d2 = vdd( id2 )
190 DO 170 ica = 1, 5
191 ca = vca( ica )
192 DO 160 itrans = 0, 1
193 DO 150 ismin = 1, 4
194 smin = vsmin( ismin )
195*
196 na = 1
197 nw = 1
198 DO 30 ia = 1, 3
199 a( 1, 1 ) = vab( ia )
200 DO 20 ib = 1, 3
201 b( 1, 1 ) = vab( ib )
202 DO 10 iwr = 1, 4
203 IF( d1.EQ.one .AND. d2.EQ.one .AND. ca.EQ.
204 $ one ) THEN
205 wr = vwr( iwr )*a( 1, 1 )
206 ELSE
207 wr = vwr( iwr )
208 END IF
209 wi = zero
210 CALL dlaln2( ltrans( itrans ), na, nw,
211 $ smin, ca, a, 2, d1, d2, b, 2,
212 $ wr, wi, x, 2, scale, xnorm,
213 $ info )
214 IF( info.LT.0 )
215 $ ninfo( 1 ) = ninfo( 1 ) + 1
216 IF( info.GT.0 )
217 $ ninfo( 2 ) = ninfo( 2 ) + 1
218 res = abs( ( ca*a( 1, 1 )-wr*d1 )*
219 $ x( 1, 1 )-scale*b( 1, 1 ) )
220 IF( info.EQ.0 ) THEN
221 den = max( eps*( abs( ( ca*a( 1,
222 $ 1 )-wr*d1 )*x( 1, 1 ) ) ),
223 $ smlnum )
224 ELSE
225 den = max( smin*abs( x( 1, 1 ) ),
226 $ smlnum )
227 END IF
228 res = res / den
229 IF( abs( x( 1, 1 ) ).LT.unfl .AND.
230 $ abs( b( 1, 1 ) ).LE.smlnum*
231 $ abs( ca*a( 1, 1 )-wr*d1 ) )res = zero
232 IF( scale.GT.one )
233 $ res = res + one / eps
234 res = res + abs( xnorm-abs( x( 1, 1 ) ) )
235 $ / max( smlnum, xnorm ) / eps
236 IF( info.NE.0 .AND. info.NE.1 )
237 $ res = res + one / eps
238 knt = knt + 1
239 IF( res.GT.rmax ) THEN
240 lmax = knt
241 rmax = res
242 END IF
243 10 CONTINUE
244 20 CONTINUE
245 30 CONTINUE
246*
247 na = 1
248 nw = 2
249 DO 70 ia = 1, 3
250 a( 1, 1 ) = vab( ia )
251 DO 60 ib = 1, 3
252 b( 1, 1 ) = vab( ib )
253 b( 1, 2 ) = -half*vab( ib )
254 DO 50 iwr = 1, 4
255 IF( d1.EQ.one .AND. d2.EQ.one .AND. ca.EQ.
256 $ one ) THEN
257 wr = vwr( iwr )*a( 1, 1 )
258 ELSE
259 wr = vwr( iwr )
260 END IF
261 DO 40 iwi = 1, 4
262 IF( d1.EQ.one .AND. d2.EQ.one .AND.
263 $ ca.EQ.one ) THEN
264 wi = vwi( iwi )*a( 1, 1 )
265 ELSE
266 wi = vwi( iwi )
267 END IF
268 CALL dlaln2( ltrans( itrans ), na, nw,
269 $ smin, ca, a, 2, d1, d2, b,
270 $ 2, wr, wi, x, 2, scale,
271 $ xnorm, info )
272 IF( info.LT.0 )
273 $ ninfo( 1 ) = ninfo( 1 ) + 1
274 IF( info.GT.0 )
275 $ ninfo( 2 ) = ninfo( 2 ) + 1
276 res = abs( ( ca*a( 1, 1 )-wr*d1 )*
277 $ x( 1, 1 )+( wi*d1 )*x( 1, 2 )-
278 $ scale*b( 1, 1 ) )
279 res = res + abs( ( -wi*d1 )*x( 1, 1 )+
280 $ ( ca*a( 1, 1 )-wr*d1 )*x( 1, 2 )-
281 $ scale*b( 1, 2 ) )
282 IF( info.EQ.0 ) THEN
283 den = max( eps*( max( abs( ca*a( 1,
284 $ 1 )-wr*d1 ), abs( d1*wi ) )*
285 $ ( abs( x( 1, 1 ) )+abs( x( 1,
286 $ 2 ) ) ) ), smlnum )
287 ELSE
288 den = max( smin*( abs( x( 1,
289 $ 1 ) )+abs( x( 1, 2 ) ) ),
290 $ smlnum )
291 END IF
292 res = res / den
293 IF( abs( x( 1, 1 ) ).LT.unfl .AND.
294 $ abs( x( 1, 2 ) ).LT.unfl .AND.
295 $ abs( b( 1, 1 ) ).LE.smlnum*
296 $ abs( ca*a( 1, 1 )-wr*d1 ) )
297 $ res = zero
298 IF( scale.GT.one )
299 $ res = res + one / eps
300 res = res + abs( xnorm-
301 $ abs( x( 1, 1 ) )-
302 $ abs( x( 1, 2 ) ) ) /
303 $ max( smlnum, xnorm ) / eps
304 IF( info.NE.0 .AND. info.NE.1 )
305 $ res = res + one / eps
306 knt = knt + 1
307 IF( res.GT.rmax ) THEN
308 lmax = knt
309 rmax = res
310 END IF
311 40 CONTINUE
312 50 CONTINUE
313 60 CONTINUE
314 70 CONTINUE
315*
316 na = 2
317 nw = 1
318 DO 100 ia = 1, 3
319 a( 1, 1 ) = vab( ia )
320 a( 1, 2 ) = -three*vab( ia )
321 a( 2, 1 ) = -seven*vab( ia )
322 a( 2, 2 ) = twnone*vab( ia )
323 DO 90 ib = 1, 3
324 b( 1, 1 ) = vab( ib )
325 b( 2, 1 ) = -two*vab( ib )
326 DO 80 iwr = 1, 4
327 IF( d1.EQ.one .AND. d2.EQ.one .AND. ca.EQ.
328 $ one ) THEN
329 wr = vwr( iwr )*a( 1, 1 )
330 ELSE
331 wr = vwr( iwr )
332 END IF
333 wi = zero
334 CALL dlaln2( ltrans( itrans ), na, nw,
335 $ smin, ca, a, 2, d1, d2, b, 2,
336 $ wr, wi, x, 2, scale, xnorm,
337 $ info )
338 IF( info.LT.0 )
339 $ ninfo( 1 ) = ninfo( 1 ) + 1
340 IF( info.GT.0 )
341 $ ninfo( 2 ) = ninfo( 2 ) + 1
342 IF( itrans.EQ.1 ) THEN
343 tmp = a( 1, 2 )
344 a( 1, 2 ) = a( 2, 1 )
345 a( 2, 1 ) = tmp
346 END IF
347 res = abs( ( ca*a( 1, 1 )-wr*d1 )*
348 $ x( 1, 1 )+( ca*a( 1, 2 ) )*
349 $ x( 2, 1 )-scale*b( 1, 1 ) )
350 res = res + abs( ( ca*a( 2, 1 ) )*
351 $ x( 1, 1 )+( ca*a( 2, 2 )-wr*d2 )*
352 $ x( 2, 1 )-scale*b( 2, 1 ) )
353 IF( info.EQ.0 ) THEN
354 den = max( eps*( max( abs( ca*a( 1,
355 $ 1 )-wr*d1 )+abs( ca*a( 1, 2 ) ),
356 $ abs( ca*a( 2, 1 ) )+abs( ca*a( 2,
357 $ 2 )-wr*d2 ) )*max( abs( x( 1,
358 $ 1 ) ), abs( x( 2, 1 ) ) ) ),
359 $ smlnum )
360 ELSE
361 den = max( eps*( max( smin / eps,
362 $ max( abs( ca*a( 1,
363 $ 1 )-wr*d1 )+abs( ca*a( 1, 2 ) ),
364 $ abs( ca*a( 2, 1 ) )+abs( ca*a( 2,
365 $ 2 )-wr*d2 ) ) )*max( abs( x( 1,
366 $ 1 ) ), abs( x( 2, 1 ) ) ) ),
367 $ smlnum )
368 END IF
369 res = res / den
370 IF( abs( x( 1, 1 ) ).LT.unfl .AND.
371 $ abs( x( 2, 1 ) ).LT.unfl .AND.
372 $ abs( b( 1, 1 ) )+abs( b( 2, 1 ) ).LE.
373 $ smlnum*( abs( ca*a( 1,
374 $ 1 )-wr*d1 )+abs( ca*a( 1,
375 $ 2 ) )+abs( ca*a( 2,
376 $ 1 ) )+abs( ca*a( 2, 2 )-wr*d2 ) ) )
377 $ res = zero
378 IF( scale.GT.one )
379 $ res = res + one / eps
380 res = res + abs( xnorm-
381 $ max( abs( x( 1, 1 ) ), abs( x( 2,
382 $ 1 ) ) ) ) / max( smlnum, xnorm ) /
383 $ eps
384 IF( info.NE.0 .AND. info.NE.1 )
385 $ res = res + one / eps
386 knt = knt + 1
387 IF( res.GT.rmax ) THEN
388 lmax = knt
389 rmax = res
390 END IF
391 80 CONTINUE
392 90 CONTINUE
393 100 CONTINUE
394*
395 na = 2
396 nw = 2
397 DO 140 ia = 1, 3
398 a( 1, 1 ) = vab( ia )*two
399 a( 1, 2 ) = -three*vab( ia )
400 a( 2, 1 ) = -seven*vab( ia )
401 a( 2, 2 ) = twnone*vab( ia )
402 DO 130 ib = 1, 3
403 b( 1, 1 ) = vab( ib )
404 b( 2, 1 ) = -two*vab( ib )
405 b( 1, 2 ) = four*vab( ib )
406 b( 2, 2 ) = -seven*vab( ib )
407 DO 120 iwr = 1, 4
408 IF( d1.EQ.one .AND. d2.EQ.one .AND. ca.EQ.
409 $ one ) THEN
410 wr = vwr( iwr )*a( 1, 1 )
411 ELSE
412 wr = vwr( iwr )
413 END IF
414 DO 110 iwi = 1, 4
415 IF( d1.EQ.one .AND. d2.EQ.one .AND.
416 $ ca.EQ.one ) THEN
417 wi = vwi( iwi )*a( 1, 1 )
418 ELSE
419 wi = vwi( iwi )
420 END IF
421 CALL dlaln2( ltrans( itrans ), na, nw,
422 $ smin, ca, a, 2, d1, d2, b,
423 $ 2, wr, wi, x, 2, scale,
424 $ xnorm, info )
425 IF( info.LT.0 )
426 $ ninfo( 1 ) = ninfo( 1 ) + 1
427 IF( info.GT.0 )
428 $ ninfo( 2 ) = ninfo( 2 ) + 1
429 IF( itrans.EQ.1 ) THEN
430 tmp = a( 1, 2 )
431 a( 1, 2 ) = a( 2, 1 )
432 a( 2, 1 ) = tmp
433 END IF
434 res = abs( ( ca*a( 1, 1 )-wr*d1 )*
435 $ x( 1, 1 )+( ca*a( 1, 2 ) )*
436 $ x( 2, 1 )+( wi*d1 )*x( 1, 2 )-
437 $ scale*b( 1, 1 ) )
438 res = res + abs( ( ca*a( 1,
439 $ 1 )-wr*d1 )*x( 1, 2 )+
440 $ ( ca*a( 1, 2 ) )*x( 2, 2 )-
441 $ ( wi*d1 )*x( 1, 1 )-scale*
442 $ b( 1, 2 ) )
443 res = res + abs( ( ca*a( 2, 1 ) )*
444 $ x( 1, 1 )+( ca*a( 2, 2 )-wr*d2 )*
445 $ x( 2, 1 )+( wi*d2 )*x( 2, 2 )-
446 $ scale*b( 2, 1 ) )
447 res = res + abs( ( ca*a( 2, 1 ) )*
448 $ x( 1, 2 )+( ca*a( 2, 2 )-wr*d2 )*
449 $ x( 2, 2 )-( wi*d2 )*x( 2, 1 )-
450 $ scale*b( 2, 2 ) )
451 IF( info.EQ.0 ) THEN
452 den = max( eps*( max( abs( ca*a( 1,
453 $ 1 )-wr*d1 )+abs( ca*a( 1,
454 $ 2 ) )+abs( wi*d1 ),
455 $ abs( ca*a( 2,
456 $ 1 ) )+abs( ca*a( 2,
457 $ 2 )-wr*d2 )+abs( wi*d2 ) )*
458 $ max( abs( x( 1,
459 $ 1 ) )+abs( x( 2, 1 ) ),
460 $ abs( x( 1, 2 ) )+abs( x( 2,
461 $ 2 ) ) ) ), smlnum )
462 ELSE
463 den = max( eps*( max( smin / eps,
464 $ max( abs( ca*a( 1,
465 $ 1 )-wr*d1 )+abs( ca*a( 1,
466 $ 2 ) )+abs( wi*d1 ),
467 $ abs( ca*a( 2,
468 $ 1 ) )+abs( ca*a( 2,
469 $ 2 )-wr*d2 )+abs( wi*d2 ) ) )*
470 $ max( abs( x( 1,
471 $ 1 ) )+abs( x( 2, 1 ) ),
472 $ abs( x( 1, 2 ) )+abs( x( 2,
473 $ 2 ) ) ) ), smlnum )
474 END IF
475 res = res / den
476 IF( abs( x( 1, 1 ) ).LT.unfl .AND.
477 $ abs( x( 2, 1 ) ).LT.unfl .AND.
478 $ abs( x( 1, 2 ) ).LT.unfl .AND.
479 $ abs( x( 2, 2 ) ).LT.unfl .AND.
480 $ abs( b( 1, 1 ) )+
481 $ abs( b( 2, 1 ) ).LE.smlnum*
482 $ ( abs( ca*a( 1, 1 )-wr*d1 )+
483 $ abs( ca*a( 1, 2 ) )+abs( ca*a( 2,
484 $ 1 ) )+abs( ca*a( 2,
485 $ 2 )-wr*d2 )+abs( wi*d2 )+abs( wi*
486 $ d1 ) ) )res = zero
487 IF( scale.GT.one )
488 $ res = res + one / eps
489 res = res + abs( xnorm-
490 $ max( abs( x( 1, 1 ) )+abs( x( 1,
491 $ 2 ) ), abs( x( 2,
492 $ 1 ) )+abs( x( 2, 2 ) ) ) ) /
493 $ max( smlnum, xnorm ) / eps
494 IF( info.NE.0 .AND. info.NE.1 )
495 $ res = res + one / eps
496 knt = knt + 1
497 IF( res.GT.rmax ) THEN
498 lmax = knt
499 rmax = res
500 END IF
501 110 CONTINUE
502 120 CONTINUE
503 130 CONTINUE
504 140 CONTINUE
505 150 CONTINUE
506 160 CONTINUE
507 170 CONTINUE
508 180 CONTINUE
509 190 CONTINUE
510*
511 RETURN
512*
513* End of DGET31
514*
dlaln2
subroutine dlaln2(ltrans, na, nw, smin, ca, a, lda, d1, d2, b, ldb, wr, wi, x, ldx, scale, xnorm, info)
DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.
Definition dlaln2.f:218

◆ dget32()

subroutine dget32 ( double precision rmax,
integer lmax,
integer ninfo,
integer knt )

DGET32

Purpose:
!>
!> DGET32 tests DLASY2, a routine for solving
!>
!>         op(TL)*X + ISGN*X*op(TR) = SCALE*B
!>
!> where TL is N1 by N1, TR is N2 by N2, and N1,N2 =1 or 2 only.
!> X and B are N1 by N2, op() is an optional transpose, an
!> ISGN = 1 or -1. SCALE is chosen less than or equal to 1 to
!> avoid overflow in X.
!>
!> The test condition is that the scaled residual
!>
!> norm( op(TL)*X + ISGN*X*op(TR) = SCALE*B )
!>      / ( max( ulp*norm(TL), ulp*norm(TR)) * norm(X), SMLNUM )
!>
!> should be on the order of 1. Here, ulp is the machine precision.
!> Also, it is verified that SCALE is less than or equal to 1, and
!> that XNORM = infinity-norm(X).
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION
!>          Value of the largest test ratio.
!>
[out]LMAX
!>          LMAX is INTEGER
!>          Example number where largest test ratio achieved.
!>
[out]NINFO
!>          NINFO is INTEGER
!>          Number of examples returned with INFO.NE.0.
!>
[out]KNT
!>          KNT is INTEGER
!>          Total number of examples tested.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 81 of file dget32.f.

82*
83* -- LAPACK test routine --
84* -- LAPACK is a software package provided by Univ. of Tennessee, --
85* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
86*
87* .. Scalar Arguments ..
88 INTEGER KNT, LMAX, NINFO
89 DOUBLE PRECISION RMAX
90* ..
91*
92* =====================================================================
93*
94* .. Parameters ..
95 DOUBLE PRECISION ZERO, ONE
96 parameter( zero = 0.0d0, one = 1.0d0 )
97 DOUBLE PRECISION TWO, FOUR, EIGHT
98 parameter( two = 2.0d0, four = 4.0d0, eight = 8.0d0 )
99* ..
100* .. Local Scalars ..
101 LOGICAL LTRANL, LTRANR
102 INTEGER IB, IB1, IB2, IB3, INFO, ISGN, ITL, ITLSCL,
103 $ ITR, ITRANL, ITRANR, ITRSCL, N1, N2
104 DOUBLE PRECISION BIGNUM, DEN, EPS, RES, SCALE, SGN, SMLNUM, TMP,
105 $ TNRM, XNORM, XNRM
106* ..
107* .. Local Arrays ..
108 INTEGER ITVAL( 2, 2, 8 )
109 DOUBLE PRECISION B( 2, 2 ), TL( 2, 2 ), TR( 2, 2 ), VAL( 3 ),
110 $ X( 2, 2 )
111* ..
112* .. External Functions ..
113 DOUBLE PRECISION DLAMCH
114 EXTERNAL dlamch
115* ..
116* .. External Subroutines ..
117 EXTERNAL dlabad, dlasy2
118* ..
119* .. Intrinsic Functions ..
120 INTRINSIC abs, max, min, sqrt
121* ..
122* .. Data statements ..
123 DATA itval / 8, 4, 2, 1, 4, 8, 1, 2, 2, 1, 8, 4, 1,
124 $ 2, 4, 8, 9, 4, 2, 1, 4, 9, 1, 2, 2, 1, 9, 4, 1,
125 $ 2, 4, 9 /
126* ..
127* .. Executable Statements ..
128*
129* Get machine parameters
130*
131 eps = dlamch( 'P' )
132 smlnum = dlamch( 'S' ) / eps
133 bignum = one / smlnum
134 CALL dlabad( smlnum, bignum )
135*
136* Set up test case parameters
137*
138 val( 1 ) = sqrt( smlnum )
139 val( 2 ) = one
140 val( 3 ) = sqrt( bignum )
141*
142 knt = 0
143 ninfo = 0
144 lmax = 0
145 rmax = zero
146*
147* Begin test loop
148*
149 DO 230 itranl = 0, 1
150 DO 220 itranr = 0, 1
151 DO 210 isgn = -1, 1, 2
152 sgn = isgn
153 ltranl = itranl.EQ.1
154 ltranr = itranr.EQ.1
155*
156 n1 = 1
157 n2 = 1
158 DO 30 itl = 1, 3
159 DO 20 itr = 1, 3
160 DO 10 ib = 1, 3
161 tl( 1, 1 ) = val( itl )
162 tr( 1, 1 ) = val( itr )
163 b( 1, 1 ) = val( ib )
164 knt = knt + 1
165 CALL dlasy2( ltranl, ltranr, isgn, n1, n2, tl,
166 $ 2, tr, 2, b, 2, scale, x, 2, xnorm,
167 $ info )
168 IF( info.NE.0 )
169 $ ninfo = ninfo + 1
170 res = abs( ( tl( 1, 1 )+sgn*tr( 1, 1 ) )*
171 $ x( 1, 1 )-scale*b( 1, 1 ) )
172 IF( info.EQ.0 ) THEN
173 den = max( eps*( ( abs( tr( 1,
174 $ 1 ) )+abs( tl( 1, 1 ) ) )*abs( x( 1,
175 $ 1 ) ) ), smlnum )
176 ELSE
177 den = smlnum*max( abs( x( 1, 1 ) ), one )
178 END IF
179 res = res / den
180 IF( scale.GT.one )
181 $ res = res + one / eps
182 res = res + abs( xnorm-abs( x( 1, 1 ) ) ) /
183 $ max( smlnum, xnorm ) / eps
184 IF( info.NE.0 .AND. info.NE.1 )
185 $ res = res + one / eps
186 IF( res.GT.rmax ) THEN
187 lmax = knt
188 rmax = res
189 END IF
190 10 CONTINUE
191 20 CONTINUE
192 30 CONTINUE
193*
194 n1 = 2
195 n2 = 1
196 DO 80 itl = 1, 8
197 DO 70 itlscl = 1, 3
198 DO 60 itr = 1, 3
199 DO 50 ib1 = 1, 3
200 DO 40 ib2 = 1, 3
201 b( 1, 1 ) = val( ib1 )
202 b( 2, 1 ) = -four*val( ib2 )
203 tl( 1, 1 ) = itval( 1, 1, itl )*
204 $ val( itlscl )
205 tl( 2, 1 ) = itval( 2, 1, itl )*
206 $ val( itlscl )
207 tl( 1, 2 ) = itval( 1, 2, itl )*
208 $ val( itlscl )
209 tl( 2, 2 ) = itval( 2, 2, itl )*
210 $ val( itlscl )
211 tr( 1, 1 ) = val( itr )
212 knt = knt + 1
213 CALL dlasy2( ltranl, ltranr, isgn, n1, n2,
214 $ tl, 2, tr, 2, b, 2, scale, x,
215 $ 2, xnorm, info )
216 IF( info.NE.0 )
217 $ ninfo = ninfo + 1
218 IF( ltranl ) THEN
219 tmp = tl( 1, 2 )
220 tl( 1, 2 ) = tl( 2, 1 )
221 tl( 2, 1 ) = tmp
222 END IF
223 res = abs( ( tl( 1, 1 )+sgn*tr( 1, 1 ) )*
224 $ x( 1, 1 )+tl( 1, 2 )*x( 2, 1 )-
225 $ scale*b( 1, 1 ) )
226 res = res + abs( ( tl( 2, 2 )+sgn*tr( 1,
227 $ 1 ) )*x( 2, 1 )+tl( 2, 1 )*
228 $ x( 1, 1 )-scale*b( 2, 1 ) )
229 tnrm = abs( tr( 1, 1 ) ) +
230 $ abs( tl( 1, 1 ) ) +
231 $ abs( tl( 1, 2 ) ) +
232 $ abs( tl( 2, 1 ) ) +
233 $ abs( tl( 2, 2 ) )
234 xnrm = max( abs( x( 1, 1 ) ),
235 $ abs( x( 2, 1 ) ) )
236 den = max( smlnum, smlnum*xnrm,
237 $ ( tnrm*eps )*xnrm )
238 res = res / den
239 IF( scale.GT.one )
240 $ res = res + one / eps
241 res = res + abs( xnorm-xnrm ) /
242 $ max( smlnum, xnorm ) / eps
243 IF( res.GT.rmax ) THEN
244 lmax = knt
245 rmax = res
246 END IF
247 40 CONTINUE
248 50 CONTINUE
249 60 CONTINUE
250 70 CONTINUE
251 80 CONTINUE
252*
253 n1 = 1
254 n2 = 2
255 DO 130 itr = 1, 8
256 DO 120 itrscl = 1, 3
257 DO 110 itl = 1, 3
258 DO 100 ib1 = 1, 3
259 DO 90 ib2 = 1, 3
260 b( 1, 1 ) = val( ib1 )
261 b( 1, 2 ) = -two*val( ib2 )
262 tr( 1, 1 ) = itval( 1, 1, itr )*
263 $ val( itrscl )
264 tr( 2, 1 ) = itval( 2, 1, itr )*
265 $ val( itrscl )
266 tr( 1, 2 ) = itval( 1, 2, itr )*
267 $ val( itrscl )
268 tr( 2, 2 ) = itval( 2, 2, itr )*
269 $ val( itrscl )
270 tl( 1, 1 ) = val( itl )
271 knt = knt + 1
272 CALL dlasy2( ltranl, ltranr, isgn, n1, n2,
273 $ tl, 2, tr, 2, b, 2, scale, x,
274 $ 2, xnorm, info )
275 IF( info.NE.0 )
276 $ ninfo = ninfo + 1
277 IF( ltranr ) THEN
278 tmp = tr( 1, 2 )
279 tr( 1, 2 ) = tr( 2, 1 )
280 tr( 2, 1 ) = tmp
281 END IF
282 tnrm = abs( tl( 1, 1 ) ) +
283 $ abs( tr( 1, 1 ) ) +
284 $ abs( tr( 1, 2 ) ) +
285 $ abs( tr( 2, 2 ) ) +
286 $ abs( tr( 2, 1 ) )
287 xnrm = abs( x( 1, 1 ) ) + abs( x( 1, 2 ) )
288 res = abs( ( ( tl( 1, 1 )+sgn*tr( 1,
289 $ 1 ) ) )*( x( 1, 1 ) )+
290 $ ( sgn*tr( 2, 1 ) )*( x( 1, 2 ) )-
291 $ ( scale*b( 1, 1 ) ) )
292 res = res + abs( ( ( tl( 1, 1 )+sgn*tr( 2,
293 $ 2 ) ) )*( x( 1, 2 ) )+
294 $ ( sgn*tr( 1, 2 ) )*( x( 1, 1 ) )-
295 $ ( scale*b( 1, 2 ) ) )
296 den = max( smlnum, smlnum*xnrm,
297 $ ( tnrm*eps )*xnrm )
298 res = res / den
299 IF( scale.GT.one )
300 $ res = res + one / eps
301 res = res + abs( xnorm-xnrm ) /
302 $ max( smlnum, xnorm ) / eps
303 IF( res.GT.rmax ) THEN
304 lmax = knt
305 rmax = res
306 END IF
307 90 CONTINUE
308 100 CONTINUE
309 110 CONTINUE
310 120 CONTINUE
311 130 CONTINUE
312*
313 n1 = 2
314 n2 = 2
315 DO 200 itr = 1, 8
316 DO 190 itrscl = 1, 3
317 DO 180 itl = 1, 8
318 DO 170 itlscl = 1, 3
319 DO 160 ib1 = 1, 3
320 DO 150 ib2 = 1, 3
321 DO 140 ib3 = 1, 3
322 b( 1, 1 ) = val( ib1 )
323 b( 2, 1 ) = -four*val( ib2 )
324 b( 1, 2 ) = -two*val( ib3 )
325 b( 2, 2 ) = eight*
326 $ min( val( ib1 ), val
327 $ ( ib2 ), val( ib3 ) )
328 tr( 1, 1 ) = itval( 1, 1, itr )*
329 $ val( itrscl )
330 tr( 2, 1 ) = itval( 2, 1, itr )*
331 $ val( itrscl )
332 tr( 1, 2 ) = itval( 1, 2, itr )*
333 $ val( itrscl )
334 tr( 2, 2 ) = itval( 2, 2, itr )*
335 $ val( itrscl )
336 tl( 1, 1 ) = itval( 1, 1, itl )*
337 $ val( itlscl )
338 tl( 2, 1 ) = itval( 2, 1, itl )*
339 $ val( itlscl )
340 tl( 1, 2 ) = itval( 1, 2, itl )*
341 $ val( itlscl )
342 tl( 2, 2 ) = itval( 2, 2, itl )*
343 $ val( itlscl )
344 knt = knt + 1
345 CALL dlasy2( ltranl, ltranr, isgn,
346 $ n1, n2, tl, 2, tr, 2,
347 $ b, 2, scale, x, 2,
348 $ xnorm, info )
349 IF( info.NE.0 )
350 $ ninfo = ninfo + 1
351 IF( ltranr ) THEN
352 tmp = tr( 1, 2 )
353 tr( 1, 2 ) = tr( 2, 1 )
354 tr( 2, 1 ) = tmp
355 END IF
356 IF( ltranl ) THEN
357 tmp = tl( 1, 2 )
358 tl( 1, 2 ) = tl( 2, 1 )
359 tl( 2, 1 ) = tmp
360 END IF
361 tnrm = abs( tr( 1, 1 ) ) +
362 $ abs( tr( 2, 1 ) ) +
363 $ abs( tr( 1, 2 ) ) +
364 $ abs( tr( 2, 2 ) ) +
365 $ abs( tl( 1, 1 ) ) +
366 $ abs( tl( 2, 1 ) ) +
367 $ abs( tl( 1, 2 ) ) +
368 $ abs( tl( 2, 2 ) )
369 xnrm = max( abs( x( 1, 1 ) )+
370 $ abs( x( 1, 2 ) ),
371 $ abs( x( 2, 1 ) )+
372 $ abs( x( 2, 2 ) ) )
373 res = abs( ( ( tl( 1, 1 )+sgn*tr( 1,
374 $ 1 ) ) )*( x( 1, 1 ) )+
375 $ ( sgn*tr( 2, 1 ) )*
376 $ ( x( 1, 2 ) )+( tl( 1, 2 ) )*
377 $ ( x( 2, 1 ) )-
378 $ ( scale*b( 1, 1 ) ) )
379 res = res + abs( ( tl( 1, 1 ) )*
380 $ ( x( 1, 2 ) )+
381 $ ( sgn*tr( 1, 2 ) )*
382 $ ( x( 1, 1 ) )+
383 $ ( sgn*tr( 2, 2 ) )*
384 $ ( x( 1, 2 ) )+( tl( 1, 2 ) )*
385 $ ( x( 2, 2 ) )-
386 $ ( scale*b( 1, 2 ) ) )
387 res = res + abs( ( tl( 2, 1 ) )*
388 $ ( x( 1, 1 ) )+
389 $ ( sgn*tr( 1, 1 ) )*
390 $ ( x( 2, 1 ) )+
391 $ ( sgn*tr( 2, 1 ) )*
392 $ ( x( 2, 2 ) )+( tl( 2, 2 ) )*
393 $ ( x( 2, 1 ) )-
394 $ ( scale*b( 2, 1 ) ) )
395 res = res + abs( ( ( tl( 2,
396 $ 2 )+sgn*tr( 2, 2 ) ) )*
397 $ ( x( 2, 2 ) )+
398 $ ( sgn*tr( 1, 2 ) )*
399 $ ( x( 2, 1 ) )+( tl( 2, 1 ) )*
400 $ ( x( 1, 2 ) )-
401 $ ( scale*b( 2, 2 ) ) )
402 den = max( smlnum, smlnum*xnrm,
403 $ ( tnrm*eps )*xnrm )
404 res = res / den
405 IF( scale.GT.one )
406 $ res = res + one / eps
407 res = res + abs( xnorm-xnrm ) /
408 $ max( smlnum, xnorm ) / eps
409 IF( res.GT.rmax ) THEN
410 lmax = knt
411 rmax = res
412 END IF
413 140 CONTINUE
414 150 CONTINUE
415 160 CONTINUE
416 170 CONTINUE
417 180 CONTINUE
418 190 CONTINUE
419 200 CONTINUE
420 210 CONTINUE
421 220 CONTINUE
422 230 CONTINUE
423*
424 RETURN
425*
426* End of DGET32
427*
dlasy2
subroutine dlasy2(ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr, ldtr, b, ldb, scale, x, ldx, xnorm, info)
DLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2.
Definition dlasy2.f:174

◆ dget33()

subroutine dget33 ( double precision rmax,
integer lmax,
integer ninfo,
integer knt )

DGET33

Purpose:
!>
!> DGET33 tests DLANV2, a routine for putting 2 by 2 blocks into
!> standard form.  In other words, it computes a two by two rotation
!> [[C,S] 
[-S,C]] where in
!>
!>    [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ]
!>    [-S C ][T(2,1) T(2,2)][ S  C ]   [ T21 T22 ]
!>
!> either
!>    1) T21=0 (real eigenvalues), or
!>    2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues).
!> We also  verify that the residual is small.
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION
!>          Value of the largest test ratio.
!>
[out]LMAX
!>          LMAX is INTEGER
!>          Example number where largest test ratio achieved.
!>
[out]NINFO
!>          NINFO is INTEGER
!>          Number of examples returned with INFO .NE. 0.
!>
[out]KNT
!>          KNT is INTEGER
!>          Total number of examples tested.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 75 of file dget33.f.

76*
77* -- LAPACK test routine --
78* -- LAPACK is a software package provided by Univ. of Tennessee, --
79* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
80*
81* .. Scalar Arguments ..
82 INTEGER KNT, LMAX, NINFO
83 DOUBLE PRECISION RMAX
84* ..
85*
86* =====================================================================
87*
88* .. Parameters ..
89 DOUBLE PRECISION ZERO, ONE
90 parameter( zero = 0.0d0, one = 1.0d0 )
91 DOUBLE PRECISION TWO, FOUR
92 parameter( two = 2.0d0, four = 4.0d0 )
93* ..
94* .. Local Scalars ..
95 INTEGER I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
96 DOUBLE PRECISION BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
97 $ WI1, WI2, WR1, WR2
98* ..
99* .. Local Arrays ..
100 DOUBLE PRECISION Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
101 $ VAL( 4 ), VM( 3 )
102* ..
103* .. External Functions ..
104 DOUBLE PRECISION DLAMCH
105 EXTERNAL dlamch
106* ..
107* .. External Subroutines ..
108 EXTERNAL dlabad, dlanv2
109* ..
110* .. Intrinsic Functions ..
111 INTRINSIC abs, max, sign
112* ..
113* .. Executable Statements ..
114*
115* Get machine parameters
116*
117 eps = dlamch( 'P' )
118 smlnum = dlamch( 'S' ) / eps
119 bignum = one / smlnum
120 CALL dlabad( smlnum, bignum )
121*
122* Set up test case parameters
123*
124 val( 1 ) = one
125 val( 2 ) = one + two*eps
126 val( 3 ) = two
127 val( 4 ) = two - four*eps
128 vm( 1 ) = smlnum
129 vm( 2 ) = one
130 vm( 3 ) = bignum
131*
132 knt = 0
133 ninfo = 0
134 lmax = 0
135 rmax = zero
136*
137* Begin test loop
138*
139 DO 150 i1 = 1, 4
140 DO 140 i2 = 1, 4
141 DO 130 i3 = 1, 4
142 DO 120 i4 = 1, 4
143 DO 110 im1 = 1, 3
144 DO 100 im2 = 1, 3
145 DO 90 im3 = 1, 3
146 DO 80 im4 = 1, 3
147 t( 1, 1 ) = val( i1 )*vm( im1 )
148 t( 1, 2 ) = val( i2 )*vm( im2 )
149 t( 2, 1 ) = -val( i3 )*vm( im3 )
150 t( 2, 2 ) = val( i4 )*vm( im4 )
151 tnrm = max( abs( t( 1, 1 ) ),
152 $ abs( t( 1, 2 ) ), abs( t( 2, 1 ) ),
153 $ abs( t( 2, 2 ) ) )
154 t1( 1, 1 ) = t( 1, 1 )
155 t1( 1, 2 ) = t( 1, 2 )
156 t1( 2, 1 ) = t( 2, 1 )
157 t1( 2, 2 ) = t( 2, 2 )
158 q( 1, 1 ) = one
159 q( 1, 2 ) = zero
160 q( 2, 1 ) = zero
161 q( 2, 2 ) = one
162*
163 CALL dlanv2( t( 1, 1 ), t( 1, 2 ),
164 $ t( 2, 1 ), t( 2, 2 ), wr1,
165 $ wi1, wr2, wi2, cs, sn )
166 DO 10 j1 = 1, 2
167 res = q( j1, 1 )*cs + q( j1, 2 )*sn
168 q( j1, 2 ) = -q( j1, 1 )*sn +
169 $ q( j1, 2 )*cs
170 q( j1, 1 ) = res
171 10 CONTINUE
172*
173 res = zero
174 res = res + abs( q( 1, 1 )**2+
175 $ q( 1, 2 )**2-one ) / eps
176 res = res + abs( q( 2, 2 )**2+
177 $ q( 2, 1 )**2-one ) / eps
178 res = res + abs( q( 1, 1 )*q( 2, 1 )+
179 $ q( 1, 2 )*q( 2, 2 ) ) / eps
180 DO 40 j1 = 1, 2
181 DO 30 j2 = 1, 2
182 t2( j1, j2 ) = zero
183 DO 20 j3 = 1, 2
184 t2( j1, j2 ) = t2( j1, j2 ) +
185 $ t1( j1, j3 )*
186 $ q( j3, j2 )
187 20 CONTINUE
188 30 CONTINUE
189 40 CONTINUE
190 DO 70 j1 = 1, 2
191 DO 60 j2 = 1, 2
192 sum = t( j1, j2 )
193 DO 50 j3 = 1, 2
194 sum = sum - q( j3, j1 )*
195 $ t2( j3, j2 )
196 50 CONTINUE
197 res = res + abs( sum ) / eps / tnrm
198 60 CONTINUE
199 70 CONTINUE
200 IF( t( 2, 1 ).NE.zero .AND.
201 $ ( t( 1, 1 ).NE.t( 2,
202 $ 2 ) .OR. sign( one, t( 1,
203 $ 2 ) )*sign( one, t( 2,
204 $ 1 ) ).GT.zero ) )res = res + one / eps
205 knt = knt + 1
206 IF( res.GT.rmax ) THEN
207 lmax = knt
208 rmax = res
209 END IF
210 80 CONTINUE
211 90 CONTINUE
212 100 CONTINUE
213 110 CONTINUE
214 120 CONTINUE
215 130 CONTINUE
216 140 CONTINUE
217 150 CONTINUE
218*
219 RETURN
220*
221* End of DGET33
222*
dlanv2
subroutine dlanv2(a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn)
DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form.
Definition dlanv2.f:127

◆ dget34()

subroutine dget34 ( double precision rmax,
integer lmax,
integer, dimension( 2 ) ninfo,
integer knt )

DGET34

Purpose:
!>
!> DGET34 tests DLAEXC, a routine for swapping adjacent blocks (either
!> 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form.
!> Thus, DLAEXC computes an orthogonal matrix Q such that
!>
!>     Q' * [ A B ] * Q  = [ C1 B1 ]
!>          [ 0 C ]        [ 0  A1 ]
!>
!> where C1 is similar to C and A1 is similar to A.  Both A and C are
!> assumed to be in standard form (equal diagonal entries and
!> offdiagonal with differing signs) and A1 and C1 are returned with the
!> same properties.
!>
!> The test code verifies these last assertions, as well as that
!> the residual in the above equation is small.
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION
!>          Value of the largest test ratio.
!>
[out]LMAX
!>          LMAX is INTEGER
!>          Example number where largest test ratio achieved.
!>
[out]NINFO
!>          NINFO is INTEGER array, dimension (2)
!>          NINFO(J) is the number of examples where INFO=J occurred.
!>
[out]KNT
!>          KNT is INTEGER
!>          Total number of examples tested.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 81 of file dget34.f.

82*
83* -- LAPACK test routine --
84* -- LAPACK is a software package provided by Univ. of Tennessee, --
85* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
86*
87* .. Scalar Arguments ..
88 INTEGER KNT, LMAX
89 DOUBLE PRECISION RMAX
90* ..
91* .. Array Arguments ..
92 INTEGER NINFO( 2 )
93* ..
94*
95* =====================================================================
96*
97* .. Parameters ..
98 DOUBLE PRECISION ZERO, HALF, ONE
99 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
100 DOUBLE PRECISION TWO, THREE
101 parameter( two = 2.0d0, three = 3.0d0 )
102 INTEGER LWORK
103 parameter( lwork = 32 )
104* ..
105* .. Local Scalars ..
106 INTEGER I, IA, IA11, IA12, IA21, IA22, IAM, IB, IC,
107 $ IC11, IC12, IC21, IC22, ICM, INFO, J
108 DOUBLE PRECISION BIGNUM, EPS, RES, SMLNUM, TNRM
109* ..
110* .. Local Arrays ..
111 DOUBLE PRECISION Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ),
112 $ VAL( 9 ), VM( 2 ), WORK( LWORK )
113* ..
114* .. External Functions ..
115 DOUBLE PRECISION DLAMCH
116 EXTERNAL dlamch
117* ..
118* .. External Subroutines ..
119 EXTERNAL dcopy, dhst01, dlabad, dlaexc
120* ..
121* .. Intrinsic Functions ..
122 INTRINSIC abs, dble, max, sign, sqrt
123* ..
124* .. Executable Statements ..
125*
126* Get machine parameters
127*
128 eps = dlamch( 'P' )
129 smlnum = dlamch( 'S' ) / eps
130 bignum = one / smlnum
131 CALL dlabad( smlnum, bignum )
132*
133* Set up test case parameters
134*
135 val( 1 ) = zero
136 val( 2 ) = sqrt( smlnum )
137 val( 3 ) = one
138 val( 4 ) = two
139 val( 5 ) = sqrt( bignum )
140 val( 6 ) = -sqrt( smlnum )
141 val( 7 ) = -one
142 val( 8 ) = -two
143 val( 9 ) = -sqrt( bignum )
144 vm( 1 ) = one
145 vm( 2 ) = one + two*eps
146 CALL dcopy( 16, val( 4 ), 0, t( 1, 1 ), 1 )
147*
148 ninfo( 1 ) = 0
149 ninfo( 2 ) = 0
150 knt = 0
151 lmax = 0
152 rmax = zero
153*
154* Begin test loop
155*
156 DO 40 ia = 1, 9
157 DO 30 iam = 1, 2
158 DO 20 ib = 1, 9
159 DO 10 ic = 1, 9
160 t( 1, 1 ) = val( ia )*vm( iam )
161 t( 2, 2 ) = val( ic )
162 t( 1, 2 ) = val( ib )
163 t( 2, 1 ) = zero
164 tnrm = max( abs( t( 1, 1 ) ), abs( t( 2, 2 ) ),
165 $ abs( t( 1, 2 ) ) )
166 CALL dcopy( 16, t, 1, t1, 1 )
167 CALL dcopy( 16, val( 1 ), 0, q, 1 )
168 CALL dcopy( 4, val( 3 ), 0, q, 5 )
169 CALL dlaexc( .true., 2, t, 4, q, 4, 1, 1, 1, work,
170 $ info )
171 IF( info.NE.0 )
172 $ ninfo( info ) = ninfo( info ) + 1
173 CALL dhst01( 2, 1, 2, t1, 4, t, 4, q, 4, work, lwork,
174 $ result )
175 res = result( 1 ) + result( 2 )
176 IF( info.NE.0 )
177 $ res = res + one / eps
178 IF( t( 1, 1 ).NE.t1( 2, 2 ) )
179 $ res = res + one / eps
180 IF( t( 2, 2 ).NE.t1( 1, 1 ) )
181 $ res = res + one / eps
182 IF( t( 2, 1 ).NE.zero )
183 $ res = res + one / eps
184 knt = knt + 1
185 IF( res.GT.rmax ) THEN
186 lmax = knt
187 rmax = res
188 END IF
189 10 CONTINUE
190 20 CONTINUE
191 30 CONTINUE
192 40 CONTINUE
193*
194 DO 110 ia = 1, 5
195 DO 100 iam = 1, 2
196 DO 90 ib = 1, 5
197 DO 80 ic11 = 1, 5
198 DO 70 ic12 = 2, 5
199 DO 60 ic21 = 2, 4
200 DO 50 ic22 = -1, 1, 2
201 t( 1, 1 ) = val( ia )*vm( iam )
202 t( 1, 2 ) = val( ib )
203 t( 1, 3 ) = -two*val( ib )
204 t( 2, 1 ) = zero
205 t( 2, 2 ) = val( ic11 )
206 t( 2, 3 ) = val( ic12 )
207 t( 3, 1 ) = zero
208 t( 3, 2 ) = -val( ic21 )
209 t( 3, 3 ) = val( ic11 )*dble( ic22 )
210 tnrm = max( abs( t( 1, 1 ) ),
211 $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
212 $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
213 $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
214 CALL dcopy( 16, t, 1, t1, 1 )
215 CALL dcopy( 16, val( 1 ), 0, q, 1 )
216 CALL dcopy( 4, val( 3 ), 0, q, 5 )
217 CALL dlaexc( .true., 3, t, 4, q, 4, 1, 1, 2,
218 $ work, info )
219 IF( info.NE.0 )
220 $ ninfo( info ) = ninfo( info ) + 1
221 CALL dhst01( 3, 1, 3, t1, 4, t, 4, q, 4,
222 $ work, lwork, result )
223 res = result( 1 ) + result( 2 )
224 IF( info.EQ.0 ) THEN
225 IF( t1( 1, 1 ).NE.t( 3, 3 ) )
226 $ res = res + one / eps
227 IF( t( 3, 1 ).NE.zero )
228 $ res = res + one / eps
229 IF( t( 3, 2 ).NE.zero )
230 $ res = res + one / eps
231 IF( t( 2, 1 ).NE.0 .AND.
232 $ ( t( 1, 1 ).NE.t( 2,
233 $ 2 ) .OR. sign( one, t( 1,
234 $ 2 ) ).EQ.sign( one, t( 2, 1 ) ) ) )
235 $ res = res + one / eps
236 END IF
237 knt = knt + 1
238 IF( res.GT.rmax ) THEN
239 lmax = knt
240 rmax = res
241 END IF
242 50 CONTINUE
243 60 CONTINUE
244 70 CONTINUE
245 80 CONTINUE
246 90 CONTINUE
247 100 CONTINUE
248 110 CONTINUE
249*
250 DO 180 ia11 = 1, 5
251 DO 170 ia12 = 2, 5
252 DO 160 ia21 = 2, 4
253 DO 150 ia22 = -1, 1, 2
254 DO 140 icm = 1, 2
255 DO 130 ib = 1, 5
256 DO 120 ic = 1, 5
257 t( 1, 1 ) = val( ia11 )
258 t( 1, 2 ) = val( ia12 )
259 t( 1, 3 ) = -two*val( ib )
260 t( 2, 1 ) = -val( ia21 )
261 t( 2, 2 ) = val( ia11 )*dble( ia22 )
262 t( 2, 3 ) = val( ib )
263 t( 3, 1 ) = zero
264 t( 3, 2 ) = zero
265 t( 3, 3 ) = val( ic )*vm( icm )
266 tnrm = max( abs( t( 1, 1 ) ),
267 $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
268 $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
269 $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
270 CALL dcopy( 16, t, 1, t1, 1 )
271 CALL dcopy( 16, val( 1 ), 0, q, 1 )
272 CALL dcopy( 4, val( 3 ), 0, q, 5 )
273 CALL dlaexc( .true., 3, t, 4, q, 4, 1, 2, 1,
274 $ work, info )
275 IF( info.NE.0 )
276 $ ninfo( info ) = ninfo( info ) + 1
277 CALL dhst01( 3, 1, 3, t1, 4, t, 4, q, 4,
278 $ work, lwork, result )
279 res = result( 1 ) + result( 2 )
280 IF( info.EQ.0 ) THEN
281 IF( t1( 3, 3 ).NE.t( 1, 1 ) )
282 $ res = res + one / eps
283 IF( t( 2, 1 ).NE.zero )
284 $ res = res + one / eps
285 IF( t( 3, 1 ).NE.zero )
286 $ res = res + one / eps
287 IF( t( 3, 2 ).NE.0 .AND.
288 $ ( t( 2, 2 ).NE.t( 3,
289 $ 3 ) .OR. sign( one, t( 2,
290 $ 3 ) ).EQ.sign( one, t( 3, 2 ) ) ) )
291 $ res = res + one / eps
292 END IF
293 knt = knt + 1
294 IF( res.GT.rmax ) THEN
295 lmax = knt
296 rmax = res
297 END IF
298 120 CONTINUE
299 130 CONTINUE
300 140 CONTINUE
301 150 CONTINUE
302 160 CONTINUE
303 170 CONTINUE
304 180 CONTINUE
305*
306 DO 300 ia11 = 1, 5
307 DO 290 ia12 = 2, 5
308 DO 280 ia21 = 2, 4
309 DO 270 ia22 = -1, 1, 2
310 DO 260 ib = 1, 5
311 DO 250 ic11 = 3, 4
312 DO 240 ic12 = 3, 4
313 DO 230 ic21 = 3, 4
314 DO 220 ic22 = -1, 1, 2
315 DO 210 icm = 5, 7
316 iam = 1
317 t( 1, 1 ) = val( ia11 )*vm( iam )
318 t( 1, 2 ) = val( ia12 )*vm( iam )
319 t( 1, 3 ) = -two*val( ib )
320 t( 1, 4 ) = half*val( ib )
321 t( 2, 1 ) = -t( 1, 2 )*val( ia21 )
322 t( 2, 2 ) = val( ia11 )*
323 $ dble( ia22 )*vm( iam )
324 t( 2, 3 ) = val( ib )
325 t( 2, 4 ) = three*val( ib )
326 t( 3, 1 ) = zero
327 t( 3, 2 ) = zero
328 t( 3, 3 ) = val( ic11 )*
329 $ abs( val( icm ) )
330 t( 3, 4 ) = val( ic12 )*
331 $ abs( val( icm ) )
332 t( 4, 1 ) = zero
333 t( 4, 2 ) = zero
334 t( 4, 3 ) = -t( 3, 4 )*val( ic21 )*
335 $ abs( val( icm ) )
336 t( 4, 4 ) = val( ic11 )*
337 $ dble( ic22 )*
338 $ abs( val( icm ) )
339 tnrm = zero
340 DO 200 i = 1, 4
341 DO 190 j = 1, 4
342 tnrm = max( tnrm,
343 $ abs( t( i, j ) ) )
344 190 CONTINUE
345 200 CONTINUE
346 CALL dcopy( 16, t, 1, t1, 1 )
347 CALL dcopy( 16, val( 1 ), 0, q, 1 )
348 CALL dcopy( 4, val( 3 ), 0, q, 5 )
349 CALL dlaexc( .true., 4, t, 4, q, 4,
350 $ 1, 2, 2, work, info )
351 IF( info.NE.0 )
352 $ ninfo( info ) = ninfo( info ) + 1
353 CALL dhst01( 4, 1, 4, t1, 4, t, 4,
354 $ q, 4, work, lwork,
355 $ result )
356 res = result( 1 ) + result( 2 )
357 IF( info.EQ.0 ) THEN
358 IF( t( 3, 1 ).NE.zero )
359 $ res = res + one / eps
360 IF( t( 4, 1 ).NE.zero )
361 $ res = res + one / eps
362 IF( t( 3, 2 ).NE.zero )
363 $ res = res + one / eps
364 IF( t( 4, 2 ).NE.zero )
365 $ res = res + one / eps
366 IF( t( 2, 1 ).NE.0 .AND.
367 $ ( t( 1, 1 ).NE.t( 2,
368 $ 2 ) .OR. sign( one, t( 1,
369 $ 2 ) ).EQ.sign( one, t( 2,
370 $ 1 ) ) ) )res = res +
371 $ one / eps
372 IF( t( 4, 3 ).NE.0 .AND.
373 $ ( t( 3, 3 ).NE.t( 4,
374 $ 4 ) .OR. sign( one, t( 3,
375 $ 4 ) ).EQ.sign( one, t( 4,
376 $ 3 ) ) ) )res = res +
377 $ one / eps
378 END IF
379 knt = knt + 1
380 IF( res.GT.rmax ) THEN
381 lmax = knt
382 rmax = res
383 END IF
384 210 CONTINUE
385 220 CONTINUE
386 230 CONTINUE
387 240 CONTINUE
388 250 CONTINUE
389 260 CONTINUE
390 270 CONTINUE
391 280 CONTINUE
392 290 CONTINUE
393 300 CONTINUE
394*
395 RETURN
396*
397* End of DGET34
398*
dlaexc
subroutine dlaexc(wantq, n, t, ldt, q, ldq, j1, n1, n2, work, info)
DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form...
Definition dlaexc.f:138

◆ dget35()

subroutine dget35 ( double precision rmax,
integer lmax,
integer ninfo,
integer knt )

DGET35

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

Definition at line 77 of file dget35.f.

78*
79* -- LAPACK test routine --
80* -- LAPACK is a software package provided by Univ. of Tennessee, --
81* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
82*
83* .. Scalar Arguments ..
84 INTEGER KNT, LMAX, NINFO
85 DOUBLE PRECISION RMAX
86* ..
87*
88* =====================================================================
89*
90* .. Parameters ..
91 DOUBLE PRECISION ZERO, ONE
92 parameter( zero = 0.0d0, one = 1.0d0 )
93 DOUBLE PRECISION TWO, FOUR
94 parameter( two = 2.0d0, four = 4.0d0 )
95* ..
96* .. Local Scalars ..
97 CHARACTER TRANA, TRANB
98 INTEGER I, IMA, IMB, IMLDA1, IMLDA2, IMLDB1, IMLOFF,
99 $ INFO, ISGN, ITRANA, ITRANB, J, M, N
100 DOUBLE PRECISION BIGNUM, CNRM, EPS, RES, RES1, RMUL, SCALE,
101 $ SMLNUM, TNRM, XNRM
102* ..
103* .. Local Arrays ..
104 INTEGER IDIM( 8 ), IVAL( 6, 6, 8 )
105 DOUBLE PRECISION A( 6, 6 ), B( 6, 6 ), C( 6, 6 ), CC( 6, 6 ),
106 $ DUM( 1 ), VM1( 3 ), VM2( 3 )
107* ..
108* .. External Functions ..
109 DOUBLE PRECISION DLAMCH, DLANGE
110 EXTERNAL dlamch, dlange
111* ..
112* .. External Subroutines ..
113 EXTERNAL dgemm, dlabad, dtrsyl
114* ..
115* .. Intrinsic Functions ..
116 INTRINSIC abs, dble, max, sin, sqrt
117* ..
118* .. Data statements ..
119 DATA idim / 1, 2, 3, 4, 3, 3, 6, 4 /
120 DATA ival / 1, 35*0, 1, 2, 4*0, -2, 0, 28*0, 1, 5*0,
121 $ 5, 1, 2, 3*0, -8, -2, 1, 21*0, 3, 4, 4*0, -5,
122 $ 3, 4*0, 1, 2, 1, 4, 2*0, -3, -9, -1, 1, 14*0,
123 $ 1, 5*0, 2, 3, 4*0, 5, 6, 7, 21*0, 1, 5*0, 1, 3,
124 $ -4, 3*0, 2, 5, 2, 21*0, 1, 2, 4*0, -2, 0, 4*0,
125 $ 5, 6, 3, 4, 2*0, -1, -9, -5, 2, 2*0, 4*8, 5, 6,
126 $ 4*9, -7, 5, 1, 5*0, 1, 5, 2, 3*0, 2, -21, 5,
127 $ 3*0, 1, 2, 3, 4, 14*0 /
128* ..
129* .. Executable Statements ..
130*
131* Get machine parameters
132*
133 eps = dlamch( 'P' )
134 smlnum = dlamch( 'S' )*four / eps
135 bignum = one / smlnum
136 CALL dlabad( smlnum, bignum )
137*
138* Set up test case parameters
139*
140 vm1( 1 ) = sqrt( smlnum )
141 vm1( 2 ) = one
142 vm1( 3 ) = sqrt( bignum )
143 vm2( 1 ) = one
144 vm2( 2 ) = one + two*eps
145 vm2( 3 ) = two
146*
147 knt = 0
148 ninfo = 0
149 lmax = 0
150 rmax = zero
151*
152* Begin test loop
153*
154 DO 150 itrana = 1, 2
155 DO 140 itranb = 1, 2
156 DO 130 isgn = -1, 1, 2
157 DO 120 ima = 1, 8
158 DO 110 imlda1 = 1, 3
159 DO 100 imlda2 = 1, 3
160 DO 90 imloff = 1, 2
161 DO 80 imb = 1, 8
162 DO 70 imldb1 = 1, 3
163 IF( itrana.EQ.1 )
164 $ trana = 'N'
165 IF( itrana.EQ.2 )
166 $ trana = 'T'
167 IF( itranb.EQ.1 )
168 $ tranb = 'N'
169 IF( itranb.EQ.2 )
170 $ tranb = 'T'
171 m = idim( ima )
172 n = idim( imb )
173 tnrm = zero
174 DO 20 i = 1, m
175 DO 10 j = 1, m
176 a( i, j ) = ival( i, j, ima )
177 IF( abs( i-j ).LE.1 ) THEN
178 a( i, j ) = a( i, j )*
179 $ vm1( imlda1 )
180 a( i, j ) = a( i, j )*
181 $ vm2( imlda2 )
182 ELSE
183 a( i, j ) = a( i, j )*
184 $ vm1( imloff )
185 END IF
186 tnrm = max( tnrm,
187 $ abs( a( i, j ) ) )
188 10 CONTINUE
189 20 CONTINUE
190 DO 40 i = 1, n
191 DO 30 j = 1, n
192 b( i, j ) = ival( i, j, imb )
193 IF( abs( i-j ).LE.1 ) THEN
194 b( i, j ) = b( i, j )*
195 $ vm1( imldb1 )
196 ELSE
197 b( i, j ) = b( i, j )*
198 $ vm1( imloff )
199 END IF
200 tnrm = max( tnrm,
201 $ abs( b( i, j ) ) )
202 30 CONTINUE
203 40 CONTINUE
204 cnrm = zero
205 DO 60 i = 1, m
206 DO 50 j = 1, n
207 c( i, j ) = sin( dble( i*j ) )
208 cnrm = max( cnrm, c( i, j ) )
209 cc( i, j ) = c( i, j )
210 50 CONTINUE
211 60 CONTINUE
212 knt = knt + 1
213 CALL dtrsyl( trana, tranb, isgn, m, n,
214 $ a, 6, b, 6, c, 6, scale,
215 $ info )
216 IF( info.NE.0 )
217 $ ninfo = ninfo + 1
218 xnrm = dlange( 'M', m, n, c, 6, dum )
219 rmul = one
220 IF( xnrm.GT.one .AND. tnrm.GT.one )
221 $ THEN
222 IF( xnrm.GT.bignum / tnrm ) THEN
223 rmul = one / max( xnrm, tnrm )
224 END IF
225 END IF
226 CALL dgemm( trana, 'N', m, n, m, rmul,
227 $ a, 6, c, 6, -scale*rmul,
228 $ cc, 6 )
229 CALL dgemm( 'N', tranb, m, n, n,
230 $ dble( isgn )*rmul, c, 6, b,
231 $ 6, one, cc, 6 )
232 res1 = dlange( 'M', m, n, cc, 6, dum )
233 res = res1 / max( smlnum, smlnum*xnrm,
234 $ ( ( rmul*tnrm )*eps )*xnrm )
235 IF( res.GT.rmax ) THEN
236 lmax = knt
237 rmax = res
238 END IF
239 70 CONTINUE
240 80 CONTINUE
241 90 CONTINUE
242 100 CONTINUE
243 110 CONTINUE
244 120 CONTINUE
245 130 CONTINUE
246 140 CONTINUE
247 150 CONTINUE
248*
249 RETURN
250*
251* End of DGET35
252*

◆ dget36()

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

DGET36

Purpose:
!>
!> DGET36 tests DTREXC, a routine for moving blocks (either 1 by 1 or
!> 2 by 2) on the diagonal of a matrix in real Schur form.  Thus, DLAEXC
!> computes an orthogonal 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 (within +-1).
!>
!> The test matrices are read from a file with logical unit number NIN.
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION
!>          Value of the largest test ratio.
!>
[out]LMAX
!>          LMAX is INTEGER
!>          Example number where largest test ratio achieved.
!>
[out]NINFO
!>          NINFO is INTEGER array, dimension (3)
!>          NINFO(J) is the number of examples where INFO=J.
!>
[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 87 of file dget36.f.

88*
89* -- LAPACK test routine --
90* -- LAPACK is a software package provided by Univ. of Tennessee, --
91* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
92*
93* .. Scalar Arguments ..
94 INTEGER KNT, LMAX, NIN
95 DOUBLE PRECISION RMAX
96* ..
97* .. Array Arguments ..
98 INTEGER NINFO( 3 )
99* ..
100*
101* =====================================================================
102*
103* .. Parameters ..
104 DOUBLE PRECISION ZERO, ONE
105 parameter( zero = 0.0d0, one = 1.0d0 )
106 INTEGER LDT, LWORK
107 parameter( ldt = 10, lwork = 2*ldt*ldt )
108* ..
109* .. Local Scalars ..
110 INTEGER I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
111 $ ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
112 DOUBLE PRECISION EPS, RES
113* ..
114* .. Local Arrays ..
115 DOUBLE PRECISION Q( LDT, LDT ), RESULT( 2 ), T1( LDT, LDT ),
116 $ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
117* ..
118* .. External Functions ..
119 DOUBLE PRECISION DLAMCH
120 EXTERNAL dlamch
121* ..
122* .. External Subroutines ..
123 EXTERNAL dhst01, dlacpy, dlaset, dtrexc
124* ..
125* .. Intrinsic Functions ..
126 INTRINSIC abs, sign
127* ..
128* .. Executable Statements ..
129*
130 eps = dlamch( 'P' )
131 rmax = zero
132 lmax = 0
133 knt = 0
134 ninfo( 1 ) = 0
135 ninfo( 2 ) = 0
136 ninfo( 3 ) = 0
137*
138* Read input data until N=0
139*
140 10 CONTINUE
141 READ( nin, fmt = * )n, ifst, ilst
142 IF( n.EQ.0 )
143 $ RETURN
144 knt = knt + 1
145 DO 20 i = 1, n
146 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
147 20 CONTINUE
148 CALL dlacpy( 'F', n, n, tmp, ldt, t1, ldt )
149 CALL dlacpy( 'F', n, n, tmp, ldt, t2, ldt )
150 ifstsv = ifst
151 ilstsv = ilst
152 ifst1 = ifst
153 ilst1 = ilst
154 ifst2 = ifst
155 ilst2 = ilst
156 res = zero
157*
158* Test without accumulating Q
159*
160 CALL dlaset( 'Full', n, n, zero, one, q, ldt )
161 CALL dtrexc( 'N', n, t1, ldt, q, ldt, ifst1, ilst1, work, info1 )
162 DO 40 i = 1, n
163 DO 30 j = 1, n
164 IF( i.EQ.j .AND. q( i, j ).NE.one )
165 $ res = res + one / eps
166 IF( i.NE.j .AND. q( i, j ).NE.zero )
167 $ res = res + one / eps
168 30 CONTINUE
169 40 CONTINUE
170*
171* Test with accumulating Q
172*
173 CALL dlaset( 'Full', n, n, zero, one, q, ldt )
174 CALL dtrexc( 'V', n, t2, ldt, q, ldt, ifst2, ilst2, work, info2 )
175*
176* Compare T1 with T2
177*
178 DO 60 i = 1, n
179 DO 50 j = 1, n
180 IF( t1( i, j ).NE.t2( i, j ) )
181 $ res = res + one / eps
182 50 CONTINUE
183 60 CONTINUE
184 IF( ifst1.NE.ifst2 )
185 $ res = res + one / eps
186 IF( ilst1.NE.ilst2 )
187 $ res = res + one / eps
188 IF( info1.NE.info2 )
189 $ res = res + one / eps
190*
191* Test for successful reordering of T2
192*
193 IF( info2.NE.0 ) THEN
194 ninfo( info2 ) = ninfo( info2 ) + 1
195 ELSE
196 IF( abs( ifst2-ifstsv ).GT.1 )
197 $ res = res + one / eps
198 IF( abs( ilst2-ilstsv ).GT.1 )
199 $ res = res + one / eps
200 END IF
201*
202* Test for small residual, and orthogonality of Q
203*
204 CALL dhst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
205 $ result )
206 res = res + result( 1 ) + result( 2 )
207*
208* Test for T2 being in Schur form
209*
210 loc = 1
211 70 CONTINUE
212 IF( t2( loc+1, loc ).NE.zero ) THEN
213*
214* 2 by 2 block
215*
216 IF( t2( loc, loc+1 ).EQ.zero .OR. t2( loc, loc ).NE.
217 $ t2( loc+1, loc+1 ) .OR. sign( one, t2( loc, loc+1 ) ).EQ.
218 $ sign( one, t2( loc+1, loc ) ) )res = res + one / eps
219 DO 80 i = loc + 2, n
220 IF( t2( i, loc ).NE.zero )
221 $ res = res + one / res
222 IF( t2( i, loc+1 ).NE.zero )
223 $ res = res + one / res
224 80 CONTINUE
225 loc = loc + 2
226 ELSE
227*
228* 1 by 1 block
229*
230 DO 90 i = loc + 1, n
231 IF( t2( i, loc ).NE.zero )
232 $ res = res + one / res
233 90 CONTINUE
234 loc = loc + 1
235 END IF
236 IF( loc.LT.n )
237 $ GO TO 70
238 IF( res.GT.rmax ) THEN
239 rmax = res
240 lmax = knt
241 END IF
242 GO TO 10
243*
244* End of DGET36
245*

◆ dget37()

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

DGET37

Purpose:
!>
!> DGET37 tests DTRSNA, a routine for estimating condition numbers of
!> eigenvalues and/or right eigenvectors of a matrix.
!>
!> The test matrices are read from a file with logical unit number NIN.
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION array, dimension (3)
!>          Value of the largest test ratio.
!>          RMAX(1) = largest ratio comparing different calls to DTRSNA
!>          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 DGEHRD returns INFO nonzero on example i, LMAX(1)=i
!>          If DHSEQR returns INFO nonzero on example i, LMAX(2)=i
!>          If DTRSNA returns INFO nonzero on example i, LMAX(3)=i
!>
[out]NINFO
!>          NINFO is INTEGER array, dimension (3)
!>          NINFO(1) = No. of times DGEHRD returned INFO nonzero
!>          NINFO(2) = No. of times DHSEQR returned INFO nonzero
!>          NINFO(3) = No. of times DTRSNA 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 dget37.f.

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

◆ dget38()

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

DGET38

Purpose:
!>
!> DGET38 tests DTRSEN, a routine for estimating condition numbers of a
!> cluster of eigenvalues and/or its associated right invariant subspace
!>
!> The test matrices are read from a file with logical unit number NIN.
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION array, dimension (3)
!>          Values of the largest test ratios.
!>          RMAX(1) = largest residuals from DHST01 or comparing
!>                    different calls to DTRSEN
!>          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 DGEHRD returns INFO nonzero on example i, LMAX(1)=i
!>          If DHSEQR returns INFO nonzero on example i, LMAX(2)=i
!>          If DTRSEN returns INFO nonzero on example i, LMAX(3)=i
!>
[out]NINFO
!>          NINFO is INTEGER array, dimension (3)
!>          NINFO(1) = No. of times DGEHRD returned INFO nonzero
!>          NINFO(2) = No. of times DHSEQR returned INFO nonzero
!>          NINFO(3) = No. of times DTRSEN 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 dget38.f.

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

◆ dget39()

subroutine dget39 ( double precision rmax,
integer lmax,
integer ninfo,
integer knt )

DGET39

Purpose:
!>
!> DGET39 tests DLAQTR, a routine for solving the real or
!> special complex quasi upper triangular system
!>
!>      op(T)*p = scale*c,
!> or
!>      op(T + iB)*(p+iq) = scale*(c+id),
!>
!> in real arithmetic. T is upper quasi-triangular.
!> If it is complex, then the first diagonal block of T must be
!> 1 by 1, B has the special structure
!>
!>                B = [ b(1) b(2) ... b(n) ]
!>                    [       w            ]
!>                    [           w        ]
!>                    [              .     ]
!>                    [                 w  ]
!>
!> op(A) = A or A', where A' denotes the conjugate transpose of
!> the matrix A.
!>
!> On input, X = [ c ].  On output, X = [ p ].
!>               [ d ]                  [ q ]
!>
!> Scale is an output less than or equal to 1, chosen to avoid
!> overflow in X.
!> This subroutine is specially designed for the condition number
!> estimation in the eigenproblem routine DTRSNA.
!>
!> The test code verifies that the following residual is order 1:
!>
!>      ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)||
!>    -----------------------------------------
!>        max(ulp*(||T||+||B||)*(||x1||+||x2||),
!>            (||T||+||B||)*smlnum/ulp,
!>            smlnum)
!>
!> (The (||T||+||B||)*smlnum/ulp term accounts for possible
!>  (gradual or nongradual) underflow in x1 and x2.)
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION
!>          Value of the largest test ratio.
!>
[out]LMAX
!>          LMAX is INTEGER
!>          Example number where largest test ratio achieved.
!>
[out]NINFO
!>          NINFO is INTEGER
!>          Number of examples where INFO is nonzero.
!>
[out]KNT
!>          KNT is INTEGER
!>          Total number of examples tested.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 102 of file dget39.f.

103*
104* -- LAPACK test routine --
105* -- LAPACK is a software package provided by Univ. of Tennessee, --
106* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
107*
108* .. Scalar Arguments ..
109 INTEGER KNT, LMAX, NINFO
110 DOUBLE PRECISION RMAX
111* ..
112*
113* =====================================================================
114*
115* .. Parameters ..
116 INTEGER LDT, LDT2
117 parameter( ldt = 10, ldt2 = 2*ldt )
118 DOUBLE PRECISION ZERO, ONE
119 parameter( zero = 0.0d0, one = 1.0d0 )
120* ..
121* .. Local Scalars ..
122 INTEGER I, INFO, IVM1, IVM2, IVM3, IVM4, IVM5, J, K, N,
123 $ NDIM
124 DOUBLE PRECISION BIGNUM, DOMIN, DUMM, EPS, NORM, NORMTB, RESID,
125 $ SCALE, SMLNUM, W, XNORM
126* ..
127* .. External Functions ..
128 INTEGER IDAMAX
129 DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE
130 EXTERNAL idamax, dasum, ddot, dlamch, dlange
131* ..
132* .. External Subroutines ..
133 EXTERNAL dcopy, dgemv, dlabad, dlaqtr
134* ..
135* .. Intrinsic Functions ..
136 INTRINSIC abs, cos, dble, max, sin, sqrt
137* ..
138* .. Local Arrays ..
139 INTEGER IDIM( 6 ), IVAL( 5, 5, 6 )
140 DOUBLE PRECISION B( LDT ), D( LDT2 ), DUM( 1 ), T( LDT, LDT ),
141 $ VM1( 5 ), VM2( 5 ), VM3( 5 ), VM4( 5 ),
142 $ VM5( 3 ), WORK( LDT ), X( LDT2 ), Y( LDT2 )
143* ..
144* .. Data statements ..
145 DATA idim / 4, 5*5 /
146 DATA ival / 3, 4*0, 1, 1, -1, 0, 0, 3, 2, 1, 0, 0,
147 $ 4, 3, 2, 2, 0, 5*0, 1, 4*0, 2, 2, 3*0, 3, 3, 4,
148 $ 0, 0, 4, 2, 2, 3, 0, 4*1, 5, 1, 4*0, 2, 4, -2,
149 $ 0, 0, 3, 3, 4, 0, 0, 4, 2, 2, 3, 0, 5*1, 1,
150 $ 4*0, 2, 1, -1, 0, 0, 9, 8, 1, 0, 0, 4, 9, 1, 2,
151 $ -1, 5*2, 9, 4*0, 6, 4, 0, 0, 0, 3, 2, 1, 1, 0,
152 $ 5, 1, -1, 1, 0, 5*2, 4, 4*0, 2, 2, 0, 0, 0, 1,
153 $ 4, 4, 0, 0, 2, 4, 2, 2, -1, 5*2 /
154* ..
155* .. Executable Statements ..
156*
157* Get machine parameters
158*
159 eps = dlamch( 'P' )
160 smlnum = dlamch( 'S' )
161 bignum = one / smlnum
162 CALL dlabad( smlnum, bignum )
163*
164* Set up test case parameters
165*
166 vm1( 1 ) = one
167 vm1( 2 ) = sqrt( smlnum )
168 vm1( 3 ) = sqrt( vm1( 2 ) )
169 vm1( 4 ) = sqrt( bignum )
170 vm1( 5 ) = sqrt( vm1( 4 ) )
171*
172 vm2( 1 ) = one
173 vm2( 2 ) = sqrt( smlnum )
174 vm2( 3 ) = sqrt( vm2( 2 ) )
175 vm2( 4 ) = sqrt( bignum )
176 vm2( 5 ) = sqrt( vm2( 4 ) )
177*
178 vm3( 1 ) = one
179 vm3( 2 ) = sqrt( smlnum )
180 vm3( 3 ) = sqrt( vm3( 2 ) )
181 vm3( 4 ) = sqrt( bignum )
182 vm3( 5 ) = sqrt( vm3( 4 ) )
183*
184 vm4( 1 ) = one
185 vm4( 2 ) = sqrt( smlnum )
186 vm4( 3 ) = sqrt( vm4( 2 ) )
187 vm4( 4 ) = sqrt( bignum )
188 vm4( 5 ) = sqrt( vm4( 4 ) )
189*
190 vm5( 1 ) = one
191 vm5( 2 ) = eps
192 vm5( 3 ) = sqrt( smlnum )
193*
194* Initialization
195*
196 knt = 0
197 rmax = zero
198 ninfo = 0
199 smlnum = smlnum / eps
200*
201* Begin test loop
202*
203 DO 140 ivm5 = 1, 3
204 DO 130 ivm4 = 1, 5
205 DO 120 ivm3 = 1, 5
206 DO 110 ivm2 = 1, 5
207 DO 100 ivm1 = 1, 5
208 DO 90 ndim = 1, 6
209*
210 n = idim( ndim )
211 DO 20 i = 1, n
212 DO 10 j = 1, n
213 t( i, j ) = dble( ival( i, j, ndim ) )*
214 $ vm1( ivm1 )
215 IF( i.GE.j )
216 $ t( i, j ) = t( i, j )*vm5( ivm5 )
217 10 CONTINUE
218 20 CONTINUE
219*
220 w = one*vm2( ivm2 )
221*
222 DO 30 i = 1, n
223 b( i ) = cos( dble( i ) )*vm3( ivm3 )
224 30 CONTINUE
225*
226 DO 40 i = 1, 2*n
227 d( i ) = sin( dble( i ) )*vm4( ivm4 )
228 40 CONTINUE
229*
230 norm = dlange( '1', n, n, t, ldt, work )
231 k = idamax( n, b, 1 )
232 normtb = norm + abs( b( k ) ) + abs( w )
233*
234 CALL dcopy( n, d, 1, x, 1 )
235 knt = knt + 1
236 CALL dlaqtr( .false., .true., n, t, ldt, dum,
237 $ dumm, scale, x, work, info )
238 IF( info.NE.0 )
239 $ ninfo = ninfo + 1
240*
241* || T*x - scale*d || /
242* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum)
243*
244 CALL dcopy( n, d, 1, y, 1 )
245 CALL dgemv( 'No transpose', n, n, one, t, ldt,
246 $ x, 1, -scale, y, 1 )
247 xnorm = dasum( n, x, 1 )
248 resid = dasum( n, y, 1 )
249 domin = max( smlnum, ( smlnum / eps )*norm,
250 $ ( norm*eps )*xnorm )
251 resid = resid / domin
252 IF( resid.GT.rmax ) THEN
253 rmax = resid
254 lmax = knt
255 END IF
256*
257 CALL dcopy( n, d, 1, x, 1 )
258 knt = knt + 1
259 CALL dlaqtr( .true., .true., n, t, ldt, dum,
260 $ dumm, scale, x, work, info )
261 IF( info.NE.0 )
262 $ ninfo = ninfo + 1
263*
264* || T*x - scale*d || /
265* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum)
266*
267 CALL dcopy( n, d, 1, y, 1 )
268 CALL dgemv( 'Transpose', n, n, one, t, ldt, x,
269 $ 1, -scale, y, 1 )
270 xnorm = dasum( n, x, 1 )
271 resid = dasum( n, y, 1 )
272 domin = max( smlnum, ( smlnum / eps )*norm,
273 $ ( norm*eps )*xnorm )
274 resid = resid / domin
275 IF( resid.GT.rmax ) THEN
276 rmax = resid
277 lmax = knt
278 END IF
279*
280 CALL dcopy( 2*n, d, 1, x, 1 )
281 knt = knt + 1
282 CALL dlaqtr( .false., .false., n, t, ldt, b, w,
283 $ scale, x, work, info )
284 IF( info.NE.0 )
285 $ ninfo = ninfo + 1
286*
287* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| /
288* max(ulp*(||T||+||B||)*(||x1||+||x2||),
289* smlnum/ulp * (||T||+||B||), smlnum )
290*
291*
292 CALL dcopy( 2*n, d, 1, y, 1 )
293 y( 1 ) = ddot( n, b, 1, x( 1+n ), 1 ) +
294 $ scale*y( 1 )
295 DO 50 i = 2, n
296 y( i ) = w*x( i+n ) + scale*y( i )
297 50 CONTINUE
298 CALL dgemv( 'No transpose', n, n, one, t, ldt,
299 $ x, 1, -one, y, 1 )
300*
301 y( 1+n ) = ddot( n, b, 1, x, 1 ) -
302 $ scale*y( 1+n )
303 DO 60 i = 2, n
304 y( i+n ) = w*x( i ) - scale*y( i+n )
305 60 CONTINUE
306 CALL dgemv( 'No transpose', n, n, one, t, ldt,
307 $ x( 1+n ), 1, one, y( 1+n ), 1 )
308*
309 resid = dasum( 2*n, y, 1 )
310 domin = max( smlnum, ( smlnum / eps )*normtb,
311 $ eps*( normtb*dasum( 2*n, x, 1 ) ) )
312 resid = resid / domin
313 IF( resid.GT.rmax ) THEN
314 rmax = resid
315 lmax = knt
316 END IF
317*
318 CALL dcopy( 2*n, d, 1, x, 1 )
319 knt = knt + 1
320 CALL dlaqtr( .true., .false., n, t, ldt, b, w,
321 $ scale, x, work, info )
322 IF( info.NE.0 )
323 $ ninfo = ninfo + 1
324*
325* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| /
326* max(ulp*(||T||+||B||)*(||x1||+||x2||),
327* smlnum/ulp * (||T||+||B||), smlnum )
328*
329 CALL dcopy( 2*n, d, 1, y, 1 )
330 y( 1 ) = b( 1 )*x( 1+n ) - scale*y( 1 )
331 DO 70 i = 2, n
332 y( i ) = b( i )*x( 1+n ) + w*x( i+n ) -
333 $ scale*y( i )
334 70 CONTINUE
335 CALL dgemv( 'Transpose', n, n, one, t, ldt, x,
336 $ 1, one, y, 1 )
337*
338 y( 1+n ) = b( 1 )*x( 1 ) + scale*y( 1+n )
339 DO 80 i = 2, n
340 y( i+n ) = b( i )*x( 1 ) + w*x( i ) +
341 $ scale*y( i+n )
342 80 CONTINUE
343 CALL dgemv( 'Transpose', n, n, one, t, ldt,
344 $ x( 1+n ), 1, -one, y( 1+n ), 1 )
345*
346 resid = dasum( 2*n, y, 1 )
347 domin = max( smlnum, ( smlnum / eps )*normtb,
348 $ eps*( normtb*dasum( 2*n, x, 1 ) ) )
349 resid = resid / domin
350 IF( resid.GT.rmax ) THEN
351 rmax = resid
352 lmax = knt
353 END IF
354*
355 90 CONTINUE
356 100 CONTINUE
357 110 CONTINUE
358 120 CONTINUE
359 130 CONTINUE
360 140 CONTINUE
361*
362 RETURN
363*
364* End of DGET39
365*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
dlaqtr
subroutine dlaqtr(ltran, lreal, n, t, ldt, b, w, scale, x, work, info)
DLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of sp...
Definition dlaqtr.f:165
ddot
double precision function ddot(n, dx, incx, dy, incy)
DDOT
Definition ddot.f:82

◆ dget40()

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

DGET40

Purpose:
!>
!> DGET40 tests DTGEXC, a routine for swapping adjacent blocks (either
!> 1 by 1 or 2 by 2) on the diagonal of a pencil in real generalized Schur form.
!> Thus, DTGEXC computes an orthogonal matrices Q and Z such that
!>
!>     Q' * ( [ A B ], [ D E ] ) * Z  = ( [ C1 B1 ], [ F1 E1 ] )
!>          ( [ 0 C ]  [   F ] )        ( [ 0  A1 ]  [    D1]  )
!>
!> where (C1,F1) is similar to (C,F) and (A1,D1) is similar to (A,D).
!> Both (A,D) and (C,F) are assumed to be in standard form
!> and (A1,D1) and (C1,F1) are returned with the
!> same properties.
!>
Parameters
[out]RMAX
!>          RMAX is DOUBLE PRECISION
!>          Value of the largest test ratio.
!>
[out]LMAX
!>          LMAX is INTEGER
!>          Example number where largest test ratio achieved.
!>
[out]NINFO
!>          NINFO is INTEGER(3)
!>          Number of examples where INFO is nonzero.
!>
[out]KNT
!>          KNT is INTEGER
!>          Total number of examples tested.
!>
[out]NIN
!>          NINFO is INTEGER
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 82 of file dget40.f.

83*
84* -- LAPACK test routine --
85* -- LAPACK is a software package provided by Univ. of Tennessee, --
86* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
87*
88* .. Scalar Arguments ..
89 INTEGER KNT, LMAX, NIN
90 DOUBLE PRECISION RMAX
91* ..
92* .. Array Arguments ..
93 INTEGER NINFO( 3 )
94* ..
95*
96* =====================================================================
97*
98* .. Parameters ..
99 DOUBLE PRECISION ZERO, ONE
100 parameter( zero = 0.0d0, one = 1.0d0 )
101 INTEGER LDT, LWORK
102 parameter( ldt = 10, lwork = 100 + 4*ldt + 16 )
103* ..
104* .. Local Scalars ..
105 INTEGER I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
106 $ ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
107 DOUBLE PRECISION EPS, RES
108* ..
109* .. Local Arrays ..
110 DOUBLE PRECISION Q( LDT, LDT ), Z( LDT, LDT ), RESULT( 4 ),
111 $ T( LDT, LDT ), T1( LDT, LDT ), T2( LDT, LDT ),
112 $ S( LDT, LDT ), S1( LDT, LDT ), S2( LDT, LDT ),
113 $ TMP( LDT, LDT ), WORK( LWORK )
114* ..
115* .. External Functions ..
116 DOUBLE PRECISION DLAMCH
117 EXTERNAL dlamch
118* ..
119* .. External Subroutines ..
120 EXTERNAL dhst01, dlacpy, dlaset, dtgexc
121* ..
122* .. Intrinsic Functions ..
123 INTRINSIC abs, sign
124* ..
125* .. Executable Statements ..
126*
127 eps = dlamch( 'P' )
128 rmax = zero
129 lmax = 0
130 knt = 0
131 ninfo( 1 ) = 0
132 ninfo( 2 ) = 0
133 ninfo( 3 ) = 0
134*
135* Read input data until N=0
136*
137 10 CONTINUE
138 READ( nin, fmt = * )n, ifst, ilst
139 IF( n.EQ.0 )
140 $ RETURN
141 knt = knt + 1
142 DO 20 i = 1, n
143 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
144 20 CONTINUE
145 CALL dlacpy( 'F', n, n, tmp, ldt, t, ldt )
146 CALL dlacpy( 'F', n, n, tmp, ldt, t1, ldt )
147 CALL dlacpy( 'F', n, n, tmp, ldt, t2, ldt )
148 DO 25 i = 1, n
149 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
150 25 CONTINUE
151 CALL dlacpy( 'F', n, n, tmp, ldt, s, ldt )
152 CALL dlacpy( 'F', n, n, tmp, ldt, s1, ldt )
153 CALL dlacpy( 'F', n, n, tmp, ldt, s2, ldt )
154 ifstsv = ifst
155 ilstsv = ilst
156 ifst1 = ifst
157 ilst1 = ilst
158 ifst2 = ifst
159 ilst2 = ilst
160 res = zero
161*
162* Test without accumulating Q and Z
163*
164 CALL dlaset( 'Full', n, n, zero, one, q, ldt )
165 CALL dlaset( 'Full', n, n, zero, one, z, ldt )
166 CALL dtgexc( .false., .false., n, t1, ldt, s1, ldt, q, ldt,
167 $ z, ldt, ifst1, ilst1, work, lwork, info1 )
168 DO 40 i = 1, n
169 DO 30 j = 1, n
170 IF( i.EQ.j .AND. q( i, j ).NE.one )
171 $ res = res + one / eps
172 IF( i.NE.j .AND. q( i, j ).NE.zero )
173 $ res = res + one / eps
174 IF( i.EQ.j .AND. z( i, j ).NE.one )
175 $ res = res + one / eps
176 IF( i.NE.j .AND. z( i, j ).NE.zero )
177 $ res = res + one / eps
178 30 CONTINUE
179 40 CONTINUE
180*
181* Test with accumulating Q
182*
183 CALL dlaset( 'Full', n, n, zero, one, q, ldt )
184 CALL dlaset( 'Full', n, n, zero, one, z, ldt )
185 CALL dtgexc( .true., .true., n, t2, ldt, s2, ldt, q, ldt,
186 $ z, ldt, ifst2, ilst2, work, lwork, info2 )
187*
188* Compare T1 with T2 and S1 with S2
189*
190 DO 60 i = 1, n
191 DO 50 j = 1, n
192 IF( t1( i, j ).NE.t2( i, j ) )
193 $ res = res + one / eps
194 IF( s1( i, j ).NE.s2( i, j ) )
195 $ res = res + one / eps
196 50 CONTINUE
197 60 CONTINUE
198 IF( ifst1.NE.ifst2 )
199 $ res = res + one / eps
200 IF( ilst1.NE.ilst2 )
201 $ res = res + one / eps
202 IF( info1.NE.info2 )
203 $ res = res + one / eps
204*
205* Test orthogonality of Q and Z and backward error on T2 and S2
206*
207 CALL dget51( 1, n, t, ldt, t2, ldt, q, ldt, z, ldt, work,
208 $ result( 1 ) )
209 CALL dget51( 1, n, s, ldt, s2, ldt, q, ldt, z, ldt, work,
210 $ result( 2 ) )
211 CALL dget51( 3, n, t, ldt, t2, ldt, q, ldt, q, ldt, work,
212 $ result( 3 ) )
213 CALL dget51( 3, n, t, ldt, t2, ldt, z, ldt, z, ldt, work,
214 $ result( 4 ) )
215 res = res + result( 1 ) + result( 2 ) + result( 3 ) + result( 4 )
216*
217* Read next matrix pair
218*
219 GO TO 10
220*
221* End of DGET40
222*

◆ dget51()

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

DGET51

Purpose:
!>
!>      DGET51  generally checks a decomposition of the form
!>
!>              A = U B V'
!>
!>      where ' means transpose and U and V are orthogonal.
!>
!>      Specifically, if ITYPE=1
!>
!>              RESULT = | A - U B V' | / ( |A| n ulp )
!>
!>      If ITYPE=2, then:
!>
!>              RESULT = | A - B | / ( |A| n ulp )
!>
!>      If ITYPE=3, then:
!>
!>              RESULT = | I - UU' | / ( n ulp )
!>
Parameters
[in]ITYPE
!>          ITYPE is INTEGER
!>          Specifies the type of tests to be performed.
!>          =1: RESULT = | A - U B V' | / ( |A| n ulp )
!>          =2: RESULT = | A - B | / ( |A| n ulp )
!>          =3: RESULT = | I - UU' | / ( n ulp )
!>
[in]N
!>          N is INTEGER
!>          The size of the matrix.  If it is zero, DGET51 does nothing.
!>          It must be at least zero.
!>
[in]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDU, N)
!>          The orthogonal 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 DOUBLE PRECISION array, dimension (LDV, N)
!>          The orthogonal 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 DOUBLE PRECISION array, dimension (2*N**2)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION
!>          The values computed by the test specified by ITYPE.  The
!>          value is currently limited to 1/ulp, to avoid overflow.
!>          Errors are flagged by RESULT=10/ulp.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 147 of file dget51.f.

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

◆ dget52()

subroutine dget52 ( logical left,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( lde, * ) e,
integer lde,
double precision, dimension( * ) alphar,
double precision, dimension( * ) alphai,
double precision, dimension( * ) beta,
double precision, dimension( * ) work,
double precision, dimension( 2 ) result )

DGET52

Purpose:
!>
!> DGET52  does an eigenvector check for the generalized eigenvalue
!> problem.
!>
!> The basic test for right eigenvectors is:
!>
!>                           | b(j) A E(j) -  a(j) B E(j) |
!>         RESULT(1) = max   -------------------------------
!>                      j    n ulp max( |b(j) A|, |a(j) B| )
!>
!> using the 1-norm.  Here, a(j)/b(j) = w is the j-th generalized
!> eigenvalue of A - w B, or, equivalently, b(j)/a(j) = m is the j-th
!> generalized eigenvalue of m A - B.
!>
!> For real eigenvalues, the test is straightforward.  For complex
!> eigenvalues, E(j) and a(j) are complex, represented by
!> Er(j) + i*Ei(j) and ar(j) + i*ai(j), resp., so the test for that
!> eigenvector becomes
!>
!>                 max( |Wr|, |Wi| )
!>     --------------------------------------------
!>     n ulp max( |b(j) A|, (|ar(j)|+|ai(j)|) |B| )
!>
!> where
!>
!>     Wr = b(j) A Er(j) - ar(j) B Er(j) + ai(j) B Ei(j)
!>
!>     Wi = b(j) A Ei(j) - ai(j) B Er(j) - ar(j) B Ei(j)
!>
!>                         T   T  _
!> For left eigenvectors, A , B , a, and b  are used.
!>
!> DGET52 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(j)=b(j)=0, then the eigenvector is set to be the jth coordinate
!> vector.  The normalization test is:
!>
!>         RESULT(2) =      max       | M(v(j)) - 1 | / ( n ulp )
!>                    eigenvectors v(j)
!>
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, DGET52 does
!>          nothing.  It must be at least zero.
!>
[in]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDE, N)
!>          The matrix of eigenvectors.  It must be O( 1 ).  Complex
!>          eigenvalues and eigenvectors always come in pairs, the
!>          eigenvalue and its conjugate being stored in adjacent
!>          elements of ALPHAR, ALPHAI, and BETA.  Thus, if a(j)/b(j)
!>          and a(j+1)/b(j+1) are a complex conjugate pair of
!>          generalized eigenvalues, then E(,j) contains the real part
!>          of the eigenvector and E(,j+1) contains the imaginary part.
!>          Note that whether E(,j) is a real eigenvector or part of a
!>          complex one is specified by whether ALPHAI(j) is zero or not.
!>
[in]LDE
!>          LDE is INTEGER
!>          The leading dimension of E.  It must be at least 1 and at
!>          least N.
!>
[in]ALPHAR
!>          ALPHAR is DOUBLE PRECISION array, dimension (N)
!>          The real parts of the values a(j) as described above, which,
!>          along with b(j), define the generalized eigenvalues.
!>          Complex eigenvalues always come in complex conjugate pairs
!>          a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent
!>          elements in ALPHAR, ALPHAI, and BETA.  Thus, if the j-th
!>          and (j+1)-st eigenvalues form a pair, ALPHAR(j+1)/BETA(j+1)
!>          is assumed to be equal to ALPHAR(j)/BETA(j).
!>
[in]ALPHAI
!>          ALPHAI is DOUBLE PRECISION array, dimension (N)
!>          The imaginary parts of the values a(j) as described above,
!>          which, along with b(j), define the generalized eigenvalues.
!>          If ALPHAI(j)=0, then the eigenvalue is real, otherwise it
!>          is part of a complex conjugate pair.  Complex eigenvalues
!>          always come in complex conjugate pairs a(j)/b(j) and
!>          a(j+1)/b(j+1), which are stored in adjacent elements in
!>          ALPHAR, ALPHAI, and BETA.  Thus, if the j-th and (j+1)-st
!>          eigenvalues form a pair, ALPHAI(j+1)/BETA(j+1) is assumed to
!>          be equal to  -ALPHAI(j)/BETA(j).  Also, nonzero values in
!>          ALPHAI are assumed to always come in adjacent pairs.
!>
[in]BETA
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>          The values b(j) as described above, which, along with a(j),
!>          define the generalized eigenvalues.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N**2+N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the test described above.  If A E or
!>          B E is likely to overflow, then RESULT(1:2) is set to
!>          10 / ulp.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 197 of file dget52.f.

199*
200* -- LAPACK test routine --
201* -- LAPACK is a software package provided by Univ. of Tennessee, --
202* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
203*
204* .. Scalar Arguments ..
205 LOGICAL LEFT
206 INTEGER LDA, LDB, LDE, N
207* ..
208* .. Array Arguments ..
209 DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
210 $ B( LDB, * ), BETA( * ), E( LDE, * ),
211 $ RESULT( 2 ), WORK( * )
212* ..
213*
214* =====================================================================
215*
216* .. Parameters ..
217 DOUBLE PRECISION ZERO, ONE, TEN
218 parameter( zero = 0.0d0, one = 1.0d0, ten = 10.0d0 )
219* ..
220* .. Local Scalars ..
221 LOGICAL ILCPLX
222 CHARACTER NORMAB, TRANS
223 INTEGER J, JVEC
224 DOUBLE PRECISION ABMAX, ACOEF, ALFMAX, ANORM, BCOEFI, BCOEFR,
225 $ BETMAX, BNORM, ENORM, ENRMER, ERRNRM, SAFMAX,
226 $ SAFMIN, SALFI, SALFR, SBETA, SCALE, TEMP1, ULP
227* ..
228* .. External Functions ..
229 DOUBLE PRECISION DLAMCH, DLANGE
230 EXTERNAL dlamch, dlange
231* ..
232* .. External Subroutines ..
233 EXTERNAL dgemv
234* ..
235* .. Intrinsic Functions ..
236 INTRINSIC abs, dble, max
237* ..
238* .. Executable Statements ..
239*
240 result( 1 ) = zero
241 result( 2 ) = zero
242 IF( n.LE.0 )
243 $ RETURN
244*
245 safmin = dlamch( 'Safe minimum' )
246 safmax = one / safmin
247 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
248*
249 IF( left ) THEN
250 trans = 'T'
251 normab = 'I'
252 ELSE
253 trans = 'N'
254 normab = 'O'
255 END IF
256*
257* Norm of A, B, and E:
258*
259 anorm = max( dlange( normab, n, n, a, lda, work ), safmin )
260 bnorm = max( dlange( normab, n, n, b, ldb, work ), safmin )
261 enorm = max( dlange( 'O', n, n, e, lde, work ), ulp )
262 alfmax = safmax / max( one, bnorm )
263 betmax = safmax / max( one, anorm )
264*
265* Compute error matrix.
266* Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B|, |b(i) A| )
267*
268 ilcplx = .false.
269 DO 10 jvec = 1, n
270 IF( ilcplx ) THEN
271*
272* 2nd Eigenvalue/-vector of pair -- do nothing
273*
274 ilcplx = .false.
275 ELSE
276 salfr = alphar( jvec )
277 salfi = alphai( jvec )
278 sbeta = beta( jvec )
279 IF( salfi.EQ.zero ) THEN
280*
281* Real eigenvalue and -vector
282*
283 abmax = max( abs( salfr ), abs( sbeta ) )
284 IF( abs( salfr ).GT.alfmax .OR. abs( sbeta ).GT.
285 $ betmax .OR. abmax.LT.one ) THEN
286 scale = one / max( abmax, safmin )
287 salfr = scale*salfr
288 sbeta = scale*sbeta
289 END IF
290 scale = one / max( abs( salfr )*bnorm,
291 $ abs( sbeta )*anorm, safmin )
292 acoef = scale*sbeta
293 bcoefr = scale*salfr
294 CALL dgemv( trans, n, n, acoef, a, lda, e( 1, jvec ), 1,
295 $ zero, work( n*( jvec-1 )+1 ), 1 )
296 CALL dgemv( trans, n, n, -bcoefr, b, lda, e( 1, jvec ),
297 $ 1, one, work( n*( jvec-1 )+1 ), 1 )
298 ELSE
299*
300* Complex conjugate pair
301*
302 ilcplx = .true.
303 IF( jvec.EQ.n ) THEN
304 result( 1 ) = ten / ulp
305 RETURN
306 END IF
307 abmax = max( abs( salfr )+abs( salfi ), abs( sbeta ) )
308 IF( abs( salfr )+abs( salfi ).GT.alfmax .OR.
309 $ abs( sbeta ).GT.betmax .OR. abmax.LT.one ) THEN
310 scale = one / max( abmax, safmin )
311 salfr = scale*salfr
312 salfi = scale*salfi
313 sbeta = scale*sbeta
314 END IF
315 scale = one / max( ( abs( salfr )+abs( salfi ) )*bnorm,
316 $ abs( sbeta )*anorm, safmin )
317 acoef = scale*sbeta
318 bcoefr = scale*salfr
319 bcoefi = scale*salfi
320 IF( left ) THEN
321 bcoefi = -bcoefi
322 END IF
323*
324 CALL dgemv( trans, n, n, acoef, a, lda, e( 1, jvec ), 1,
325 $ zero, work( n*( jvec-1 )+1 ), 1 )
326 CALL dgemv( trans, n, n, -bcoefr, b, lda, e( 1, jvec ),
327 $ 1, one, work( n*( jvec-1 )+1 ), 1 )
328 CALL dgemv( trans, n, n, bcoefi, b, lda, e( 1, jvec+1 ),
329 $ 1, one, work( n*( jvec-1 )+1 ), 1 )
330*
331 CALL dgemv( trans, n, n, acoef, a, lda, e( 1, jvec+1 ),
332 $ 1, zero, work( n*jvec+1 ), 1 )
333 CALL dgemv( trans, n, n, -bcoefi, b, lda, e( 1, jvec ),
334 $ 1, one, work( n*jvec+1 ), 1 )
335 CALL dgemv( trans, n, n, -bcoefr, b, lda, e( 1, jvec+1 ),
336 $ 1, one, work( n*jvec+1 ), 1 )
337 END IF
338 END IF
339 10 CONTINUE
340*
341 errnrm = dlange( 'One', n, n, work, n, work( n**2+1 ) ) / enorm
342*
343* Compute RESULT(1)
344*
345 result( 1 ) = errnrm / ulp
346*
347* Normalization of E:
348*
349 enrmer = zero
350 ilcplx = .false.
351 DO 40 jvec = 1, n
352 IF( ilcplx ) THEN
353 ilcplx = .false.
354 ELSE
355 temp1 = zero
356 IF( alphai( jvec ).EQ.zero ) THEN
357 DO 20 j = 1, n
358 temp1 = max( temp1, abs( e( j, jvec ) ) )
359 20 CONTINUE
360 enrmer = max( enrmer, abs( temp1-one ) )
361 ELSE
362 ilcplx = .true.
363 DO 30 j = 1, n
364 temp1 = max( temp1, abs( e( j, jvec ) )+
365 $ abs( e( j, jvec+1 ) ) )
366 30 CONTINUE
367 enrmer = max( enrmer, abs( temp1-one ) )
368 END IF
369 END IF
370 40 CONTINUE
371*
372* Compute RESULT(2) : the normalization error in E.
373*
374 result( 2 ) = enrmer / ( dble( n )*ulp )
375*
376 RETURN
377*
378* End of DGET52
379*

◆ dget53()

subroutine dget53 ( double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision scale,
double precision wr,
double precision wi,
double precision result,
integer info )

DGET53

Purpose:
!>
!> DGET53  checks the generalized eigenvalues computed by DLAG2.
!>
!> The basic test for an eigenvalue is:
!>
!>                              | det( s A - w B ) |
!>     RESULT =  ---------------------------------------------------
!>               ulp max( s norm(A), |w| norm(B) )*norm( s A - w B )
!>
!> Two  are performed:
!>
!> (1)  ulp*max( s*norm(A), |w|*norm(B) )  must be at least
!>      safe_minimum.  This insures that the test performed is
!>      not essentially  det(0*A + 0*B)=0.
!>
!> (2)  s*norm(A) + |w|*norm(B) must be less than 1/safe_minimum.
!>      This insures that  s*A - w*B  will not overflow.
!>
!> If these tests are not passed, then  s  and  w  are scaled and
!> tested anyway, if this is possible.
!>
Parameters
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA, 2)
!>          The 2x2 matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 2.
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (LDB, N)
!>          The 2x2 upper-triangular matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of B.  It must be at least 2.
!>
[in]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The  s in the formula  s A - w B .  It is
!>          assumed to be non-negative.
!>
[in]WR
!>          WR is DOUBLE PRECISION
!>          The real part of the eigenvalue  w  in the formula
!>          s A - w B .
!>
[in]WI
!>          WI is DOUBLE PRECISION
!>          The imaginary part of the eigenvalue  w  in the formula
!>          s A - w B .
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION
!>          If INFO is 2 or less, the value computed by the test
!>             described above.
!>          If INFO=3, this will just be 1/ulp.
!>
[out]INFO
!>          INFO is INTEGER
!>          =0:  The input data pass the .
!>          =1:  s*norm(A) + |w|*norm(B) > 1/safe_minimum.
!>          =2:  ulp*max( s*norm(A), |w|*norm(B) ) < safe_minimum
!>          =3:  same as INFO=2, but  s  and  w  could not be scaled so
!>               as to compute the test.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 125 of file dget53.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 INTEGER INFO, LDA, LDB
133 DOUBLE PRECISION RESULT, SCALE, WI, WR
134* ..
135* .. Array Arguments ..
136 DOUBLE PRECISION A( LDA, * ), B( LDB, * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 DOUBLE PRECISION ZERO, ONE
143 parameter( zero = 0.0d0, one = 1.0d0 )
144* ..
145* .. Local Scalars ..
146 DOUBLE PRECISION ABSW, ANORM, BNORM, CI11, CI12, CI22, CNORM,
147 $ CR11, CR12, CR21, CR22, CSCALE, DETI, DETR, S1,
148 $ SAFMIN, SCALES, SIGMIN, TEMP, ULP, WIS, WRS
149* ..
150* .. External Functions ..
151 DOUBLE PRECISION DLAMCH
152 EXTERNAL dlamch
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC abs, max, sqrt
156* ..
157* .. Executable Statements ..
158*
159* Initialize
160*
161 info = 0
162 result = zero
163 scales = scale
164 wrs = wr
165 wis = wi
166*
167* Machine constants and norms
168*
169 safmin = dlamch( 'Safe minimum' )
170 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
171 absw = abs( wrs ) + abs( wis )
172 anorm = max( abs( a( 1, 1 ) )+abs( a( 2, 1 ) ),
173 $ abs( a( 1, 2 ) )+abs( a( 2, 2 ) ), safmin )
174 bnorm = max( abs( b( 1, 1 ) ), abs( b( 1, 2 ) )+abs( b( 2, 2 ) ),
175 $ safmin )
176*
177* Check for possible overflow.
178*
179 temp = ( safmin*bnorm )*absw + ( safmin*anorm )*scales
180 IF( temp.GE.one ) THEN
181*
182* Scale down to avoid overflow
183*
184 info = 1
185 temp = one / temp
186 scales = scales*temp
187 wrs = wrs*temp
188 wis = wis*temp
189 absw = abs( wrs ) + abs( wis )
190 END IF
191 s1 = max( ulp*max( scales*anorm, absw*bnorm ),
192 $ safmin*max( scales, absw ) )
193*
194* Check for W and SCALE essentially zero.
195*
196 IF( s1.LT.safmin ) THEN
197 info = 2
198 IF( scales.LT.safmin .AND. absw.LT.safmin ) THEN
199 info = 3
200 result = one / ulp
201 RETURN
202 END IF
203*
204* Scale up to avoid underflow
205*
206 temp = one / max( scales*anorm+absw*bnorm, safmin )
207 scales = scales*temp
208 wrs = wrs*temp
209 wis = wis*temp
210 absw = abs( wrs ) + abs( wis )
211 s1 = max( ulp*max( scales*anorm, absw*bnorm ),
212 $ safmin*max( scales, absw ) )
213 IF( s1.LT.safmin ) THEN
214 info = 3
215 result = one / ulp
216 RETURN
217 END IF
218 END IF
219*
220* Compute C = s A - w B
221*
222 cr11 = scales*a( 1, 1 ) - wrs*b( 1, 1 )
223 ci11 = -wis*b( 1, 1 )
224 cr21 = scales*a( 2, 1 )
225 cr12 = scales*a( 1, 2 ) - wrs*b( 1, 2 )
226 ci12 = -wis*b( 1, 2 )
227 cr22 = scales*a( 2, 2 ) - wrs*b( 2, 2 )
228 ci22 = -wis*b( 2, 2 )
229*
230* Compute the smallest singular value of s A - w B:
231*
232* |det( s A - w B )|
233* sigma_min = ------------------
234* norm( s A - w B )
235*
236 cnorm = max( abs( cr11 )+abs( ci11 )+abs( cr21 ),
237 $ abs( cr12 )+abs( ci12 )+abs( cr22 )+abs( ci22 ), safmin )
238 cscale = one / sqrt( cnorm )
239 detr = ( cscale*cr11 )*( cscale*cr22 ) -
240 $ ( cscale*ci11 )*( cscale*ci22 ) -
241 $ ( cscale*cr12 )*( cscale*cr21 )
242 deti = ( cscale*cr11 )*( cscale*ci22 ) +
243 $ ( cscale*ci11 )*( cscale*cr22 ) -
244 $ ( cscale*ci12 )*( cscale*cr21 )
245 sigmin = abs( detr ) + abs( deti )
246 result = sigmin / s1
247 RETURN
248*
249* End of DGET53
250*

◆ dget54()

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

DGET54

Purpose:
!>
!> DGET54 checks a generalized decomposition of the form
!>
!>          A = U*S*V'  and B = U*T* V'
!>
!> where ' means transpose and U and V are orthogonal.
!>
!> Specifically,
!>
!>  RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp )
!>
Parameters
[in]N
!>          N is INTEGER
!>          The size of the matrix.  If it is zero, DGET54 does nothing.
!>          It must be at least zero.
!>
[in]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (3*N**2)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION
!>          The value RESULT, It is currently limited to 1/ulp, to
!>          avoid overflow. Errors are flagged by RESULT=10/ulp.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 154 of file dget54.f.

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

◆ dglmts()

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

DGLMTS

Purpose:
!>
!> DGLMTS tests DGGGLM - 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 DOUBLE PRECISION array, dimension (LDA,M)
!>          The N-by-M matrix A.
!>
[out]AF
!>          AF is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,P)
!>          The N-by-P matrix A.
!>
[out]BF
!>          BF is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension( N )
!>          On input, the left hand side of the GLM.
!>
[out]DF
!>          DF is DOUBLE PRECISION array, dimension( N )
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension( M )
!>          solution vector X in the GLM problem.
!>
[out]U
!>          U is DOUBLE PRECISION array, dimension( P )
!>          solution vector U in the GLM problem.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION
!>          The test ratio:
!>                           norm( d - A*x - B*u )
!>            RESULT = -----------------------------------------
!>                     (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 144 of file dglmts.f.

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

◆ dgqrts()

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

DGQRTS

Purpose:
!>
!> DGQRTS tests DGGQRF, 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 DOUBLE PRECISION array, dimension (LDA,M)
!>          The N-by-M matrix A.
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the GQR factorization of A and B, as returned
!>          by DGGQRF, see SGGQRF for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,N)
!>          The M-by-M orthogonal matrix Q.
!>
[out]R
!>          R is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGGQRF.
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (LDB,P)
!>          On entry, the N-by-P matrix A.
!>
[out]BF
!>          BF is DOUBLE PRECISION array, dimension (LDB,N)
!>          Details of the GQR factorization of A and B, as returned
!>          by DGGQRF, see SGGQRF for further details.
!>
[out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDB,P)
!>          The P-by-P orthogonal matrix Z.
!>
[out]T
!>          T is DOUBLE PRECISION array, dimension (LDB,max(P,N))
!>
[out]BWK
!>          BWK is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (min(P,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGGRQF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK, LWORK >= max(N,M,P)**2.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(N,M,P))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios:
!>            RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP)
!>            RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP)
!>            RESULT(3) = norm( I - Q'*Q ) / ( M*ULP )
!>            RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 174 of file dgqrts.f.

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

◆ dgrqts()

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

DGRQTS

Purpose:
!>
!> DGRQTS tests DGGRQF, 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The M-by-N matrix A.
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the GRQ factorization of A and B, as returned
!>          by DGGRQF, see SGGRQF for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,N)
!>          The N-by-N orthogonal matrix Q.
!>
[out]R
!>          R is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGGQRC.
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>          On entry, the P-by-N matrix A.
!>
[out]BF
!>          BF is DOUBLE PRECISION array, dimension (LDB,N)
!>          Details of the GQR factorization of A and B, as returned
!>          by DGGRQF, see SGGRQF for further details.
!>
[out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDB,P)
!>          The P-by-P orthogonal matrix Z.
!>
[out]T
!>          T is DOUBLE PRECISION array, dimension (LDB,max(P,N))
!>
[out]BWK
!>          BWK is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (min(P,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGGRQF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK, LWORK >= max(M,P,N)**2.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios:
!>            RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP)
!>            RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP)
!>            RESULT(3) = norm( I - Q'*Q ) / ( N*ULP )
!>            RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 174 of file dgrqts.f.

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

◆ dgsvts3()

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

DGSVTS3

Purpose:
!>
!> DGSVTS3 tests DGGSVD3, 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 DOUBLE PRECISION array, dimension (LDA,M)
!>          The M-by-N matrix A.
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the GSVD of A and B, as returned by DGGSVD3,
!>          see DGGSVD3 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 DOUBLE PRECISION array, dimension (LDB,P)
!>          On entry, the P-by-N matrix B.
!>
[out]BF
!>          BF is DOUBLE PRECISION array, dimension (LDB,N)
!>          Details of the GSVD of A and B, as returned by DGGSVD3,
!>          see DGGSVD3 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 DOUBLE PRECISION 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]V
!>          V is DOUBLE PRECISION array, dimension(LDV,M)
!>          The P by P orthogonal matrix V.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= max(1,P).
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension(LDQ,N)
!>          The N by N orthogonal matrix Q.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= max(1,N).
!>
[out]ALPHA
!>          ALPHA is DOUBLE PRECISION array, dimension (N)
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>
!>          The generalized singular value pairs of A and B, the
!>          ``diagonal'' matrices D1 and D2 are constructed from
!>          ALPHA and BETA, see subroutine DGGSVD3 for details.
!>
[out]R
!>          R is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK,
!>          LWORK >= max(M,P,N)*max(M,P,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(M,P,N))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          The test ratios:
!>          RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP)
!>          RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP)
!>          RESULT(3) = norm( I - U'*U ) / ( M*ULP )
!>          RESULT(4) = norm( I - V'*V ) / ( P*ULP )
!>          RESULT(5) = norm( I - Q'*Q ) / ( N*ULP )
!>          RESULT(6) = 0        if ALPHA is in decreasing order;
!>                    = ULPINV   otherwise.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 207 of file dgsvts3.f.

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

◆ dhst01()

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

DHST01

Purpose:
!>
!> DHST01 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 DGEHRD + DORGHR.
!>
!> In this version, ILO and IHI are not used and are assumed to be 1 and
!> N, respectively.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The original n by n matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]H
!>          H is DOUBLE PRECISION array, dimension (LDH,N)
!>          The upper Hessenberg matrix H from the reduction A = Q*H*Q'
!>          as computed by DGEHRD.  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 DOUBLE PRECISION array, dimension (LDQ,N)
!>          The orthogonal matrix Q from the reduction A = Q*H*Q' as
!>          computed by DGEHRD + DORGHR.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= 2*N*N.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 132 of file dhst01.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 INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N
141* ..
142* .. Array Arguments ..
143 DOUBLE PRECISION A( LDA, * ), H( LDH, * ), Q( LDQ, * ),
144 $ RESULT( 2 ), WORK( LWORK )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 DOUBLE PRECISION ONE, ZERO
151 parameter( one = 1.0d+0, zero = 0.0d+0 )
152* ..
153* .. Local Scalars ..
154 INTEGER LDWORK
155 DOUBLE PRECISION ANORM, EPS, OVFL, SMLNUM, UNFL, WNORM
156* ..
157* .. External Functions ..
158 DOUBLE PRECISION DLAMCH, DLANGE
159 EXTERNAL dlamch, dlange
160* ..
161* .. External Subroutines ..
162 EXTERNAL dgemm, dlabad, dlacpy, dort01
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC max, min
166* ..
167* .. Executable Statements ..
168*
169* Quick return if possible
170*
171 IF( n.LE.0 ) THEN
172 result( 1 ) = zero
173 result( 2 ) = zero
174 RETURN
175 END IF
176*
177 unfl = dlamch( 'Safe minimum' )
178 eps = dlamch( 'Precision' )
179 ovfl = one / unfl
180 CALL dlabad( unfl, ovfl )
181 smlnum = unfl*n / eps
182*
183* Test 1: Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
184*
185* Copy A to WORK
186*
187 ldwork = max( 1, n )
188 CALL dlacpy( ' ', n, n, a, lda, work, ldwork )
189*
190* Compute Q*H
191*
192 CALL dgemm( 'No transpose', 'No transpose', n, n, n, one, q, ldq,
193 $ h, ldh, zero, work( ldwork*n+1 ), ldwork )
194*
195* Compute A - Q*H*Q'
196*
197 CALL dgemm( 'No transpose', 'Transpose', n, n, n, -one,
198 $ work( ldwork*n+1 ), ldwork, q, ldq, one, work,
199 $ ldwork )
200*
201 anorm = max( dlange( '1', n, n, a, lda, work( ldwork*n+1 ) ),
202 $ unfl )
203 wnorm = dlange( '1', n, n, work, ldwork, work( ldwork*n+1 ) )
204*
205* Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS)
206*
207 result( 1 ) = min( wnorm, anorm ) / max( smlnum, anorm*eps ) / n
208*
209* Test 2: Compute norm( I - Q'*Q ) / ( N * EPS )
210*
211 CALL dort01( 'Columns', n, n, q, ldq, work, lwork, result( 2 ) )
212*
213 RETURN
214*
215* End of DHST01
216*

◆ dlafts()

subroutine dlafts ( character*3 type,
integer m,
integer n,
integer imat,
integer ntests,
double precision, dimension( * ) result,
integer, dimension( 4 ) iseed,
double precision thresh,
integer iounit,
integer ie )

DLAFTS

Purpose:
!>
!>    DLAFTS tests the result vector against the threshold value to
!>    see which tests for this matrix type failed to pass the threshold.
!>    Output is to the file given by unit IOUNIT.
!> 
!>  TYPE   - CHARACTER*3
!>           On entry, TYPE specifies the matrix type to be used in the
!>           printed messages.
!>           Not modified.
!>
!>  N      - INTEGER
!>           On entry, N specifies the order of the test matrix.
!>           Not modified.
!>
!>  IMAT   - INTEGER
!>           On entry, IMAT specifies the type of the test matrix.
!>           A listing of the different types is printed by DLAHD2
!>           to the output file if a test fails to pass the threshold.
!>           Not modified.
!>
!>  NTESTS - INTEGER
!>           On entry, NTESTS is the number of tests performed on the
!>           subroutines in the path given by TYPE.
!>           Not modified.
!>
!>  RESULT - DOUBLE PRECISION               array of dimension( NTESTS )
!>           On entry, RESULT contains the test ratios from the tests
!>           performed in the calling program.
!>           Not modified.
!>
!>  ISEED  - INTEGER            array of dimension( 4 )
!>           Contains the random seed that generated the matrix used
!>           for the tests whose ratios are in RESULT.
!>           Not modified.
!>
!>  THRESH - DOUBLE PRECISION
!>           On entry, THRESH specifies the acceptable threshold of the
!>           test ratios.  If RESULT( K ) > THRESH, then the K-th test
!>           did not pass the threshold and a message will be printed.
!>           Not modified.
!>
!>  IOUNIT - INTEGER
!>           On entry, IOUNIT specifies the unit number of the file
!>           to which the messages are printed.
!>           Not modified.
!>
!>  IE     - INTEGER
!>           On entry, IE contains the number of tests which have
!>           failed to pass the threshold so far.
!>           Updated on exit if any of the ratios in RESULT also fail.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 97 of file dlafts.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 CHARACTER*3 TYPE
106 INTEGER IE, IMAT, IOUNIT, M, N, NTESTS
107 DOUBLE PRECISION THRESH
108* ..
109* .. Array Arguments ..
110 INTEGER ISEED( 4 )
111 DOUBLE PRECISION RESULT( * )
112* ..
113*
114* =====================================================================
115*
116* .. Local Scalars ..
117 INTEGER K
118* ..
119* .. External Subroutines ..
120 EXTERNAL dlahd2
121* ..
122* .. Executable Statements ..
123*
124 IF( m.EQ.n ) THEN
125*
126* Output for square matrices:
127*
128 DO 10 k = 1, ntests
129 IF( result( k ).GE.thresh ) THEN
130*
131* If this is the first test to fail, call DLAHD2
132* to print a header to the data file.
133*
134 IF( ie.EQ.0 )
135 $ CALL dlahd2( iounit, TYPE )
136 ie = ie + 1
137 IF( result( k ).LT.10000.0d0 ) THEN
138 WRITE( iounit, fmt = 9999 )n, imat, iseed, k,
139 $ result( k )
140 9999 FORMAT( ' Matrix order=', i5, ', type=', i2,
141 $ ', seed=', 4( i4, ',' ), ' result ', i3, ' is',
142 $ 0p, f8.2 )
143 ELSE
144 WRITE( iounit, fmt = 9998 )n, imat, iseed, k,
145 $ result( k )
146 9998 FORMAT( ' Matrix order=', i5, ', type=', i2,
147 $ ', seed=', 4( i4, ',' ), ' result ', i3, ' is',
148 $ 1p, d10.3 )
149 END IF
150 END IF
151 10 CONTINUE
152 ELSE
153*
154* Output for rectangular matrices
155*
156 DO 20 k = 1, ntests
157 IF( result( k ).GE.thresh ) THEN
158*
159* If this is the first test to fail, call DLAHD2
160* to print a header to the data file.
161*
162 IF( ie.EQ.0 )
163 $ CALL dlahd2( iounit, TYPE )
164 ie = ie + 1
165 IF( result( k ).LT.10000.0d0 ) THEN
166 WRITE( iounit, fmt = 9997 )m, n, imat, iseed, k,
167 $ result( k )
168 9997 FORMAT( 1x, i5, ' x', i5, ' matrix, type=', i2, ', s',
169 $ 'eed=', 3( i4, ',' ), i4, ': result ', i3,
170 $ ' is', 0p, f8.2 )
171 ELSE
172 WRITE( iounit, fmt = 9996 )m, n, imat, iseed, k,
173 $ result( k )
174 9996 FORMAT( 1x, i5, ' x', i5, ' matrix, type=', i2, ', s',
175 $ 'eed=', 3( i4, ',' ), i4, ': result ', i3,
176 $ ' is', 1p, d10.3 )
177 END IF
178 END IF
179 20 CONTINUE
180*
181 END IF
182 RETURN
183*
184* End of DLAFTS
185*

◆ dlahd2()

subroutine dlahd2 ( integer iounit,
character*3 path )

DLAHD2

Purpose:
!>
!> DLAHD2 prints header information for the different test paths.
!>
Parameters
[in]IOUNIT
!>          IOUNIT is INTEGER.
!>          On entry, IOUNIT specifies the unit number to which the
!>          header information should be printed.
!>
[in]PATH
!>          PATH is CHARACTER*3.
!>          On entry, PATH contains the name of the path for which the
!>          header information is to be printed.  Current paths are
!>
!>             DHS, ZHS:  Non-symmetric eigenproblem.
!>             DST, ZST:  Symmetric eigenproblem.
!>             DSG, ZSG:  Symmetric Generalized eigenproblem.
!>             DBD, ZBD:  Singular Value Decomposition (SVD)
!>             DBB, ZBB:  General Banded reduction to bidiagonal form
!>
!>          These paths also are supplied in double precision (replace
!>          leading S by D and leading C by Z in path names).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 64 of file dlahd2.f.

65*
66* -- LAPACK test routine --
67* -- LAPACK is a software package provided by Univ. of Tennessee, --
68* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
69*
70* .. Scalar Arguments ..
71 CHARACTER*3 PATH
72 INTEGER IOUNIT
73* ..
74*
75* =====================================================================
76*
77* .. Local Scalars ..
78 LOGICAL CORZ, SORD
79 CHARACTER*2 C2
80 INTEGER J
81* ..
82* .. External Functions ..
83 LOGICAL LSAME, LSAMEN
84 EXTERNAL lsame, lsamen
85* ..
86* .. Executable Statements ..
87*
88 IF( iounit.LE.0 )
89 $ RETURN
90 sord = lsame( path, 'S' ) .OR. lsame( path, 'D' )
91 corz = lsame( path, 'C' ) .OR. lsame( path, 'Z' )
92 IF( .NOT.sord .AND. .NOT.corz ) THEN
93 WRITE( iounit, fmt = 9999 )path
94 END IF
95 c2 = path( 2: 3 )
96*
97 IF( lsamen( 2, c2, 'HS' ) ) THEN
98 IF( sord ) THEN
99*
100* Real Non-symmetric Eigenvalue Problem:
101*
102 WRITE( iounit, fmt = 9998 )path
103*
104* Matrix types
105*
106 WRITE( iounit, fmt = 9988 )
107 WRITE( iounit, fmt = 9987 )
108 WRITE( iounit, fmt = 9986 )'pairs ', 'pairs ', 'prs.',
109 $ 'prs.'
110 WRITE( iounit, fmt = 9985 )
111*
112* Tests performed
113*
114 WRITE( iounit, fmt = 9984 )'orthogonal', '''=transpose',
115 $ ( '''', j = 1, 6 )
116*
117 ELSE
118*
119* Complex Non-symmetric Eigenvalue Problem:
120*
121 WRITE( iounit, fmt = 9997 )path
122*
123* Matrix types
124*
125 WRITE( iounit, fmt = 9988 )
126 WRITE( iounit, fmt = 9987 )
127 WRITE( iounit, fmt = 9986 )'e.vals', 'e.vals', 'e.vs',
128 $ 'e.vs'
129 WRITE( iounit, fmt = 9985 )
130*
131* Tests performed
132*
133 WRITE( iounit, fmt = 9984 )'unitary', '*=conj.transp.',
134 $ ( '*', j = 1, 6 )
135 END IF
136*
137 ELSE IF( lsamen( 2, c2, 'ST' ) ) THEN
138*
139 IF( sord ) THEN
140*
141* Real Symmetric Eigenvalue Problem:
142*
143 WRITE( iounit, fmt = 9996 )path
144*
145* Matrix types
146*
147 WRITE( iounit, fmt = 9983 )
148 WRITE( iounit, fmt = 9982 )
149 WRITE( iounit, fmt = 9981 )'Symmetric'
150*
151* Tests performed
152*
153 WRITE( iounit, fmt = 9968 )
154*
155 ELSE
156*
157* Complex Hermitian Eigenvalue Problem:
158*
159 WRITE( iounit, fmt = 9995 )path
160*
161* Matrix types
162*
163 WRITE( iounit, fmt = 9983 )
164 WRITE( iounit, fmt = 9982 )
165 WRITE( iounit, fmt = 9981 )'Hermitian'
166*
167* Tests performed
168*
169 WRITE( iounit, fmt = 9967 )
170 END IF
171*
172 ELSE IF( lsamen( 2, c2, 'SG' ) ) THEN
173*
174 IF( sord ) THEN
175*
176* Real Symmetric Generalized Eigenvalue Problem:
177*
178 WRITE( iounit, fmt = 9992 )path
179*
180* Matrix types
181*
182 WRITE( iounit, fmt = 9980 )
183 WRITE( iounit, fmt = 9979 )
184 WRITE( iounit, fmt = 9978 )'Symmetric'
185*
186* Tests performed
187*
188 WRITE( iounit, fmt = 9977 )
189 WRITE( iounit, fmt = 9976 )
190*
191 ELSE
192*
193* Complex Hermitian Generalized Eigenvalue Problem:
194*
195 WRITE( iounit, fmt = 9991 )path
196*
197* Matrix types
198*
199 WRITE( iounit, fmt = 9980 )
200 WRITE( iounit, fmt = 9979 )
201 WRITE( iounit, fmt = 9978 )'Hermitian'
202*
203* Tests performed
204*
205 WRITE( iounit, fmt = 9975 )
206 WRITE( iounit, fmt = 9974 )
207*
208 END IF
209*
210 ELSE IF( lsamen( 2, c2, 'BD' ) ) THEN
211*
212 IF( sord ) THEN
213*
214* Real Singular Value Decomposition:
215*
216 WRITE( iounit, fmt = 9994 )path
217*
218* Matrix types
219*
220 WRITE( iounit, fmt = 9973 )
221*
222* Tests performed
223*
224 WRITE( iounit, fmt = 9972 )'orthogonal'
225 WRITE( iounit, fmt = 9971 )
226 ELSE
227*
228* Complex Singular Value Decomposition:
229*
230 WRITE( iounit, fmt = 9993 )path
231*
232* Matrix types
233*
234 WRITE( iounit, fmt = 9973 )
235*
236* Tests performed
237*
238 WRITE( iounit, fmt = 9972 )'unitary '
239 WRITE( iounit, fmt = 9971 )
240 END IF
241*
242 ELSE IF( lsamen( 2, c2, 'BB' ) ) THEN
243*
244 IF( sord ) THEN
245*
246* Real General Band reduction to bidiagonal form:
247*
248 WRITE( iounit, fmt = 9990 )path
249*
250* Matrix types
251*
252 WRITE( iounit, fmt = 9970 )
253*
254* Tests performed
255*
256 WRITE( iounit, fmt = 9969 )'orthogonal'
257 ELSE
258*
259* Complex Band reduction to bidiagonal form:
260*
261 WRITE( iounit, fmt = 9989 )path
262*
263* Matrix types
264*
265 WRITE( iounit, fmt = 9970 )
266*
267* Tests performed
268*
269 WRITE( iounit, fmt = 9969 )'unitary '
270 END IF
271*
272 ELSE
273*
274 WRITE( iounit, fmt = 9999 )path
275 RETURN
276 END IF
277*
278 RETURN
279*
280 9999 FORMAT( 1x, a3, ': no header available' )
281 9998 FORMAT( / 1x, a3, ' -- Real Non-symmetric eigenvalue problem' )
282 9997 FORMAT( / 1x, a3, ' -- Complex Non-symmetric eigenvalue problem' )
283 9996 FORMAT( / 1x, a3, ' -- Real Symmetric eigenvalue problem' )
284 9995 FORMAT( / 1x, a3, ' -- Complex Hermitian eigenvalue problem' )
285 9994 FORMAT( / 1x, a3, ' -- Real Singular Value Decomposition' )
286 9993 FORMAT( / 1x, a3, ' -- Complex Singular Value Decomposition' )
287 9992 FORMAT( / 1x, a3, ' -- Real Symmetric Generalized eigenvalue ',
288 $ 'problem' )
289 9991 FORMAT( / 1x, a3, ' -- Complex Hermitian Generalized eigenvalue ',
290 $ 'problem' )
291 9990 FORMAT( / 1x, a3, ' -- Real Band reduc. to bidiagonal form' )
292 9989 FORMAT( / 1x, a3, ' -- Complex Band reduc. to bidiagonal form' )
293*
294 9988 FORMAT( ' Matrix types (see xCHKHS for details): ' )
295*
296 9987 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
297 $ ' ', ' 5=Diagonal: geometr. spaced entries.',
298 $ / ' 2=Identity matrix. ', ' 6=Diagona',
299 $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
300 $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
301 $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
302 $ 'mall, evenly spaced.' )
303 9986 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
304 $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
305 $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
306 $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
307 $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
308 $ 'lex ', a6, / ' 12=Well-cond., random complex ', a6, ' ',
309 $ ' 17=Ill-cond., large rand. complx ', a4, / ' 13=Ill-condi',
310 $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
311 $ ' complx ', a4 )
312 9985 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
313 $ 'with small random entries.', / ' 20=Matrix with large ran',
314 $ 'dom entries. ' )
315 9984 FORMAT( / ' Tests performed: ', '(H is Hessenberg, T is Schur,',
316 $ ' U and Z are ', a, ',', / 20x, a, ', W is a diagonal matr',
317 $ 'ix of eigenvalues,', / 20x, 'L and R are the left and rig',
318 $ 'ht eigenvector matrices)', / ' 1 = | A - U H U', a1, ' |',
319 $ ' / ( |A| n ulp ) ', ' 2 = | I - U U', a1, ' | / ',
320 $ '( n ulp )', / ' 3 = | H - Z T Z', a1, ' | / ( |H| n ulp ',
321 $ ') ', ' 4 = | I - Z Z', a1, ' | / ( n ulp )',
322 $ / ' 5 = | A - UZ T (UZ)', a1, ' | / ( |A| n ulp ) ',
323 $ ' 6 = | I - UZ (UZ)', a1, ' | / ( n ulp )', / ' 7 = | T(',
324 $ 'e.vects.) - T(no e.vects.) | / ( |T| ulp )', / ' 8 = | W',
325 $ '(e.vects.) - W(no e.vects.) | / ( |W| ulp )', / ' 9 = | ',
326 $ 'TR - RW | / ( |T| |R| ulp ) ', ' 10 = | LT - WL | / (',
327 $ ' |T| |L| ulp )', / ' 11= |HX - XW| / (|H| |X| ulp) (inv.',
328 $ 'it)', ' 12= |YH - WY| / (|H| |Y| ulp) (inv.it)' )
329*
330* Symmetric/Hermitian eigenproblem
331*
332 9983 FORMAT( ' Matrix types (see xDRVST for details): ' )
333*
334 9982 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
335 $ ' ', ' 5=Diagonal: clustered entries.', / ' 2=',
336 $ 'Identity matrix. ', ' 6=Diagonal: lar',
337 $ 'ge, evenly spaced.', / ' 3=Diagonal: evenly spaced entri',
338 $ 'es. ', ' 7=Diagonal: small, evenly spaced.', / ' 4=D',
339 $ 'iagonal: geometr. spaced entries.' )
340 9981 FORMAT( ' Dense ', a, ' Matrices:', / ' 8=Evenly spaced eigen',
341 $ 'vals. ', ' 12=Small, evenly spaced eigenvals.',
342 $ / ' 9=Geometrically spaced eigenvals. ', ' 13=Matrix ',
343 $ 'with random O(1) entries.', / ' 10=Clustered eigenvalues.',
344 $ ' ', ' 14=Matrix with large random entries.',
345 $ / ' 11=Large, evenly spaced eigenvals. ', ' 15=Matrix ',
346 $ 'with small random entries.' )
347*
348* Symmetric/Hermitian Generalized eigenproblem
349*
350 9980 FORMAT( ' Matrix types (see xDRVSG for details): ' )
351*
352 9979 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
353 $ ' ', ' 5=Diagonal: clustered entries.', / ' 2=',
354 $ 'Identity matrix. ', ' 6=Diagonal: lar',
355 $ 'ge, evenly spaced.', / ' 3=Diagonal: evenly spaced entri',
356 $ 'es. ', ' 7=Diagonal: small, evenly spaced.', / ' 4=D',
357 $ 'iagonal: geometr. spaced entries.' )
358 9978 FORMAT( ' Dense or Banded ', a, ' Matrices: ',
359 $ / ' 8=Evenly spaced eigenvals. ',
360 $ ' 15=Matrix with small random entries.',
361 $ / ' 9=Geometrically spaced eigenvals. ',
362 $ ' 16=Evenly spaced eigenvals, KA=1, KB=1.',
363 $ / ' 10=Clustered eigenvalues. ',
364 $ ' 17=Evenly spaced eigenvals, KA=2, KB=1.',
365 $ / ' 11=Large, evenly spaced eigenvals. ',
366 $ ' 18=Evenly spaced eigenvals, KA=2, KB=2.',
367 $ / ' 12=Small, evenly spaced eigenvals. ',
368 $ ' 19=Evenly spaced eigenvals, KA=3, KB=1.',
369 $ / ' 13=Matrix with random O(1) entries. ',
370 $ ' 20=Evenly spaced eigenvals, KA=3, KB=2.',
371 $ / ' 14=Matrix with large random entries.',
372 $ ' 21=Evenly spaced eigenvals, KA=3, KB=3.' )
373 9977 FORMAT( / ' Tests performed: ',
374 $ / '( For each pair (A,B), where A is of the given type ',
375 $ / ' and B is a random well-conditioned matrix. D is ',
376 $ / ' diagonal, and Z is orthogonal. )',
377 $ / ' 1 = DSYGV, with ITYPE=1 and UPLO=''U'':',
378 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
379 $ / ' 2 = DSPGV, with ITYPE=1 and UPLO=''U'':',
380 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
381 $ / ' 3 = DSBGV, with ITYPE=1 and UPLO=''U'':',
382 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
383 $ / ' 4 = DSYGV, with ITYPE=1 and UPLO=''L'':',
384 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
385 $ / ' 5 = DSPGV, with ITYPE=1 and UPLO=''L'':',
386 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
387 $ / ' 6 = DSBGV, with ITYPE=1 and UPLO=''L'':',
388 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ' )
389 9976 FORMAT( ' 7 = DSYGV, with ITYPE=2 and UPLO=''U'':',
390 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
391 $ / ' 8 = DSPGV, with ITYPE=2 and UPLO=''U'':',
392 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
393 $ / ' 9 = DSPGV, with ITYPE=2 and UPLO=''L'':',
394 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
395 $ / '10 = DSPGV, with ITYPE=2 and UPLO=''L'':',
396 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
397 $ / '11 = DSYGV, with ITYPE=3 and UPLO=''U'':',
398 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
399 $ / '12 = DSPGV, with ITYPE=3 and UPLO=''U'':',
400 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
401 $ / '13 = DSYGV, with ITYPE=3 and UPLO=''L'':',
402 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
403 $ / '14 = DSPGV, with ITYPE=3 and UPLO=''L'':',
404 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ' )
405 9975 FORMAT( / ' Tests performed: ',
406 $ / '( For each pair (A,B), where A is of the given type ',
407 $ / ' and B is a random well-conditioned matrix. D is ',
408 $ / ' diagonal, and Z is unitary. )',
409 $ / ' 1 = ZHEGV, with ITYPE=1 and UPLO=''U'':',
410 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
411 $ / ' 2 = ZHPGV, with ITYPE=1 and UPLO=''U'':',
412 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
413 $ / ' 3 = ZHBGV, with ITYPE=1 and UPLO=''U'':',
414 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
415 $ / ' 4 = ZHEGV, with ITYPE=1 and UPLO=''L'':',
416 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
417 $ / ' 5 = ZHPGV, with ITYPE=1 and UPLO=''L'':',
418 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
419 $ / ' 6 = ZHBGV, with ITYPE=1 and UPLO=''L'':',
420 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ' )
421 9974 FORMAT( ' 7 = ZHEGV, with ITYPE=2 and UPLO=''U'':',
422 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
423 $ / ' 8 = ZHPGV, with ITYPE=2 and UPLO=''U'':',
424 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
425 $ / ' 9 = ZHPGV, with ITYPE=2 and UPLO=''L'':',
426 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
427 $ / '10 = ZHPGV, with ITYPE=2 and UPLO=''L'':',
428 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
429 $ / '11 = ZHEGV, with ITYPE=3 and UPLO=''U'':',
430 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
431 $ / '12 = ZHPGV, with ITYPE=3 and UPLO=''U'':',
432 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
433 $ / '13 = ZHEGV, with ITYPE=3 and UPLO=''L'':',
434 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
435 $ / '14 = ZHPGV, with ITYPE=3 and UPLO=''L'':',
436 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ' )
437*
438* Singular Value Decomposition
439*
440 9973 FORMAT( ' Matrix types (see xCHKBD for details):',
441 $ / ' Diagonal matrices:', / ' 1: Zero', 28x,
442 $ ' 5: Clustered entries', / ' 2: Identity', 24x,
443 $ ' 6: Large, evenly spaced entries',
444 $ / ' 3: Evenly spaced entries', 11x,
445 $ ' 7: Small, evenly spaced entries',
446 $ / ' 4: Geometrically spaced entries',
447 $ / ' General matrices:', / ' 8: Evenly spaced sing. vals.',
448 $ 7x, '12: Small, evenly spaced sing vals',
449 $ / ' 9: Geometrically spaced sing vals ',
450 $ '13: Random, O(1) entries', / ' 10: Clustered sing. vals.',
451 $ 11x, '14: Random, scaled near overflow',
452 $ / ' 11: Large, evenly spaced sing vals ',
453 $ '15: Random, scaled near underflow' )
454*
455 9972 FORMAT( / ' Test ratios: ',
456 $ '(B: bidiagonal, S: diagonal, Q, P, U, and V: ', a10, / 16x,
457 $ 'X: m x nrhs, Y = Q'' X, and Z = U'' Y)' )
458 9971 FORMAT( ' 1: norm( A - Q B P'' ) / ( norm(A) max(m,n) ulp )',
459 $ / ' 2: norm( I - Q'' Q ) / ( m ulp )',
460 $ / ' 3: norm( I - P'' P ) / ( n ulp )',
461 $ / ' 4: norm( B - U S V'' ) / ( norm(B) min(m,n) ulp )',
462 $ / ' 5: norm( Y - U Z ) / ',
463 $ '( norm(Z) max(min(m,n),k) ulp )',
464 $ / ' 6: norm( I - U'' U ) / ( min(m,n) ulp )',
465 $ / ' 7: norm( I - V'' V ) / ( min(m,n) ulp )',
466 $ / ' 8: Test ordering of S (0 if nondecreasing, 1/ulp ',
467 $ ' otherwise)',
468 $ / ' 9: norm( S - S1 ) / ( norm(S) ulp ),',
469 $ ' where S1 is computed', / 43x,
470 $ ' without computing U and V''',
471 $ / ' 10: Sturm sequence test ',
472 $ '(0 if sing. vals of B within THRESH of S)',
473 $ / ' 11: norm( A - (QU) S (V'' P'') ) / ',
474 $ '( norm(A) max(m,n) ulp )',
475 $ / ' 12: norm( X - (QU) Z ) / ( |X| max(M,k) ulp )',
476 $ / ' 13: norm( I - (QU)''(QU) ) / ( M ulp )',
477 $ / ' 14: norm( I - (V'' P'') (P V) ) / ( N ulp )',
478 $ / ' 15: norm( B - U S V'' ) / ( norm(B) min(m,n) ulp )',
479 $ / ' 16: norm( I - U'' U ) / ( min(m,n) ulp )',
480 $ / ' 17: norm( I - V'' V ) / ( min(m,n) ulp )',
481 $ / ' 18: Test ordering of S (0 if nondecreasing, 1/ulp ',
482 $ ' otherwise)',
483 $ / ' 19: norm( S - S1 ) / ( norm(S) ulp ),',
484 $ ' where S1 is computed', / 43x,
485 $ ' without computing U and V''',
486 $ / ' 20: norm( B - U S V'' ) / ( norm(B) min(m,n) ulp )',
487 $ ' DBDSVX(V,A)',
488 $ / ' 21: norm( I - U'' U ) / ( min(m,n) ulp )',
489 $ / ' 22: norm( I - V'' V ) / ( min(m,n) ulp )',
490 $ / ' 23: Test ordering of S (0 if nondecreasing, 1/ulp ',
491 $ ' otherwise)',
492 $ / ' 24: norm( S - S1 ) / ( norm(S) ulp ),',
493 $ ' where S1 is computed', / 44x,
494 $ ' without computing U and V''',
495 $ / ' 25: norm( S - U'' B V ) / ( norm(B) n ulp )',
496 $ ' DBDSVX(V,I)',
497 $ / ' 26: norm( I - U'' U ) / ( min(m,n) ulp )',
498 $ / ' 27: norm( I - V'' V ) / ( min(m,n) ulp )',
499 $ / ' 28: Test ordering of S (0 if nondecreasing, 1/ulp ',
500 $ ' otherwise)',
501 $ / ' 29: norm( S - S1 ) / ( norm(S) ulp ),',
502 $ ' where S1 is computed', / 44x,
503 $ ' without computing U and V''',
504 $ / ' 30: norm( S - U'' B V ) / ( norm(B) n ulp )',
505 $ ' DBDSVX(V,V)',
506 $ / ' 31: norm( I - U'' U ) / ( min(m,n) ulp )',
507 $ / ' 32: norm( I - V'' V ) / ( min(m,n) ulp )',
508 $ / ' 33: Test ordering of S (0 if nondecreasing, 1/ulp ',
509 $ ' otherwise)',
510 $ / ' 34: norm( S - S1 ) / ( norm(S) ulp ),',
511 $ ' where S1 is computed', / 44x,
512 $ ' without computing U and V''' )
513*
514* Band reduction to bidiagonal form
515*
516 9970 FORMAT( ' Matrix types (see xCHKBB for details):',
517 $ / ' Diagonal matrices:', / ' 1: Zero', 28x,
518 $ ' 5: Clustered entries', / ' 2: Identity', 24x,
519 $ ' 6: Large, evenly spaced entries',
520 $ / ' 3: Evenly spaced entries', 11x,
521 $ ' 7: Small, evenly spaced entries',
522 $ / ' 4: Geometrically spaced entries',
523 $ / ' General matrices:', / ' 8: Evenly spaced sing. vals.',
524 $ 7x, '12: Small, evenly spaced sing vals',
525 $ / ' 9: Geometrically spaced sing vals ',
526 $ '13: Random, O(1) entries', / ' 10: Clustered sing. vals.',
527 $ 11x, '14: Random, scaled near overflow',
528 $ / ' 11: Large, evenly spaced sing vals ',
529 $ '15: Random, scaled near underflow' )
530*
531 9969 FORMAT( / ' Test ratios: ', '(B: upper bidiagonal, Q and P: ',
532 $ a10, / 16x, 'C: m x nrhs, PT = P'', Y = Q'' C)',
533 $ / ' 1: norm( A - Q B PT ) / ( norm(A) max(m,n) ulp )',
534 $ / ' 2: norm( I - Q'' Q ) / ( m ulp )',
535 $ / ' 3: norm( I - PT PT'' ) / ( n ulp )',
536 $ / ' 4: norm( Y - Q'' C ) / ( norm(Y) max(m,nrhs) ulp )' )
537 9968 FORMAT( / ' Tests performed: See sdrvst.f' )
538 9967 FORMAT( / ' Tests performed: See cdrvst.f' )
539*
540* End of DLAHD2
541*

◆ dlarfy()

subroutine dlarfy ( character uplo,
integer n,
double precision, dimension( * ) v,
integer incv,
double precision tau,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) work )

DLARFY

Purpose:
!>
!> DLARFY applies an elementary reflector, or Householder matrix, H,
!> to an n x n symmetric 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
!>          symmetric 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 DOUBLE PRECISION 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 DOUBLE PRECISION
!>          The value tau as described above.
!>
[in,out]C
!>          C is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

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

◆ dlarhs()

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

DLARHS

Purpose:
!>
!> DLARHS 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 or A**T, depending on TRANS.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The type of the real matrix A.  PATH may be given in any
!>          combination of upper and lower case.  Valid types include
!>             xGE:  General m x n matrix
!>             xGB:  General banded matrix
!>             xPO:  Symmetric positive definite, 2-D storage
!>             xPP:  Symmetric positive definite packed
!>             xPB:  Symmetric positive definite 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
!>          Specifies whether the upper or lower triangular part of the
!>          matrix A is stored, if A is symmetric.
!>          = '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 = Transpose)
!>
[in]M
!>          M is INTEGER
!>          The number or 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 DOUBLE PRECISION 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) DOUBLE PRECISION 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 DOUBLE PRECISION 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
!>          DLATMS).  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 203 of file dlarhs.f.

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

◆ dlasum()

subroutine dlasum ( character*3 type,
integer iounit,
integer ie,
integer nrun )

DLASUM

Purpose:
!>
!> DLASUM prints a summary of the results from one of the test routines.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 42 of file dlasum.f.

43*
44* -- LAPACK test routine --
45* -- LAPACK is a software package provided by Univ. of Tennessee, --
46* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
47*
48* .. Scalar Arguments ..
49 CHARACTER*3 TYPE
50 INTEGER IE, IOUNIT, NRUN
51* ..
52*
53* =====================================================================
54*
55* .. Executable Statements ..
56*
57 IF( ie.GT.0 ) THEN
58 WRITE( iounit, fmt = 9999 )TYPE, ': ', IE, ' out of ', NRUN,
59 $ ' tests failed to pass the threshold'
60 ELSE
61 WRITE( iounit, fmt = 9998 )'All tests for ', TYPE,
62 $ ' passed the threshold ( ', NRUN, ' tests run)'
63 END IF
64 9999 FORMAT( 1x, a3, a2, i4, a8, i5, a35 )
65 9998 FORMAT( / 1x, a14, a3, a24, i5, a11 )
66 RETURN
67*
68* End of DLASUM
69*

◆ dlatb9()

subroutine dlatb9 ( character*3 path,
integer imat,
integer m,
integer p,
integer n,
character type,
integer kla,
integer kua,
integer klb,
integer kub,
double precision anorm,
double precision bnorm,
integer modea,
integer modeb,
double precision cndnma,
double precision cndnmb,
character dista,
character distb )

DLATB9

Purpose:
!>
!> DLATB9 sets parameters for the matrix generator based on the type of
!> matrix to be generated.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name.
!>
[in]IMAT
!>          IMAT is INTEGER
!>          An integer key describing which matrix to generate for this
!>          path.
!>          = 1:   A: diagonal, B: upper triangular
!>          = 2:   A: upper triangular, B: upper triangular
!>          = 3:   A: lower triangular, B: upper triangular
!>          Else:  A: general dense, B: general dense
!>
[in]M
!>          M is INTEGER
!>          The number of rows in the matrix to be generated.
!>
[in]P
!>          P is INTEGER
!>
[in]N
!>          N is INTEGER
!>          The number of columns in the matrix to be generated.
!>
[out]TYPE
!>          TYPE is CHARACTER*1
!>          The type of the matrix to be generated:
!>          = 'S':  symmetric matrix;
!>          = 'P':  symmetric positive (semi)definite matrix;
!>          = 'N':  nonsymmetric matrix.
!>
[out]KLA
!>          KLA is INTEGER
!>          The lower band width of the matrix to be generated.
!>
[out]KUA
!>          KUA is INTEGER
!>          The upper band width of the matrix to be generated.
!>
[out]KLB
!>          KLB is INTEGER
!>          The lower band width of the matrix to be generated.
!>
[out]KUB
!>          KUA is INTEGER
!>          The upper band width of the matrix to be generated.
!>
[out]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The desired norm of the matrix to be generated.  The diagonal
!>          matrix of singular values or eigenvalues is scaled by this
!>          value.
!>
[out]BNORM
!>          BNORM is DOUBLE PRECISION
!>          The desired norm of the matrix to be generated.  The diagonal
!>          matrix of singular values or eigenvalues is scaled by this
!>          value.
!>
[out]MODEA
!>          MODEA is INTEGER
!>          A key indicating how to choose the vector of eigenvalues.
!>
[out]MODEB
!>          MODEB is INTEGER
!>          A key indicating how to choose the vector of eigenvalues.
!>
[out]CNDNMA
!>          CNDNMA is DOUBLE PRECISION
!>          The desired condition number.
!>
[out]CNDNMB
!>          CNDNMB is DOUBLE PRECISION
!>          The desired condition number.
!>
[out]DISTA
!>          DISTA is CHARACTER*1
!>          The type of distribution to be used by the random number
!>          generator.
!>
[out]DISTB
!>          DISTB is CHARACTER*1
!>          The type of distribution to be used by the random number
!>          generator.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 167 of file dlatb9.f.

170*
171* -- LAPACK test routine --
172* -- LAPACK is a software package provided by Univ. of Tennessee, --
173* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
174*
175* .. Scalar Arguments ..
176 CHARACTER DISTA, DISTB, TYPE
177 CHARACTER*3 PATH
178 INTEGER IMAT, KLA, KLB, KUA, KUB, M, MODEA, MODEB, N, P
179 DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 DOUBLE PRECISION SHRINK, TENTH
186 parameter( shrink = 0.25d0, tenth = 0.1d+0 )
187 DOUBLE PRECISION ONE, TEN
188 parameter( one = 1.0d+0, ten = 1.0d+1 )
189* ..
190* .. Local Scalars ..
191 LOGICAL FIRST
192 DOUBLE PRECISION BADC1, BADC2, EPS, LARGE, SMALL
193* ..
194* .. External Functions ..
195 LOGICAL LSAMEN
196 DOUBLE PRECISION DLAMCH
197 EXTERNAL lsamen, dlamch
198* ..
199* .. Intrinsic Functions ..
200 INTRINSIC max, sqrt
201* ..
202* .. External Subroutines ..
203 EXTERNAL dlabad
204* ..
205* .. Save statement ..
206 SAVE eps, small, large, badc1, badc2, first
207* ..
208* .. Data statements ..
209 DATA first / .true. /
210* ..
211* .. Executable Statements ..
212*
213* Set some constants for use in the subroutine.
214*
215 IF( first ) THEN
216 first = .false.
217 eps = dlamch( 'Precision' )
218 badc2 = tenth / eps
219 badc1 = sqrt( badc2 )
220 small = dlamch( 'Safe minimum' )
221 large = one / small
222*
223* If it looks like we're on a Cray, take the square root of
224* SMALL and LARGE to avoid overflow and underflow problems.
225*
226 CALL dlabad( small, large )
227 small = shrink*( small / eps )
228 large = one / small
229 END IF
230*
231* Set some parameters we don't plan to change.
232*
233 TYPE = 'N'
234 dista = 'S'
235 distb = 'S'
236 modea = 3
237 modeb = 4
238*
239* Set the lower and upper bandwidths.
240*
241 IF( lsamen( 3, path, 'GRQ' ) .OR. lsamen( 3, path, 'LSE' ) .OR.
242 $ lsamen( 3, path, 'GSV' ) ) THEN
243*
244* A: M by N, B: P by N
245*
246 IF( imat.EQ.1 ) THEN
247*
248* A: diagonal, B: upper triangular
249*
250 kla = 0
251 kua = 0
252 klb = 0
253 kub = max( n-1, 0 )
254*
255 ELSE IF( imat.EQ.2 ) THEN
256*
257* A: upper triangular, B: upper triangular
258*
259 kla = 0
260 kua = max( n-1, 0 )
261 klb = 0
262 kub = max( n-1, 0 )
263*
264 ELSE IF( imat.EQ.3 ) THEN
265*
266* A: lower triangular, B: upper triangular
267*
268 kla = max( m-1, 0 )
269 kua = 0
270 klb = 0
271 kub = max( n-1, 0 )
272*
273 ELSE
274*
275* A: general dense, B: general dense
276*
277 kla = max( m-1, 0 )
278 kua = max( n-1, 0 )
279 klb = max( p-1, 0 )
280 kub = max( n-1, 0 )
281*
282 END IF
283*
284 ELSE IF( lsamen( 3, path, 'GQR' ) .OR. lsamen( 3, path, 'GLM' ) )
285 $ THEN
286*
287* A: N by M, B: N by P
288*
289 IF( imat.EQ.1 ) THEN
290*
291* A: diagonal, B: lower triangular
292*
293 kla = 0
294 kua = 0
295 klb = max( n-1, 0 )
296 kub = 0
297 ELSE IF( imat.EQ.2 ) THEN
298*
299* A: lower triangular, B: diagonal
300*
301 kla = max( n-1, 0 )
302 kua = 0
303 klb = 0
304 kub = 0
305*
306 ELSE IF( imat.EQ.3 ) THEN
307*
308* A: lower triangular, B: upper triangular
309*
310 kla = max( n-1, 0 )
311 kua = 0
312 klb = 0
313 kub = max( p-1, 0 )
314*
315 ELSE
316*
317* A: general dense, B: general dense
318*
319 kla = max( n-1, 0 )
320 kua = max( m-1, 0 )
321 klb = max( n-1, 0 )
322 kub = max( p-1, 0 )
323 END IF
324*
325 END IF
326*
327* Set the condition number and norm.
328*
329 cndnma = ten*ten
330 cndnmb = ten
331 IF( lsamen( 3, path, 'GQR' ) .OR. lsamen( 3, path, 'GRQ' ) .OR.
332 $ lsamen( 3, path, 'GSV' ) ) THEN
333 IF( imat.EQ.5 ) THEN
334 cndnma = badc1
335 cndnmb = badc1
336 ELSE IF( imat.EQ.6 ) THEN
337 cndnma = badc2
338 cndnmb = badc2
339 ELSE IF( imat.EQ.7 ) THEN
340 cndnma = badc1
341 cndnmb = badc2
342 ELSE IF( imat.EQ.8 ) THEN
343 cndnma = badc2
344 cndnmb = badc1
345 END IF
346 END IF
347*
348 anorm = ten
349 bnorm = ten*ten*ten
350 IF( lsamen( 3, path, 'GQR' ) .OR. lsamen( 3, path, 'GRQ' ) ) THEN
351 IF( imat.EQ.7 ) THEN
352 anorm = small
353 bnorm = large
354 ELSE IF( imat.EQ.8 ) THEN
355 anorm = large
356 bnorm = small
357 END IF
358 END IF
359*
360 IF( n.LE.1 ) THEN
361 cndnma = one
362 cndnmb = one
363 END IF
364*
365 RETURN
366*
367* End of DLATB9
368*

◆ dlatm4()

subroutine dlatm4 ( integer itype,
integer n,
integer nz1,
integer nz2,
integer isign,
double precision amagn,
double precision rcond,
double precision triang,
integer idist,
integer, dimension( 4 ) iseed,
double precision, dimension( lda, * ) a,
integer lda )

DLATM4

Purpose:
!>
!> DLATM4 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, ISIGN, 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 ISIGN.
!>
!>          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 DLARND.)
!>
[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]ISIGN
!>          ISIGN is INTEGER
!>          = 0: The sign of the diagonal and subdiagonal entries will
!>               be left unchanged.
!>          = 1: The diagonal and subdiagonal entries will have their
!>               sign changed at random.
!>          = 2: If ITYPE is 2 or 3, then the same as ISIGN=1.
!>               Otherwise, with probability 0.5, odd-even pairs of
!>               diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be
!>               converted to a 2x2 block by pre- and post-multiplying
!>               by distinct random orthogonal rotations.  The remaining
!>               diagonal entries will have their sign changed at random.
!>
[in]AMAGN
!>          AMAGN is DOUBLE PRECISION
!>          The diagonal and subdiagonal entries will be multiplied by
!>          AMAGN.
!>
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          If abs(ITYPE) > 4, then the smallest diagonal entry will be
!>          entry will be RCOND.  RCOND must be between 0 and 1.
!>
[in]TRIANG
!>          TRIANG is DOUBLE PRECISION
!>          The entries above the diagonal will be random numbers with
!>          magnitude bounded by TRIANG (i.e., random numbers multiplied
!>          by TRIANG.)
!>
[in]IDIST
!>          IDIST is INTEGER
!>          Specifies the type of distribution to be used to generate a
!>          random matrix.
!>          = 1:  UNIFORM( 0, 1 )
!>          = 2:  UNIFORM( -1, 1 )
!>          = 3:  NORMAL ( 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 DLATM4 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 DOUBLE PRECISION 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 173 of file dlatm4.f.

175*
176* -- LAPACK test routine --
177* -- LAPACK is a software package provided by Univ. of Tennessee, --
178* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
179*
180* .. Scalar Arguments ..
181 INTEGER IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2
182 DOUBLE PRECISION AMAGN, RCOND, TRIANG
183* ..
184* .. Array Arguments ..
185 INTEGER ISEED( 4 )
186 DOUBLE PRECISION A( LDA, * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 DOUBLE PRECISION ZERO, ONE, TWO
193 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
194 DOUBLE PRECISION HALF
195 parameter( half = one / two )
196* ..
197* .. Local Scalars ..
198 INTEGER I, IOFF, ISDB, ISDE, JC, JD, JR, K, KBEG, KEND,
199 $ KLEN
200 DOUBLE PRECISION ALPHA, CL, CR, SAFMIN, SL, SR, SV1, SV2, TEMP
201* ..
202* .. External Functions ..
203 DOUBLE PRECISION DLAMCH, DLARAN, DLARND
204 EXTERNAL dlamch, dlaran, dlarnd
205* ..
206* .. External Subroutines ..
207 EXTERNAL dlaset
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC abs, dble, exp, log, max, min, mod, sqrt
211* ..
212* .. Executable Statements ..
213*
214 IF( n.LE.0 )
215 $ RETURN
216 CALL dlaset( 'Full', n, n, zero, zero, a, lda )
217*
218* Insure a correct ISEED
219*
220 IF( mod( iseed( 4 ), 2 ).NE.1 )
221 $ iseed( 4 ) = iseed( 4 ) + 1
222*
223* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
224* and RCOND
225*
226 IF( itype.NE.0 ) THEN
227 IF( abs( itype ).GE.4 ) THEN
228 kbeg = max( 1, min( n, nz1+1 ) )
229 kend = max( kbeg, min( n, n-nz2 ) )
230 klen = kend + 1 - kbeg
231 ELSE
232 kbeg = 1
233 kend = n
234 klen = n
235 END IF
236 isdb = 1
237 isde = 0
238 GO TO ( 10, 30, 50, 80, 100, 120, 140, 160,
239 $ 180, 200 )abs( itype )
240*
241* abs(ITYPE) = 1: Identity
242*
243 10 CONTINUE
244 DO 20 jd = 1, n
245 a( jd, jd ) = one
246 20 CONTINUE
247 GO TO 220
248*
249* abs(ITYPE) = 2: Transposed Jordan block
250*
251 30 CONTINUE
252 DO 40 jd = 1, n - 1
253 a( jd+1, jd ) = one
254 40 CONTINUE
255 isdb = 1
256 isde = n - 1
257 GO TO 220
258*
259* abs(ITYPE) = 3: Transposed Jordan block, followed by the
260* identity.
261*
262 50 CONTINUE
263 k = ( n-1 ) / 2
264 DO 60 jd = 1, k
265 a( jd+1, jd ) = one
266 60 CONTINUE
267 isdb = 1
268 isde = k
269 DO 70 jd = k + 2, 2*k + 1
270 a( jd, jd ) = one
271 70 CONTINUE
272 GO TO 220
273*
274* abs(ITYPE) = 4: 1,...,k
275*
276 80 CONTINUE
277 DO 90 jd = kbeg, kend
278 a( jd, jd ) = dble( jd-nz1 )
279 90 CONTINUE
280 GO TO 220
281*
282* abs(ITYPE) = 5: One large D value:
283*
284 100 CONTINUE
285 DO 110 jd = kbeg + 1, kend
286 a( jd, jd ) = rcond
287 110 CONTINUE
288 a( kbeg, kbeg ) = one
289 GO TO 220
290*
291* abs(ITYPE) = 6: One small D value:
292*
293 120 CONTINUE
294 DO 130 jd = kbeg, kend - 1
295 a( jd, jd ) = one
296 130 CONTINUE
297 a( kend, kend ) = rcond
298 GO TO 220
299*
300* abs(ITYPE) = 7: Exponentially distributed D values:
301*
302 140 CONTINUE
303 a( kbeg, kbeg ) = one
304 IF( klen.GT.1 ) THEN
305 alpha = rcond**( one / dble( klen-1 ) )
306 DO 150 i = 2, klen
307 a( nz1+i, nz1+i ) = alpha**dble( i-1 )
308 150 CONTINUE
309 END IF
310 GO TO 220
311*
312* abs(ITYPE) = 8: Arithmetically distributed D values:
313*
314 160 CONTINUE
315 a( kbeg, kbeg ) = one
316 IF( klen.GT.1 ) THEN
317 alpha = ( one-rcond ) / dble( klen-1 )
318 DO 170 i = 2, klen
319 a( nz1+i, nz1+i ) = dble( klen-i )*alpha + rcond
320 170 CONTINUE
321 END IF
322 GO TO 220
323*
324* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1):
325*
326 180 CONTINUE
327 alpha = log( rcond )
328 DO 190 jd = kbeg, kend
329 a( jd, jd ) = exp( alpha*dlaran( iseed ) )
330 190 CONTINUE
331 GO TO 220
332*
333* abs(ITYPE) = 10: Randomly distributed D values from DIST
334*
335 200 CONTINUE
336 DO 210 jd = kbeg, kend
337 a( jd, jd ) = dlarnd( idist, iseed )
338 210 CONTINUE
339*
340 220 CONTINUE
341*
342* Scale by AMAGN
343*
344 DO 230 jd = kbeg, kend
345 a( jd, jd ) = amagn*dble( a( jd, jd ) )
346 230 CONTINUE
347 DO 240 jd = isdb, isde
348 a( jd+1, jd ) = amagn*dble( a( jd+1, jd ) )
349 240 CONTINUE
350*
351* If ISIGN = 1 or 2, assign random signs to diagonal and
352* subdiagonal
353*
354 IF( isign.GT.0 ) THEN
355 DO 250 jd = kbeg, kend
356 IF( dble( a( jd, jd ) ).NE.zero ) THEN
357 IF( dlaran( iseed ).GT.half )
358 $ a( jd, jd ) = -a( jd, jd )
359 END IF
360 250 CONTINUE
361 DO 260 jd = isdb, isde
362 IF( dble( a( jd+1, jd ) ).NE.zero ) THEN
363 IF( dlaran( iseed ).GT.half )
364 $ a( jd+1, jd ) = -a( jd+1, jd )
365 END IF
366 260 CONTINUE
367 END IF
368*
369* Reverse if ITYPE < 0
370*
371 IF( itype.LT.0 ) THEN
372 DO 270 jd = kbeg, ( kbeg+kend-1 ) / 2
373 temp = a( jd, jd )
374 a( jd, jd ) = a( kbeg+kend-jd, kbeg+kend-jd )
375 a( kbeg+kend-jd, kbeg+kend-jd ) = temp
376 270 CONTINUE
377 DO 280 jd = 1, ( n-1 ) / 2
378 temp = a( jd+1, jd )
379 a( jd+1, jd ) = a( n+1-jd, n-jd )
380 a( n+1-jd, n-jd ) = temp
381 280 CONTINUE
382 END IF
383*
384* If ISIGN = 2, and no subdiagonals already, then apply
385* random rotations to make 2x2 blocks.
386*
387 IF( isign.EQ.2 .AND. itype.NE.2 .AND. itype.NE.3 ) THEN
388 safmin = dlamch( 'S' )
389 DO 290 jd = kbeg, kend - 1, 2
390 IF( dlaran( iseed ).GT.half ) THEN
391*
392* Rotation on left.
393*
394 cl = two*dlaran( iseed ) - one
395 sl = two*dlaran( iseed ) - one
396 temp = one / max( safmin, sqrt( cl**2+sl**2 ) )
397 cl = cl*temp
398 sl = sl*temp
399*
400* Rotation on right.
401*
402 cr = two*dlaran( iseed ) - one
403 sr = two*dlaran( iseed ) - one
404 temp = one / max( safmin, sqrt( cr**2+sr**2 ) )
405 cr = cr*temp
406 sr = sr*temp
407*
408* Apply
409*
410 sv1 = a( jd, jd )
411 sv2 = a( jd+1, jd+1 )
412 a( jd, jd ) = cl*cr*sv1 + sl*sr*sv2
413 a( jd+1, jd ) = -sl*cr*sv1 + cl*sr*sv2
414 a( jd, jd+1 ) = -cl*sr*sv1 + sl*cr*sv2
415 a( jd+1, jd+1 ) = sl*sr*sv1 + cl*cr*sv2
416 END IF
417 290 CONTINUE
418 END IF
419*
420 END IF
421*
422* Fill in upper triangle (except for 2x2 blocks)
423*
424 IF( triang.NE.zero ) THEN
425 IF( isign.NE.2 .OR. itype.EQ.2 .OR. itype.EQ.3 ) THEN
426 ioff = 1
427 ELSE
428 ioff = 2
429 DO 300 jr = 1, n - 1
430 IF( a( jr+1, jr ).EQ.zero )
431 $ a( jr, jr+1 ) = triang*dlarnd( idist, iseed )
432 300 CONTINUE
433 END IF
434*
435 DO 320 jc = 2, n
436 DO 310 jr = 1, jc - ioff
437 a( jr, jc ) = triang*dlarnd( idist, iseed )
438 310 CONTINUE
439 320 CONTINUE
440 END IF
441*
442 RETURN
443*
444* End of DLATM4
445*

◆ dlctes()

logical function dlctes ( double precision zr,
double precision zi,
double precision d )

DLCTES

Purpose:
!>
!> DLCTES returns .TRUE. if the eigenvalue (ZR/D) + sqrt(-1)*(ZI/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 DDRGES to test whether the driver
!> routine DGGES successfully sorts eigenvalues.
!>
Parameters
[in]ZR
!>          ZR is DOUBLE PRECISION
!>          The numerator of the real part of a complex eigenvalue
!>          (ZR/D) + i*(ZI/D).
!>
[in]ZI
!>          ZI is DOUBLE PRECISION
!>          The numerator of the imaginary part of a complex eigenvalue
!>          (ZR/D) + i*(ZI).
!>
[in]D
!>          D is DOUBLE PRECISION
!>          The denominator part of a complex eigenvalue
!>          (ZR/D) + i*(ZI/D).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 67 of file dlctes.f.

68*
69* -- LAPACK test routine --
70* -- LAPACK is a software package provided by Univ. of Tennessee, --
71* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
72*
73* .. Scalar Arguments ..
74 DOUBLE PRECISION D, ZI, ZR
75* ..
76*
77* =====================================================================
78*
79* .. Parameters ..
80 DOUBLE PRECISION ZERO, ONE
81 parameter( zero = 0.0d+0, one = 1.0d+0 )
82* ..
83* .. Intrinsic Functions ..
84 INTRINSIC sign
85* ..
86* .. Executable Statements ..
87*
88 IF( d.EQ.zero ) THEN
89 dlctes = ( zr.LT.zero )
90 ELSE
91 dlctes = ( sign( one, zr ).NE.sign( one, d ) )
92 END IF
93*
94 RETURN
95*
96* End of DLCTES
97*

◆ dlctsx()

logical function dlctsx ( double precision ar,
double precision ai,
double precision beta )

DLCTSX

Purpose:
!>
!> This function is used to determine what eigenvalues will be
!> selected.  If this is part of the test driver DDRGSX, do not
!> change the code UNLESS you are testing input examples and not
!> using the built-in examples.
!>
Parameters
[in]AR
!>          AR is DOUBLE PRECISION
!>          The numerator of the real part of a complex eigenvalue
!>          (AR/BETA) + i*(AI/BETA).
!>
[in]AI
!>          AI is DOUBLE PRECISION
!>          The numerator of the imaginary part of a complex eigenvalue
!>          (AR/BETA) + i*(AI).
!>
[in]BETA
!>          BETA is DOUBLE PRECISION
!>          The denominator part of a complex eigenvalue
!>          (AR/BETA) + i*(AI/BETA).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 64 of file dlctsx.f.

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

◆ dlsets()

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

DLSETS

Purpose:
!>
!> DLSETS tests DGGLSE - 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The M-by-N matrix A.
!>
[out]AF
!>          AF is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,N)
!>          The P-by-N matrix A.
!>
[out]BF
!>          BF is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension( M )
!>          the vector C in the LSE problem.
!>
[out]CF
!>          CF is DOUBLE PRECISION array, dimension( M )
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension( P )
!>          the vector D in the LSE problem.
!>
[out]DF
!>          DF is DOUBLE PRECISION array, dimension( P )
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension( N )
!>          solution vector X in the LSE problem.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>            RESULT(1) = norm( A*x - c )/ norm(A)*norm(X)*EPS
!>            RESULT(2) = norm( B*x - d )/ norm(B)*norm(X)*EPS
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 149 of file dlsets.f.

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

◆ dort01()

subroutine dort01 ( character rowcol,
integer m,
integer n,
double precision, dimension( ldu, * ) u,
integer ldu,
double precision, dimension( * ) work,
integer lwork,
double precision resid )

DORT01

Purpose:
!>
!> DORT01 checks that the matrix U is orthogonal 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 DOUBLE PRECISION array, dimension (LDU,N)
!>          The orthogonal 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 DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  For best performance, LWORK
!>          should be at least N*(N+1) if ROWCOL = 'C' or M*(M+1) if
!>          ROWCOL = 'R', but the test will be done even if LWORK is 0.
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or
!>          RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 115 of file dort01.f.

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

◆ dort03()

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

DORT03

Purpose:
!>
!> DORT03 compares two orthogonal 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 S is +-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 DORT03 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 DORT03 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
!>          DORT03 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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]RESULT
!>          RESULT is DOUBLE PRECISION
!>          The value computed by the test described above.  RESULT is
!>          limited to 1/ulp to avoid overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          0  indicates a successful exit
!>          -k indicates the k-th parameter had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 154 of file dort03.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 CHARACTER*( * ) RC
163 INTEGER INFO, K, LDU, LDV, LWORK, MU, MV, N
164 DOUBLE PRECISION RESULT
165* ..
166* .. Array Arguments ..
167 DOUBLE PRECISION U( LDU, * ), V( LDV, * ), WORK( * )
168* ..
169*
170* =====================================================================
171*
172* .. Parameters ..
173 DOUBLE PRECISION ZERO, ONE
174 parameter( zero = 0.0d0, one = 1.0d0 )
175* ..
176* .. Local Scalars ..
177 INTEGER I, IRC, J, LMX
178 DOUBLE PRECISION RES1, RES2, S, ULP
179* ..
180* .. External Functions ..
181 LOGICAL LSAME
182 INTEGER IDAMAX
183 DOUBLE PRECISION DLAMCH
184 EXTERNAL lsame, idamax, dlamch
185* ..
186* .. Intrinsic Functions ..
187 INTRINSIC abs, dble, max, min, sign
188* ..
189* .. External Subroutines ..
190 EXTERNAL dort01, xerbla
191* ..
192* .. Executable Statements ..
193*
194* Check inputs
195*
196 info = 0
197 IF( lsame( rc, 'R' ) ) THEN
198 irc = 0
199 ELSE IF( lsame( rc, 'C' ) ) THEN
200 irc = 1
201 ELSE
202 irc = -1
203 END IF
204 IF( irc.EQ.-1 ) THEN
205 info = -1
206 ELSE IF( mu.LT.0 ) THEN
207 info = -2
208 ELSE IF( mv.LT.0 ) THEN
209 info = -3
210 ELSE IF( n.LT.0 ) THEN
211 info = -4
212 ELSE IF( k.LT.0 .OR. k.GT.max( mu, mv ) ) THEN
213 info = -5
214 ELSE IF( ( irc.EQ.0 .AND. ldu.LT.max( 1, mu ) ) .OR.
215 $ ( irc.EQ.1 .AND. ldu.LT.max( 1, n ) ) ) THEN
216 info = -7
217 ELSE IF( ( irc.EQ.0 .AND. ldv.LT.max( 1, mv ) ) .OR.
218 $ ( irc.EQ.1 .AND. ldv.LT.max( 1, n ) ) ) THEN
219 info = -9
220 END IF
221 IF( info.NE.0 ) THEN
222 CALL xerbla( 'DORT03', -info )
223 RETURN
224 END IF
225*
226* Initialize result
227*
228 result = zero
229 IF( mu.EQ.0 .OR. mv.EQ.0 .OR. n.EQ.0 )
230 $ RETURN
231*
232* Machine constants
233*
234 ulp = dlamch( 'Precision' )
235*
236 IF( irc.EQ.0 ) THEN
237*
238* Compare rows
239*
240 res1 = zero
241 DO 20 i = 1, k
242 lmx = idamax( n, u( i, 1 ), ldu )
243 s = sign( one, u( i, lmx ) )*sign( one, v( i, lmx ) )
244 DO 10 j = 1, n
245 res1 = max( res1, abs( u( i, j )-s*v( i, j ) ) )
246 10 CONTINUE
247 20 CONTINUE
248 res1 = res1 / ( dble( n )*ulp )
249*
250* Compute orthogonality of rows of V.
251*
252 CALL dort01( 'Rows', mv, n, v, ldv, work, lwork, res2 )
253*
254 ELSE
255*
256* Compare columns
257*
258 res1 = zero
259 DO 40 i = 1, k
260 lmx = idamax( n, u( 1, i ), 1 )
261 s = sign( one, u( lmx, i ) )*sign( one, v( lmx, i ) )
262 DO 30 j = 1, n
263 res1 = max( res1, abs( u( j, i )-s*v( j, i ) ) )
264 30 CONTINUE
265 40 CONTINUE
266 res1 = res1 / ( dble( n )*ulp )
267*
268* Compute orthogonality of columns of V.
269*
270 CALL dort01( 'Columns', n, mv, v, ldv, work, lwork, res2 )
271 END IF
272*
273 result = min( max( res1, res2 ), one / ulp )
274 RETURN
275*
276* End of DORT03
277*

◆ dsbt21()

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

DSBT21

Purpose:
!>
!> DSBT21  generally checks a decomposition of the form
!>
!>         A = U S U**T
!>
!> where **T means transpose, A is symmetric banded, U is
!> orthogonal, and S is diagonal (if KS=0) or symmetric
!> tridiagonal (if KS=1).
!>
!> Specifically:
!>
!>         RESULT(1) = | A - U S U**T | / ( |A| n ulp ) and
!>         RESULT(2) = | I - U U**T | / ( 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, DSBT21 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 DOUBLE PRECISION 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.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least min( KA, N-1 ).
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix S.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix S.
!>          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
!>          (3,2) element, etc.
!>          Not referenced if KS=0.
!>
[in]U
!>          U is DOUBLE PRECISION array, dimension (LDU, N)
!>          The orthogonal 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 DOUBLE PRECISION array, dimension (N**2+N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 145 of file dsbt21.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 CHARACTER UPLO
154 INTEGER KA, KS, LDA, LDU, N
155* ..
156* .. Array Arguments ..
157 DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
158 $ U( LDU, * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 DOUBLE PRECISION ZERO, ONE
165 parameter( zero = 0.0d0, one = 1.0d0 )
166* ..
167* .. Local Scalars ..
168 LOGICAL LOWER
169 CHARACTER CUPLO
170 INTEGER IKA, J, JC, JR, LW
171 DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
172* ..
173* .. External Functions ..
174 LOGICAL LSAME
175 DOUBLE PRECISION DLAMCH, DLANGE, DLANSB, DLANSP
176 EXTERNAL lsame, dlamch, dlange, dlansb, dlansp
177* ..
178* .. External Subroutines ..
179 EXTERNAL dgemm, dspr, dspr2
180* ..
181* .. Intrinsic Functions ..
182 INTRINSIC dble, max, min
183* ..
184* .. Executable Statements ..
185*
186* Constants
187*
188 result( 1 ) = zero
189 result( 2 ) = zero
190 IF( n.LE.0 )
191 $ RETURN
192*
193 ika = max( 0, min( n-1, ka ) )
194 lw = ( n*( n+1 ) ) / 2
195*
196 IF( lsame( uplo, 'U' ) ) THEN
197 lower = .false.
198 cuplo = 'U'
199 ELSE
200 lower = .true.
201 cuplo = 'L'
202 END IF
203*
204 unfl = dlamch( 'Safe minimum' )
205 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
206*
207* Some Error Checks
208*
209* Do Test 1
210*
211* Norm of A:
212*
213 anorm = max( dlansb( '1', cuplo, n, ika, a, lda, work ), unfl )
214*
215* Compute error matrix: Error = A - U S U**T
216*
217* Copy A from SB to SP storage format.
218*
219 j = 0
220 DO 50 jc = 1, n
221 IF( lower ) THEN
222 DO 10 jr = 1, min( ika+1, n+1-jc )
223 j = j + 1
224 work( j ) = a( jr, jc )
225 10 CONTINUE
226 DO 20 jr = ika + 2, n + 1 - jc
227 j = j + 1
228 work( j ) = zero
229 20 CONTINUE
230 ELSE
231 DO 30 jr = ika + 2, jc
232 j = j + 1
233 work( j ) = zero
234 30 CONTINUE
235 DO 40 jr = min( ika, jc-1 ), 0, -1
236 j = j + 1
237 work( j ) = a( ika+1-jr, jc )
238 40 CONTINUE
239 END IF
240 50 CONTINUE
241*
242 DO 60 j = 1, n
243 CALL dspr( cuplo, n, -d( j ), u( 1, j ), 1, work )
244 60 CONTINUE
245*
246 IF( n.GT.1 .AND. ks.EQ.1 ) THEN
247 DO 70 j = 1, n - 1
248 CALL dspr2( cuplo, n, -e( j ), u( 1, j ), 1, u( 1, j+1 ), 1,
249 $ work )
250 70 CONTINUE
251 END IF
252 wnorm = dlansp( '1', cuplo, n, work, work( lw+1 ) )
253*
254 IF( anorm.GT.wnorm ) THEN
255 result( 1 ) = ( wnorm / anorm ) / ( n*ulp )
256 ELSE
257 IF( anorm.LT.one ) THEN
258 result( 1 ) = ( min( wnorm, n*anorm ) / anorm ) / ( n*ulp )
259 ELSE
260 result( 1 ) = min( wnorm / anorm, dble( n ) ) / ( n*ulp )
261 END IF
262 END IF
263*
264* Do Test 2
265*
266* Compute U U**T - I
267*
268 CALL dgemm( 'N', 'C', n, n, n, one, u, ldu, u, ldu, zero, work,
269 $ n )
270*
271 DO 80 j = 1, n
272 work( ( n+1 )*( j-1 )+1 ) = work( ( n+1 )*( j-1 )+1 ) - one
273 80 CONTINUE
274*
275 result( 2 ) = min( dlange( '1', n, n, work, n, work( n**2+1 ) ),
276 $ dble( n ) ) / ( n*ulp )
277*
278 RETURN
279*
280* End of DSBT21
281*
dlansp
double precision function dlansp(norm, uplo, n, ap, work)
DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlansp.f:114
dlansb
double precision function dlansb(norm, uplo, n, k, ab, ldab, work)
DLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlansb.f:129
dspr2
subroutine dspr2(uplo, n, alpha, x, incx, y, incy, ap)
DSPR2
Definition dspr2.f:142
dspr
subroutine dspr(uplo, n, alpha, x, incx, ap)
DSPR
Definition dspr.f:127

◆ dsgt01()

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

DSGT01

Purpose:
!>
!> DDGT01 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 symmetric matrix, B is
!> symmetric positive definite, Z is orthogonal, 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 symmetric 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
!>          symmetric 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.  0 <= M <= N.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA, N)
!>          The original symmetric matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (LDB, N)
!>          The original symmetric positive definite matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ, M)
!>          The computed eigenvectors of the generalized eigenproblem.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= max(1,N).
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (M)
!>          The computed eigenvalues of the generalized eigenproblem.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N*N)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (1)
!>          The test ratio as described above.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 144 of file dsgt01.f.

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

◆ dslect()

logical function dslect ( double precision zr,
double precision zi )

DSLECT

Purpose:
!>
!> DSLECT returns .TRUE. if the eigenvalue ZR+sqrt(-1)*ZI is to be
!> selected, and otherwise it returns .FALSE.
!> It is used by DCHK41 to test if DGEES successfully sorts eigenvalues,
!> and by DCHK43 to test if DGEESX successfully sorts eigenvalues.
!>
!> The common block /SSLCT/ controls how eigenvalues are selected.
!> If SELOPT = 0, then DSLECT return .TRUE. when ZR is less than zero,
!> and .FALSE. otherwise.
!> If SELOPT is at least 1, DSLECT returns SELVAL(SELOPT) and adds 1
!> to SELOPT, cycling back to 1 at SELMAX.
!>
Parameters
[in]ZR
!>          ZR is DOUBLE PRECISION
!>          The real part of a complex eigenvalue ZR + i*ZI.
!>
[in]ZI
!>          ZI is DOUBLE PRECISION
!>          The imaginary part of a complex eigenvalue ZR + i*ZI.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 61 of file dslect.f.

62*
63* -- LAPACK test routine --
64* -- LAPACK is a software package provided by Univ. of Tennessee, --
65* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
66*
67* .. Scalar Arguments ..
68 DOUBLE PRECISION ZI, ZR
69* ..
70*
71* =====================================================================
72*
73* .. Arrays in Common ..
74 LOGICAL SELVAL( 20 )
75 DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
76* ..
77* .. Scalars in Common ..
78 INTEGER SELDIM, SELOPT
79* ..
80* .. Common blocks ..
81 COMMON / sslct / selopt, seldim, selval, selwr, selwi
82* ..
83* .. Local Scalars ..
84 INTEGER I
85 DOUBLE PRECISION RMIN, X
86* ..
87* .. Parameters ..
88 DOUBLE PRECISION ZERO
89 parameter( zero = 0.0d0 )
90* ..
91* .. External Functions ..
92 DOUBLE PRECISION DLAPY2
93 EXTERNAL dlapy2
94* ..
95* .. Executable Statements ..
96*
97 IF( selopt.EQ.0 ) THEN
98 dslect = ( zr.LT.zero )
99 ELSE
100 rmin = dlapy2( zr-selwr( 1 ), zi-selwi( 1 ) )
101 dslect = selval( 1 )
102 DO 10 i = 2, seldim
103 x = dlapy2( zr-selwr( i ), zi-selwi( i ) )
104 IF( x.LE.rmin ) THEN
105 rmin = x
106 dslect = selval( i )
107 END IF
108 10 CONTINUE
109 END IF
110 RETURN
111*
112* End of DSLECT
113*

◆ dspt21()

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

DSPT21

Purpose:
!>
!> DSPT21  generally checks a decomposition of the form
!>
!>         A = U S U**T
!>
!> where **T means transpose, A is symmetric (stored in packed format), U
!> is orthogonal, 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) = | A - U S U**T | / ( |A| n ulp ) and
!>         RESULT(2) = | I - U U**T | / ( n ulp )
!>
!> If ITYPE=2, then:
!>
!>         RESULT(1) = | A - V S V**T | / ( |A| n ulp )
!>
!> If ITYPE=3, then:
!>
!>         RESULT(1) = | I - V U**T | / ( 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)**T
!>
!>    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)**T
!>
!>    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 orthogonal matrix:
!>             RESULT(1) = | A - U S U**T | / ( |A| n ulp ) and
!>             RESULT(2) = | I - U U**T | / ( n ulp )
!>
!>          2: U expressed as a product V of Housholder transformations:
!>             RESULT(1) = | A - V S V**T | / ( |A| n ulp )
!>
!>          3: U expressed both as a dense orthogonal matrix and
!>             as a product of Housholder transformations:
!>             RESULT(1) = | I - V U**T | / ( n ulp )
!>
[in]UPLO
!>          UPLO is CHARACTER
!>          If UPLO='U', AP and VP are considered to contain the upper
!>          triangle of A and V.
!>          If UPLO='L', AP and VP are considered to contain the lower
!>          triangle of A and V.
!>
[in]N
!>          N is INTEGER
!>          The size of the matrix.  If it is zero, DSPT21 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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The original (unfactored) matrix.  It is assumed to be
!>          symmetric, and contains the columns of just the upper
!>          triangle (UPLO='U') or only the lower triangle (UPLO='L'),
!>          packed one after another.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-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 DOUBLE PRECISION array, dimension (LDU, N)
!>          If ITYPE=1 or 3, this contains the orthogonal matrix in
!>          the decomposition, expressed as a dense matrix.  If ITYPE=2,
!>          then it is not referenced.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U.  LDU must be at least N and
!>          at least 1.
!>
[in]VP
!>          VP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          If ITYPE=2 or 3, the columns of this array contain the
!>          Householder vectors used to describe the orthogonal 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 DOUBLE PRECISION array, dimension (N)
!>          If ITYPE >= 2, then TAU(j) is the scalar factor of
!>          v(j) v(j)**T 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 DOUBLE PRECISION array, dimension (N**2+N)
!>          Workspace.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.  RESULT(2) is modified only
!>          if ITYPE=1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 219 of file dspt21.f.

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

◆ dstech()

subroutine dstech ( integer n,
double precision, dimension( * ) a,
double precision, dimension( * ) b,
double precision, dimension( * ) eig,
double precision tol,
double precision, dimension( * ) work,
integer info )

DSTECH

Purpose:
!>
!>    Let T be the tridiagonal matrix with diagonal entries A(1) ,...,
!>    A(N) and offdiagonal entries B(1) ,..., B(N-1)).  DSTECH checks to
!>    see if EIG(1) ,..., EIG(N) are indeed accurate eigenvalues of T.
!>    It does this by expanding each EIG(I) into an interval
!>    [SVD(I) - EPS, SVD(I) + EPS], merging overlapping intervals if
!>    any, and using Sturm sequences to count and verify whether each
!>    resulting interval has the correct number of eigenvalues (using
!>    DSTECT).  Here EPS = TOL*MAZHEPS*MAXEIG, where MACHEPS is the
!>    machine precision and MAXEIG is the absolute value of the largest
!>    eigenvalue. If each interval contains the correct number of
!>    eigenvalues, INFO = 0 is returned, otherwise INFO is the index of
!>    the first eigenvalue in the first bad interval.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The dimension of the tridiagonal matrix T.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (N)
!>          The diagonal entries of the tridiagonal matrix T.
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (N-1)
!>          The offdiagonal entries of the tridiagonal matrix T.
!>
[in]EIG
!>          EIG is DOUBLE PRECISION array, dimension (N)
!>          The purported eigenvalues to be checked.
!>
[in]TOL
!>          TOL is DOUBLE PRECISION
!>          Error tolerance for checking, a multiple of the
!>          machine precision.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          0  if the eigenvalues are all correct (to within
!>             1 +- TOL*MAZHEPS*MAXEIG)
!>          >0 if the interval containing the INFO-th eigenvalue
!>             contains the incorrect number of eigenvalues.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 100 of file dstech.f.

101*
102* -- LAPACK test routine --
103* -- LAPACK is a software package provided by Univ. of Tennessee, --
104* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
105*
106* .. Scalar Arguments ..
107 INTEGER INFO, N
108 DOUBLE PRECISION TOL
109* ..
110* .. Array Arguments ..
111 DOUBLE PRECISION A( * ), B( * ), EIG( * ), WORK( * )
112* ..
113*
114* =====================================================================
115*
116* .. Parameters ..
117 DOUBLE PRECISION ZERO
118 parameter( zero = 0.0d0 )
119* ..
120* .. Local Scalars ..
121 INTEGER BPNT, COUNT, I, ISUB, J, NUML, NUMU, TPNT
122 DOUBLE PRECISION EMIN, EPS, LOWER, MX, TUPPR, UNFLEP, UPPER
123* ..
124* .. External Functions ..
125 DOUBLE PRECISION DLAMCH
126 EXTERNAL dlamch
127* ..
128* .. External Subroutines ..
129 EXTERNAL dstect
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC abs, max
133* ..
134* .. Executable Statements ..
135*
136* Check input parameters
137*
138 info = 0
139 IF( n.EQ.0 )
140 $ RETURN
141 IF( n.LT.0 ) THEN
142 info = -1
143 RETURN
144 END IF
145 IF( tol.LT.zero ) THEN
146 info = -5
147 RETURN
148 END IF
149*
150* Get machine constants
151*
152 eps = dlamch( 'Epsilon' )*dlamch( 'Base' )
153 unflep = dlamch( 'Safe minimum' ) / eps
154 eps = tol*eps
155*
156* Compute maximum absolute eigenvalue, error tolerance
157*
158 mx = abs( eig( 1 ) )
159 DO 10 i = 2, n
160 mx = max( mx, abs( eig( i ) ) )
161 10 CONTINUE
162 eps = max( eps*mx, unflep )
163*
164* Sort eigenvalues from EIG into WORK
165*
166 DO 20 i = 1, n
167 work( i ) = eig( i )
168 20 CONTINUE
169 DO 40 i = 1, n - 1
170 isub = 1
171 emin = work( 1 )
172 DO 30 j = 2, n + 1 - i
173 IF( work( j ).LT.emin ) THEN
174 isub = j
175 emin = work( j )
176 END IF
177 30 CONTINUE
178 IF( isub.NE.n+1-i ) THEN
179 work( isub ) = work( n+1-i )
180 work( n+1-i ) = emin
181 END IF
182 40 CONTINUE
183*
184* TPNT points to singular value at right endpoint of interval
185* BPNT points to singular value at left endpoint of interval
186*
187 tpnt = 1
188 bpnt = 1
189*
190* Begin loop over all intervals
191*
192 50 CONTINUE
193 upper = work( tpnt ) + eps
194 lower = work( bpnt ) - eps
195*
196* Begin loop merging overlapping intervals
197*
198 60 CONTINUE
199 IF( bpnt.EQ.n )
200 $ GO TO 70
201 tuppr = work( bpnt+1 ) + eps
202 IF( tuppr.LT.lower )
203 $ GO TO 70
204*
205* Merge
206*
207 bpnt = bpnt + 1
208 lower = work( bpnt ) - eps
209 GO TO 60
210 70 CONTINUE
211*
212* Count singular values in interval [ LOWER, UPPER ]
213*
214 CALL dstect( n, a, b, lower, numl )
215 CALL dstect( n, a, b, upper, numu )
216 count = numu - numl
217 IF( count.NE.bpnt-tpnt+1 ) THEN
218*
219* Wrong number of singular values in interval
220*
221 info = tpnt
222 GO TO 80
223 END IF
224 tpnt = bpnt + 1
225 bpnt = tpnt
226 IF( tpnt.LE.n )
227 $ GO TO 50
228 80 CONTINUE
229 RETURN
230*
231* End of DSTECH
232*
eig
subroutine eig(k_diag, k_lt, iadk, jdik, ms, in, nddl, ndof, nnzl, x, d, v, a, bufel, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, pm, geo, cont, icut, skew, xcut, fint, itab, fext, fopt, anin, lpby, npby, nstrf, rwbuf, nprw, tani, elbuf_tab, matparam_tab, dd_iad, fr_iad, dd_front, cluster, weight, eani, ipart, rby, nom_opt, igrsurf, bufsf, idata, rdata, bufmat, bufgeo, kxx, ixx, kxsp, ixsp, nod2sp, spbuf, ixs10, ixs20, ixs16, vr, monvol, volmon, ipm, igeo, iparg, eigipm, eigibuf, eigrpm, ldiag, ljdik, ljdik2, ikc, maxncv, thke, nms, nint2, iint2, ipari, intbuf_tab, nodglob, iad_elem, fr_elem, fr_sec, fr_rby2, iad_rby2, fr_wall, inloc, iddl, partsav, fncont, ftcont, temp, err_thk_sh4, err_thk_sh3, irbe2, irbe3, lrbe2, lrbe3, fr_rbe2, fr_rbe3m, iad_rbe2, weight_md, fcluster, mcluster, xfem_tab, w, nv46, nercvois, nesdvois, lercvois, lesdvois, crkedge, indx_crk, xedge4n, xedge3n, stack, sph2sol, stifn, stifr, drape_q4, drape_t3, h3d_data, subset, igrnod, fcont_max, fncontp2, ftcontp2, ale_connectivity, glob_therm)
Definition eig.F:73
dstect
subroutine dstect(n, a, b, shift, num)
DSTECT
Definition dstect.f:82

◆ dstect()

subroutine dstect ( integer n,
double precision, dimension( * ) a,
double precision, dimension( * ) b,
double precision shift,
integer num )

DSTECT

Purpose:
!>
!>    DSTECT counts the number NUM of eigenvalues of a tridiagonal
!>    matrix T which are less than or equal to SHIFT. T has
!>    diagonal entries A(1), ... , A(N), and offdiagonal entries
!>    B(1), ..., B(N-1).
!>    See W. Kahan , Report CS41, Computer Science Dept., Stanford
!>    University, July 21, 1966
!>
Parameters
[in]N
!>          N is INTEGER
!>          The dimension of the tridiagonal matrix T.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (N)
!>          The diagonal entries of the tridiagonal matrix T.
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (N-1)
!>          The offdiagonal entries of the tridiagonal matrix T.
!>
[in]SHIFT
!>          SHIFT is DOUBLE PRECISION
!>          The shift, used as described under Purpose.
!>
[out]NUM
!>          NUM is INTEGER
!>          The number of eigenvalues of T less than or equal
!>          to SHIFT.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 81 of file dstect.f.

82*
83* -- LAPACK test routine --
84* -- LAPACK is a software package provided by Univ. of Tennessee, --
85* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
86*
87* .. Scalar Arguments ..
88 INTEGER N, NUM
89 DOUBLE PRECISION SHIFT
90* ..
91* .. Array Arguments ..
92 DOUBLE PRECISION A( * ), B( * )
93* ..
94*
95* =====================================================================
96*
97* .. Parameters ..
98 DOUBLE PRECISION ZERO, ONE, THREE
99 parameter( zero = 0.0d0, one = 1.0d0, three = 3.0d0 )
100* ..
101* .. Local Scalars ..
102 INTEGER I
103 DOUBLE PRECISION M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
104 $ TOM, U, UNFL
105* ..
106* .. External Functions ..
107 DOUBLE PRECISION DLAMCH
108 EXTERNAL dlamch
109* ..
110* .. Intrinsic Functions ..
111 INTRINSIC abs, max, sqrt
112* ..
113* .. Executable Statements ..
114*
115* Get machine constants
116*
117 unfl = dlamch( 'Safe minimum' )
118 ovfl = dlamch( 'Overflow' )
119*
120* Find largest entry
121*
122 mx = abs( a( 1 ) )
123 DO 10 i = 1, n - 1
124 mx = max( mx, abs( a( i+1 ) ), abs( b( i ) ) )
125 10 CONTINUE
126*
127* Handle easy cases, including zero matrix
128*
129 IF( shift.GE.three*mx ) THEN
130 num = n
131 RETURN
132 END IF
133 IF( shift.LT.-three*mx ) THEN
134 num = 0
135 RETURN
136 END IF
137*
138* Compute scale factors as in Kahan's report
139* At this point, MX .NE. 0 so we can divide by it
140*
141 sun = sqrt( unfl )
142 ssun = sqrt( sun )
143 sov = sqrt( ovfl )
144 tom = ssun*sov
145 IF( mx.LE.one ) THEN
146 m1 = one / mx
147 m2 = tom
148 ELSE
149 m1 = one
150 m2 = tom / mx
151 END IF
152*
153* Begin counting
154*
155 num = 0
156 sshift = ( shift*m1 )*m2
157 u = ( a( 1 )*m1 )*m2 - sshift
158 IF( u.LE.sun ) THEN
159 IF( u.LE.zero ) THEN
160 num = num + 1
161 IF( u.GT.-sun )
162 $ u = -sun
163 ELSE
164 u = sun
165 END IF
166 END IF
167 DO 20 i = 2, n
168 tmp = ( b( i-1 )*m1 )*m2
169 u = ( ( a( i )*m1 )*m2-tmp*( tmp / u ) ) - sshift
170 IF( u.LE.sun ) THEN
171 IF( u.LE.zero ) THEN
172 num = num + 1
173 IF( u.GT.-sun )
174 $ u = -sun
175 ELSE
176 u = sun
177 END IF
178 END IF
179 20 CONTINUE
180 RETURN
181*
182* End of DSTECT
183*

◆ dstt21()

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

DSTT21

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

Definition at line 125 of file dstt21.f.

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

◆ dstt22()

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

DSTT22

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

Definition at line 137 of file dstt22.f.

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

◆ dsvdch()

subroutine dsvdch ( integer n,
double precision, dimension( * ) s,
double precision, dimension( * ) e,
double precision, dimension( * ) svd,
double precision tol,
integer info )

DSVDCH

Purpose:
!>
!> DSVDCH checks to see if SVD(1) ,..., SVD(N) are accurate singular
!> values of the bidiagonal matrix B with diagonal entries
!> S(1) ,..., S(N) and superdiagonal entries E(1) ,..., E(N-1)).
!> It does this by expanding each SVD(I) into an interval
!> [SVD(I) * (1-EPS) , SVD(I) * (1+EPS)], merging overlapping intervals
!> if any, and using Sturm sequences to count and verify whether each
!> resulting interval has the correct number of singular values (using
!> DSVDCT). Here EPS=TOL*MAX(N/10,1)*MAZHEP, where MACHEP is the
!> machine precision. The routine assumes the singular values are sorted
!> with SVD(1) the largest and SVD(N) smallest.  If each interval
!> contains the correct number of singular values, INFO = 0 is returned,
!> otherwise INFO is the index of the first singular value in the first
!> bad interval.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The dimension of the bidiagonal matrix B.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (N)
!>          The diagonal entries of the bidiagonal matrix B.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The superdiagonal entries of the bidiagonal matrix B.
!>
[in]SVD
!>          SVD is DOUBLE PRECISION array, dimension (N)
!>          The computed singular values to be checked.
!>
[in]TOL
!>          TOL is DOUBLE PRECISION
!>          Error tolerance for checking, a multiplier of the
!>          machine precision.
!>
[out]INFO
!>          INFO is INTEGER
!>          =0 if the singular values are all correct (to within
!>             1 +- TOL*MAZHEPS)
!>          >0 if the interval containing the INFO-th singular value
!>             contains the incorrect number of singular values.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 96 of file dsvdch.f.

97*
98* -- LAPACK test routine --
99* -- LAPACK is a software package provided by Univ. of Tennessee, --
100* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
101*
102* .. Scalar Arguments ..
103 INTEGER INFO, N
104 DOUBLE PRECISION TOL
105* ..
106* .. Array Arguments ..
107 DOUBLE PRECISION E( * ), S( * ), SVD( * )
108* ..
109*
110* =====================================================================
111*
112* .. Parameters ..
113 DOUBLE PRECISION ONE
114 parameter( one = 1.0d0 )
115 DOUBLE PRECISION ZERO
116 parameter( zero = 0.0d0 )
117* ..
118* .. Local Scalars ..
119 INTEGER BPNT, COUNT, NUML, NUMU, TPNT
120 DOUBLE PRECISION EPS, LOWER, OVFL, TUPPR, UNFL, UNFLEP, UPPER
121* ..
122* .. External Functions ..
123 DOUBLE PRECISION DLAMCH
124 EXTERNAL dlamch
125* ..
126* .. External Subroutines ..
127 EXTERNAL dsvdct
128* ..
129* .. Intrinsic Functions ..
130 INTRINSIC max, sqrt
131* ..
132* .. Executable Statements ..
133*
134* Get machine constants
135*
136 info = 0
137 IF( n.LE.0 )
138 $ RETURN
139 unfl = dlamch( 'Safe minimum' )
140 ovfl = dlamch( 'Overflow' )
141 eps = dlamch( 'Epsilon' )*dlamch( 'Base' )
142*
143* UNFLEP is chosen so that when an eigenvalue is multiplied by the
144* scale factor sqrt(OVFL)*sqrt(sqrt(UNFL))/MX in DSVDCT, it exceeds
145* sqrt(UNFL), which is the lower limit for DSVDCT.
146*
147 unflep = ( sqrt( sqrt( unfl ) ) / sqrt( ovfl ) )*svd( 1 ) +
148 $ unfl / eps
149*
150* The value of EPS works best when TOL .GE. 10.
151*
152 eps = tol*max( n / 10, 1 )*eps
153*
154* TPNT points to singular value at right endpoint of interval
155* BPNT points to singular value at left endpoint of interval
156*
157 tpnt = 1
158 bpnt = 1
159*
160* Begin loop over all intervals
161*
162 10 CONTINUE
163 upper = ( one+eps )*svd( tpnt ) + unflep
164 lower = ( one-eps )*svd( bpnt ) - unflep
165 IF( lower.LE.unflep )
166 $ lower = -upper
167*
168* Begin loop merging overlapping intervals
169*
170 20 CONTINUE
171 IF( bpnt.EQ.n )
172 $ GO TO 30
173 tuppr = ( one+eps )*svd( bpnt+1 ) + unflep
174 IF( tuppr.LT.lower )
175 $ GO TO 30
176*
177* Merge
178*
179 bpnt = bpnt + 1
180 lower = ( one-eps )*svd( bpnt ) - unflep
181 IF( lower.LE.unflep )
182 $ lower = -upper
183 GO TO 20
184 30 CONTINUE
185*
186* Count singular values in interval [ LOWER, UPPER ]
187*
188 CALL dsvdct( n, s, e, lower, numl )
189 CALL dsvdct( n, s, e, upper, numu )
190 count = numu - numl
191 IF( lower.LT.zero )
192 $ count = count / 2
193 IF( count.NE.bpnt-tpnt+1 ) THEN
194*
195* Wrong number of singular values in interval
196*
197 info = tpnt
198 GO TO 40
199 END IF
200 tpnt = bpnt + 1
201 bpnt = tpnt
202 IF( tpnt.LE.n )
203 $ GO TO 10
204 40 CONTINUE
205 RETURN
206*
207* End of DSVDCH
208*
dsvdct
subroutine dsvdct(n, s, e, shift, num)
DSVDCT
Definition dsvdct.f:87

◆ dsvdct()

subroutine dsvdct ( integer n,
double precision, dimension( * ) s,
double precision, dimension( * ) e,
double precision shift,
integer num )

DSVDCT

Purpose:
!>
!> DSVDCT counts the number NUM of eigenvalues of a 2*N by 2*N
!> tridiagonal matrix T which are less than or equal to SHIFT.  T is
!> formed by putting zeros on the diagonal and making the off-diagonals
!> equal to S(1), E(1), S(2), E(2), ... , E(N-1), S(N).  If SHIFT is
!> positive, NUM is equal to N plus the number of singular values of a
!> bidiagonal matrix B less than or equal to SHIFT.  Here B has diagonal
!> entries S(1), ..., S(N) and superdiagonal entries E(1), ... E(N-1).
!> If SHIFT is negative, NUM is equal to the number of singular values
!> of B greater than or equal to -SHIFT.
!>
!> See W. Kahan , Report CS41, Computer Science Dept., Stanford University,
!> July 21, 1966
!>
Parameters
[in]N
!>          N is INTEGER
!>          The dimension of the bidiagonal matrix B.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (N)
!>          The diagonal entries of the bidiagonal matrix B.
!>
[in]E
!>          E is DOUBLE PRECISION array of dimension (N-1)
!>          The superdiagonal entries of the bidiagonal matrix B.
!>
[in]SHIFT
!>          SHIFT is DOUBLE PRECISION
!>          The shift, used as described under Purpose.
!>
[out]NUM
!>          NUM is INTEGER
!>          The number of eigenvalues of T less than or equal to SHIFT.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 86 of file dsvdct.f.

87*
88* -- LAPACK test routine --
89* -- LAPACK is a software package provided by Univ. of Tennessee, --
90* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
91*
92* .. Scalar Arguments ..
93 INTEGER N, NUM
94 DOUBLE PRECISION SHIFT
95* ..
96* .. Array Arguments ..
97 DOUBLE PRECISION E( * ), S( * )
98* ..
99*
100* =====================================================================
101*
102* .. Parameters ..
103 DOUBLE PRECISION ONE
104 parameter( one = 1.0d0 )
105 DOUBLE PRECISION ZERO
106 parameter( zero = 0.0d0 )
107* ..
108* .. Local Scalars ..
109 INTEGER I
110 DOUBLE PRECISION M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
111 $ TOM, U, UNFL
112* ..
113* .. External Functions ..
114 DOUBLE PRECISION DLAMCH
115 EXTERNAL dlamch
116* ..
117* .. Intrinsic Functions ..
118 INTRINSIC abs, max, sqrt
119* ..
120* .. Executable Statements ..
121*
122* Get machine constants
123*
124 unfl = 2*dlamch( 'Safe minimum' )
125 ovfl = one / unfl
126*
127* Find largest entry
128*
129 mx = abs( s( 1 ) )
130 DO 10 i = 1, n - 1
131 mx = max( mx, abs( s( i+1 ) ), abs( e( i ) ) )
132 10 CONTINUE
133*
134 IF( mx.EQ.zero ) THEN
135 IF( shift.LT.zero ) THEN
136 num = 0
137 ELSE
138 num = 2*n
139 END IF
140 RETURN
141 END IF
142*
143* Compute scale factors as in Kahan's report
144*
145 sun = sqrt( unfl )
146 ssun = sqrt( sun )
147 sov = sqrt( ovfl )
148 tom = ssun*sov
149 IF( mx.LE.one ) THEN
150 m1 = one / mx
151 m2 = tom
152 ELSE
153 m1 = one
154 m2 = tom / mx
155 END IF
156*
157* Begin counting
158*
159 u = one
160 num = 0
161 sshift = ( shift*m1 )*m2
162 u = -sshift
163 IF( u.LE.sun ) THEN
164 IF( u.LE.zero ) THEN
165 num = num + 1
166 IF( u.GT.-sun )
167 $ u = -sun
168 ELSE
169 u = sun
170 END IF
171 END IF
172 tmp = ( s( 1 )*m1 )*m2
173 u = -tmp*( tmp / u ) - sshift
174 IF( u.LE.sun ) THEN
175 IF( u.LE.zero ) THEN
176 num = num + 1
177 IF( u.GT.-sun )
178 $ u = -sun
179 ELSE
180 u = sun
181 END IF
182 END IF
183 DO 20 i = 1, n - 1
184 tmp = ( e( i )*m1 )*m2
185 u = -tmp*( tmp / u ) - sshift
186 IF( u.LE.sun ) THEN
187 IF( u.LE.zero ) THEN
188 num = num + 1
189 IF( u.GT.-sun )
190 $ u = -sun
191 ELSE
192 u = sun
193 END IF
194 END IF
195 tmp = ( s( i+1 )*m1 )*m2
196 u = -tmp*( tmp / u ) - sshift
197 IF( u.LE.sun ) THEN
198 IF( u.LE.zero ) THEN
199 num = num + 1
200 IF( u.GT.-sun )
201 $ u = -sun
202 ELSE
203 u = sun
204 END IF
205 END IF
206 20 CONTINUE
207 RETURN
208*
209* End of DSVDCT
210*

◆ dsxt1()

double precision function dsxt1 ( integer ijob,
double precision, dimension( * ) d1,
integer n1,
double precision, dimension( * ) d2,
integer n2,
double precision abstol,
double precision ulp,
double precision unfl )

DSXT1

Purpose:
!>
!> DSXT1  computes the difference between a set of eigenvalues.
!> The result is returned as the function value.
!>
!> IJOB = 1:   Computes   max { min | D1(i)-D2(j) | }
!>                         i     j
!>
!> IJOB = 2:   Computes   max { min | D1(i)-D2(j) | /
!>                         i     j
!>                              ( ABSTOL + |D1(i)|*ULP ) }
!>
Parameters
[in]IJOB
!>          IJOB is INTEGER
!>          Specifies the type of tests to be performed.  (See above.)
!>
[in]D1
!>          D1 is DOUBLE PRECISION array, dimension (N1)
!>          The first array.  D1 should be in increasing order, i.e.,
!>          D1(j) <= D1(j+1).
!>
[in]N1
!>          N1 is INTEGER
!>          The length of D1.
!>
[in]D2
!>          D2 is DOUBLE PRECISION array, dimension (N2)
!>          The second array.  D2 should be in increasing order, i.e.,
!>          D2(j) <= D2(j+1).
!>
[in]N2
!>          N2 is INTEGER
!>          The length of D2.
!>
[in]ABSTOL
!>          ABSTOL is DOUBLE PRECISION
!>          The absolute tolerance, used as a measure of the error.
!>
[in]ULP
!>          ULP is DOUBLE PRECISION
!>          Machine precision.
!>
[in]UNFL
!>          UNFL is DOUBLE PRECISION
!>          The smallest positive number whose reciprocal does not
!>          overflow.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 104 of file dsxt1.f.

106*
107* -- LAPACK test routine --
108* -- LAPACK is a software package provided by Univ. of Tennessee, --
109* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
110*
111* .. Scalar Arguments ..
112 INTEGER IJOB, N1, N2
113 DOUBLE PRECISION ABSTOL, ULP, UNFL
114* ..
115* .. Array Arguments ..
116 DOUBLE PRECISION D1( * ), D2( * )
117* ..
118*
119* =====================================================================
120*
121* .. Parameters ..
122 DOUBLE PRECISION ZERO
123 parameter( zero = 0.0d0 )
124* ..
125* .. Local Scalars ..
126 INTEGER I, J
127 DOUBLE PRECISION TEMP1, TEMP2
128* ..
129* .. Intrinsic Functions ..
130 INTRINSIC abs, max, min
131* ..
132* .. Executable Statements ..
133*
134 temp1 = zero
135*
136 j = 1
137 DO 20 i = 1, n1
138 10 CONTINUE
139 IF( d2( j ).LT.d1( i ) .AND. j.LT.n2 ) THEN
140 j = j + 1
141 GO TO 10
142 END IF
143 IF( j.EQ.1 ) THEN
144 temp2 = abs( d2( j )-d1( i ) )
145 IF( ijob.EQ.2 )
146 $ temp2 = temp2 / max( unfl, abstol+ulp*abs( d1( i ) ) )
147 ELSE
148 temp2 = min( abs( d2( j )-d1( i ) ),
149 $ abs( d1( i )-d2( j-1 ) ) )
150 IF( ijob.EQ.2 )
151 $ temp2 = temp2 / max( unfl, abstol+ulp*abs( d1( i ) ) )
152 END IF
153 temp1 = max( temp1, temp2 )
154 20 CONTINUE
155*
156 dsxt1 = temp1
157 RETURN
158*
159* End of DSXT1
160*

◆ dsyt21()

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

DSYT21

Purpose:
!>
!> DSYT21 generally checks a decomposition of the form
!>
!>    A = U S U**T
!>
!> where **T means transpose, A is symmetric, U is orthogonal, 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 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**T | / ( |A| n ulp ) and
!>    RESULT(2) = | I - U U**T | / ( n ulp )
!>
!> If ITYPE=2, then:
!>
!>    RESULT(1) = | A - V S V**T | / ( |A| n ulp )
!>
!> If ITYPE=3, then:
!>
!>    RESULT(1) = | I - V U**T | / ( 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)**T 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 orthogonal matrix:
!>             RESULT(1) = | A - U S U**T | / ( |A| n ulp )  and
!>             RESULT(2) = | I - U U**T | / ( n ulp )
!>
!>          2: U expressed as a product V of Housholder transformations:
!>             RESULT(1) = | A - V S V**T | / ( |A| n ulp )
!>
!>          3: U expressed both as a dense orthogonal matrix and
!>             as a product of Housholder transformations:
!>             RESULT(1) = | I - V U**T | / ( 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, DSYT21 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 DOUBLE PRECISION 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.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least N.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix.
!>          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
!>          (3,2) element, etc.
!>          Not referenced if KBAND=0.
!>
[in]U
!>          U is DOUBLE PRECISION array, dimension (LDU, N)
!>          If ITYPE=1 or 3, this contains the orthogonal 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 DOUBLE PRECISION array, dimension (LDV, N)
!>          If ITYPE=2 or 3, the columns of this array contain the
!>          Householder vectors used to describe the orthogonal 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 DOUBLE PRECISION array, dimension (N)
!>          If ITYPE >= 2, then TAU(j) is the scalar factor of
!>          v(j) v(j)**T 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 DOUBLE PRECISION array, dimension (2*N**2)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.  RESULT(2) is modified only
!>          if ITYPE=1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 205 of file dsyt21.f.

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

◆ dsyt22()

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

DSYT22

Purpose:
!>
!>      DSYT22  generally checks a decomposition of the form
!>
!>              A U = U S
!>
!>      where A is symmetric, 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**T A U - S | / ( |A| m ulp ) and
!>              RESULT(2) = | I - U**T 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**T | / ( |A| n ulp )  and
!>             RESULT(2) = | I - U U**T | / ( 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, DSYT22 does nothing.
!>          It must be at least zero.
!>          Not modified.
!>
!>  M       INTEGER
!>          The number of columns of U.  If it is zero, DSYT22 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       DOUBLE PRECISION array, dimension (LDA , N)
!>          The original (unfactored) matrix.  It is assumed to be
!>          symmetric, and only the upper (UPLO='U') or only the lower
!>          (UPLO='L') will be referenced.
!>          Not modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least N.
!>          Not modified.
!>
!>  D       DOUBLE PRECISION array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>          Not modified.
!>
!>  E       DOUBLE PRECISION array, dimension (N)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix.
!>          E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc.
!>          Not referenced if KBAND=0.
!>          Not modified.
!>
!>  U       DOUBLE PRECISION array, dimension (LDU, N)
!>          If ITYPE=1 or 3, this contains the orthogonal matrix in
!>          the decomposition, expressed as a dense matrix.  If ITYPE=2,
!>          then it is not referenced.
!>          Not modified.
!>
!>  LDU     INTEGER
!>          The leading dimension of U.  LDU must be at least N and
!>          at least 1.
!>          Not modified.
!>
!>  V       DOUBLE PRECISION 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     DOUBLE PRECISION array, dimension (N)
!>          If ITYPE >= 2, then TAU(j) is the scalar factor of
!>          v(j) v(j)**T 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    DOUBLE PRECISION array, dimension (2*N**2)
!>          Workspace.
!>          Modified.
!>
!>  RESULT  DOUBLE PRECISION array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.  RESULT(2) is modified only
!>          if LDU is at least N.
!>          Modified.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 155 of file dsyt22.f.

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

◆ sbdt04()

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

SBDT04

Purpose:
!>
!> SBDT04 reconstructs a bidiagonal matrix B from its (partial) 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( S - U' * B * V ) / ( 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]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]S
!>          S is REAL array, dimension (NS)
!>          The singular values from the (partial) SVD of B, sorted in
!>          decreasing order.
!>
[in]NS
!>          NS is INTEGER
!>          The number of singular values/vectors from the (partial)
!>          SVD of B.
!>
[in]U
!>          U is REAL array, dimension (LDU,NS)
!>          The n by ns orthogonal matrix U in S = U' * B * V.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,N)
!>
[in]VT
!>          VT is REAL array, dimension (LDVT,N)
!>          The n by ns orthogonal matrix V in S = U' * B * V.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.
!>
[out]WORK
!>          WORK is REAL array, dimension (2*N)
!>
[out]RESID
!>          RESID is REAL
!>          The test ratio:  norm(S - U' * B * V) / ( n * norm(B) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file sbdt04.f.

131*
132* -- LAPACK test routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136* .. Scalar Arguments ..
137 CHARACTER UPLO
138 INTEGER LDU, LDVT, N, NS
139 REAL RESID
140* ..
141* .. Array Arguments ..
142 REAL D( * ), E( * ), S( * ), U( LDU, * ),
143 $ VT( LDVT, * ), WORK( * )
144* ..
145*
146* ======================================================================
147*
148* .. Parameters ..
149 REAL ZERO, ONE
150 parameter( zero = 0.0e+0, one = 1.0e+0 )
151* ..
152* .. Local Scalars ..
153 INTEGER I, J, K
154 REAL BNORM, EPS
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 INTEGER ISAMAX
159 REAL SASUM, SLAMCH
160 EXTERNAL lsame, isamax, sasum, slamch
161* ..
162* .. External Subroutines ..
163 EXTERNAL sgemm
164* ..
165* .. Intrinsic Functions ..
166 INTRINSIC abs, real, max, min
167* ..
168* .. Executable Statements ..
169*
170* Quick return if possible.
171*
172 resid = zero
173 IF( n.LE.0 .OR. ns.LE.0 )
174 $ RETURN
175*
176 eps = slamch( 'Precision' )
177*
178* Compute S - U' * B * V.
179*
180 bnorm = zero
181*
182 IF( lsame( uplo, 'U' ) ) THEN
183*
184* B is upper bidiagonal.
185*
186 k = 0
187 DO 20 i = 1, ns
188 DO 10 j = 1, n-1
189 k = k + 1
190 work( k ) = d( j )*vt( i, j ) + e( j )*vt( i, j+1 )
191 10 CONTINUE
192 k = k + 1
193 work( k ) = d( n )*vt( i, n )
194 20 CONTINUE
195 bnorm = abs( d( 1 ) )
196 DO 30 i = 2, n
197 bnorm = max( bnorm, abs( d( i ) )+abs( e( i-1 ) ) )
198 30 CONTINUE
199 ELSE
200*
201* B is lower bidiagonal.
202*
203 k = 0
204 DO 50 i = 1, ns
205 k = k + 1
206 work( k ) = d( 1 )*vt( i, 1 )
207 DO 40 j = 1, n-1
208 k = k + 1
209 work( k ) = e( j )*vt( i, j ) + d( j+1 )*vt( i, j+1 )
210 40 CONTINUE
211 50 CONTINUE
212 bnorm = abs( d( n ) )
213 DO 60 i = 1, n-1
214 bnorm = max( bnorm, abs( d( i ) )+abs( e( i ) ) )
215 60 CONTINUE
216 END IF
217*
218 CALL sgemm( 'T', 'N', ns, ns, n, -one, u, ldu, work( 1 ),
219 $ n, zero, work( 1+n*ns ), ns )
220*
221* norm(S - U' * B * V)
222*
223 k = n*ns
224 DO 70 i = 1, ns
225 work( k+i ) = work( k+i ) + s( i )
226 resid = max( resid, sasum( ns, work( k+1 ), 1 ) )
227 k = k + ns
228 70 CONTINUE
229*
230 IF( bnorm.LE.zero ) THEN
231 IF( resid.NE.zero )
232 $ resid = one / eps
233 ELSE
234 IF( bnorm.GE.resid ) THEN
235 resid = ( resid / bnorm ) / ( real( n )*eps )
236 ELSE
237 IF( bnorm.LT.one ) THEN
238 resid = ( min( resid, real( n )*bnorm ) / bnorm ) /
239 $ ( real( n )*eps )
240 ELSE
241 resid = min( resid / bnorm, real( n ) ) /
242 $ ( real( n )*eps )
243 END IF
244 END IF
245 END IF
246*
247 RETURN
248*
249* End of SBDT04
250*
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187

◆ sbdt05()

subroutine sbdt05 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) s,
integer ns,
real, dimension( ldu, * ) u,
integer ldu,
real, dimension( ldvt, * ) vt,
integer ldvt,
real, dimension( * ) work,
real resid )

SBDT05

Purpose:
!>
!> SBDT05 reconstructs a bidiagonal matrix B from its (partial) 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( S - U' * B * V ) / ( n * norm(B) * EPS )
!> where VT = V' and EPS is the machine precision.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrices A and U.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and VT.
!>
[in]A
!>          A is REAL 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]S
!>          S is REAL array, dimension (NS)
!>          The singular values from the (partial) SVD of B, sorted in
!>          decreasing order.
!>
[in]NS
!>          NS is INTEGER
!>          The number of singular values/vectors from the (partial)
!>          SVD of B.
!>
[in]U
!>          U is REAL array, dimension (LDU,NS)
!>          The n by ns orthogonal matrix U in S = U' * B * V.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,N)
!>
[in]VT
!>          VT is REAL array, dimension (LDVT,N)
!>          The n by ns orthogonal matrix V in S = U' * B * V.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.
!>
[out]WORK
!>          WORK is REAL array, dimension (M,N)
!>
[out]RESID
!>          RESID is REAL
!>          The test ratio:  norm(S - U' * A * V) / ( n * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 125 of file sbdt05.f.

127*
128* -- LAPACK test routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 INTEGER LDA, LDU, LDVT, M, N, NS
134 REAL RESID
135* ..
136* .. Array Arguments ..
137 REAL A( LDA, * ), S( * ), U( LDU, * ),
138 $ VT( LDVT, * ), 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 INTEGER I, J
149 REAL ANORM, EPS
150* ..
151* .. External Functions ..
152 LOGICAL LSAME
153 INTEGER ISAMAX
154 REAL SASUM, SLAMCH, SLANGE
155 EXTERNAL lsame, isamax, sasum, slamch, slange
156* ..
157* .. External Subroutines ..
158 EXTERNAL sgemm
159* ..
160* .. Intrinsic Functions ..
161 INTRINSIC abs, real, max, min
162* ..
163* .. Executable Statements ..
164*
165* Quick return if possible.
166*
167 resid = zero
168 IF( min( m, n ).LE.0 .OR. ns.LE.0 )
169 $ RETURN
170*
171 eps = slamch( 'Precision' )
172 anorm = slange( 'M', m, n, a, lda, work )
173*
174* Compute U' * A * V.
175*
176 CALL sgemm( 'N', 'T', m, ns, n, one, a, lda, vt,
177 $ ldvt, zero, work( 1+ns*ns ), m )
178 CALL sgemm( 'T', 'N', ns, ns, m, -one, u, ldu, work( 1+ns*ns ),
179 $ m, zero, work, ns )
180*
181* norm(S - U' * B * V)
182*
183 j = 0
184 DO 10 i = 1, ns
185 work( j+i ) = work( j+i ) + s( i )
186 resid = max( resid, sasum( ns, work( j+1 ), 1 ) )
187 j = j + ns
188 10 CONTINUE
189*
190 IF( anorm.LE.zero ) THEN
191 IF( resid.NE.zero )
192 $ resid = one / eps
193 ELSE
194 IF( anorm.GE.resid ) THEN
195 resid = ( resid / anorm ) / ( real( n )*eps )
196 ELSE
197 IF( anorm.LT.one ) THEN
198 resid = ( min( resid, real( n )*anorm ) / anorm ) /
199 $ ( real( n )*eps )
200 ELSE
201 resid = min( resid / anorm, real( n ) ) /
202 $ ( real( n )*eps )
203 END IF
204 END IF
205 END IF
206*
207 RETURN
208*
209* End of SBDT05
210*
slange
real function slange(norm, m, n, a, lda, work)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition slange.f:114

◆ sget40()

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

SGET40

Purpose:
!>
!> SGET40 tests STGEXC, a routine for swapping adjacent blocks (either
!> 1 by 1 or 2 by 2) on the diagonal of a pencil in real generalized Schur form.
!> Thus, STGEXC computes an orthogonal matrices Q and Z such that
!>
!>     Q' * ( [ A B ], [ D E ] ) * Z  = ( [ C1 B1 ], [ F1 E1 ] )
!>          ( [ 0 C ]  [   F ] )        ( [ 0  A1 ]  [    D1]  )
!>
!> where (C1,F1) is similar to (C,F) and (A1,D1) is similar to (A,D).
!> Both (A,D) and (C,F) are assumed to be in standard form
!> and (A1,D1) and (C1,F1) are returned with the
!> same properties.
!>
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.
!>
[out]NIN
!>          NINFO is INTEGER
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 82 of file sget40.f.

83*
84* -- LAPACK test routine --
85* -- LAPACK is a software package provided by Univ. of Tennessee, --
86* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
87*
88* .. Scalar Arguments ..
89 INTEGER KNT, LMAX, NIN
90 REAL RMAX
91* ..
92* .. Array Arguments ..
93 INTEGER NINFO( 3 )
94* ..
95*
96* =====================================================================
97*
98* .. Parameters ..
99 REAL ZERO, ONE
100 parameter( zero = 0.0, one = 1.0 )
101 INTEGER LDT, LWORK
102 parameter( ldt = 10, lwork = 100 + 4*ldt + 16 )
103* ..
104* .. Local Scalars ..
105 INTEGER I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
106 $ ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
107 REAL EPS, RES
108* ..
109* .. Local Arrays ..
110 REAL Q( LDT, LDT ), Z( LDT, LDT ), RESULT( 4 ),
111 $ T( LDT, LDT ), T1( LDT, LDT ), T2( LDT, LDT ),
112 $ S( LDT, LDT ), S1( LDT, LDT ), S2( LDT, LDT ),
113 $ TMP( LDT, LDT ), WORK( LWORK )
114* ..
115* .. External Functions ..
116 REAL SLAMCH
117 EXTERNAL slamch
118* ..
119* .. External Subroutines ..
120 EXTERNAL sget51, slacpy, slaset, stgexc
121* ..
122* .. Intrinsic Functions ..
123 INTRINSIC abs, sign
124* ..
125* .. Executable Statements ..
126*
127 eps = slamch( 'P' )
128 rmax = zero
129 lmax = 0
130 knt = 0
131 ninfo( 1 ) = 0
132 ninfo( 2 ) = 0
133 ninfo( 3 ) = 0
134*
135* Read input data until N=0
136*
137 10 CONTINUE
138 READ( nin, fmt = * )n, ifst, ilst
139 IF( n.EQ.0 )
140 $ RETURN
141 knt = knt + 1
142 DO 20 i = 1, n
143 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
144 20 CONTINUE
145 CALL slacpy( 'F', n, n, tmp, ldt, t, ldt )
146 CALL slacpy( 'F', n, n, tmp, ldt, t1, ldt )
147 CALL slacpy( 'F', n, n, tmp, ldt, t2, ldt )
148 DO 25 i = 1, n
149 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
150 25 CONTINUE
151 CALL slacpy( 'F', n, n, tmp, ldt, s, ldt )
152 CALL slacpy( 'F', n, n, tmp, ldt, s1, ldt )
153 CALL slacpy( 'F', n, n, tmp, ldt, s2, ldt )
154 ifstsv = ifst
155 ilstsv = ilst
156 ifst1 = ifst
157 ilst1 = ilst
158 ifst2 = ifst
159 ilst2 = ilst
160 res = zero
161*
162* Test without accumulating Q and Z
163*
164 CALL slaset( 'Full', n, n, zero, one, q, ldt )
165 CALL slaset( 'Full', n, n, zero, one, z, ldt )
166 CALL stgexc( .false., .false., n, t1, ldt, s1, ldt, q, ldt,
167 $ z, ldt, ifst1, ilst1, work, lwork, info1 )
168 DO 40 i = 1, n
169 DO 30 j = 1, n
170 IF( i.EQ.j .AND. q( i, j ).NE.one )
171 $ res = res + one / eps
172 IF( i.NE.j .AND. q( i, j ).NE.zero )
173 $ res = res + one / eps
174 IF( i.EQ.j .AND. z( i, j ).NE.one )
175 $ res = res + one / eps
176 IF( i.NE.j .AND. z( i, j ).NE.zero )
177 $ res = res + one / eps
178 30 CONTINUE
179 40 CONTINUE
180*
181* Test with accumulating Q
182*
183 CALL slaset( 'Full', n, n, zero, one, q, ldt )
184 CALL slaset( 'Full', n, n, zero, one, z, ldt )
185 CALL stgexc( .true., .true., n, t2, ldt, s2, ldt, q, ldt,
186 $ z, ldt, ifst2, ilst2, work, lwork, info2 )
187*
188* Compare T1 with T2 and S1 with S2
189*
190 DO 60 i = 1, n
191 DO 50 j = 1, n
192 IF( t1( i, j ).NE.t2( i, j ) )
193 $ res = res + one / eps
194 IF( s1( i, j ).NE.s2( i, j ) )
195 $ res = res + one / eps
196 50 CONTINUE
197 60 CONTINUE
198 IF( ifst1.NE.ifst2 )
199 $ res = res + one / eps
200 IF( ilst1.NE.ilst2 )
201 $ res = res + one / eps
202 IF( info1.NE.info2 )
203 $ res = res + one / eps
204*
205* Test orthogonality of Q and Z and backward error on T2 and S2
206*
207 CALL sget51( 1, n, t, ldt, t2, ldt, q, ldt, z, ldt, work,
208 $ result( 1 ) )
209 CALL sget51( 1, n, s, ldt, s2, ldt, q, ldt, z, ldt, work,
210 $ result( 2 ) )
211 CALL sget51( 3, n, t, ldt, t2, ldt, q, ldt, q, ldt, work,
212 $ result( 3 ) )
213 CALL sget51( 3, n, t, ldt, t2, ldt, z, ldt, z, ldt, work,
214 $ result( 4 ) )
215 res = res + result( 1 ) + result( 2 ) + result( 3 ) + result( 4 )
216*
217* Read next matrix pair
218*
219 GO TO 10
220*
221* End of SGET40
222*
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
slacpy
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
Definition slacpy.f:103
stgexc
subroutine stgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, work, lwork, info)
STGEXC
Definition stgexc.f:220
sget51
subroutine sget51(itype, n, a, lda, b, ldb, u, ldu, v, ldv, work, result)
SGET51
Definition sget51.f:149

◆ zbdt05()

subroutine zbdt05 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) s,
integer ns,
complex*16, dimension( * ) u,
integer ldu,
complex*16, dimension( ldvt, * ) vt,
integer ldvt,
complex*16, dimension( * ) work,
double precision resid )

ZBDT05

Purpose:
!>
!> ZBDT05 reconstructs a bidiagonal matrix B from its (partial) 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( S - U' * B * V ) / ( n * norm(B) * EPS )
!> where VT = V' and EPS is the machine precision.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrices A and U.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and VT.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m by n matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (NS)
!>          The singular values from the (partial) SVD of B, sorted in
!>          decreasing order.
!>
[in]NS
!>          NS is INTEGER
!>          The number of singular values/vectors from the (partial)
!>          SVD of B.
!>
[in]U
!>          U is COMPLEX*16 array, dimension (LDU,NS)
!>          The n by ns orthogonal matrix U in S = U' * B * V.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,N)
!>
[in]VT
!>          VT is COMPLEX*16 array, dimension (LDVT,N)
!>          The n by ns orthogonal matrix V in S = U' * B * V.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (M,N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The test ratio:  norm(S - U' * A * V) / ( n * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file zbdt05.f.

125*
126* -- LAPACK test routine --
127* -- LAPACK is a software package provided by Univ. of Tennessee, --
128* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
129*
130* .. Scalar Arguments ..
131 INTEGER LDA, LDU, LDVT, M, N, NS
132 DOUBLE PRECISION RESID
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION S( * )
136 COMPLEX*16 A( LDA, * ), U( * ), VT( LDVT, * ), WORK( * )
137* ..
138*
139* ======================================================================
140*
141* .. Parameters ..
142 DOUBLE PRECISION ZERO, ONE
143 parameter( zero = 0.0d+0, one = 1.0d+0 )
144 COMPLEX*16 CZERO, CONE
145 parameter( czero = ( 0.0d+0, 0.0d+0 ),
146 $ cone = ( 1.0d+0, 0.0d+0 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER I, J
150 DOUBLE PRECISION ANORM, EPS
151* ..
152* .. Local Arrays ..
153 DOUBLE PRECISION DUM( 1 )
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 INTEGER IDAMAX
158 DOUBLE PRECISION DASUM, DZASUM, DLAMCH, ZLANGE
159 EXTERNAL lsame, idamax, dasum, dzasum, dlamch, zlange
160* ..
161* .. External Subroutines ..
162 EXTERNAL zgemm
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC abs, dble, max, min
166* ..
167* .. Executable Statements ..
168*
169* Quick return if possible.
170*
171 resid = zero
172 IF( min( m, n ).LE.0 .OR. ns.LE.0 )
173 $ RETURN
174*
175 eps = dlamch( 'Precision' )
176 anorm = zlange( 'M', m, n, a, lda, dum )
177*
178* Compute U' * A * V.
179*
180 CALL zgemm( 'N', 'C', m, ns, n, cone, a, lda, vt,
181 $ ldvt, czero, work( 1+ns*ns ), m )
182 CALL zgemm( 'C', 'N', ns, ns, m, -cone, u, ldu, work( 1+ns*ns ),
183 $ m, czero, work, ns )
184*
185* norm(S - U' * B * V)
186*
187 j = 0
188 DO 10 i = 1, ns
189 work( j+i ) = work( j+i ) + dcmplx( s( i ), zero )
190 resid = max( resid, dzasum( ns, work( j+1 ), 1 ) )
191 j = j + ns
192 10 CONTINUE
193*
194 IF( anorm.LE.zero ) THEN
195 IF( resid.NE.zero )
196 $ resid = one / eps
197 ELSE
198 IF( anorm.GE.resid ) THEN
199 resid = ( resid / anorm ) / ( dble( n )*eps )
200 ELSE
201 IF( anorm.LT.one ) THEN
202 resid = ( min( resid, dble( n )*anorm ) / anorm ) /
203 $ ( dble( n )*eps )
204 ELSE
205 resid = min( resid / anorm, dble( n ) ) /
206 $ ( dble( n )*eps )
207 END IF
208 END IF
209 END IF
210*
211 RETURN
212*
213* End of ZBDT05
214*
zlange
double precision function zlange(norm, m, n, a, lda, work)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlange.f:115
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187
dzasum
double precision function dzasum(n, zx, incx)
DZASUM
Definition dzasum.f:72