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

Functions

subroutine sbdt01 (m, n, kd, a, lda, q, ldq, d, e, pt, ldpt, work, resid)
 SBDT01
subroutine sbdt02 (m, n, b, ldb, c, ldc, u, ldu, work, resid)
 SBDT02
subroutine sbdt03 (uplo, n, kd, d, e, u, ldu, s, vt, ldvt, work, resid)
 SBDT03
subroutine schkbb (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)
 SCHKBB
subroutine schkbd (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)
 SCHKBD
subroutine schkbk (nin, nout)
 SCHKBK
subroutine schkbl (nin, nout)
 SCHKBL
subroutine schkec (thresh, tsterr, nin, nout)
 SCHKEC
program schkee
 SCHKEE
subroutine schkgg (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)
 SCHKGG
subroutine schkgk (nin, nout)
 SCHKGK
subroutine schkgl (nin, nout)
 SCHKGL
subroutine schkhs (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)
 SCHKHS
subroutine schksb (nsizes, nn, nwdths, kk, ntypes, dotype, iseed, thresh, nounit, a, lda, sd, se, u, ldu, work, lwork, result, info)
 SCHKSB
subroutine schksb2stg (nsizes, nn, nwdths, kk, ntypes, dotype, iseed, thresh, nounit, a, lda, sd, se, d1, d2, d3, u, ldu, work, lwork, result, info)
 SCHKSB2STG
subroutine schkst (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)
 SCHKST
subroutine schkst2stg (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)
 SCHKST2STG
subroutine sckcsd (nm, mval, pval, qval, nmats, iseed, thresh, mmax, x, xf, u1, u2, v1t, v2t, theta, iwork, work, rwork, nin, nout, info)
 SCKCSD
subroutine sckglm (nn, mval, pval, nval, nmats, iseed, thresh, nmax, a, af, b, bf, x, work, rwork, nin, nout, info)
 SCKGLM
subroutine sckgqr (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)
 SCKGQR
subroutine sckgsv (nm, mval, pval, nval, nmats, iseed, thresh, nmax, a, af, b, bf, u, v, q, alpha, beta, r, iwork, work, rwork, nin, nout, info)
 SCKGSV
subroutine scklse (nn, mval, pval, nval, nmats, iseed, thresh, nmax, a, af, b, bf, x, work, rwork, nin, nout, info)
 SCKLSE
subroutine scsdts (m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, theta, iwork, work, lwork, rwork, result)
 SCSDTS
subroutine sdrges (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, alphar, alphai, beta, work, lwork, result, bwork, info)
 SDRGES
subroutine sdrges3 (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, s, t, q, ldq, z, alphar, alphai, beta, work, lwork, result, bwork, info)
 SDRGES3
subroutine sdrgev (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)
 SDRGEV
subroutine sdrgev3 (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)
 SDRGEV3
subroutine sdrgsx (nsize, ncmax, thresh, nin, nout, a, lda, b, ai, bi, z, q, alphar, alphai, beta, c, ldc, s, work, lwork, iwork, liwork, bwork, info)
 SDRGSX
subroutine sdrgvx (nsize, thresh, nin, nout, a, lda, b, ai, bi, alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, s, stru, dif, diftru, work, lwork, iwork, liwork, result, bwork, info)
 SDRGVX
subroutine sdrvbd (nsizes, mm, nn, ntypes, dotype, iseed, thresh, a, lda, u, ldu, vt, ldvt, asav, usav, vtsav, s, ssav, e, work, lwork, iwork, nout, info)
 SDRVBD
subroutine sdrves (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, h, ht, wr, wi, wrt, wit, vs, ldvs, result, work, nwork, iwork, bwork, info)
 SDRVES
subroutine sdrvev (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)
 SDRVEV
subroutine sdrvsg (nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, b, ldb, d, z, ldz, ab, bb, ap, bp, work, nwork, iwork, liwork, result, info)
 SDRVSG
subroutine sdrvst (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)
 SDRVST
subroutine sdrvst2stg (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)
 SDRVST2STG
subroutine sdrvsx (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)
 SDRVSX
subroutine sdrvvx (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)
 SDRVVX
subroutine serrbd (path, nunit)
 SERRBD
subroutine serrec (path, nunit)
 SERREC
subroutine serred (path, nunit)
 SERRED
subroutine serrgg (path, nunit)
 SERRGG
subroutine serrhs (path, nunit)
 SERRHS
subroutine serrst (path, nunit)
 SERRST
subroutine sget02 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 SGET02
subroutine sget10 (m, n, a, lda, b, ldb, work, result)
 SGET10
subroutine sget22 (transa, transe, transw, n, a, lda, e, lde, wr, wi, work, result)
 SGET22
subroutine sget23 (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)
 SGET23
subroutine sget24 (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)
 SGET24
subroutine sget31 (rmax, lmax, ninfo, knt)
 SGET31
subroutine sget32 (rmax, lmax, ninfo, knt)
 SGET32
subroutine sget33 (rmax, lmax, ninfo, knt)
 SGET33
subroutine sget34 (rmax, lmax, ninfo, knt)
 SGET34
subroutine sget35 (rmax, lmax, ninfo, knt)
 SGET35
subroutine sget36 (rmax, lmax, ninfo, knt, nin)
 SGET36
subroutine sget37 (rmax, lmax, ninfo, knt, nin)
 SGET37
subroutine sget38 (rmax, lmax, ninfo, knt, nin)
 SGET38
subroutine sget39 (rmax, lmax, ninfo, knt)
 SGET39
subroutine sget51 (itype, n, a, lda, b, ldb, u, ldu, v, ldv, work, result)
 SGET51
subroutine sget52 (left, n, a, lda, b, ldb, e, lde, alphar, alphai, beta, work, result)
 SGET52
subroutine sget53 (a, lda, b, ldb, scale, wr, wi, result, info)
 SGET53
subroutine sget54 (n, a, lda, b, ldb, s, lds, t, ldt, u, ldu, v, ldv, work, result)
 SGET54
subroutine sglmts (n, m, p, a, af, lda, b, bf, ldb, d, df, x, u, work, lwork, rwork, result)
 SGLMTS
subroutine sgqrts (n, m, p, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
 SGQRTS
subroutine sgrqts (m, p, n, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
 SGRQTS
subroutine sgsvts3 (m, p, n, a, af, lda, b, bf, ldb, u, ldu, v, ldv, q, ldq, alpha, beta, r, ldr, iwork, work, lwork, rwork, result)
 SGSVTS3
subroutine shst01 (n, ilo, ihi, a, lda, h, ldh, q, ldq, work, lwork, result)
 SHST01
subroutine slafts (type, m, n, imat, ntests, result, iseed, thresh, iounit, ie)
 SLAFTS
subroutine slahd2 (iounit, path)
 SLAHD2
subroutine slarfy (uplo, n, v, incv, tau, c, ldc, work)
 SLARFY
subroutine slarhs (path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
 SLARHS
subroutine slatb9 (path, imat, m, p, n, type, kla, kua, klb, kub, anorm, bnorm, modea, modeb, cndnma, cndnmb, dista, distb)
 SLATB9
subroutine slatm4 (itype, n, nz1, nz2, isign, amagn, rcond, triang, idist, iseed, a, lda)
 SLATM4
logical function slctes (zr, zi, d)
 SLCTES
logical function slctsx (ar, ai, beta)
 SLCTSX
subroutine slsets (m, p, n, a, af, lda, b, bf, ldb, c, cf, d, df, x, work, lwork, rwork, result)
 SLSETS
subroutine sort01 (rowcol, m, n, u, ldu, work, lwork, resid)
 SORT01
subroutine sort03 (rc, mu, mv, n, k, u, ldu, v, ldv, work, lwork, result, info)
 SORT03
subroutine ssbt21 (uplo, n, ka, ks, a, lda, d, e, u, ldu, work, result)
 SSBT21
subroutine ssgt01 (itype, uplo, n, m, a, lda, b, ldb, z, ldz, d, work, result)
 SSGT01
logical function sslect (zr, zi)
 SSLECT
subroutine sspt21 (itype, uplo, n, kband, ap, d, e, u, ldu, vp, tau, work, result)
 SSPT21
subroutine sstech (n, a, b, eig, tol, work, info)
 SSTECH
subroutine sstect (n, a, b, shift, num)
 SSTECT
subroutine sstt21 (n, kband, ad, ae, sd, se, u, ldu, work, result)
 SSTT21
subroutine sstt22 (n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, result)
 SSTT22
subroutine ssvdch (n, s, e, svd, tol, info)
 SSVDCH
subroutine ssvdct (n, s, e, shift, num)
 SSVDCT
real function ssxt1 (ijob, d1, n1, d2, n2, abstol, ulp, unfl)
 SSXT1
subroutine ssyt21 (itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, result)
 SSYT21
subroutine ssyt22 (itype, uplo, n, m, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, result)
 SSYT22

Detailed Description

This is the group of real LAPACK TESTING EIG routines.

Function Documentation

◆ sbdt01()

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

SBDT01

Purpose:
!>
!> SBDT01 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 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]Q
!>          Q is REAL 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 REAL array, dimension (min(M,N))
!>          The diagonal elements of the bidiagonal matrix B.
!>
[in]E
!>          E is REAL array, dimension (min(M,N)-1)
!>          The superdiagonal elements of the bidiagonal matrix B if
!>          m >= n, or the subdiagonal elements of B if m < n.
!>
[in]PT
!>          PT is REAL 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 REAL array, dimension (M+N)
!>
[out]RESID
!>          RESID is REAL
!>          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 sbdt01.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 REAL RESID
149* ..
150* .. Array Arguments ..
151 REAL A( LDA, * ), D( * ), E( * ), PT( LDPT, * ),
152 $ Q( LDQ, * ), WORK( * )
153* ..
154*
155* =====================================================================
156*
157* .. Parameters ..
158 REAL ZERO, ONE
159 parameter( zero = 0.0e+0, one = 1.0e+0 )
160* ..
161* .. Local Scalars ..
162 INTEGER I, J
163 REAL ANORM, EPS
164* ..
165* .. External Functions ..
166 REAL SASUM, SLAMCH, SLANGE
167 EXTERNAL sasum, slamch, slange
168* ..
169* .. External Subroutines ..
170 EXTERNAL scopy, sgemv
171* ..
172* .. Intrinsic Functions ..
173 INTRINSIC max, min, real
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 scopy( 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 sgemv( 'No transpose', m, n, -one, q, ldq,
202 $ work( m+1 ), 1, one, work, 1 )
203 resid = max( resid, sasum( 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 scopy( 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 sgemv( 'No transpose', m, m, -one, q, ldq,
216 $ work( m+1 ), 1, one, work, 1 )
217 resid = max( resid, sasum( m, work, 1 ) )
218 40 CONTINUE
219 ELSE
220*
221* B is lower bidiagonal.
222*
223 DO 60 j = 1, n
224 CALL scopy( 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 sgemv( 'No transpose', m, m, -one, q, ldq,
231 $ work( m+1 ), 1, one, work, 1 )
232 resid = max( resid, sasum( 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 scopy( 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 sgemv( 'No transpose', m, n, -one, q, ldq,
246 $ work( m+1 ), 1, one, work, 1 )
247 resid = max( resid, sasum( m, work, 1 ) )
248 80 CONTINUE
249 ELSE
250 DO 100 j = 1, n
251 CALL scopy( 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 sgemv( 'No transpose', m, m, -one, q, ldq,
256 $ work( m+1 ), 1, one, work, 1 )
257 resid = max( resid, sasum( 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 = slange( '1', m, n, a, lda, work )
265 eps = slamch( '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 ) / ( real( n )*eps )
273 ELSE
274 IF( anorm.LT.one ) THEN
275 resid = ( min( resid, real( n )*anorm ) / anorm ) /
276 $ ( real( n )*eps )
277 ELSE
278 resid = min( resid / anorm, real( n ) ) /
279 $ ( real( n )*eps )
280 END IF
281 END IF
282 END IF
283*
284 RETURN
285*
286* End of SBDT01
287*
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
sasum
real function sasum(n, sx, incx)
SASUM
Definition sasum.f:72
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
sgemv
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SGEMV
Definition sgemv.f:156
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

◆ sbdt02()

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

SBDT02

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

Definition at line 111 of file sbdt02.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 REAL RESID
120* ..
121* .. Array Arguments ..
122 REAL B( LDB, * ), C( LDC, * ), U( LDU, * ),
123 $ WORK( * )
124* ..
125*
126* ======================================================================
127*
128* .. Parameters ..
129 REAL ZERO, ONE
130 parameter( zero = 0.0e+0, one = 1.0e+0 )
131* ..
132* .. Local Scalars ..
133 INTEGER J
134 REAL BNORM, EPS, REALMN
135* ..
136* .. External Functions ..
137 REAL SASUM, SLAMCH, SLANGE
138 EXTERNAL sasum, slamch, slange
139* ..
140* .. External Subroutines ..
141 EXTERNAL scopy, sgemv
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC max, min, real
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 = real( max( m, n ) )
154 eps = slamch( 'Precision' )
155*
156* Compute norm(B - U * C)
157*
158 DO 10 j = 1, n
159 CALL scopy( m, b( 1, j ), 1, work, 1 )
160 CALL sgemv( 'No transpose', m, m, -one, u, ldu, c( 1, j ), 1,
161 $ one, work, 1 )
162 resid = max( resid, sasum( m, work, 1 ) )
163 10 CONTINUE
164*
165* Compute norm of B.
166*
167 bnorm = slange( '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 SBDT02
187*

◆ sbdt03()

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

SBDT03

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

Definition at line 133 of file sbdt03.f.

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

◆ schkbb()

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

SCHKBB

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

Definition at line 351 of file schkbb.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 REAL THRESH
364* ..
365* .. Array Arguments ..
366 LOGICAL DOTYPE( * )
367 INTEGER ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * )
368 REAL 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 REAL ZERO, ONE
377 parameter( zero = 0.0e0, one = 1.0e0 )
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 REAL 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 REAL SLAMCH
396 EXTERNAL slamch
397* ..
398* .. External Subroutines ..
399 EXTERNAL sbdt01, sbdt02, sgbbrd, slacpy, slahd2, slaset,
400 $ slasum, slatmr, slatms, sort01, xerbla
401* ..
402* .. Intrinsic Functions ..
403 INTRINSIC abs, max, min, real, 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( 'SCHKBB', -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 = slamch( 'Safe minimum' )
486 ovfl = one / unfl
487 ulp = slamch( 'Epsilon' )*slamch( '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 / real( 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 slaset( 'Full', lda, n, zero, zero, a, lda )
566 CALL slaset( '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 slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 slacpy( 'Full', m, nrhs, c, ldc, cc, ldc )
643*
644* Call SGBBRD to compute B, Q and P, and to update C.
645*
646 CALL sgbbrd( '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 )'SGBBRD', 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 sbdt01( m, n, -1, a, lda, q, ldq, bd, be, p, ldp,
667 $ work, result( 1 ) )
668 CALL sort01( 'Columns', m, m, q, ldq, work, lwork,
669 $ result( 2 ) )
670 CALL sort01( 'Rows', n, n, p, ldp, work, lwork,
671 $ result( 3 ) )
672 CALL sbdt02( 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 slahd2( nounit, 'SBB' )
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 slasum( 'SBB', nounit, nerrs, ntestt )
700 RETURN
701*
702 9999 FORMAT( ' SCHKBB: ', 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 SCHKBB
709*
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
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
sgbbrd
subroutine sgbbrd(vect, m, n, ncc, kl, ku, ab, ldab, d, e, q, ldq, pt, ldpt, c, ldc, work, info)
SGBBRD
Definition sgbbrd.f:187
slatmr
subroutine slatmr(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)
SLATMR
Definition slatmr.f:471
slatms
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
Definition slatms.f:321
sort01
subroutine sort01(rowcol, m, n, u, ldu, work, lwork, resid)
SORT01
Definition sort01.f:116
sbdt02
subroutine sbdt02(m, n, b, ldb, c, ldc, u, ldu, work, resid)
SBDT02
Definition sbdt02.f:112
sbdt01
subroutine sbdt01(m, n, kd, a, lda, q, ldq, d, e, pt, ldpt, work, resid)
SBDT01
Definition sbdt01.f:141
slahd2
subroutine slahd2(iounit, path)
SLAHD2
Definition slahd2.f:65
slasum
subroutine slasum(type, iounit, ie, nrun)
SLASUM
Definition slasum.f:41

◆ schkbd()

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

SCHKBD

Purpose:
!>
!> SCHKBD checks the singular value decomposition (SVD) routines.
!>
!> SGEBRD 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.
!>
!> SORGBR generates the orthogonal matrices Q and P' from SGEBRD.
!> Note that Q and P are not necessarily square.
!>
!> SBDSQR 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, SBDSQR has an option to apply the left orthogonal matrix
!> U to a matrix X, useful in least squares applications.
!>
!> SBDSDC 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.
!>
!>  SBDSVDX 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 SGEBRD and SORGBR
!>
!> (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 SBDSQR 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
!>       SSVDCH)
!>
!> Test SBDSQR 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 SBDSDC 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 SBDSVDX 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 )    SBDSVDX('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 )   SBDSVDX('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) SGEBRD 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, SCHKBD
!>          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 SBDSQR.  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 SCHKBD to continue the same random
!>          number sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.  Note that the
!>          expected value of the test ratios is O(1), so THRESH should
!>          be a reasonably small multiple of 1, e.g., 10 or 100.
!>
[out]A
!>          A is REAL array, dimension (LDA,NMAX)
!>          where NMAX is the maximum value of N in NVAL.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,MMAX),
!>          where MMAX is the maximum value of M in MVAL.
!>
[out]BD
!>          BD is REAL array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]BE
!>          BE is REAL array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]S1
!>          S1 is REAL array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]S2
!>          S2 is REAL array, dimension
!>                      (max(min(MVAL(j),NVAL(j))))
!>
[out]X
!>          X is REAL 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 REAL array, dimension (LDX,NRHS)
!>
[out]Z
!>          Z is REAL array, dimension (LDX,NRHS)
!>
[out]Q
!>          Q is REAL array, dimension (LDQ,MMAX)
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,MMAX).
!>
[out]PT
!>          PT is REAL 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 REAL array, dimension
!>                      (LDPT,max(min(MVAL(j),NVAL(j))))
!>
[out]VT
!>          VT is REAL array, dimension
!>                      (LDPT,max(min(MVAL(j),NVAL(j))))
!>
[out]WORK
!>          WORK is REAL 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  SLATMR, SLATMS, SGEBRD, SORGBR, or SBDSQR,
!>              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 schkbd.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 REAL THRESH
502* ..
503* .. Array Arguments ..
504 LOGICAL DOTYPE( * )
505 INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * )
506 REAL 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 REAL ZERO, ONE, TWO, HALF
516 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
517 $ half = 0.5e0 )
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 REAL 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 REAL DUM( 1 ), DUMMA( 1 ), RESULT( 40 )
539* ..
540* .. External Functions ..
541 REAL SLAMCH, SLARND, SSXT1
542 EXTERNAL slamch, slarnd, ssxt1
543* ..
544* .. External Subroutines ..
545 EXTERNAL alasum, sbdsdc, sbdsqr, sbdsvdx, sbdt01,
546 $ sbdt02, sbdt03, sbdt04, scopy, sgebrd,
547 $ sgemm, slabad, slacpy, slahd2, slaset,
548 $ slatmr, slatms, sorgbr, sort01, 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( 'SCHKBD', -info )
619 RETURN
620 END IF
621*
622* Initialize constants
623*
624 path( 1: 1 ) = 'Single precision'
625 path( 2: 3 ) = 'BD'
626 nfail = 0
627 ntest = 0
628 unfl = slamch( 'Safe minimum' )
629 ovfl = slamch( 'Overflow' )
630 CALL slabad( unfl, ovfl )
631 ulp = slamch( '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 slaset( '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 slatms( 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 slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 slatmr( 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*slarnd( 2, iseed ) )
784 IF( j.LT.mnmin )
785 $ be( j ) = exp( temp1*slarnd( 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 slatmr( 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 slatmr( 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 SGEBRD and SORGBR 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 slacpy( ' ', m, n, a, lda, q, ldq )
837 CALL sgebrd( 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 SGEBRD.
841*
842 IF( iinfo.NE.0 ) THEN
843 WRITE( nout, fmt = 9998 )'SGEBRD', iinfo, m, n,
844 $ jtype, ioldsd
845 info = abs( iinfo )
846 RETURN
847 END IF
848*
849 CALL slacpy( ' ', 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 sorgbr( 'Q', m, mq, n, q, ldq, work,
862 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
863*
864* Check error code from SORGBR.
865*
866 IF( iinfo.NE.0 ) THEN
867 WRITE( nout, fmt = 9998 )'SORGBR(Q)', iinfo, m, n,
868 $ jtype, ioldsd
869 info = abs( iinfo )
870 RETURN
871 END IF
872*
873* Generate P'
874*
875 CALL sorgbr( 'P', mnmin, n, m, pt, ldpt, work( mnmin+1 ),
876 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
877*
878* Check error code from SORGBR.
879*
880 IF( iinfo.NE.0 ) THEN
881 WRITE( nout, fmt = 9998 )'SORGBR(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 sgemm( '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 sbdt01( m, n, 1, a, lda, q, ldq, bd, be, pt, ldpt,
897 $ work, result( 1 ) )
898 CALL sort01( 'Columns', m, mq, q, ldq, work, lwork,
899 $ result( 2 ) )
900 CALL sort01( 'Rows', mnmin, n, pt, ldpt, work, lwork,
901 $ result( 3 ) )
902 END IF
903*
904* Use SBDSQR to form the SVD of the bidiagonal matrix B:
905* B := U * S1 * VT, and compute Z = U' * Y.
906*
907 CALL scopy( mnmin, bd, 1, s1, 1 )
908 IF( mnmin.GT.0 )
909 $ CALL scopy( mnmin-1, be, 1, work, 1 )
910 CALL slacpy( ' ', m, nrhs, y, ldx, z, ldx )
911 CALL slaset( 'Full', mnmin, mnmin, zero, one, u, ldpt )
912 CALL slaset( 'Full', mnmin, mnmin, zero, one, vt, ldpt )
913*
914 CALL sbdsqr( uplo, mnmin, mnmin, mnmin, nrhs, s1, work, vt,
915 $ ldpt, u, ldpt, z, ldx, work( mnmin+1 ), iinfo )
916*
917* Check error code from SBDSQR.
918*
919 IF( iinfo.NE.0 ) THEN
920 WRITE( nout, fmt = 9998 )'SBDSQR(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 SBDSQR to compute only the singular values of the
932* bidiagonal matrix B; U, VT, and Z should not be modified.
933*
934 CALL scopy( mnmin, bd, 1, s2, 1 )
935 IF( mnmin.GT.0 )
936 $ CALL scopy( mnmin-1, be, 1, work, 1 )
937*
938 CALL sbdsqr( uplo, mnmin, 0, 0, 0, s2, work, vt, ldpt, u,
939 $ ldpt, z, ldx, work( mnmin+1 ), iinfo )
940*
941* Check error code from SBDSQR.
942*
943 IF( iinfo.NE.0 ) THEN
944 WRITE( nout, fmt = 9998 )'SBDSQR(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 sbdt03( uplo, mnmin, 1, bd, be, u, ldpt, s1, vt, ldpt,
961 $ work, result( 4 ) )
962 CALL sbdt02( mnmin, nrhs, y, ldx, z, ldx, u, ldpt, work,
963 $ result( 5 ) )
964 CALL sort01( 'Columns', mnmin, mnmin, u, ldpt, work, lwork,
965 $ result( 6 ) )
966 CALL sort01( '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 SBDSQR 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 SSVDCH( 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 SBDSQR 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 scopy( mnmin, bd, 1, s2, 1 )
1017 IF( mnmin.GT.0 )
1018 $ CALL scopy( mnmin-1, be, 1, work, 1 )
1019*
1020 CALL sbdsqr( 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 sbdt01( m, n, 0, a, lda, q, ldq, s2, dumma, pt,
1029 $ ldpt, work, result( 11 ) )
1030 CALL sbdt02( m, nrhs, x, ldx, y, ldx, q, ldq, work,
1031 $ result( 12 ) )
1032 CALL sort01( 'Columns', m, mq, q, ldq, work, lwork,
1033 $ result( 13 ) )
1034 CALL sort01( 'Rows', mnmin, n, pt, ldpt, work, lwork,
1035 $ result( 14 ) )
1036 END IF
1037*
1038* Use SBDSDC to form the SVD of the bidiagonal matrix B:
1039* B := U * S1 * VT
1040*
1041 CALL scopy( mnmin, bd, 1, s1, 1 )
1042 IF( mnmin.GT.0 )
1043 $ CALL scopy( mnmin-1, be, 1, work, 1 )
1044 CALL slaset( 'Full', mnmin, mnmin, zero, one, u, ldpt )
1045 CALL slaset( 'Full', mnmin, mnmin, zero, one, vt, ldpt )
1046*
1047 CALL sbdsdc( uplo, 'I', mnmin, s1, work, u, ldpt, vt, ldpt,
1048 $ dum, idum, work( mnmin+1 ), iwork, iinfo )
1049*
1050* Check error code from SBDSDC.
1051*
1052 IF( iinfo.NE.0 ) THEN
1053 WRITE( nout, fmt = 9998 )'SBDSDC(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 SBDSDC to compute only the singular values of the
1065* bidiagonal matrix B; U and VT should not be modified.
1066*
1067 CALL scopy( mnmin, bd, 1, s2, 1 )
1068 IF( mnmin.GT.0 )
1069 $ CALL scopy( mnmin-1, be, 1, work, 1 )
1070*
1071 CALL sbdsdc( uplo, 'N', mnmin, s2, work, dum, 1, dum, 1,
1072 $ dum, idum, work( mnmin+1 ), iwork, iinfo )
1073*
1074* Check error code from SBDSDC.
1075*
1076 IF( iinfo.NE.0 ) THEN
1077 WRITE( nout, fmt = 9998 )'SBDSDC(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 sbdt03( uplo, mnmin, 1, bd, be, u, ldpt, s1, vt, ldpt,
1093 $ work, result( 15 ) )
1094 CALL sort01( 'Columns', mnmin, mnmin, u, ldpt, work, lwork,
1095 $ result( 16 ) )
1096 CALL sort01( '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 SBDSQR 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 SBDSVDX 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 scopy( mnmin, bd, 1, work( iwbd ), 1 )
1147 IF( mnmin.GT.0 )
1148 $ CALL scopy( mnmin-1, be, 1, work( iwbe ), 1 )
1149*
1150 CALL sbdsvdx( 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 SBDSVDX.
1156*
1157 IF( iinfo.NE.0 ) THEN
1158 WRITE( nout, fmt = 9998 )'SBDSVDX(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 scopy( mnmin, work( j ), 1, u( 1,i ), 1 )
1172 j = j + mnmin
1173 CALL scopy( mnmin, work( j ), 1, vt( i,1 ), ldpt )
1174 j = j + mnmin
1175 170 CONTINUE
1176*
1177* Use SBDSVDX 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 scopy( mnmin, bd, 1, work( iwbd ), 1 )
1189 IF( mnmin.GT.0 )
1190 $ CALL scopy( mnmin-1, be, 1, work( iwbe ), 1 )
1191*
1192 CALL sbdsvdx( 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 SBDSVDX.
1198*
1199 IF( iinfo.NE.0 ) THEN
1200 WRITE( nout, fmt = 9998 )'SBDSVDX(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 scopy( 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 SBDSVDX with and without singular vectors
1221*
1222 CALL sbdt03( uplo, mnmin, 1, bd, be, u, ldpt, s1, vt,
1223 $ ldpt, work( iwbs+mnmin ), result( 20 ) )
1224 CALL sort01( 'Columns', mnmin, mnmin, u, ldpt,
1225 $ work( iwbs+mnmin ), lwork-mnmin,
1226 $ result( 21 ) )
1227 CALL sort01( '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 SBDSVDX 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 )*slarnd( 1, iseed2 ) )
1265 iu = 1 + int( ( mnmin-1 )*slarnd( 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 scopy( mnmin, bd, 1, work( iwbd ), 1 )
1274 IF( mnmin.GT.0 )
1275 $ CALL scopy( mnmin-1, be, 1, work( iwbe ), 1 )
1276*
1277 CALL sbdsvdx( 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 SBDSVDX.
1283*
1284 IF( iinfo.NE.0 ) THEN
1285 WRITE( nout, fmt = 9998 )'SBDSVDX(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 scopy( mnmin, work( j ), 1, u( 1,i ), 1 )
1299 j = j + mnmin
1300 CALL scopy( mnmin, work( j ), 1, vt( i,1 ), ldpt )
1301 j = j + mnmin
1302 210 CONTINUE
1303*
1304* Use SBDSVDX to compute only the singular values of the
1305* bidiagonal matrix B; U and VT should not be modified.
1306*
1307 CALL scopy( mnmin, bd, 1, work( iwbd ), 1 )
1308 IF( mnmin.GT.0 )
1309 $ CALL scopy( mnmin-1, be, 1, work( iwbe ), 1 )
1310*
1311 CALL sbdsvdx( 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 SBDSVDX.
1317*
1318 IF( iinfo.NE.0 ) THEN
1319 WRITE( nout, fmt = 9998 )'SBDSVDX(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 SBDSVDX with and without singular vectors
1336*
1337 CALL sbdt04( uplo, mnmin, bd, be, s1, ns1, u,
1338 $ ldpt, vt, ldpt, work( iwbs+mnmin ),
1339 $ result( 25 ) )
1340 CALL sort01( 'Columns', mnmin, ns1, u, ldpt,
1341 $ work( iwbs+mnmin ), lwork-mnmin,
1342 $ result( 26 ) )
1343 CALL sort01( '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 SBDSVDX 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 scopy( 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 scopy( mnmin, bd, 1, work( iwbd ), 1 )
1398 IF( mnmin.GT.0 )
1399 $ CALL scopy( mnmin-1, be, 1, work( iwbe ), 1 )
1400*
1401 CALL sbdsvdx( 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 SBDSVDX.
1407*
1408 IF( iinfo.NE.0 ) THEN
1409 WRITE( nout, fmt = 9998 )'SBDSVDX(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 scopy( mnmin, work( j ), 1, u( 1,i ), 1 )
1423 j = j + mnmin
1424 CALL scopy( mnmin, work( j ), 1, vt( i,1 ), ldpt )
1425 j = j + mnmin
1426 240 CONTINUE
1427*
1428* Use SBDSVDX to compute only the singular values of the
1429* bidiagonal matrix B; U and VT should not be modified.
1430*
1431 CALL scopy( mnmin, bd, 1, work( iwbd ), 1 )
1432 IF( mnmin.GT.0 )
1433 $ CALL scopy( mnmin-1, be, 1, work( iwbe ), 1 )
1434*
1435 CALL sbdsvdx( 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 SBDSVDX.
1441*
1442 IF( iinfo.NE.0 ) THEN
1443 WRITE( nout, fmt = 9998 )'SBDSVDX(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 SBDSVDX with and without singular vectors
1460*
1461 CALL sbdt04( uplo, mnmin, bd, be, s1, ns1, u,
1462 $ ldpt, vt, ldpt, work( iwbs+mnmin ),
1463 $ result( 30 ) )
1464 CALL sort01( 'Columns', mnmin, ns1, u, ldpt,
1465 $ work( iwbs+mnmin ), lwork-mnmin,
1466 $ result( 31 ) )
1467 CALL sort01( '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 slahd2( 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 SCHKBD
1521*
1522 9999 FORMAT( ' M=', i5, ', N=', i5, ', type ', i2, ', seed=',
1523 $ 4( i4, ',' ), ' test(', i2, ')=', g11.4 )
1524 9998 FORMAT( ' SCHKBD: ', a, ' returned INFO=', i6, '.', / 9x, 'M=',
1525 $ i6, ', N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ),
1526 $ i5, ')' )
1527*
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74
sbdsqr
subroutine sbdsqr(uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
SBDSQR
Definition sbdsqr.f:240
sbdsdc
subroutine sbdsdc(uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq, work, iwork, info)
SBDSDC
Definition sbdsdc.f:205
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
sbdt04
subroutine sbdt04(uplo, n, d, e, s, ns, u, ldu, vt, ldvt, work, resid)
SBDT04
Definition sbdt04.f:131
sorgbr
subroutine sorgbr(vect, m, n, k, a, lda, tau, work, lwork, info)
SORGBR
Definition sorgbr.f:157
sgebrd
subroutine sgebrd(m, n, a, lda, d, e, tauq, taup, work, lwork, info)
SGEBRD
Definition sgebrd.f:205
sbdsvdx
subroutine sbdsvdx(uplo, jobz, range, n, d, e, vl, vu, il, iu, ns, s, z, ldz, work, iwork, info)
SBDSVDX
Definition sbdsvdx.f:226
slarnd
real function slarnd(idist, iseed)
SLARND
Definition slarnd.f:73
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187
ssxt1
real function ssxt1(ijob, d1, n1, d2, n2, abstol, ulp, unfl)
SSXT1
Definition ssxt1.f:106
sbdt03
subroutine sbdt03(uplo, n, kd, d, e, u, ldu, s, vt, ldvt, work, resid)
SBDT03
Definition sbdt03.f:135

◆ schkbk()

subroutine schkbk ( integer nin,
integer nout )

SCHKBK

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

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 INTEGER NIN, NOUT
62* ..
63*
64* ======================================================================
65*
66* .. Parameters ..
67 INTEGER LDE
68 parameter( lde = 20 )
69 REAL ZERO
70 parameter( zero = 0.0e0 )
71* ..
72* .. Local Scalars ..
73 INTEGER I, IHI, ILO, INFO, J, KNT, N, NINFO
74 REAL EPS, RMAX, SAFMIN, VMAX, X
75* ..
76* .. Local Arrays ..
77 INTEGER LMAX( 2 )
78 REAL E( LDE, LDE ), EIN( LDE, LDE ), SCALE( LDE )
79* ..
80* .. External Functions ..
81 REAL SLAMCH
82 EXTERNAL slamch
83* ..
84* .. External Subroutines ..
85 EXTERNAL sgebak
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 = slamch( 'E' )
98 safmin = slamch( '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 sgebak( '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 SGEBAK .. ' )
144*
145 WRITE( nout, fmt = 9998 )rmax
146 9998 FORMAT( 1x, 'value of largest test error = ', e12.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 SCHKBK
159*
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2942
sgebak
subroutine sgebak(job, side, n, ilo, ihi, scale, m, v, ldv, info)
SGEBAK
Definition sgebak.f:130

◆ schkbl()

subroutine schkbl ( integer nin,
integer nout )

SCHKBL

Purpose:
!>
!> SCHKBL tests SGEBAL, 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 schkbl.f.

54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 INTEGER NIN, NOUT
61* ..
62*
63* ======================================================================
64*
65* .. Parameters ..
66 INTEGER LDA
67 parameter( lda = 20 )
68 REAL ZERO
69 parameter( zero = 0.0e+0 )
70* ..
71* .. Local Scalars ..
72 INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
73 $ NINFO
74 REAL ANORM, MEPS, RMAX, SFMIN, TEMP, VMAX
75* ..
76* .. Local Arrays ..
77 INTEGER LMAX( 3 )
78 REAL A( LDA, LDA ), AIN( LDA, LDA ), DUMMY( 1 ),
79 $ SCALE( LDA ), SCALIN( LDA )
80* ..
81* .. External Functions ..
82 REAL SLAMCH, SLANGE
83 EXTERNAL slamch, slange
84* ..
85* .. External Subroutines ..
86 EXTERNAL sgebal
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 = slamch( 'S' )
101 meps = slamch( '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 = slange( 'M', n, n, a, lda, dummy )
119 knt = knt + 1
120*
121 CALL sgebal( '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 SGEBAL .. ' )
159*
160 WRITE( nout, fmt = 9998 )rmax
161 9998 FORMAT( 1x, 'value of largest test error = ', e12.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 SCHKBL
176*
sgebal
subroutine sgebal(job, n, a, lda, ilo, ihi, scale, info)
SGEBAL
Definition sgebal.f:160

◆ schkec()

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

SCHKEC

Purpose:
!>
!> SCHKEC tests eigen- condition estimation routines
!>        SLALN2, SLASY2, SLANV2, SLAQTR, SLAEXC,
!>        STRSYL, STREXC, STRSNA, STRSEN, STGEXC
!>
!> 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, STREXC, STRSNA and STRSEN
!> are tested by reading in precomputed examples from a file (on input
!> unit NIN).  Output is written to output unit NOUT.
!>
Parameters
[in]THRESH
!>          THRESH is REAL
!>          Threshold for residual tests.  A computed test ratio passes
!>          the threshold if it is less than THRESH.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NIN
!>          NIN is INTEGER
!>          The logical unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The logical unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 75 of file schkec.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 REAL 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 REAL 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 REAL RTRSEN( 3 ), RTRSNA( 3 )
104* ..
105* .. External Subroutines ..
106 EXTERNAL serrec, sget31, sget32, sget33, sget34, sget35,
107 $ sget36, sget37, sget38, sget39, sget40
108* ..
109* .. External Functions ..
110 REAL SLAMCH
111 EXTERNAL slamch
112* ..
113* .. Executable Statements ..
114*
115 path( 1: 1 ) = 'Single precision'
116 path( 2: 3 ) = 'EC'
117 eps = slamch( 'P' )
118 sfmin = slamch( '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 serrec( path, nout )
130*
131 ok = .true.
132 CALL sget31( 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 sget32( 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 sget33( 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 sget34( 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 sget35( 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 sget36( 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 sget37( 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 sget38( 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 sget39( 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 sget40( 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
198 IF( ok )
199 $ WRITE( nout, fmt = 9990 )path, ntests
200*
201 RETURN
202 9999 FORMAT( ' Error in SLALN2: RMAX =', e12.3, / ' LMAX = ', i8, ' N',
203 $ 'INFO=', 2i8, ' KNT=', i8 )
204 9998 FORMAT( ' Error in SLASY2: RMAX =', e12.3, / ' LMAX = ', i8, ' N',
205 $ 'INFO=', i8, ' KNT=', i8 )
206 9997 FORMAT( ' Error in SLANV2: RMAX =', e12.3, / ' LMAX = ', i8, ' N',
207 $ 'INFO=', i8, ' KNT=', i8 )
208 9996 FORMAT( ' Error in SLAEXC: RMAX =', e12.3, / ' LMAX = ', i8, ' N',
209 $ 'INFO=', 2i8, ' KNT=', i8 )
210 9995 FORMAT( ' Error in STRSYL: RMAX =', e12.3, / ' LMAX = ', i8, ' N',
211 $ 'INFO=', i8, ' KNT=', i8 )
212 9994 FORMAT( ' Error in STREXC: RMAX =', e12.3, / ' LMAX = ', i8, ' N',
213 $ 'INFO=', 3i8, ' KNT=', i8 )
214 9993 FORMAT( ' Error in STRSNA: RMAX =', 3e12.3, / ' LMAX = ', 3i8,
215 $ ' NINFO=', 3i8, ' KNT=', i8 )
216 9992 FORMAT( ' Error in STRSEN: RMAX =', 3e12.3, / ' LMAX = ', 3i8,
217 $ ' NINFO=', 3i8, ' KNT=', i8 )
218 9991 FORMAT( ' Error in SLAQTR: RMAX =', e12.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', / ' SLALN2, SLASY2, SLANV2, SLAEXC, STRS',
224 $ 'YL, STREXC, STRSNA, STRSEN, SLAQTR', / )
225 9988 FORMAT( ' Relative machine precision (EPS) = ', e16.6, / ' Safe ',
226 $ 'minimum (SFMIN) = ', e16.6, / )
227 9987 FORMAT( ' Routines pass computational tests if test ratio is les',
228 $ 's than', f8.2, / / )
229 9986 FORMAT( ' Error in STGEXC: RMAX =', e12.3, / ' LMAX = ', i8, ' N',
230 $ 'INFO=', i8, ' KNT=', i8 )
231*
232* End of SCHKEC
233*
sget40
subroutine sget40(rmax, lmax, ninfo, knt, nin)
SGET40
Definition sget40.f:83
sget31
subroutine sget31(rmax, lmax, ninfo, knt)
SGET31
Definition sget31.f:91
sget34
subroutine sget34(rmax, lmax, ninfo, knt)
SGET34
Definition sget34.f:82
serrec
subroutine serrec(path, nunit)
SERREC
Definition serrec.f:56
sget37
subroutine sget37(rmax, lmax, ninfo, knt, nin)
SGET37
Definition sget37.f:90
sget39
subroutine sget39(rmax, lmax, ninfo, knt)
SGET39
Definition sget39.f:103
sget35
subroutine sget35(rmax, lmax, ninfo, knt)
SGET35
Definition sget35.f:78
sget38
subroutine sget38(rmax, lmax, ninfo, knt, nin)
SGET38
Definition sget38.f:91
sget36
subroutine sget36(rmax, lmax, ninfo, knt, nin)
SGET36
Definition sget36.f:88
sget32
subroutine sget32(rmax, lmax, ninfo, knt)
SGET32
Definition sget32.f:82
sget33
subroutine sget33(rmax, lmax, ninfo, knt)
SGET33
Definition sget33.f:76

◆ schkee()

program schkee

SCHKEE

Purpose:
!>
!> SCHKEE tests the REAL LAPACK subroutines for the matrix
!> eigenvalue problem.  The test paths in this version are
!>
!> NEP (Nonsymmetric Eigenvalue Problem):
!>     Test SGEHRD, SORGHR, SHSEQR, STREVC, SHSEIN, and SORMHR
!>
!> SEP (Symmetric Eigenvalue Problem):
!>     Test SSYTRD, SORGTR, SSTEQR, SSTERF, SSTEIN, SSTEDC,
!>     and drivers SSYEV(X), SSBEV(X), SSPEV(X), SSTEV(X),
!>                 SSYEVD,   SSBEVD,   SSPEVD,   SSTEVD
!>
!> SVD (Singular Value Decomposition):
!>     Test SGEBRD, SORGBR, SBDSQR, SBDSDC
!>     and the drivers SGESVD, SGESDD
!>
!> SEV (Nonsymmetric Eigenvalue/eigenvector Driver):
!>     Test SGEEV
!>
!> SES (Nonsymmetric Schur form Driver):
!>     Test SGEES
!>
!> SVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver):
!>     Test SGEEVX
!>
!> SSX (Nonsymmetric Schur form Expert Driver):
!>     Test SGEESX
!>
!> SGG (Generalized Nonsymmetric Eigenvalue Problem):
!>     Test SGGHD3, SGGBAL, SGGBAK, SHGEQZ, and STGEVC
!>
!> SGS (Generalized Nonsymmetric Schur form Driver):
!>     Test SGGES
!>
!> SGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver):
!>     Test SGGEV
!>
!> SGX (Generalized Nonsymmetric Schur form Expert Driver):
!>     Test SGGESX
!>
!> SXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver):
!>     Test SGGEVX
!>
!> SSG (Symmetric Generalized Eigenvalue Problem):
!>     Test SSYGST, SSYGV, SSYGVD, SSYGVX, SSPGST, SSPGV, SSPGVD,
!>     SSPGVX, SSBGST, SSBGV, SSBGVD, and SSBGVX
!>
!> SSB (Symmetric Band Eigenvalue Problem):
!>     Test SSBTRD
!>
!> SBB (Band Singular Value Decomposition):
!>     Test SGBBRD
!>
!> SEC (Eigencondition estimation):
!>     Test SLALN2, SLASY2, SLAEQU, SLAEXC, STRSYL, STREXC, STRSNA,
!>     STRSEN, and SLAQTR
!>
!> SBL (Balancing a general matrix)
!>     Test SGEBAL
!>
!> SBK (Back transformation on a balanced matrix)
!>     Test SGEBAK
!>
!> SGL (Balancing a matrix pair)
!>     Test SGGBAL
!>
!> SGK (Back transformation on a matrix pair)
!>     Test SGGBAK
!>
!> GLM (Generalized Linear Regression Model):
!>     Tests SGGGLM
!>
!> GQR (Generalized QR and RQ factorizations):
!>     Tests SGGQRF and SGGRQF
!>
!> GSV (Generalized Singular Value Decomposition):
!>     Tests SGGSVD, SGGSVP, STGSJA, SLAGS2, SLAPLL, and SLAPMT
!>
!> CSD (CS decomposition):
!>     Tests SORCSD
!>
!> LSE (Constrained Linear Least Squares):
!>     Tests SGGLSE
!>
!> 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
!>
!> SHS or NEP      21     SCHKHS
!> SST or SEP      21     SCHKST (routines)
!>                 18     SDRVST (drivers)
!> SBD or SVD      16     SCHKBD (routines)
!>                  5     SDRVBD (drivers)
!> SEV             21     SDRVEV
!> SES             21     SDRVES
!> SVX             21     SDRVVX
!> SSX             21     SDRVSX
!> SGG             26     SCHKGG (routines)
!> SGS             26     SDRGES
!> SGX              5     SDRGSX
!> SGV             26     SDRGEV
!> SXV              2     SDRGVX
!> SSG             21     SDRVSG
!> SSB             15     SCHKSB
!> SBB             15     SCHKBB
!> SEC              -     SCHKEC
!> SBL              -     SCHKBL
!> SBK              -     SCHKBK
!> SGL              -     SCHKGL
!> SGK              -     SCHKGK
!> GLM              8     SCKGLM
!> GQR              8     SCKGQR
!> GSV              8     SCKGSV
!> CSD              3     SCKCSD
!> LSE              8     SCKLSE
!>
!>-----------------------------------------------------------------------
!>
!> 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 SSG 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
!>          'SSG' 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.
!>
!>-----------------------------------------------------------------------
!>
!> SEV and SES data files:
!>
!> line 1:  'SEV' or 'SES' 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 'SEV' to test SGEEV, or
!>          'SES' to test SGEES.
!>
!>-----------------------------------------------------------------------
!>
!> The SVX data has two parts. The first part is identical to SEV,
!> and the second part consists of test matrices with precomputed
!> solutions.
!>
!> line 1:  'SVX' 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 'SVX' 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 SSX data is like SVX. The first part is identical to SEV, and the
!> second part consists of test matrices with precomputed solutions.
!>
!> line 1:  'SSX' 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 'SSX' 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.
!>
!>-----------------------------------------------------------------------
!>
!> SGG 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 'SGG' for the generalized
!>          eigenvalue problem routines and driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> SGS and SGV input files:
!>
!> line 1:  'SGS' or 'SGV' 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 'SGS' for the generalized
!>          eigenvalue problem routines and driver routines.
!>
!>-----------------------------------------------------------------------
!>
!> SXV input files:
!>
!> line 1:  'SXV' 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.
!>
!>-----------------------------------------------------------------------
!>
!> SGX input files:
!>
!> line 1:  'SGX' 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.
!>
!>-----------------------------------------------------------------------
!>
!> SSB 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 'SSB'.
!>
!>-----------------------------------------------------------------------
!>
!> SBB 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 'SBB'.
!>
!>-----------------------------------------------------------------------
!>
!> SEC 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.
!>
!>-----------------------------------------------------------------------
!>
!> SBL and SBK input files:
!>
!> line 1:  'SBL' in columns 1-3 to test SGEBAL, or 'SBK' in
!>          columns 1-3 to test SGEBAK.
!>
!> The remaining lines consist of specially constructed test cases.
!>
!>-----------------------------------------------------------------------
!>
!> SGL and SGK input files:
!>
!> line 1:  'SGL' in columns 1-3 to test SGGBAL, or 'SGK' in
!>          columns 1-3 to test SGGBAK.
!>
!> 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 SGG.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 1039 of file schkee.F.

◆ schkgg()

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

SCHKGG

Purpose:
!>
!> SCHKGG  checks the nonsymmetric generalized eigenvalue problem
!> routines.
!>                                T          T        T
!> SGGHRD 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
!> SHGEQZ 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
!>
!> STGEVC 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 SCHKGG 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
!>       STGEVC 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
!>       STGEVC 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,
!>          SCHKGG 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, SCHKGG
!>          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 SCHKGG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error is
!>          scaled to be O(1), so THRESH should be a reasonably small
!>          multiple of 1, e.g., 10 or 100.  In particular, it should
!>          not depend on the precision (single vs. double) or the size
!>          of the matrix.  It must be at least zero.
!>
[in]TSTDIF
!>          TSTDIF is LOGICAL
!>          Specifies whether test ratios 13-15 will be computed and
!>          compared with THRESH.
!>          = .FALSE.: Only test ratios 1-12 will be computed and tested.
!>                     Ratios 13-15 will be set to zero.
!>          = .TRUE.:  All the test ratios 1-15 will be computed and
!>                     tested.
!>
[in]THRSHN
!>          THRSHN is REAL
!>          Threshold for reporting eigenvector normalization error.
!>          If the normalization of any eigenvector differs from 1 by
!>          more than THRSHN*ulp, then a special error message will be
!>          printed.  (This is handled separately from the other tests,
!>          since only a compiler or programming error should cause an
!>          error message, at least if THRSHN is at least 5--10.)
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is REAL 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 REAL 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 REAL array, dimension (LDA, max(NN))
!>          The upper Hessenberg matrix computed from A by SGGHRD.
!>
[out]T
!>          T is REAL array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from B by SGGHRD.
!>
[out]S1
!>          S1 is REAL array, dimension (LDA, max(NN))
!>          The Schur (block upper triangular) matrix computed from H by
!>          SHGEQZ when Q and Z are also computed.
!>
[out]S2
!>          S2 is REAL array, dimension (LDA, max(NN))
!>          The Schur (block upper triangular) matrix computed from H by
!>          SHGEQZ when Q and Z are not computed.
!>
[out]P1
!>          P1 is REAL array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from T by SHGEQZ
!>          when Q and Z are also computed.
!>
[out]P2
!>          P2 is REAL array, dimension (LDA, max(NN))
!>          The upper triangular matrix computed from T by SHGEQZ
!>          when Q and Z are not computed.
!>
[out]U
!>          U is REAL array, dimension (LDU, max(NN))
!>          The (left) orthogonal matrix computed by SGGHRD.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of U, V, Q, Z, EVECTL, and EVECTR.  It
!>          must be at least 1 and at least max( NN ).
!>
[out]V
!>          V is REAL array, dimension (LDU, max(NN))
!>          The (right) orthogonal matrix computed by SGGHRD.
!>
[out]Q
!>          Q is REAL array, dimension (LDU, max(NN))
!>          The (left) orthogonal matrix computed by SHGEQZ.
!>
[out]Z
!>          Z is REAL array, dimension (LDU, max(NN))
!>          The (left) orthogonal matrix computed by SHGEQZ.
!>
[out]ALPHR1
!>          ALPHR1 is REAL array, dimension (max(NN))
!>
[out]ALPHI1
!>          ALPHI1 is REAL array, dimension (max(NN))
!>
[out]BETA1
!>          BETA1 is REAL array, dimension (max(NN))
!>
!>          The generalized eigenvalues of (A,B) computed by SHGEQZ
!>          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 REAL array, dimension (max(NN))
!>
[out]ALPHI3
!>          ALPHI3 is REAL array, dimension (max(NN))
!>
[out]BETA3
!>          BETA3 is REAL array, dimension (max(NN))
!>
[out]EVECTL
!>          EVECTL is REAL array, dimension (LDU, max(NN))
!>          The (block lower triangular) left eigenvector matrix for
!>          the matrices in S1 and P1.  (See STGEVC for the format.)
!>
[out]EVECTR
!>          EVECTR is REAL array, dimension (LDU, max(NN))
!>          The (block upper triangular) right eigenvector matrix for
!>          the matrices in S1 and P1.  (See STGEVC for the format.)
!>
[out]WORK
!>          WORK is REAL 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 REAL array, dimension (15)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  A routine returned an error code.  INFO is the
!>                absolute value of the INFO value returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 506 of file schkgg.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 REAL THRESH, THRSHN
520* ..
521* .. Array Arguments ..
522 LOGICAL DOTYPE( * ), LLWORK( * )
523 INTEGER ISEED( 4 ), NN( * )
524 REAL 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 REAL ZERO, ONE
538 parameter( zero = 0.0, one = 1.0 )
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 REAL 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 REAL DUMMA( 4 ), RMAGN( 0: 3 )
558* ..
559* .. External Functions ..
560 REAL SLAMCH, SLANGE, SLARND
561 EXTERNAL slamch, slange, slarnd
562* ..
563* .. External Subroutines ..
564 EXTERNAL sgeqr2, sget51, sget52, sgghrd, shgeqz, slabad,
565 $ slacpy, slarfg, slaset, slasum, slatm4, sorm2r,
566 $ stgevc, xerbla
567* ..
568* .. Intrinsic Functions ..
569 INTRINSIC abs, max, min, real, 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( 'SCHKGG', -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 = slamch( 'Safe minimum' )
641 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
642 safmin = safmin / ulp
643 safmax = one / safmin
644 CALL slabad( 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 / real( 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* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
693* =3 means random.
694* KATYPE: the "type" to be passed to SLATM4 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 slaset( 'Full', n, n, zero, zero, a, lda )
722 ELSE
723 in = n
724 END IF
725 CALL slatm4( 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 slaset( 'Full', n, n, zero, zero, b, lda )
740 ELSE
741 in = n
742 END IF
743 CALL slatm4( 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 ) = slarnd( 3, iseed )
762 v( jr, jc ) = slarnd( 3, iseed )
763 40 CONTINUE
764 CALL slarfg( 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 slarfg( 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, slarnd( 2, iseed ) )
776 v( n, n ) = one
777 work( 2*n ) = zero
778 work( 4*n ) = sign( one, slarnd( 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 sorm2r( '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 sorm2r( '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 sorm2r( '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 sorm2r( '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 $ slarnd( 2, iseed )
815 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
816 $ slarnd( 2, iseed )
817 80 CONTINUE
818 90 CONTINUE
819 END IF
820*
821 anorm = slange( '1', n, n, a, lda, work )
822 bnorm = slange( '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 SGEQR2, SORM2R, and SGGHRD to compute H, T, U, and V
836*
837 CALL slacpy( ' ', n, n, a, lda, h, lda )
838 CALL slacpy( ' ', n, n, b, lda, t, lda )
839 ntest = 1
840 result( 1 ) = ulpinv
841*
842 CALL sgeqr2( n, n, t, lda, work, work( n+1 ), iinfo )
843 IF( iinfo.NE.0 ) THEN
844 WRITE( nounit, fmt = 9999 )'SGEQR2', iinfo, n, jtype,
845 $ ioldsd
846 info = abs( iinfo )
847 GO TO 210
848 END IF
849*
850 CALL sorm2r( '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 )'SORM2R', iinfo, n, jtype,
854 $ ioldsd
855 info = abs( iinfo )
856 GO TO 210
857 END IF
858*
859 CALL slaset( 'Full', n, n, zero, one, u, ldu )
860 CALL sorm2r( '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 )'SORM2R', iinfo, n, jtype,
864 $ ioldsd
865 info = abs( iinfo )
866 GO TO 210
867 END IF
868*
869 CALL sgghrd( '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 )'SGGHRD', 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 sget51( 1, n, a, lda, h, lda, u, ldu, v, ldu, work,
882 $ result( 1 ) )
883 CALL sget51( 1, n, b, lda, t, lda, u, ldu, v, ldu, work,
884 $ result( 2 ) )
885 CALL sget51( 3, n, b, lda, t, lda, u, ldu, u, ldu, work,
886 $ result( 3 ) )
887 CALL sget51( 3, n, b, lda, t, lda, v, ldu, v, ldu, work,
888 $ result( 4 ) )
889*
890* Call SHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests.
891*
892* Compute T1 and UZ
893*
894* Eigenvalues only
895*
896 CALL slacpy( ' ', n, n, h, lda, s2, lda )
897 CALL slacpy( ' ', n, n, t, lda, p2, lda )
898 ntest = 5
899 result( 5 ) = ulpinv
900*
901 CALL shgeqz( '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 )'SHGEQZ(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 slacpy( ' ', n, n, h, lda, s2, lda )
914 CALL slacpy( ' ', n, n, t, lda, p2, lda )
915*
916 CALL shgeqz( '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 )'SHGEQZ(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 slacpy( ' ', n, n, h, lda, s1, lda )
929 CALL slacpy( ' ', n, n, t, lda, p1, lda )
930*
931 CALL shgeqz( '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 )'SHGEQZ(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 sget51( 1, n, h, lda, s1, lda, q, ldu, z, ldu, work,
946 $ result( 5 ) )
947 CALL sget51( 1, n, t, lda, p1, lda, q, ldu, z, ldu, work,
948 $ result( 6 ) )
949 CALL sget51( 3, n, t, lda, p1, lda, q, ldu, q, ldu, work,
950 $ result( 7 ) )
951 CALL sget51( 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 stgevc( '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 )'STGEVC(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 stgevc( '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 )'STGEVC(L,S2)', iinfo, n,
995 $ jtype, ioldsd
996 info = abs( iinfo )
997 GO TO 210
998 END IF
999*
1000 CALL sget52( .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', 'STGEVC(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 slacpy( 'F', n, n, q, ldu, evectl, ldu )
1014 CALL stgevc( '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 )'STGEVC(L,B)', iinfo, n,
1018 $ jtype, ioldsd
1019 info = abs( iinfo )
1020 GO TO 210
1021 END IF
1022*
1023 CALL sget52( .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', 'STGEVC(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 stgevc( '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 )'STGEVC(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 stgevc( '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 )'STGEVC(R,S2)', iinfo, n,
1070 $ jtype, ioldsd
1071 info = abs( iinfo )
1072 GO TO 210
1073 END IF
1074*
1075 CALL sget52( .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', 'STGEVC(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 slacpy( 'F', n, n, z, ldu, evectr, ldu )
1089 CALL stgevc( '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 )'STGEVC(R,B)', iinfo, n,
1093 $ jtype, ioldsd
1094 info = abs( iinfo )
1095 GO TO 210
1096 END IF
1097*
1098 CALL sget52( .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', 'STGEVC(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 sget51( 2, n, s1, lda, s2, lda, q, ldu, z, ldu,
1113 $ work, result( 13 ) )
1114 CALL sget51( 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 )'SGG'
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.0 ) THEN
1169 WRITE( nounit, fmt = 9992 )n, jtype, ioldsd, jr,
1170 $ result( jr )
1171 ELSE
1172 WRITE( nounit, fmt = 9991 )n, jtype, ioldsd, jr,
1173 $ result( jr )
1174 END IF
1175 END IF
1176 220 CONTINUE
1177*
1178 230 CONTINUE
1179 240 CONTINUE
1180*
1181* Summary
1182*
1183 CALL slasum( 'SGG', nounit, nerrs, ntestt )
1184 RETURN
1185*
1186 9999 FORMAT( ' SCHKGG: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1187 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1188*
1189 9998 FORMAT( ' SCHKGG: ', 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 SCHKGG for details): ' )
1197*
1198 9995 FORMAT( ' Special Matrices:', 23x,
1199 $ '(J''=transposed Jordan block)',
1200 $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
1201 $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
1202 $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
1203 $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
1204 $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
1205 $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
1206 9994 FORMAT( ' Matrices Rotated by Random ', a, ' Matrices U, V:',
1207 $ / ' 16=Transposed Jordan Blocks 19=geometric ',
1208 $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
1209 $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
1210 $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
1211 $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
1212 $ '23=(small,large) 24=(small,small) 25=(large,large)',
1213 $ / ' 26=random O(1) matrices.' )
1214*
1215 9993 FORMAT( / ' Tests performed: (H is Hessenberg, S is Schur, B, ',
1216 $ 'T, P are triangular,', / 20x, 'U, V, Q, and Z are ', a,
1217 $ ', l and r are the', / 20x,
1218 $ 'appropriate left and right eigenvectors, resp., a is',
1219 $ / 20x, 'alpha, b is beta, and ', a, ' means ', a, '.)',
1220 $ / ' 1 = | A - U H V', a,
1221 $ ' | / ( |A| n ulp ) 2 = | B - U T V', a,
1222 $ ' | / ( |B| n ulp )', / ' 3 = | I - UU', a,
1223 $ ' | / ( n ulp ) 4 = | I - VV', a,
1224 $ ' | / ( n ulp )', / ' 5 = | H - Q S Z', a,
1225 $ ' | / ( |H| n ulp )', 6x, '6 = | T - Q P Z', a,
1226 $ ' | / ( |T| n ulp )', / ' 7 = | I - QQ', a,
1227 $ ' | / ( n ulp ) 8 = | I - ZZ', a,
1228 $ ' | / ( n ulp )', / ' 9 = max | ( b S - a P )', a,
1229 $ ' l | / const. 10 = max | ( b H - a T )', a,
1230 $ ' l | / const.', /
1231 $ ' 11= max | ( b S - a P ) r | / const. 12 = max | ( b H',
1232 $ ' - a T ) r | / const.', / 1x )
1233*
1234 9992 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
1235 $ 4( i4, ',' ), ' result ', i2, ' is', 0p, f8.2 )
1236 9991 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
1237 $ 4( i4, ',' ), ' result ', i2, ' is', 1p, e10.3 )
1238*
1239* End of SCHKGG
1240*
stgevc
subroutine stgevc(side, howmny, select, n, s, lds, p, ldp, vl, ldvl, vr, ldvr, mm, m, work, info)
STGEVC
Definition stgevc.f:295
shgeqz
subroutine shgeqz(job, compq, compz, n, ilo, ihi, h, ldh, t, ldt, alphar, alphai, beta, q, ldq, z, ldz, work, lwork, info)
SHGEQZ
Definition shgeqz.f:304
sgeqr2
subroutine sgeqr2(m, n, a, lda, tau, work, info)
SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition sgeqr2.f:130
slarfg
subroutine slarfg(n, alpha, x, incx, tau)
SLARFG generates an elementary reflector (Householder matrix).
Definition slarfg.f:106
sgghrd
subroutine sgghrd(compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, info)
SGGHRD
Definition sgghrd.f:207
sorm2r
subroutine sorm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
SORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sge...
Definition sorm2r.f:159
slatm4
subroutine slatm4(itype, n, nz1, nz2, isign, amagn, rcond, triang, idist, iseed, a, lda)
SLATM4
Definition slatm4.f:175
sget51
subroutine sget51(itype, n, a, lda, b, ldb, u, ldu, v, ldv, work, result)
SGET51
Definition sget51.f:149
sget52
subroutine sget52(left, n, a, lda, b, ldb, e, lde, alphar, alphai, beta, work, result)
SGET52
Definition sget52.f:199
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ schkgk()

subroutine schkgk ( integer nin,
integer nout )

SCHKGK

Purpose:
!>
!> SCHKGK tests SGGBAK, 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 schkgk.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 REAL ZERO, ONE
71 parameter( zero = 0.0e+0, one = 1.0e+0 )
72* ..
73* .. Local Scalars ..
74 INTEGER I, IHI, ILO, INFO, J, KNT, M, N, NINFO
75 REAL ANORM, BNORM, EPS, RMAX, VMAX
76* ..
77* .. Local Arrays ..
78 INTEGER LMAX( 4 )
79 REAL 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 REAL SLAMCH, SLANGE
87 EXTERNAL slamch, slange
88* ..
89* .. External Subroutines ..
90 EXTERNAL sgemm, sggbak, sggbal, slacpy
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 = slamch( '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 = slange( 'M', n, n, a, lda, work )
133 bnorm = slange( 'M', n, n, b, ldb, work )
134*
135 CALL slacpy( 'FULL', n, n, a, lda, af, lda )
136 CALL slacpy( 'FULL', n, n, b, ldb, bf, ldb )
137*
138 CALL sggbal( '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 slacpy( 'FULL', n, m, vl, ldvl, vlf, ldvl )
146 CALL slacpy( 'FULL', n, m, vr, ldvr, vrf, ldvr )
147*
148 CALL sggbak( '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 sggbak( '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 SGGBAK
163*
164* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
165* where tilde(A) denotes the transformed matrix.
166*
167 CALL sgemm( 'N', 'N', n, m, n, one, af, lda, vr, ldvr, zero, work,
168 $ ldwork )
169 CALL sgemm( 'T', 'N', m, m, n, one, vl, ldvl, work, ldwork, zero,
170 $ e, lde )
171*
172 CALL sgemm( 'N', 'N', n, m, n, one, a, lda, vrf, ldvr, zero, work,
173 $ ldwork )
174 CALL sgemm( '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 sgemm( 'N', 'N', n, m, n, one, bf, ldb, vr, ldvr, zero, work,
192 $ ldwork )
193 CALL sgemm( 'T', 'N', m, m, n, one, vl, ldvl, work, ldwork, zero,
194 $ e, lde )
195*
196 CALL sgemm( 'N', 'N', n, m, n, one, b, ldb, vrf, ldvr, zero, work,
197 $ ldwork )
198 CALL sgemm( '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 SGGBAK .. ' )
219*
220 WRITE( nout, fmt = 9998 )rmax
221 9998 FORMAT( ' value of largest test error =', e12.3 )
222 WRITE( nout, fmt = 9997 )lmax( 1 )
223 9997 FORMAT( ' example number where SGGBAL info is not 0 =', i4 )
224 WRITE( nout, fmt = 9996 )lmax( 2 )
225 9996 FORMAT( ' example number where SGGBAK(L) info is not 0 =', i4 )
226 WRITE( nout, fmt = 9995 )lmax( 3 )
227 9995 FORMAT( ' example number where SGGBAK(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 = 9992 )ninfo
231 9992 FORMAT( ' number of examples where info is not 0 =', i4 )
232 WRITE( nout, fmt = 9991 )knt
233 9991 FORMAT( ' total number of examples tested =', i4 )
234*
235 RETURN
236*
237* End of SCHKGK
238*
sggbak
subroutine sggbak(job, side, n, ilo, ihi, lscale, rscale, m, v, ldv, info)
SGGBAK
Definition sggbak.f:147
sggbal
subroutine sggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, work, info)
SGGBAL
Definition sggbal.f:177

◆ schkgl()

subroutine schkgl ( integer nin,
integer nout )

SCHKGL

Purpose:
!>
!> SCHKGL tests SGGBAL, 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 schkgl.f.

53*
54* -- LAPACK test routine --
55* -- LAPACK is a software package provided by Univ. of Tennessee, --
56* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
57*
58* .. Scalar Arguments ..
59 INTEGER NIN, NOUT
60* ..
61*
62* =====================================================================
63*
64* .. Parameters ..
65 INTEGER LDA, LDB, LWORK
66 parameter( lda = 20, ldb = 20, lwork = 6*lda )
67 REAL ZERO
68 parameter( zero = 0.0e+0 )
69* ..
70* .. Local Scalars ..
71 INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
72 $ NINFO
73 REAL ANORM, BNORM, EPS, RMAX, VMAX
74* ..
75* .. Local Arrays ..
76 INTEGER LMAX( 5 )
77 REAL 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 REAL SLAMCH, SLANGE
83 EXTERNAL slamch, slange
84* ..
85* .. External Subroutines ..
86 EXTERNAL sggbal
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 = slamch( '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 = slange( 'M', n, n, a, lda, work )
127 bnorm = slange( 'M', n, n, b, ldb, work )
128*
129 knt = knt + 1
130*
131 CALL sggbal( '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 SGGBAL .. ' )
170*
171 WRITE( nout, fmt = 9998 )rmax
172 9998 FORMAT( 1x, 'value of largest test error = ', e12.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 SCHKGL
187*

◆ schkhs()

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

SCHKHS

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

Definition at line 407 of file schkhs.f.

412*
413* -- LAPACK test routine --
414* -- LAPACK is a software package provided by Univ. of Tennessee, --
415* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
416*
417* .. Scalar Arguments ..
418 INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK
419 REAL THRESH
420* ..
421* .. Array Arguments ..
422 LOGICAL DOTYPE( * ), SELECT( * )
423 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
424 REAL 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 REAL ZERO, ONE
437 parameter( zero = 0.0, one = 1.0 )
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 REAL 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 REAL DUMMA( 6 )
455* ..
456* .. External Functions ..
457 REAL SLAMCH
458 EXTERNAL slamch
459* ..
460* .. External Subroutines ..
461 EXTERNAL scopy, sgehrd, sgemm, sget10, sget22, shsein,
462 $ shseqr, shst01, slabad, slacpy, slafts, slaset,
463 $ slasum, slatme, slatmr, slatms, sorghr, sormhr,
464 $ strevc, xerbla
465* ..
466* .. Intrinsic Functions ..
467 INTRINSIC abs, max, min, real, 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( 'SCHKHS', -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 = slamch( 'Safe minimum' )
523 ovfl = slamch( 'Overflow' )
524 CALL slabad( unfl, ovfl )
525 ulp = slamch( 'Epsilon' )*slamch( '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 / real( 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 slaset( '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 slatms( 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 slatms( 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 slatme( 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 slatmr( 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 slatmr( 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 slatmr( 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 slatmr( 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 SGEHRD to compute H and U, do tests.
723*
724 CALL slacpy( ' ', n, n, a, lda, h, lda )
725*
726 ntest = 1
727*
728 ilo = 1
729 ihi = n
730*
731 CALL sgehrd( 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 )'SGEHRD', 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 scopy( n-1, work, 1, tau, 1 )
751 CALL sorghr( n, ilo, ihi, u, ldu, work, work( n+1 ),
752 $ nwork-n, iinfo )
753 ntest = 2
754*
755 CALL shst01( n, ilo, ihi, a, lda, h, lda, u, ldu, work,
756 $ nwork, result( 1 ) )
757*
758* Call SHSEQR to compute T1, T2 and Z, do tests.
759*
760* Eigenvalues only (WR3,WI3)
761*
762 CALL slacpy( ' ', n, n, h, lda, t2, lda )
763 ntest = 3
764 result( 3 ) = ulpinv
765*
766 CALL shseqr( '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 )'SHSEQR(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 slacpy( ' ', n, n, h, lda, t2, lda )
780*
781 CALL shseqr( '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 )'SHSEQR(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 slacpy( ' ', n, n, h, lda, t1, lda )
794 CALL slacpy( ' ', n, n, u, ldu, uz, ldu )
795*
796 CALL shseqr( '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 )'SHSEQR(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 sgemm( '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 shst01( 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 shst01( 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 sget10( 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 strevc( '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 )'STREVC(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 sget22( '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', 'STREVC',
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 strevc( '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 )'STREVC(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', 'STREVC', n, jtype,
931 $ ioldsd
932*
933* Compute the Left eigenvector Matrix:
934*
935 ntest = 10
936 result( 10 ) = ulpinv
937 CALL strevc( '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 )'STREVC(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 sget22( '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', 'STREVC', 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 strevc( '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 )'STREVC(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', 'STREVC', n, jtype,
993 $ ioldsd
994*
995* Call SHSEIN 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 shsein( '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 )'SHSEIN(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 sget22( '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', 'SHSEIN',
1024 $ dumma( 2 ), n, jtype, ioldsd
1025 END IF
1026 END IF
1027*
1028* Call SHSEIN 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 shsein( '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 )'SHSEIN(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 sget22( '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', 'SHSEIN',
1057 $ dumma( 4 ), n, jtype, ioldsd
1058 END IF
1059 END IF
1060*
1061* Call SORMHR for Right eigenvectors of A, do test 13
1062*
1063 ntest = 13
1064 result( 13 ) = ulpinv
1065*
1066 CALL sormhr( '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 )'SORMHR(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 sget22( '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 SORMHR for Left eigenvectors of A, do test 14
1087*
1088 ntest = 14
1089 result( 14 ) = ulpinv
1090*
1091 CALL sormhr( '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 )'SORMHR(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 sget22( '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 slafts( 'SHS', n, n, jtype, ntest, result, ioldsd,
1117 $ thresh, nounit, nerrs )
1118*
1119 260 CONTINUE
1120 270 CONTINUE
1121*
1122* Summary
1123*
1124 CALL slasum( 'SHS', nounit, nerrs, ntestt )
1125*
1126 RETURN
1127*
1128 9999 FORMAT( ' SCHKHS: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1129 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1130 9998 FORMAT( ' SCHKHS: ', 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( ' SCHKHS: 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 SCHKHS
1139*
sgehrd
subroutine sgehrd(n, ilo, ihi, a, lda, tau, work, lwork, info)
SGEHRD
Definition sgehrd.f:167
shseqr
subroutine shseqr(job, compz, n, ilo, ihi, h, ldh, wr, wi, z, ldz, work, lwork, info)
SHSEQR
Definition shseqr.f:316
sormhr
subroutine sormhr(side, trans, m, n, ilo, ihi, a, lda, tau, c, ldc, work, lwork, info)
SORMHR
Definition sormhr.f:179
sorghr
subroutine sorghr(n, ilo, ihi, a, lda, tau, work, lwork, info)
SORGHR
Definition sorghr.f:126
strevc
subroutine strevc(side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, info)
STREVC
Definition strevc.f:222
shsein
subroutine shsein(side, eigsrc, initv, select, n, h, ldh, wr, wi, vl, ldvl, vr, ldvr, mm, m, work, ifaill, ifailr, info)
SHSEIN
Definition shsein.f:263
slatme
subroutine slatme(n, dist, iseed, d, mode, cond, dmax, ei, rsign, upper, sim, ds, modes, conds, kl, ku, anorm, a, lda, work, info)
SLATME
Definition slatme.f:332
sget22
subroutine sget22(transa, transe, transw, n, a, lda, e, lde, wr, wi, work, result)
SGET22
Definition sget22.f:168
sget10
subroutine sget10(m, n, a, lda, b, ldb, work, result)
SGET10
Definition sget10.f:93
shst01
subroutine shst01(n, ilo, ihi, a, lda, h, ldh, q, ldq, work, lwork, result)
SHST01
Definition shst01.f:134
slafts
subroutine slafts(type, m, n, imat, ntests, result, iseed, thresh, iounit, ie)
SLAFTS
Definition slafts.f:99

◆ schksb()

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

SCHKSB

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

Definition at line 290 of file schksb.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 REAL THRESH
302* ..
303* .. Array Arguments ..
304 LOGICAL DOTYPE( * )
305 INTEGER ISEED( 4 ), KK( * ), NN( * )
306 REAL A( LDA, * ), RESULT( * ), SD( * ), SE( * ),
307 $ U( LDU, * ), WORK( * )
308* ..
309*
310* =====================================================================
311*
312* .. Parameters ..
313 REAL ZERO, ONE, TWO, TEN
314 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
315 $ ten = 10.0e0 )
316 REAL 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 REAL 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 REAL SLAMCH
335 EXTERNAL slamch
336* ..
337* .. External Subroutines ..
338 EXTERNAL slacpy, slasum, slatmr, slatms, slaset, ssbt21,
339 $ ssbtrd, xerbla
340* ..
341* .. Intrinsic Functions ..
342 INTRINSIC abs, max, min, real, 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( 'SCHKSB', -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 = slamch( 'Safe minimum' )
410 ovfl = one / unfl
411 ulp = slamch( 'Epsilon' )*slamch( '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 / real( 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 slaset( '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 slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 slatms( 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 slatms( 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 SSBTRD to compute S and U from upper triangle.
587*
588 CALL slacpy( ' ', k+1, n, a, lda, work, lda )
589*
590 ntest = 1
591 CALL ssbtrd( '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 )'SSBTRD(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 ssbt21( '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 SSBTRD to compute S and U from lower triangle
626*
627 CALL slacpy( ' ', k+1, n, a, lda, work, lda )
628*
629 ntest = 3
630 CALL ssbtrd( '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 )'SSBTRD(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 ssbt21( '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 )'SSB'
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 slasum( 'SSB', nounit, nerrs, ntestt )
685 RETURN
686*
687 9999 FORMAT( ' SCHKSB: ', 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 SCHKSB 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 SCHKSB
722*
ssbtrd
subroutine ssbtrd(vect, uplo, n, kd, ab, ldab, d, e, q, ldq, work, info)
SSBTRD
Definition ssbtrd.f:163
ssbt21
subroutine ssbt21(uplo, n, ka, ks, a, lda, d, e, u, ldu, work, result)
SSBT21
Definition ssbt21.f:147

◆ schksb2stg()

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

SCHKSB2STG

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

Definition at line 329 of file schksb2stg.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 REAL THRESH
341* ..
342* .. Array Arguments ..
343 LOGICAL DOTYPE( * )
344 INTEGER ISEED( 4 ), KK( * ), NN( * )
345 REAL A( LDA, * ), RESULT( * ), SD( * ), SE( * ),
346 $ D1( * ), D2( * ), D3( * ),
347 $ U( LDU, * ), WORK( * )
348* ..
349*
350* =====================================================================
351*
352* .. Parameters ..
353 REAL ZERO, ONE, TWO, TEN
354 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
355 $ ten = 10.0e0 )
356 REAL 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 REAL 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 REAL SLAMCH
375 EXTERNAL slamch
376* ..
377* .. External Subroutines ..
378 EXTERNAL slacpy, slaset, slasum, slatmr, slatms, ssbt21,
379 $ ssbtrd, xerbla, ssytrd_sb2st, ssteqr
380* ..
381* .. Intrinsic Functions ..
382 INTRINSIC abs, real, 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( 'SCHKSB2STG', -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 = slamch( 'Safe minimum' )
450 ovfl = one / unfl
451 ulp = slamch( 'Epsilon' )*slamch( '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 / real( 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 slaset( '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 slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 slatms( 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 slatms( 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 SSBTRD to compute S and U from upper triangle.
627*
628 CALL slacpy( ' ', k+1, n, a, lda, work, lda )
629*
630 ntest = 1
631 CALL ssbtrd( '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 )'SSBTRD(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 ssbt21( 'Upper', n, k, 1, a, lda, sd, se, u, ldu,
649 $ work, result( 1 ) )
650*
651* Before converting A into lower for SSBTRD, run SSYTRD_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* ofSSYTRD_SB2ST
655*
656* Compute D1 the eigenvalues resulting from the tridiagonal
657* form using the SSBTRD and used as reference to compare
658* with the SSYTRD_SB2ST routine
659*
660* Compute D1 from the SSBTRD and used as reference for the
661* SSYTRD_SB2ST
662*
663 CALL scopy( n, sd, 1, d1, 1 )
664 IF( n.GT.0 )
665 $ CALL scopy( n-1, se, 1, work, 1 )
666*
667 CALL ssteqr( 'N', n, d1, work, work( n+1 ), ldu,
668 $ work( n+1 ), iinfo )
669 IF( iinfo.NE.0 ) THEN
670 WRITE( nounit, fmt = 9999 )'SSTEQR(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* SSYTRD_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 SSBTRD.
685*
686 CALL slaset( 'Full', n, 1, zero, zero, sd, n )
687 CALL slaset( 'Full', n, 1, zero, zero, se, n )
688 CALL slacpy( ' ', k+1, n, a, lda, u, ldu )
689 lh = max(1, 4*n)
690 lw = lwork - lh
691 CALL ssytrd_sb2st( 'N', 'N', "U", n, k, u, ldu, sd, se,
692 $ work, lh, work( lh+1 ), lw, iinfo )
693*
694* Compute D2 from the SSYTRD_SB2ST Upper case
695*
696 CALL scopy( n, sd, 1, d2, 1 )
697 IF( n.GT.0 )
698 $ CALL scopy( n-1, se, 1, work, 1 )
699*
700 CALL ssteqr( 'N', n, d2, work, work( n+1 ), ldu,
701 $ work( n+1 ), iinfo )
702 IF( iinfo.NE.0 ) THEN
703 WRITE( nounit, fmt = 9999 )'SSTEQR(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 SSBTRD to compute S and U from lower triangle
729*
730 CALL slacpy( ' ', k+1, n, a, lda, work, lda )
731*
732 ntest = 3
733 CALL ssbtrd( '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 )'SSBTRD(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 ssbt21( 'Lower', n, k, 1, a, lda, sd, se, u, ldu,
752 $ work, result( 3 ) )
753*
754* SSYTRD_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 SSBTRD.
758*
759 CALL slaset( 'Full', n, 1, zero, zero, sd, n )
760 CALL slaset( 'Full', n, 1, zero, zero, se, n )
761 CALL slacpy( ' ', k+1, n, a, lda, u, ldu )
762 lh = max(1, 4*n)
763 lw = lwork - lh
764 CALL ssytrd_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 scopy( n, sd, 1, d3, 1 )
770 IF( n.GT.0 )
771 $ CALL scopy( n-1, se, 1, work, 1 )
772*
773 CALL ssteqr( 'N', n, d3, work, work( n+1 ), ldu,
774 $ work( n+1 ), iinfo )
775 IF( iinfo.NE.0 ) THEN
776 WRITE( nounit, fmt = 9999 )'SSTEQR(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 )'SSB'
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 slasum( 'SSB', nounit, nerrs, ntestt )
841 RETURN
842*
843 9999 FORMAT( ' SCHKSB2STG: ', 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 SCHKSB2STG 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 SCHKSB2STG
880*
ssteqr
subroutine ssteqr(compz, n, d, e, z, ldz, work, info)
SSTEQR
Definition ssteqr.f:131
ssytrd_sb2st
subroutine ssytrd_sb2st(stage1, vect, uplo, n, kd, ab, ldab, d, e, hous, lhous, work, lwork, info)
SSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric tridiagonal form T
Definition ssytrd_sb2st.F:230

◆ schkst()

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

SCHKST

Purpose:
!>
!> SCHKST  checks the symmetric eigenvalue problem routines.
!>
!>    SSYTRD factors A as  U S U' , where ' means transpose,
!>    S is symmetric tridiagonal, and U is orthogonal.
!>    SSYTRD can use either just the lower or just the upper triangle
!>    of A; SCHKST 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.
!>
!>    SSPTRD does the same as SSYTRD, except that A and V are stored
!>    in  format.
!>
!>    SORGTR constructs the matrix U from the contents of V and TAU.
!>
!>    SOPGTR constructs the matrix U from the contents of VP and TAU.
!>
!>    SSTEQR 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.
!>
!>    SSTERF computes D3, the matrix of eigenvalues, by the
!>    PWK method, which does not yield eigenvectors.
!>
!>    SPTEQR 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.
!>
!>    SSTEBZ computes selected eigenvalues.  WA1, WA2, and
!>    WA3 will denote eigenvalues computed to high
!>    absolute accuracy, with different range options.
!>    WR will denote eigenvalues computed to high relative
!>    accuracy.
!>
!>    SSTEIN computes Y, the eigenvectors of S, given the
!>    eigenvalues.
!>
!>    SSTEDC 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 SSYTRD/SORGTR or SSPTRD/SOPGTR ('V' option). It may
!>    also just compute eigenvalues ('N' option).
!>
!>    SSTEMR 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).  SSTEMR
!>    uses the Relatively Robust Representation whenever possible.
!>
!> When SCHKST 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 ) SSYTRD( UPLO='U', ... )
!>
!> (2)     | I - UV' | / ( n ulp )        SORGTR( UPLO='U', ... )
!>
!> (3)     | A - V S V' | / ( |A| n ulp ) SSYTRD( UPLO='L', ... )
!>
!> (4)     | I - UV' | / ( n ulp )        SORGTR( UPLO='L', ... )
!>
!> (5-8)   Same as 1-4, but for SSPTRD and SOPGTR.
!>
!> (9)     | S - Z D Z' | / ( |S| n ulp ) SSTEQR('V',...)
!>
!> (10)    | I - ZZ' | / ( n ulp )        SSTEQR('V',...)
!>
!> (11)    | D1 - D2 | / ( |D1| ulp )        SSTEQR('N',...)
!>
!> (12)    | D1 - D3 | / ( |D1| ulp )        SSTERF
!>
!> (13)    0 if the true eigenvalues (computed by sturm count)
!>         of S are within THRESH of
!>         those in D1.  2*THRESH if they are not.  (Tested using
!>         SSTECH)
!>
!> For S positive definite,
!>
!> (14)    | S - Z4 D4 Z4' | / ( |S| n ulp ) SPTEQR('V',...)
!>
!> (15)    | I - Z4 Z4' | / ( n ulp )        SPTEQR('V',...)
!>
!> (16)    | D4 - D5 | / ( 100 |D4| ulp )       SPTEQR('N',...)
!>
!> When S is also diagonally dominant by the factor gamma < 1,
!>
!> (17)    max | D4(i) - WR(i) | / ( |D4(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              SSTEBZ( 'A', 'E', ...)
!>
!> (18)    | WA1 - D3 | / ( |D3| ulp )          SSTEBZ( 'A', 'E', ...)
!>
!> (19)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>                                              SSTEBZ( 'I', 'E', ...)
!>
!> (20)    | S - Y WA1 Y' | / ( |S| n ulp )  SSTEBZ, SSTEIN
!>
!> (21)    | I - Y Y' | / ( n ulp )          SSTEBZ, SSTEIN
!>
!> (22)    | S - Z D Z' | / ( |S| n ulp )    SSTEDC('I')
!>
!> (23)    | I - ZZ' | / ( n ulp )           SSTEDC('I')
!>
!> (24)    | S - Z D Z' | / ( |S| n ulp )    SSTEDC('V')
!>
!> (25)    | I - ZZ' | / ( n ulp )           SSTEDC('V')
!>
!> (26)    | D1 - D2 | / ( |D1| ulp )           SSTEDC('V') and
!>                                              SSTEDC('N')
!>
!> Test 27 is disabled at the moment because SSTEMR 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
!>                                              SSTEMR('V', 'A')
!>
!> (28)    max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              SSTEMR('V', 'I')
!>
!> Tests 29 through 34 are disable at present because SSTEMR
!> does not handle partial spectrum requests.
!>
!> (29)    | S - Z D Z' | / ( |S| n ulp )    SSTEMR('V', 'I')
!>
!> (30)    | I - ZZ' | / ( n ulp )           SSTEMR('V', 'I')
!>
!> (31)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         SSTEMR('N', 'I') vs. SSTEMR('V', 'I')
!>
!> (32)    | S - Z D Z' | / ( |S| n ulp )    SSTEMR('V', 'V')
!>
!> (33)    | I - ZZ' | / ( n ulp )           SSTEMR('V', 'V')
!>
!> (34)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         SSTEMR('N', 'V') vs. SSTEMR('V', 'V')
!>
!> (35)    | S - Z D Z' | / ( |S| n ulp )    SSTEMR('V', 'A')
!>
!> (36)    | I - ZZ' | / ( n ulp )           SSTEMR('V', 'A')
!>
!> (37)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         SSTEMR('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,
!>          SCHKST 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, SCHKST
!>          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 SCHKST to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is REAL array 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 REAL array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix A stored in packed format.
!>
[out]SD
!>          SD is REAL array of
!>                             dimension( max(NN) )
!>          The diagonal of the tridiagonal matrix computed by SSYTRD.
!>          On exit, SD and SE contain the tridiagonal form of the
!>          matrix in A.
!>
[out]SE
!>          SE is REAL array of
!>                             dimension( max(NN) )
!>          The off-diagonal of the tridiagonal matrix computed by
!>          SSYTRD.  On exit, SD and SE contain the tridiagonal form of
!>          the matrix in A.
!>
[out]D1
!>          D1 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>
[out]D2
!>          D2 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>
[out]D3
!>          D3 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>
[out]D4
!>          D4 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SPTEQR(V).
!>          ZPTEQR factors S as  Z4 D4 Z4*
!>          On exit, the eigenvalues in D4 correspond with the matrix in A.
!>
[out]D5
!>          D5 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SPTEQR(N)
!>          when Z is not computed. On exit, the
!>          eigenvalues in D4 correspond with the matrix in A.
!>
[out]WA1
!>          WA1 is REAL array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>
[out]WA2
!>          WA2 is REAL array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>          Choose random values for IL and IU, and ask for the
!>          IL-th through IU-th eigenvalues.
!>
[out]WA3
!>          WA3 is REAL array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>          Determine the values VL and VU of the IL-th and IU-th
!>          eigenvalues and ask for all eigenvalues in this range.
!>
[out]WR
!>          WR is REAL array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different options.
!>          as computed by SSTEBZ.
!>
[out]U
!>          U is REAL array of
!>                             dimension( LDU, max(NN) ).
!>          The orthogonal matrix computed by SSYTRD + SORGTR.
!>
[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 REAL array of
!>                             dimension( LDU, max(NN) ).
!>          The Housholder vectors computed by SSYTRD 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 SSYTRD, 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 SORGTR, set those entries to
!>          1 before using them, and then restore them later.)
!>
[out]VP
!>          VP is REAL array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix V stored in packed format.
!>
[out]TAU
!>          TAU is REAL array of
!>                             dimension( max(NN) )
!>          The Householder factors computed by SSYTRD in reducing A
!>          to tridiagonal form.
!>
[out]Z
!>          Z is REAL array of
!>                             dimension( LDU, max(NN) ).
!>          The orthogonal matrix of eigenvectors computed by SSTEQR,
!>          SPTEQR, and SSTEIN.
!>
[out]WORK
!>          WORK is REAL 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 REAL array, dimension (26)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -23: LDU < 1 or LDU < NMAX.
!>          -29: LWORK too small.
!>          If  SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF,
!>              or SORMC2 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 schkst.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 REAL THRESH
600* ..
601* .. Array Arguments ..
602 LOGICAL DOTYPE( * )
603 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
604 REAL 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 REAL ZERO, ONE, TWO, EIGHT, TEN, HUN
615 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
616 $ eight = 8.0e0, ten = 10.0e0, hun = 100.0e0 )
617 REAL 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 REAL 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 REAL DUMMA( 1 )
641* ..
642* .. External Functions ..
643 INTEGER ILAENV
644 REAL SLAMCH, SLARND, SSXT1
645 EXTERNAL ilaenv, slamch, slarnd, ssxt1
646* ..
647* .. External Subroutines ..
648 EXTERNAL scopy, slabad, slacpy, slaset, slasum, slatmr,
649 $ slatms, sopgtr, sorgtr, spteqr, sspt21, ssptrd,
650 $ sstebz, sstech, sstedc, sstemr, sstein, ssteqr,
651 $ ssterf, sstt21, sstt22, ssyt21, ssytrd, xerbla
652* ..
653* .. Intrinsic Functions ..
654 INTRINSIC abs, int, log, max, min, real, 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, 'SSYTRD', '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( 'SCHKST', -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 = slamch( 'Safe minimum' )
717 ovfl = one / unfl
718 CALL slabad( unfl, ovfl )
719 ulp = slamch( 'Epsilon' )*slamch( '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( real( 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 / real( 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 slaset( '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 slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 slatms( 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 slatms( 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 SSYTRD and SORGTR to compute S and U from
904* upper triangle.
905*
906 CALL slacpy( 'U', n, n, a, lda, v, ldu )
907*
908 ntest = 1
909 CALL ssytrd( 'U', n, v, ldu, sd, se, tau, work, lwork,
910 $ iinfo )
911*
912 IF( iinfo.NE.0 ) THEN
913 WRITE( nounit, fmt = 9999 )'SSYTRD(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 slacpy( 'U', n, n, v, ldu, u, ldu )
925*
926 ntest = 2
927 CALL sorgtr( 'U', n, u, ldu, tau, work, lwork, iinfo )
928 IF( iinfo.NE.0 ) THEN
929 WRITE( nounit, fmt = 9999 )'SORGTR(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 ssyt21( 2, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
943 $ ldu, tau, work, result( 1 ) )
944 CALL ssyt21( 3, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
945 $ ldu, tau, work, result( 2 ) )
946*
947* Call SSYTRD and SORGTR to compute S and U from
948* lower triangle, do tests.
949*
950 CALL slacpy( 'L', n, n, a, lda, v, ldu )
951*
952 ntest = 3
953 CALL ssytrd( 'L', n, v, ldu, sd, se, tau, work, lwork,
954 $ iinfo )
955*
956 IF( iinfo.NE.0 ) THEN
957 WRITE( nounit, fmt = 9999 )'SSYTRD(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 slacpy( 'L', n, n, v, ldu, u, ldu )
969*
970 ntest = 4
971 CALL sorgtr( 'L', n, u, ldu, tau, work, lwork, iinfo )
972 IF( iinfo.NE.0 ) THEN
973 WRITE( nounit, fmt = 9999 )'SORGTR(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 ssyt21( 2, 'Lower', n, 1, a, lda, sd, se, u, ldu, v,
985 $ ldu, tau, work, result( 3 ) )
986 CALL ssyt21( 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 SSPTRD and SOPGTR to compute S and U from AP
1000*
1001 CALL scopy( nap, ap, 1, vp, 1 )
1002*
1003 ntest = 5
1004 CALL ssptrd( 'U', n, vp, sd, se, tau, iinfo )
1005*
1006 IF( iinfo.NE.0 ) THEN
1007 WRITE( nounit, fmt = 9999 )'SSPTRD(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 sopgtr( 'U', n, vp, tau, u, ldu, work, iinfo )
1020 IF( iinfo.NE.0 ) THEN
1021 WRITE( nounit, fmt = 9999 )'SOPGTR(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 sspt21( 2, 'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1035 $ work, result( 5 ) )
1036 CALL sspt21( 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 SSPTRD and SOPGTR to compute S and U from AP
1050*
1051 CALL scopy( nap, ap, 1, vp, 1 )
1052*
1053 ntest = 7
1054 CALL ssptrd( 'L', n, vp, sd, se, tau, iinfo )
1055*
1056 IF( iinfo.NE.0 ) THEN
1057 WRITE( nounit, fmt = 9999 )'SSPTRD(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 sopgtr( 'L', n, vp, tau, u, ldu, work, iinfo )
1070 IF( iinfo.NE.0 ) THEN
1071 WRITE( nounit, fmt = 9999 )'SOPGTR(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 sspt21( 2, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1083 $ work, result( 7 ) )
1084 CALL sspt21( 3, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1085 $ work, result( 8 ) )
1086*
1087* Call SSTEQR to compute D1, D2, and Z, do tests.
1088*
1089* Compute D1 and Z
1090*
1091 CALL scopy( n, sd, 1, d1, 1 )
1092 IF( n.GT.0 )
1093 $ CALL scopy( n-1, se, 1, work, 1 )
1094 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1095*
1096 ntest = 9
1097 CALL ssteqr( 'V', n, d1, work, z, ldu, work( n+1 ), iinfo )
1098 IF( iinfo.NE.0 ) THEN
1099 WRITE( nounit, fmt = 9999 )'SSTEQR(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 scopy( n, sd, 1, d2, 1 )
1113 IF( n.GT.0 )
1114 $ CALL scopy( n-1, se, 1, work, 1 )
1115*
1116 ntest = 11
1117 CALL ssteqr( 'N', n, d2, work, work( n+1 ), ldu,
1118 $ work( n+1 ), iinfo )
1119 IF( iinfo.NE.0 ) THEN
1120 WRITE( nounit, fmt = 9999 )'SSTEQR(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 scopy( n, sd, 1, d3, 1 )
1134 IF( n.GT.0 )
1135 $ CALL scopy( n-1, se, 1, work, 1 )
1136*
1137 ntest = 12
1138 CALL ssterf( n, d3, work, iinfo )
1139 IF( iinfo.NE.0 ) THEN
1140 WRITE( nounit, fmt = 9999 )'SSTERF', 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 sstt21( 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 sstech( 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 SPTEQR
1190* and do tests 14, 15, and 16 .
1191*
1192 IF( jtype.GT.15 ) THEN
1193*
1194* Compute D4 and Z4
1195*
1196 CALL scopy( n, sd, 1, d4, 1 )
1197 IF( n.GT.0 )
1198 $ CALL scopy( n-1, se, 1, work, 1 )
1199 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1200*
1201 ntest = 14
1202 CALL spteqr( 'V', n, d4, work, z, ldu, work( n+1 ),
1203 $ iinfo )
1204 IF( iinfo.NE.0 ) THEN
1205 WRITE( nounit, fmt = 9999 )'SPTEQR(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 sstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1219 $ result( 14 ) )
1220*
1221* Compute D5
1222*
1223 CALL scopy( n, sd, 1, d5, 1 )
1224 IF( n.GT.0 )
1225 $ CALL scopy( n-1, se, 1, work, 1 )
1226*
1227 ntest = 16
1228 CALL spteqr( 'N', n, d5, work, z, ldu, work( n+1 ),
1229 $ iinfo )
1230 IF( iinfo.NE.0 ) THEN
1231 WRITE( nounit, fmt = 9999 )'SPTEQR(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 SSTEBZ 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 sstebz( '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 )'SSTEBZ(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 sstebz( '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 )'SSTEBZ(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( slarnd( 1, iseed2 ) )
1341 iu = 1 + ( n-1 )*int( slarnd( 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 sstebz( '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 )'SSTEBZ(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 sstebz( '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 )'SSTEBZ(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1410 temp2 = ssxt1( 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 SSTEIN to compute eigenvectors corresponding to
1420* eigenvalues in WA1. (First call SSTEBZ again, to make sure
1421* it returns these eigenvalues in the correct order.)
1422*
1423 ntest = 21
1424 CALL sstebz( '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 )'SSTEBZ(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 sstein( 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 )'SSTEIN', 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 sstt21( n, 0, sd, se, wa1, dumma, z, ldu, work,
1459 $ result( 20 ) )
1460*
1461* Call SSTEDC(I) to compute D1 and Z, do tests.
1462*
1463* Compute D1 and Z
1464*
1465 CALL scopy( n, sd, 1, d1, 1 )
1466 IF( n.GT.0 )
1467 $ CALL scopy( n-1, se, 1, work, 1 )
1468 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1469*
1470 ntest = 22
1471 CALL sstedc( '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 )'SSTEDC(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 sstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1488 $ result( 22 ) )
1489*
1490* Call SSTEDC(V) to compute D1 and Z, do tests.
1491*
1492* Compute D1 and Z
1493*
1494 CALL scopy( n, sd, 1, d1, 1 )
1495 IF( n.GT.0 )
1496 $ CALL scopy( n-1, se, 1, work, 1 )
1497 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1498*
1499 ntest = 24
1500 CALL sstedc( '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 )'SSTEDC(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 sstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1517 $ result( 24 ) )
1518*
1519* Call SSTEDC(N) to compute D2, do tests.
1520*
1521* Compute D2
1522*
1523 CALL scopy( n, sd, 1, d2, 1 )
1524 IF( n.GT.0 )
1525 $ CALL scopy( n-1, se, 1, work, 1 )
1526 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1527*
1528 ntest = 26
1529 CALL sstedc( '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 )'SSTEDC(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 SSTEMR if IEEE compliant
1556*
1557 IF( ilaenv( 10, 'SSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1558 $ ilaenv( 11, 'SSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
1559*
1560* Call SSTEMR, 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 sstemr( '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 )'SSTEMR(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( slarnd( 1, iseed2 ) )
1602 iu = 1 + ( n-1 )*int( slarnd( 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 sstemr( '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 )'SSTEMR(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 SSTEMR(V,I) to compute D1 and Z, do tests.
1651*
1652* Compute D1 and Z
1653*
1654 CALL scopy( n, sd, 1, d5, 1 )
1655 IF( n.GT.0 )
1656 $ CALL scopy( n-1, se, 1, work, 1 )
1657 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1658*
1659 IF( srange ) THEN
1660 ntest = 29
1661 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1662 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1663 IF( iu.LT.il ) THEN
1664 itemp = iu
1665 iu = il
1666 il = itemp
1667 END IF
1668 CALL sstemr( '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 )'SSTEMR(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 sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1687 $ m, result( 29 ) )
1688*
1689* Call SSTEMR to compute D2, do tests.
1690*
1691* Compute D2
1692*
1693 CALL scopy( n, sd, 1, d5, 1 )
1694 IF( n.GT.0 )
1695 $ CALL scopy( n-1, se, 1, work, 1 )
1696*
1697 ntest = 31
1698 CALL sstemr( '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 )'SSTEMR(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 SSTEMR(V,V) to compute D1 and Z, do tests.
1730*
1731* Compute D1 and Z
1732*
1733 CALL scopy( n, sd, 1, d5, 1 )
1734 IF( n.GT.0 )
1735 $ CALL scopy( n-1, se, 1, work, 1 )
1736 CALL slaset( '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 sstemr( '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 )'SSTEMR(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 sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1781 $ m, result( 32 ) )
1782*
1783* Call SSTEMR to compute D2, do tests.
1784*
1785* Compute D2
1786*
1787 CALL scopy( n, sd, 1, d5, 1 )
1788 IF( n.GT.0 )
1789 $ CALL scopy( n-1, se, 1, work, 1 )
1790*
1791 ntest = 34
1792 CALL sstemr( '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 )'SSTEMR(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 SSTEMR(V,A) to compute D1 and Z, do tests.
1832*
1833* Compute D1 and Z
1834*
1835 CALL scopy( n, sd, 1, d5, 1 )
1836 IF( n.GT.0 )
1837 $ CALL scopy( n-1, se, 1, work, 1 )
1838*
1839 ntest = 35
1840*
1841 CALL sstemr( '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 )'SSTEMR(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 sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1860 $ result( 35 ) )
1861*
1862* Call SSTEMR to compute D2, do tests.
1863*
1864* Compute D2
1865*
1866 CALL scopy( n, sd, 1, d5, 1 )
1867 IF( n.GT.0 )
1868 $ CALL scopy( n-1, se, 1, work, 1 )
1869*
1870 ntest = 37
1871 CALL sstemr( '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 )'SSTEMR(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 )'SST'
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 slasum( 'SST', nounit, nerrs, ntestt )
1937 RETURN
1938*
1939 9999 FORMAT( ' SCHKST: ', 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 SCHKST 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 SCHKST for details.', / )
1974* End of SCHKST
1975*
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
sstedc
subroutine sstedc(compz, n, d, e, z, ldz, work, lwork, iwork, liwork, info)
SSTEDC
Definition sstedc.f:188
sstebz
subroutine sstebz(range, order, n, vl, vu, il, iu, abstol, d, e, m, nsplit, w, iblock, isplit, work, iwork, info)
SSTEBZ
Definition sstebz.f:273
ssterf
subroutine ssterf(n, d, e, info)
SSTERF
Definition ssterf.f:86
sstemr
subroutine sstemr(jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
SSTEMR
Definition sstemr.f:321
sopgtr
subroutine sopgtr(uplo, n, ap, tau, q, ldq, work, info)
SOPGTR
Definition sopgtr.f:114
sorgtr
subroutine sorgtr(uplo, n, a, lda, tau, work, lwork, info)
SORGTR
Definition sorgtr.f:123
ssptrd
subroutine ssptrd(uplo, n, ap, d, e, tau, info)
SSPTRD
Definition ssptrd.f:150
sstein
subroutine sstein(n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
SSTEIN
Definition sstein.f:174
spteqr
subroutine spteqr(compz, n, d, e, z, ldz, work, info)
SPTEQR
Definition spteqr.f:145
ssytrd
subroutine ssytrd(uplo, n, a, lda, d, e, tau, work, lwork, info)
SSYTRD
Definition ssytrd.f:192
sspt21
subroutine sspt21(itype, uplo, n, kband, ap, d, e, u, ldu, vp, tau, work, result)
SSPT21
Definition sspt21.f:221
sstt21
subroutine sstt21(n, kband, ad, ae, sd, se, u, ldu, work, result)
SSTT21
Definition sstt21.f:127
sstt22
subroutine sstt22(n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, result)
SSTT22
Definition sstt22.f:139
sstech
subroutine sstech(n, a, b, eig, tol, work, info)
SSTECH
Definition sstech.f:101
ssyt21
subroutine ssyt21(itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, result)
SSYT21
Definition ssyt21.f:207

◆ schkst2stg()

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

SCHKST2STG

Purpose:
!>
!> SCHKST2STG  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
!> SSYTRD. For that, we call the standard SSYTRD and compute D1 using 
!> SSTEQR, then we call the 2-stage SSYTRD_2STAGE with Upper and Lower
!> and we compute D2 and D3 using SSTEQR 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 SCHKST in the next 
!> release when vectors and generation of Q will be implemented.
!>
!>    SSYTRD factors A as  U S U' , where ' means transpose,
!>    S is symmetric tridiagonal, and U is orthogonal.
!>    SSYTRD can use either just the lower or just the upper triangle
!>    of A; SCHKST2STG 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.
!>
!>    SSPTRD does the same as SSYTRD, except that A and V are stored
!>    in  format.
!>
!>    SORGTR constructs the matrix U from the contents of V and TAU.
!>
!>    SOPGTR constructs the matrix U from the contents of VP and TAU.
!>
!>    SSTEQR 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.
!>
!>    SSTERF computes D3, the matrix of eigenvalues, by the
!>    PWK method, which does not yield eigenvectors.
!>
!>    SPTEQR 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.
!>
!>    SSTEBZ computes selected eigenvalues.  WA1, WA2, and
!>    WA3 will denote eigenvalues computed to high
!>    absolute accuracy, with different range options.
!>    WR will denote eigenvalues computed to high relative
!>    accuracy.
!>
!>    SSTEIN computes Y, the eigenvectors of S, given the
!>    eigenvalues.
!>
!>    SSTEDC 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 SSYTRD/SORGTR or SSPTRD/SOPGTR ('V' option). It may
!>    also just compute eigenvalues ('N' option).
!>
!>    SSTEMR 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).  SSTEMR
!>    uses the Relatively Robust Representation whenever possible.
!>
!> When SCHKST2STG 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 ) SSYTRD( UPLO='U', ... )
!>
!> (2)     | I - UV' | / ( n ulp )        SORGTR( UPLO='U', ... )
!>
!> (3)     | A - V S V' | / ( |A| n ulp ) SSYTRD( 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
!>         SSYTRD_2STAGE(, ,....). D1 and D2 are computed 
!>         via SSTEQR('N',...)  
!>
!> (4)     | I - UV' | / ( n ulp )        SORGTR( 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
!>         SSYTRD_2STAGE(, ,....). D1 and D3 are computed 
!>         via SSTEQR('N',...)  
!>
!> (5-8)   Same as 1-4, but for SSPTRD and SOPGTR.
!>
!> (9)     | S - Z D Z' | / ( |S| n ulp ) SSTEQR('V',...)
!>
!> (10)    | I - ZZ' | / ( n ulp )        SSTEQR('V',...)
!>
!> (11)    | D1 - D2 | / ( |D1| ulp )        SSTEQR('N',...)
!>
!> (12)    | D1 - D3 | / ( |D1| ulp )        SSTERF
!>
!> (13)    0 if the true eigenvalues (computed by sturm count)
!>         of S are within THRESH of
!>         those in D1.  2*THRESH if they are not.  (Tested using
!>         SSTECH)
!>
!> For S positive definite,
!>
!> (14)    | S - Z4 D4 Z4' | / ( |S| n ulp ) SPTEQR('V',...)
!>
!> (15)    | I - Z4 Z4' | / ( n ulp )        SPTEQR('V',...)
!>
!> (16)    | D4 - D5 | / ( 100 |D4| ulp )       SPTEQR('N',...)
!>
!> When S is also diagonally dominant by the factor gamma < 1,
!>
!> (17)    max | D4(i) - WR(i) | / ( |D4(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              SSTEBZ( 'A', 'E', ...)
!>
!> (18)    | WA1 - D3 | / ( |D3| ulp )          SSTEBZ( 'A', 'E', ...)
!>
!> (19)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>                                              SSTEBZ( 'I', 'E', ...)
!>
!> (20)    | S - Y WA1 Y' | / ( |S| n ulp )  SSTEBZ, SSTEIN
!>
!> (21)    | I - Y Y' | / ( n ulp )          SSTEBZ, SSTEIN
!>
!> (22)    | S - Z D Z' | / ( |S| n ulp )    SSTEDC('I')
!>
!> (23)    | I - ZZ' | / ( n ulp )           SSTEDC('I')
!>
!> (24)    | S - Z D Z' | / ( |S| n ulp )    SSTEDC('V')
!>
!> (25)    | I - ZZ' | / ( n ulp )           SSTEDC('V')
!>
!> (26)    | D1 - D2 | / ( |D1| ulp )           SSTEDC('V') and
!>                                              SSTEDC('N')
!>
!> Test 27 is disabled at the moment because SSTEMR 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
!>                                              SSTEMR('V', 'A')
!>
!> (28)    max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
!>          i
!>         omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
!>                                              SSTEMR('V', 'I')
!>
!> Tests 29 through 34 are disable at present because SSTEMR
!> does not handle partial spectrum requests.
!>
!> (29)    | S - Z D Z' | / ( |S| n ulp )    SSTEMR('V', 'I')
!>
!> (30)    | I - ZZ' | / ( n ulp )           SSTEMR('V', 'I')
!>
!> (31)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         SSTEMR('N', 'I') vs. SSTEMR('V', 'I')
!>
!> (32)    | S - Z D Z' | / ( |S| n ulp )    SSTEMR('V', 'V')
!>
!> (33)    | I - ZZ' | / ( n ulp )           SSTEMR('V', 'V')
!>
!> (34)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         SSTEMR('N', 'V') vs. SSTEMR('V', 'V')
!>
!> (35)    | S - Z D Z' | / ( |S| n ulp )    SSTEMR('V', 'A')
!>
!> (36)    | I - ZZ' | / ( n ulp )           SSTEMR('V', 'A')
!>
!> (37)    ( max { min | WA2(i)-WA3(j) | } +
!>            i     j
!>           max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
!>            i     j
!>         SSTEMR('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,
!>          SCHKST2STG 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, SCHKST2STG
!>          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 SCHKST2STG to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[in,out]A
!>          A is REAL array 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 REAL array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix A stored in packed format.
!>
[out]SD
!>          SD is REAL array of
!>                             dimension( max(NN) )
!>          The diagonal of the tridiagonal matrix computed by SSYTRD.
!>          On exit, SD and SE contain the tridiagonal form of the
!>          matrix in A.
!>
[out]SE
!>          SE is REAL array of
!>                             dimension( max(NN) )
!>          The off-diagonal of the tridiagonal matrix computed by
!>          SSYTRD.  On exit, SD and SE contain the tridiagonal form of
!>          the matrix in A.
!>
[out]D1
!>          D1 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>
[out]D2
!>          D2 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>
[out]D3
!>          D3 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>
[out]D4
!>          D4 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SPTEQR(V).
!>          SPTEQR factors S as  Z4 D4 Z4*
!>          On exit, the eigenvalues in D4 correspond with the matrix in A.
!>
[out]D5
!>          D5 is REAL array of
!>                             dimension( max(NN) )
!>          The eigenvalues of A, as computed by SPTEQR(N)
!>          when Z is not computed. On exit, the
!>          eigenvalues in D4 correspond with the matrix in A.
!>
[out]WA1
!>          WA1 is REAL array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>
[out]WA2
!>          WA2 is REAL array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>          Choose random values for IL and IU, and ask for the
!>          IL-th through IU-th eigenvalues.
!>
[out]WA3
!>          WA3 is REAL array of
!>                             dimension( max(NN) )
!>          Selected eigenvalues of A, computed to high
!>          absolute accuracy, with different range options.
!>          as computed by SSTEBZ.
!>          Determine the values VL and VU of the IL-th and IU-th
!>          eigenvalues and ask for all eigenvalues in this range.
!>
[out]WR
!>          WR is REAL array of
!>                             dimension( max(NN) )
!>          All eigenvalues of A, computed to high
!>          absolute accuracy, with different options.
!>          as computed by SSTEBZ.
!>
[out]U
!>          U is REAL array of
!>                             dimension( LDU, max(NN) ).
!>          The orthogonal matrix computed by SSYTRD + SORGTR.
!>
[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 REAL array of
!>                             dimension( LDU, max(NN) ).
!>          The Housholder vectors computed by SSYTRD 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 SSYTRD, 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 SORGTR, set those entries to
!>          1 before using them, and then restore them later.)
!>
[out]VP
!>          VP is REAL array of
!>                      dimension( max(NN)*max(NN+1)/2 )
!>          The matrix V stored in packed format.
!>
[out]TAU
!>          TAU is REAL array of
!>                             dimension( max(NN) )
!>          The Householder factors computed by SSYTRD in reducing A
!>          to tridiagonal form.
!>
[out]Z
!>          Z is REAL array of
!>                             dimension( LDU, max(NN) ).
!>          The orthogonal matrix of eigenvectors computed by SSTEQR,
!>          SPTEQR, and SSTEIN.
!>
[out]WORK
!>          WORK is REAL 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 REAL array, dimension (26)
!>          The values computed by the tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]INFO
!>          INFO is INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -23: LDU < 1 or LDU < NMAX.
!>          -29: LWORK too small.
!>          If  SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF,
!>              or SORMC2 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 schkst2stg.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 REAL THRESH
621* ..
622* .. Array Arguments ..
623 LOGICAL DOTYPE( * )
624 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
625 REAL 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 REAL ZERO, ONE, TWO, EIGHT, TEN, HUN
636 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
637 $ eight = 8.0e0, ten = 10.0e0, hun = 100.0e0 )
638 REAL 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 REAL 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 REAL DUMMA( 1 )
662* ..
663* .. External Functions ..
664 INTEGER ILAENV
665 REAL SLAMCH, SLARND, SSXT1
666 EXTERNAL ilaenv, slamch, slarnd, ssxt1
667* ..
668* .. External Subroutines ..
669 EXTERNAL scopy, slabad, slacpy, slaset, slasum, slatmr,
670 $ slatms, sopgtr, sorgtr, spteqr, sspt21, ssptrd,
671 $ sstebz, sstech, sstedc, sstemr, sstein, ssteqr,
672 $ ssterf, sstt21, sstt22, ssyt21, ssytrd, xerbla,
673 $ ssytrd_2stage
674* ..
675* .. Intrinsic Functions ..
676 INTRINSIC abs, real, 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, 'SSYTRD', '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( 'SCHKST2STG', -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 = slamch( 'Safe minimum' )
739 ovfl = one / unfl
740 CALL slabad( unfl, ovfl )
741 ulp = slamch( 'Epsilon' )*slamch( '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( real( 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 / real( 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 slaset( '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 slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 slatms( 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 slatms( 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 SSYTRD and SORGTR to compute S and U from
926* upper triangle.
927*
928 CALL slacpy( 'U', n, n, a, lda, v, ldu )
929*
930 ntest = 1
931 CALL ssytrd( 'U', n, v, ldu, sd, se, tau, work, lwork,
932 $ iinfo )
933*
934 IF( iinfo.NE.0 ) THEN
935 WRITE( nounit, fmt = 9999 )'SSYTRD(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 slacpy( 'U', n, n, v, ldu, u, ldu )
947*
948 ntest = 2
949 CALL sorgtr( 'U', n, u, ldu, tau, work, lwork, iinfo )
950 IF( iinfo.NE.0 ) THEN
951 WRITE( nounit, fmt = 9999 )'SORGTR(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 ssyt21( 2, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
965 $ ldu, tau, work, result( 1 ) )
966 CALL ssyt21( 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 scopy( n, sd, 1, d1, 1 )
977 IF( n.GT.0 )
978 $ CALL scopy( n-1, se, 1, work, 1 )
979*
980 CALL ssteqr( 'N', n, d1, work, work( n+1 ), ldu,
981 $ work( n+1 ), iinfo )
982 IF( iinfo.NE.0 ) THEN
983 WRITE( nounit, fmt = 9999 )'SSTEQR(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 slaset( 'Full', n, 1, zero, zero, sd, n )
1000 CALL slaset( 'Full', n, 1, zero, zero, se, n )
1001 CALL slacpy( "U", n, n, a, lda, v, ldu )
1002 lh = max(1, 4*n)
1003 lw = lwork - lh
1004 CALL ssytrd_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 scopy( n, sd, 1, d2, 1 )
1010 IF( n.GT.0 )
1011 $ CALL scopy( n-1, se, 1, work, 1 )
1012*
1013 CALL ssteqr( 'N', n, d2, work, work( n+1 ), ldu,
1014 $ work( n+1 ), iinfo )
1015 IF( iinfo.NE.0 ) THEN
1016 WRITE( nounit, fmt = 9999 )'SSTEQR(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 slaset( 'Full', n, 1, zero, zero, sd, n )
1033 CALL slaset( 'Full', n, 1, zero, zero, se, n )
1034 CALL slacpy( "L", n, n, a, lda, v, ldu )
1035 CALL ssytrd_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 scopy( n, sd, 1, d3, 1 )
1041 IF( n.GT.0 )
1042 $ CALL scopy( n-1, se, 1, work, 1 )
1043*
1044 CALL ssteqr( 'N', n, d3, work, work( n+1 ), ldu,
1045 $ work( n+1 ), iinfo )
1046 IF( iinfo.NE.0 ) THEN
1047 WRITE( nounit, fmt = 9999 )'SSTEQR(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 SSPTRD and SOPGTR to compute S and U from AP
1088*
1089 CALL scopy( nap, ap, 1, vp, 1 )
1090*
1091 ntest = 5
1092 CALL ssptrd( 'U', n, vp, sd, se, tau, iinfo )
1093*
1094 IF( iinfo.NE.0 ) THEN
1095 WRITE( nounit, fmt = 9999 )'SSPTRD(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 sopgtr( 'U', n, vp, tau, u, ldu, work, iinfo )
1108 IF( iinfo.NE.0 ) THEN
1109 WRITE( nounit, fmt = 9999 )'SOPGTR(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 sspt21( 2, 'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1123 $ work, result( 5 ) )
1124 CALL sspt21( 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 SSPTRD and SOPGTR to compute S and U from AP
1138*
1139 CALL scopy( nap, ap, 1, vp, 1 )
1140*
1141 ntest = 7
1142 CALL ssptrd( 'L', n, vp, sd, se, tau, iinfo )
1143*
1144 IF( iinfo.NE.0 ) THEN
1145 WRITE( nounit, fmt = 9999 )'SSPTRD(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 sopgtr( 'L', n, vp, tau, u, ldu, work, iinfo )
1158 IF( iinfo.NE.0 ) THEN
1159 WRITE( nounit, fmt = 9999 )'SOPGTR(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 sspt21( 2, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1171 $ work, result( 7 ) )
1172 CALL sspt21( 3, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1173 $ work, result( 8 ) )
1174*
1175* Call SSTEQR to compute D1, D2, and Z, do tests.
1176*
1177* Compute D1 and Z
1178*
1179 CALL scopy( n, sd, 1, d1, 1 )
1180 IF( n.GT.0 )
1181 $ CALL scopy( n-1, se, 1, work, 1 )
1182 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1183*
1184 ntest = 9
1185 CALL ssteqr( 'V', n, d1, work, z, ldu, work( n+1 ), iinfo )
1186 IF( iinfo.NE.0 ) THEN
1187 WRITE( nounit, fmt = 9999 )'SSTEQR(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 scopy( n, sd, 1, d2, 1 )
1201 IF( n.GT.0 )
1202 $ CALL scopy( n-1, se, 1, work, 1 )
1203*
1204 ntest = 11
1205 CALL ssteqr( 'N', n, d2, work, work( n+1 ), ldu,
1206 $ work( n+1 ), iinfo )
1207 IF( iinfo.NE.0 ) THEN
1208 WRITE( nounit, fmt = 9999 )'SSTEQR(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 scopy( n, sd, 1, d3, 1 )
1222 IF( n.GT.0 )
1223 $ CALL scopy( n-1, se, 1, work, 1 )
1224*
1225 ntest = 12
1226 CALL ssterf( n, d3, work, iinfo )
1227 IF( iinfo.NE.0 ) THEN
1228 WRITE( nounit, fmt = 9999 )'SSTERF', 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 sstt21( 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 sstech( 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 SPTEQR
1278* and do tests 14, 15, and 16 .
1279*
1280 IF( jtype.GT.15 ) THEN
1281*
1282* Compute D4 and Z4
1283*
1284 CALL scopy( n, sd, 1, d4, 1 )
1285 IF( n.GT.0 )
1286 $ CALL scopy( n-1, se, 1, work, 1 )
1287 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1288*
1289 ntest = 14
1290 CALL spteqr( 'V', n, d4, work, z, ldu, work( n+1 ),
1291 $ iinfo )
1292 IF( iinfo.NE.0 ) THEN
1293 WRITE( nounit, fmt = 9999 )'SPTEQR(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 sstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1307 $ result( 14 ) )
1308*
1309* Compute D5
1310*
1311 CALL scopy( n, sd, 1, d5, 1 )
1312 IF( n.GT.0 )
1313 $ CALL scopy( n-1, se, 1, work, 1 )
1314*
1315 ntest = 16
1316 CALL spteqr( 'N', n, d5, work, z, ldu, work( n+1 ),
1317 $ iinfo )
1318 IF( iinfo.NE.0 ) THEN
1319 WRITE( nounit, fmt = 9999 )'SPTEQR(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 SSTEBZ 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 sstebz( '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 )'SSTEBZ(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 sstebz( '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 )'SSTEBZ(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( slarnd( 1, iseed2 ) )
1429 iu = 1 + ( n-1 )*int( slarnd( 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 sstebz( '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 )'SSTEBZ(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 sstebz( '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 )'SSTEBZ(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1498 temp2 = ssxt1( 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 SSTEIN to compute eigenvectors corresponding to
1508* eigenvalues in WA1. (First call SSTEBZ again, to make sure
1509* it returns these eigenvalues in the correct order.)
1510*
1511 ntest = 21
1512 CALL sstebz( '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 )'SSTEBZ(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 sstein( 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 )'SSTEIN', 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 sstt21( n, 0, sd, se, wa1, dumma, z, ldu, work,
1547 $ result( 20 ) )
1548*
1549* Call SSTEDC(I) to compute D1 and Z, do tests.
1550*
1551* Compute D1 and Z
1552*
1553 CALL scopy( n, sd, 1, d1, 1 )
1554 IF( n.GT.0 )
1555 $ CALL scopy( n-1, se, 1, work, 1 )
1556 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1557*
1558 ntest = 22
1559 CALL sstedc( '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 )'SSTEDC(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 sstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1576 $ result( 22 ) )
1577*
1578* Call SSTEDC(V) to compute D1 and Z, do tests.
1579*
1580* Compute D1 and Z
1581*
1582 CALL scopy( n, sd, 1, d1, 1 )
1583 IF( n.GT.0 )
1584 $ CALL scopy( n-1, se, 1, work, 1 )
1585 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1586*
1587 ntest = 24
1588 CALL sstedc( '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 )'SSTEDC(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 sstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1605 $ result( 24 ) )
1606*
1607* Call SSTEDC(N) to compute D2, do tests.
1608*
1609* Compute D2
1610*
1611 CALL scopy( n, sd, 1, d2, 1 )
1612 IF( n.GT.0 )
1613 $ CALL scopy( n-1, se, 1, work, 1 )
1614 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1615*
1616 ntest = 26
1617 CALL sstedc( '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 )'SSTEDC(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 SSTEMR if IEEE compliant
1644*
1645 IF( ilaenv( 10, 'SSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1646 $ ilaenv( 11, 'SSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
1647*
1648* Call SSTEMR, 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 sstemr( '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 )'SSTEMR(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( slarnd( 1, iseed2 ) )
1690 iu = 1 + ( n-1 )*int( slarnd( 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 sstemr( '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 )'SSTEMR(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 SSTEMR(V,I) to compute D1 and Z, do tests.
1738*
1739* Compute D1 and Z
1740*
1741 CALL scopy( n, sd, 1, d5, 1 )
1742 IF( n.GT.0 )
1743 $ CALL scopy( n-1, se, 1, work, 1 )
1744 CALL slaset( 'Full', n, n, zero, one, z, ldu )
1745*
1746 IF( srange ) THEN
1747 ntest = 29
1748 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1749 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1750 IF( iu.LT.il ) THEN
1751 itemp = iu
1752 iu = il
1753 il = itemp
1754 END IF
1755 CALL sstemr( '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 )'SSTEMR(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 sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1774 $ m, result( 29 ) )
1775*
1776* Call SSTEMR to compute D2, do tests.
1777*
1778* Compute D2
1779*
1780 CALL scopy( n, sd, 1, d5, 1 )
1781 IF( n.GT.0 )
1782 $ CALL scopy( n-1, se, 1, work, 1 )
1783*
1784 ntest = 31
1785 CALL sstemr( '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 )'SSTEMR(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 SSTEMR(V,V) to compute D1 and Z, do tests.
1816*
1817* Compute D1 and Z
1818*
1819 CALL scopy( n, sd, 1, d5, 1 )
1820 IF( n.GT.0 )
1821 $ CALL scopy( n-1, se, 1, work, 1 )
1822 CALL slaset( '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 sstemr( '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 )'SSTEMR(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 sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1867 $ m, result( 32 ) )
1868*
1869* Call SSTEMR to compute D2, do tests.
1870*
1871* Compute D2
1872*
1873 CALL scopy( n, sd, 1, d5, 1 )
1874 IF( n.GT.0 )
1875 $ CALL scopy( n-1, se, 1, work, 1 )
1876*
1877 ntest = 34
1878 CALL sstemr( '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 )'SSTEMR(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 SSTEMR(V,A) to compute D1 and Z, do tests.
1917*
1918* Compute D1 and Z
1919*
1920 CALL scopy( n, sd, 1, d5, 1 )
1921 IF( n.GT.0 )
1922 $ CALL scopy( n-1, se, 1, work, 1 )
1923*
1924 ntest = 35
1925*
1926 CALL sstemr( '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 )'SSTEMR(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 sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1945 $ result( 35 ) )
1946*
1947* Call SSTEMR to compute D2, do tests.
1948*
1949* Compute D2
1950*
1951 CALL scopy( n, sd, 1, d5, 1 )
1952 IF( n.GT.0 )
1953 $ CALL scopy( n-1, se, 1, work, 1 )
1954*
1955 ntest = 37
1956 CALL sstemr( '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 )'SSTEMR(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 )'SST'
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 slasum( 'SST', nounit, nerrs, ntestt )
2021 RETURN
2022*
2023 9999 FORMAT( ' SCHKST2STG: ', 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 SCHKST2STG 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 SCHKST2STG for details.', / )
2058*
2059* End of SCHKST2STG
2060*
ssytrd_2stage
subroutine ssytrd_2stage(vect, uplo, n, a, lda, d, e, tau, hous2, lhous2, work, lwork, info)
SSYTRD_2STAGE
Definition ssytrd_2stage.f:224

◆ sckcsd()

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

SCKCSD

Purpose:
!>
!> SCKCSD tests SORCSD:
!>        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 REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]MMAX
!>          MMAX is INTEGER
!>          The maximum value permitted for M, used in dimensioning the
!>          work arrays.
!>
[out]X
!>          X is REAL array, dimension (MMAX*MMAX)
!>
[out]XF
!>          XF is REAL array, dimension (MMAX*MMAX)
!>
[out]U1
!>          U1 is REAL array, dimension (MMAX*MMAX)
!>
[out]U2
!>          U2 is REAL array, dimension (MMAX*MMAX)
!>
[out]V1T
!>          V1T is REAL array, dimension (MMAX*MMAX)
!>
[out]V2T
!>          V2T is REAL array, dimension (MMAX*MMAX)
!>
[out]THETA
!>          THETA is REAL array, dimension (MMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (MMAX)
!>
[out]WORK
!>          WORK is REAL array
!>
[out]RWORK
!>          RWORK is REAL array
!>
[in]NIN
!>          NIN is INTEGER
!>          The unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0 :  successful exit
!>          > 0 :  If SLAROR 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 sckcsd.f.

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

◆ sckglm()

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

SCKGLM

Purpose:
!>
!> SCKGLM tests SGGGLM - 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 REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESID >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is REAL array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is REAL array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is REAL array, dimension (NMAX*NMAX)
!>
[out]X
!>          X is REAL array, dimension (4*NMAX)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (NMAX)
!>
[out]WORK
!>          WORK is REAL 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 SLATMS 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 sckglm.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 REAL THRESH
175* ..
176* .. Array Arguments ..
177 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
178 REAL 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 REAL ANORM, BNORM, CNDNMA, CNDNMB, RESID
195* ..
196* .. Local Arrays ..
197 LOGICAL DOTYPE( NTYPES )
198* ..
199* .. External Functions ..
200 REAL SLARND
201 EXTERNAL slarnd
202* ..
203* .. External Subroutines ..
204 EXTERNAL alahdg, alareq, alasum, sglmts, slatb9, slatms
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 SLATB9 and generate test
256* matrices A and B with SLATMS.
257*
258 CALL slatb9( path, imat, m, p, n, TYPE, KLA, KUA, KLB, KUB,
259 $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
260 $ DISTA, DISTB )
261*
262 CALL slatms( 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 slatms( 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 ) = slarnd( 2, iseed )
284 20 CONTINUE
285*
286 CALL sglmts( 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( ' SLATMS in SCKGLM 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 SCKGLM
319*
slatb9
subroutine slatb9(path, imat, m, p, n, type, kla, kua, klb, kub, anorm, bnorm, modea, modeb, cndnma, cndnmb, dista, distb)
SLATB9
Definition slatb9.f:170
sglmts
subroutine sglmts(n, m, p, a, af, lda, b, bf, ldb, d, df, x, u, work, lwork, rwork, result)
SGLMTS
Definition sglmts.f:149

◆ sckgqr()

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

SCKGQR

Purpose:
!>
!> SCKGQR tests
!> SGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B,
!> SGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B.
!>
Parameters
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row(column) dimension M.
!>
[in]NP
!>          NP is INTEGER
!>          The number of values of P contained in the vector PVAL.
!>
[in]PVAL
!>          PVAL is INTEGER array, dimension (NP)
!>          The values of the matrix row(column) dimension P.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column(row) dimension N.
!>
[in]NMATS
!>          NMATS is INTEGER
!>          The number of matrix types to be tested for each combination
!>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
!>          number of matrix types), then all the different types are
!>          generated for testing.  If NMATS < NTYPES, another input line
!>          is read to get the numbers of the matrix types to be used.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator.  The array
!>          elements should be between 0 and 4095, otherwise they will be
!>          reduced mod 4096, and ISEED(4) must be odd.
!>          On exit, the next seed in the random number sequence after
!>          all the test matrices have been generated.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is REAL array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is REAL array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is REAL array, dimension (NMAX*NMAX)
!>
[out]AR
!>          AR is REAL array, dimension (NMAX*NMAX)
!>
[out]TAUA
!>          TAUA is REAL array, dimension (NMAX)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is REAL array, dimension (NMAX*NMAX)
!>
[out]BZ
!>          BZ is REAL array, dimension (NMAX*NMAX)
!>
[out]BT
!>          BT is REAL array, dimension (NMAX*NMAX)
!>
[out]BWK
!>          BWK is REAL array, dimension (NMAX*NMAX)
!>
[out]TAUB
!>          TAUB is REAL array, dimension (NMAX)
!>
[out]WORK
!>          WORK is REAL array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (NMAX)
!>
[in]NIN
!>          NIN is INTEGER
!>          The unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0 :  successful exit
!>          > 0 :  If SLATMS 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 sckgqr.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 REAL THRESH
218* ..
219* .. Array Arguments ..
220 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
221 REAL 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 REAL ANORM, BNORM, CNDNMA, CNDNMB
242* ..
243* .. Local Arrays ..
244 LOGICAL DOTYPE( NTYPES )
245 REAL RESULT( NTESTS )
246* ..
247* .. External Subroutines ..
248 EXTERNAL alahdg, alareq, alasum, sgqrts, sgrqts, slatb9,
249 $ slatms
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 SGGRQF
291*
292* Set up parameters with SLATB9 and generate test
293* matrices A and B with SLATMS.
294*
295 CALL slatb9( '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 slatms( 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 slatms( 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 sgrqts( 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 SGGQRF
344*
345* Set up parameters with SLATB9 and generate test
346* matrices A and B with SLATMS.
347*
348 CALL slatb9( '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 slatms( 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 slatms( 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 sgqrts( 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( ' SLATMS in SCKGQR: 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 SCKGQR
413*
sgrqts
subroutine sgrqts(m, p, n, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
SGRQTS
Definition sgrqts.f:177
sgqrts
subroutine sgqrts(n, m, p, a, af, q, r, lda, taua, b, bf, z, t, bwk, ldb, taub, work, lwork, rwork, result)
SGQRTS
Definition sgqrts.f:176

◆ sckgsv()

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

SCKGSV

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

198*
199* -- LAPACK test routine --
200* -- LAPACK is a software package provided by Univ. of Tennessee, --
201* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
202*
203* .. Scalar Arguments ..
204 INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT
205 REAL THRESH
206* ..
207* .. Array Arguments ..
208 INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * ),
209 $ PVAL( * )
210 REAL 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 REAL ANORM, BNORM, CNDNMA, CNDNMB
231* ..
232* .. Local Arrays ..
233 LOGICAL DOTYPE( NTYPES )
234 REAL RESULT( NTESTS )
235* ..
236* .. External Subroutines ..
237 EXTERNAL alahdg, alareq, alasum, sgsvts3, slatb9, slatms
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 SLATB9 and generate test
275* matrices A and B with SLATMS.
276*
277 CALL slatb9( 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 slatms( 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 slatms( 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 sgsvts3( 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( ' SLATMS in SCKGSV 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 SCKGSV
335*
alpha
#define alpha
Definition eval.h:35
sgsvts3
subroutine sgsvts3(m, p, n, a, af, lda, b, bf, ldb, u, ldu, v, ldv, q, ldq, alpha, beta, r, ldr, iwork, work, lwork, rwork, result)
SGSVTS3
Definition sgsvts3.f:210

◆ scklse()

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

SCKLSE

Purpose:
!>
!> SCKLSE tests SGGLSE - a subroutine for solving linear equality
!> constrained least square problem (LSE).
!>
Parameters
[in]NN
!>          NN is INTEGER
!>          The number of values of (M,P,N) contained in the vectors
!>          (MVAL, PVAL, NVAL).
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NN)
!>          The values of the matrix row(column) dimension M.
!>
[in]PVAL
!>          PVAL is INTEGER array, dimension (NN)
!>          The values of the matrix row(column) dimension P.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column(row) dimension N.
!>
[in]NMATS
!>          NMATS is INTEGER
!>          The number of matrix types to be tested for each combination
!>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
!>          number of matrix types), then all the different types are
!>          generated for testing.  If NMATS < NTYPES, another input line
!>          is read to get the numbers of the matrix types to be used.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator.  The array
!>          elements should be between 0 and 4095, otherwise they will be
!>          reduced mod 4096, and ISEED(4) must be odd.
!>          On exit, the next seed in the random number sequence after
!>          all the test matrices have been generated.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is REAL array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is REAL array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NMAX)
!>
[out]BF
!>          BF is REAL array, dimension (NMAX*NMAX)
!>
[out]X
!>          X is REAL array, dimension (5*NMAX)
!>
[out]WORK
!>          WORK is REAL array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (NMAX)
!>
[in]NIN
!>          NIN is INTEGER
!>          The unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0 :  successful exit
!>          > 0 :  If SLATMS 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 scklse.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 REAL THRESH
175* ..
176* .. Array Arguments ..
177 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
178 REAL 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 REAL ANORM, BNORM, CNDNMA, CNDNMB
198* ..
199* .. Local Arrays ..
200 LOGICAL DOTYPE( NTYPES )
201 REAL RESULT( NTESTS )
202* ..
203* .. External Subroutines ..
204 EXTERNAL alahdg, alareq, alasum, slarhs, slatb9, slatms,
205 $ slsets
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 SLATB9 and generate test
257* matrices A and B with SLATMS.
258*
259 CALL slatb9( path, imat, m, p, n, TYPE, KLA, KUA, KLB, KUB,
260 $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
261 $ DISTA, DISTB )
262*
263 CALL slatms( 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 slatms( 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 slarhs( 'SGE', '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 slarhs( 'SGE', '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 slsets( 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( ' SLATMS in SCKLSE 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 SCKLSE
332*
slsets
subroutine slsets(m, p, n, a, af, lda, b, bf, ldb, c, cf, d, df, x, work, lwork, rwork, result)
SLSETS
Definition slsets.f:155
slarhs
subroutine slarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
SLARHS
Definition slarhs.f:205

◆ scsdts()

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

SCSDTS

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

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

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

Definition at line 226 of file scsdts.f.

229*
230* -- LAPACK test routine --
231* -- LAPACK is a software package provided by Univ. of Tennessee, --
232* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
233*
234* .. Scalar Arguments ..
235 INTEGER LDX, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q
236* ..
237* .. Array Arguments ..
238 INTEGER IWORK( * )
239 REAL RESULT( 15 ), RWORK( * ), THETA( * )
240 REAL U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
241 $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
242 $ XF( LDX, * )
243* ..
244*
245* =====================================================================
246*
247* .. Parameters ..
248 REAL REALONE, REALZERO
249 parameter( realone = 1.0e0, realzero = 0.0e0 )
250 REAL ZERO, ONE
251 parameter( zero = 0.0e0, one = 1.0e0 )
252 REAL PIOVER2
253 parameter( piover2 = 1.57079632679489661923132169163975144210e0 )
254* ..
255* .. Local Scalars ..
256 INTEGER I, INFO, R
257 REAL EPS2, RESID, ULP, ULPINV
258* ..
259* .. External Functions ..
260 REAL SLAMCH, SLANGE, SLANSY
261 EXTERNAL slamch, slange, slansy
262* ..
263* .. External Subroutines ..
264 EXTERNAL sgemm, slacpy, slaset, sorcsd, sorcsd2by1,
265 $ ssyrk
266* ..
267* .. Intrinsic Functions ..
268 INTRINSIC cos, max, min, real, sin
269* ..
270* .. Executable Statements ..
271*
272 ulp = slamch( 'Precision' )
273 ulpinv = realone / ulp
274*
275* The first half of the routine checks the 2-by-2 CSD
276*
277 CALL slaset( 'Full', m, m, zero, one, work, ldx )
278 CALL ssyrk( 'Upper', 'Conjugate transpose', m, m, -one, x, ldx,
279 $ one, work, ldx )
280 IF (m.GT.0) THEN
281 eps2 = max( ulp,
282 $ slange( '1', m, m, work, ldx, rwork ) / real( m ) )
283 ELSE
284 eps2 = ulp
285 END IF
286 r = min( p, m-p, q, m-q )
287*
288* Copy the matrix X to the array XF.
289*
290 CALL slacpy( 'Full', m, m, x, ldx, xf, ldx )
291*
292* Compute the CSD
293*
294 CALL sorcsd( '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 slacpy( 'Full', m, m, x, ldx, xf, ldx )
302*
303 CALL sgemm( 'No transpose', 'Conjugate transpose', p, q, q, one,
304 $ xf, ldx, v1t, ldv1t, zero, work, ldx )
305*
306 CALL sgemm( '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 sgemm( 'No transpose', 'Conjugate transpose', p, m-q, m-q,
318 $ one, xf(1,q+1), ldx, v2t, ldv2t, zero, work, ldx )
319*
320 CALL sgemm( '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 sgemm( 'No transpose', 'Conjugate transpose', m-p, q, q, one,
333 $ xf(p+1,1), ldx, v1t, ldv1t, zero, work, ldx )
334*
335 CALL sgemm( '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 sgemm( '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 sgemm( '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 = slange( '1', p, q, xf, ldx, rwork )
365 result( 1 ) = ( resid / real(max(1,p,q)) ) / eps2
366*
367* Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
368*
369 resid = slange( '1', p, m-q, xf(1,q+1), ldx, rwork )
370 result( 2 ) = ( resid / real(max(1,p,m-q)) ) / eps2
371*
372* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
373*
374 resid = slange( '1', m-p, q, xf(p+1,1), ldx, rwork )
375 result( 3 ) = ( resid / real(max(1,m-p,q)) ) / eps2
376*
377* Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
378*
379 resid = slange( '1', m-p, m-q, xf(p+1,q+1), ldx, rwork )
380 result( 4 ) = ( resid / real(max(1,m-p,m-q)) ) / eps2
381*
382* Compute I - U1'*U1
383*
384 CALL slaset( 'Full', p, p, zero, one, work, ldu1 )
385 CALL ssyrk( '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 = slansy( '1', 'Upper', p, work, ldu1, rwork )
391 result( 5 ) = ( resid / real(max(1,p)) ) / ulp
392*
393* Compute I - U2'*U2
394*
395 CALL slaset( 'Full', m-p, m-p, zero, one, work, ldu2 )
396 CALL ssyrk( '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 = slansy( '1', 'Upper', m-p, work, ldu2, rwork )
402 result( 6 ) = ( resid / real(max(1,m-p)) ) / ulp
403*
404* Compute I - V1T*V1T'
405*
406 CALL slaset( 'Full', q, q, zero, one, work, ldv1t )
407 CALL ssyrk( '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 = slansy( '1', 'Upper', q, work, ldv1t, rwork )
413 result( 7 ) = ( resid / real(max(1,q)) ) / ulp
414*
415* Compute I - V2T*V2T'
416*
417 CALL slaset( 'Full', m-q, m-q, zero, one, work, ldv2t )
418 CALL ssyrk( '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 = slansy( '1', 'Upper', m-q, work, ldv2t, rwork )
424 result( 8 ) = ( resid / real(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 slaset( 'Full', q, q, zero, one, work, ldx )
443 CALL ssyrk( 'Upper', 'Conjugate transpose', q, m, -one, x, ldx,
444 $ one, work, ldx )
445 IF (m.GT.0) THEN
446 eps2 = max( ulp,
447 $ slange( '1', q, q, work, ldx, rwork ) / real( 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 slacpy( 'Full', m, q, x, ldx, xf, ldx )
456*
457* Compute the CSD
458*
459 CALL sorcsd2by1( '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 sgemm( 'No transpose', 'Conjugate transpose', p, q, q, one,
466 $ x, ldx, v1t, ldv1t, zero, work, ldx )
467*
468 CALL sgemm( '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 sgemm( 'No transpose', 'Conjugate transpose', m-p, q, q, one,
480 $ x(p+1,1), ldx, v1t, ldv1t, zero, work, ldx )
481*
482 CALL sgemm( '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 = slange( '1', p, q, x, ldx, rwork )
497 result( 10 ) = ( resid / real(max(1,p,q)) ) / eps2
498*
499* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
500*
501 resid = slange( '1', m-p, q, x(p+1,1), ldx, rwork )
502 result( 11 ) = ( resid / real(max(1,m-p,q)) ) / eps2
503*
504* Compute I - U1'*U1
505*
506 CALL slaset( 'Full', p, p, zero, one, work, ldu1 )
507 CALL ssyrk( '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 = slansy( '1', 'Upper', p, work, ldu1, rwork )
513 result( 12 ) = ( resid / real(max(1,p)) ) / ulp
514*
515* Compute I - U2'*U2
516*
517 CALL slaset( 'Full', m-p, m-p, zero, one, work, ldu2 )
518 CALL ssyrk( '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 = slansy( '1', 'Upper', m-p, work, ldu2, rwork )
524 result( 13 ) = ( resid / real(max(1,m-p)) ) / ulp
525*
526* Compute I - V1T*V1T'
527*
528 CALL slaset( 'Full', q, q, zero, one, work, ldv1t )
529 CALL ssyrk( '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 = slansy( '1', 'Upper', q, work, ldv1t, rwork )
535 result( 14 ) = ( resid / real(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 SCSDTS
554*
sorcsd2by1
subroutine sorcsd2by1(jobu1, jobu2, jobv1t, m, p, q, x11, ldx11, x21, ldx21, theta, u1, ldu1, u2, ldu2, v1t, ldv1t, work, lwork, iwork, info)
SORCSD2BY1
Definition sorcsd2by1.f:233
sorcsd
recursive subroutine sorcsd(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)
SORCSD
Definition sorcsd.f:300
slansy
real function slansy(norm, uplo, n, a, lda, work)
SLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slansy.f:122
ssyrk
subroutine ssyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
SSYRK
Definition ssyrk.f:169

◆ sdrges()

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

SDRGES

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

Definition at line 399 of file sdrges.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 REAL THRESH
411* ..
412* .. Array Arguments ..
413 LOGICAL BWORK( * ), DOTYPE( * )
414 INTEGER ISEED( 4 ), NN( * )
415 REAL 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 REAL ZERO, ONE
425 parameter( zero = 0.0e+0, one = 1.0e+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 REAL 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 REAL RMAGN( 0: 3 )
446* ..
447* .. External Functions ..
448 LOGICAL SLCTES
449 INTEGER ILAENV
450 REAL SLAMCH, SLARND
451 EXTERNAL slctes, ilaenv, slamch, slarnd
452* ..
453* .. External Subroutines ..
454 EXTERNAL alasvm, sget51, sget53, sget54, sgges, slabad,
455 $ slacpy, slarfg, slaset, slatm4, sorm2r, xerbla
456* ..
457* .. Intrinsic Functions ..
458 INTRINSIC abs, max, min, real, sign
459* ..
460* .. Data statements ..
461 DATA kclass / 15*1, 10*2, 1*3 /
462 DATA kz1 / 0, 1, 2, 1, 3, 3 /
463 DATA kz2 / 0, 0, 1, 2, 1, 1 /
464 DATA kadd / 0, 0, 0, 0, 3, 2 /
465 DATA katype / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
466 $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
467 DATA kbtype / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
468 $ 1, 1, -4, 2, -4, 8*8, 0 /
469 DATA kazero / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
470 $ 4*5, 4*3, 1 /
471 DATA kbzero / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
472 $ 4*6, 4*4, 1 /
473 DATA kamagn / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
474 $ 2, 1 /
475 DATA kbmagn / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
476 $ 2, 1 /
477 DATA ktrian / 16*0, 10*1 /
478 DATA 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, 'SGEQRF', ' ', nmax, nmax, -1, -1 ),
521 $ ilaenv( 1, 'SORMQR', 'LT', nmax, nmax, nmax, -1 ),
522 $ ilaenv( 1, 'SORGQR', ' ', 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( 'SDRGES', -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 = slamch( 'Safe minimum' )
541 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
542 safmin = safmin / ulp
543 safmax = one / safmin
544 CALL slabad( 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 / real( n1 )
562 rmagn( 3 ) = safmin*ulpinv*real( 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* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
595* =3 means random.
596* KATYPE: the "type" to be passed to SLATM4 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 slaset( 'Full', n, n, zero, zero, a, lda )
624 ELSE
625 in = n
626 END IF
627 CALL slatm4( 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 slaset( 'Full', n, n, zero, zero, b, lda )
642 ELSE
643 in = n
644 END IF
645 CALL slatm4( 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 ) = slarnd( 3, iseed )
664 z( jr, jc ) = slarnd( 3, iseed )
665 40 CONTINUE
666 CALL slarfg( 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 slarfg( 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, slarnd( 2, iseed ) )
678 z( n, n ) = one
679 work( 2*n ) = zero
680 work( 4*n ) = sign( one, slarnd( 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 sorm2r( '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 sorm2r( '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 sorm2r( '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 sorm2r( '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 $ slarnd( 2, iseed )
717 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
718 $ slarnd( 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 SGGES to compute H, T, Q, Z, alpha, and beta.
750*
751 CALL slacpy( 'Full', n, n, a, lda, s, lda )
752 CALL slacpy( 'Full', n, n, b, lda, t, lda )
753 ntest = 1 + rsub + isort
754 result( 1+rsub+isort ) = ulpinv
755 CALL sgges( 'V', 'V', sort, slctes, 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 )'SGGES', 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 sget51( 1, n, a, lda, s, lda, q, ldq, z, ldq,
772 $ work, result( 1 ) )
773 CALL sget51( 1, n, b, lda, t, lda, q, ldq, z, ldq,
774 $ work, result( 2 ) )
775 ELSE
776 CALL sget54( n, a, lda, b, lda, s, lda, t, lda, q,
777 $ ldq, z, ldq, work, result( 7 ) )
778 END IF
779 CALL sget51( 3, n, a, lda, t, lda, q, ldq, q, ldq, work,
780 $ result( 3+rsub ) )
781 CALL sget51( 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 sget53( 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( slctes( alphar( i ), alphai( i ),
862 $ beta( i ) ) .OR. slctes( alphar( i ),
863 $ -alphai( i ), beta( i ) ) ) THEN
864 knteig = knteig + 1
865 END IF
866 IF( i.LT.n ) THEN
867 IF( ( slctes( alphar( i+1 ), alphai( i+1 ),
868 $ beta( i+1 ) ) .OR. slctes( alphar( i+1 ),
869 $ -alphai( i+1 ), beta( i+1 ) ) ) .AND.
870 $ ( .NOT.( slctes( alphar( i ), alphai( i ),
871 $ beta( i ) ) .OR. slctes( 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 )'SGS'
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.0 ) 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( 'SGS', nounit, nerrs, ntestt, 0 )
931*
932 work( 1 ) = maxwrk
933*
934 RETURN
935*
936 9999 FORMAT( ' SDRGES: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
937 $ i6, ', JTYPE=', i6, ', ISEED=(', 4( i4, ',' ), i5, ')' )
938*
939 9998 FORMAT( ' SDRGES: SGET53 returned INFO=', i1, ' for eigenvalue ',
940 $ i6, '.', / 9x, 'N=', i6, ', JTYPE=', i6, ', ISEED=(',
941 $ 4( i4, ',' ), i5, ')' )
942*
943 9997 FORMAT( ' SDRGES: 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 SDRGES 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, e10.3 )
991*
992* End of SDRGES
993*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
sgges
subroutine sgges(jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb, sdim, alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, work, lwork, bwork, info)
SGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE m...
Definition sgges.f:284
slctes
logical function slctes(zr, zi, d)
SLCTES
Definition slctes.f:68
sget53
subroutine sget53(a, lda, b, ldb, scale, wr, wi, result, info)
SGET53
Definition sget53.f:126
sget54
subroutine sget54(n, a, lda, b, ldb, s, lds, t, ldt, u, ldu, v, ldv, work, result)
SGET54
Definition sget54.f:156

◆ sdrges3()

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

SDRGES3

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

Definition at line 399 of file sdrges3.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 REAL THRESH
411* ..
412* .. Array Arguments ..
413 LOGICAL BWORK( * ), DOTYPE( * )
414 INTEGER ISEED( 4 ), NN( * )
415 REAL 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 REAL ZERO, ONE
425 parameter( zero = 0.0e+0, one = 1.0e+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 REAL 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 REAL RMAGN( 0: 3 )
446* ..
447* .. External Functions ..
448 LOGICAL SLCTES
449 INTEGER ILAENV
450 REAL SLAMCH, SLARND
451 EXTERNAL slctes, ilaenv, slamch, slarnd
452* ..
453* .. External Subroutines ..
454 EXTERNAL alasvm, sget51, sget53, sget54, sgges3, slabad,
455 $ slacpy, slarfg, slaset, slatm4, sorm2r, xerbla
456* ..
457* .. Intrinsic Functions ..
458 INTRINSIC abs, max, min, real, sign
459* ..
460* .. Data statements ..
461 DATA kclass / 15*1, 10*2, 1*3 /
462 DATA kz1 / 0, 1, 2, 1, 3, 3 /
463 DATA kz2 / 0, 0, 1, 2, 1, 1 /
464 DATA kadd / 0, 0, 0, 0, 3, 2 /
465 DATA katype / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
466 $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
467 DATA kbtype / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
468 $ 1, 1, -4, 2, -4, 8*8, 0 /
469 DATA kazero / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
470 $ 4*5, 4*3, 1 /
471 DATA kbzero / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
472 $ 4*6, 4*4, 1 /
473 DATA kamagn / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
474 $ 2, 1 /
475 DATA kbmagn / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
476 $ 2, 1 /
477 DATA ktrian / 16*0, 10*1 /
478 DATA 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, 'SGEQRF', ' ', nmax, nmax, -1, -1 ),
521 $ ilaenv( 1, 'SORMQR', 'LT', nmax, nmax, nmax, -1 ),
522 $ ilaenv( 1, 'SORGQR', ' ', 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( 'SDRGES3', -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 = slamch( 'Safe minimum' )
541 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
542 safmin = safmin / ulp
543 safmax = one / safmin
544 CALL slabad( 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 / real( n1 )
562 rmagn( 3 ) = safmin*ulpinv*real( 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* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
595* =3 means random.
596* KATYPE: the "type" to be passed to SLATM4 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 slaset( 'Full', n, n, zero, zero, a, lda )
624 ELSE
625 in = n
626 END IF
627 CALL slatm4( 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 slaset( 'Full', n, n, zero, zero, b, lda )
642 ELSE
643 in = n
644 END IF
645 CALL slatm4( 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 ) = slarnd( 3, iseed )
664 z( jr, jc ) = slarnd( 3, iseed )
665 40 CONTINUE
666 CALL slarfg( 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 slarfg( 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, slarnd( 2, iseed ) )
678 z( n, n ) = one
679 work( 2*n ) = zero
680 work( 4*n ) = sign( one, slarnd( 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 sorm2r( '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 sorm2r( '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 sorm2r( '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 sorm2r( '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 $ slarnd( 2, iseed )
717 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
718 $ slarnd( 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 SLAQZ0
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 SGGES3 to compute H, T, Q, Z, alpha, and beta.
758*
759 CALL slacpy( 'Full', n, n, a, lda, s, lda )
760 CALL slacpy( 'Full', n, n, b, lda, t, lda )
761 ntest = 1 + rsub + isort
762 result( 1+rsub+isort ) = ulpinv
763 CALL sgges3( 'V', 'V', sort, slctes, 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 )'SGGES3', 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 sget51( 1, n, a, lda, s, lda, q, ldq, z, ldq,
780 $ work, result( 1 ) )
781 CALL sget51( 1, n, b, lda, t, lda, q, ldq, z, ldq,
782 $ work, result( 2 ) )
783 ELSE
784 CALL sget54( n, a, lda, b, lda, s, lda, t, lda, q,
785 $ ldq, z, ldq, work, result( 7 ) )
786 END IF
787 CALL sget51( 3, n, a, lda, t, lda, q, ldq, q, ldq, work,
788 $ result( 3+rsub ) )
789 CALL sget51( 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 sget53( 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( slctes( alphar( i ), alphai( i ),
870 $ beta( i ) ) .OR. slctes( alphar( i ),
871 $ -alphai( i ), beta( i ) ) ) THEN
872 knteig = knteig + 1
873 END IF
874 IF( i.LT.n ) THEN
875 IF( ( slctes( alphar( i+1 ), alphai( i+1 ),
876 $ beta( i+1 ) ) .OR. slctes( alphar( i+1 ),
877 $ -alphai( i+1 ), beta( i+1 ) ) ) .AND.
878 $ ( .NOT.( slctes( alphar( i ), alphai( i ),
879 $ beta( i ) ) .OR. slctes( 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 )'SGS'
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.0 ) 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( 'SGS', nounit, nerrs, ntestt, 0 )
939*
940 work( 1 ) = maxwrk
941*
942 RETURN
943*
944 9999 FORMAT( ' SDRGES3: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
945 $ i6, ', JTYPE=', i6, ', ISEED=(', 4( i4, ',' ), i5, ')' )
946*
947 9998 FORMAT( ' SDRGES3: SGET53 returned INFO=', i1, ' for eigenvalue ',
948 $ i6, '.', / 9x, 'N=', i6, ', JTYPE=', i6, ', ISEED=(',
949 $ 4( i4, ',' ), i5, ')' )
950*
951 9997 FORMAT( ' SDRGES3: 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 SDRGES3 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, e10.3 )
999*
1000* End of SDRGES3
1001*
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
sgges3
subroutine sgges3(jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb, sdim, alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, work, lwork, bwork, info)
SGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition sgges3.f:282

◆ sdrgev()

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

SDRGEV

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

Definition at line 404 of file sdrgev.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 REAL THRESH
417* ..
418* .. Array Arguments ..
419 LOGICAL DOTYPE( * )
420 INTEGER ISEED( 4 ), NN( * )
421 REAL A( LDA, * ), ALPHAI( * ), ALPHI1( * ),
422 $ ALPHAR( * ), 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 REAL ZERO, ONE
432 parameter( zero = 0.0e+0, one = 1.0e+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 REAL 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 REAL RMAGN( 0: 3 )
451* ..
452* .. External Functions ..
453 INTEGER ILAENV
454 REAL SLAMCH, SLARND
455 EXTERNAL ilaenv, slamch, slarnd
456* ..
457* .. External Subroutines ..
458 EXTERNAL alasvm, sget52, sggev, slabad, slacpy, slarfg,
459 $ slaset, slatm4, sorm2r, xerbla
460* ..
461* .. Intrinsic Functions ..
462 INTRINSIC abs, max, min, real, 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, 'SGEQRF', ' ', 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( 'SDRGEV', -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 = slamch( 'Safe minimum' )
546 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
547 safmin = safmin / ulp
548 safmax = one / safmin
549 CALL slabad( safmin, safmax )
550 ulpinv = one / ulp
551*
552* The values RMAGN(2:3) depend on N, see below.
553*
554 rmagn( 0 ) = zero
555 rmagn( 1 ) = one
556*
557* Loop over sizes, types
558*
559 ntestt = 0
560 nerrs = 0
561 nmats = 0
562*
563 DO 220 jsize = 1, nsizes
564 n = nn( jsize )
565 n1 = max( 1, n )
566 rmagn( 2 ) = safmax*ulp / real( n1 )
567 rmagn( 3 ) = safmin*ulpinv*n1
568*
569 IF( nsizes.NE.1 ) THEN
570 mtypes = min( maxtyp, ntypes )
571 ELSE
572 mtypes = min( maxtyp+1, ntypes )
573 END IF
574*
575 DO 210 jtype = 1, mtypes
576 IF( .NOT.dotype( jtype ) )
577 $ GO TO 210
578 nmats = nmats + 1
579*
580* Save ISEED in case of an error.
581*
582 DO 20 j = 1, 4
583 ioldsd( j ) = iseed( j )
584 20 CONTINUE
585*
586* Generate test matrices A and B
587*
588* Description of control parameters:
589*
590* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
591* =3 means random.
592* KATYPE: the "type" to be passed to SLATM4 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 slaset( 'Full', n, n, zero, zero, a, lda )
620 ELSE
621 in = n
622 END IF
623 CALL slatm4( 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 slaset( 'Full', n, n, zero, zero, b, lda )
638 ELSE
639 in = n
640 END IF
641 CALL slatm4( 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 ) = slarnd( 3, iseed )
660 z( jr, jc ) = slarnd( 3, iseed )
661 30 CONTINUE
662 CALL slarfg( 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 slarfg( 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, slarnd( 2, iseed ) )
674 z( n, n ) = one
675 work( 2*n ) = zero
676 work( 4*n ) = sign( one, slarnd( 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 sorm2r( '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 sorm2r( '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 sorm2r( '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 sorm2r( '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 $ slarnd( 2, iseed )
713 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
714 $ slarnd( 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 SGGEV to compute eigenvalues and eigenvectors.
735*
736 CALL slacpy( ' ', n, n, a, lda, s, lda )
737 CALL slacpy( ' ', n, n, b, lda, t, lda )
738 CALL sggev( '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 )'SGGEV1', 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 sget52( .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', 'SGGEV1',
754 $ result( 2 ), n, jtype, ioldsd
755 END IF
756*
757* Do the tests (3) and (4)
758*
759 CALL sget52( .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', 'SGGEV1',
763 $ result( 4 ), n, jtype, ioldsd
764 END IF
765*
766* Do the test (5)
767*
768 CALL slacpy( ' ', n, n, a, lda, s, lda )
769 CALL slacpy( ' ', n, n, b, lda, t, lda )
770 CALL sggev( '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 )'SGGEV2', 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 ) )
783 $ result( 5 ) = ulpinv
784 120 CONTINUE
785*
786* Do the test (6): Compute eigenvalues and left eigenvectors,
787* and test them
788*
789 CALL slacpy( ' ', n, n, a, lda, s, lda )
790 CALL slacpy( ' ', n, n, b, lda, t, lda )
791 CALL sggev( '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 )'SGGEV3', 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 ) )
804 $ result( 6 ) = ulpinv
805 130 CONTINUE
806*
807 DO 150 j = 1, n
808 DO 140 jc = 1, n
809 IF( q( j, jc ).NE.qe( j, jc ) )
810 $ result( 6 ) = ulpinv
811 140 CONTINUE
812 150 CONTINUE
813*
814* DO the test (7): Compute eigenvalues and right eigenvectors,
815* and test them
816*
817 CALL slacpy( ' ', n, n, a, lda, s, lda )
818 CALL slacpy( ' ', n, n, b, lda, t, lda )
819 CALL sggev( '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 )'SGGEV4', 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 ) )
832 $ result( 7 ) = 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 )'SGV'
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.0 ) 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( 'SGV', nounit, nerrs, ntestt, 0 )
887*
888 work( 1 ) = maxwrk
889*
890 RETURN
891*
892 9999 FORMAT( ' SDRGEV: ', a, ' returned INFO=', i6, '.', / 3x, 'N=',
893 $ i6, ', JTYPE=', i6, ', ISEED=(', 4( i4, ',' ), i5, ')' )
894*
895 9998 FORMAT( ' SDRGEV: ', 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 SDRGEV 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, e10.3 )
934*
935* End of SDRGEV
936*
sggev
subroutine sggev(jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai, beta, vl, ldvl, vr, ldvr, work, lwork, info)
SGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition sggev.f:226

◆ sdrgev3()

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

SDRGEV3

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

Definition at line 404 of file sdrgev3.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 REAL THRESH
417* ..
418* .. Array Arguments ..
419 LOGICAL DOTYPE( * )
420 INTEGER ISEED( 4 ), NN( * )
421 REAL A( LDA, * ), ALPHAI( * ), ALPHI1( * ),
422 $ ALPHAR( * ), 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 REAL ZERO, ONE
432 parameter( zero = 0.0e+0, one = 1.0e+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 REAL 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 REAL RMAGN( 0: 3 )
451* ..
452* .. External Functions ..
453 INTEGER ILAENV
454 REAL SLAMCH, SLARND
455 EXTERNAL ilaenv, slamch, slarnd
456* ..
457* .. External Subroutines ..
458 EXTERNAL alasvm, sget52, sggev3, slabad, slacpy, slarfg,
459 $ slaset, slatm4, sorm2r, xerbla
460* ..
461* .. Intrinsic Functions ..
462 INTRINSIC abs, max, min, real, 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, 'SGEQRF', ' ', 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( 'SDRGEV3', -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 = slamch( 'Safe minimum' )
546 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
547 safmin = safmin / ulp
548 safmax = one / safmin
549 CALL slabad( safmin, safmax )
550 ulpinv = one / ulp
551*
552* The values RMAGN(2:3) depend on N, see below.
553*
554 rmagn( 0 ) = zero
555 rmagn( 1 ) = one
556*
557* Loop over sizes, types
558*
559 ntestt = 0
560 nerrs = 0
561 nmats = 0
562*
563 DO 220 jsize = 1, nsizes
564 n = nn( jsize )
565 n1 = max( 1, n )
566 rmagn( 2 ) = safmax*ulp / real( n1 )
567 rmagn( 3 ) = safmin*ulpinv*n1
568*
569 IF( nsizes.NE.1 ) THEN
570 mtypes = min( maxtyp, ntypes )
571 ELSE
572 mtypes = min( maxtyp+1, ntypes )
573 END IF
574*
575 DO 210 jtype = 1, mtypes
576 IF( .NOT.dotype( jtype ) )
577 $ GO TO 210
578 nmats = nmats + 1
579*
580* Save ISEED in case of an error.
581*
582 DO 20 j = 1, 4
583 ioldsd( j ) = iseed( j )
584 20 CONTINUE
585*
586* Generate test matrices A and B
587*
588* Description of control parameters:
589*
590* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
591* =3 means random.
592* KATYPE: the "type" to be passed to SLATM4 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 slaset( 'Full', n, n, zero, zero, a, lda )
620 ELSE
621 in = n
622 END IF
623 CALL slatm4( 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 slaset( 'Full', n, n, zero, zero, b, lda )
638 ELSE
639 in = n
640 END IF
641 CALL slatm4( 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 ) = slarnd( 3, iseed )
660 z( jr, jc ) = slarnd( 3, iseed )
661 30 CONTINUE
662 CALL slarfg( 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 slarfg( 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, slarnd( 2, iseed ) )
674 z( n, n ) = one
675 work( 2*n ) = zero
676 work( 4*n ) = sign( one, slarnd( 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 sorm2r( '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 sorm2r( '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 sorm2r( '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 sorm2r( '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 $ slarnd( 2, iseed )
713 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
714 $ slarnd( 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 XLAENV to set the parameters used in SLAQZ0
735*
736 CALL xlaenv( 12, 10 )
737 CALL xlaenv( 13, 12 )
738 CALL xlaenv( 14, 13 )
739 CALL xlaenv( 15, 2 )
740 CALL xlaenv( 17, 10 )
741*
742* Call SGGEV3 to compute eigenvalues and eigenvectors.
743*
744 CALL slacpy( ' ', n, n, a, lda, s, lda )
745 CALL slacpy( ' ', n, n, b, lda, t, lda )
746 CALL sggev3( 'V', 'V', n, s, lda, t, lda, alphar, alphai,
747 $ beta, q, ldq, z, ldq, work, lwork, ierr )
748 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
749 result( 1 ) = ulpinv
750 WRITE( nounit, fmt = 9999 )'SGGEV31', ierr, n, jtype,
751 $ ioldsd
752 info = abs( ierr )
753 GO TO 190
754 END IF
755*
756* Do the tests (1) and (2)
757*
758 CALL sget52( .true., n, a, lda, b, lda, q, ldq, alphar,
759 $ alphai, beta, work, result( 1 ) )
760 IF( result( 2 ).GT.thresh ) THEN
761 WRITE( nounit, fmt = 9998 )'Left', 'SGGEV31',
762 $ result( 2 ), n, jtype, ioldsd
763 END IF
764*
765* Do the tests (3) and (4)
766*
767 CALL sget52( .false., n, a, lda, b, lda, z, ldq, alphar,
768 $ alphai, beta, work, result( 3 ) )
769 IF( result( 4 ).GT.thresh ) THEN
770 WRITE( nounit, fmt = 9998 )'Right', 'SGGEV31',
771 $ result( 4 ), n, jtype, ioldsd
772 END IF
773*
774* Do the test (5)
775*
776 CALL slacpy( ' ', n, n, a, lda, s, lda )
777 CALL slacpy( ' ', n, n, b, lda, t, lda )
778 CALL sggev3( 'N', 'N', n, s, lda, t, lda, alphr1, alphi1,
779 $ beta1, q, ldq, z, ldq, work, lwork, ierr )
780 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
781 result( 1 ) = ulpinv
782 WRITE( nounit, fmt = 9999 )'SGGEV32', ierr, n, jtype,
783 $ ioldsd
784 info = abs( ierr )
785 GO TO 190
786 END IF
787*
788 DO 120 j = 1, n
789 IF( alphar( j ).NE.alphr1( j ) .OR.
790 $ beta( j ).NE. beta1( j ) ) THEN
791 result( 5 ) = ulpinv
792 END IF
793 120 CONTINUE
794*
795* Do the test (6): Compute eigenvalues and left eigenvectors,
796* and test them
797*
798 CALL slacpy( ' ', n, n, a, lda, s, lda )
799 CALL slacpy( ' ', n, n, b, lda, t, lda )
800 CALL sggev3( 'V', 'N', n, s, lda, t, lda, alphr1, alphi1,
801 $ beta1, qe, ldqe, z, ldq, work, lwork, ierr )
802 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
803 result( 1 ) = ulpinv
804 WRITE( nounit, fmt = 9999 )'SGGEV33', ierr, n, jtype,
805 $ ioldsd
806 info = abs( ierr )
807 GO TO 190
808 END IF
809*
810 DO 130 j = 1, n
811 IF( alphar( j ).NE.alphr1( j ) .OR. alphai( j ).NE.
812 $ alphi1( j ) .OR. beta( j ).NE.beta1( j ) )
813 $ result( 6 ) = ulpinv
814 130 CONTINUE
815*
816 DO 150 j = 1, n
817 DO 140 jc = 1, n
818 IF( q( j, jc ).NE.qe( j, jc ) )
819 $ result( 6 ) = ulpinv
820 140 CONTINUE
821 150 CONTINUE
822*
823* DO the test (7): Compute eigenvalues and right eigenvectors,
824* and test them
825*
826 CALL slacpy( ' ', n, n, a, lda, s, lda )
827 CALL slacpy( ' ', n, n, b, lda, t, lda )
828 CALL sggev3( 'N', 'V', n, s, lda, t, lda, alphr1, alphi1,
829 $ beta1, q, ldq, qe, ldqe, work, lwork, ierr )
830 IF( ierr.NE.0 .AND. ierr.NE.n+1 ) THEN
831 result( 1 ) = ulpinv
832 WRITE( nounit, fmt = 9999 )'SGGEV34', ierr, n, jtype,
833 $ ioldsd
834 info = abs( ierr )
835 GO TO 190
836 END IF
837*
838 DO 160 j = 1, n
839 IF( alphar( j ).NE.alphr1( j ) .OR. alphai( j ).NE.
840 $ alphi1( j ) .OR. beta( j ).NE.beta1( j ) )
841 $ result( 7 ) = ulpinv
842 160 CONTINUE
843*
844 DO 180 j = 1, n
845 DO 170 jc = 1, n
846 IF( z( j, jc ).NE.qe( j, jc ) )
847 $ result( 7 ) = ulpinv
848 170 CONTINUE
849 180 CONTINUE
850*
851* End of Loop -- Check for RESULT(j) > THRESH
852*
853 190 CONTINUE
854*
855 ntestt = ntestt + 7
856*
857* Print out tests which fail.
858*
859 DO 200 jr = 1, 7
860 IF( result( jr ).GE.thresh ) THEN
861*
862* If this is the first test to fail,
863* print a header to the data file.
864*
865 IF( nerrs.EQ.0 ) THEN
866 WRITE( nounit, fmt = 9997 )'SGV'
867*
868* Matrix types
869*
870 WRITE( nounit, fmt = 9996 )
871 WRITE( nounit, fmt = 9995 )
872 WRITE( nounit, fmt = 9994 )'Orthogonal'
873*
874* Tests performed
875*
876 WRITE( nounit, fmt = 9993 )
877*
878 END IF
879 nerrs = nerrs + 1
880 IF( result( jr ).LT.10000.0 ) THEN
881 WRITE( nounit, fmt = 9992 )n, jtype, ioldsd, jr,
882 $ result( jr )
883 ELSE
884 WRITE( nounit, fmt = 9991 )n, jtype, ioldsd, jr,
885 $ result( jr )
886 END IF
887 END IF
888 200 CONTINUE
889*
890 210 CONTINUE
891 220 CONTINUE
892*
893* Summary
894*
895 CALL alasvm( 'SGV', nounit, nerrs, ntestt, 0 )
896*
897 work( 1 ) = maxwrk
898*
899 RETURN
900*
901 9999 FORMAT( ' SDRGEV3: ', a, ' returned INFO=', i6, '.', / 3x, 'N=',
902 $ i6, ', JTYPE=', i6, ', ISEED=(', 4( i4, ',' ), i5, ')' )
903*
904 9998 FORMAT( ' SDRGEV3: ', a, ' Eigenvectors from ', a,
905 $ ' incorrectly normalized.', / ' Bits of error=', 0p, g10.3,
906 $ ',', 3x, 'N=', i4, ', JTYPE=', i3, ', ISEED=(',
907 $ 4( i4, ',' ), i5, ')' )
908*
909 9997 FORMAT( / 1x, a3, ' -- Real Generalized eigenvalue problem driver'
910 $ )
911*
912 9996 FORMAT( ' Matrix types (see SDRGEV3 for details): ' )
913*
914 9995 FORMAT( ' Special Matrices:', 23x,
915 $ '(J''=transposed Jordan block)',
916 $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
917 $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
918 $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
919 $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
920 $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
921 $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
922 9994 FORMAT( ' Matrices Rotated by Random ', a, ' Matrices U, V:',
923 $ / ' 16=Transposed Jordan Blocks 19=geometric ',
924 $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
925 $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
926 $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
927 $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
928 $ '23=(small,large) 24=(small,small) 25=(large,large)',
929 $ / ' 26=random O(1) matrices.' )
930*
931 9993 FORMAT( / ' Tests performed: ',
932 $ / ' 1 = max | ( b A - a B )''*l | / const.,',
933 $ / ' 2 = | |VR(i)| - 1 | / ulp,',
934 $ / ' 3 = max | ( b A - a B )*r | / const.',
935 $ / ' 4 = | |VL(i)| - 1 | / ulp,',
936 $ / ' 5 = 0 if W same no matter if r or l computed,',
937 $ / ' 6 = 0 if l same no matter if l computed,',
938 $ / ' 7 = 0 if r same no matter if r computed,', / 1x )
939 9992 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
940 $ 4( i4, ',' ), ' result ', i2, ' is', 0p, f8.2 )
941 9991 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
942 $ 4( i4, ',' ), ' result ', i2, ' is', 1p, e10.3 )
943*
944* End of SDRGEV3
945*
sggev3
subroutine sggev3(jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai, beta, vl, ldvl, vr, ldvr, work, lwork, info)
SGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (...
Definition sggev3.f:226

◆ sdrgsx()

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

SDRGSX

Purpose:
!>
!> SDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
!> problem expert driver SGGESX.
!>
!> SGGESX 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 SDRGSX is called with NSIZE > 0, five (5) types of built-in
!> matrix pairs are used to test the routine SGGESX.
!>
!> When SDRGSX is called with NSIZE = 0, it reads in test matrix data
!> to test SGGESX.
!>
!> 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 SGGESX, 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 SGESVD) is used for computing the true value of DIF_u
!> and DIF_l when testing the built-in test problems.
!>
!> Built-in Test Matrices
!> ======================
!>
!> All built-in test matrices are the 2 by 2 block of triangular
!> matrices
!>
!>          A = [ A11 A12 ]    and      B = [ B11 B12 ]
!>              [     A22 ]                 [     B22 ]
!>
!> where for different type of A11 and A22 are given as the following.
!> A12 and B12 are chosen so that the generalized Sylvester equation
!>
!>          A11*R - L*A22 = -A12
!>          B11*R - L*B22 = -B12
!>
!> have prescribed solution R and L.
!>
!> Type 1:  A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
!>          B11 = I_m, B22 = I_k
!>          where J_k(a,b) is the k-by-k Jordan block with ``a'' on
!>          diagonal and ``b'' on superdiagonal.
!>
!> Type 2:  A11 = (a_ij) = ( 2(.5-sin(i)) ) and
!>          B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
!>          A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
!>          B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
!>
!> Type 3:  A11, A22 and B11, B22 are chosen as for Type 2, but each
!>          second diagonal block in A_11 and each third diagonal block
!>          in A_22 are made as 2 by 2 blocks.
!>
!> Type 4:  A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
!>             for i=1,...,m,  j=1,...,m and
!>          A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
!>             for i=m+1,...,k,  j=m+1,...,k
!>
!> Type 5:  (A,B) and have potentially close or common eigenvalues and
!>          very large departure from block diagonality A_11 is chosen
!>          as the m x m leading submatrix of A_1:
!>                  |  1  b                            |
!>                  | -b  1                            |
!>                  |        1+d  b                    |
!>                  |         -b 1+d                   |
!>           A_1 =  |                  d  1            |
!>                  |                 -1  d            |
!>                  |                        -d  1     |
!>                  |                        -1 -d     |
!>                  |                               1  |
!>          and A_22 is chosen as the k x k leading submatrix of A_2:
!>                  | -1  b                            |
!>                  | -b -1                            |
!>                  |       1-d  b                     |
!>                  |       -b  1-d                    |
!>           A_2 =  |                 d 1+b            |
!>                  |               -1-b d             |
!>                  |                       -d  1+b    |
!>                  |                      -1+b  -d    |
!>                  |                              1-d |
!>          and matrix B are chosen as identity matrices (see SLATM5).
!>
!>
Parameters
[in]NSIZE
!>          NSIZE is INTEGER
!>          The maximum size of the matrices to use. NSIZE >= 0.
!>          If NSIZE = 0, no built-in tests matrices are used, but
!>          read-in test matrices are used to test SGGESX.
!>
[in]NCMAX
!>          NCMAX is INTEGER
!>          Maximum allowable NMAX for generating Kroneker matrix
!>          in call to SLAKF2
!>
[in]THRESH
!>          THRESH is REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  THRESH >= 0.
!>
[in]NIN
!>          NIN is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>
[out]A
!>          A is REAL 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 REAL 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 REAL array, dimension (LDA, NSIZE)
!>          Copy of A, modified by SGGESX.
!>
[out]BI
!>          BI is REAL array, dimension (LDA, NSIZE)
!>          Copy of B, modified by SGGESX.
!>
[out]Z
!>          Z is REAL array, dimension (LDA, NSIZE)
!>          Z holds the left Schur vectors computed by SGGESX.
!>
[out]Q
!>          Q is REAL array, dimension (LDA, NSIZE)
!>          Q holds the right Schur vectors computed by SGGESX.
!>
[out]ALPHAR
!>          ALPHAR is REAL array, dimension (NSIZE)
!>
[out]ALPHAI
!>          ALPHAI is REAL array, dimension (NSIZE)
!>
[out]BETA
!>          BETA is REAL array, dimension (NSIZE)
!> \verbatim
!>          On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
!>
[out]C
!>          C is REAL array, dimension (LDC, LDC)
!>          Store the matrix generated by subroutine SLAKF2, this is the
!>          matrix formed by Kronecker products used for estimating
!>          DIF.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
!>
[out]S
!>          S is REAL array, dimension (LDC)
!>          Singular values of C
!>
[out]WORK
!>          WORK is REAL 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 sdrgsx.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 REAL THRESH
368* ..
369* .. Array Arguments ..
370 LOGICAL BWORK( * )
371 INTEGER IWORK( * )
372 REAL 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 REAL ZERO, ONE, TEN
382 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 1.0e+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 REAL ABNRM, BIGNUM, DIFTRU, PLTRU, SMLNUM, TEMP1,
391 $ TEMP2, THRSH2, ULP, ULPINV, WEIGHT
392* ..
393* .. Local Arrays ..
394 REAL DIFEST( 2 ), PL( 2 ), RESULT( 10 )
395* ..
396* .. External Functions ..
397 LOGICAL SLCTSX
398 INTEGER ILAENV
399 REAL SLAMCH, SLANGE
400 EXTERNAL slctsx, ilaenv, slamch, slange
401* ..
402* .. External Subroutines ..
403 EXTERNAL alasvm, sgesvd, sget51, sget53, sggesx, slabad,
404 $ slacpy, slakf2, slaset, slatm5, 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
445c MINWRK = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2-2 )
446 minwrk = max( 10*( nsize+1 ), 5*nsize*nsize / 2 )
447*
448* workspace for sggesx
449*
450 maxwrk = 9*( nsize+1 ) + nsize*
451 $ ilaenv( 1, 'SGEQRF', ' ', nsize, 1, nsize, 0 )
452 maxwrk = max( maxwrk, 9*( nsize+1 )+nsize*
453 $ ilaenv( 1, 'SORGQR', ' ', nsize, 1, nsize, -1 ) )
454*
455* workspace for sgesvd
456*
457 bdspac = 5*nsize*nsize / 2
458 maxwrk = max( maxwrk, 3*nsize*nsize / 2+nsize*nsize*
459 $ ilaenv( 1, 'SGEBRD', ' ', nsize*nsize / 2,
460 $ nsize*nsize / 2, -1, -1 ) )
461 maxwrk = max( maxwrk, bdspac )
462*
463 maxwrk = max( maxwrk, minwrk )
464*
465 work( 1 ) = maxwrk
466 END IF
467*
468 IF( lwork.LT.minwrk )
469 $ info = -19
470*
471 IF( info.NE.0 ) THEN
472 CALL xerbla( 'SDRGSX', -info )
473 RETURN
474 END IF
475*
476* Important constants
477*
478 ulp = slamch( 'P' )
479 ulpinv = one / ulp
480 smlnum = slamch( 'S' ) / ulp
481 bignum = one / smlnum
482 CALL slabad( smlnum, bignum )
483 thrsh2 = ten*thresh
484 ntestt = 0
485 nerrs = 0
486*
487* Go to the tests for read-in matrix pairs
488*
489 ifunc = 0
490 IF( nsize.EQ.0 )
491 $ GO TO 70
492*
493* Test the built-in matrix pairs.
494* Loop over different functions (IFUNC) of SGGESX, types (PRTYPE)
495* of test matrices, different size (M+N)
496*
497 prtype = 0
498 qba = 3
499 qbb = 4
500 weight = sqrt( ulp )
501*
502 DO 60 ifunc = 0, 3
503 DO 50 prtype = 1, 5
504 DO 40 m = 1, nsize - 1
505 DO 30 n = 1, nsize - m
506*
507 weight = one / weight
508 mplusn = m + n
509*
510* Generate test matrices
511*
512 fs = .true.
513 k = 0
514*
515 CALL slaset( 'Full', mplusn, mplusn, zero, zero, ai,
516 $ lda )
517 CALL slaset( 'Full', mplusn, mplusn, zero, zero, bi,
518 $ lda )
519*
520 CALL slatm5( prtype, m, n, ai, lda, ai( m+1, m+1 ),
521 $ lda, ai( 1, m+1 ), lda, bi, lda,
522 $ bi( m+1, m+1 ), lda, bi( 1, m+1 ), lda,
523 $ q, lda, z, lda, weight, qba, qbb )
524*
525* Compute the Schur factorization and swapping the
526* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
527* Swapping is accomplished via the function SLCTSX
528* which is supplied below.
529*
530 IF( ifunc.EQ.0 ) THEN
531 sense = 'N'
532 ELSE IF( ifunc.EQ.1 ) THEN
533 sense = 'E'
534 ELSE IF( ifunc.EQ.2 ) THEN
535 sense = 'V'
536 ELSE IF( ifunc.EQ.3 ) THEN
537 sense = 'B'
538 END IF
539*
540 CALL slacpy( 'Full', mplusn, mplusn, ai, lda, a, lda )
541 CALL slacpy( 'Full', mplusn, mplusn, bi, lda, b, lda )
542*
543 CALL sggesx( 'V', 'V', 'S', slctsx, sense, mplusn, ai,
544 $ lda, bi, lda, mm, alphar, alphai, beta,
545 $ q, lda, z, lda, pl, difest, work, lwork,
546 $ iwork, liwork, bwork, linfo )
547*
548 IF( linfo.NE.0 .AND. linfo.NE.mplusn+2 ) THEN
549 result( 1 ) = ulpinv
550 WRITE( nout, fmt = 9999 )'SGGESX', linfo, mplusn,
551 $ prtype
552 info = linfo
553 GO TO 30
554 END IF
555*
556* Compute the norm(A, B)
557*
558 CALL slacpy( 'Full', mplusn, mplusn, ai, lda, work,
559 $ mplusn )
560 CALL slacpy( 'Full', mplusn, mplusn, bi, lda,
561 $ work( mplusn*mplusn+1 ), mplusn )
562 abnrm = slange( 'Fro', mplusn, 2*mplusn, work, mplusn,
563 $ work )
564*
565* Do tests (1) to (4)
566*
567 CALL sget51( 1, mplusn, a, lda, ai, lda, q, lda, z,
568 $ lda, work, result( 1 ) )
569 CALL sget51( 1, mplusn, b, lda, bi, lda, q, lda, z,
570 $ lda, work, result( 2 ) )
571 CALL sget51( 3, mplusn, b, lda, bi, lda, q, lda, q,
572 $ lda, work, result( 3 ) )
573 CALL sget51( 3, mplusn, b, lda, bi, lda, z, lda, z,
574 $ lda, work, result( 4 ) )
575 ntest = 4
576*
577* Do tests (5) and (6): check Schur form of A and
578* compare eigenvalues with diagonals.
579*
580 temp1 = zero
581 result( 5 ) = zero
582 result( 6 ) = zero
583*
584 DO 10 j = 1, mplusn
585 ilabad = .false.
586 IF( alphai( j ).EQ.zero ) THEN
587 temp2 = ( abs( alphar( j )-ai( j, j ) ) /
588 $ max( smlnum, abs( alphar( j ) ),
589 $ abs( ai( j, j ) ) )+
590 $ abs( beta( j )-bi( j, j ) ) /
591 $ max( smlnum, abs( beta( j ) ),
592 $ abs( bi( j, j ) ) ) ) / ulp
593 IF( j.LT.mplusn ) THEN
594 IF( ai( j+1, j ).NE.zero ) THEN
595 ilabad = .true.
596 result( 5 ) = ulpinv
597 END IF
598 END IF
599 IF( j.GT.1 ) THEN
600 IF( ai( j, j-1 ).NE.zero ) THEN
601 ilabad = .true.
602 result( 5 ) = ulpinv
603 END IF
604 END IF
605 ELSE
606 IF( alphai( j ).GT.zero ) THEN
607 i1 = j
608 ELSE
609 i1 = j - 1
610 END IF
611 IF( i1.LE.0 .OR. i1.GE.mplusn ) THEN
612 ilabad = .true.
613 ELSE IF( i1.LT.mplusn-1 ) THEN
614 IF( ai( i1+2, i1+1 ).NE.zero ) THEN
615 ilabad = .true.
616 result( 5 ) = ulpinv
617 END IF
618 ELSE IF( i1.GT.1 ) THEN
619 IF( ai( i1, i1-1 ).NE.zero ) THEN
620 ilabad = .true.
621 result( 5 ) = ulpinv
622 END IF
623 END IF
624 IF( .NOT.ilabad ) THEN
625 CALL sget53( ai( i1, i1 ), lda, bi( i1, i1 ),
626 $ lda, beta( j ), alphar( j ),
627 $ alphai( j ), temp2, iinfo )
628 IF( iinfo.GE.3 ) THEN
629 WRITE( nout, fmt = 9997 )iinfo, j,
630 $ mplusn, prtype
631 info = abs( iinfo )
632 END IF
633 ELSE
634 temp2 = ulpinv
635 END IF
636 END IF
637 temp1 = max( temp1, temp2 )
638 IF( ilabad ) THEN
639 WRITE( nout, fmt = 9996 )j, mplusn, prtype
640 END IF
641 10 CONTINUE
642 result( 6 ) = temp1
643 ntest = ntest + 2
644*
645* Test (7) (if sorting worked)
646*
647 result( 7 ) = zero
648 IF( linfo.EQ.mplusn+3 ) THEN
649 result( 7 ) = ulpinv
650 ELSE IF( mm.NE.n ) THEN
651 result( 7 ) = ulpinv
652 END IF
653 ntest = ntest + 1
654*
655* Test (8): compare the estimated value DIF and its
656* value. first, compute the exact DIF.
657*
658 result( 8 ) = zero
659 mn2 = mm*( mplusn-mm )*2
660 IF( ifunc.GE.2 .AND. mn2.LE.ncmax*ncmax ) THEN
661*
662* Note: for either following two causes, there are
663* almost same number of test cases fail the test.
664*
665 CALL slakf2( mm, mplusn-mm, ai, lda,
666 $ ai( mm+1, mm+1 ), bi,
667 $ bi( mm+1, mm+1 ), c, ldc )
668*
669 CALL sgesvd( 'N', 'N', mn2, mn2, c, ldc, s, work,
670 $ 1, work( 2 ), 1, work( 3 ), lwork-2,
671 $ info )
672 diftru = s( mn2 )
673*
674 IF( difest( 2 ).EQ.zero ) THEN
675 IF( diftru.GT.abnrm*ulp )
676 $ result( 8 ) = ulpinv
677 ELSE IF( diftru.EQ.zero ) THEN
678 IF( difest( 2 ).GT.abnrm*ulp )
679 $ result( 8 ) = ulpinv
680 ELSE IF( ( diftru.GT.thrsh2*difest( 2 ) ) .OR.
681 $ ( diftru*thrsh2.LT.difest( 2 ) ) ) THEN
682 result( 8 ) = max( diftru / difest( 2 ),
683 $ difest( 2 ) / diftru )
684 END IF
685 ntest = ntest + 1
686 END IF
687*
688* Test (9)
689*
690 result( 9 ) = zero
691 IF( linfo.EQ.( mplusn+2 ) ) THEN
692 IF( diftru.GT.abnrm*ulp )
693 $ result( 9 ) = ulpinv
694 IF( ( ifunc.GT.1 ) .AND. ( difest( 2 ).NE.zero ) )
695 $ result( 9 ) = ulpinv
696 IF( ( ifunc.EQ.1 ) .AND. ( pl( 1 ).NE.zero ) )
697 $ result( 9 ) = ulpinv
698 ntest = ntest + 1
699 END IF
700*
701 ntestt = ntestt + ntest
702*
703* Print out tests which fail.
704*
705 DO 20 j = 1, 9
706 IF( result( j ).GE.thresh ) THEN
707*
708* If this is the first test to fail,
709* print a header to the data file.
710*
711 IF( nerrs.EQ.0 ) THEN
712 WRITE( nout, fmt = 9995 )'SGX'
713*
714* Matrix types
715*
716 WRITE( nout, fmt = 9993 )
717*
718* Tests performed
719*
720 WRITE( nout, fmt = 9992 )'orthogonal', '''',
721 $ 'transpose', ( '''', i = 1, 4 )
722*
723 END IF
724 nerrs = nerrs + 1
725 IF( result( j ).LT.10000.0 ) THEN
726 WRITE( nout, fmt = 9991 )mplusn, prtype,
727 $ weight, m, j, result( j )
728 ELSE
729 WRITE( nout, fmt = 9990 )mplusn, prtype,
730 $ weight, m, j, result( j )
731 END IF
732 END IF
733 20 CONTINUE
734*
735 30 CONTINUE
736 40 CONTINUE
737 50 CONTINUE
738 60 CONTINUE
739*
740 GO TO 150
741*
742 70 CONTINUE
743*
744* Read in data from file to check accuracy of condition estimation
745* Read input data until N=0
746*
747 nptknt = 0
748*
749 80 CONTINUE
750 READ( nin, fmt = *, END = 140 )mplusn
751 IF( mplusn.EQ.0 )
752 $ GO TO 140
753 READ( nin, fmt = *, END = 140 )n
754 DO 90 i = 1, mplusn
755 READ( nin, fmt = * )( ai( i, j ), j = 1, mplusn )
756 90 CONTINUE
757 DO 100 i = 1, mplusn
758 READ( nin, fmt = * )( bi( i, j ), j = 1, mplusn )
759 100 CONTINUE
760 READ( nin, fmt = * )pltru, diftru
761*
762 nptknt = nptknt + 1
763 fs = .true.
764 k = 0
765 m = mplusn - n
766*
767 CALL slacpy( 'Full', mplusn, mplusn, ai, lda, a, lda )
768 CALL slacpy( 'Full', mplusn, mplusn, bi, lda, b, lda )
769*
770* Compute the Schur factorization while swapping the
771* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
772*
773 CALL sggesx( 'V', 'V', 'S', slctsx, 'B', mplusn, ai, lda, bi, lda,
774 $ mm, alphar, alphai, beta, q, lda, z, lda, pl, difest,
775 $ work, lwork, iwork, liwork, bwork, linfo )
776*
777 IF( linfo.NE.0 .AND. linfo.NE.mplusn+2 ) THEN
778 result( 1 ) = ulpinv
779 WRITE( nout, fmt = 9998 )'SGGESX', linfo, mplusn, nptknt
780 GO TO 130
781 END IF
782*
783* Compute the norm(A, B)
784* (should this be norm of (A,B) or (AI,BI)?)
785*
786 CALL slacpy( 'Full', mplusn, mplusn, ai, lda, work, mplusn )
787 CALL slacpy( 'Full', mplusn, mplusn, bi, lda,
788 $ work( mplusn*mplusn+1 ), mplusn )
789 abnrm = slange( 'Fro', mplusn, 2*mplusn, work, mplusn, work )
790*
791* Do tests (1) to (4)
792*
793 CALL sget51( 1, mplusn, a, lda, ai, lda, q, lda, z, lda, work,
794 $ result( 1 ) )
795 CALL sget51( 1, mplusn, b, lda, bi, lda, q, lda, z, lda, work,
796 $ result( 2 ) )
797 CALL sget51( 3, mplusn, b, lda, bi, lda, q, lda, q, lda, work,
798 $ result( 3 ) )
799 CALL sget51( 3, mplusn, b, lda, bi, lda, z, lda, z, lda, work,
800 $ result( 4 ) )
801*
802* Do tests (5) and (6): check Schur form of A and compare
803* eigenvalues with diagonals.
804*
805 ntest = 6
806 temp1 = zero
807 result( 5 ) = zero
808 result( 6 ) = zero
809*
810 DO 110 j = 1, mplusn
811 ilabad = .false.
812 IF( alphai( j ).EQ.zero ) THEN
813 temp2 = ( abs( alphar( j )-ai( j, j ) ) /
814 $ max( smlnum, abs( alphar( j ) ), abs( ai( j,
815 $ j ) ) )+abs( beta( j )-bi( j, j ) ) /
816 $ max( smlnum, abs( beta( j ) ), abs( bi( j, j ) ) ) )
817 $ / ulp
818 IF( j.LT.mplusn ) THEN
819 IF( ai( j+1, j ).NE.zero ) THEN
820 ilabad = .true.
821 result( 5 ) = ulpinv
822 END IF
823 END IF
824 IF( j.GT.1 ) THEN
825 IF( ai( j, j-1 ).NE.zero ) THEN
826 ilabad = .true.
827 result( 5 ) = ulpinv
828 END IF
829 END IF
830 ELSE
831 IF( alphai( j ).GT.zero ) THEN
832 i1 = j
833 ELSE
834 i1 = j - 1
835 END IF
836 IF( i1.LE.0 .OR. i1.GE.mplusn ) THEN
837 ilabad = .true.
838 ELSE IF( i1.LT.mplusn-1 ) THEN
839 IF( ai( i1+2, i1+1 ).NE.zero ) THEN
840 ilabad = .true.
841 result( 5 ) = ulpinv
842 END IF
843 ELSE IF( i1.GT.1 ) THEN
844 IF( ai( i1, i1-1 ).NE.zero ) THEN
845 ilabad = .true.
846 result( 5 ) = ulpinv
847 END IF
848 END IF
849 IF( .NOT.ilabad ) THEN
850 CALL sget53( ai( i1, i1 ), lda, bi( i1, i1 ), lda,
851 $ beta( j ), alphar( j ), alphai( j ), temp2,
852 $ iinfo )
853 IF( iinfo.GE.3 ) THEN
854 WRITE( nout, fmt = 9997 )iinfo, j, mplusn, nptknt
855 info = abs( iinfo )
856 END IF
857 ELSE
858 temp2 = ulpinv
859 END IF
860 END IF
861 temp1 = max( temp1, temp2 )
862 IF( ilabad ) THEN
863 WRITE( nout, fmt = 9996 )j, mplusn, nptknt
864 END IF
865 110 CONTINUE
866 result( 6 ) = temp1
867*
868* Test (7) (if sorting worked) <--------- need to be checked.
869*
870 ntest = 7
871 result( 7 ) = zero
872 IF( linfo.EQ.mplusn+3 )
873 $ result( 7 ) = ulpinv
874*
875* Test (8): compare the estimated value of DIF and its true value.
876*
877 ntest = 8
878 result( 8 ) = zero
879 IF( difest( 2 ).EQ.zero ) THEN
880 IF( diftru.GT.abnrm*ulp )
881 $ result( 8 ) = ulpinv
882 ELSE IF( diftru.EQ.zero ) THEN
883 IF( difest( 2 ).GT.abnrm*ulp )
884 $ result( 8 ) = ulpinv
885 ELSE IF( ( diftru.GT.thrsh2*difest( 2 ) ) .OR.
886 $ ( diftru*thrsh2.LT.difest( 2 ) ) ) THEN
887 result( 8 ) = max( diftru / difest( 2 ), difest( 2 ) / diftru )
888 END IF
889*
890* Test (9)
891*
892 ntest = 9
893 result( 9 ) = zero
894 IF( linfo.EQ.( mplusn+2 ) ) THEN
895 IF( diftru.GT.abnrm*ulp )
896 $ result( 9 ) = ulpinv
897 IF( ( ifunc.GT.1 ) .AND. ( difest( 2 ).NE.zero ) )
898 $ result( 9 ) = ulpinv
899 IF( ( ifunc.EQ.1 ) .AND. ( pl( 1 ).NE.zero ) )
900 $ result( 9 ) = ulpinv
901 END IF
902*
903* Test (10): compare the estimated value of PL and it true value.
904*
905 ntest = 10
906 result( 10 ) = zero
907 IF( pl( 1 ).EQ.zero ) THEN
908 IF( pltru.GT.abnrm*ulp )
909 $ result( 10 ) = ulpinv
910 ELSE IF( pltru.EQ.zero ) THEN
911 IF( pl( 1 ).GT.abnrm*ulp )
912 $ result( 10 ) = ulpinv
913 ELSE IF( ( pltru.GT.thresh*pl( 1 ) ) .OR.
914 $ ( pltru*thresh.LT.pl( 1 ) ) ) THEN
915 result( 10 ) = ulpinv
916 END IF
917*
918 ntestt = ntestt + ntest
919*
920* Print out tests which fail.
921*
922 DO 120 j = 1, ntest
923 IF( result( j ).GE.thresh ) THEN
924*
925* If this is the first test to fail,
926* print a header to the data file.
927*
928 IF( nerrs.EQ.0 ) THEN
929 WRITE( nout, fmt = 9995 )'SGX'
930*
931* Matrix types
932*
933 WRITE( nout, fmt = 9994 )
934*
935* Tests performed
936*
937 WRITE( nout, fmt = 9992 )'orthogonal', '''',
938 $ 'transpose', ( '''', i = 1, 4 )
939*
940 END IF
941 nerrs = nerrs + 1
942 IF( result( j ).LT.10000.0 ) THEN
943 WRITE( nout, fmt = 9989 )nptknt, mplusn, j, result( j )
944 ELSE
945 WRITE( nout, fmt = 9988 )nptknt, mplusn, j, result( j )
946 END IF
947 END IF
948*
949 120 CONTINUE
950*
951 130 CONTINUE
952 GO TO 80
953 140 CONTINUE
954*
955 150 CONTINUE
956*
957* Summary
958*
959 CALL alasvm( 'SGX', nout, nerrs, ntestt, 0 )
960*
961 work( 1 ) = maxwrk
962*
963 RETURN
964*
965 9999 FORMAT( ' SDRGSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
966 $ i6, ', JTYPE=', i6, ')' )
967*
968 9998 FORMAT( ' SDRGSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
969 $ i6, ', Input Example #', i2, ')' )
970*
971 9997 FORMAT( ' SDRGSX: SGET53 returned INFO=', i1, ' for eigenvalue ',
972 $ i6, '.', / 9x, 'N=', i6, ', JTYPE=', i6, ')' )
973*
974 9996 FORMAT( ' SDRGSX: S not in Schur form at eigenvalue ', i6, '.',
975 $ / 9x, 'N=', i6, ', JTYPE=', i6, ')' )
976*
977 9995 FORMAT( / 1x, a3, ' -- Real Expert Generalized Schur form',
978 $ ' problem driver' )
979*
980 9994 FORMAT( 'Input Example' )
981*
982 9993 FORMAT( ' Matrix types: ', /
983 $ ' 1: A is a block diagonal matrix of Jordan blocks ',
984 $ 'and B is the identity ', / ' matrix, ',
985 $ / ' 2: A and B are upper triangular matrices, ',
986 $ / ' 3: A and B are as type 2, but each second diagonal ',
987 $ 'block in A_11 and ', /
988 $ ' each third diaongal block in A_22 are 2x2 blocks,',
989 $ / ' 4: A and B are block diagonal matrices, ',
990 $ / ' 5: (A,B) has potentially close or common ',
991 $ 'eigenvalues.', / )
992*
993 9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
994 $ 'Q and Z are ', a, ',', / 19x,
995 $ ' a is alpha, b is beta, and ', a, ' means ', a, '.)',
996 $ / ' 1 = | A - Q S Z', a,
997 $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', a,
998 $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', a,
999 $ ' | / ( n ulp ) 4 = | I - ZZ', a,
1000 $ ' | / ( n ulp )', / ' 5 = 1/ULP if A is not in ',
1001 $ 'Schur form S', / ' 6 = difference between (alpha,beta)',
1002 $ ' and diagonals of (S,T)', /
1003 $ ' 7 = 1/ULP if SDIM is not the correct number of ',
1004 $ 'selected eigenvalues', /
1005 $ ' 8 = 1/ULP if DIFEST/DIFTRU > 10*THRESH or ',
1006 $ 'DIFTRU/DIFEST > 10*THRESH',
1007 $ / ' 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B) ',
1008 $ 'when reordering fails', /
1009 $ ' 10 = 1/ULP if PLEST/PLTRU > THRESH or ',
1010 $ 'PLTRU/PLEST > THRESH', /
1011 $ ' ( Test 10 is only for input examples )', / )
1012 9991 FORMAT( ' Matrix order=', i2, ', type=', i2, ', a=', e10.3,
1013 $ ', order(A_11)=', i2, ', result ', i2, ' is ', 0p, f8.2 )
1014 9990 FORMAT( ' Matrix order=', i2, ', type=', i2, ', a=', e10.3,
1015 $ ', order(A_11)=', i2, ', result ', i2, ' is ', 0p, e10.3 )
1016 9989 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
1017 $ ' result ', i2, ' is', 0p, f8.2 )
1018 9988 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
1019 $ ' result ', i2, ' is', 1p, e10.3 )
1020*
1021* End of SDRGSX
1022*
sggesx
subroutine sggesx(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)
SGGESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition sggesx.f:365
sgesvd
subroutine sgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, info)
SGESVD computes the singular value decomposition (SVD) for GE matrices
Definition sgesvd.f:211
slatm5
subroutine slatm5(prtype, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, r, ldr, l, ldl, alpha, qblcka, qblckb)
SLATM5
Definition slatm5.f:268
slakf2
subroutine slakf2(m, n, a, lda, b, d, e, z, ldz)
SLAKF2
Definition slakf2.f:105
slctsx
logical function slctsx(ar, ai, beta)
SLCTSX
Definition slctsx.f:65

◆ sdrgvx()

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

SDRGVX

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

Definition at line 297 of file sdrgvx.f.

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

◆ sdrvbd()

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

SDRVBD

Purpose:
!>
!> SDRVBD checks the singular value decomposition (SVD) drivers
!> SGESVD, SGESDD, SGESVDQ, SGESVJ, SGEJSV, and DGESVDX.
!>
!> Both SGESVD and SGESDD 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 SDRVBD 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 SGESVD:
!>
!> (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 SGESDD:
!>
!> (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 SGESVDQ:
!>
!> (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 SGESVJ:
!>
!> (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 SGEJSV:
!>
!> (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 SGESVDX( 'V', 'V', 'A' )/SGESVDX( '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 SGESVDX( '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 SGESVDX( '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, SDRVBD
!>          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
!>          SDRVBD to continue the same random number sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  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 REAL 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 REAL array, dimension (LDU,MMAX)
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,MMAX).
!>
[out]VT
!>          VT is REAL array, dimension (LDVT,NMAX)
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.  LDVT >= max(1,NMAX).
!>
[out]ASAV
!>          ASAV is REAL array, dimension (LDA,NMAX)
!>
[out]USAV
!>          USAV is REAL array, dimension (LDU,MMAX)
!>
[out]VTSAV
!>          VTSAV is REAL array, dimension (LDVT,NMAX)
!>
[out]S
!>          S is REAL array, dimension
!>                      (max(min(MM,NN)))
!>
[out]SSAV
!>          SSAV is REAL array, dimension
!>                      (max(min(MM,NN)))
!>
[out]E
!>          E is REAL array, dimension
!>                      (max(min(MM,NN)))
!>
[out]WORK
!>          WORK is REAL 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  SLATMS, or SGESVD 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 sdrvbd.f.

366*
367* -- LAPACK test routine --
368* -- LAPACK is a software package provided by Univ. of Tennessee, --
369* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
370*
371 IMPLICIT NONE
372*
373* .. Scalar Arguments ..
374 INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUT, NSIZES,
375 $ NTYPES
376 REAL THRESH
377* ..
378* .. Array Arguments ..
379 LOGICAL DOTYPE( * )
380 INTEGER ISEED( 4 ), IWORK( * ), MM( * ), NN( * )
381 REAL 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 REAL ZERO, ONE, TWO, HALF
390 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
391 $ half = 0.5e0 )
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 REAL 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 REAL RWORK( 2 )
411* ..
412* .. Local Arrays ..
413 CHARACTER CJOB( 4 ), CJOBR( 3 ), CJOBV( 2 )
414 INTEGER IOLDSD( 4 ), ISEED2( 4 )
415 REAL RESULT( 39 )
416* ..
417* .. External Functions ..
418 REAL SLAMCH, SLARND
419 EXTERNAL slamch, slarnd
420* ..
421* .. External Subroutines ..
422 EXTERNAL alasvm, sbdt01, sgejsv, sgesdd, sgesvd,
423 $ sgesvdq, sgesvdx, sgesvj, slabad, slacpy,
424 $ slaset, slatms, sort01, sort03, xerbla
425* ..
426* .. Intrinsic Functions ..
427 INTRINSIC abs, real, 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( 'SDRVBD', -info )
489 RETURN
490 END IF
491*
492* Initialize constants
493*
494 path( 1: 1 ) = 'Single precision'
495 path( 2: 3 ) = 'BD'
496 nfail = 0
497 ntest = 0
498 unfl = slamch( 'Safe minimum' )
499 ovfl = one / unfl
500 CALL slabad( unfl, ovfl )
501 ulp = slamch( '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 slaset( 'Full', m, n, zero, zero, a, lda )
537*
538 ELSE IF( jtype.EQ.2 ) THEN
539*
540* Identity matrix
541*
542 CALL slaset( '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 slatms( m, n, 'U', iseed, 'N', s, 4, real( 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 slacpy( '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 SGESVD: 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 slacpy( 'F', m, n, asav, lda, a, lda )
586 srnamt = 'SGESVD'
587 CALL sgesvd( '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 sbdt01( 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 sort01( 'Columns', m, m, usav, ldu, work, lwork,
602 $ result( 2 ) )
603 CALL sort01( '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 slacpy( 'F', m, n, asav, lda, a, lda )
630 srnamt = 'SGESVD'
631 CALL sgesvd( 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 sort03( 'C', m, mnmin, m, mnmin, usav,
640 $ ldu, a, lda, work, lwork, dif,
641 $ iinfo )
642 ELSE IF( iju.EQ.2 ) THEN
643 CALL sort03( 'C', m, mnmin, m, mnmin, usav,
644 $ ldu, u, ldu, work, lwork, dif,
645 $ iinfo )
646 ELSE IF( iju.EQ.3 ) THEN
647 CALL sort03( '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 sort03( 'R', n, mnmin, n, mnmin, vtsav,
660 $ ldvt, a, lda, work, lwork, dif,
661 $ iinfo )
662 ELSE IF( ijvt.EQ.2 ) THEN
663 CALL sort03( 'R', n, mnmin, n, mnmin, vtsav,
664 $ ldvt, vt, ldvt, work, lwork,
665 $ dif, iinfo )
666 ELSE IF( ijvt.EQ.3 ) THEN
667 CALL sort03( '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 SGESDD: 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 slacpy( 'F', m, n, asav, lda, a, lda )
699 srnamt = 'SGESDD'
700 CALL sgesdd( '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 sbdt01( 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 sort01( 'Columns', m, m, usav, ldu, work, lwork,
715 $ result( 9 ) )
716 CALL sort01( '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 slacpy( 'F', m, n, asav, lda, a, lda )
739 srnamt = 'SGESDD'
740 CALL sgesdd( 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 sort03( 'C', m, mnmin, m, mnmin, usav,
750 $ ldu, a, lda, work, lwork, dif,
751 $ info )
752 ELSE
753 CALL sort03( '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 sort03( '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 sort03( 'R', n, mnmin, n, mnmin, vtsav,
771 $ ldvt, vt, ldvt, work, lwork,
772 $ dif, info )
773 ELSE
774 CALL sort03( '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 sort03( '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 SGESVDQ
801* Note: SGESVDQ 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 slacpy( 'F', m, n, asav, lda, a, lda )
817 srnamt = 'SGESVDQ'
818*
819 lrwork = 2
820 liwork = max( n, 1 )
821 CALL sgesvdq( '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 )'SGESVDQ', 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 sbdt01( 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 sort01( 'Columns', m, m, usav, ldu, work,
839 $ lwork, result( 37 ) )
840 CALL sort01( '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 SGESVJ
857* Note: SGESVJ 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 slacpy( 'F', m, n, asav, lda, usav, lda )
873 srnamt = 'SGESVJ'
874 CALL sgesvj( 'G', 'U', 'V', m, n, usav, lda, ssav,
875 & 0, a, ldvt, work, lwork, info )
876*
877* SGESVJ 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 sbdt01( 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 sort01( 'Columns', m, m, usav, ldu, work,
898 $ lwork, result( 16 ) )
899 CALL sort01( '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 SGEJSV
916* Note: SGEJSV 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 slacpy( 'F', m, n, asav, lda, vtsav, lda )
931 srnamt = 'SGEJSV'
932 CALL sgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
933 & m, n, vtsav, lda, ssav, usav, ldu, a, ldvt,
934 & work, lwork, iwork, info )
935*
936* SGEJSV 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 sbdt01( 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 sort01( 'Columns', m, m, usav, ldu, work,
957 $ lwork, result( 20 ) )
958 CALL sort01( '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 SGESVDX
975*
976 CALL slacpy( 'F', m, n, asav, lda, a, lda )
977 CALL sgesvdx( '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 sbdt01( 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 sort01( 'Columns', m, m, usav, ldu, work, lwork,
997 $ result( 24 ) )
998 CALL sort01( '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 slacpy( 'F', m, n, asav, lda, a, lda )
1026 CALL sgesvdx( 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 sort03( '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 sort03( '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: SGESVDX( '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 )*slarnd( 1, iseed2 ) )
1080 iu = 1 + int( ( mnmin-1 )*slarnd( 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 slacpy( 'F', m, n, asav, lda, a, lda )
1088 CALL sgesvdx( '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 sbdt05( m, n, asav, lda, s, nsi, u, ldu,
1103 $ vt, ldvt, work, result( 30 ) )
1104 CALL sort01( 'Columns', m, nsi, u, ldu, work, lwork,
1105 $ result( 31 ) )
1106 CALL sort01( 'Rows', nsi, n, vt, ldvt, work, lwork,
1107 $ result( 32 ) )
1108*
1109* Do tests 33--35: SGESVDX( '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 slacpy( 'F', m, n, asav, lda, a, lda )
1136 CALL sgesvdx( '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 sbdt05( m, n, asav, lda, s, nsv, u, ldu,
1151 $ vt, ldvt, work, result( 33 ) )
1152 CALL sort01( 'Columns', m, nsv, u, ldu, work, lwork,
1153 $ result( 34 ) )
1154 CALL sort01( '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 SDRVBD 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 $ ' SGESVDX(V,V,A) ',
1215 $ / '23 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ),'
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 $ ' SGESVDX(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 $ ' SGESVDX(V,V,V) ',
1229 $ / '34 = | I - U**T U | / ( M ulp ) ',
1230 $ / '35 = | I - VT VT**T | / ( N ulp ) ',
1231 $ ' SGESVDQ(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( ' SDRVBD: ', a, ' returned INFO=', i6, '.', / 9x, 'M=',
1241 $ i6, ', N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ),
1242 $ i5, ')' )
1243 9995 FORMAT( ' SDRVBD: ', 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 SDRVBD
1250*
sbdt05
subroutine sbdt05(m, n, a, lda, s, ns, u, ldu, vt, ldvt, work, resid)
SBDT05
Definition sbdt05.f:127
sgesvj
subroutine sgesvj(joba, jobu, jobv, m, n, a, lda, sva, mv, v, ldv, work, lwork, info)
SGESVJ
Definition sgesvj.f:323
sgesvdq
subroutine sgesvdq(joba, jobp, jobr, jobu, jobv, m, n, a, lda, s, u, ldu, v, ldv, numrank, iwork, liwork, work, lwork, rwork, lrwork, info)
SGESVDQ computes the singular value decomposition (SVD) with a QR-Preconditioned QR SVD Method for GE...
Definition sgesvdq.f:415
sgesvdx
subroutine sgesvdx(jobu, jobvt, range, m, n, a, lda, vl, vu, il, iu, ns, s, u, ldu, vt, ldvt, work, lwork, iwork, info)
SGESVDX computes the singular value decomposition (SVD) for GE matrices
Definition sgesvdx.f:263
sgesdd
subroutine sgesdd(jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, iwork, info)
SGESDD
Definition sgesdd.f:219
sgejsv
subroutine sgejsv(joba, jobu, jobv, jobr, jobt, jobp, m, n, a, lda, sva, u, ldu, v, ldv, work, lwork, iwork, info)
SGEJSV
Definition sgejsv.f:476
sort03
subroutine sort03(rc, mu, mv, n, k, u, ldu, v, ldv, work, lwork, result, info)
SORT03
Definition sort03.f:156

◆ sdrves()

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

SDRVES

Purpose:
!>
!>    SDRVES checks the nonsymmetric eigenvalue (Schur form) problem
!>    driver SGEES.
!>
!>    When SDRVES 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,
!>          SDRVES 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, SDRVES
!>          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 SDRVES to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is REAL 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 REAL array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by SGEES.
!>
[out]HT
!>          HT is REAL array, dimension (LDA, max(NN))
!>          Yet another copy of the test matrix A, modified by SGEES.
!>
[out]WR
!>          WR is REAL array, dimension (max(NN))
!>
[out]WI
!>          WI is REAL 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 REAL array, dimension (max(NN))
!>
[out]WIT
!>          WIT is REAL array, dimension (max(NN))
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when SGEES only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]VS
!>          VS is REAL array, dimension (LDVS, max(NN))
!>          VS holds the computed Schur vectors.
!>
[in]LDVS
!>          LDVS is INTEGER
!>          Leading dimension of VS. Must be at least max(1,max(NN)).
!>
[out]RESULT
!>          RESULT is REAL array, dimension (13)
!>          The values computed by the 13 tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]WORK
!>          WORK is REAL 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  SLATMR, SLATMS, SLATME or SGEES 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 sdrves.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 REAL THRESH
396* ..
397* .. Array Arguments ..
398 LOGICAL BWORK( * ), DOTYPE( * )
399 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
400 REAL A( LDA, * ), H( LDA, * ), HT( LDA, * ),
401 $ RESULT( 13 ), VS( LDVS, * ), WI( * ), WIT( * ),
402 $ WORK( * ), WR( * ), WRT( * )
403* ..
404*
405* =====================================================================
406*
407* .. Parameters ..
408 REAL ZERO, ONE
409 parameter( zero = 0.0e0, one = 1.0e0 )
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,
419 $ NERRS, NFAIL, NMAX, NNWORK, NTEST, NTESTF,
420 $ NTESTT, RSUB, SDIM
421 REAL 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 REAL RES( 2 )
430* ..
431* .. Arrays in Common ..
432 LOGICAL SELVAL( 20 )
433 REAL 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 SSLECT
443 REAL SLAMCH
444 EXTERNAL sslect, slamch
445* ..
446* .. External Subroutines ..
447 EXTERNAL sgees, shst01, slabad, slacpy, slasum, slatme,
448 $ slatmr, slatms, slaset, 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 ) = 'Single 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( 'SDRVES', -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 = slamch( 'Safe minimum' )
516 ovfl = one / unfl
517 CALL slabad( unfl, ovfl )
518 ulp = slamch( '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 slaset( '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 slatms( 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 slatms( 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 slatme( 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 slatmr( 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 slatmr( 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 slatmr( 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 slaset( 'Full', 2, n, zero, zero, a, lda )
674 CALL slaset( 'Full', n-3, 1, zero, zero, a( 3, 1 ),
675 $ lda )
676 CALL slaset( 'Full', n-3, 2, zero, zero, a( 3, n-1 ),
677 $ lda )
678 CALL slaset( '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 slatmr( 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 slacpy( 'F', n, n, a, lda, h, lda )
735 CALL sgees( 'V', sort, sslect, 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 )'SGEES1', 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 shst01( 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 slacpy( 'F', n, n, a, lda, ht, lda )
809 CALL sgees( 'N', sort, sslect, 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 )'SGEES2', 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( sslect( wr( i ), wi( i ) ) .OR.
843 $ sslect( wr( i ), -wi( i ) ) )
844 $ knteig = knteig + 1
845 IF( i.LT.n ) THEN
846 IF( ( sslect( wr( i+1 ),
847 $ wi( i+1 ) ) .OR. sslect( wr( i+1 ),
848 $ -wi( i+1 ) ) ) .AND.
849 $ ( .NOT.( sslect( wr( i ),
850 $ wi( i ) ) .OR. sslect( 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 slasum( path, nounit, nerrs, ntestt )
904*
905 9999 FORMAT( / 1x, a3, ' -- Real Schur Form Decomposition Driver',
906 $ / ' Matrix types (see SDRVES 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( ' SDRVES: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
952 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
953*
954 RETURN
955*
956* End of SDRVES
957*
sgees
subroutine sgees(jobvs, sort, select, n, a, lda, sdim, wr, wi, vs, ldvs, work, lwork, bwork, info)
SGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE m...
Definition sgees.f:216
sslect
logical function sslect(zr, zi)
SSLECT
Definition sslect.f:62

◆ sdrvev()

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

SDRVEV

Purpose:
!>
!>    SDRVEV  checks the nonsymmetric eigenvalue problem driver SGEEV.
!>
!>    When SDRVEV 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,
!>          SDRVEV 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, SDRVEV
!>          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 SDRVEV to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is REAL 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 REAL array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by SGEEV.
!>
[out]WR
!>          WR is REAL array, dimension (max(NN))
!>
[out]WI
!>          WI is REAL 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 REAL array, dimension (max(NN))
!>
[out]WI1
!>          WI1 is REAL array, dimension (max(NN))
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when SGEEV only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is REAL 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 REAL 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 REAL array, dimension (LDLRE,max(NN))
!>          LRE holds the computed right or left eigenvectors.
!>
[in]LDLRE
!>          LDLRE is INTEGER
!>          Leading dimension of LRE. Must be at least max(1,max(NN)).
!>
[out]RESULT
!>          RESULT is REAL array, dimension (7)
!>          The values computed by the seven tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]WORK
!>          WORK is REAL 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  SLATMR, SLATMS, SLATME or SGEEV 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 sdrvev.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 REAL THRESH
415* ..
416* .. Array Arguments ..
417 LOGICAL DOTYPE( * )
418 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
419 REAL 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 REAL ZERO, ONE
428 parameter( zero = 0.0e0, one = 1.0e0 )
429 REAL TWO
430 parameter( two = 2.0e0 )
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,
439 $ NNWORK, NTEST, NTESTF, NTESTT
440 REAL 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 REAL DUM( 1 ), RES( 2 )
449* ..
450* .. External Functions ..
451 REAL SLAMCH, SLAPY2, SNRM2
452 EXTERNAL slamch, slapy2, snrm2
453* ..
454* .. External Subroutines ..
455 EXTERNAL sgeev, sget22, slabad, slacpy, slasum, slatme,
456 $ slatmr, slatms, slaset, 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 ) = 'Single 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( 'SDRVEV', -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 = slamch( 'Safe minimum' )
527 ovfl = one / unfl
528 CALL slabad( unfl, ovfl )
529 ulp = slamch( '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 slaset( '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 slatms( 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 slatms( 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 slatme( 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 slatmr( 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 slatmr( 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 slatmr( 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 slaset( 'Full', 2, n, zero, zero, a, lda )
687 CALL slaset( 'Full', n-3, 1, zero, zero, a( 3, 1 ),
688 $ lda )
689 CALL slaset( 'Full', n-3, 2, zero, zero, a( 3, n-1 ),
690 $ lda )
691 CALL slaset( '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 slatmr( 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 slacpy( 'F', n, n, a, lda, h, lda )
737 CALL sgeev( '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 )'SGEEV1', iinfo, n, jtype,
742 $ ioldsd
743 info = abs( iinfo )
744 GO TO 220
745 END IF
746*
747* Do Test (1)
748*
749 CALL sget22( '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 sget22( '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 = snrm2( n, vr( 1, j ), 1 )
765 ELSE IF( wi( j ).GT.zero ) THEN
766 tnrm = slapy2( snrm2( n, vr( 1, j ), 1 ),
767 $ snrm2( 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 = slapy2( 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 = snrm2( n, vl( 1, j ), 1 )
793 ELSE IF( wi( j ).GT.zero ) THEN
794 tnrm = slapy2( snrm2( n, vl( 1, j ), 1 ),
795 $ snrm2( 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 = slapy2( 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 slacpy( 'F', n, n, a, lda, h, lda )
818 CALL sgeev( '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 )'SGEEV2', 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 slacpy( 'F', n, n, a, lda, h, lda )
838 CALL sgeev( '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 )'SGEEV3', 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 slacpy( 'F', n, n, a, lda, h, lda )
867 CALL sgeev( '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 )'SGEEV4', 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 slasum( path, nounit, nerrs, ntestt )
934*
935 9999 FORMAT( / 1x, a3, ' -- Real Eigenvalue-Eigenvector Decomposition',
936 $ ' Driver', / ' Matrix types (see SDRVEV 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( ' SDRVEV: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
971 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
972*
973 RETURN
974*
975* End of SDRVEV
976*
slapy2
real function slapy2(x, y)
SLAPY2 returns sqrt(x2+y2).
Definition slapy2.f:63
sgeev
subroutine sgeev(jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr, ldvr, work, lwork, info)
SGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition sgeev.f:192
snrm2
real(wp) function snrm2(n, x, incx)
SNRM2
Definition snrm2.f90:89

◆ sdrvsg()

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

SDRVSG

Purpose:
!>
!>      SDRVSG checks the real symmetric generalized eigenproblem
!>      drivers.
!>
!>              SSYGV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem.
!>
!>              SSYGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem using a divide and conquer algorithm.
!>
!>              SSYGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem.
!>
!>              SSPGV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem in packed storage.
!>
!>              SSPGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem in packed storage using a divide and
!>              conquer algorithm.
!>
!>              SSPGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite generalized
!>              eigenproblem in packed storage.
!>
!>              SSBGV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite banded
!>              generalized eigenproblem.
!>
!>              SSBGVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite banded
!>              generalized eigenproblem using a divide and conquer
!>              algorithm.
!>
!>              SSBGVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric-definite banded
!>              generalized eigenproblem.
!>
!>      When SDRVSG 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) SSYGV with ITYPE = 1 and UPLO ='U':
!>
!>              | A Z - B Z D | / ( |A| |Z| n ulp )
!>
!>      (2) as (1) but calling SSPGV
!>      (3) as (1) but calling SSBGV
!>      (4) as (1) but with UPLO = 'L'
!>      (5) as (4) but calling SSPGV
!>      (6) as (4) but calling SSBGV
!>
!>      (7) SSYGV with ITYPE = 2 and UPLO ='U':
!>
!>              | A B Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (8) as (7) but calling SSPGV
!>      (9) as (7) but with UPLO = 'L'
!>      (10) as (9) but calling SSPGV
!>
!>      (11) SSYGV with ITYPE = 3 and UPLO ='U':
!>
!>              | B A Z - Z D | / ( |A| |Z| n ulp )
!>
!>      (12) as (11) but calling SSPGV
!>      (13) as (11) but with UPLO = 'L'
!>      (14) as (13) but calling SSPGV
!>
!>      SSYGVD, SSPGVD and SSBGVD performed the same 14 tests.
!>
!>      SSYGVX, SSPGVX and SSBGVX 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,
!>          SDRVSG 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, SDRVSG
!>          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 SDRVSG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       REAL 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       REAL 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       REAL array, dimension (max(NN))
!>          The eigenvalues of A. On exit, the eigenvalues in D
!>          correspond with the matrix in A.
!>          Modified.
!>
!>  Z       REAL 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      REAL array, dimension (LDA, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  BB      REAL array, dimension (LDB, max(NN))
!>          Workspace.
!>          Modified.
!>
!>  AP      REAL array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  BP      REAL array, dimension (max(NN)**2)
!>          Workspace.
!>          Modified.
!>
!>  WORK    REAL 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  REAL array, dimension (70)
!>          The values computed by the 70 tests described above.
!>          Modified.
!>
!>  INFO    INTEGER
!>          If 0, then everything ran OK.
!>           -1: NSIZES < 0
!>           -2: Some NN(j) < 0
!>           -3: NTYPES < 0
!>           -5: THRESH < 0
!>           -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
!>          -16: LDZ < 1 or LDZ < NMAX.
!>          -21: NWORK too small.
!>          -23: LIWORK too small.
!>          If  SLATMR, SLATMS, SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD,
!>              SSBGVD, SSYGVX, SSPGVX 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 SLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 352 of file sdrvsg.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 REAL THRESH
364* ..
365* .. Array Arguments ..
366 LOGICAL DOTYPE( * )
367 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
368 REAL A( LDA, * ), AB( LDA, * ), AP( * ),
369 $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ),
370 $ RESULT( * ), WORK( * ), Z( LDZ, * )
371* ..
372*
373* =====================================================================
374*
375* .. Parameters ..
376 REAL ZERO, ONE, TEN
377 parameter( zero = 0.0e0, one = 1.0e0, ten = 10.0e0 )
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 REAL 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 REAL SLAMCH, SLARND
399 EXTERNAL lsame, slamch, slarnd
400* ..
401* .. External Subroutines ..
402 EXTERNAL slabad, slacpy, slafts, slaset, slasum, slatmr,
403 $ slatms, ssbgv, ssbgvd, ssbgvx, ssgt01, sspgv,
404 $ sspgvd, sspgvx, ssygv, ssygvd, ssygvx, xerbla
405* ..
406* .. Intrinsic Functions ..
407 INTRINSIC abs, max, min, real, 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( 'SDRVSG', -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 = slamch( 'Safe minimum' )
462 ovfl = slamch( 'Overflow' )
463 CALL slabad( unfl, ovfl )
464 ulp = slamch( 'Epsilon' )*slamch( '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 / real( 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 slaset( '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 slaset( '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 slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 slatms( 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 )*slarnd( 1, iseed2 )
649 iu = 1 + ( n-1 )*slarnd( 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 SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD, SSBGVD,
658* SSYGVX, SSPGVX, and SSBGVX, 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 slatms( n, n, 'U', iseed, 'P', work, 5, ten, one,
679 $ kb, kb, uplo, b, ldb, work( n+1 ),
680 $ iinfo )
681*
682* Test SSYGV
683*
684 ntest = ntest + 1
685*
686 CALL slacpy( ' ', n, n, a, lda, z, ldz )
687 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
688*
689 CALL ssygv( ibtype, 'V', uplo, n, z, ldz, bb, ldb, d,
690 $ work, nwork, iinfo )
691 IF( iinfo.NE.0 ) THEN
692 WRITE( nounit, fmt = 9999 )'SSYGV(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 ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
706 $ ldz, d, work, result( ntest ) )
707*
708* Test SSYGVD
709*
710 ntest = ntest + 1
711*
712 CALL slacpy( ' ', n, n, a, lda, z, ldz )
713 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
714*
715 CALL ssygvd( 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 )'SSYGVD(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 ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
732 $ ldz, d, work, result( ntest ) )
733*
734* Test SSYGVX
735*
736 ntest = ntest + 1
737*
738 CALL slacpy( ' ', n, n, a, lda, ab, lda )
739 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
740*
741 CALL ssygvx( 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 )'SSYGVX(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 ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
760 $ ldz, d, work, result( ntest ) )
761*
762 ntest = ntest + 1
763*
764 CALL slacpy( ' ', n, n, a, lda, ab, lda )
765 CALL slacpy( 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 ssygvx( 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 )'SSYGVX(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 ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
793 $ ldz, d, work, result( ntest ) )
794*
795 ntest = ntest + 1
796*
797 CALL slacpy( ' ', n, n, a, lda, ab, lda )
798 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
799*
800 CALL ssygvx( 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 )'SSYGVX(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 ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
819 $ ldz, d, work, result( ntest ) )
820*
821 100 CONTINUE
822*
823* Test SSPGV
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 sspgv( ibtype, 'V', uplo, n, ap, bp, d, z, ldz,
850 $ work, iinfo )
851 IF( iinfo.NE.0 ) THEN
852 WRITE( nounit, fmt = 9999 )'SSPGV(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 ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
866 $ ldz, d, work, result( ntest ) )
867*
868* Test SSPGVD
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 sspgvd( 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 )'SSPGVD(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 ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
911 $ ldz, d, work, result( ntest ) )
912*
913* Test SSPGVX
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 sspgvx( 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 )'SSPGVX(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 ssgt01( 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 sspgvx( 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 )'SSPGVX(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 ssgt01( 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 sspgvx( 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 )'SSPGVX(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 ssgt01( 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 SSBGV
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 ssbgv( '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 )'SSBGV(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 ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1096 $ ldz, d, work, result( ntest ) )
1097*
1098* TEST SSBGVD
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 ssbgvd( '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 )'SSBGVD(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 ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1142 $ ldz, d, work, result( ntest ) )
1143*
1144* Test SSBGVX
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 ssbgvx( '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 )'SSBGVX(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 ssgt01( 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 ssbgvx( '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 )'SSBGVX(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 ssgt01( 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 ssbgvx( '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 )'SSBGVX(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 ssgt01( 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 slafts( 'SSG', n, n, jtype, ntest, result, ioldsd,
1293 $ thresh, nounit, nerrs )
1294 640 CONTINUE
1295 650 CONTINUE
1296*
1297* Summary
1298*
1299 CALL slasum( 'SSG', nounit, nerrs, ntestt )
1300*
1301 RETURN
1302*
1303* End of SDRVSG
1304*
1305 9999 FORMAT( ' SDRVSG: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1306 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
sspgvx
subroutine sspgvx(itype, jobz, range, uplo, n, ap, bp, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
SSPGVX
Definition sspgvx.f:272
ssbgv
subroutine ssbgv(jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, ldz, work, info)
SSBGV
Definition ssbgv.f:177
ssbgvd
subroutine ssbgvd(jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, ldz, work, lwork, iwork, liwork, info)
SSBGVD
Definition ssbgvd.f:227
sspgv
subroutine sspgv(itype, jobz, uplo, n, ap, bp, w, z, ldz, work, info)
SSPGV
Definition sspgv.f:160
ssbgvx
subroutine ssbgvx(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)
SSBGVX
Definition ssbgvx.f:294
sspgvd
subroutine sspgvd(itype, jobz, uplo, n, ap, bp, w, z, ldz, work, lwork, iwork, liwork, info)
SSPGVD
Definition sspgvd.f:210
ssygvd
subroutine ssygvd(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, iwork, liwork, info)
SSYGVD
Definition ssygvd.f:227
ssygv
subroutine ssygv(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, info)
SSYGV
Definition ssygv.f:175
ssygvx
subroutine ssygvx(itype, jobz, range, uplo, n, a, lda, b, ldb, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, iwork, ifail, info)
SSYGVX
Definition ssygvx.f:297
ssgt01
subroutine ssgt01(itype, uplo, n, m, a, lda, b, ldb, z, ldz, d, work, result)
SSGT01
Definition ssgt01.f:146

◆ sdrvst()

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

SDRVST

Purpose:
!>
!>      SDRVST  checks the symmetric eigenvalue problem drivers.
!>
!>              SSTEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix.
!>
!>              SSTEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix.
!>
!>              SSTEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              SSYEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix.
!>
!>              SSYEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix.
!>
!>              SSYEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              SSPEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage.
!>
!>              SSPEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage.
!>
!>              SSBEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix.
!>
!>              SSBEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix.
!>
!>              SSYEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix using
!>              a divide and conquer algorithm.
!>
!>              SSPEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage, using a divide and conquer algorithm.
!>
!>              SSBEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix,
!>              using a divide and conquer algorithm.
!>
!>      When SDRVST 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,
!>          SDRVST 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, SDRVST
!>          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 SDRVST to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       REAL array, dimension (LDA , max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  D1      REAL array, dimension (max(NN))
!>          The eigenvalues of A, as computed by SSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>          Modified.
!>
!>  D2      REAL array, dimension (max(NN))
!>          The eigenvalues of A, as computed by SSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>          Modified.
!>
!>  D3      REAL array, dimension (max(NN))
!>          The eigenvalues of A, as computed by SSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>          Modified.
!>
!>  D4      REAL array, dimension
!>
!>  EVEIGS  REAL array, dimension (max(NN))
!>          The eigenvalues as computed by SSTEV('N', ... )
!>          (I reserve the right to change this to the output of
!>          whichever algorithm computes the most accurate eigenvalues).
!>
!>  WA1     REAL array, dimension
!>
!>  WA2     REAL array, dimension
!>
!>  WA3     REAL array, dimension
!>
!>  U       REAL array, dimension (LDU, max(NN))
!>          The orthogonal matrix computed by SSYTRD + SORGTR.
!>          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       REAL array, dimension (LDU, max(NN))
!>          The Housholder vectors computed by SSYTRD in reducing A to
!>          tridiagonal form.
!>          Modified.
!>
!>  TAU     REAL array, dimension (max(NN))
!>          The Householder factors computed by SSYTRD in reducing A
!>          to tridiagonal form.
!>          Modified.
!>
!>  Z       REAL array, dimension (LDU, max(NN))
!>          The orthogonal matrix of eigenvectors computed by SSTEQR,
!>          SPTEQR, and SSTEIN.
!>          Modified.
!>
!>  WORK    REAL 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  REAL 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  SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF,
!>              or SORMTR returns an error code, the
!>              absolute value of it is returned.
!>          Modified.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far (computed by SLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
!>     The tests performed are:                 Routine tested
!>    1= | A - U S U' | / ( |A| n ulp )         SSTEV('V', ... )
!>    2= | I - U U' | / ( n ulp )               SSTEV('V', ... )
!>    3= |D(with Z) - D(w/o Z)| / (|D| ulp)     SSTEV('N', ... )
!>    4= | A - U S U' | / ( |A| n ulp )         SSTEVX('V','A', ... )
!>    5= | I - U U' | / ( n ulp )               SSTEVX('V','A', ... )
!>    6= |D(with Z) - EVEIGS| / (|D| ulp)       SSTEVX('N','A', ... )
!>    7= | A - U S U' | / ( |A| n ulp )         SSTEVR('V','A', ... )
!>    8= | I - U U' | / ( n ulp )               SSTEVR('V','A', ... )
!>    9= |D(with Z) - EVEIGS| / (|D| ulp)       SSTEVR('N','A', ... )
!>    10= | A - U S U' | / ( |A| n ulp )        SSTEVX('V','I', ... )
!>    11= | I - U U' | / ( n ulp )              SSTEVX('V','I', ... )
!>    12= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSTEVX('N','I', ... )
!>    13= | A - U S U' | / ( |A| n ulp )        SSTEVX('V','V', ... )
!>    14= | I - U U' | / ( n ulp )              SSTEVX('V','V', ... )
!>    15= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSTEVX('N','V', ... )
!>    16= | A - U S U' | / ( |A| n ulp )        SSTEVD('V', ... )
!>    17= | I - U U' | / ( n ulp )              SSTEVD('V', ... )
!>    18= |D(with Z) - EVEIGS| / (|D| ulp)      SSTEVD('N', ... )
!>    19= | A - U S U' | / ( |A| n ulp )        SSTEVR('V','I', ... )
!>    20= | I - U U' | / ( n ulp )              SSTEVR('V','I', ... )
!>    21= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSTEVR('N','I', ... )
!>    22= | A - U S U' | / ( |A| n ulp )        SSTEVR('V','V', ... )
!>    23= | I - U U' | / ( n ulp )              SSTEVR('V','V', ... )
!>    24= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSTEVR('N','V', ... )
!>
!>    25= | A - U S U' | / ( |A| n ulp )        SSYEV('L','V', ... )
!>    26= | I - U U' | / ( n ulp )              SSYEV('L','V', ... )
!>    27= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEV('L','N', ... )
!>    28= | A - U S U' | / ( |A| n ulp )        SSYEVX('L','V','A', ... )
!>    29= | I - U U' | / ( n ulp )              SSYEVX('L','V','A', ... )
!>    30= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVX('L','N','A', ... )
!>    31= | A - U S U' | / ( |A| n ulp )        SSYEVX('L','V','I', ... )
!>    32= | I - U U' | / ( n ulp )              SSYEVX('L','V','I', ... )
!>    33= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVX('L','N','I', ... )
!>    34= | A - U S U' | / ( |A| n ulp )        SSYEVX('L','V','V', ... )
!>    35= | I - U U' | / ( n ulp )              SSYEVX('L','V','V', ... )
!>    36= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVX('L','N','V', ... )
!>    37= | A - U S U' | / ( |A| n ulp )        SSPEV('L','V', ... )
!>    38= | I - U U' | / ( n ulp )              SSPEV('L','V', ... )
!>    39= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEV('L','N', ... )
!>    40= | A - U S U' | / ( |A| n ulp )        SSPEVX('L','V','A', ... )
!>    41= | I - U U' | / ( n ulp )              SSPEVX('L','V','A', ... )
!>    42= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVX('L','N','A', ... )
!>    43= | A - U S U' | / ( |A| n ulp )        SSPEVX('L','V','I', ... )
!>    44= | I - U U' | / ( n ulp )              SSPEVX('L','V','I', ... )
!>    45= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVX('L','N','I', ... )
!>    46= | A - U S U' | / ( |A| n ulp )        SSPEVX('L','V','V', ... )
!>    47= | I - U U' | / ( n ulp )              SSPEVX('L','V','V', ... )
!>    48= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVX('L','N','V', ... )
!>    49= | A - U S U' | / ( |A| n ulp )        SSBEV('L','V', ... )
!>    50= | I - U U' | / ( n ulp )              SSBEV('L','V', ... )
!>    51= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEV('L','N', ... )
!>    52= | A - U S U' | / ( |A| n ulp )        SSBEVX('L','V','A', ... )
!>    53= | I - U U' | / ( n ulp )              SSBEVX('L','V','A', ... )
!>    54= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVX('L','N','A', ... )
!>    55= | A - U S U' | / ( |A| n ulp )        SSBEVX('L','V','I', ... )
!>    56= | I - U U' | / ( n ulp )              SSBEVX('L','V','I', ... )
!>    57= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVX('L','N','I', ... )
!>    58= | A - U S U' | / ( |A| n ulp )        SSBEVX('L','V','V', ... )
!>    59= | I - U U' | / ( n ulp )              SSBEVX('L','V','V', ... )
!>    60= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVX('L','N','V', ... )
!>    61= | A - U S U' | / ( |A| n ulp )        SSYEVD('L','V', ... )
!>    62= | I - U U' | / ( n ulp )              SSYEVD('L','V', ... )
!>    63= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVD('L','N', ... )
!>    64= | A - U S U' | / ( |A| n ulp )        SSPEVD('L','V', ... )
!>    65= | I - U U' | / ( n ulp )              SSPEVD('L','V', ... )
!>    66= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVD('L','N', ... )
!>    67= | A - U S U' | / ( |A| n ulp )        SSBEVD('L','V', ... )
!>    68= | I - U U' | / ( n ulp )              SSBEVD('L','V', ... )
!>    69= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVD('L','N', ... )
!>    70= | A - U S U' | / ( |A| n ulp )        SSYEVR('L','V','A', ... )
!>    71= | I - U U' | / ( n ulp )              SSYEVR('L','V','A', ... )
!>    72= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVR('L','N','A', ... )
!>    73= | A - U S U' | / ( |A| n ulp )        SSYEVR('L','V','I', ... )
!>    74= | I - U U' | / ( n ulp )              SSYEVR('L','V','I', ... )
!>    75= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVR('L','N','I', ... )
!>    76= | A - U S U' | / ( |A| n ulp )        SSYEVR('L','V','V', ... )
!>    77= | I - U U' | / ( n ulp )              SSYEVR('L','V','V', ... )
!>    78= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVR('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 )        SSPEVR('L','V','A', ... )
!>    80= | I - U U' | / ( n ulp )              SSPEVR('L','V','A', ... )
!>    81= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVR('L','N','A', ... )
!>    82= | A - U S U' | / ( |A| n ulp )        SSPEVR('L','V','I', ... )
!>    83= | I - U U' | / ( n ulp )              SSPEVR('L','V','I', ... )
!>    84= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVR('L','N','I', ... )
!>    85= | A - U S U' | / ( |A| n ulp )        SSPEVR('L','V','V', ... )
!>    86= | I - U U' | / ( n ulp )              SSPEVR('L','V','V', ... )
!>    87= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVR('L','N','V', ... )
!>    88= | A - U S U' | / ( |A| n ulp )        SSBEVR('L','V','A', ... )
!>    89= | I - U U' | / ( n ulp )              SSBEVR('L','V','A', ... )
!>    90= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVR('L','N','A', ... )
!>    91= | A - U S U' | / ( |A| n ulp )        SSBEVR('L','V','I', ... )
!>    92= | I - U U' | / ( n ulp )              SSBEVR('L','V','I', ... )
!>    93= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVR('L','N','I', ... )
!>    94= | A - U S U' | / ( |A| n ulp )        SSBEVR('L','V','V', ... )
!>    95= | I - U U' | / ( n ulp )              SSBEVR('L','V','V', ... )
!>    96= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVR('L','N','V', ... )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 449 of file sdrvst.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 REAL THRESH
462* ..
463* .. Array Arguments ..
464 LOGICAL DOTYPE( * )
465 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
466 REAL 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 REAL ZERO, ONE, TWO, TEN
476 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
477 $ ten = 10.0e0 )
478 REAL HALF
479 parameter( half = 0.5e0 )
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 REAL 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 REAL SLAMCH, SLARND, SSXT1
502 EXTERNAL slamch, slarnd, ssxt1
503* ..
504* .. External Subroutines ..
505 EXTERNAL alasvm, slabad, slacpy, slafts, slaset, slatmr,
506 $ slatms, ssbev, ssbevd, ssbevx, sspev, sspevd,
507 $ sspevx, sstev, sstevd, sstevr, sstevx, sstt21,
508 $ sstt22, ssyev, ssyevd, ssyevr, ssyevx, ssyt21,
509 $ ssyt22, 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, int, log, max, min, real, 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( 'SDRVST', -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 = slamch( 'Safe minimum' )
576 ovfl = slamch( 'Overflow' )
577 CALL slabad( unfl, ovfl )
578 ulp = slamch( 'Epsilon' )*slamch( '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( real( 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 / real( 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 slaset( '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 slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 )*slarnd( 1, iseed3 ) )
728 CALL slatms( 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 slaset( '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 + int( ( n-1 )*slarnd( 1, iseed2 ) )
763 iu = 1 + int( ( n-1 )*slarnd( 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 SSTEV and SSTEVX.
772*
773 IF( jtype.LE.7 ) THEN
774 ntest = 1
775 DO 120 i = 1, n
776 d1( i ) = real( a( i, i ) )
777 120 CONTINUE
778 DO 130 i = 1, n - 1
779 d2( i ) = real( a( i+1, i ) )
780 130 CONTINUE
781 srnamt = 'SSTEV'
782 CALL sstev( 'V', n, d1, d2, z, ldu, work, iinfo )
783 IF( iinfo.NE.0 ) THEN
784 WRITE( nounit, fmt = 9999 )'SSTEV(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 ) = real( a( i, i ) )
801 140 CONTINUE
802 DO 150 i = 1, n - 1
803 d4( i ) = real( a( i+1, i ) )
804 150 CONTINUE
805 CALL sstt21( 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 ) = real( a( i+1, i ) )
811 160 CONTINUE
812 srnamt = 'SSTEV'
813 CALL sstev( 'N', n, d3, d4, z, ldu, work, iinfo )
814 IF( iinfo.NE.0 ) THEN
815 WRITE( nounit, fmt = 9999 )'SSTEV(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 ) = real( a( i, i ) )
843 190 CONTINUE
844 DO 200 i = 1, n - 1
845 d2( i ) = real( a( i+1, i ) )
846 200 CONTINUE
847 srnamt = 'SSTEVX'
848 CALL sstevx( '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 )'SSTEVX(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 ) = real( a( i, i ) )
874 210 CONTINUE
875 DO 220 i = 1, n - 1
876 d4( i ) = real( a( i+1, i ) )
877 220 CONTINUE
878 CALL sstt21( 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 ) = real( a( i+1, i ) )
884 230 CONTINUE
885 srnamt = 'SSTEVX'
886 CALL sstevx( '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 )'SSTEVX(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 ) = real( a( i, i ) )
918 260 CONTINUE
919 DO 270 i = 1, n - 1
920 d2( i ) = real( a( i+1, i ) )
921 270 CONTINUE
922 srnamt = 'SSTEVR'
923 CALL sstevr( '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 )'SSTEVR(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 ) = real( a( i, i ) )
948 280 CONTINUE
949 DO 290 i = 1, n - 1
950 d4( i ) = real( a( i+1, i ) )
951 290 CONTINUE
952 CALL sstt21( 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 ) = real( a( i+1, i ) )
958 300 CONTINUE
959 srnamt = 'SSTEVR'
960 CALL sstevr( '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 )'SSTEVR(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 ) = real( a( i, i ) )
993 330 CONTINUE
994 DO 340 i = 1, n - 1
995 d2( i ) = real( a( i+1, i ) )
996 340 CONTINUE
997 srnamt = 'SSTEVX'
998 CALL sstevx( '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 )'SSTEVX(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 ) = real( a( i, i ) )
1019 350 CONTINUE
1020 DO 360 i = 1, n - 1
1021 d4( i ) = real( a( i+1, i ) )
1022 360 CONTINUE
1023 CALL sstt22( 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 ) = real( a( i+1, i ) )
1030 370 CONTINUE
1031 srnamt = 'SSTEVX'
1032 CALL sstevx( '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 )'SSTEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1050 temp2 = ssxt1( 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 ) = real( a( i, i ) )
1080 390 CONTINUE
1081 DO 400 i = 1, n - 1
1082 d2( i ) = real( a( i+1, i ) )
1083 400 CONTINUE
1084 srnamt = 'SSTEVX'
1085 CALL sstevx( '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 )'SSTEVX(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 ) = real( a( i, i ) )
1113 410 CONTINUE
1114 DO 420 i = 1, n - 1
1115 d4( i ) = real( a( i+1, i ) )
1116 420 CONTINUE
1117 CALL sstt22( 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 ) = real( a( i+1, i ) )
1123 430 CONTINUE
1124 srnamt = 'SSTEVX'
1125 CALL sstevx( '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 )'SSTEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1143 temp2 = ssxt1( 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 ) = real( a( i, i ) )
1151 450 CONTINUE
1152 DO 460 i = 1, n - 1
1153 d2( i ) = real( a( i+1, i ) )
1154 460 CONTINUE
1155 srnamt = 'SSTEVD'
1156 CALL sstevd( 'V', n, d1, d2, z, ldu, work, lwedc, iwork,
1157 $ liwedc, iinfo )
1158 IF( iinfo.NE.0 ) THEN
1159 WRITE( nounit, fmt = 9999 )'SSTEVD(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 ) = real( a( i, i ) )
1176 470 CONTINUE
1177 DO 480 i = 1, n - 1
1178 d4( i ) = real( a( i+1, i ) )
1179 480 CONTINUE
1180 CALL sstt21( 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 ) = real( a( i+1, i ) )
1186 490 CONTINUE
1187 srnamt = 'SSTEVD'
1188 CALL sstevd( 'N', n, d3, d4, z, ldu, work, lwedc, iwork,
1189 $ liwedc, iinfo )
1190 IF( iinfo.NE.0 ) THEN
1191 WRITE( nounit, fmt = 9999 )'SSTEVD(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 ) = real( a( i, i ) )
1219 520 CONTINUE
1220 DO 530 i = 1, n - 1
1221 d2( i ) = real( a( i+1, i ) )
1222 530 CONTINUE
1223 srnamt = 'SSTEVR'
1224 CALL sstevr( '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 )'SSTEVR(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 ) = real( a( i, i ) )
1245 540 CONTINUE
1246 DO 550 i = 1, n - 1
1247 d4( i ) = real( a( i+1, i ) )
1248 550 CONTINUE
1249 CALL sstt22( 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 ) = real( a( i+1, i ) )
1256 560 CONTINUE
1257 srnamt = 'SSTEVR'
1258 CALL sstevr( '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 )'SSTEVR(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1276 temp2 = ssxt1( 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 ) = real( a( i, i ) )
1306 580 CONTINUE
1307 DO 590 i = 1, n - 1
1308 d2( i ) = real( a( i+1, i ) )
1309 590 CONTINUE
1310 srnamt = 'SSTEVR'
1311 CALL sstevr( '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 )'SSTEVR(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 ) = real( a( i, i ) )
1339 600 CONTINUE
1340 DO 610 i = 1, n - 1
1341 d4( i ) = real( a( i+1, i ) )
1342 610 CONTINUE
1343 CALL sstt22( 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 ) = real( a( i+1, i ) )
1349 620 CONTINUE
1350 srnamt = 'SSTEVR'
1351 CALL sstevr( '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 )'SSTEVR(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1369 temp2 = ssxt1( 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 SSYEV and SSYEVX.
1395*
1396 CALL slacpy( ' ', n, n, a, lda, v, ldu )
1397*
1398 ntest = ntest + 1
1399 srnamt = 'SSYEV'
1400 CALL ssyev( 'V', uplo, n, a, ldu, d1, work, lwork,
1401 $ iinfo )
1402 IF( iinfo.NE.0 ) THEN
1403 WRITE( nounit, fmt = 9999 )'SSYEV(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 ssyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
1419 $ ldu, tau, work, result( ntest ) )
1420*
1421 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1422*
1423 ntest = ntest + 2
1424 srnamt = 'SSYEV'
1425 CALL ssyev( 'N', uplo, n, a, ldu, d3, work, lwork,
1426 $ iinfo )
1427 IF( iinfo.NE.0 ) THEN
1428 WRITE( nounit, fmt = 9999 )'SSYEV(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 slacpy( ' ', 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 = 'SSYEVX'
1478 CALL ssyevx( '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 )'SSYEVX(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 slacpy( ' ', n, n, v, ldu, a, lda )
1498*
1499 CALL ssyt21( 1, uplo, n, 0, a, ldu, d1, d2, z, ldu, v,
1500 $ ldu, tau, work, result( ntest ) )
1501*
1502 ntest = ntest + 2
1503 srnamt = 'SSYEVX'
1504 CALL ssyevx( '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 )'SSYEVX(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 slacpy( ' ', n, n, v, ldu, a, lda )
1534 srnamt = 'SSYEVX'
1535 CALL ssyevx( '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 )'SSYEVX(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 slacpy( ' ', n, n, v, ldu, a, lda )
1555*
1556 CALL ssyt22( 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 slacpy( ' ', n, n, v, ldu, a, lda )
1561 srnamt = 'SSYEVX'
1562 CALL ssyevx( '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 )'SSYEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1580 temp2 = ssxt1( 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 slacpy( ' ', n, n, v, ldu, a, lda )
1587 srnamt = 'SSYEVX'
1588 CALL ssyevx( '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 )'SSYEVX(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 slacpy( ' ', n, n, v, ldu, a, lda )
1608*
1609 CALL ssyt22( 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 slacpy( ' ', n, n, v, ldu, a, lda )
1614 srnamt = 'SSYEVX'
1615 CALL ssyevx( '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 )'SSYEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1638 temp2 = ssxt1( 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 SSPEV and SSPEVX.
1650*
1651 CALL slacpy( ' ', 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 = 'SSPEV'
1676 CALL sspev( 'V', uplo, n, work, d1, z, ldu, v, iinfo )
1677 IF( iinfo.NE.0 ) THEN
1678 WRITE( nounit, fmt = 9999 )'SSPEV(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 ssyt21( 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 = 'SSPEV'
1716 CALL sspev( 'N', uplo, n, work, d3, z, ldu, v, iinfo )
1717 IF( iinfo.NE.0 ) THEN
1718 WRITE( nounit, fmt = 9999 )'SSPEV(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 = 'SSPEVX'
1787 CALL sspevx( '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 )'SSPEVX(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 ssyt21( 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 = 'SSPEVX'
1830 CALL sspevx( '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 )'SSPEVX(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 = 'SSPEVX'
1878 CALL sspevx( '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 )'SSPEVX(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 ssyt22( 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 = 'SSPEVX'
1921 CALL sspevx( '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 )'SSPEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1944 temp2 = ssxt1( 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 = 'SSPEVX'
1975 CALL sspevx( '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 )'SSPEVX(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 ssyt22( 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 = 'SSPEVX'
2018 CALL sspevx( '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 )'SSPEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2041 temp2 = ssxt1( 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 SSBEV and SSBEVX.
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 = 'SSBEV'
2081 CALL ssbev( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
2082 $ iinfo )
2083 IF( iinfo.NE.0 ) THEN
2084 WRITE( nounit, fmt = 9999 )'SSBEV(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 ssyt21( 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 = 'SSBEV'
2118 CALL ssbev( 'N', uplo, n, kd, v, ldu, d3, z, ldu, work,
2119 $ iinfo )
2120 IF( iinfo.NE.0 ) THEN
2121 WRITE( nounit, fmt = 9999 )'SSBEV(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 = 'SSBEVX'
2163 CALL ssbevx( '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 )'SSBEVX(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 ssyt21( 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 = 'SSBEVX'
2202 CALL ssbevx( '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 )'SSBEVX(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 = 'SSBEVX'
2245 CALL ssbevx( '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 )'SSBEVX(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 ssyt22( 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 = 'SSBEVX'
2284 CALL ssbevx( '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 )'SSBEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2302 temp2 = ssxt1( 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 = 'SSBEVX'
2328 CALL ssbevx( '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 )'SSBEVX(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 ssyt22( 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 = 'SSBEVX'
2367 CALL ssbevx( '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 )'SSBEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2390 temp2 = ssxt1( 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 SSYEVD
2402*
2403 CALL slacpy( ' ', n, n, a, lda, v, ldu )
2404*
2405 ntest = ntest + 1
2406 srnamt = 'SSYEVD'
2407 CALL ssyevd( 'V', uplo, n, a, ldu, d1, work, lwedc,
2408 $ iwork, liwedc, iinfo )
2409 IF( iinfo.NE.0 ) THEN
2410 WRITE( nounit, fmt = 9999 )'SSYEVD(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 ssyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
2426 $ ldu, tau, work, result( ntest ) )
2427*
2428 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2429*
2430 ntest = ntest + 2
2431 srnamt = 'SSYEVD'
2432 CALL ssyevd( 'N', uplo, n, a, ldu, d3, work, lwedc,
2433 $ iwork, liwedc, iinfo )
2434 IF( iinfo.NE.0 ) THEN
2435 WRITE( nounit, fmt = 9999 )'SSYEVD(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 SSPEVD.
2460*
2461 CALL slacpy( ' ', 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 = 'SSPEVD'
2486 CALL sspevd( '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 )'SSPEVD(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 ssyt21( 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 = 'SSPEVD'
2529 CALL sspevd( '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 )'SSPEVD(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 SSBEVD.
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 = 'SSBEVD'
2585 CALL ssbevd( '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 )'SSBEVD(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 ssyt21( 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 = 'SSBEVD'
2622 CALL ssbevd( '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 )'SSBEVD(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 slacpy( ' ', n, n, a, lda, v, ldu )
2651 ntest = ntest + 1
2652 srnamt = 'SSYEVR'
2653 CALL ssyevr( '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 )'SSYEVR(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 slacpy( ' ', n, n, v, ldu, a, lda )
2673*
2674 CALL ssyt21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
2675 $ ldu, tau, work, result( ntest ) )
2676*
2677 ntest = ntest + 2
2678 srnamt = 'SSYEVR'
2679 CALL ssyevr( '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 )'SSYEVR(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 slacpy( ' ', n, n, v, ldu, a, lda )
2709 srnamt = 'SSYEVR'
2710 CALL ssyevr( '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 )'SSYEVR(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 slacpy( ' ', n, n, v, ldu, a, lda )
2730*
2731 CALL ssyt22( 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 slacpy( ' ', n, n, v, ldu, a, lda )
2736 srnamt = 'SSYEVR'
2737 CALL ssyevr( '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 )'SSYEVR(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2755 temp2 = ssxt1( 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 slacpy( ' ', n, n, v, ldu, a, lda )
2762 srnamt = 'SSYEVR'
2763 CALL ssyevr( '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 )'SSYEVR(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 slacpy( ' ', n, n, v, ldu, a, lda )
2783*
2784 CALL ssyt22( 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 slacpy( ' ', n, n, v, ldu, a, lda )
2789 srnamt = 'SSYEVR'
2790 CALL ssyevr( '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 )'SSYEVR(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2813 temp2 = ssxt1( 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 slacpy( ' ', 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 slafts( 'SST', n, n, jtype, ntest, result, ioldsd,
2831 $ thresh, nounit, nerrs )
2832*
2833 1730 CONTINUE
2834 1740 CONTINUE
2835*
2836* Summary
2837*
2838 CALL alasvm( 'SST', nounit, nerrs, ntestt, 0 )
2839*
2840 9999 FORMAT( ' SDRVST: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
2841 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2842*
2843 RETURN
2844*
2845* End of SDRVST
2846*
sstevx
subroutine sstevx(jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
SSTEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition sstevx.f:227
sspevd
subroutine sspevd(jobz, uplo, n, ap, w, z, ldz, work, lwork, iwork, liwork, info)
SSPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition sspevd.f:178
ssbevx
subroutine ssbevx(jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
SSBEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition ssbevx.f:265
ssbevd
subroutine ssbevd(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, iwork, liwork, info)
SSBEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition ssbevd.f:193
ssbev
subroutine ssbev(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, info)
SSBEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition ssbev.f:146
sspevx
subroutine sspevx(jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
SSPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition sspevx.f:234
sspev
subroutine sspev(jobz, uplo, n, ap, w, z, ldz, work, info)
SSPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition sspev.f:130
sstev
subroutine sstev(jobz, n, d, e, z, ldz, work, info)
SSTEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
Definition sstev.f:116
sstevr
subroutine sstevr(jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
SSTEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition sstevr.f:306
sstevd
subroutine sstevd(jobz, n, d, e, z, ldz, work, lwork, iwork, liwork, info)
SSTEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
Definition sstevd.f:163
ssyevd
subroutine ssyevd(jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork, info)
SSYEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition ssyevd.f:183
ssyevx
subroutine ssyevx(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, iwork, ifail, info)
SSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition ssyevx.f:253
ssyevr
subroutine ssyevr(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
SSYEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition ssyevr.f:336
ssyev
subroutine ssyev(jobz, uplo, n, a, lda, w, work, lwork, info)
SSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
Definition ssyev.f:132
ssyt22
subroutine ssyt22(itype, uplo, n, m, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, result)
SSYT22
Definition ssyt22.f:157

◆ sdrvst2stg()

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

SDRVST2STG

Purpose:
!>
!>      SDRVST2STG  checks the symmetric eigenvalue problem drivers.
!>
!>              SSTEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix.
!>
!>              SSTEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix.
!>
!>              SSTEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric tridiagonal matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              SSYEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix.
!>
!>              SSYEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix.
!>
!>              SSYEVR computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix
!>              using the Relatively Robust Representation where it can.
!>
!>              SSPEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage.
!>
!>              SSPEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage.
!>
!>              SSBEV computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix.
!>
!>              SSBEVX computes selected eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix.
!>
!>              SSYEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix using
!>              a divide and conquer algorithm.
!>
!>              SSPEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric matrix in packed
!>              storage, using a divide and conquer algorithm.
!>
!>              SSBEVD computes all eigenvalues and, optionally,
!>              eigenvectors of a real symmetric band matrix,
!>              using a divide and conquer algorithm.
!>
!>      When SDRVST2STG 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,
!>          SDRVST2STG 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, SDRVST2STG
!>          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 SDRVST2STG to continue the same random number
!>          sequence.
!>          Modified.
!>
!>  THRESH  REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>          Not modified.
!>
!>  NOUNIT  INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns IINFO not equal to 0.)
!>          Not modified.
!>
!>  A       REAL             array, dimension (LDA , max(NN))
!>          Used to hold the matrix whose eigenvalues are to be
!>          computed.  On exit, A contains the last matrix actually
!>          used.
!>          Modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at
!>          least 1 and at least max( NN ).
!>          Not modified.
!>
!>  D1      REAL             array, dimension (max(NN))
!>          The eigenvalues of A, as computed by SSTEQR simlutaneously
!>          with Z.  On exit, the eigenvalues in D1 correspond with the
!>          matrix in A.
!>          Modified.
!>
!>  D2      REAL             array, dimension (max(NN))
!>          The eigenvalues of A, as computed by SSTEQR if Z is not
!>          computed.  On exit, the eigenvalues in D2 correspond with
!>          the matrix in A.
!>          Modified.
!>
!>  D3      REAL             array, dimension (max(NN))
!>          The eigenvalues of A, as computed by SSTERF.  On exit, the
!>          eigenvalues in D3 correspond with the matrix in A.
!>          Modified.
!>
!>  D4      REAL             array, dimension
!>
!>  EVEIGS  REAL array, dimension (max(NN))
!>          The eigenvalues as computed by SSTEV('N', ... )
!>          (I reserve the right to change this to the output of
!>          whichever algorithm computes the most accurate eigenvalues).
!>
!>  WA1     REAL array, dimension
!>
!>  WA2     REAL array, dimension
!>
!>  WA3     REAL array, dimension
!>
!>  U       REAL             array, dimension (LDU, max(NN))
!>          The orthogonal matrix computed by SSYTRD + SORGTR.
!>          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       REAL             array, dimension (LDU, max(NN))
!>          The Housholder vectors computed by SSYTRD in reducing A to
!>          tridiagonal form.
!>          Modified.
!>
!>  TAU     REAL array, dimension (max(NN))
!>          The Householder factors computed by SSYTRD in reducing A
!>          to tridiagonal form.
!>          Modified.
!>
!>  Z       REAL             array, dimension (LDU, max(NN))
!>          The orthogonal matrix of eigenvectors computed by SSTEQR,
!>          SPTEQR, and SSTEIN.
!>          Modified.
!>
!>  WORK    REAL 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  REAL 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  SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF,
!>              or SORMTR returns an error code, the
!>              absolute value of it is returned.
!>          Modified.
!>
!>-----------------------------------------------------------------------
!>
!>       Some Local Variables and Parameters:
!>       ---- ----- --------- --- ----------
!>       ZERO, ONE       Real 0 and 1.
!>       MAXTYP          The number of types defined.
!>       NTEST           The number of tests performed, or which can
!>                       be performed so far, for the current matrix.
!>       NTESTT          The total number of tests performed so far.
!>       NMAX            Largest value in NN.
!>       NMATS           The number of matrices generated so far.
!>       NERRS           The number of tests which have exceeded THRESH
!>                       so far (computed by SLAFTS).
!>       COND, IMODE     Values to be passed to the matrix generators.
!>       ANORM           Norm of A; passed to matrix generators.
!>
!>       OVFL, UNFL      Overflow and underflow thresholds.
!>       ULP, ULPINV     Finest relative precision and its inverse.
!>       RTOVFL, RTUNFL  Square roots of the previous 2 values.
!>               The following four arrays decode JTYPE:
!>       KTYPE(j)        The general type (1-10) for type .
!>       KMODE(j)        The MODE value to be passed to the matrix
!>                       generator for type .
!>       KMAGN(j)        The order of magnitude ( O(1),
!>                       O(overflow^(1/2) ), O(underflow^(1/2) )
!>
!>     The tests performed are:                 Routine tested
!>    1= | A - U S U' | / ( |A| n ulp )         SSTEV('V', ... )
!>    2= | I - U U' | / ( n ulp )               SSTEV('V', ... )
!>    3= |D(with Z) - D(w/o Z)| / (|D| ulp)     SSTEV('N', ... )
!>    4= | A - U S U' | / ( |A| n ulp )         SSTEVX('V','A', ... )
!>    5= | I - U U' | / ( n ulp )               SSTEVX('V','A', ... )
!>    6= |D(with Z) - EVEIGS| / (|D| ulp)       SSTEVX('N','A', ... )
!>    7= | A - U S U' | / ( |A| n ulp )         SSTEVR('V','A', ... )
!>    8= | I - U U' | / ( n ulp )               SSTEVR('V','A', ... )
!>    9= |D(with Z) - EVEIGS| / (|D| ulp)       SSTEVR('N','A', ... )
!>    10= | A - U S U' | / ( |A| n ulp )        SSTEVX('V','I', ... )
!>    11= | I - U U' | / ( n ulp )              SSTEVX('V','I', ... )
!>    12= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSTEVX('N','I', ... )
!>    13= | A - U S U' | / ( |A| n ulp )        SSTEVX('V','V', ... )
!>    14= | I - U U' | / ( n ulp )              SSTEVX('V','V', ... )
!>    15= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSTEVX('N','V', ... )
!>    16= | A - U S U' | / ( |A| n ulp )        SSTEVD('V', ... )
!>    17= | I - U U' | / ( n ulp )              SSTEVD('V', ... )
!>    18= |D(with Z) - EVEIGS| / (|D| ulp)      SSTEVD('N', ... )
!>    19= | A - U S U' | / ( |A| n ulp )        SSTEVR('V','I', ... )
!>    20= | I - U U' | / ( n ulp )              SSTEVR('V','I', ... )
!>    21= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSTEVR('N','I', ... )
!>    22= | A - U S U' | / ( |A| n ulp )        SSTEVR('V','V', ... )
!>    23= | I - U U' | / ( n ulp )              SSTEVR('V','V', ... )
!>    24= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSTEVR('N','V', ... )
!>
!>    25= | A - U S U' | / ( |A| n ulp )        SSYEV('L','V', ... )
!>    26= | I - U U' | / ( n ulp )              SSYEV('L','V', ... )
!>    27= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEV_2STAGE('L','N', ... )
!>    28= | A - U S U' | / ( |A| n ulp )        SSYEVX('L','V','A', ... )
!>    29= | I - U U' | / ( n ulp )              SSYEVX('L','V','A', ... )
!>    30= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVX_2STAGE('L','N','A', ... )
!>    31= | A - U S U' | / ( |A| n ulp )        SSYEVX('L','V','I', ... )
!>    32= | I - U U' | / ( n ulp )              SSYEVX('L','V','I', ... )
!>    33= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVX_2STAGE('L','N','I', ... )
!>    34= | A - U S U' | / ( |A| n ulp )        SSYEVX('L','V','V', ... )
!>    35= | I - U U' | / ( n ulp )              SSYEVX('L','V','V', ... )
!>    36= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVX_2STAGE('L','N','V', ... )
!>    37= | A - U S U' | / ( |A| n ulp )        SSPEV('L','V', ... )
!>    38= | I - U U' | / ( n ulp )              SSPEV('L','V', ... )
!>    39= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEV('L','N', ... )
!>    40= | A - U S U' | / ( |A| n ulp )        SSPEVX('L','V','A', ... )
!>    41= | I - U U' | / ( n ulp )              SSPEVX('L','V','A', ... )
!>    42= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVX('L','N','A', ... )
!>    43= | A - U S U' | / ( |A| n ulp )        SSPEVX('L','V','I', ... )
!>    44= | I - U U' | / ( n ulp )              SSPEVX('L','V','I', ... )
!>    45= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVX('L','N','I', ... )
!>    46= | A - U S U' | / ( |A| n ulp )        SSPEVX('L','V','V', ... )
!>    47= | I - U U' | / ( n ulp )              SSPEVX('L','V','V', ... )
!>    48= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVX('L','N','V', ... )
!>    49= | A - U S U' | / ( |A| n ulp )        SSBEV('L','V', ... )
!>    50= | I - U U' | / ( n ulp )              SSBEV('L','V', ... )
!>    51= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEV_2STAGE('L','N', ... )
!>    52= | A - U S U' | / ( |A| n ulp )        SSBEVX('L','V','A', ... )
!>    53= | I - U U' | / ( n ulp )              SSBEVX('L','V','A', ... )
!>    54= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVX_2STAGE('L','N','A', ... )
!>    55= | A - U S U' | / ( |A| n ulp )        SSBEVX('L','V','I', ... )
!>    56= | I - U U' | / ( n ulp )              SSBEVX('L','V','I', ... )
!>    57= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVX_2STAGE('L','N','I', ... )
!>    58= | A - U S U' | / ( |A| n ulp )        SSBEVX('L','V','V', ... )
!>    59= | I - U U' | / ( n ulp )              SSBEVX('L','V','V', ... )
!>    60= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVX_2STAGE('L','N','V', ... )
!>    61= | A - U S U' | / ( |A| n ulp )        SSYEVD('L','V', ... )
!>    62= | I - U U' | / ( n ulp )              SSYEVD('L','V', ... )
!>    63= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVD_2STAGE('L','N', ... )
!>    64= | A - U S U' | / ( |A| n ulp )        SSPEVD('L','V', ... )
!>    65= | I - U U' | / ( n ulp )              SSPEVD('L','V', ... )
!>    66= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVD('L','N', ... )
!>    67= | A - U S U' | / ( |A| n ulp )        SSBEVD('L','V', ... )
!>    68= | I - U U' | / ( n ulp )              SSBEVD('L','V', ... )
!>    69= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVD_2STAGE('L','N', ... )
!>    70= | A - U S U' | / ( |A| n ulp )        SSYEVR('L','V','A', ... )
!>    71= | I - U U' | / ( n ulp )              SSYEVR('L','V','A', ... )
!>    72= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVR_2STAGE('L','N','A', ... )
!>    73= | A - U S U' | / ( |A| n ulp )        SSYEVR('L','V','I', ... )
!>    74= | I - U U' | / ( n ulp )              SSYEVR('L','V','I', ... )
!>    75= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVR_2STAGE('L','N','I', ... )
!>    76= | A - U S U' | / ( |A| n ulp )        SSYEVR('L','V','V', ... )
!>    77= | I - U U' | / ( n ulp )              SSYEVR('L','V','V', ... )
!>    78= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSYEVR_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 )        SSPEVR('L','V','A', ... )
!>    80= | I - U U' | / ( n ulp )              SSPEVR('L','V','A', ... )
!>    81= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVR('L','N','A', ... )
!>    82= | A - U S U' | / ( |A| n ulp )        SSPEVR('L','V','I', ... )
!>    83= | I - U U' | / ( n ulp )              SSPEVR('L','V','I', ... )
!>    84= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVR('L','N','I', ... )
!>    85= | A - U S U' | / ( |A| n ulp )        SSPEVR('L','V','V', ... )
!>    86= | I - U U' | / ( n ulp )              SSPEVR('L','V','V', ... )
!>    87= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSPEVR('L','N','V', ... )
!>    88= | A - U S U' | / ( |A| n ulp )        SSBEVR('L','V','A', ... )
!>    89= | I - U U' | / ( n ulp )              SSBEVR('L','V','A', ... )
!>    90= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVR('L','N','A', ... )
!>    91= | A - U S U' | / ( |A| n ulp )        SSBEVR('L','V','I', ... )
!>    92= | I - U U' | / ( n ulp )              SSBEVR('L','V','I', ... )
!>    93= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVR('L','N','I', ... )
!>    94= | A - U S U' | / ( |A| n ulp )        SSBEVR('L','V','V', ... )
!>    95= | I - U U' | / ( n ulp )              SSBEVR('L','V','V', ... )
!>    96= |D(with Z) - D(w/o Z)| / (|D| ulp)    SSBEVR('L','N','V', ... )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 449 of file sdrvst2stg.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 REAL THRESH
462* ..
463* .. Array Arguments ..
464 LOGICAL DOTYPE( * )
465 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
466 REAL 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 REAL ZERO, ONE, TWO, TEN
476 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
477 $ ten = 10.0e0 )
478 REAL HALF
479 parameter( half = 0.5e+0 )
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 REAL 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 REAL SLAMCH, SLARND, SSXT1
502 EXTERNAL slamch, slarnd, ssxt1
503* ..
504* .. External Subroutines ..
505 EXTERNAL alasvm, slabad, slacpy, slafts, slaset, slatmr,
506 $ slatms, ssbev, ssbevd, ssbevx, sspev, sspevd,
507 $ sspevx, sstev, sstevd, sstevr, sstevx, sstt21,
508 $ sstt22, ssyev, ssyevd, ssyevr, ssyevx, ssyt21,
509 $ ssyevd_2stage, ssyevr_2stage, ssyevx_2stage,
510 $ ssyev_2stage, ssbev_2stage, ssbevd_2stage,
511 $ ssbevx_2stage, ssytrd_2stage, ssytrd_sy2sb,
512 $ ssytrd_sb2st, ssyt22, 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, real, 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( 'SDRVST2STG', -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 = slamch( 'Safe minimum' )
579 ovfl = slamch( 'Overflow' )
580 CALL slabad( unfl, ovfl )
581 ulp = slamch( 'Epsilon' )*slamch( '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( real( 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 / real( 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 slaset( '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 slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 )*slarnd( 1, iseed3 ) )
731 CALL slatms( 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 slaset( '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 )*slarnd( 1, iseed2 ) )
766 iu = 1 + int( ( n-1 )*slarnd( 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 SSTEV and SSTEVX.
775*
776 IF( jtype.LE.7 ) THEN
777 ntest = 1
778 DO 120 i = 1, n
779 d1( i ) = real( a( i, i ) )
780 120 CONTINUE
781 DO 130 i = 1, n - 1
782 d2( i ) = real( a( i+1, i ) )
783 130 CONTINUE
784 srnamt = 'SSTEV'
785 CALL sstev( 'V', n, d1, d2, z, ldu, work, iinfo )
786 IF( iinfo.NE.0 ) THEN
787 WRITE( nounit, fmt = 9999 )'SSTEV(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 ) = real( a( i, i ) )
804 140 CONTINUE
805 DO 150 i = 1, n - 1
806 d4( i ) = real( a( i+1, i ) )
807 150 CONTINUE
808 CALL sstt21( 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 ) = real( a( i+1, i ) )
814 160 CONTINUE
815 srnamt = 'SSTEV'
816 CALL sstev( 'N', n, d3, d4, z, ldu, work, iinfo )
817 IF( iinfo.NE.0 ) THEN
818 WRITE( nounit, fmt = 9999 )'SSTEV(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 ) = real( a( i, i ) )
846 190 CONTINUE
847 DO 200 i = 1, n - 1
848 d2( i ) = real( a( i+1, i ) )
849 200 CONTINUE
850 srnamt = 'SSTEVX'
851 CALL sstevx( '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 )'SSTEVX(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 ) = real( a( i, i ) )
877 210 CONTINUE
878 DO 220 i = 1, n - 1
879 d4( i ) = real( a( i+1, i ) )
880 220 CONTINUE
881 CALL sstt21( 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 ) = real( a( i+1, i ) )
887 230 CONTINUE
888 srnamt = 'SSTEVX'
889 CALL sstevx( '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 )'SSTEVX(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 ) = real( a( i, i ) )
921 260 CONTINUE
922 DO 270 i = 1, n - 1
923 d2( i ) = real( a( i+1, i ) )
924 270 CONTINUE
925 srnamt = 'SSTEVR'
926 CALL sstevr( '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 )'SSTEVR(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 ) = real( a( i, i ) )
951 280 CONTINUE
952 DO 290 i = 1, n - 1
953 d4( i ) = real( a( i+1, i ) )
954 290 CONTINUE
955 CALL sstt21( 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 ) = real( a( i+1, i ) )
961 300 CONTINUE
962 srnamt = 'SSTEVR'
963 CALL sstevr( '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 )'SSTEVR(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 ) = real( a( i, i ) )
996 330 CONTINUE
997 DO 340 i = 1, n - 1
998 d2( i ) = real( a( i+1, i ) )
999 340 CONTINUE
1000 srnamt = 'SSTEVX'
1001 CALL sstevx( '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 )'SSTEVX(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 ) = real( a( i, i ) )
1022 350 CONTINUE
1023 DO 360 i = 1, n - 1
1024 d4( i ) = real( a( i+1, i ) )
1025 360 CONTINUE
1026 CALL sstt22( 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 ) = real( a( i+1, i ) )
1033 370 CONTINUE
1034 srnamt = 'SSTEVX'
1035 CALL sstevx( '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 )'SSTEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1053 temp2 = ssxt1( 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 ) = real( a( i, i ) )
1083 390 CONTINUE
1084 DO 400 i = 1, n - 1
1085 d2( i ) = real( a( i+1, i ) )
1086 400 CONTINUE
1087 srnamt = 'SSTEVX'
1088 CALL sstevx( '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 )'SSTEVX(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 ) = real( a( i, i ) )
1116 410 CONTINUE
1117 DO 420 i = 1, n - 1
1118 d4( i ) = real( a( i+1, i ) )
1119 420 CONTINUE
1120 CALL sstt22( 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 ) = real( a( i+1, i ) )
1126 430 CONTINUE
1127 srnamt = 'SSTEVX'
1128 CALL sstevx( '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 )'SSTEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1146 temp2 = ssxt1( 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 ) = real( a( i, i ) )
1154 450 CONTINUE
1155 DO 460 i = 1, n - 1
1156 d2( i ) = real( a( i+1, i ) )
1157 460 CONTINUE
1158 srnamt = 'SSTEVD'
1159 CALL sstevd( 'V', n, d1, d2, z, ldu, work, lwedc, iwork,
1160 $ liwedc, iinfo )
1161 IF( iinfo.NE.0 ) THEN
1162 WRITE( nounit, fmt = 9999 )'SSTEVD(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 ) = real( a( i, i ) )
1179 470 CONTINUE
1180 DO 480 i = 1, n - 1
1181 d4( i ) = real( a( i+1, i ) )
1182 480 CONTINUE
1183 CALL sstt21( 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 ) = real( a( i+1, i ) )
1189 490 CONTINUE
1190 srnamt = 'SSTEVD'
1191 CALL sstevd( 'N', n, d3, d4, z, ldu, work, lwedc, iwork,
1192 $ liwedc, iinfo )
1193 IF( iinfo.NE.0 ) THEN
1194 WRITE( nounit, fmt = 9999 )'SSTEVD(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 ) = real( a( i, i ) )
1222 520 CONTINUE
1223 DO 530 i = 1, n - 1
1224 d2( i ) = real( a( i+1, i ) )
1225 530 CONTINUE
1226 srnamt = 'SSTEVR'
1227 CALL sstevr( '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 )'SSTEVR(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 ) = real( a( i, i ) )
1248 540 CONTINUE
1249 DO 550 i = 1, n - 1
1250 d4( i ) = real( a( i+1, i ) )
1251 550 CONTINUE
1252 CALL sstt22( 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 ) = real( a( i+1, i ) )
1259 560 CONTINUE
1260 srnamt = 'SSTEVR'
1261 CALL sstevr( '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 )'SSTEVR(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1279 temp2 = ssxt1( 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 ) = real( a( i, i ) )
1309 580 CONTINUE
1310 DO 590 i = 1, n - 1
1311 d2( i ) = real( a( i+1, i ) )
1312 590 CONTINUE
1313 srnamt = 'SSTEVR'
1314 CALL sstevr( '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 )'SSTEVR(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 ) = real( a( i, i ) )
1342 600 CONTINUE
1343 DO 610 i = 1, n - 1
1344 d4( i ) = real( a( i+1, i ) )
1345 610 CONTINUE
1346 CALL sstt22( 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 ) = real( a( i+1, i ) )
1352 620 CONTINUE
1353 srnamt = 'SSTEVR'
1354 CALL sstevr( '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 )'SSTEVR(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1372 temp2 = ssxt1( 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 SSYEV and SSYEVX.
1398*
1399 CALL slacpy( ' ', n, n, a, lda, v, ldu )
1400*
1401 ntest = ntest + 1
1402 srnamt = 'SSYEV'
1403 CALL ssyev( 'V', uplo, n, a, ldu, d1, work, lwork,
1404 $ iinfo )
1405 IF( iinfo.NE.0 ) THEN
1406 WRITE( nounit, fmt = 9999 )'SSYEV(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 ssyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
1422 $ ldu, tau, work, result( ntest ) )
1423*
1424 CALL slacpy( ' ', n, n, v, ldu, a, lda )
1425*
1426 ntest = ntest + 2
1427 srnamt = 'SSYEV_2STAGE'
1428 CALL ssyev_2stage( 'N', uplo, n, a, ldu, d3, work, lwork,
1429 $ iinfo )
1430 IF( iinfo.NE.0 ) THEN
1431 WRITE( nounit, fmt = 9999 )
1432 $ 'SSYEV_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 slacpy( ' ', 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 = 'SSYEVX'
1482 CALL ssyevx( '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 )'SSYEVX(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 slacpy( ' ', n, n, v, ldu, a, lda )
1502*
1503 CALL ssyt21( 1, uplo, n, 0, a, ldu, d1, d2, z, ldu, v,
1504 $ ldu, tau, work, result( ntest ) )
1505*
1506 ntest = ntest + 2
1507 srnamt = 'SSYEVX_2STAGE'
1508 CALL ssyevx_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 $ 'SSYEVX_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 slacpy( ' ', n, n, v, ldu, a, lda )
1539 srnamt = 'SSYEVX'
1540 CALL ssyevx( '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 )'SSYEVX(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 slacpy( ' ', n, n, v, ldu, a, lda )
1560*
1561 CALL ssyt22( 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 slacpy( ' ', n, n, v, ldu, a, lda )
1566 srnamt = 'SSYEVX_2STAGE'
1567 CALL ssyevx_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 $ 'SSYEVX_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1586 temp2 = ssxt1( 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 slacpy( ' ', n, n, v, ldu, a, lda )
1593 srnamt = 'SSYEVX'
1594 CALL ssyevx( '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 )'SSYEVX(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 slacpy( ' ', n, n, v, ldu, a, lda )
1614*
1615 CALL ssyt22( 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 slacpy( ' ', n, n, v, ldu, a, lda )
1620 srnamt = 'SSYEVX_2STAGE'
1621 CALL ssyevx_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 $ 'SSYEVX_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1645 temp2 = ssxt1( 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 SSPEV and SSPEVX.
1657*
1658 CALL slacpy( ' ', 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 = 'SSPEV'
1683 CALL sspev( 'V', uplo, n, work, d1, z, ldu, v, iinfo )
1684 IF( iinfo.NE.0 ) THEN
1685 WRITE( nounit, fmt = 9999 )'SSPEV(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 ssyt21( 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 = 'SSPEV'
1723 CALL sspev( 'N', uplo, n, work, d3, z, ldu, v, iinfo )
1724 IF( iinfo.NE.0 ) THEN
1725 WRITE( nounit, fmt = 9999 )'SSPEV(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 = 'SSPEVX'
1794 CALL sspevx( '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 )'SSPEVX(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 ssyt21( 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 = 'SSPEVX'
1837 CALL sspevx( '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 )'SSPEVX(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 = 'SSPEVX'
1885 CALL sspevx( '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 )'SSPEVX(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 ssyt22( 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 = 'SSPEVX'
1928 CALL sspevx( '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 )'SSPEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1951 temp2 = ssxt1( 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 = 'SSPEVX'
1982 CALL sspevx( '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 )'SSPEVX(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 ssyt22( 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 = 'SSPEVX'
2025 CALL sspevx( '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 )'SSPEVX(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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2048 temp2 = ssxt1( 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 SSBEV and SSBEVX.
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 = 'SSBEV'
2088 CALL ssbev( 'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
2089 $ iinfo )
2090 IF( iinfo.NE.0 ) THEN
2091 WRITE( nounit, fmt = 9999 )'SSBEV(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 ssyt21( 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 = 'SSBEV_2STAGE'
2125 CALL ssbev_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 $ 'SSBEV_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 = 'SSBEVX'
2171 CALL ssbevx( '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 )'SSBEVX(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 ssyt21( 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 = 'SSBEVX_2STAGE'
2210 CALL ssbevx_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 $ 'SSBEVX_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 = 'SSBEVX'
2255 CALL ssbevx( '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 )'SSBEVX(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 ssyt22( 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 = 'SSBEVX_2STAGE'
2294 CALL ssbevx_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 $ 'SSBEVX_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2314 temp2 = ssxt1( 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 = 'SSBEVX'
2340 CALL ssbevx( '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 )'SSBEVX(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 ssyt22( 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 = 'SSBEVX_2STAGE'
2379 CALL ssbevx_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 $ 'SSBEVX_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2404 temp2 = ssxt1( 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 SSYEVD
2416*
2417 CALL slacpy( ' ', n, n, a, lda, v, ldu )
2418*
2419 ntest = ntest + 1
2420 srnamt = 'SSYEVD'
2421 CALL ssyevd( 'V', uplo, n, a, ldu, d1, work, lwedc,
2422 $ iwork, liwedc, iinfo )
2423 IF( iinfo.NE.0 ) THEN
2424 WRITE( nounit, fmt = 9999 )'SSYEVD(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 ssyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
2440 $ ldu, tau, work, result( ntest ) )
2441*
2442 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2443*
2444 ntest = ntest + 2
2445 srnamt = 'SSYEVD_2STAGE'
2446 CALL ssyevd_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 $ 'SSYEVD_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 SSPEVD.
2475*
2476 CALL slacpy( ' ', 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 = 'SSPEVD'
2501 CALL sspevd( '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 )'SSPEVD(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 ssyt21( 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 = 'SSPEVD'
2544 CALL sspevd( '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 )'SSPEVD(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 SSBEVD.
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 = 'SSBEVD'
2600 CALL ssbevd( '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 )'SSBEVD(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 ssyt21( 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 = 'SSBEVD_2STAGE'
2637 CALL ssbevd_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 $ 'SSBEVD_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 slacpy( ' ', n, n, a, lda, v, ldu )
2667 ntest = ntest + 1
2668 srnamt = 'SSYEVR'
2669 CALL ssyevr( '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 )'SSYEVR(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 slacpy( ' ', n, n, v, ldu, a, lda )
2689*
2690 CALL ssyt21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
2691 $ ldu, tau, work, result( ntest ) )
2692*
2693 ntest = ntest + 2
2694 srnamt = 'SSYEVR_2STAGE'
2695 CALL ssyevr_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 $ 'SSYEVR_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 slacpy( ' ', n, n, v, ldu, a, lda )
2727 srnamt = 'SSYEVR'
2728 CALL ssyevr( '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 )'SSYEVR(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 slacpy( ' ', n, n, v, ldu, a, lda )
2748*
2749 CALL ssyt22( 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 slacpy( ' ', n, n, v, ldu, a, lda )
2754 srnamt = 'SSYEVR_2STAGE'
2755 CALL ssyevr_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 $ 'SSYEVR_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 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2775 temp2 = ssxt1( 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 slacpy( ' ', n, n, v, ldu, a, lda )
2782 srnamt = 'SSYEVR'
2783 CALL ssyevr( '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 )'SSYEVR(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 700
2797 END IF
2798 END IF
2799*
2800* Do tests 76 and 77 (or +54)
2801*
2802 CALL slacpy( ' ', n, n, v, ldu, a, lda )
2803*
2804 CALL ssyt22( 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 slacpy( ' ', n, n, v, ldu, a, lda )
2809 srnamt = 'SSYEVR_2STAGE'
2810 CALL ssyevr_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 $ 'SSYEVR_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 700
2824 END IF
2825 END IF
2826*
2827 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2828 result( ntest ) = ulpinv
2829 GO TO 700
2830 END IF
2831*
2832* Do test 78 (or +54)
2833*
2834 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2835 temp2 = ssxt1( 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 slacpy( ' ', 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 slafts( 'SST', n, n, jtype, ntest, result, ioldsd,
2853 $ thresh, nounit, nerrs )
2854*
2855 1730 CONTINUE
2856 1740 CONTINUE
2857*
2858* Summary
2859*
2860 CALL alasvm( 'SST', nounit, nerrs, ntestt, 0 )
2861*
2862 9999 FORMAT( ' SDRVST2STG: ', a, ' returned INFO=', i6, '.', / 9x,
2863 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2864*
2865 RETURN
2866*
2867* End of SDRVST2STG
2868*
ssbev_2stage
subroutine ssbev_2stage(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, info)
SSBEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER m...
Definition ssbev_2stage.f:204
ssbevx_2stage
subroutine ssbevx_2stage(jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, iwork, ifail, info)
SSBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER ...
Definition ssbevx_2stage.f:322
ssbevd_2stage
subroutine ssbevd_2stage(jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, iwork, liwork, info)
SSBEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER ...
Definition ssbevd_2stage.f:234
ssytrd_sy2sb
subroutine ssytrd_sy2sb(uplo, n, kd, a, lda, ab, ldab, tau, work, lwork, info)
SSYTRD_SY2SB
Definition ssytrd_sy2sb.f:243
ssyevd_2stage
subroutine ssyevd_2stage(jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork, info)
SSYEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY mat...
Definition ssyevd_2stage.f:227
ssyevr_2stage
subroutine ssyevr_2stage(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)
SSYEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY mat...
Definition ssyevr_2stage.f:381
ssyev_2stage
subroutine ssyev_2stage(jobz, uplo, n, a, lda, w, work, lwork, info)
SSYEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matr...
Definition ssyev_2stage.f:183
ssyevx_2stage
subroutine ssyevx_2stage(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, iwork, ifail, info)
SSYEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY mat...
Definition ssyevx_2stage.f:300

◆ sdrvsx()

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

SDRVSX

Purpose:
!>
!>    SDRVSX checks the nonsymmetric eigenvalue (Schur form) problem
!>    expert driver SGEESX.
!>
!>    SDRVSX 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 SDRVSX 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 SGEESX 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 SGEESX 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 SDRVSX to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NIUNIT
!>          NIUNIT is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is REAL 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 REAL array, dimension (LDA, max(NN))
!>          Another copy of the test matrix A, modified by SGEESX.
!>
[out]HT
!>          HT is REAL array, dimension (LDA, max(NN))
!>          Yet another copy of the test matrix A, modified by SGEESX.
!>
[out]WR
!>          WR is REAL array, dimension (max(NN))
!>
[out]WI
!>          WI is REAL 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 REAL array, dimension (max(NN))
!>
[out]WIT
!>          WIT is REAL array, dimension (max(NN))
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when SGEESX only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]WRTMP
!>          WRTMP is REAL array, dimension (max(NN))
!>
[out]WITMP
!>          WITMP is REAL array, dimension (max(NN))
!>
!>          More temporary storage for eigenvalues.
!>
[out]VS
!>          VS is REAL 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 REAL array, dimension (LDVS, max(NN))
!>          VS1 holds another copy of the computed Schur vectors.
!>
[out]RESULT
!>          RESULT is REAL array, dimension (17)
!>          The values computed by the 17 tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]WORK
!>          WORK is REAL 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,  SLATMR, SLATMS, SLATME or SGET24 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 sdrvsx.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 REAL THRESH
463* ..
464* .. Array Arguments ..
465 LOGICAL BWORK( * ), DOTYPE( * )
466 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
467 REAL 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 REAL ZERO, ONE
477 parameter( zero = 0.0e0, one = 1.0e0 )
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,
486 $ NNWORK, NSLCT, NTEST, NTESTF, NTESTT
487 REAL 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 REAL 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 REAL SLAMCH
508 EXTERNAL slamch
509* ..
510* .. External Subroutines ..
511 EXTERNAL sget24, slabad, slasum, slatme, slatmr, slatms,
512 $ slaset, 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 ) = 'Single 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( 'SDRVSX', -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 = slamch( 'Safe minimum' )
585 ovfl = one / unfl
586 CALL slabad( unfl, ovfl )
587 ulp = slamch( '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 slaset( '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 slatms( 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 slatms( 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 slatme( 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 slatmr( 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 slatmr( 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 slatmr( 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 slaset( 'Full', 2, n, zero, zero, a, lda )
745 CALL slaset( 'Full', n-3, 1, zero, zero, a( 3, 1 ),
746 $ lda )
747 CALL slaset( 'Full', n-3, 2, zero, zero, a( 3, n-1 ),
748 $ lda )
749 CALL slaset( '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 slatmr( 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 sget24( .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 sget24( .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 slasum( path, nounit, nerrs, ntestt )
889*
890 9999 FORMAT( / 1x, a3, ' -- Real Schur Form Decomposition Expert ',
891 $ 'Driver', / ' Matrix types (see SDRVSX 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( ' SDRVSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
945 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
946*
947 RETURN
948*
949* End of SDRVSX
950*
sget24
subroutine sget24(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)
SGET24
Definition sget24.f:343

◆ sdrvvx()

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

SDRVVX

Purpose:
!>
!>    SDRVVX  checks the nonsymmetric eigenvalue problem expert driver
!>    SGEEVX.
!>
!>    SDRVVX 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 SDRVVX 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 SGEEVX 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 SGEEVX 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 SDRVVX to continue the same random number
!>          sequence.
!>
[in]THRESH
!>          THRESH is REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NIUNIT
!>          NIUNIT is INTEGER
!>          The FORTRAN unit number for reading in the data file of
!>          problems to solve.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[out]A
!>          A is REAL 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 REAL array, dimension
!>                      (LDA, max(NN,12))
!>          Another copy of the test matrix A, modified by SGEEVX.
!>
[out]WR
!>          WR is REAL array, dimension (max(NN))
!>
[out]WI
!>          WI is REAL 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 REAL array, dimension (max(NN,12))
!>
[out]WI1
!>          WI1 is REAL array, dimension (max(NN,12))
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when SGEEVX only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is REAL 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 REAL 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 REAL array, dimension
!>                      (LDLRE, max(NN,12))
!>          LRE holds the computed right or left eigenvectors.
!>
[in]LDLRE
!>          LDLRE is INTEGER
!>          Leading dimension of LRE. Must be at least max(1,max(NN,12))
!>
[out]RCONDV
!>          RCONDV is REAL array, dimension (N)
!>          RCONDV holds the computed reciprocal condition numbers
!>          for eigenvectors.
!>
[out]RCNDV1
!>          RCNDV1 is REAL array, dimension (N)
!>          RCNDV1 holds more computed reciprocal condition numbers
!>          for eigenvectors.
!>
[out]RCDVIN
!>          RCDVIN is REAL array, dimension (N)
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition numbers for eigenvectors to be compared with
!>          RCONDV.
!>
[out]RCONDE
!>          RCONDE is REAL array, dimension (N)
!>          RCONDE holds the computed reciprocal condition numbers
!>          for eigenvalues.
!>
[out]RCNDE1
!>          RCNDE1 is REAL array, dimension (N)
!>          RCNDE1 holds more computed reciprocal condition numbers
!>          for eigenvalues.
!>
[out]RCDEIN
!>          RCDEIN is REAL array, dimension (N)
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition numbers for eigenvalues to be compared with
!>          RCONDE.
!>
[out]SCALE
!>          SCALE is REAL array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]SCALE1
!>          SCALE1 is REAL array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]RESULT
!>          RESULT is REAL array, dimension (11)
!>          The values computed by the seven tests described above.
!>          The values are currently limited to 1/ulp, to avoid overflow.
!>
[out]WORK
!>          WORK is REAL 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, SLATMR, SLATMS, SLATME or SGET23 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 515 of file sdrvvx.f.

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

◆ serrbd()

subroutine serrbd ( character*3 path,
integer nunit )

SERRBD

Purpose:
!>
!> SERRBD tests the error exits for SGEBD2, SGEBRD, SORGBR, SORMBR,
!> SBDSQR, SBDSDC and SBDSVDX.
!>
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 serrbd.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 REAL ZERO, ONE
71 parameter( zero = 0.0e0, one = 1.0e0 )
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 REAL 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, sbdsdc, sbdsqr, sbdsvdx, sgebd2,
90 $ sgebrd, sorgbr, sormbr
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 real
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 / real( 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* SGEBRD
125*
126 srnamt = 'SGEBRD'
127 infot = 1
128 CALL sgebrd( -1, 0, a, 1, d, e, tq, tp, w, 1, info )
129 CALL chkxer( 'SGEBRD', infot, nout, lerr, ok )
130 infot = 2
131 CALL sgebrd( 0, -1, a, 1, d, e, tq, tp, w, 1, info )
132 CALL chkxer( 'SGEBRD', infot, nout, lerr, ok )
133 infot = 4
134 CALL sgebrd( 2, 1, a, 1, d, e, tq, tp, w, 2, info )
135 CALL chkxer( 'SGEBRD', infot, nout, lerr, ok )
136 infot = 10
137 CALL sgebrd( 2, 1, a, 2, d, e, tq, tp, w, 1, info )
138 CALL chkxer( 'SGEBRD', infot, nout, lerr, ok )
139 nt = nt + 4
140*
141* SGEBD2
142*
143 srnamt = 'SGEBD2'
144 infot = 1
145 CALL sgebd2( -1, 0, a, 1, d, e, tq, tp, w, info )
146 CALL chkxer( 'SGEBD2', infot, nout, lerr, ok )
147 infot = 2
148 CALL sgebd2( 0, -1, a, 1, d, e, tq, tp, w, info )
149 CALL chkxer( 'SGEBD2', infot, nout, lerr, ok )
150 infot = 4
151 CALL sgebd2( 2, 1, a, 1, d, e, tq, tp, w, info )
152 CALL chkxer( 'SGEBD2', infot, nout, lerr, ok )
153 nt = nt + 3
154*
155* SORGBR
156*
157 srnamt = 'SORGBR'
158 infot = 1
159 CALL sorgbr( '/', 0, 0, 0, a, 1, tq, w, 1, info )
160 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
161 infot = 2
162 CALL sorgbr( 'Q', -1, 0, 0, a, 1, tq, w, 1, info )
163 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
164 infot = 3
165 CALL sorgbr( 'Q', 0, -1, 0, a, 1, tq, w, 1, info )
166 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
167 infot = 3
168 CALL sorgbr( 'Q', 0, 1, 0, a, 1, tq, w, 1, info )
169 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
170 infot = 3
171 CALL sorgbr( 'Q', 1, 0, 1, a, 1, tq, w, 1, info )
172 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
173 infot = 3
174 CALL sorgbr( 'P', 1, 0, 0, a, 1, tq, w, 1, info )
175 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
176 infot = 3
177 CALL sorgbr( 'P', 0, 1, 1, a, 1, tq, w, 1, info )
178 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
179 infot = 4
180 CALL sorgbr( 'Q', 0, 0, -1, a, 1, tq, w, 1, info )
181 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
182 infot = 6
183 CALL sorgbr( 'Q', 2, 1, 1, a, 1, tq, w, 1, info )
184 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
185 infot = 9
186 CALL sorgbr( 'Q', 2, 2, 1, a, 2, tq, w, 1, info )
187 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
188 nt = nt + 10
189*
190* SORMBR
191*
192 srnamt = 'SORMBR'
193 infot = 1
194 CALL sormbr( '/', 'L', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
195 $ info )
196 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
197 infot = 2
198 CALL sormbr( 'Q', '/', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
199 $ info )
200 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
201 infot = 3
202 CALL sormbr( 'Q', 'L', '/', 0, 0, 0, a, 1, tq, u, 1, w, 1,
203 $ info )
204 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
205 infot = 4
206 CALL sormbr( 'Q', 'L', 'T', -1, 0, 0, a, 1, tq, u, 1, w, 1,
207 $ info )
208 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
209 infot = 5
210 CALL sormbr( 'Q', 'L', 'T', 0, -1, 0, a, 1, tq, u, 1, w, 1,
211 $ info )
212 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
213 infot = 6
214 CALL sormbr( 'Q', 'L', 'T', 0, 0, -1, a, 1, tq, u, 1, w, 1,
215 $ info )
216 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
217 infot = 8
218 CALL sormbr( 'Q', 'L', 'T', 2, 0, 0, a, 1, tq, u, 2, w, 1,
219 $ info )
220 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
221 infot = 8
222 CALL sormbr( 'Q', 'R', 'T', 0, 2, 0, a, 1, tq, u, 1, w, 1,
223 $ info )
224 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
225 infot = 8
226 CALL sormbr( 'P', 'L', 'T', 2, 0, 2, a, 1, tq, u, 2, w, 1,
227 $ info )
228 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
229 infot = 8
230 CALL sormbr( 'P', 'R', 'T', 0, 2, 2, a, 1, tq, u, 1, w, 1,
231 $ info )
232 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
233 infot = 11
234 CALL sormbr( 'Q', 'R', 'T', 2, 0, 0, a, 1, tq, u, 1, w, 1,
235 $ info )
236 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
237 infot = 13
238 CALL sormbr( 'Q', 'L', 'T', 0, 2, 0, a, 1, tq, u, 1, w, 1,
239 $ info )
240 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
241 infot = 13
242 CALL sormbr( 'Q', 'R', 'T', 2, 0, 0, a, 1, tq, u, 2, w, 1,
243 $ info )
244 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
245 nt = nt + 13
246*
247* SBDSQR
248*
249 srnamt = 'SBDSQR'
250 infot = 1
251 CALL sbdsqr( '/', 0, 0, 0, 0, d, e, v, 1, u, 1, a, 1, w, info )
252 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
253 infot = 2
254 CALL sbdsqr( 'U', -1, 0, 0, 0, d, e, v, 1, u, 1, a, 1, w,
255 $ info )
256 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
257 infot = 3
258 CALL sbdsqr( 'U', 0, -1, 0, 0, d, e, v, 1, u, 1, a, 1, w,
259 $ info )
260 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
261 infot = 4
262 CALL sbdsqr( 'U', 0, 0, -1, 0, d, e, v, 1, u, 1, a, 1, w,
263 $ info )
264 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
265 infot = 5
266 CALL sbdsqr( 'U', 0, 0, 0, -1, d, e, v, 1, u, 1, a, 1, w,
267 $ info )
268 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
269 infot = 9
270 CALL sbdsqr( 'U', 2, 1, 0, 0, d, e, v, 1, u, 1, a, 1, w, info )
271 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
272 infot = 11
273 CALL sbdsqr( 'U', 0, 0, 2, 0, d, e, v, 1, u, 1, a, 1, w, info )
274 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
275 infot = 13
276 CALL sbdsqr( 'U', 2, 0, 0, 1, d, e, v, 1, u, 1, a, 1, w, info )
277 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
278 nt = nt + 8
279*
280* SBDSDC
281*
282 srnamt = 'SBDSDC'
283 infot = 1
284 CALL sbdsdc( '/', 'N', 0, d, e, u, 1, v, 1, q, iq, w, iw,
285 $ info )
286 CALL chkxer( 'SBDSDC', infot, nout, lerr, ok )
287 infot = 2
288 CALL sbdsdc( 'U', '/', 0, d, e, u, 1, v, 1, q, iq, w, iw,
289 $ info )
290 CALL chkxer( 'SBDSDC', infot, nout, lerr, ok )
291 infot = 3
292 CALL sbdsdc( 'U', 'N', -1, d, e, u, 1, v, 1, q, iq, w, iw,
293 $ info )
294 CALL chkxer( 'SBDSDC', infot, nout, lerr, ok )
295 infot = 7
296 CALL sbdsdc( 'U', 'I', 2, d, e, u, 1, v, 1, q, iq, w, iw,
297 $ info )
298 CALL chkxer( 'SBDSDC', infot, nout, lerr, ok )
299 infot = 9
300 CALL sbdsdc( 'U', 'I', 2, d, e, u, 2, v, 1, q, iq, w, iw,
301 $ info )
302 CALL chkxer( 'SBDSDC', infot, nout, lerr, ok )
303 nt = nt + 5
304*
305* SBDSVDX
306*
307 srnamt = 'SBDSVDX'
308 infot = 1
309 CALL sbdsvdx( 'X', 'N', 'A', 1, d, e, zero, one, 0, 0,
310 $ ns, s, q, 1, w, iw, info)
311 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
312 infot = 2
313 CALL sbdsvdx( 'U', 'X', 'A', 1, d, e, zero, one, 0, 0,
314 $ ns, s, q, 1, w, iw, info)
315 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
316 infot = 3
317 CALL sbdsvdx( 'U', 'V', 'X', 1, d, e, zero, one, 0, 0,
318 $ ns, s, q, 1, w, iw, info)
319 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
320 infot = 4
321 CALL sbdsvdx( 'U', 'V', 'A', -1, d, e, zero, one, 0, 0,
322 $ ns, s, q, 1, w, iw, info)
323 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
324 infot = 7
325 CALL sbdsvdx( 'U', 'V', 'V', 2, d, e, -one, zero, 0, 0,
326 $ ns, s, q, 1, w, iw, info)
327 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
328 infot = 8
329 CALL sbdsvdx( 'U', 'V', 'V', 2, d, e, one, zero, 0, 0,
330 $ ns, s, q, 1, w, iw, info)
331 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
332 infot = 9
333 CALL sbdsvdx( 'L', 'V', 'I', 2, d, e, zero, zero, 0, 2,
334 $ ns, s, q, 1, w, iw, info)
335 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
336 infot = 9
337 CALL sbdsvdx( 'L', 'V', 'I', 4, d, e, zero, zero, 5, 2,
338 $ ns, s, q, 1, w, iw, info)
339 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
340 infot = 10
341 CALL sbdsvdx( 'L', 'V', 'I', 4, d, e, zero, zero, 3, 2,
342 $ ns, s, q, 1, w, iw, info)
343 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
344 infot = 10
345 CALL sbdsvdx( 'L', 'V', 'I', 4, d, e, zero, zero, 3, 5,
346 $ ns, s, q, 1, w, iw, info)
347 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
348 infot = 14
349 CALL sbdsvdx( 'L', 'V', 'A', 4, d, e, zero, zero, 0, 0,
350 $ ns, s, q, 0, w, iw, info)
351 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
352 infot = 14
353 CALL sbdsvdx( 'L', 'V', 'A', 4, d, e, zero, zero, 0, 0,
354 $ ns, s, q, 2, w, iw, info)
355 CALL chkxer( 'SBDSVDX', 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 SERRBD
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
sgebd2
subroutine sgebd2(m, n, a, lda, d, e, tauq, taup, work, info)
SGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
Definition sgebd2.f:189
sormbr
subroutine sormbr(vect, side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
SORMBR
Definition sormbr.f:196

◆ serrec()

subroutine serrec ( character*3 path,
integer nunit )

SERREC

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

◆ serred()

subroutine serred ( character*3 path,
integer nunit )

SERRED

Purpose:
!>
!> SERRED tests the error exits for the eigenvalue driver routines for
!> REAL matrices:
!>
!> PATH  driver   description
!> ----  ------   -----------
!> SEV   SGEEV    find eigenvalues/eigenvectors for nonsymmetric A
!> SES   SGEES    find eigenvalues/Schur form for nonsymmetric A
!> SVX   SGEEVX   SGEEV + balancing and condition estimation
!> SSX   SGEESX   SGEES + balancing and condition estimation
!> SBD   SGESVD   compute SVD of an M-by-N matrix A
!>       SGESDD   compute SVD of an M-by-N matrix A (by divide and
!>                conquer)
!>       SGEJSV   compute SVD of an M-by-N matrix A where M >= N
!>       SGESVDX  compute SVD of an M-by-N matrix A(by bisection
!>                and inverse iteration)
!>       SGESVDQ  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 serred.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 REAL ONE, ZERO
85 parameter( nmax = 4, one = 1.0e0, zero = 0.0e0 )
86* ..
87* .. Local Scalars ..
88 CHARACTER*2 C2
89 INTEGER I, IHI, ILO, INFO, J, NS, NT, SDIM
90 REAL ABNRM
91* ..
92* .. Local Arrays ..
93 LOGICAL B( NMAX )
94 INTEGER IW( 2*NMAX )
95 REAL 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, sgees, sgeesx, sgeev, sgeevx, sgejsv,
102 $ sgesdd, sgesvd, sgesvdx, sgesvdq
103* ..
104* .. External Functions ..
105 LOGICAL SSLECT, LSAMEN
106 EXTERNAL sslect, lsamen
107* ..
108* .. Intrinsic Functions ..
109 INTRINSIC len_trim
110* ..
111* .. Arrays in Common ..
112 LOGICAL SELVAL( 20 )
113 REAL 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 SGEEV
147*
148 srnamt = 'SGEEV '
149 infot = 1
150 CALL sgeev( 'X', 'N', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
151 $ info )
152 CALL chkxer( 'SGEEV ', infot, nout, lerr, ok )
153 infot = 2
154 CALL sgeev( 'N', 'X', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
155 $ info )
156 CALL chkxer( 'SGEEV ', infot, nout, lerr, ok )
157 infot = 3
158 CALL sgeev( 'N', 'N', -1, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
159 $ info )
160 CALL chkxer( 'SGEEV ', infot, nout, lerr, ok )
161 infot = 5
162 CALL sgeev( 'N', 'N', 2, a, 1, wr, wi, vl, 1, vr, 1, w, 6,
163 $ info )
164 CALL chkxer( 'SGEEV ', infot, nout, lerr, ok )
165 infot = 9
166 CALL sgeev( 'V', 'N', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
167 $ info )
168 CALL chkxer( 'SGEEV ', infot, nout, lerr, ok )
169 infot = 11
170 CALL sgeev( 'N', 'V', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
171 $ info )
172 CALL chkxer( 'SGEEV ', infot, nout, lerr, ok )
173 infot = 13
174 CALL sgeev( 'V', 'V', 1, a, 1, wr, wi, vl, 1, vr, 1, w, 3,
175 $ info )
176 CALL chkxer( 'SGEEV ', infot, nout, lerr, ok )
177 nt = nt + 7
178*
179 ELSE IF( lsamen( 2, c2, 'ES' ) ) THEN
180*
181* Test SGEES
182*
183 srnamt = 'SGEES '
184 infot = 1
185 CALL sgees( 'X', 'N', sslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
186 $ 1, b, info )
187 CALL chkxer( 'SGEES ', infot, nout, lerr, ok )
188 infot = 2
189 CALL sgees( 'N', 'X', sslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
190 $ 1, b, info )
191 CALL chkxer( 'SGEES ', infot, nout, lerr, ok )
192 infot = 4
193 CALL sgees( 'N', 'S', sslect, -1, a, 1, sdim, wr, wi, vl, 1, w,
194 $ 1, b, info )
195 CALL chkxer( 'SGEES ', infot, nout, lerr, ok )
196 infot = 6
197 CALL sgees( 'N', 'S', sslect, 2, a, 1, sdim, wr, wi, vl, 1, w,
198 $ 6, b, info )
199 CALL chkxer( 'SGEES ', infot, nout, lerr, ok )
200 infot = 11
201 CALL sgees( 'V', 'S', sslect, 2, a, 2, sdim, wr, wi, vl, 1, w,
202 $ 6, b, info )
203 CALL chkxer( 'SGEES ', infot, nout, lerr, ok )
204 infot = 13
205 CALL sgees( 'N', 'S', sslect, 1, a, 1, sdim, wr, wi, vl, 1, w,
206 $ 2, b, info )
207 CALL chkxer( 'SGEES ', infot, nout, lerr, ok )
208 nt = nt + 6
209*
210 ELSE IF( lsamen( 2, c2, 'VX' ) ) THEN
211*
212* Test SGEEVX
213*
214 srnamt = 'SGEEVX'
215 infot = 1
216 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
219 infot = 2
220 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
223 infot = 3
224 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
227 infot = 4
228 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
231 infot = 5
232 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
235 infot = 7
236 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
239 infot = 11
240 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
243 infot = 13
244 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
247 infot = 21
248 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
251 infot = 21
252 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
255 infot = 21
256 CALL sgeevx( '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( 'SGEEVX', infot, nout, lerr, ok )
259 nt = nt + 11
260*
261 ELSE IF( lsamen( 2, c2, 'SX' ) ) THEN
262*
263* Test SGEESX
264*
265 srnamt = 'SGEESX'
266 infot = 1
267 CALL sgeesx( 'X', 'N', sslect, 'N', 0, a, 1, sdim, wr, wi, vl,
268 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
269 CALL chkxer( 'SGEESX', infot, nout, lerr, ok )
270 infot = 2
271 CALL sgeesx( 'N', 'X', sslect, 'N', 0, a, 1, sdim, wr, wi, vl,
272 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
273 CALL chkxer( 'SGEESX', infot, nout, lerr, ok )
274 infot = 4
275 CALL sgeesx( 'N', 'N', sslect, 'X', 0, a, 1, sdim, wr, wi, vl,
276 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
277 CALL chkxer( 'SGEESX', infot, nout, lerr, ok )
278 infot = 5
279 CALL sgeesx( 'N', 'N', sslect, 'N', -1, a, 1, sdim, wr, wi, vl,
280 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
281 CALL chkxer( 'SGEESX', infot, nout, lerr, ok )
282 infot = 7
283 CALL sgeesx( 'N', 'N', sslect, 'N', 2, a, 1, sdim, wr, wi, vl,
284 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
285 CALL chkxer( 'SGEESX', infot, nout, lerr, ok )
286 infot = 12
287 CALL sgeesx( 'V', 'N', sslect, 'N', 2, a, 2, sdim, wr, wi, vl,
288 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
289 CALL chkxer( 'SGEESX', infot, nout, lerr, ok )
290 infot = 16
291 CALL sgeesx( 'N', 'N', sslect, 'N', 1, a, 1, sdim, wr, wi, vl,
292 $ 1, r1( 1 ), r2( 1 ), w, 2, iw, 1, b, info )
293 CALL chkxer( 'SGEESX', infot, nout, lerr, ok )
294 nt = nt + 7
295*
296 ELSE IF( lsamen( 2, c2, 'BD' ) ) THEN
297*
298* Test SGESVD
299*
300 srnamt = 'SGESVD'
301 infot = 1
302 CALL sgesvd( 'X', 'N', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
303 CALL chkxer( 'SGESVD', infot, nout, lerr, ok )
304 infot = 2
305 CALL sgesvd( 'N', 'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
306 CALL chkxer( 'SGESVD', infot, nout, lerr, ok )
307 infot = 2
308 CALL sgesvd( 'O', 'O', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
309 CALL chkxer( 'SGESVD', infot, nout, lerr, ok )
310 infot = 3
311 CALL sgesvd( 'N', 'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1,
312 $ info )
313 CALL chkxer( 'SGESVD', infot, nout, lerr, ok )
314 infot = 4
315 CALL sgesvd( 'N', 'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1,
316 $ info )
317 CALL chkxer( 'SGESVD', infot, nout, lerr, ok )
318 infot = 6
319 CALL sgesvd( 'N', 'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, info )
320 CALL chkxer( 'SGESVD', infot, nout, lerr, ok )
321 infot = 9
322 CALL sgesvd( 'A', 'N', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, info )
323 CALL chkxer( 'SGESVD', infot, nout, lerr, ok )
324 infot = 11
325 CALL sgesvd( 'N', 'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, info )
326 CALL chkxer( 'SGESVD', 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 SGESDD
336*
337 srnamt = 'SGESDD'
338 infot = 1
339 CALL sgesdd( 'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
340 CALL chkxer( 'SGESDD', infot, nout, lerr, ok )
341 infot = 2
342 CALL sgesdd( 'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
343 CALL chkxer( 'SGESDD', infot, nout, lerr, ok )
344 infot = 3
345 CALL sgesdd( 'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
346 CALL chkxer( 'SGESDD', infot, nout, lerr, ok )
347 infot = 5
348 CALL sgesdd( 'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
349 CALL chkxer( 'SGESDD', infot, nout, lerr, ok )
350 infot = 8
351 CALL sgesdd( 'A', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, iw, info )
352 CALL chkxer( 'SGESDD', infot, nout, lerr, ok )
353 infot = 10
354 CALL sgesdd( 'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
355 CALL chkxer( 'SGESDD', 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 SGEJSV
365*
366 srnamt = 'SGEJSV'
367 infot = 1
368 CALL sgejsv( 'X', 'U', 'V', 'R', 'N', 'N',
369 $ 0, 0, a, 1, s, u, 1, vt, 1,
370 $ w, 1, iw, info)
371 CALL chkxer( 'SGEJSV', infot, nout, lerr, ok )
372 infot = 2
373 CALL sgejsv( 'G', 'X', 'V', 'R', 'N', 'N',
374 $ 0, 0, a, 1, s, u, 1, vt, 1,
375 $ w, 1, iw, info)
376 CALL chkxer( 'SGEJSV', infot, nout, lerr, ok )
377 infot = 3
378 CALL sgejsv( 'G', 'U', 'X', 'R', 'N', 'N',
379 $ 0, 0, a, 1, s, u, 1, vt, 1,
380 $ w, 1, iw, info)
381 CALL chkxer( 'SGEJSV', infot, nout, lerr, ok )
382 infot = 4
383 CALL sgejsv( 'G', 'U', 'V', 'X', 'N', 'N',
384 $ 0, 0, a, 1, s, u, 1, vt, 1,
385 $ w, 1, iw, info)
386 CALL chkxer( 'SGEJSV', infot, nout, lerr, ok )
387 infot = 5
388 CALL sgejsv( 'G', 'U', 'V', 'R', 'X', 'N',
389 $ 0, 0, a, 1, s, u, 1, vt, 1,
390 $ w, 1, iw, info)
391 CALL chkxer( 'SGEJSV', infot, nout, lerr, ok )
392 infot = 6
393 CALL sgejsv( 'G', 'U', 'V', 'R', 'N', 'X',
394 $ 0, 0, a, 1, s, u, 1, vt, 1,
395 $ w, 1, iw, info)
396 CALL chkxer( 'SGEJSV', infot, nout, lerr, ok )
397 infot = 7
398 CALL sgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
399 $ -1, 0, a, 1, s, u, 1, vt, 1,
400 $ w, 1, iw, info)
401 CALL chkxer( 'SGEJSV', infot, nout, lerr, ok )
402 infot = 8
403 CALL sgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
404 $ 0, -1, a, 1, s, u, 1, vt, 1,
405 $ w, 1, iw, info)
406 CALL chkxer( 'SGEJSV', infot, nout, lerr, ok )
407 infot = 10
408 CALL sgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
409 $ 2, 1, a, 1, s, u, 1, vt, 1,
410 $ w, 1, iw, info)
411 CALL chkxer( 'SGEJSV', infot, nout, lerr, ok )
412 infot = 13
413 CALL sgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
414 $ 2, 2, a, 2, s, u, 1, vt, 2,
415 $ w, 1, iw, info)
416 CALL chkxer( 'SGEJSV', infot, nout, lerr, ok )
417 infot = 15
418 CALL sgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
419 $ 2, 2, a, 2, s, u, 2, vt, 1,
420 $ w, 1, iw, info)
421 CALL chkxer( 'SGEJSV', 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 SGESVDX
431*
432 srnamt = 'SGESVDX'
433 infot = 1
434 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
437 infot = 2
438 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
441 infot = 3
442 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
445 infot = 4
446 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
449 infot = 5
450 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
453 infot = 7
454 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
457 infot = 8
458 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
461 infot = 9
462 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
465 infot = 10
466 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
469 infot = 11
470 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
473 infot = 15
474 CALL sgesvdx( '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( 'SGESVDX', infot, nout, lerr, ok )
477 infot = 17
478 CALL sgesvdx( '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( 'SGESVDX', 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 SGESVDQ
490*
491 srnamt = 'SGESVDQ'
492 infot = 1
493 CALL sgesvdq( '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( 'SGESVDQ', infot, nout, lerr, ok )
496 infot = 2
497 CALL sgesvdq( '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( 'SGESVDQ', infot, nout, lerr, ok )
500 infot = 3
501 CALL sgesvdq( '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( 'SGESVDQ', infot, nout, lerr, ok )
504 infot = 4
505 CALL sgesvdq( '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( 'SGESVDQ', infot, nout, lerr, ok )
508 infot = 5
509 CALL sgesvdq( '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( 'SGESVDQ', infot, nout, lerr, ok )
512 infot = 6
513 CALL sgesvdq( '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( 'SGESVDQ', infot, nout, lerr, ok )
516 infot = 7
517 CALL sgesvdq( '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( 'SGESVDQ', infot, nout, lerr, ok )
520 infot = 9
521 CALL sgesvdq( '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( 'SGESVDQ', infot, nout, lerr, ok )
524 infot = 12
525 CALL sgesvdq( '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( 'SGESVDQ', infot, nout, lerr, ok )
528 infot = 14
529 CALL sgesvdq( '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( 'SGESVDQ', infot, nout, lerr, ok )
532 infot = 17
533 CALL sgesvdq( '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( 'SGESVDQ', 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 SERRED
562*
sgeesx
subroutine sgeesx(jobvs, sort, select, sense, n, a, lda, sdim, wr, wi, vs, ldvs, rconde, rcondv, work, lwork, iwork, liwork, bwork, info)
SGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition sgeesx.f:281
sgeevx
subroutine sgeevx(balanc, jobvl, jobvr, sense, n, a, lda, wr, wi, vl, ldvl, vr, ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, work, lwork, iwork, info)
SGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition sgeevx.f:306

◆ serrgg()

subroutine serrgg ( character*3 path,
integer nunit )

SERRGG

Purpose:
!>
!> SERRGG tests the error exits for SGGES, SGGESX, SGGEV, SGGEVX,
!> SGGES3, SGGEV3, SGGGLM, SGGHRD, SGGLSE, SGGQRF, SGGRQF,
!> SGGSVD3, SGGSVP3, SHGEQZ, SORCSD, STGEVC, STGEXC, STGSEN,
!> STGSJA, STGSNA, and STGSYL.
!>
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 serrgg.f.

57*
58* -- LAPACK test routine --
59* -- LAPACK is a software package provided by Univ. of Tennessee, --
60* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
61*
62* .. Scalar Arguments ..
63 CHARACTER*3 PATH
64 INTEGER NUNIT
65* ..
66*
67* =====================================================================
68*
69* .. Parameters ..
70 INTEGER NMAX, LW
71 parameter( nmax = 3, lw = 6*nmax )
72 REAL ONE, ZERO
73 parameter( one = 1.0e+0, zero = 0.0e+0 )
74* ..
75* .. Local Scalars ..
76 CHARACTER*2 C2
77 INTEGER DUMMYK, DUMMYL, I, IFST, ILO, IHI, ILST, INFO,
78 $ J, M, NCYCLE, NT, SDIM, LWORK
79 REAL ANRM, BNRM, DIF, SCALE, TOLA, TOLB
80* ..
81* .. Local Arrays ..
82 LOGICAL BW( NMAX ), SEL( NMAX )
83 INTEGER IW( NMAX ), IDUM(NMAX)
84 REAL 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 LSAMEN, SLCTES, SLCTSX
92 EXTERNAL lsamen, slctes, slctsx
93* ..
94* .. External Subroutines ..
95 EXTERNAL chkxer, sgges, sggesx, sggev, sggevx, sggglm,
96 $ sgghrd, sgglse, sggqrf, sggrqf,
97 $ shgeqz, sorcsd, stgevc, stgexc, stgsen, stgsja,
98 $ stgsna, stgsyl, sgges3, sggev3, sgghd3,
99 $ sggsvd3, sggsvp3, 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.0e0
131 tolb = 1.0e0
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* SGGHRD
150*
151 srnamt = 'SGGHRD'
152 infot = 1
153 CALL sgghrd( '/', 'N', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, info )
154 CALL chkxer( 'SGGHRD', infot, nout, lerr, ok )
155 infot = 2
156 CALL sgghrd( 'N', '/', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, info )
157 CALL chkxer( 'SGGHRD', infot, nout, lerr, ok )
158 infot = 3
159 CALL sgghrd( 'N', 'N', -1, 0, 0, a, 1, b, 1, q, 1, z, 1, info )
160 CALL chkxer( 'SGGHRD', infot, nout, lerr, ok )
161 infot = 4
162 CALL sgghrd( 'N', 'N', 0, 0, 0, a, 1, b, 1, q, 1, z, 1, info )
163 CALL chkxer( 'SGGHRD', infot, nout, lerr, ok )
164 infot = 5
165 CALL sgghrd( 'N', 'N', 0, 1, 1, a, 1, b, 1, q, 1, z, 1, info )
166 CALL chkxer( 'SGGHRD', infot, nout, lerr, ok )
167 infot = 7
168 CALL sgghrd( 'N', 'N', 2, 1, 1, a, 1, b, 2, q, 1, z, 1, info )
169 CALL chkxer( 'SGGHRD', infot, nout, lerr, ok )
170 infot = 9
171 CALL sgghrd( 'N', 'N', 2, 1, 1, a, 2, b, 1, q, 1, z, 1, info )
172 CALL chkxer( 'SGGHRD', infot, nout, lerr, ok )
173 infot = 11
174 CALL sgghrd( 'V', 'N', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, info )
175 CALL chkxer( 'SGGHRD', infot, nout, lerr, ok )
176 infot = 13
177 CALL sgghrd( 'N', 'V', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, info )
178 CALL chkxer( 'SGGHRD', infot, nout, lerr, ok )
179 nt = nt + 9
180*
181* SGGHD3
182*
183 srnamt = 'SGGHD3'
184 infot = 1
185 CALL sgghd3( '/', 'N', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
186 $ info )
187 CALL chkxer( 'SGGHD3', infot, nout, lerr, ok )
188 infot = 2
189 CALL sgghd3( 'N', '/', 0, 1, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
190 $ info )
191 CALL chkxer( 'SGGHD3', infot, nout, lerr, ok )
192 infot = 3
193 CALL sgghd3( 'N', 'N', -1, 0, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
194 $ info )
195 CALL chkxer( 'SGGHD3', infot, nout, lerr, ok )
196 infot = 4
197 CALL sgghd3( 'N', 'N', 0, 0, 0, a, 1, b, 1, q, 1, z, 1, w, lw,
198 $ info )
199 CALL chkxer( 'SGGHD3', infot, nout, lerr, ok )
200 infot = 5
201 CALL sgghd3( 'N', 'N', 0, 1, 1, a, 1, b, 1, q, 1, z, 1, w, lw,
202 $ info )
203 CALL chkxer( 'SGGHD3', infot, nout, lerr, ok )
204 infot = 7
205 CALL sgghd3( 'N', 'N', 2, 1, 1, a, 1, b, 2, q, 1, z, 1, w, lw,
206 $ info )
207 CALL chkxer( 'SGGHD3', infot, nout, lerr, ok )
208 infot = 9
209 CALL sgghd3( 'N', 'N', 2, 1, 1, a, 2, b, 1, q, 1, z, 1, w, lw,
210 $ info )
211 CALL chkxer( 'SGGHD3', infot, nout, lerr, ok )
212 infot = 11
213 CALL sgghd3( 'V', 'N', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, w, lw,
214 $ info )
215 CALL chkxer( 'SGGHD3', infot, nout, lerr, ok )
216 infot = 13
217 CALL sgghd3( 'N', 'V', 2, 1, 1, a, 2, b, 2, q, 1, z, 1, w, lw,
218 $ info )
219 CALL chkxer( 'SGGHD3', infot, nout, lerr, ok )
220 nt = nt + 9
221*
222* SHGEQZ
223*
224 srnamt = 'SHGEQZ'
225 infot = 1
226 CALL shgeqz( '/', 'N', 'N', 0, 1, 0, a, 1, b, 1, r1, r2, r3, q,
227 $ 1, z, 1, w, lw, info )
228 CALL chkxer( 'SHGEQZ', infot, nout, lerr, ok )
229 infot = 2
230 CALL shgeqz( 'E', '/', 'N', 0, 1, 0, a, 1, b, 1, r1, r2, r3, q,
231 $ 1, z, 1, w, lw, info )
232 CALL chkxer( 'SHGEQZ', infot, nout, lerr, ok )
233 infot = 3
234 CALL shgeqz( 'E', 'N', '/', 0, 1, 0, a, 1, b, 1, r1, r2, r3, q,
235 $ 1, z, 1, w, lw, info )
236 CALL chkxer( 'SHGEQZ', infot, nout, lerr, ok )
237 infot = 4
238 CALL shgeqz( 'E', 'N', 'N', -1, 0, 0, a, 1, b, 1, r1, r2, r3,
239 $ q, 1, z, 1, w, lw, info )
240 CALL chkxer( 'SHGEQZ', infot, nout, lerr, ok )
241 infot = 5
242 CALL shgeqz( 'E', 'N', 'N', 0, 0, 0, a, 1, b, 1, r1, r2, r3, q,
243 $ 1, z, 1, w, lw, info )
244 CALL chkxer( 'SHGEQZ', infot, nout, lerr, ok )
245 infot = 6
246 CALL shgeqz( 'E', 'N', 'N', 0, 1, 1, a, 1, b, 1, r1, r2, r3, q,
247 $ 1, z, 1, w, lw, info )
248 CALL chkxer( 'SHGEQZ', infot, nout, lerr, ok )
249 infot = 8
250 CALL shgeqz( 'E', 'N', 'N', 2, 1, 1, a, 1, b, 2, r1, r2, r3, q,
251 $ 1, z, 1, w, lw, info )
252 CALL chkxer( 'SHGEQZ', infot, nout, lerr, ok )
253 infot = 10
254 CALL shgeqz( 'E', 'N', 'N', 2, 1, 1, a, 2, b, 1, r1, r2, r3, q,
255 $ 1, z, 1, w, lw, info )
256 CALL chkxer( 'SHGEQZ', infot, nout, lerr, ok )
257 infot = 15
258 CALL shgeqz( 'E', 'V', 'N', 2, 1, 1, a, 2, b, 2, r1, r2, r3, q,
259 $ 1, z, 1, w, lw, info )
260 CALL chkxer( 'SHGEQZ', infot, nout, lerr, ok )
261 infot = 17
262 CALL shgeqz( 'E', 'N', 'V', 2, 1, 1, a, 2, b, 2, r1, r2, r3, q,
263 $ 1, z, 1, w, lw, info )
264 CALL chkxer( 'SHGEQZ', infot, nout, lerr, ok )
265 nt = nt + 10
266*
267* STGEVC
268*
269 srnamt = 'STGEVC'
270 infot = 1
271 CALL stgevc( '/', 'A', sel, 0, a, 1, b, 1, q, 1, z, 1, 0, m, w,
272 $ info )
273 CALL chkxer( 'STGEVC', infot, nout, lerr, ok )
274 infot = 2
275 CALL stgevc( 'R', '/', sel, 0, a, 1, b, 1, q, 1, z, 1, 0, m, w,
276 $ info )
277 CALL chkxer( 'STGEVC', infot, nout, lerr, ok )
278 infot = 4
279 CALL stgevc( 'R', 'A', sel, -1, a, 1, b, 1, q, 1, z, 1, 0, m,
280 $ w, info )
281 CALL chkxer( 'STGEVC', infot, nout, lerr, ok )
282 infot = 6
283 CALL stgevc( 'R', 'A', sel, 2, a, 1, b, 2, q, 1, z, 2, 0, m, w,
284 $ info )
285 CALL chkxer( 'STGEVC', infot, nout, lerr, ok )
286 infot = 8
287 CALL stgevc( 'R', 'A', sel, 2, a, 2, b, 1, q, 1, z, 2, 0, m, w,
288 $ info )
289 CALL chkxer( 'STGEVC', infot, nout, lerr, ok )
290 infot = 10
291 CALL stgevc( 'L', 'A', sel, 2, a, 2, b, 2, q, 1, z, 1, 0, m, w,
292 $ info )
293 CALL chkxer( 'STGEVC', infot, nout, lerr, ok )
294 infot = 12
295 CALL stgevc( 'R', 'A', sel, 2, a, 2, b, 2, q, 1, z, 1, 0, m, w,
296 $ info )
297 CALL chkxer( 'STGEVC', infot, nout, lerr, ok )
298 infot = 13
299 CALL stgevc( 'R', 'A', sel, 2, a, 2, b, 2, q, 1, z, 2, 1, m, w,
300 $ info )
301 CALL chkxer( 'STGEVC', 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* SGGSVD3
309*
310 srnamt = 'SGGSVD3'
311 infot = 1
312 CALL sggsvd3( '/', '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( 'SGGSVD3', infot, nout, lerr, ok )
315 infot = 2
316 CALL sggsvd3( '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( 'SGGSVD3', infot, nout, lerr, ok )
319 infot = 3
320 CALL sggsvd3( '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( 'SGGSVD3', infot, nout, lerr, ok )
323 infot = 4
324 CALL sggsvd3( '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( 'SGGSVD3', infot, nout, lerr, ok )
327 infot = 5
328 CALL sggsvd3( '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( 'SGGSVD3', infot, nout, lerr, ok )
331 infot = 6
332 CALL sggsvd3( '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( 'SGGSVD3', infot, nout, lerr, ok )
335 infot = 10
336 CALL sggsvd3( '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( 'SGGSVD3', infot, nout, lerr, ok )
339 infot = 12
340 CALL sggsvd3( '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( 'SGGSVD3', infot, nout, lerr, ok )
343 infot = 16
344 CALL sggsvd3( '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( 'SGGSVD3', infot, nout, lerr, ok )
347 infot = 18
348 CALL sggsvd3( '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( 'SGGSVD3', infot, nout, lerr, ok )
351 infot = 20
352 CALL sggsvd3( '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( 'SGGSVD3', infot, nout, lerr, ok )
355 nt = nt + 11
356*
357* SGGSVP3
358*
359 srnamt = 'SGGSVP3'
360 infot = 1
361 CALL sggsvp3( '/', '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( 'SGGSVP3', infot, nout, lerr, ok )
365 infot = 2
366 CALL sggsvp3( '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( 'SGGSVP3', infot, nout, lerr, ok )
370 infot = 3
371 CALL sggsvp3( '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( 'SGGSVP3', infot, nout, lerr, ok )
375 infot = 4
376 CALL sggsvp3( '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( 'SGGSVP3', infot, nout, lerr, ok )
380 infot = 5
381 CALL sggsvp3( '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( 'SGGSVP3', infot, nout, lerr, ok )
385 infot = 6
386 CALL sggsvp3( '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( 'SGGSVP3', infot, nout, lerr, ok )
390 infot = 8
391 CALL sggsvp3( '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( 'SGGSVP3', infot, nout, lerr, ok )
395 infot = 10
396 CALL sggsvp3( '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( 'SGGSVP3', infot, nout, lerr, ok )
400 infot = 16
401 CALL sggsvp3( '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( 'SGGSVP3', infot, nout, lerr, ok )
405 infot = 18
406 CALL sggsvp3( '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( 'SGGSVP3', infot, nout, lerr, ok )
410 infot = 20
411 CALL sggsvp3( '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( 'SGGSVP3', infot, nout, lerr, ok )
415 nt = nt + 11
416*
417* STGSJA
418*
419 srnamt = 'STGSJA'
420 infot = 1
421 CALL stgsja( '/', '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( 'STGSJA', infot, nout, lerr, ok )
425 infot = 2
426 CALL stgsja( '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( 'STGSJA', infot, nout, lerr, ok )
430 infot = 3
431 CALL stgsja( '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( 'STGSJA', infot, nout, lerr, ok )
435 infot = 4
436 CALL stgsja( '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( 'STGSJA', infot, nout, lerr, ok )
440 infot = 5
441 CALL stgsja( '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( 'STGSJA', infot, nout, lerr, ok )
445 infot = 6
446 CALL stgsja( '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( 'STGSJA', infot, nout, lerr, ok )
450 infot = 10
451 CALL stgsja( '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( 'STGSJA', infot, nout, lerr, ok )
455 infot = 12
456 CALL stgsja( '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( 'STGSJA', infot, nout, lerr, ok )
460 infot = 18
461 CALL stgsja( '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( 'STGSJA', infot, nout, lerr, ok )
465 infot = 20
466 CALL stgsja( '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( 'STGSJA', infot, nout, lerr, ok )
470 infot = 22
471 CALL stgsja( '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( 'STGSJA', 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* SGGGLM
482*
483 srnamt = 'SGGGLM'
484 infot = 1
485 CALL sggglm( -1, 0, 0, a, 1, b, 1, r1, r2, r3, w, lw, info )
486 CALL chkxer( 'SGGGLM', infot, nout, lerr, ok )
487 infot = 2
488 CALL sggglm( 0, -1, 0, a, 1, b, 1, r1, r2, r3, w, lw, info )
489 CALL chkxer( 'SGGGLM', infot, nout, lerr, ok )
490 infot = 2
491 CALL sggglm( 0, 1, 0, a, 1, b, 1, r1, r2, r3, w, lw, info )
492 CALL chkxer( 'SGGGLM', infot, nout, lerr, ok )
493 infot = 3
494 CALL sggglm( 0, 0, -1, a, 1, b, 1, r1, r2, r3, w, lw, info )
495 CALL chkxer( 'SGGGLM', infot, nout, lerr, ok )
496 infot = 3
497 CALL sggglm( 1, 0, 0, a, 1, b, 1, r1, r2, r3, w, lw, info )
498 CALL chkxer( 'SGGGLM', infot, nout, lerr, ok )
499 infot = 5
500 CALL sggglm( 0, 0, 0, a, 0, b, 1, r1, r2, r3, w, lw, info )
501 CALL chkxer( 'SGGGLM', infot, nout, lerr, ok )
502 infot = 7
503 CALL sggglm( 0, 0, 0, a, 1, b, 0, r1, r2, r3, w, lw, info )
504 CALL chkxer( 'SGGGLM', infot, nout, lerr, ok )
505 infot = 12
506 CALL sggglm( 1, 1, 1, a, 1, b, 1, r1, r2, r3, w, 1, info )
507 CALL chkxer( 'SGGGLM', 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* SGGLSE
515*
516 srnamt = 'SGGLSE'
517 infot = 1
518 CALL sgglse( -1, 0, 0, a, 1, b, 1, r1, r2, r3, w, lw, info )
519 CALL chkxer( 'SGGLSE', infot, nout, lerr, ok )
520 infot = 2
521 CALL sgglse( 0, -1, 0, a, 1, b, 1, r1, r2, r3, w, lw, info )
522 CALL chkxer( 'SGGLSE', infot, nout, lerr, ok )
523 infot = 3
524 CALL sgglse( 0, 0, -1, a, 1, b, 1, r1, r2, r3, w, lw, info )
525 CALL chkxer( 'SGGLSE', infot, nout, lerr, ok )
526 infot = 3
527 CALL sgglse( 0, 0, 1, a, 1, b, 1, r1, r2, r3, w, lw, info )
528 CALL chkxer( 'SGGLSE', infot, nout, lerr, ok )
529 infot = 3
530 CALL sgglse( 0, 1, 0, a, 1, b, 1, r1, r2, r3, w, lw, info )
531 CALL chkxer( 'SGGLSE', infot, nout, lerr, ok )
532 infot = 5
533 CALL sgglse( 0, 0, 0, a, 0, b, 1, r1, r2, r3, w, lw, info )
534 CALL chkxer( 'SGGLSE', infot, nout, lerr, ok )
535 infot = 7
536 CALL sgglse( 0, 0, 0, a, 1, b, 0, r1, r2, r3, w, lw, info )
537 CALL chkxer( 'SGGLSE', infot, nout, lerr, ok )
538 infot = 12
539 CALL sgglse( 1, 1, 1, a, 1, b, 1, r1, r2, r3, w, 1, info )
540 CALL chkxer( 'SGGLSE', 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* SORCSD
548*
549 srnamt = 'SORCSD'
550 infot = 7
551 CALL sorcsd( '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( 'SORCSD', infot, nout, lerr, ok )
557 infot = 8
558 CALL sorcsd( '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( 'SORCSD', infot, nout, lerr, ok )
564 infot = 9
565 CALL sorcsd( '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( 'SORCSD', infot, nout, lerr, ok )
571 infot = 11
572 CALL sorcsd( '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( 'SORCSD', infot, nout, lerr, ok )
578 infot = 20
579 CALL sorcsd( '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( 'SORCSD', infot, nout, lerr, ok )
585 infot = 22
586 CALL sorcsd( '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( 'SORCSD', infot, nout, lerr, ok )
592 infot = 24
593 CALL sorcsd( '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( 'SORCSD', infot, nout, lerr, ok )
599 infot = 26
600 CALL sorcsd( '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( 'SORCSD', 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* SGGQRF
613*
614 srnamt = 'SGGQRF'
615 infot = 1
616 CALL sggqrf( -1, 0, 0, a, 1, r1, b, 1, r2, w, lw, info )
617 CALL chkxer( 'SGGQRF', infot, nout, lerr, ok )
618 infot = 2
619 CALL sggqrf( 0, -1, 0, a, 1, r1, b, 1, r2, w, lw, info )
620 CALL chkxer( 'SGGQRF', infot, nout, lerr, ok )
621 infot = 3
622 CALL sggqrf( 0, 0, -1, a, 1, r1, b, 1, r2, w, lw, info )
623 CALL chkxer( 'SGGQRF', infot, nout, lerr, ok )
624 infot = 5
625 CALL sggqrf( 0, 0, 0, a, 0, r1, b, 1, r2, w, lw, info )
626 CALL chkxer( 'SGGQRF', infot, nout, lerr, ok )
627 infot = 8
628 CALL sggqrf( 0, 0, 0, a, 1, r1, b, 0, r2, w, lw, info )
629 CALL chkxer( 'SGGQRF', infot, nout, lerr, ok )
630 infot = 11
631 CALL sggqrf( 1, 1, 2, a, 1, r1, b, 1, r2, w, 1, info )
632 CALL chkxer( 'SGGQRF', infot, nout, lerr, ok )
633 nt = nt + 6
634*
635* SGGRQF
636*
637 srnamt = 'SGGRQF'
638 infot = 1
639 CALL sggrqf( -1, 0, 0, a, 1, r1, b, 1, r2, w, lw, info )
640 CALL chkxer( 'SGGRQF', infot, nout, lerr, ok )
641 infot = 2
642 CALL sggrqf( 0, -1, 0, a, 1, r1, b, 1, r2, w, lw, info )
643 CALL chkxer( 'SGGRQF', infot, nout, lerr, ok )
644 infot = 3
645 CALL sggrqf( 0, 0, -1, a, 1, r1, b, 1, r2, w, lw, info )
646 CALL chkxer( 'SGGRQF', infot, nout, lerr, ok )
647 infot = 5
648 CALL sggrqf( 0, 0, 0, a, 0, r1, b, 1, r2, w, lw, info )
649 CALL chkxer( 'SGGRQF', infot, nout, lerr, ok )
650 infot = 8
651 CALL sggrqf( 0, 0, 0, a, 1, r1, b, 0, r2, w, lw, info )
652 CALL chkxer( 'SGGRQF', infot, nout, lerr, ok )
653 infot = 11
654 CALL sggrqf( 1, 1, 2, a, 1, r1, b, 1, r2, w, 1, info )
655 CALL chkxer( 'SGGRQF', infot, nout, lerr, ok )
656 nt = nt + 6
657*
658* Test error exits for the SGS, SGV, SGX, and SXV paths.
659*
660 ELSE IF( lsamen( 3, path, 'SGS' ) .OR.
661 $ lsamen( 3, path, 'SGV' ) .OR.
662 $ lsamen( 3, path, 'SGX' ) .OR. lsamen( 3, path, 'SXV' ) )
663 $ THEN
664*
665* SGGES
666*
667 srnamt = 'SGGES '
668 infot = 1
669 CALL sgges( '/', 'N', 'S', slctes, 1, a, 1, b, 1, sdim, r1, r2,
670 $ r3, q, 1, u, 1, w, 1, bw, info )
671 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
672 infot = 2
673 CALL sgges( 'N', '/', 'S', slctes, 1, a, 1, b, 1, sdim, r1, r2,
674 $ r3, q, 1, u, 1, w, 1, bw, info )
675 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
676 infot = 3
677 CALL sgges( 'N', 'V', '/', slctes, 1, a, 1, b, 1, sdim, r1, r2,
678 $ r3, q, 1, u, 1, w, 1, bw, info )
679 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
680 infot = 5
681 CALL sgges( 'N', 'V', 'S', slctes, -1, a, 1, b, 1, sdim, r1,
682 $ r2, r3, q, 1, u, 1, w, 1, bw, info )
683 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
684 infot = 7
685 CALL sgges( 'N', 'V', 'S', slctes, 1, a, 0, b, 1, sdim, r1, r2,
686 $ r3, q, 1, u, 1, w, 1, bw, info )
687 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
688 infot = 9
689 CALL sgges( 'N', 'V', 'S', slctes, 1, a, 1, b, 0, sdim, r1, r2,
690 $ r3, q, 1, u, 1, w, 1, bw, info )
691 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
692 infot = 15
693 CALL sgges( 'N', 'V', 'S', slctes, 1, a, 1, b, 1, sdim, r1, r2,
694 $ r3, q, 0, u, 1, w, 1, bw, info )
695 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
696 infot = 15
697 CALL sgges( 'V', 'V', 'S', slctes, 2, a, 2, b, 2, sdim, r1, r2,
698 $ r3, q, 1, u, 2, w, 1, bw, info )
699 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
700 infot = 17
701 CALL sgges( 'N', 'V', 'S', slctes, 1, a, 1, b, 1, sdim, r1, r2,
702 $ r3, q, 1, u, 0, w, 1, bw, info )
703 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
704 infot = 17
705 CALL sgges( 'V', 'V', 'S', slctes, 2, a, 2, b, 2, sdim, r1, r2,
706 $ r3, q, 2, u, 1, w, 1, bw, info )
707 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
708 infot = 19
709 CALL sgges( 'V', 'V', 'S', slctes, 2, a, 2, b, 2, sdim, r1, r2,
710 $ r3, q, 2, u, 2, w, 1, bw, info )
711 CALL chkxer( 'SGGES ', infot, nout, lerr, ok )
712 nt = nt + 11
713*
714* SGGES3
715*
716 srnamt = 'SGGES3'
717 infot = 1
718 CALL sgges3( '/', 'N', 'S', slctes, 1, a, 1, b, 1, sdim, r1,
719 $ r2, r3, q, 1, u, 1, w, 1, bw, info )
720 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
721 infot = 2
722 CALL sgges3( 'N', '/', 'S', slctes, 1, a, 1, b, 1, sdim, r1,
723 $ r2, r3, q, 1, u, 1, w, 1, bw, info )
724 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
725 infot = 3
726 CALL sgges3( 'N', 'V', '/', slctes, 1, a, 1, b, 1, sdim, r1,
727 $ r2, r3, q, 1, u, 1, w, 1, bw, info )
728 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
729 infot = 5
730 CALL sgges3( 'N', 'V', 'S', slctes, -1, a, 1, b, 1, sdim, r1,
731 $ r2, r3, q, 1, u, 1, w, 1, bw, info )
732 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
733 infot = 7
734 CALL sgges3( 'N', 'V', 'S', slctes, 1, a, 0, b, 1, sdim, r1,
735 $ r2, r3, q, 1, u, 1, w, 1, bw, info )
736 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
737 infot = 9
738 CALL sgges3( 'N', 'V', 'S', slctes, 1, a, 1, b, 0, sdim, r1,
739 $ r2, r3, q, 1, u, 1, w, 1, bw, info )
740 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
741 infot = 15
742 CALL sgges3( 'N', 'V', 'S', slctes, 1, a, 1, b, 1, sdim, r1,
743 $ r2, r3, q, 0, u, 1, w, 1, bw, info )
744 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
745 infot = 15
746 CALL sgges3( 'V', 'V', 'S', slctes, 2, a, 2, b, 2, sdim, r1,
747 $ r2, r3, q, 1, u, 2, w, 1, bw, info )
748 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
749 infot = 17
750 CALL sgges3( 'N', 'V', 'S', slctes, 1, a, 1, b, 1, sdim, r1,
751 $ r2, r3, q, 1, u, 0, w, 1, bw, info )
752 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
753 infot = 17
754 CALL sgges3( 'V', 'V', 'S', slctes, 2, a, 2, b, 2, sdim, r1,
755 $ r2, r3, q, 2, u, 1, w, 1, bw, info )
756 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
757 infot = 19
758 CALL sgges3( 'V', 'V', 'S', slctes, 2, a, 2, b, 2, sdim, r1,
759 $ r2, r3, q, 2, u, 2, w, 1, bw, info )
760 CALL chkxer( 'SGGES3 ', infot, nout, lerr, ok )
761 nt = nt + 11
762*
763* SGGESX
764*
765 srnamt = 'SGGESX'
766 infot = 1
767 CALL sggesx( '/', 'N', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
771 infot = 2
772 CALL sggesx( 'N', '/', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
776 infot = 3
777 CALL sggesx( 'V', 'V', '/', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
781 infot = 5
782 CALL sggesx( 'V', 'V', 'S', slctsx, '/', 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( 'SGGESX', infot, nout, lerr, ok )
786 infot = 6
787 CALL sggesx( 'V', 'V', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
791 infot = 8
792 CALL sggesx( 'V', 'V', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
796 infot = 10
797 CALL sggesx( 'V', 'V', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
801 infot = 16
802 CALL sggesx( 'V', 'V', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
806 infot = 16
807 CALL sggesx( 'V', 'V', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
811 infot = 18
812 CALL sggesx( 'V', 'V', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
816 infot = 18
817 CALL sggesx( 'V', 'V', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
821 infot = 22
822 CALL sggesx( 'V', 'V', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
826 infot = 24
827 CALL sggesx( 'V', 'V', 'S', slctsx, '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( 'SGGESX', infot, nout, lerr, ok )
831 nt = nt + 13
832*
833* SGGEV
834*
835 srnamt = 'SGGEV '
836 infot = 1
837 CALL sggev( '/', 'N', 1, a, 1, b, 1, r1, r2, r3, q, 1, u, 1, w,
838 $ 1, info )
839 CALL chkxer( 'SGGEV ', infot, nout, lerr, ok )
840 infot = 2
841 CALL sggev( 'N', '/', 1, a, 1, b, 1, r1, r2, r3, q, 1, u, 1, w,
842 $ 1, info )
843 CALL chkxer( 'SGGEV ', infot, nout, lerr, ok )
844 infot = 3
845 CALL sggev( 'V', 'V', -1, a, 1, b, 1, r1, r2, r3, q, 1, u, 1,
846 $ w, 1, info )
847 CALL chkxer( 'SGGEV ', infot, nout, lerr, ok )
848 infot = 5
849 CALL sggev( 'V', 'V', 1, a, 0, b, 1, r1, r2, r3, q, 1, u, 1, w,
850 $ 1, info )
851 CALL chkxer( 'SGGEV ', infot, nout, lerr, ok )
852 infot = 7
853 CALL sggev( 'V', 'V', 1, a, 1, b, 0, r1, r2, r3, q, 1, u, 1, w,
854 $ 1, info )
855 CALL chkxer( 'SGGEV ', infot, nout, lerr, ok )
856 infot = 12
857 CALL sggev( 'N', 'V', 1, a, 1, b, 1, r1, r2, r3, q, 0, u, 1, w,
858 $ 1, info )
859 CALL chkxer( 'SGGEV ', infot, nout, lerr, ok )
860 infot = 12
861 CALL sggev( 'V', 'V', 2, a, 2, b, 2, r1, r2, r3, q, 1, u, 2, w,
862 $ 1, info )
863 CALL chkxer( 'SGGEV ', infot, nout, lerr, ok )
864 infot = 14
865 CALL sggev( 'V', 'N', 2, a, 2, b, 2, r1, r2, r3, q, 2, u, 0, w,
866 $ 1, info )
867 CALL chkxer( 'SGGEV ', infot, nout, lerr, ok )
868 infot = 14
869 CALL sggev( 'V', 'V', 2, a, 2, b, 2, r1, r2, r3, q, 2, u, 1, w,
870 $ 1, info )
871 CALL chkxer( 'SGGEV ', infot, nout, lerr, ok )
872 infot = 16
873 CALL sggev( 'V', 'V', 1, a, 1, b, 1, r1, r2, r3, q, 1, u, 1, w,
874 $ 1, info )
875 CALL chkxer( 'SGGEV ', infot, nout, lerr, ok )
876 nt = nt + 10
877*
878* SGGEV3
879*
880 srnamt = 'SGGEV3 '
881 infot = 1
882 CALL sggev3( '/', 'N', 1, a, 1, b, 1, r1, r2, r3, q, 1, u, 1,
883 $ w, 1, info )
884 CALL chkxer( 'SGGEV3 ', infot, nout, lerr, ok )
885 infot = 2
886 CALL sggev3( 'N', '/', 1, a, 1, b, 1, r1, r2, r3, q, 1, u, 1,
887 $ w, 1, info )
888 CALL chkxer( 'SGGEV3 ', infot, nout, lerr, ok )
889 infot = 3
890 CALL sggev3( 'V', 'V', -1, a, 1, b, 1, r1, r2, r3, q, 1, u, 1,
891 $ w, 1, info )
892 CALL chkxer( 'SGGEV3 ', infot, nout, lerr, ok )
893 infot = 5
894 CALL sggev3( 'V', 'V', 1, a, 0, b, 1, r1, r2, r3, q, 1, u, 1,
895 $ w, 1, info )
896 CALL chkxer( 'SGGEV3 ', infot, nout, lerr, ok )
897 infot = 7
898 CALL sggev3( 'V', 'V', 1, a, 1, b, 0, r1, r2, r3, q, 1, u, 1,
899 $ w, 1, info )
900 CALL chkxer( 'SGGEV3 ', infot, nout, lerr, ok )
901 infot = 12
902 CALL sggev3( 'N', 'V', 1, a, 1, b, 1, r1, r2, r3, q, 0, u, 1,
903 $ w, 1, info )
904 CALL chkxer( 'SGGEV3 ', infot, nout, lerr, ok )
905 infot = 12
906 CALL sggev3( 'V', 'V', 2, a, 2, b, 2, r1, r2, r3, q, 1, u, 2,
907 $ w, 1, info )
908 CALL chkxer( 'SGGEV3 ', infot, nout, lerr, ok )
909 infot = 14
910 CALL sggev3( 'V', 'N', 2, a, 2, b, 2, r1, r2, r3, q, 2, u, 0,
911 $ w, 1, info )
912 CALL chkxer( 'SGGEV3 ', infot, nout, lerr, ok )
913 infot = 14
914 CALL sggev3( 'V', 'V', 2, a, 2, b, 2, r1, r2, r3, q, 2, u, 1,
915 $ w, 1, info )
916 CALL chkxer( 'SGGEV3 ', infot, nout, lerr, ok )
917 infot = 16
918 CALL sggev3( 'V', 'V', 1, a, 1, b, 1, r1, r2, r3, q, 1, u, 1,
919 $ w, 1, info )
920 CALL chkxer( 'SGGEV3 ', infot, nout, lerr, ok )
921 nt = nt + 10
922*
923* SGGEVX
924*
925 srnamt = 'SGGEVX'
926 infot = 1
927 CALL sggevx( '/', 'N', 'N', 'N', 1, a, 1, b, 1, r1, r2, r3, q,
928 $ 1, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
929 $ w, 1, iw, bw, info )
930 CALL chkxer( 'SGGEVX', infot, nout, lerr, ok )
931 infot = 2
932 CALL sggevx( '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( 'SGGEVX', infot, nout, lerr, ok )
936 infot = 3
937 CALL sggevx( '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( 'SGGEVX', infot, nout, lerr, ok )
941 infot = 4
942 CALL sggevx( '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( 'SGGEVX', infot, nout, lerr, ok )
946 infot = 5
947 CALL sggevx( 'N', '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( 'SGGEVX', infot, nout, lerr, ok )
951 infot = 7
952 CALL sggevx( 'N', 'N', 'N', 'N', 1, a, 0, 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( 'SGGEVX', infot, nout, lerr, ok )
956 infot = 9
957 CALL sggevx( 'N', 'N', 'N', 'N', 1, a, 1, b, 0, 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( 'SGGEVX', infot, nout, lerr, ok )
961 infot = 14
962 CALL sggevx( 'N', 'N', 'N', 'N', 1, a, 1, b, 1, r1, r2, r3, q,
963 $ 0, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
964 $ w, 1, iw, bw, info )
965 CALL chkxer( 'SGGEVX', infot, nout, lerr, ok )
966 infot = 14
967 CALL sggevx( 'N', 'V', 'N', 'N', 2, a, 2, b, 2, r1, r2, r3, q,
968 $ 1, u, 2, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
969 $ w, 1, iw, bw, info )
970 CALL chkxer( 'SGGEVX', infot, nout, lerr, ok )
971 infot = 16
972 CALL sggevx( 'N', 'N', 'N', 'N', 1, a, 1, b, 1, r1, r2, r3, q,
973 $ 1, u, 0, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
974 $ w, 1, iw, bw, info )
975 CALL chkxer( 'SGGEVX', infot, nout, lerr, ok )
976 infot = 16
977 CALL sggevx( 'N', 'N', 'V', 'N', 2, a, 2, b, 2, r1, r2, r3, q,
978 $ 2, u, 1, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
979 $ w, 1, iw, bw, info )
980 CALL chkxer( 'SGGEVX', infot, nout, lerr, ok )
981 infot = 26
982 CALL sggevx( 'N', 'N', 'V', 'N', 2, a, 2, b, 2, r1, r2, r3, q,
983 $ 2, u, 2, ilo, ihi, ls, rs, anrm, bnrm, rce, rcv,
984 $ w, 1, iw, bw, info )
985 CALL chkxer( 'SGGEVX', infot, nout, lerr, ok )
986 nt = nt + 12
987*
988* STGEXC
989*
990 srnamt = 'STGEXC'
991 infot = 3
992 CALL stgexc( .true., .true., -1, a, 1, b, 1, q, 1, z, 1, ifst,
993 $ ilst, w, 1, info )
994 CALL chkxer( 'STGEXC', infot, nout, lerr, ok )
995 infot = 5
996 CALL stgexc( .true., .true., 1, a, 0, b, 1, q, 1, z, 1, ifst,
997 $ ilst, w, 1, info )
998 CALL chkxer( 'STGEXC', infot, nout, lerr, ok )
999 infot = 7
1000 CALL stgexc( .true., .true., 1, a, 1, b, 0, q, 1, z, 1, ifst,
1001 $ ilst, w, 1, info )
1002 CALL chkxer( 'STGEXC', infot, nout, lerr, ok )
1003 infot = 9
1004 CALL stgexc( .false., .true., 1, a, 1, b, 1, q, 0, z, 1, ifst,
1005 $ ilst, w, 1, info )
1006 CALL chkxer( 'STGEXC', infot, nout, lerr, ok )
1007 infot = 9
1008 CALL stgexc( .true., .true., 1, a, 1, b, 1, q, 0, z, 1, ifst,
1009 $ ilst, w, 1, info )
1010 CALL chkxer( 'STGEXC', infot, nout, lerr, ok )
1011 infot = 11
1012 CALL stgexc( .true., .false., 1, a, 1, b, 1, q, 1, z, 0, ifst,
1013 $ ilst, w, 1, info )
1014 CALL chkxer( 'STGEXC', infot, nout, lerr, ok )
1015 infot = 11
1016 CALL stgexc( .true., .true., 1, a, 1, b, 1, q, 1, z, 0, ifst,
1017 $ ilst, w, 1, info )
1018 CALL chkxer( 'STGEXC', infot, nout, lerr, ok )
1019 infot = 15
1020 CALL stgexc( .true., .true., 1, a, 1, b, 1, q, 1, z, 1, ifst,
1021 $ ilst, w, 0, info )
1022 CALL chkxer( 'STGEXC', infot, nout, lerr, ok )
1023 nt = nt + 8
1024*
1025* STGSEN
1026*
1027 srnamt = 'STGSEN'
1028 infot = 1
1029 CALL stgsen( -1, .true., .true., sel, 1, a, 1, b, 1, r1, r2,
1030 $ r3, q, 1, z, 1, m, tola, tolb, rcv, w, 1, iw, 1,
1031 $ info )
1032 CALL chkxer( 'STGSEN', infot, nout, lerr, ok )
1033 infot = 5
1034 CALL stgsen( 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( 'STGSEN', infot, nout, lerr, ok )
1038 infot = 7
1039 CALL stgsen( 1, .true., .true., sel, 1, a, 0, b, 1, r1, r2, r3,
1040 $ q, 1, z, 1, m, tola, tolb, rcv, w, 1, iw, 1,
1041 $ info )
1042 CALL chkxer( 'STGSEN', infot, nout, lerr, ok )
1043 infot = 9
1044 CALL stgsen( 1, .true., .true., sel, 1, a, 1, b, 0, r1, r2, r3,
1045 $ q, 1, z, 1, m, tola, tolb, rcv, w, 1, iw, 1,
1046 $ info )
1047 CALL chkxer( 'STGSEN', infot, nout, lerr, ok )
1048 infot = 14
1049 CALL stgsen( 1, .true., .true., sel, 1, a, 1, b, 1, r1, r2, r3,
1050 $ q, 0, z, 1, m, tola, tolb, rcv, w, 1, iw, 1,
1051 $ info )
1052 CALL chkxer( 'STGSEN', infot, nout, lerr, ok )
1053 infot = 16
1054 CALL stgsen( 1, .true., .true., sel, 1, a, 1, b, 1, r1, r2, r3,
1055 $ q, 1, z, 0, m, tola, tolb, rcv, w, 1, iw, 1,
1056 $ info )
1057 CALL chkxer( 'STGSEN', infot, nout, lerr, ok )
1058 infot = 22
1059 CALL stgsen( 0, .true., .true., sel, 1, a, 1, b, 1, r1, r2, r3,
1060 $ q, 1, z, 1, m, tola, tolb, rcv, w, 1, iw, 1,
1061 $ info )
1062 CALL chkxer( 'STGSEN', infot, nout, lerr, ok )
1063 infot = 22
1064 CALL stgsen( 1, .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( 'STGSEN', infot, nout, lerr, ok )
1068 infot = 22
1069 CALL stgsen( 2, .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( 'STGSEN', infot, nout, lerr, ok )
1073 infot = 24
1074 CALL stgsen( 0, .true., .true., sel, 1, a, 1, b, 1, r1, r2, r3,
1075 $ q, 1, z, 1, m, tola, tolb, rcv, w, 20, iw, 0,
1076 $ info )
1077 CALL chkxer( 'STGSEN', infot, nout, lerr, ok )
1078 infot = 24
1079 CALL stgsen( 1, .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( 'STGSEN', infot, nout, lerr, ok )
1083 infot = 24
1084 CALL stgsen( 2, .true., .true., sel, 1, a, 1, b, 1, r1, r2, r3,
1085 $ q, 1, z, 1, m, tola, tolb, rcv, w, 20, iw, 1,
1086 $ info )
1087 CALL chkxer( 'STGSEN', infot, nout, lerr, ok )
1088 nt = nt + 12
1089*
1090* STGSNA
1091*
1092 srnamt = 'STGSNA'
1093 infot = 1
1094 CALL stgsna( '/', 'A', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1095 $ 1, m, w, 1, iw, info )
1096 CALL chkxer( 'STGSNA', infot, nout, lerr, ok )
1097 infot = 2
1098 CALL stgsna( 'B', '/', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1099 $ 1, m, w, 1, iw, info )
1100 CALL chkxer( 'STGSNA', infot, nout, lerr, ok )
1101 infot = 4
1102 CALL stgsna( 'B', 'A', sel, -1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1103 $ 1, m, w, 1, iw, info )
1104 CALL chkxer( 'STGSNA', infot, nout, lerr, ok )
1105 infot = 6
1106 CALL stgsna( 'B', 'A', sel, 1, a, 0, b, 1, q, 1, u, 1, r1, r2,
1107 $ 1, m, w, 1, iw, info )
1108 CALL chkxer( 'STGSNA', infot, nout, lerr, ok )
1109 infot = 8
1110 CALL stgsna( 'B', 'A', sel, 1, a, 1, b, 0, q, 1, u, 1, r1, r2,
1111 $ 1, m, w, 1, iw, info )
1112 CALL chkxer( 'STGSNA', infot, nout, lerr, ok )
1113 infot = 10
1114 CALL stgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 0, u, 1, r1, r2,
1115 $ 1, m, w, 1, iw, info )
1116 CALL chkxer( 'STGSNA', infot, nout, lerr, ok )
1117 infot = 12
1118 CALL stgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 1, u, 0, r1, r2,
1119 $ 1, m, w, 1, iw, info )
1120 CALL chkxer( 'STGSNA', infot, nout, lerr, ok )
1121 infot = 15
1122 CALL stgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1123 $ 0, m, w, 1, iw, info )
1124 CALL chkxer( 'STGSNA', infot, nout, lerr, ok )
1125 infot = 18
1126 CALL stgsna( 'E', 'A', sel, 1, a, 1, b, 1, q, 1, u, 1, r1, r2,
1127 $ 1, m, w, 0, iw, info )
1128 CALL chkxer( 'STGSNA', infot, nout, lerr, ok )
1129 nt = nt + 9
1130*
1131* STGSYL
1132*
1133 srnamt = 'STGSYL'
1134 infot = 1
1135 CALL stgsyl( '/', 0, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1136 $ scale, dif, w, 1, iw, info )
1137 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1138 infot = 2
1139 CALL stgsyl( 'N', -1, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1140 $ scale, dif, w, 1, iw, info )
1141 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1142 infot = 3
1143 CALL stgsyl( 'N', 0, 0, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1144 $ scale, dif, w, 1, iw, info )
1145 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1146 infot = 4
1147 CALL stgsyl( 'N', 0, 1, 0, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1148 $ scale, dif, w, 1, iw, info )
1149 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1150 infot = 6
1151 CALL stgsyl( 'N', 0, 1, 1, a, 0, b, 1, q, 1, u, 1, v, 1, z, 1,
1152 $ scale, dif, w, 1, iw, info )
1153 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1154 infot = 8
1155 CALL stgsyl( 'N', 0, 1, 1, a, 1, b, 0, q, 1, u, 1, v, 1, z, 1,
1156 $ scale, dif, w, 1, iw, info )
1157 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1158 infot = 10
1159 CALL stgsyl( 'N', 0, 1, 1, a, 1, b, 1, q, 0, u, 1, v, 1, z, 1,
1160 $ scale, dif, w, 1, iw, info )
1161 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1162 infot = 12
1163 CALL stgsyl( 'N', 0, 1, 1, a, 1, b, 1, q, 1, u, 0, v, 1, z, 1,
1164 $ scale, dif, w, 1, iw, info )
1165 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1166 infot = 14
1167 CALL stgsyl( 'N', 0, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 0, z, 1,
1168 $ scale, dif, w, 1, iw, info )
1169 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1170 infot = 16
1171 CALL stgsyl( 'N', 0, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 0,
1172 $ scale, dif, w, 1, iw, info )
1173 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1174 infot = 20
1175 CALL stgsyl( 'N', 1, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1176 $ scale, dif, w, 1, iw, info )
1177 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1178 infot = 20
1179 CALL stgsyl( 'N', 2, 1, 1, a, 1, b, 1, q, 1, u, 1, v, 1, z, 1,
1180 $ scale, dif, w, 1, iw, info )
1181 CALL chkxer( 'STGSYL', infot, nout, lerr, ok )
1182 nt = nt + 12
1183 END IF
1184*
1185* Print a summary line.
1186*
1187 IF( ok ) THEN
1188 WRITE( nout, fmt = 9999 )path, nt
1189 ELSE
1190 WRITE( nout, fmt = 9998 )path
1191 END IF
1192*
1193 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits (',
1194 $ i3, ' tests done)' )
1195 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
1196 $ 'exits ***' )
1197*
1198 RETURN
1199*
1200* End of SERRGG
1201*
stgexc
subroutine stgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, work, lwork, info)
STGEXC
Definition stgexc.f:220
sggsvd3
subroutine sggsvd3(jobu, jobv, jobq, m, n, p, k, l, a, lda, b, ldb, alpha, beta, u, ldu, v, ldv, q, ldq, work, lwork, iwork, info)
SGGSVD3 computes the singular value decomposition (SVD) for OTHER matrices
Definition sggsvd3.f:349
sgghd3
subroutine sgghd3(compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, work, lwork, info)
SGGHD3
Definition sgghd3.f:230
stgsja
subroutine stgsja(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)
STGSJA
Definition stgsja.f:378
stgsna
subroutine stgsna(job, howmny, select, n, a, lda, b, ldb, vl, ldvl, vr, ldvr, s, dif, mm, m, work, lwork, iwork, info)
STGSNA
Definition stgsna.f:381
sggqrf
subroutine sggqrf(n, m, p, a, lda, taua, b, ldb, taub, work, lwork, info)
SGGQRF
Definition sggqrf.f:215
sggsvp3
subroutine sggsvp3(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)
SGGSVP3
Definition sggsvp3.f:272
stgsen
subroutine stgsen(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)
STGSEN
Definition stgsen.f:451
sggrqf
subroutine sggrqf(m, p, n, a, lda, taua, b, ldb, taub, work, lwork, info)
SGGRQF
Definition sggrqf.f:214
sggglm
subroutine sggglm(n, m, p, a, lda, b, ldb, d, x, y, work, lwork, info)
SGGGLM
Definition sggglm.f:185
sgglse
subroutine sgglse(m, n, p, a, lda, b, ldb, c, d, x, work, lwork, info)
SGGLSE solves overdetermined or underdetermined systems for OTHER matrices
Definition sgglse.f:180
stgsyl
subroutine stgsyl(trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, scale, dif, work, lwork, iwork, info)
STGSYL
Definition stgsyl.f:299

◆ serrhs()

subroutine serrhs ( character*3 path,
integer nunit )

SERRHS

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

◆ serrst()

subroutine serrst ( character*3 path,
integer nunit )

SERRST

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

◆ sget02()

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

SGET02

Purpose:
!>
!> SGET02 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 REAL 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 REAL 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 REAL array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESID
!>          RESID is REAL
!>          The maximum over the number of right hand sides of
!>          norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 133 of file sget02.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 REAL RESID
144* ..
145* .. Array Arguments ..
146 REAL A( LDA, * ), B( LDB, * ), RWORK( * ),
147 $ X( LDX, * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ZERO, ONE
154 parameter( zero = 0.0e+0, one = 1.0e+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER J, N1, N2
158 REAL ANORM, BNORM, EPS, XNORM
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 REAL SASUM, SLAMCH, SLANGE
163 EXTERNAL lsame, sasum, slamch, slange
164* ..
165* .. External Subroutines ..
166 EXTERNAL sgemm
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 = slamch( 'Epsilon' )
191 IF( lsame( trans, 'N' ) ) THEN
192 anorm = slange( '1', m, n, a, lda, rwork )
193 ELSE
194 anorm = slange( '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 sgemm( 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 = sasum( n1, b( 1, j ), 1 )
212 xnorm = sasum( 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 SGET02
223*

◆ sget10()

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

SGET10

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

Definition at line 92 of file sget10.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 REAL RESULT
101* ..
102* .. Array Arguments ..
103 REAL A( LDA, * ), B( LDB, * ), WORK( * )
104* ..
105*
106* =====================================================================
107*
108* .. Parameters ..
109 REAL ONE, ZERO
110 parameter( one = 1.0e+0, zero = 0.0e+0 )
111* ..
112* .. Local Scalars ..
113 INTEGER J
114 REAL ANORM, EPS, UNFL, WNORM
115* ..
116* .. External Functions ..
117 REAL SASUM, SLAMCH, SLANGE
118 EXTERNAL sasum, slamch, slange
119* ..
120* .. External Subroutines ..
121 EXTERNAL saxpy, scopy
122* ..
123* .. Intrinsic Functions ..
124 INTRINSIC max, min, real
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 = slamch( 'Safe minimum' )
136 eps = slamch( 'Precision' )
137*
138 wnorm = zero
139 DO 10 j = 1, n
140 CALL scopy( m, a( 1, j ), 1, work, 1 )
141 CALL saxpy( m, -one, b( 1, j ), 1, work, 1 )
142 wnorm = max( wnorm, sasum( n, work, 1 ) )
143 10 CONTINUE
144*
145 anorm = max( slange( '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, real( m ) ) / ( m*eps )
154 END IF
155 END IF
156*
157 RETURN
158*
159* End of SGET10
160*
saxpy
subroutine saxpy(n, sa, sx, incx, sy, incy)
SAXPY
Definition saxpy.f:89

◆ sget22()

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

SGET22

Purpose:
!>
!> SGET22 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 REAL 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 REAL 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 REAL array, dimension (N)
!>
[in]WI
!>          WI is REAL 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 REAL array, dimension (N*(N+1))
!>
[out]RESULT
!>          RESULT is REAL array, dimension (2)
!>          RESULT(1) = | A E  -  E W | / ( |A| |E| ulp )
!>          RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
!>                       j
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 166 of file sget22.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 REAL A( LDA, * ), E( LDE, * ), RESULT( 2 ), WI( * ),
179 $ WORK( * ), WR( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 REAL ZERO, ONE
186 parameter( zero = 0.0, one = 1.0 )
187* ..
188* .. Local Scalars ..
189 CHARACTER NORMA, NORME
190 INTEGER IECOL, IEROW, INCE, IPAIR, ITRNSE, J, JCOL,
191 $ JVEC
192 REAL ANORM, ENORM, ENRMAX, ENRMIN, ERRNRM, TEMP1,
193 $ ULP, UNFL
194* ..
195* .. Local Arrays ..
196 REAL WMAT( 2, 2 )
197* ..
198* .. External Functions ..
199 LOGICAL LSAME
200 REAL SLAMCH, SLANGE
201 EXTERNAL lsame, slamch, slange
202* ..
203* .. External Subroutines ..
204 EXTERNAL saxpy, sgemm, slaset
205* ..
206* .. Intrinsic Functions ..
207 INTRINSIC abs, max, min, real
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 = slamch( 'Safe minimum' )
219 ulp = slamch( '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( slange( norma, n, n, a, lda, work ), unfl )
311*
312* Norm of E:
313*
314 enorm = max( slange( norme, n, n, e, lde, work ), ulp )
315*
316* Norm of error:
317*
318* Error = AE - EW
319*
320 CALL slaset( '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 sgemm( 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 saxpy( 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 sgemm( transa, transe, n, n, n, one, a, lda, e, lde, -one,
357 $ work, n )
358*
359 errnrm = slange( '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 $ ( real( n )*ulp )
377*
378 RETURN
379*
380* End of SGET22
381*

◆ sget23()

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

SGET23

Purpose:
!>
!>    SGET23  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 SGEEVX 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 SGEEVX 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 REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          If COMP = .FALSE., the random number generator seed
!>          used to produce matrix.
!>          If COMP = .TRUE., ISEED(1) = the number of the example.
!>          Used to label output if error occurs.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[in]N
!>          N is INTEGER
!>          The dimension of A. N must be at least 0.
!>
[in,out]A
!>          A is REAL 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 REAL array, dimension (LDA,N)
!>          Another copy of the test matrix A, modified by SGEEVX.
!>
[out]WR
!>          WR is REAL array, dimension (N)
!>
[out]WI
!>          WI is REAL 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 REAL array, dimension (N)
!>
[out]WI1
!>          WI1 is REAL array, dimension (N)
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when SGEEVX only computes a partial
!>          eigendecomposition, i.e. not the eigenvalues and left
!>          and right eigenvectors.
!>
[out]VL
!>          VL is REAL 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 REAL 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 REAL array, dimension (LDLRE,N)
!>          LRE holds the computed right or left eigenvectors.
!>
[in]LDLRE
!>          LDLRE is INTEGER
!>          Leading dimension of LRE. Must be at least max(1,N).
!>
[out]RCONDV
!>          RCONDV is REAL array, dimension (N)
!>          RCONDV holds the computed reciprocal condition numbers
!>          for eigenvectors.
!>
[out]RCNDV1
!>          RCNDV1 is REAL array, dimension (N)
!>          RCNDV1 holds more computed reciprocal condition numbers
!>          for eigenvectors.
!>
[in]RCDVIN
!>          RCDVIN is REAL array, dimension (N)
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition numbers for eigenvectors to be compared with
!>          RCONDV.
!>
[out]RCONDE
!>          RCONDE is REAL array, dimension (N)
!>          RCONDE holds the computed reciprocal condition numbers
!>          for eigenvalues.
!>
[out]RCNDE1
!>          RCNDE1 is REAL array, dimension (N)
!>          RCNDE1 holds more computed reciprocal condition numbers
!>          for eigenvalues.
!>
[in]RCDEIN
!>          RCDEIN is REAL array, dimension (N)
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition numbers for eigenvalues to be compared with
!>          RCONDE.
!>
[out]SCALE
!>          SCALE is REAL array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]SCALE1
!>          SCALE1 is REAL array, dimension (N)
!>          Holds information describing balancing of matrix.
!>
[out]RESULT
!>          RESULT is REAL array, dimension (11)
!>          The values computed by the 11 tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]WORK
!>          WORK is REAL 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, SGEEVX 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 sget23.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 REAL THRESH
389* ..
390* .. Array Arguments ..
391 INTEGER ISEED( 4 ), IWORK( * )
392 REAL 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 REAL ZERO, ONE, TWO
405 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
406 REAL EPSIN
407 parameter( epsin = 5.9605e-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 REAL 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 REAL DUM( 1 ), RES( 2 )
421* ..
422* .. External Functions ..
423 LOGICAL LSAME
424 REAL SLAMCH, SLAPY2, SNRM2
425 EXTERNAL lsame, slamch, slapy2, snrm2
426* ..
427* .. External Subroutines ..
428 EXTERNAL sgeevx, sget22, slacpy, xerbla
429* ..
430* .. Intrinsic Functions ..
431 INTRINSIC abs, max, min, real
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( 'SGET23', -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 = slamch( 'Precision' )
481 smlnum = slamch( '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 slacpy( 'F', n, n, a, lda, h, lda )
494 CALL sgeevx( 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 )'SGEEVX1', iinfo, n, jtype,
501 $ balanc, iseed
502 ELSE
503 WRITE( nounit, fmt = 9999 )'SGEEVX1', iinfo, n, iseed( 1 )
504 END IF
505 info = abs( iinfo )
506 RETURN
507 END IF
508*
509* Do Test (1)
510*
511 CALL sget22( '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 sget22( '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 = snrm2( n, vr( 1, j ), 1 )
527 ELSE IF( wi( j ).GT.zero ) THEN
528 tnrm = slapy2( snrm2( n, vr( 1, j ), 1 ),
529 $ snrm2( 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 = slapy2( 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 = snrm2( n, vl( 1, j ), 1 )
554 ELSE IF( wi( j ).GT.zero ) THEN
555 tnrm = slapy2( snrm2( n, vl( 1, j ), 1 ),
556 $ snrm2( 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 = slapy2( 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 slacpy( 'F', n, n, a, lda, h, lda )
584 CALL sgeevx( 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 )'SGEEVX2', iinfo, n, jtype,
591 $ balanc, iseed
592 ELSE
593 WRITE( nounit, fmt = 9999 )'SGEEVX2', 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 slacpy( 'F', n, n, a, lda, h, lda )
634 CALL sgeevx( 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 )'SGEEVX3', iinfo, n, jtype,
641 $ balanc, iseed
642 ELSE
643 WRITE( nounit, fmt = 9999 )'SGEEVX3', 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 slacpy( 'F', n, n, a, lda, h, lda )
693 CALL sgeevx( 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 )'SGEEVX4', iinfo, n, jtype,
700 $ balanc, iseed
701 ELSE
702 WRITE( nounit, fmt = 9999 )'SGEEVX4', 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 slacpy( 'F', n, n, a, lda, h, lda )
757 CALL sgeevx( '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 )'SGEEVX5', 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( real( 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( ' SGET23: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
863 $ i6, ', INPUT EXAMPLE NUMBER = ', i4 )
864 9998 FORMAT( ' SGET23: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
865 $ i6, ', JTYPE=', i6, ', BALANC = ', a, ', ISEED=(',
866 $ 3( i5, ',' ), i5, ')' )
867*
868 RETURN
869*
870* End of SGET23
871*
comp
int comp(int a, int b)
Definition set_surface_lines.cpp:102

◆ sget24()

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

SGET24

Purpose:
!>
!>    SGET24 checks the nonsymmetric eigenvalue (Schur form) problem
!>    expert driver SGEESX.
!>
!>    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 SGEESX 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 SGEESX and RCDVIN (the precomputed true
!>       value) is supplied as input. cond(RCONDV) is the condition
!>       number of RCONDV, and takes errors in computing RCONDV into
!>       account, so that the resulting quantity should be O(ULP).
!>       cond(RCONDV) is essentially given by norm(A)/RCONDE.
!>
Parameters
[in]COMP
!>          COMP is LOGICAL
!>          COMP describes which input tests to perform:
!>            = .FALSE. if the computed condition numbers are not to
!>                      be tested against RCDVIN and RCDEIN
!>            = .TRUE.  if they are to be compared
!>
[in]JTYPE
!>          JTYPE is INTEGER
!>          Type of input matrix. Used to label output if error occurs.
!>
[in]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          If COMP = .FALSE., the random number generator seed
!>          used to produce matrix.
!>          If COMP = .TRUE., ISEED(1) = the number of the example.
!>          Used to label output if error occurs.
!>
[in]THRESH
!>          THRESH is REAL
!>          A test will count as  if the , computed as
!>          described above, exceeds THRESH.  Note that the error
!>          is scaled to be O(1), so THRESH should be a reasonably
!>          small multiple of 1, e.g., 10 or 100.  In particular,
!>          it should not depend on the precision (single vs. double)
!>          or the size of the matrix.  It must be at least zero.
!>
[in]NOUNIT
!>          NOUNIT is INTEGER
!>          The FORTRAN unit number for printing out error messages
!>          (e.g., if a routine returns INFO not equal to 0.)
!>
[in]N
!>          N is INTEGER
!>          The dimension of A. N must be at least 0.
!>
[in,out]A
!>          A is REAL 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 REAL array, dimension (LDA, N)
!>          Another copy of the test matrix A, modified by SGEESX.
!>
[out]HT
!>          HT is REAL array, dimension (LDA, N)
!>          Yet another copy of the test matrix A, modified by SGEESX.
!>
[out]WR
!>          WR is REAL array, dimension (N)
!>
[out]WI
!>          WI is REAL 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 REAL array, dimension (N)
!>
[out]WIT
!>          WIT is REAL array, dimension (N)
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but those computed when SGEESX only computes a partial
!>          eigendecomposition, i.e. not Schur vectors
!>
[out]WRTMP
!>          WRTMP is REAL array, dimension (N)
!>
[out]WITMP
!>          WITMP is REAL array, dimension (N)
!>
!>          Like WR, WI, these arrays contain the eigenvalues of A,
!>          but sorted by increasing real part.
!>
[out]VS
!>          VS is REAL 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 REAL array, dimension (LDVS, N)
!>          VS1 holds another copy of the computed Schur vectors.
!>
[in]RCDEIN
!>          RCDEIN is REAL
!>          When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
!>          condition number for the average of selected eigenvalues.
!>
[in]RCDVIN
!>          RCDVIN is REAL
!>          When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
!>          condition number for the selected right invariant subspace.
!>
[in]NSLCT
!>          NSLCT is INTEGER
!>          When COMP = .TRUE. the number of selected eigenvalues
!>          corresponding to the precomputed values RCDEIN and RCDVIN.
!>
[in]ISLCT
!>          ISLCT is INTEGER array, dimension (NSLCT)
!>          When COMP = .TRUE. ISLCT selects the eigenvalues of the
!>          input matrix corresponding to the precomputed values RCDEIN
!>          and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the
!>          eigenvalue with the J-th largest real part is selected.
!>          Not referenced if COMP = .FALSE.
!>
[out]RESULT
!>          RESULT is REAL array, dimension (17)
!>          The values computed by the 17 tests described above.
!>          The values are currently limited to 1/ulp, to avoid
!>          overflow.
!>
[out]WORK
!>          WORK is REAL array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The number of entries in WORK to be passed to SGEESX. 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, SGEESX 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 sget24.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 REAL RCDEIN, RCDVIN, THRESH
352* ..
353* .. Array Arguments ..
354 LOGICAL BWORK( * )
355 INTEGER ISEED( 4 ), ISLCT( * ), IWORK( * )
356 REAL 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 REAL ZERO, ONE
366 parameter( zero = 0.0e0, one = 1.0e0 )
367 REAL EPSIN
368 parameter( epsin = 5.9605e-8 )
369* ..
370* .. Local Scalars ..
371 CHARACTER SORT
372 INTEGER I, IINFO, ISORT, ITMP, J, KMIN, KNTEIG, LIWORK,
373 $ RSUB, SDIM, SDIM1
374 REAL 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 REAL 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 SSLECT
393 REAL SLAMCH, SLANGE
394 EXTERNAL sslect, slamch, slange
395* ..
396* .. External Subroutines ..
397 EXTERNAL scopy, sgeesx, sgemm, slacpy, sort01, xerbla
398* ..
399* .. Intrinsic Functions ..
400 INTRINSIC abs, max, min, real, 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( 'SGET24', -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 = slamch( 'Safe minimum' )
438 ulp = slamch( '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 slacpy( 'F', n, n, a, lda, h, lda )
457 CALL sgeesx( 'V', sort, sslect, '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 )'SGEESX1', iinfo, n, jtype,
464 $ iseed
465 ELSE
466 WRITE( nounit, fmt = 9999 )'SGEESX1', 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 scopy( n, wr, 1, wrtmp, 1 )
474 CALL scopy( 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 slacpy( ' ', n, n, a, lda, vs1, ldvs )
503*
504* Compute Q*H and store in HT.
505*
506 CALL sgemm( '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 sgemm( 'No transpose', 'Transpose', n, n, n, -one, ht,
512 $ lda, vs, ldvs, one, vs1, ldvs )
513*
514 anorm = max( slange( '1', n, n, a, lda, work ), smlnum )
515 wnorm = slange( '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, real( 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 sort01( '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 slacpy( 'F', n, n, a, lda, ht, lda )
566 CALL sgeesx( 'N', sort, sslect, '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 )'SGEESX2', iinfo, n, jtype,
573 $ iseed
574 ELSE
575 WRITE( nounit, fmt = 9999 )'SGEESX2', 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( sslect( wr( i ), wi( i ) ) .OR.
605 $ sslect( wr( i ), -wi( i ) ) )knteig = knteig + 1
606 IF( i.LT.n ) THEN
607 IF( ( sslect( wr( i+1 ), wi( i+1 ) ) .OR.
608 $ sslect( wr( i+1 ), -wi( i+1 ) ) ) .AND.
609 $ ( .NOT.( sslect( wr( i ),
610 $ wi( i ) ) .OR. sslect( 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 slacpy( 'F', n, n, a, lda, ht, lda )
632 CALL sgeesx( 'V', sort, sslect, '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 )'SGEESX3', iinfo, n, jtype,
640 $ iseed
641 ELSE
642 WRITE( nounit, fmt = 9999 )'SGEESX3', 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 slacpy( 'F', n, n, a, lda, ht, lda )
667 CALL sgeesx( 'N', sort, sslect, '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 )'SGEESX4', iinfo, n, jtype,
675 $ iseed
676 ELSE
677 WRITE( nounit, fmt = 9999 )'SGEESX4', 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 slacpy( 'F', n, n, a, lda, ht, lda )
709 CALL sgeesx( 'V', sort, sslect, '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 )'SGEESX5', iinfo, n, jtype,
716 $ iseed
717 ELSE
718 WRITE( nounit, fmt = 9999 )'SGEESX5', 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 slacpy( 'F', n, n, a, lda, ht, lda )
748 CALL sgeesx( 'N', sort, sslect, '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 )'SGEESX6', iinfo, n, jtype,
755 $ iseed
756 ELSE
757 WRITE( nounit, fmt = 9999 )'SGEESX6', 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 slacpy( 'F', n, n, a, lda, ht, lda )
787 CALL sgeesx( 'V', sort, sslect, '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 )'SGEESX7', iinfo, n, jtype,
794 $ iseed
795 ELSE
796 WRITE( nounit, fmt = 9999 )'SGEESX7', 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 slacpy( 'F', n, n, a, lda, ht, lda )
826 CALL sgeesx( 'N', sort, sslect, '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 )'SGEESX8', iinfo, n, jtype,
833 $ iseed
834 ELSE
835 WRITE( nounit, fmt = 9999 )'SGEESX8', 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 SSLECT 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 slacpy( 'F', n, n, a, lda, ht, lda )
910 CALL sgeesx( 'N', 'S', sslect, '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 )'SGEESX9', 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 = slange( '1', n, n, a, lda, work )
925 v = max( real( 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( ' SGET24: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
984 $ i6, ', INPUT EXAMPLE NUMBER = ', i4 )
985 9998 FORMAT( ' SGET24: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
986 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
987*
988 RETURN
989*
990* End of SGET24
991*

◆ sget31()

subroutine sget31 ( real rmax,
integer lmax,
integer, dimension( 2 ) ninfo,
integer knt )

SGET31

Purpose:
!>
!> SGET31 tests SLALN2, 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 REAL
!>          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 sget31.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 REAL RMAX
99* ..
100* .. Array Arguments ..
101 INTEGER NINFO( 2 )
102* ..
103*
104* =====================================================================
105*
106* .. Parameters ..
107 REAL ZERO, HALF, ONE
108 parameter( zero = 0.0e0, half = 0.5e0, one = 1.0e0 )
109 REAL TWO, THREE, FOUR
110 parameter( two = 2.0e0, three = 3.0e0, four = 4.0e0 )
111 REAL SEVEN, TEN
112 parameter( seven = 7.0e0, ten = 10.0e0 )
113 REAL TWNONE
114 parameter( twnone = 21.0e0 )
115* ..
116* .. Local Scalars ..
117 INTEGER IA, IB, ICA, ID1, ID2, INFO, ISMIN, ITRANS,
118 $ IWI, IWR, NA, NW
119 REAL 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 REAL 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 REAL SLAMCH
130 EXTERNAL slamch
131* ..
132* .. External Subroutines ..
133 EXTERNAL slabad, slaln2
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 = slamch( 'P' )
146 unfl = slamch( 'U' )
147 smlnum = slamch( 'S' ) / eps
148 bignum = one / smlnum
149 CALL slabad( 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 slaln2( 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 slaln2( 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 slaln2( 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 slaln2( 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 SGET31
514*
slaln2
subroutine slaln2(ltrans, na, nw, smin, ca, a, lda, d1, d2, b, ldb, wr, wi, x, ldx, scale, xnorm, info)
SLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.
Definition slaln2.f:218

◆ sget32()

subroutine sget32 ( real rmax,
integer lmax,
integer ninfo,
integer knt )

SGET32

Purpose:
!>
!> SGET32 tests SLASY2, 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 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 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 sget32.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 REAL RMAX
90* ..
91*
92* =====================================================================
93*
94* .. Parameters ..
95 REAL ZERO, ONE
96 parameter( zero = 0.0e0, one = 1.0e0 )
97 REAL TWO, FOUR, EIGHT
98 parameter( two = 2.0e0, four = 4.0e0, eight = 8.0e0 )
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 REAL BIGNUM, DEN, EPS, RES, SCALE, SGN, SMLNUM, TMP,
105 $ TNRM, XNORM, XNRM
106* ..
107* .. Local Arrays ..
108 INTEGER ITVAL( 2, 2, 8 )
109 REAL B( 2, 2 ), TL( 2, 2 ), TR( 2, 2 ), VAL( 3 ),
110 $ X( 2, 2 )
111* ..
112* .. External Functions ..
113 REAL SLAMCH
114 EXTERNAL slamch
115* ..
116* .. External Subroutines ..
117 EXTERNAL slabad, slasy2
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 = slamch( 'P' )
132 smlnum = slamch( 'S' ) / eps
133 bignum = one / smlnum
134 CALL slabad( 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 slasy2( 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 slasy2( 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 slasy2( 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 slasy2( 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 SGET32
427*
slasy2
subroutine slasy2(ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr, ldtr, b, ldb, scale, x, ldx, xnorm, info)
SLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2.
Definition slasy2.f:174

◆ sget33()

subroutine sget33 ( real rmax,
integer lmax,
integer ninfo,
integer knt )

SGET33

Purpose:
!>
!> SGET33 tests SLANV2, 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 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 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 sget33.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 REAL RMAX
84* ..
85*
86* =====================================================================
87*
88* .. Parameters ..
89 REAL ZERO, ONE
90 parameter( zero = 0.0e0, one = 1.0e0 )
91 REAL TWO, FOUR
92 parameter( two = 2.0e0, four = 4.0e0 )
93* ..
94* .. Local Scalars ..
95 INTEGER I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
96 REAL BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
97 $ WI1, WI2, WR1, WR2
98* ..
99* .. Local Arrays ..
100 REAL Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
101 $ VAL( 4 ), VM( 3 )
102* ..
103* .. External Functions ..
104 REAL SLAMCH
105 EXTERNAL slamch
106* ..
107* .. External Subroutines ..
108 EXTERNAL slabad, slanv2
109* ..
110* .. Intrinsic Functions ..
111 INTRINSIC abs, max, sign
112* ..
113* .. Executable Statements ..
114*
115* Get machine parameters
116*
117 eps = slamch( 'P' )
118 smlnum = slamch( 'S' ) / eps
119 bignum = one / smlnum
120 CALL slabad( 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 slanv2( 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 SGET33
222*
slanv2
subroutine slanv2(a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn)
SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form.
Definition slanv2.f:127

◆ sget34()

subroutine sget34 ( real rmax,
integer lmax,
integer, dimension( 2 ) ninfo,
integer knt )

SGET34

Purpose:
!>
!> SGET34 tests SLAEXC, 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, SLAEXC 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 last assertions, as well as that
!> the residual in the above equation is small.
!>
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 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 sget34.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 REAL RMAX
90* ..
91* .. Array Arguments ..
92 INTEGER NINFO( 2 )
93* ..
94*
95* =====================================================================
96*
97* .. Parameters ..
98 REAL ZERO, HALF, ONE
99 parameter( zero = 0.0e0, half = 0.5e0, one = 1.0e0 )
100 REAL TWO, THREE
101 parameter( two = 2.0e0, three = 3.0e0 )
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 REAL BIGNUM, EPS, RES, SMLNUM, TNRM
109* ..
110* .. Local Arrays ..
111 REAL Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ),
112 $ VAL( 9 ), VM( 2 ), WORK( LWORK )
113* ..
114* .. External Functions ..
115 REAL SLAMCH
116 EXTERNAL slamch
117* ..
118* .. External Subroutines ..
119 EXTERNAL scopy, slaexc
120* ..
121* .. Intrinsic Functions ..
122 INTRINSIC abs, max, real, sign, sqrt
123* ..
124* .. Executable Statements ..
125*
126* Get machine parameters
127*
128 eps = slamch( 'P' )
129 smlnum = slamch( 'S' ) / eps
130 bignum = one / smlnum
131 CALL slabad( 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 scopy( 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 scopy( 16, t, 1, t1, 1 )
167 CALL scopy( 16, val( 1 ), 0, q, 1 )
168 CALL scopy( 4, val( 3 ), 0, q, 5 )
169 CALL slaexc( .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 shst01( 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 )*real( 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 scopy( 16, t, 1, t1, 1 )
215 CALL scopy( 16, val( 1 ), 0, q, 1 )
216 CALL scopy( 4, val( 3 ), 0, q, 5 )
217 CALL slaexc( .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 shst01( 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 )*real( 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 scopy( 16, t, 1, t1, 1 )
271 CALL scopy( 16, val( 1 ), 0, q, 1 )
272 CALL scopy( 4, val( 3 ), 0, q, 5 )
273 CALL slaexc( .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 shst01( 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 $ real( 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 $ real( 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 scopy( 16, t, 1, t1, 1 )
347 CALL scopy( 16, val( 1 ), 0, q, 1 )
348 CALL scopy( 4, val( 3 ), 0, q, 5 )
349 CALL slaexc( .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 shst01( 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 SGET34
398*
slaexc
subroutine slaexc(wantq, n, t, ldt, q, ldq, j1, n1, n2, work, info)
SLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form...
Definition slaexc.f:138

◆ sget35()

subroutine sget35 ( real rmax,
integer lmax,
integer ninfo,
integer knt )

SGET35

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

Definition at line 77 of file sget35.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 REAL RMAX
86* ..
87*
88* =====================================================================
89*
90* .. Parameters ..
91 REAL ZERO, ONE
92 parameter( zero = 0.0e0, one = 1.0e0 )
93 REAL TWO, FOUR
94 parameter( two = 2.0e0, four = 4.0e0 )
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 REAL BIGNUM, CNRM, EPS, RES, RES1, RMUL, SCALE,
101 $ SMLNUM, TNRM, XNRM
102* ..
103* .. Local Arrays ..
104 INTEGER IDIM( 8 ), IVAL( 6, 6, 8 )
105 REAL A( 6, 6 ), B( 6, 6 ), C( 6, 6 ), CC( 6, 6 ),
106 $ DUM( 1 ), VM1( 3 ), VM2( 3 )
107* ..
108* .. External Functions ..
109 REAL SLAMCH, SLANGE
110 EXTERNAL slamch, slange
111* ..
112* .. External Subroutines ..
113 EXTERNAL sgemm, strsyl
114* ..
115* .. Intrinsic Functions ..
116 INTRINSIC abs, max, real, 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 = slamch( 'P' )
134 smlnum = slamch( 'S' )*four / eps
135 bignum = one / smlnum
136 CALL slabad( 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( real( 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 strsyl( 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 = slange( '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 sgemm( trana, 'N', m, n, m, rmul,
227 $ a, 6, c, 6, -scale*rmul,
228 $ cc, 6 )
229 CALL sgemm( 'N', tranb, m, n, n,
230 $ real( isgn )*rmul, c, 6, b,
231 $ 6, one, cc, 6 )
232 res1 = slange( '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 SGET35
252*

◆ sget36()

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

SGET36

Purpose:
!>
!> SGET36 tests STREXC, a routine for moving blocks (either 1 by 1 or
!> 2 by 2) on the diagonal of a matrix in real Schur form.  Thus, SLAEXC
!> 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 REAL
!>          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 sget36.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 REAL RMAX
96* ..
97* .. Array Arguments ..
98 INTEGER NINFO( 3 )
99* ..
100*
101* =====================================================================
102*
103* .. Parameters ..
104 REAL ZERO, ONE
105 parameter( zero = 0.0e0, one = 1.0e0 )
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 REAL EPS, RES
113* ..
114* .. Local Arrays ..
115 REAL Q( LDT, LDT ), RESULT( 2 ), T1( LDT, LDT ),
116 $ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
117* ..
118* .. External Functions ..
119 REAL SLAMCH
120 EXTERNAL slamch
121* ..
122* .. External Subroutines ..
123 EXTERNAL shst01, slacpy, slaset, strexc
124* ..
125* .. Intrinsic Functions ..
126 INTRINSIC abs, sign
127* ..
128* .. Executable Statements ..
129*
130 eps = slamch( '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 slacpy( 'F', n, n, tmp, ldt, t1, ldt )
149 CALL slacpy( '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 slaset( 'Full', n, n, zero, one, q, ldt )
161 CALL strexc( '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 slaset( 'Full', n, n, zero, one, q, ldt )
174 CALL strexc( '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 shst01( 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 SGET36
245*

◆ sget37()

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

SGET37

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

90*
91* -- LAPACK test routine --
92* -- LAPACK is a software package provided by Univ. of Tennessee, --
93* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
94*
95* .. Scalar Arguments ..
96 INTEGER KNT, NIN
97* ..
98* .. Array Arguments ..
99 INTEGER LMAX( 3 ), NINFO( 3 )
100 REAL RMAX( 3 )
101* ..
102*
103* =====================================================================
104*
105* .. Parameters ..
106 REAL ZERO, ONE, TWO
107 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
108 REAL EPSIN
109 parameter( epsin = 5.9605e-8 )
110 INTEGER LDT, LWORK
111 parameter( ldt = 20, lwork = 2*ldt*( 10+ldt ) )
112* ..
113* .. Local Scalars ..
114 INTEGER I, ICMP, IFND, INFO, ISCL, J, KMIN, M, N
115 REAL 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 REAL 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 REAL SLAMCH, SLANGE
131 EXTERNAL slamch, slange
132* ..
133* .. External Subroutines ..
134 EXTERNAL scopy, sgehrd, shseqr, slabad, slacpy, sscal,
135 $ strevc, strsna
136* ..
137* .. Intrinsic Functions ..
138 INTRINSIC max, real, sqrt
139* ..
140* .. Executable Statements ..
141*
142 eps = slamch( 'P' )
143 smlnum = slamch( 'S' ) / eps
144 bignum = one / smlnum
145 CALL slabad( smlnum, bignum )
146*
147* EPSIN = 2**(-24) = precision to which input data computed
148*
149 eps = max( eps, epsin )
150 rmax( 1 ) = zero
151 rmax( 2 ) = zero
152 rmax( 3 ) = zero
153 lmax( 1 ) = 0
154 lmax( 2 ) = 0
155 lmax( 3 ) = 0
156 knt = 0
157 ninfo( 1 ) = 0
158 ninfo( 2 ) = 0
159 ninfo( 3 ) = 0
160*
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 = slange( '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 slacpy( 'F', n, n, tmp, ldt, t, ldt )
189 vmul = val( iscl )
190 DO 40 i = 1, n
191 CALL sscal( 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 sgehrd( 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 shseqr( '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 strevc( 'Both', 'All', SELECT, n, t, ldt, le, ldt, re,
224 $ ldt, n, m, work, info )
225*
226* Compute condition numbers
227*
228 CALL strsna( '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 scopy( n, wr, 1, wrtmp, 1 )
240 CALL scopy( n, wi, 1, witmp, 1 )
241 CALL scopy( n, s, 1, stmp, 1 )
242 CALL scopy( n, sep, 1, septmp, 1 )
243 CALL sscal( 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*real( 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.real( 2*n )*eps .AND. stmp( i ).LE.
343 $ real( 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 scopy( n, dum, 0, stmp, 1 )
392 CALL scopy( n, dum, 0, septmp, 1 )
393 CALL strsna( '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 scopy( n, dum, 0, stmp, 1 )
410 CALL scopy( n, dum, 0, septmp, 1 )
411 CALL strsna( '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 scopy( n, dum, 0, stmp, 1 )
431 CALL scopy( n, dum, 0, septmp, 1 )
432 CALL strsna( '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 scopy( n, dum, 0, stmp, 1 )
450 CALL scopy( n, dum, 0, septmp, 1 )
451 CALL strsna( '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 scopy( n, dum, 0, stmp, 1 )
468 CALL scopy( n, dum, 0, septmp, 1 )
469 CALL strsna( '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 scopy( n, re( 1, i ), 1, re( 1, 2 ), 1 )
501 CALL scopy( n, re( 1, i+1 ), 1, re( 1, 3 ), 1 )
502 CALL scopy( n, le( 1, i ), 1, le( 1, 2 ), 1 )
503 CALL scopy( 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 scopy( n, re( 1, i ), 1, re( 1, 3 ), 1 )
522 CALL scopy( 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 scopy( icmp, dum, 0, stmp, 1 )
535 CALL scopy( icmp, dum, 0, septmp, 1 )
536 CALL strsna( '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 scopy( icmp, dum, 0, stmp, 1 )
555 CALL scopy( icmp, dum, 0, septmp, 1 )
556 CALL strsna( '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 scopy( icmp, dum, 0, stmp, 1 )
574 CALL scopy( icmp, dum, 0, septmp, 1 )
575 CALL strsna( '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 SGET37
598*
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79

◆ sget38()

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

SGET38

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

91*
92* -- LAPACK test routine --
93* -- LAPACK is a software package provided by Univ. of Tennessee, --
94* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
95*
96* .. Scalar Arguments ..
97 INTEGER KNT, NIN
98* ..
99* .. Array Arguments ..
100 INTEGER LMAX( 3 ), NINFO( 3 )
101 REAL RMAX( 3 )
102* ..
103*
104* =====================================================================
105*
106* .. Parameters ..
107 REAL ZERO, ONE, TWO
108 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
109 REAL EPSIN
110 parameter( epsin = 5.9605e-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 REAL 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 REAL 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 REAL SLAMCH, SLANGE
134 EXTERNAL slamch, slange
135* ..
136* .. External Subroutines ..
137 EXTERNAL scopy, sgehrd, shseqr, shst01, slabad, slacpy,
138 $ sorghr, sscal, strsen
139* ..
140* .. Intrinsic Functions ..
141 INTRINSIC max, real, sqrt
142* ..
143* .. Executable Statements ..
144*
145 eps = slamch( 'P' )
146 smlnum = slamch( 'S' ) / eps
147 bignum = one / smlnum
148 CALL slabad( 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 = slange( 'M', n, n, tmp, ldt, work )
183 DO 160 iscl = 1, 3
184*
185* Scale input matrix
186*
187 knt = knt + 1
188 CALL slacpy( 'F', n, n, tmp, ldt, t, ldt )
189 vmul = val( iscl )
190 DO 30 i = 1, n
191 CALL sscal( n, vmul, t( 1, i ), 1 )
192 30 CONTINUE
193 IF( tnrm.EQ.zero )
194 $ vmul = one
195 CALL slacpy( 'F', n, n, t, ldt, tsav, ldt )
196*
197* Compute Schur form
198*
199 CALL sgehrd( 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 slacpy( 'L', n, n, t, ldt, q, ldt )
210 CALL sorghr( n, 1, n, q, ldt, work( 1 ), work( n+1 ), lwork-n,
211 $ info )
212*
213* Compute Schur form
214*
215 CALL shseqr( '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 scopy( n, wr, 1, wrtmp, 1 )
230 CALL scopy( 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 slacpy( 'F', n, n, q, ldt, qsav, ldt )
257 CALL slacpy( 'F', n, n, t, ldt, tsav1, ldt )
258 CALL strsen( '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 shst01( 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*real( 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.real( 2*n )*eps .AND. stmp.LE.real( 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 slacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
395 CALL slacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
396 septmp = -one
397 stmp = -one
398 CALL strsen( '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 slacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
423 CALL slacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
424 septmp = -one
425 stmp = -one
426 CALL strsen( '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 slacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
451 CALL slacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
452 septmp = -one
453 stmp = -one
454 CALL strsen( '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 slacpy( 'F', n, n, tsav1, ldt, ttmp, ldt )
479 CALL slacpy( 'F', n, n, qsav, ldt, qtmp, ldt )
480 septmp = -one
481 stmp = -one
482 CALL strsen( '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 SGET38
511*

◆ sget39()

subroutine sget39 ( real rmax,
integer lmax,
integer ninfo,
integer knt )

SGET39

Purpose:
!>
!> SGET39 tests SLAQTR, 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 STRSNA.
!>
!> 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 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.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 102 of file sget39.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 REAL RMAX
111* ..
112*
113* =====================================================================
114*
115* .. Parameters ..
116 INTEGER LDT, LDT2
117 parameter( ldt = 10, ldt2 = 2*ldt )
118 REAL ZERO, ONE
119 parameter( zero = 0.0, one = 1.0 )
120* ..
121* .. Local Scalars ..
122 INTEGER I, INFO, IVM1, IVM2, IVM3, IVM4, IVM5, J, K, N,
123 $ NDIM
124 REAL BIGNUM, DOMIN, DUMM, EPS, NORM, NORMTB, RESID,
125 $ SCALE, SMLNUM, W, XNORM
126* ..
127* .. External Functions ..
128 INTEGER ISAMAX
129 REAL SASUM, SDOT, SLAMCH, SLANGE
130 EXTERNAL isamax, sasum, sdot, slamch, slange
131* ..
132* .. External Subroutines ..
133 EXTERNAL scopy, sgemv, slabad, slaqtr
134* ..
135* .. Intrinsic Functions ..
136 INTRINSIC abs, cos, max, real, sin, sqrt
137* ..
138* .. Local Arrays ..
139 INTEGER IDIM( 6 ), IVAL( 5, 5, 6 )
140 REAL 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 = slamch( 'P' )
160 smlnum = slamch( 'S' )
161 bignum = one / smlnum
162 CALL slabad( 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 ) = real( 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( real( i ) )*vm3( ivm3 )
224 30 CONTINUE
225*
226 DO 40 i = 1, 2*n
227 d( i ) = sin( real( i ) )*vm4( ivm4 )
228 40 CONTINUE
229*
230 norm = slange( '1', n, n, t, ldt, work )
231 k = isamax( n, b, 1 )
232 normtb = norm + abs( b( k ) ) + abs( w )
233*
234 CALL scopy( n, d, 1, x, 1 )
235 knt = knt + 1
236 CALL slaqtr( .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 scopy( n, d, 1, y, 1 )
245 CALL sgemv( 'No transpose', n, n, one, t, ldt,
246 $ x, 1, -scale, y, 1 )
247 xnorm = sasum( n, x, 1 )
248 resid = sasum( 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 scopy( n, d, 1, x, 1 )
258 knt = knt + 1
259 CALL slaqtr( .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 scopy( n, d, 1, y, 1 )
268 CALL sgemv( 'Transpose', n, n, one, t, ldt, x,
269 $ 1, -scale, y, 1 )
270 xnorm = sasum( n, x, 1 )
271 resid = sasum( 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 scopy( 2*n, d, 1, x, 1 )
281 knt = knt + 1
282 CALL slaqtr( .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 scopy( 2*n, d, 1, y, 1 )
293 y( 1 ) = sdot( 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 sgemv( 'No transpose', n, n, one, t, ldt,
299 $ x, 1, -one, y, 1 )
300*
301 y( 1+n ) = sdot( 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 sgemv( 'No transpose', n, n, one, t, ldt,
307 $ x( 1+n ), 1, one, y( 1+n ), 1 )
308*
309 resid = sasum( 2*n, y, 1 )
310 domin = max( smlnum, ( smlnum / eps )*normtb,
311 $ eps*( normtb*sasum( 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 scopy( 2*n, d, 1, x, 1 )
319 knt = knt + 1
320 CALL slaqtr( .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 scopy( 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 sgemv( '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 sgemv( 'Transpose', n, n, one, t, ldt,
344 $ x( 1+n ), 1, -one, y( 1+n ), 1 )
345*
346 resid = sasum( 2*n, y, 1 )
347 domin = max( smlnum, ( smlnum / eps )*normtb,
348 $ eps*( normtb*sasum( 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 SGET39
365*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
slaqtr
subroutine slaqtr(ltran, lreal, n, t, ldt, b, w, scale, x, work, info)
SLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of sp...
Definition slaqtr.f:165
sdot
real function sdot(n, sx, incx, sy, incy)
SDOT
Definition sdot.f:82

◆ sget51()

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

SGET51

Purpose:
!>
!>      SGET51  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, SGET51 does nothing.
!>          It must be at least zero.
!>
[in]A
!>          A is REAL 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 REAL 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 REAL 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 REAL 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 REAL array, dimension (2*N**2)
!>
[out]RESULT
!>          RESULT is REAL
!>          The values computed by the test specified by ITYPE.  The
!>          value is currently limited to 1/ulp, to avoid overflow.
!>          Errors are flagged by RESULT=10/ulp.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 147 of file sget51.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 REAL RESULT
157* ..
158* .. Array Arguments ..
159 REAL A( LDA, * ), B( LDB, * ), U( LDU, * ),
160 $ V( LDV, * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 REAL ZERO, ONE, TEN
167 parameter( zero = 0.0, one = 1.0e0, ten = 10.0e0 )
168* ..
169* .. Local Scalars ..
170 INTEGER JCOL, JDIAG, JROW
171 REAL ANORM, ULP, UNFL, WNORM
172* ..
173* .. External Functions ..
174 REAL SLAMCH, SLANGE
175 EXTERNAL slamch, slange
176* ..
177* .. External Subroutines ..
178 EXTERNAL sgemm, slacpy
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC max, min, real
182* ..
183* .. Executable Statements ..
184*
185 result = zero
186 IF( n.LE.0 )
187 $ RETURN
188*
189* Constants
190*
191 unfl = slamch( 'Safe minimum' )
192 ulp = slamch( 'Epsilon' )*slamch( '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( slange( '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 slacpy( ' ', n, n, a, lda, work, n )
212 CALL sgemm( 'N', 'N', n, n, n, one, u, ldu, b, ldb, zero,
213 $ work( n**2+1 ), n )
214*
215 CALL sgemm( '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 slacpy( ' ', 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 = slange( '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, real( 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 sgemm( '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( slange( '1', n, n, work, n, work( n**2+1 ) ),
261 $ real( n ) ) / ( n*ulp )
262 END IF
263*
264 RETURN
265*
266* End of SGET51
267*

◆ sget52()

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

SGET52

Purpose:
!>
!> SGET52  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.
!>
!> SGET52 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, SGET52 does
!>          nothing.  It must be at least zero.
!>
[in]A
!>          A is REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL array, dimension (N)
!>          The values b(j) as described above, which, along with a(j),
!>          define the generalized eigenvalues.
!>
[out]WORK
!>          WORK is REAL array, dimension (N**2+N)
!>
[out]RESULT
!>          RESULT is REAL array, dimension (2)
!>          The values computed by the test described above.  If A E or
!>          B E is likely to overflow, then RESULT(1:2) is set to
!>          10 / ulp.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 197 of file sget52.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 REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
210 $ B( LDB, * ), BETA( * ), E( LDE, * ),
211 $ RESULT( 2 ), WORK( * )
212* ..
213*
214* =====================================================================
215*
216* .. Parameters ..
217 REAL ZERO, ONE, TEN
218 parameter( zero = 0.0, one = 1.0, ten = 10.0 )
219* ..
220* .. Local Scalars ..
221 LOGICAL ILCPLX
222 CHARACTER NORMAB, TRANS
223 INTEGER J, JVEC
224 REAL 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 REAL SLAMCH, SLANGE
230 EXTERNAL slamch, slange
231* ..
232* .. External Subroutines ..
233 EXTERNAL sgemv
234* ..
235* .. Intrinsic Functions ..
236 INTRINSIC abs, max, real
237* ..
238* .. Executable Statements ..
239*
240 result( 1 ) = zero
241 result( 2 ) = zero
242 IF( n.LE.0 )
243 $ RETURN
244*
245 safmin = slamch( 'Safe minimum' )
246 safmax = one / safmin
247 ulp = slamch( 'Epsilon' )*slamch( '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( slange( normab, n, n, a, lda, work ), safmin )
260 bnorm = max( slange( normab, n, n, b, ldb, work ), safmin )
261 enorm = max( slange( '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 sgemv( trans, n, n, acoef, a, lda, e( 1, jvec ), 1,
295 $ zero, work( n*( jvec-1 )+1 ), 1 )
296 CALL sgemv( 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 sgemv( trans, n, n, acoef, a, lda, e( 1, jvec ), 1,
325 $ zero, work( n*( jvec-1 )+1 ), 1 )
326 CALL sgemv( trans, n, n, -bcoefr, b, lda, e( 1, jvec ),
327 $ 1, one, work( n*( jvec-1 )+1 ), 1 )
328 CALL sgemv( trans, n, n, bcoefi, b, lda, e( 1, jvec+1 ),
329 $ 1, one, work( n*( jvec-1 )+1 ), 1 )
330*
331 CALL sgemv( trans, n, n, acoef, a, lda, e( 1, jvec+1 ),
332 $ 1, zero, work( n*jvec+1 ), 1 )
333 CALL sgemv( trans, n, n, -bcoefi, b, lda, e( 1, jvec ),
334 $ 1, one, work( n*jvec+1 ), 1 )
335 CALL sgemv( 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 = slange( '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 / ( real( n )*ulp )
375*
376 RETURN
377*
378* End of SGET52
379*

◆ sget53()

subroutine sget53 ( real, dimension( lda, * ) a,
integer lda,
real, dimension( ldb, * ) b,
integer ldb,
real scale,
real wr,
real wi,
real result,
integer info )

SGET53

Purpose:
!>
!> SGET53  checks the generalized eigenvalues computed by SLAG2.
!>
!> 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 REAL 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 REAL 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 REAL
!>          The  s in the formula  s A - w B .  It is
!>          assumed to be non-negative.
!>
[in]WR
!>          WR is REAL
!>          The real part of the eigenvalue  w  in the formula
!>          s A - w B .
!>
[in]WI
!>          WI is REAL
!>          The imaginary part of the eigenvalue  w  in the formula
!>          s A - w B .
!>
[out]RESULT
!>          RESULT is REAL
!>          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 sget53.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 REAL RESULT, SCALE, WI, WR
134* ..
135* .. Array Arguments ..
136 REAL A( LDA, * ), B( LDB, * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 REAL ZERO, ONE
143 parameter( zero = 0.0, one = 1.0 )
144* ..
145* .. Local Scalars ..
146 REAL 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 REAL SLAMCH
152 EXTERNAL slamch
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 = slamch( 'Safe minimum' )
170 ulp = slamch( 'Epsilon' )*slamch( '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 SGET53
250*

◆ sget54()

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

SGET54

Purpose:
!>
!> SGET54 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, SGET54 does nothing.
!>          It must be at least zero.
!>
[in]A
!>          A is REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL array, dimension (3*N**2)
!>
[out]RESULT
!>          RESULT is REAL
!>          The value RESULT, It is currently limited to 1/ulp, to
!>          avoid overflow. Errors are flagged by RESULT=10/ulp.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 154 of file sget54.f.

156*
157* -- LAPACK test routine --
158* -- LAPACK is a software package provided by Univ. of Tennessee, --
159* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
160*
161* .. Scalar Arguments ..
162 INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N
163 REAL RESULT
164* ..
165* .. Array Arguments ..
166 REAL A( LDA, * ), B( LDB, * ), S( LDS, * ),
167 $ T( LDT, * ), U( LDU, * ), V( LDV, * ),
168 $ WORK( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ZERO, ONE
175 parameter( zero = 0.0e+0, one = 1.0e+0 )
176* ..
177* .. Local Scalars ..
178 REAL ABNORM, ULP, UNFL, WNORM
179* ..
180* .. Local Arrays ..
181 REAL DUM( 1 )
182* ..
183* .. External Functions ..
184 REAL SLAMCH, SLANGE
185 EXTERNAL slamch, slange
186* ..
187* .. External Subroutines ..
188 EXTERNAL sgemm, slacpy
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC max, min, real
192* ..
193* .. Executable Statements ..
194*
195 result = zero
196 IF( n.LE.0 )
197 $ RETURN
198*
199* Constants
200*
201 unfl = slamch( 'Safe minimum' )
202 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
203*
204* compute the norm of (A,B)
205*
206 CALL slacpy( 'Full', n, n, a, lda, work, n )
207 CALL slacpy( 'Full', n, n, b, ldb, work( n*n+1 ), n )
208 abnorm = max( slange( '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 slacpy( ' ', n, n, a, lda, work, n )
213 CALL sgemm( 'N', 'N', n, n, n, one, u, ldu, s, lds, zero,
214 $ work( n*n+1 ), n )
215*
216 CALL sgemm( '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 slacpy( ' ', n, n, b, ldb, work( n*n+1 ), n )
222 CALL sgemm( 'N', 'N', n, n, n, one, u, ldu, t, ldt, zero,
223 $ work( 2*n*n+1 ), n )
224*
225 CALL sgemm( '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 = slange( '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, real( 2*n ) ) / ( 2*n*ulp )
239 END IF
240 END IF
241*
242 RETURN
243*
244* End of SGET54
245*

◆ sglmts()

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

SGLMTS

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

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

◆ sgqrts()

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

SGQRTS

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

Definition at line 174 of file sgqrts.f.

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

◆ sgrqts()

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

SGRQTS

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

Definition at line 175 of file sgrqts.f.

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

◆ sgsvts3()

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

SGSVTS3

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

Definition at line 207 of file sgsvts3.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 REAL 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 REAL ZERO, ONE
231 parameter( zero = 0.0e+0, one = 1.0e+0 )
232* ..
233* .. Local Scalars ..
234 INTEGER I, INFO, J, K, L
235 REAL ANORM, BNORM, RESID, TEMP, ULP, ULPINV, UNFL
236* ..
237* .. External Functions ..
238 REAL SLAMCH, SLANGE, SLANSY
239 EXTERNAL slamch, slange, slansy
240* ..
241* .. External Subroutines ..
242 EXTERNAL scopy, sgemm, sggsvd3, slacpy, slaset, ssyrk
243* ..
244* .. Intrinsic Functions ..
245 INTRINSIC max, min, real
246* ..
247* .. Executable Statements ..
248*
249 ulp = slamch( 'Precision' )
250 ulpinv = one / ulp
251 unfl = slamch( 'Safe minimum' )
252*
253* Copy the matrix A to the array AF.
254*
255 CALL slacpy( 'Full', m, n, a, lda, af, lda )
256 CALL slacpy( 'Full', p, n, b, ldb, bf, ldb )
257*
258 anorm = max( slange( '1', m, n, a, lda, rwork ), unfl )
259 bnorm = max( slange( '1', p, n, b, ldb, rwork ), unfl )
260*
261* Factorize the matrices A and B in the arrays AF and BF.
262*
263 CALL sggsvd3( '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 sgemm( 'No transpose', 'No transpose', m, n, n, one, a, lda,
286 $ q, ldq, zero, work, lda )
287*
288 CALL sgemm( '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 = slange( '1', m, n, a, lda, rwork )
306*
307 IF( anorm.GT.zero ) THEN
308 result( 1 ) = ( ( resid / real( max( 1, m, n ) ) ) / anorm ) /
309 $ ulp
310 ELSE
311 result( 1 ) = zero
312 END IF
313*
314* Compute B := V'*B*Q - D2*R
315*
316 CALL sgemm( 'No transpose', 'No transpose', p, n, n, one, b, ldb,
317 $ q, ldq, zero, work, ldb )
318*
319 CALL sgemm( '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 = slange( '1', p, n, b, ldb, rwork )
331 IF( bnorm.GT.zero ) THEN
332 result( 2 ) = ( ( resid / real( max( 1, p, n ) ) ) / bnorm ) /
333 $ ulp
334 ELSE
335 result( 2 ) = zero
336 END IF
337*
338* Compute I - U'*U
339*
340 CALL slaset( 'Full', m, m, zero, one, work, ldq )
341 CALL ssyrk( 'Upper', 'Transpose', m, m, -one, u, ldu, one, work,
342 $ ldu )
343*
344* Compute norm( I - U'*U ) / ( M * ULP ) .
345*
346 resid = slansy( '1', 'Upper', m, work, ldu, rwork )
347 result( 3 ) = ( resid / real( max( 1, m ) ) ) / ulp
348*
349* Compute I - V'*V
350*
351 CALL slaset( 'Full', p, p, zero, one, work, ldv )
352 CALL ssyrk( 'Upper', 'Transpose', p, p, -one, v, ldv, one, work,
353 $ ldv )
354*
355* Compute norm( I - V'*V ) / ( P * ULP ) .
356*
357 resid = slansy( '1', 'Upper', p, work, ldv, rwork )
358 result( 4 ) = ( resid / real( max( 1, p ) ) ) / ulp
359*
360* Compute I - Q'*Q
361*
362 CALL slaset( 'Full', n, n, zero, one, work, ldq )
363 CALL ssyrk( 'Upper', 'Transpose', n, n, -one, q, ldq, one, work,
364 $ ldq )
365*
366* Compute norm( I - Q'*Q ) / ( N * ULP ) .
367*
368 resid = slansy( '1', 'Upper', n, work, ldq, rwork )
369 result( 5 ) = ( resid / real( max( 1, n ) ) ) / ulp
370*
371* Check sorting
372*
373 CALL scopy( n, alpha, 1, 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 SGSVTS3
392*

◆ shst01()

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

SHST01

Purpose:
!>
!> SHST01 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 SGEHRD + SORGHR.
!>
!> 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 REAL 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 REAL array, dimension (LDH,N)
!>          The upper Hessenberg matrix H from the reduction A = Q*H*Q'
!>          as computed by SGEHRD.  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 REAL array, dimension (LDQ,N)
!>          The orthogonal matrix Q from the reduction A = Q*H*Q' as
!>          computed by SGEHRD + SORGHR.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[out]WORK
!>          WORK is REAL array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= 2*N*N.
!>
[out]RESULT
!>          RESULT is REAL array, dimension (2)
!>          RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 132 of file shst01.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 REAL A( LDA, * ), H( LDH, * ), Q( LDQ, * ),
144 $ RESULT( 2 ), WORK( LWORK )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 REAL ONE, ZERO
151 parameter( one = 1.0e+0, zero = 0.0e+0 )
152* ..
153* .. Local Scalars ..
154 INTEGER LDWORK
155 REAL ANORM, EPS, OVFL, SMLNUM, UNFL, WNORM
156* ..
157* .. External Functions ..
158 REAL SLAMCH, SLANGE
159 EXTERNAL slamch, slange
160* ..
161* .. External Subroutines ..
162 EXTERNAL sgemm, slabad, slacpy, sort01
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 = slamch( 'Safe minimum' )
178 eps = slamch( 'Precision' )
179 ovfl = one / unfl
180 CALL slabad( 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 slacpy( ' ', n, n, a, lda, work, ldwork )
189*
190* Compute Q*H
191*
192 CALL sgemm( '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 sgemm( 'No transpose', 'Transpose', n, n, n, -one,
198 $ work( ldwork*n+1 ), ldwork, q, ldq, one, work,
199 $ ldwork )
200*
201 anorm = max( slange( '1', n, n, a, lda, work( ldwork*n+1 ) ),
202 $ unfl )
203 wnorm = slange( '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 sort01( 'Columns', n, n, q, ldq, work, lwork, result( 2 ) )
212*
213 RETURN
214*
215* End of SHST01
216*

◆ slafts()

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

SLAFTS

Purpose:
!>
!>    SLAFTS 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 SLAHD2
!>           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 - REAL               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 - REAL
!>           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 slafts.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 REAL THRESH
108* ..
109* .. Array Arguments ..
110 INTEGER ISEED( 4 )
111 REAL RESULT( * )
112* ..
113*
114* =====================================================================
115*
116* .. Local Scalars ..
117 INTEGER K
118* ..
119* .. External Subroutines ..
120 EXTERNAL slahd2
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 SLAHD2
132* to print a header to the data file.
133*
134 IF( ie.EQ.0 )
135 $ CALL slahd2( iounit, TYPE )
136 ie = ie + 1
137 IF( result( k ).LT.10000.0 ) 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, e10.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 SLAHD2
160* to print a header to the data file.
161*
162 IF( ie.EQ.0 )
163 $ CALL slahd2( iounit, TYPE )
164 ie = ie + 1
165 IF( result( k ).LT.10000.0 ) 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, e10.3 )
177 END IF
178 END IF
179 20 CONTINUE
180*
181 END IF
182 RETURN
183*
184* End of SLAFTS
185*

◆ slahd2()

subroutine slahd2 ( integer iounit,
character*3 path )

SLAHD2

Purpose:
!>
!> SLAHD2 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
!>
!>             SHS, CHS:  Non-symmetric eigenproblem.
!>             SST, CST:  Symmetric eigenproblem.
!>             SSG, CSG:  Symmetric Generalized eigenproblem.
!>             SBD, CBD:  Singular Value Decomposition (SVD)
!>             SBB, CBB:  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 slahd2.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 = SSYGV, with ITYPE=1 and UPLO=''U'':',
378 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
379 $ / ' 2 = SSPGV, with ITYPE=1 and UPLO=''U'':',
380 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
381 $ / ' 3 = SSBGV, with ITYPE=1 and UPLO=''U'':',
382 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
383 $ / ' 4 = SSYGV, with ITYPE=1 and UPLO=''L'':',
384 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
385 $ / ' 5 = SSPGV, with ITYPE=1 and UPLO=''L'':',
386 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
387 $ / ' 6 = SSBGV, with ITYPE=1 and UPLO=''L'':',
388 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ' )
389 9976 FORMAT( ' 7 = SSYGV, with ITYPE=2 and UPLO=''U'':',
390 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
391 $ / ' 8 = SSPGV, with ITYPE=2 and UPLO=''U'':',
392 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
393 $ / ' 9 = SSPGV, with ITYPE=2 and UPLO=''L'':',
394 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
395 $ / '10 = SSPGV, with ITYPE=2 and UPLO=''L'':',
396 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
397 $ / '11 = SSYGV, with ITYPE=3 and UPLO=''U'':',
398 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
399 $ / '12 = SSPGV, with ITYPE=3 and UPLO=''U'':',
400 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
401 $ / '13 = SSYGV, with ITYPE=3 and UPLO=''L'':',
402 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
403 $ / '14 = SSPGV, 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 = CHEGV, with ITYPE=1 and UPLO=''U'':',
410 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
411 $ / ' 2 = CHPGV, with ITYPE=1 and UPLO=''U'':',
412 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
413 $ / ' 3 = CHBGV, with ITYPE=1 and UPLO=''U'':',
414 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
415 $ / ' 4 = CHEGV, with ITYPE=1 and UPLO=''L'':',
416 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
417 $ / ' 5 = CHPGV, with ITYPE=1 and UPLO=''L'':',
418 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
419 $ / ' 6 = CHBGV, with ITYPE=1 and UPLO=''L'':',
420 $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ' )
421 9974 FORMAT( ' 7 = CHEGV, with ITYPE=2 and UPLO=''U'':',
422 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
423 $ / ' 8 = CHPGV, with ITYPE=2 and UPLO=''U'':',
424 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
425 $ / ' 9 = CHPGV, with ITYPE=2 and UPLO=''L'':',
426 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
427 $ / '10 = CHPGV, with ITYPE=2 and UPLO=''L'':',
428 $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
429 $ / '11 = CHEGV, with ITYPE=3 and UPLO=''U'':',
430 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
431 $ / '12 = CHPGV, with ITYPE=3 and UPLO=''U'':',
432 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
433 $ / '13 = CHEGV, with ITYPE=3 and UPLO=''L'':',
434 $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
435 $ / '14 = CHPGV, 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 $ ' SBDSVX(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 $ ' SBDSVX(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 $ ' SBDSVX(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 SLAHD2
541*

◆ slarfy()

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

SLARFY

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

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

◆ slarhs()

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

SLARHS

Purpose:
!>
!> SLARHS 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 REAL 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) REAL 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 REAL 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
!>          SLATMS).  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 slarhs.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 REAL A( LDA, * ), B( LDB, * ), X( LDX, * )
218* ..
219*
220* =====================================================================
221*
222* .. Parameters ..
223 REAL ONE, ZERO
224 parameter( one = 1.0e+0, zero = 0.0e+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 sgbmv, sgemm, slacpy, slarnv, ssbmv, sspmv,
238 $ ssymm, stbmv, stpmv, strmm, 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, 'Single 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( 'SLARHS', -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 slarnv( 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 sgemm( 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 ssymm( '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 sgbmv( 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 ssbmv( 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 sspmv( 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 slacpy( '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 strmm( '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 slacpy( '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 stpmv( 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 slacpy( '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 stbmv( 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( 'SLARHS', -info )
404 END IF
405*
406 RETURN
407*
408* End of SLARHS
409*
slarnv
subroutine slarnv(idist, iseed, n, x)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition slarnv.f:97
sgbmv
subroutine sgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
SGBMV
Definition sgbmv.f:185
stbmv
subroutine stbmv(uplo, trans, diag, n, k, a, lda, x, incx)
STBMV
Definition stbmv.f:186
stpmv
subroutine stpmv(uplo, trans, diag, n, ap, x, incx)
STPMV
Definition stpmv.f:142
ssbmv
subroutine ssbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
SSBMV
Definition ssbmv.f:184
sspmv
subroutine sspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
SSPMV
Definition sspmv.f:147
ssymm
subroutine ssymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
SSYMM
Definition ssymm.f:189
strmm
subroutine strmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRMM
Definition strmm.f:177

◆ slatb9()

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

SLATB9

Purpose:
!>
!> SLATB9 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 REAL
!>          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 REAL
!>          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 REAL
!>          The desired condition number.
!>
[out]CNDNMB
!>          CNDNMB is REAL
!>          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 slatb9.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, KUA, KLB, KUB, M, P, MODEA, MODEB, N
179 REAL ANORM, BNORM, CNDNMA, CNDNMB
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 REAL SHRINK, TENTH
186 parameter( shrink = 0.25e0, tenth = 0.1e+0 )
187 REAL ONE, TEN
188 parameter( one = 1.0e+0, ten = 1.0e+1 )
189* ..
190* .. Local Scalars ..
191 LOGICAL FIRST
192 REAL BADC1, BADC2, EPS, LARGE, SMALL
193* ..
194* .. External Functions ..
195 LOGICAL LSAMEN
196 REAL SLAMCH
197 EXTERNAL lsamen, slamch
198* ..
199* .. Intrinsic Functions ..
200 INTRINSIC max, sqrt
201* ..
202* .. External Subroutines ..
203 EXTERNAL slabad
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 = slamch( 'Precision' )
218 badc2 = tenth / eps
219 badc1 = sqrt( badc2 )
220 small = slamch( '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 slabad( 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.
285 $ lsamen( 3, path, 'GLM') )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 SLATB9
368*

◆ slatm4()

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

SLATM4

Purpose:
!>
!> SLATM4 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 SLARND.)
!>
[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 REAL
!>          The diagonal and subdiagonal entries will be multiplied by
!>          AMAGN.
!>
[in]RCOND
!>          RCOND is REAL
!>          If abs(ITYPE) > 4, then the smallest diagonal entry will be
!>          entry will be RCOND.  RCOND must be between 0 and 1.
!>
[in]TRIANG
!>          TRIANG is REAL
!>          The entries above the diagonal will be random numbers with
!>          magnitude bounded by TRIANG (i.e., random numbers multiplied
!>          by TRIANG.)
!>
[in]IDIST
!>          IDIST is INTEGER
!>          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 SLATM4 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 REAL 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 slatm4.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 REAL AMAGN, RCOND, TRIANG
183* ..
184* .. Array Arguments ..
185 INTEGER ISEED( 4 )
186 REAL A( LDA, * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 REAL ZERO, ONE, TWO
193 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
194 REAL 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 REAL ALPHA, CL, CR, SAFMIN, SL, SR, SV1, SV2, TEMP
201* ..
202* .. External Functions ..
203 REAL SLAMCH, SLARAN, SLARND
204 EXTERNAL slamch, slaran, slarnd
205* ..
206* .. External Subroutines ..
207 EXTERNAL slaset
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC abs, exp, log, max, min, mod, real, sqrt
211* ..
212* .. Executable Statements ..
213*
214 IF( n.LE.0 )
215 $ RETURN
216 CALL slaset( '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 ) = real( 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 / real( klen-1 ) )
306 DO 150 i = 2, klen
307 a( nz1+i, nz1+i ) = alpha**real( 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 ) / real( klen-1 )
318 DO 170 i = 2, klen
319 a( nz1+i, nz1+i ) = real( 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*slaran( 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 ) = slarnd( 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*real( a( jd, jd ) )
346 230 CONTINUE
347 DO 240 jd = isdb, isde
348 a( jd+1, jd ) = amagn*real( 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( real( a( jd, jd ) ).NE.zero ) THEN
357 IF( slaran( iseed ).GT.half )
358 $ a( jd, jd ) = -a( jd, jd )
359 END IF
360 250 CONTINUE
361 DO 260 jd = isdb, isde
362 IF( real( a( jd+1, jd ) ).NE.zero ) THEN
363 IF( slaran( 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 = slamch( 'S' )
389 DO 290 jd = kbeg, kend - 1, 2
390 IF( slaran( iseed ).GT.half ) THEN
391*
392* Rotation on left.
393*
394 cl = two*slaran( iseed ) - one
395 sl = two*slaran( 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*slaran( iseed ) - one
403 sr = two*slaran( 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*slarnd( 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*slarnd( idist, iseed )
438 310 CONTINUE
439 320 CONTINUE
440 END IF
441*
442 RETURN
443*
444* End of SLATM4
445*

◆ slctes()

logical function slctes ( real zr,
real zi,
real d )

SLCTES

Purpose:
!>
!> SLCTES 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 SDRGES to test whether the driver
!> routine SGGES successfully sorts eigenvalues.
!>
Parameters
[in]ZR
!>          ZR is REAL
!>          The numerator of the real part of a complex eigenvalue
!>          (ZR/D) + i*(ZI/D).
!>
[in]ZI
!>          ZI is REAL
!>          The numerator of the imaginary part of a complex eigenvalue
!>          (ZR/D) + i*(ZI).
!>
[in]D
!>          D is REAL
!>          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 slctes.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 REAL D, ZI, ZR
75* ..
76*
77* =====================================================================
78*
79* .. Parameters ..
80 REAL ZERO, ONE
81 parameter( zero = 0.0e+0, one = 1.0e+0 )
82* ..
83* .. Intrinsic Functions ..
84 INTRINSIC sign
85* ..
86* .. Executable Statements ..
87*
88 IF( d.EQ.zero ) THEN
89 slctes = ( zr.LT.zero )
90 ELSE
91 slctes = ( sign( one, zr ).NE.sign( one, d ) )
92 END IF
93*
94 RETURN
95*
96* End of SLCTES
97*

◆ slctsx()

logical function slctsx ( real ar,
real ai,
real beta )

SLCTSX

Purpose:
!>
!> This function is used to determine what eigenvalues will be
!> selected.  If this is part of the test driver SDRGSX, do not
!> change the code UNLESS you are testing input examples and not
!> using the built-in examples.
!>
Parameters
[in]AR
!>          AR is REAL
!>          The numerator of the real part of a complex eigenvalue
!>          (AR/BETA) + i*(AI/BETA).
!>
[in]AI
!>          AI is REAL
!>          The numerator of the imaginary part of a complex eigenvalue
!>          (AR/BETA) + i*(AI).
!>
[in]BETA
!>          BETA is REAL
!>          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 slctsx.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 REAL 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 slctsx = .false.
92 ELSE
93 slctsx = .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 slctsx = .true.
103 ELSE
104 slctsx = .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* SLCTSX = .TRUE.
114* ELSE
115* SLCTSX = .FALSE.
116* END IF
117*
118 RETURN
119*
120* End of SLCTSX
121*

◆ slsets()

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

SLSETS

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

Definition at line 153 of file slsets.f.

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

◆ sort01()

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

SORT01

Purpose:
!>
!> SORT01 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 REAL 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 REAL 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 REAL
!>          RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or
!>          RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 115 of file sort01.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 REAL RESID
125* ..
126* .. Array Arguments ..
127 REAL U( LDU, * ), WORK( * )
128* ..
129*
130* =====================================================================
131*
132* .. Parameters ..
133 REAL ZERO, ONE
134 parameter( zero = 0.0e+0, one = 1.0e+0 )
135* ..
136* .. Local Scalars ..
137 CHARACTER TRANSU
138 INTEGER I, J, K, LDWORK, MNMIN
139 REAL EPS, TMP
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 REAL SDOT, SLAMCH, SLANSY
144 EXTERNAL lsame, sdot, slamch, slansy
145* ..
146* .. External Subroutines ..
147 EXTERNAL slaset, ssyrk
148* ..
149* .. Intrinsic Functions ..
150 INTRINSIC max, min, real
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 = slamch( '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 slaset( 'Upper', mnmin, mnmin, zero, one, work, ldwork )
181 CALL ssyrk( 'Upper', transu, mnmin, k, -one, u, ldu, one, work,
182 $ ldwork )
183*
184* Compute norm( I - U*U' ) / ( K * EPS ) .
185*
186 resid = slansy( '1', 'Upper', mnmin, work, ldwork,
187 $ work( ldwork*mnmin+1 ) )
188 resid = ( resid / real( 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 - sdot( m, u( 1, i ), 1, u( 1, j ), 1 )
201 resid = max( resid, abs( tmp ) )
202 10 CONTINUE
203 20 CONTINUE
204 resid = ( resid / real( 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 - sdot( n, u( j, 1 ), ldu, u( i, 1 ), ldu )
217 resid = max( resid, abs( tmp ) )
218 30 CONTINUE
219 40 CONTINUE
220 resid = ( resid / real( n ) ) / eps
221 END IF
222 RETURN
223*
224* End of SORT01
225*

◆ sort03()

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

SORT03

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

Definition at line 154 of file sort03.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 REAL RESULT
165* ..
166* .. Array Arguments ..
167 REAL U( LDU, * ), V( LDV, * ), WORK( * )
168* ..
169*
170* =====================================================================
171*
172* .. Parameters ..
173 REAL ZERO, ONE
174 parameter( zero = 0.0e0, one = 1.0e0 )
175* ..
176* .. Local Scalars ..
177 INTEGER I, IRC, J, LMX
178 REAL RES1, RES2, S, ULP
179* ..
180* .. External Functions ..
181 LOGICAL LSAME
182 INTEGER ISAMAX
183 REAL SLAMCH
184 EXTERNAL lsame, isamax, slamch
185* ..
186* .. Intrinsic Functions ..
187 INTRINSIC abs, max, min, real, sign
188* ..
189* .. External Subroutines ..
190 EXTERNAL sort01, 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( 'SORT03', -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 = slamch( 'Precision' )
235*
236 IF( irc.EQ.0 ) THEN
237*
238* Compare rows
239*
240 res1 = zero
241 DO 20 i = 1, k
242 lmx = isamax( 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 / ( real( n )*ulp )
249*
250* Compute orthogonality of rows of V.
251*
252 CALL sort01( '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 = isamax( 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 / ( real( n )*ulp )
267*
268* Compute orthogonality of columns of V.
269*
270 CALL sort01( '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 SORT03
277*

◆ ssbt21()

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

SSBT21

Purpose:
!>
!> SSBT21  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, SSBT21 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 REAL 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 REAL array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix S.
!>
[in]E
!>          E is REAL array, dimension (N-1)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix S.
!>          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
!>          (3,2) element, etc.
!>          Not referenced if KS=0.
!>
[in]U
!>          U is REAL 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 REAL array, dimension (N**2+N)
!>
[out]RESULT
!>          RESULT is REAL array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 145 of file ssbt21.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 REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
158 $ U( LDU, * ), WORK( * )
159* ..
160*
161* =====================================================================
162*
163* .. Parameters ..
164 REAL ZERO, ONE
165 parameter( zero = 0.0e0, one = 1.0e0 )
166* ..
167* .. Local Scalars ..
168 LOGICAL LOWER
169 CHARACTER CUPLO
170 INTEGER IKA, J, JC, JR, LW
171 REAL ANORM, ULP, UNFL, WNORM
172* ..
173* .. External Functions ..
174 LOGICAL LSAME
175 REAL SLAMCH, SLANGE, SLANSB, SLANSP
176 EXTERNAL lsame, slamch, slange, slansb, slansp
177* ..
178* .. External Subroutines ..
179 EXTERNAL sgemm, sspr, sspr2
180* ..
181* .. Intrinsic Functions ..
182 INTRINSIC max, min, real
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 = slamch( 'Safe minimum' )
205 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
206*
207* Some Error Checks
208*
209* Do Test 1
210*
211* Norm of A:
212*
213 anorm = max( slansb( '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 sspr( 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 sspr2( cuplo, n, -e( j ), u( 1, j ), 1, u( 1, j+1 ), 1,
249 $ work )
250 70 CONTINUE
251 END IF
252 wnorm = slansp( '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, real( n ) ) / ( n*ulp )
261 END IF
262 END IF
263*
264* Do Test 2
265*
266* Compute U U**T - I
267*
268 CALL sgemm( '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( slange( '1', n, n, work, n, work( n**2+1 ) ),
276 $ real( n ) ) / ( n*ulp )
277*
278 RETURN
279*
280* End of SSBT21
281*
slansb
real function slansb(norm, uplo, n, k, ab, ldab, work)
SLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slansb.f:129
slansp
real function slansp(norm, uplo, n, ap, work)
SLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slansp.f:114
sspr2
subroutine sspr2(uplo, n, alpha, x, incx, y, incy, ap)
SSPR2
Definition sspr2.f:142
sspr
subroutine sspr(uplo, n, alpha, x, incx, ap)
SSPR
Definition sspr.f:127

◆ ssgt01()

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

SSGT01

Purpose:
!>
!> SSGT01 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 REAL 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 REAL 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 REAL array, dimension (LDZ, M)
!>          The computed eigenvectors of the generalized eigenproblem.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= max(1,N).
!>
[in]D
!>          D is REAL array, dimension (M)
!>          The computed eigenvalues of the generalized eigenproblem.
!>
[out]WORK
!>          WORK is REAL array, dimension (N*N)
!>
[out]RESULT
!>          RESULT is REAL array, dimension (1)
!>          The test ratio as described above.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 144 of file ssgt01.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 REAL A( LDA, * ), B( LDB, * ), D( * ), RESULT( * ),
157 $ WORK( * ), Z( LDZ, * )
158* ..
159*
160* =====================================================================
161*
162* .. Parameters ..
163 REAL ZERO, ONE
164 parameter( zero = 0.0e0, one = 1.0e0 )
165* ..
166* .. Local Scalars ..
167 INTEGER I
168 REAL ANORM, ULP
169* ..
170* .. External Functions ..
171 REAL SLAMCH, SLANGE, SLANSY
172 EXTERNAL slamch, slange, slansy
173* ..
174* .. External Subroutines ..
175 EXTERNAL sscal, ssymm
176* ..
177* .. Executable Statements ..
178*
179 result( 1 ) = zero
180 IF( n.LE.0 )
181 $ RETURN
182*
183 ulp = slamch( 'Epsilon' )
184*
185* Compute product of 1-norms of A and Z.
186*
187 anorm = slansy( '1', uplo, n, a, lda, work )*
188 $ slange( '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 ssymm( 'Left', uplo, n, m, one, a, lda, z, ldz, zero,
197 $ work, n )
198 DO 10 i = 1, m
199 CALL sscal( n, d( i ), z( 1, i ), 1 )
200 10 CONTINUE
201 CALL ssymm( 'Left', uplo, n, m, one, b, ldb, z, ldz, -one,
202 $ work, n )
203*
204 result( 1 ) = ( slange( '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 ssymm( 'Left', uplo, n, m, one, b, ldb, z, ldz, zero,
212 $ work, n )
213 DO 20 i = 1, m
214 CALL sscal( n, d( i ), z( 1, i ), 1 )
215 20 CONTINUE
216 CALL ssymm( 'Left', uplo, n, m, one, a, lda, work, n, -one, z,
217 $ ldz )
218*
219 result( 1 ) = ( slange( '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 ssymm( 'Left', uplo, n, m, one, a, lda, z, ldz, zero,
227 $ work, n )
228 DO 30 i = 1, m
229 CALL sscal( n, d( i ), z( 1, i ), 1 )
230 30 CONTINUE
231 CALL ssymm( 'Left', uplo, n, m, one, b, ldb, work, n, -one, z,
232 $ ldz )
233*
234 result( 1 ) = ( slange( '1', n, m, z, ldz, work ) / anorm ) /
235 $ ( n*ulp )
236 END IF
237*
238 RETURN
239*
240* End of SSGT01
241*

◆ sslect()

logical function sslect ( real zr,
real zi )

SSLECT

Purpose:
!>
!> SSLECT returns .TRUE. if the eigenvalue ZR+sqrt(-1)*ZI is to be
!> selected, and otherwise it returns .FALSE.
!> It is used by SCHK41 to test if SGEES successfully sorts eigenvalues,
!> and by SCHK43 to test if SGEESX successfully sorts eigenvalues.
!>
!> The common block /SSLCT/ controls how eigenvalues are selected.
!> If SELOPT = 0, then SSLECT return .TRUE. when ZR is less than zero,
!> and .FALSE. otherwise.
!> If SELOPT is at least 1, SSLECT returns SELVAL(SELOPT) and adds 1
!> to SELOPT, cycling back to 1 at SELMAX.
!>
Parameters
[in]ZR
!>          ZR is REAL
!>          The real part of a complex eigenvalue ZR + i*ZI.
!>
[in]ZI
!>          ZI is REAL
!>          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 sslect.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 REAL ZI, ZR
69* ..
70*
71* =====================================================================
72*
73* .. Arrays in Common ..
74 LOGICAL SELVAL( 20 )
75 REAL 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 REAL RMIN, X
86* ..
87* .. Parameters ..
88 REAL ZERO
89 parameter( zero = 0.0e0 )
90* ..
91* .. External Functions ..
92 REAL SLAPY2
93 EXTERNAL slapy2
94* ..
95* .. Executable Statements ..
96*
97 IF( selopt.EQ.0 ) THEN
98 sslect = ( zr.LT.zero )
99 ELSE
100 rmin = slapy2( zr-selwr( 1 ), zi-selwi( 1 ) )
101 sslect = selval( 1 )
102 DO 10 i = 2, seldim
103 x = slapy2( zr-selwr( i ), zi-selwi( i ) )
104 IF( x.LE.rmin ) THEN
105 rmin = x
106 sslect = selval( i )
107 END IF
108 10 CONTINUE
109 END IF
110 RETURN
111*
112* End of SSLECT
113*

◆ sspt21()

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

SSPT21

Purpose:
!>
!> SSPT21  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, SSPT21 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 REAL 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 REAL array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>
[in]E
!>          E is REAL array, dimension (N-1)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix.
!>          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
!>          (3,2) element, etc.
!>          Not referenced if KBAND=0.
!>
[in]U
!>          U is REAL 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 REAL array, dimension (N*(N+1)/2)
!>          If ITYPE=2 or 3, the columns of this array contain the
!>          Householder vectors used to describe the 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 REAL 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 REAL array, dimension (N**2+N)
!>          Workspace.
!>
[out]RESULT
!>          RESULT is REAL array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.  RESULT(2) is modified only
!>          if ITYPE=1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 219 of file sspt21.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 REAL AP( * ), D( * ), E( * ), RESULT( 2 ), TAU( * ),
232 $ U( LDU, * ), VP( * ), WORK( * )
233* ..
234*
235* =====================================================================
236*
237* .. Parameters ..
238 REAL ZERO, ONE, TEN
239 parameter( zero = 0.0e0, one = 1.0e0, ten = 10.0e0 )
240 REAL HALF
241 parameter( half = 1.0e+0 / 2.0e+0 )
242* ..
243* .. Local Scalars ..
244 LOGICAL LOWER
245 CHARACTER CUPLO
246 INTEGER IINFO, J, JP, JP1, JR, LAP
247 REAL ANORM, TEMP, ULP, UNFL, VSAVE, WNORM
248* ..
249* .. External Functions ..
250 LOGICAL LSAME
251 REAL SDOT, SLAMCH, SLANGE, SLANSP
252 EXTERNAL lsame, sdot, slamch, slange, slansp
253* ..
254* .. External Subroutines ..
255 EXTERNAL saxpy, scopy, sgemm, slacpy, slaset, sopmtr,
256 $ sspmv, sspr, sspr2
257* ..
258* .. Intrinsic Functions ..
259 INTRINSIC max, min, real
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 = slamch( 'Safe minimum' )
282 ulp = slamch( 'Epsilon' )*slamch( '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( slansp( '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 slaset( 'Full', n, n, zero, zero, work, n )
308 CALL scopy( lap, ap, 1, work, 1 )
309*
310 DO 10 j = 1, n
311 CALL sspr( 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 sspr2( cuplo, n, -e( j ), u( 1, j ), 1, u( 1, j+1 ),
317 $ 1, work )
318 20 CONTINUE
319 END IF
320 wnorm = slansp( '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 slaset( '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 sspmv( 'L', n-j, one, work( jp1+j+1 ),
344 $ vp( jp+j+1 ), 1, zero, work( lap+1 ), 1 )
345 temp = -half*tau( j )*sdot( n-j, work( lap+1 ), 1,
346 $ vp( jp+j+1 ), 1 )
347 CALL saxpy( n-j, temp, vp( jp+j+1 ), 1, work( lap+1 ),
348 $ 1 )
349 CALL sspr2( '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 sspmv( 'U', j, one, work, vp( jp1+1 ), 1, zero,
371 $ work( lap+1 ), 1 )
372 temp = -half*tau( j )*sdot( j, work( lap+1 ), 1,
373 $ vp( jp1+1 ), 1 )
374 CALL saxpy( j, temp, vp( jp1+1 ), 1, work( lap+1 ),
375 $ 1 )
376 CALL sspr2( '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 = slansp( '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 slacpy( ' ', n, n, u, ldu, work, n )
396 CALL sopmtr( '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 = slange( '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, real( 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 sgemm( '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( slange( '1', n, n, work, n,
433 $ work( n**2+1 ) ), real( n ) ) / ( n*ulp )
434 END IF
435*
436 RETURN
437*
438* End of SSPT21
439*

◆ sstech()

subroutine sstech ( integer n,
real, dimension( * ) a,
real, dimension( * ) b,
real, dimension( * ) eig,
real tol,
real, dimension( * ) work,
integer info )

SSTECH

Purpose:
!>
!>    Let T be the tridiagonal matrix with diagonal entries A(1) ,...,
!>    A(N) and offdiagonal entries B(1) ,..., B(N-1)).  SSTECH 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
!>    SSTECT).  Here EPS = TOL*MACHEPS*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 REAL array, dimension (N)
!>          The diagonal entries of the tridiagonal matrix T.
!>
[in]B
!>          B is REAL array, dimension (N-1)
!>          The offdiagonal entries of the tridiagonal matrix T.
!>
[in]EIG
!>          EIG is REAL array, dimension (N)
!>          The purported eigenvalues to be checked.
!>
[in]TOL
!>          TOL is REAL
!>          Error tolerance for checking, a multiple of the
!>          machine precision.
!>
[out]WORK
!>          WORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          0  if the eigenvalues are all correct (to within
!>             1 +- TOL*MACHEPS*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 sstech.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 REAL TOL
109* ..
110* .. Array Arguments ..
111 REAL A( * ), B( * ), EIG( * ), WORK( * )
112* ..
113*
114* =====================================================================
115*
116* .. Parameters ..
117 REAL ZERO
118 parameter( zero = 0.0e0 )
119* ..
120* .. Local Scalars ..
121 INTEGER BPNT, COUNT, I, ISUB, J, NUML, NUMU, TPNT
122 REAL EMIN, EPS, LOWER, MX, TUPPR, UNFLEP, UPPER
123* ..
124* .. External Functions ..
125 REAL SLAMCH
126 EXTERNAL slamch
127* ..
128* .. External Subroutines ..
129 EXTERNAL sstect
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 = slamch( 'Epsilon' )*slamch( 'Base' )
153 unflep = slamch( '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 sstect( n, a, b, lower, numl )
215 CALL sstect( 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 SSTECH
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
sstect
subroutine sstect(n, a, b, shift, num)
SSTECT
Definition sstect.f:82

◆ sstect()

subroutine sstect ( integer n,
real, dimension( * ) a,
real, dimension( * ) b,
real shift,
integer num )

SSTECT

Purpose:
!>
!>    SSTECT 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 REAL array, dimension (N)
!>          The diagonal entries of the tridiagonal matrix T.
!>
[in]B
!>          B is REAL array, dimension (N-1)
!>          The offdiagonal entries of the tridiagonal matrix T.
!>
[in]SHIFT
!>          SHIFT is REAL
!>          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 sstect.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 REAL SHIFT
90* ..
91* .. Array Arguments ..
92 REAL A( * ), B( * )
93* ..
94*
95* =====================================================================
96*
97* .. Parameters ..
98 REAL ZERO, ONE, THREE
99 parameter( zero = 0.0e0, one = 1.0e0, three = 3.0e0 )
100* ..
101* .. Local Scalars ..
102 INTEGER I
103 REAL M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
104 $ TOM, U, UNFL
105* ..
106* .. External Functions ..
107 REAL SLAMCH
108 EXTERNAL slamch
109* ..
110* .. Intrinsic Functions ..
111 INTRINSIC abs, max, sqrt
112* ..
113* .. Executable Statements ..
114*
115* Get machine constants
116*
117 unfl = slamch( 'Safe minimum' )
118 ovfl = slamch( '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 SSTECT
183*

◆ sstt21()

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

SSTT21

Purpose:
!>
!> SSTT21 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, SSTT21 does nothing.
!>          It must be at least zero.
!>
[in]KBAND
!>          KBAND is INTEGER
!>          The bandwidth of the matrix S.  It may only be zero or one.
!>          If zero, then S is diagonal, and SE is not referenced.  If
!>          one, then S is symmetric tri-diagonal.
!>
[in]AD
!>          AD is REAL array, dimension (N)
!>          The diagonal of the original (unfactored) matrix A.  A is
!>          assumed to be symmetric tridiagonal.
!>
[in]AE
!>          AE is REAL array, dimension (N-1)
!>          The off-diagonal of the original (unfactored) matrix A.  A
!>          is assumed to be symmetric tridiagonal.  AE(1) is the (1,2)
!>          and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.
!>
[in]SD
!>          SD is REAL array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix S.
!>
[in]SE
!>          SE is REAL array, dimension (N-1)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix S.
!>          Not referenced if KBSND=0.  If KBAND=1, then AE(1) is the
!>          (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)
!>          element, etc.
!>
[in]U
!>          U is REAL 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 REAL array, dimension (N*(N+1))
!>
[out]RESULT
!>          RESULT is REAL array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 125 of file sstt21.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 REAL AD( * ), AE( * ), RESULT( 2 ), SD( * ),
137 $ SE( * ), U( LDU, * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e0, one = 1.0e0 )
145* ..
146* .. Local Scalars ..
147 INTEGER J
148 REAL ANORM, TEMP1, TEMP2, ULP, UNFL, WNORM
149* ..
150* .. External Functions ..
151 REAL SLAMCH, SLANGE, SLANSY
152 EXTERNAL slamch, slange, slansy
153* ..
154* .. External Subroutines ..
155 EXTERNAL sgemm, slaset, ssyr, ssyr2
156* ..
157* .. Intrinsic Functions ..
158 INTRINSIC abs, max, min, real
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 = slamch( 'Safe minimum' )
170 ulp = slamch( 'Precision' )
171*
172* Do Test 1
173*
174* Copy A & Compute its 1-Norm:
175*
176 CALL slaset( '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 ssyr( '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 ssyr2( '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 = slansy( '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, real( n ) ) / ( n*ulp )
214 END IF
215 END IF
216*
217* Do Test 2
218*
219* Compute UU' - I
220*
221 CALL sgemm( '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( real( n ), slange( '1', n, n, work, n,
229 $ work( n**2+1 ) ) ) / ( n*ulp )
230*
231 RETURN
232*
233* End of SSTT21
234*
ssyr
subroutine ssyr(uplo, n, alpha, x, incx, a, lda)
SSYR
Definition ssyr.f:132

◆ sstt22()

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

SSTT22

Purpose:
!>
!> SSTT22  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, SSTT22 does nothing.
!>          It must be at least zero.
!>
[in]M
!>          M is INTEGER
!>          The number of eigenpairs to check.  If it is zero, SSTT22
!>          does nothing.  It must be at least zero.
!>
[in]KBAND
!>          KBAND is INTEGER
!>          The bandwidth of the matrix S.  It may only be zero or one.
!>          If zero, then S is diagonal, and SE is not referenced.  If
!>          one, then S is symmetric tri-diagonal.
!>
[in]AD
!>          AD is REAL array, dimension (N)
!>          The diagonal of the original (unfactored) matrix A.  A is
!>          assumed to be symmetric tridiagonal.
!>
[in]AE
!>          AE is REAL 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 REAL array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix S.
!>
[in]SE
!>          SE is REAL 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 REAL 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 REAL 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 REAL array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 137 of file sstt22.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 REAL AD( * ), AE( * ), RESULT( 2 ), SD( * ),
149 $ SE( * ), U( LDU, * ), WORK( LDWORK, * )
150* ..
151*
152* =====================================================================
153*
154* .. Parameters ..
155 REAL ZERO, ONE
156 parameter( zero = 0.0e0, one = 1.0e0 )
157* ..
158* .. Local Scalars ..
159 INTEGER I, J, K
160 REAL ANORM, AUKJ, ULP, UNFL, WNORM
161* ..
162* .. External Functions ..
163 REAL SLAMCH, SLANGE, SLANSY
164 EXTERNAL slamch, slange, slansy
165* ..
166* .. External Subroutines ..
167 EXTERNAL sgemm
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, max, min, real
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 = slamch( 'Safe minimum' )
180 ulp = slamch( '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 = slansy( '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, real( m ) ) / ( m*ulp )
230 END IF
231 END IF
232*
233* Do Test 2
234*
235* Compute U'U - I
236*
237 CALL sgemm( '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( real( m ), slange( '1', m, m, work, m, work( 1,
245 $ m+1 ) ) ) / ( m*ulp )
246*
247 RETURN
248*
249* End of SSTT22
250*

◆ ssvdch()

subroutine ssvdch ( integer n,
real, dimension( * ) s,
real, dimension( * ) e,
real, dimension( * ) svd,
real tol,
integer info )

SSVDCH

Purpose:
!>
!> SSVDCH 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
!> SSVDCT). Here EPS=TOL*MAX(N/10,1)*MACHEP, 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 REAL array, dimension (N)
!>          The diagonal entries of the bidiagonal matrix B.
!>
[in]E
!>          E is REAL array, dimension (N-1)
!>          The superdiagonal entries of the bidiagonal matrix B.
!>
[in]SVD
!>          SVD is REAL array, dimension (N)
!>          The computed singular values to be checked.
!>
[in]TOL
!>          TOL is REAL
!>          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*MACHEPS)
!>          >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 ssvdch.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 REAL TOL
105* ..
106* .. Array Arguments ..
107 REAL E( * ), S( * ), SVD( * )
108* ..
109*
110* =====================================================================
111*
112* .. Parameters ..
113 REAL ONE
114 parameter( one = 1.0e0 )
115 REAL ZERO
116 parameter( zero = 0.0e0 )
117* ..
118* .. Local Scalars ..
119 INTEGER BPNT, COUNT, NUML, NUMU, TPNT
120 REAL EPS, LOWER, OVFL, TUPPR, UNFL, UNFLEP, UPPER
121* ..
122* .. External Functions ..
123 REAL SLAMCH
124 EXTERNAL slamch
125* ..
126* .. External Subroutines ..
127 EXTERNAL ssvdct
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 = slamch( 'Safe minimum' )
140 ovfl = slamch( 'Overflow' )
141 eps = slamch( 'Epsilon' )*slamch( '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 SSVDCT, it exceeds
145* sqrt(UNFL), which is the lower limit for SSVDCT.
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 ssvdct( n, s, e, lower, numl )
189 CALL ssvdct( 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 SSVDCH
208*
ssvdct
subroutine ssvdct(n, s, e, shift, num)
SSVDCT
Definition ssvdct.f:87

◆ ssvdct()

subroutine ssvdct ( integer n,
real, dimension( * ) s,
real, dimension( * ) e,
real shift,
integer num )

SSVDCT

Purpose:
!>
!> SSVDCT 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 REAL array, dimension (N)
!>          The diagonal entries of the bidiagonal matrix B.
!>
[in]E
!>          E is REAL array of dimension (N-1)
!>          The superdiagonal entries of the bidiagonal matrix B.
!>
[in]SHIFT
!>          SHIFT is REAL
!>          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 ssvdct.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 REAL SHIFT
95* ..
96* .. Array Arguments ..
97 REAL E( * ), S( * )
98* ..
99*
100* =====================================================================
101*
102* .. Parameters ..
103 REAL ONE
104 parameter( one = 1.0e0 )
105 REAL ZERO
106 parameter( zero = 0.0e0 )
107* ..
108* .. Local Scalars ..
109 INTEGER I
110 REAL M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
111 $ TOM, U, UNFL
112* ..
113* .. External Functions ..
114 REAL SLAMCH
115 EXTERNAL slamch
116* ..
117* .. Intrinsic Functions ..
118 INTRINSIC abs, max, sqrt
119* ..
120* .. Executable Statements ..
121*
122* Get machine constants
123*
124 unfl = 2*slamch( '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 SSVDCT
210*

◆ ssxt1()

real function ssxt1 ( integer ijob,
real, dimension( * ) d1,
integer n1,
real, dimension( * ) d2,
integer n2,
real abstol,
real ulp,
real unfl )

SSXT1

Purpose:
!>
!> SSXT1  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 REAL 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 REAL 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 REAL
!>          The absolute tolerance, used as a measure of the error.
!>
[in]ULP
!>          ULP is REAL
!>          Machine precision.
!>
[in]UNFL
!>          UNFL is REAL
!>          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 ssxt1.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 REAL ABSTOL, ULP, UNFL
114* ..
115* .. Array Arguments ..
116 REAL D1( * ), D2( * )
117* ..
118*
119* =====================================================================
120*
121* .. Parameters ..
122 REAL ZERO
123 parameter( zero = 0.0e0 )
124* ..
125* .. Local Scalars ..
126 INTEGER I, J
127 REAL 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 ssxt1 = temp1
157 RETURN
158*
159* End of SSXT1
160*

◆ ssyt21()

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

SSYT21

Purpose:
!>
!> SSYT21 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, SSYT21 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 REAL 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 REAL array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>
[in]E
!>          E is REAL array, dimension (N-1)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix.
!>          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
!>          (3,2) element, etc.
!>          Not referenced if KBAND=0.
!>
[in]U
!>          U is REAL 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 REAL 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 REAL 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 REAL array, dimension (2*N**2)
!>
[out]RESULT
!>          RESULT is REAL array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.  RESULT(2) is modified only
!>          if ITYPE=1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 205 of file ssyt21.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 REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
218 $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
219* ..
220*
221* =====================================================================
222*
223* .. Parameters ..
224 REAL ZERO, ONE, TEN
225 parameter( zero = 0.0e0, one = 1.0e0, ten = 10.0e0 )
226* ..
227* .. Local Scalars ..
228 LOGICAL LOWER
229 CHARACTER CUPLO
230 INTEGER IINFO, J, JCOL, JR, JROW
231 REAL ANORM, ULP, UNFL, VSAVE, WNORM
232* ..
233* .. External Functions ..
234 LOGICAL LSAME
235 REAL SLAMCH, SLANGE, SLANSY
236 EXTERNAL lsame, slamch, slange, slansy
237* ..
238* .. External Subroutines ..
239 EXTERNAL sgemm, slacpy, slarfy, slaset, sorm2l, sorm2r,
240 $ ssyr, ssyr2
241* ..
242* .. Intrinsic Functions ..
243 INTRINSIC max, min, real
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 = slamch( 'Safe minimum' )
262 ulp = slamch( 'Epsilon' )*slamch( '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( slansy( '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 slaset( 'Full', n, n, zero, zero, work, n )
288 CALL slacpy( cuplo, n, n, a, lda, work, n )
289*
290 DO 10 j = 1, n
291 CALL ssyr( 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 ssyr2( cuplo, n, -e( j ), u( 1, j ), 1, u( 1, j+1 ),
297 $ 1, work, n )
298 20 CONTINUE
299 END IF
300 wnorm = slansy( '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 slaset( '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 slarfy( '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 slarfy( '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 = slansy( '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 slacpy( ' ', n, n, u, ldu, work, n )
366 IF( lower ) THEN
367 CALL sorm2r( '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 sorm2l( '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 = slange( '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, real( 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 sgemm( '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( slange( '1', n, n, work, n,
408 $ work( n**2+1 ) ), real( n ) ) / ( n*ulp )
409 END IF
410*
411 RETURN
412*
413* End of SSYT21
414*
slarfy
subroutine slarfy(uplo, n, v, incv, tau, c, ldc, work)
SLARFY
Definition slarfy.f:108
sorm2l
subroutine sorm2l(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
SORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sge...
Definition sorm2l.f:159

◆ ssyt22()

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

SSYT22

Purpose:
!>
!>      SSYT22  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, SSYT22 does nothing.
!>          It must be at least zero.
!>          Not modified.
!>
!>  M       INTEGER
!>          The number of columns of U.  If it is zero, SSYT22 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       REAL array, dimension (LDA , N)
!>          The original (unfactored) matrix.  It is assumed to be
!>          symmetric, and only the upper (UPLO='U') or only the lower
!>          (UPLO='L') will be referenced.
!>          Not modified.
!>
!>  LDA     INTEGER
!>          The leading dimension of A.  It must be at least 1
!>          and at least N.
!>          Not modified.
!>
!>  D       REAL array, dimension (N)
!>          The diagonal of the (symmetric tri-) diagonal matrix.
!>          Not modified.
!>
!>  E       REAL array, dimension (N)
!>          The off-diagonal of the (symmetric tri-) diagonal matrix.
!>          E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc.
!>          Not referenced if KBAND=0.
!>          Not modified.
!>
!>  U       REAL 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       REAL 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     REAL 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    REAL array, dimension (2*N**2)
!>          Workspace.
!>          Modified.
!>
!>  RESULT  REAL array, dimension (2)
!>          The values computed by the two tests described above.  The
!>          values are currently limited to 1/ulp, to avoid overflow.
!>          RESULT(1) is always modified.  RESULT(2) is modified only
!>          if LDU is at least N.
!>          Modified.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 155 of file ssyt22.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 REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
168 $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ZERO, ONE
175 parameter( zero = 0.0e0, one = 1.0e0 )
176* ..
177* .. Local Scalars ..
178 INTEGER J, JJ, JJ1, JJ2, NN, NNP1
179 REAL ANORM, ULP, UNFL, WNORM
180* ..
181* .. External Functions ..
182 REAL SLAMCH, SLANSY
183 EXTERNAL slamch, slansy
184* ..
185* .. External Subroutines ..
186 EXTERNAL sgemm, ssymm
187* ..
188* .. Intrinsic Functions ..
189 INTRINSIC max, min, real
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 = slamch( 'Safe minimum' )
199 ulp = slamch( 'Precision' )
200*
201* Do Test 1
202*
203* Norm of A:
204*
205 anorm = max( slansy( '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 ssymm( 'L', uplo, n, m, one, a, lda, u, ldu, zero, work, n )
212 nn = n*n
213 nnp1 = nn + 1
214 CALL sgemm( '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 = slansy( '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, real( 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 sort01( 'Columns', n, m, u, ldu, work, 2*n*n,
246 $ result( 2 ) )
247*
248 RETURN
249*
250* End of SSYT22
251*