LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
sdrvsg.f
Go to the documentation of this file.
1 *> \brief \b SDRVSG
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE SDRVSG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
12 * NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP,
13 * BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO )
14 *
15 * .. Scalar Arguments ..
16 * INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES,
17 * $ NTYPES, NWORK
18 * REAL THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER ISEED( 4 ), IWORK( * ), NN( * )
23 * REAL A( LDA, * ), AB( LDA, * ), AP( * ),
24 * $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ),
25 * $ RESULT( * ), WORK( * ), Z( LDZ, * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> SDRVSG checks the real symmetric generalized eigenproblem
35 *> drivers.
36 *>
37 *> SSYGV computes all eigenvalues and, optionally,
38 *> eigenvectors of a real symmetric-definite generalized
39 *> eigenproblem.
40 *>
41 *> SSYGVD computes all eigenvalues and, optionally,
42 *> eigenvectors of a real symmetric-definite generalized
43 *> eigenproblem using a divide and conquer algorithm.
44 *>
45 *> SSYGVX computes selected eigenvalues and, optionally,
46 *> eigenvectors of a real symmetric-definite generalized
47 *> eigenproblem.
48 *>
49 *> SSPGV computes all eigenvalues and, optionally,
50 *> eigenvectors of a real symmetric-definite generalized
51 *> eigenproblem in packed storage.
52 *>
53 *> SSPGVD computes all eigenvalues and, optionally,
54 *> eigenvectors of a real symmetric-definite generalized
55 *> eigenproblem in packed storage using a divide and
56 *> conquer algorithm.
57 *>
58 *> SSPGVX computes selected eigenvalues and, optionally,
59 *> eigenvectors of a real symmetric-definite generalized
60 *> eigenproblem in packed storage.
61 *>
62 *> SSBGV computes all eigenvalues and, optionally,
63 *> eigenvectors of a real symmetric-definite banded
64 *> generalized eigenproblem.
65 *>
66 *> SSBGVD computes all eigenvalues and, optionally,
67 *> eigenvectors of a real symmetric-definite banded
68 *> generalized eigenproblem using a divide and conquer
69 *> algorithm.
70 *>
71 *> SSBGVX computes selected eigenvalues and, optionally,
72 *> eigenvectors of a real symmetric-definite banded
73 *> generalized eigenproblem.
74 *>
75 *> When SDRVSG is called, a number of matrix "sizes" ("n's") and a
76 *> number of matrix "types" are specified. For each size ("n")
77 *> and each type of matrix, one matrix A of the given type will be
78 *> generated; a random well-conditioned matrix B is also generated
79 *> and the pair (A,B) is used to test the drivers.
80 *>
81 *> For each pair (A,B), the following tests are performed:
82 *>
83 *> (1) SSYGV with ITYPE = 1 and UPLO ='U':
84 *>
85 *> | A Z - B Z D | / ( |A| |Z| n ulp )
86 *>
87 *> (2) as (1) but calling SSPGV
88 *> (3) as (1) but calling SSBGV
89 *> (4) as (1) but with UPLO = 'L'
90 *> (5) as (4) but calling SSPGV
91 *> (6) as (4) but calling SSBGV
92 *>
93 *> (7) SSYGV with ITYPE = 2 and UPLO ='U':
94 *>
95 *> | A B Z - Z D | / ( |A| |Z| n ulp )
96 *>
97 *> (8) as (7) but calling SSPGV
98 *> (9) as (7) but with UPLO = 'L'
99 *> (10) as (9) but calling SSPGV
100 *>
101 *> (11) SSYGV with ITYPE = 3 and UPLO ='U':
102 *>
103 *> | B A Z - Z D | / ( |A| |Z| n ulp )
104 *>
105 *> (12) as (11) but calling SSPGV
106 *> (13) as (11) but with UPLO = 'L'
107 *> (14) as (13) but calling SSPGV
108 *>
109 *> SSYGVD, SSPGVD and SSBGVD performed the same 14 tests.
110 *>
111 *> SSYGVX, SSPGVX and SSBGVX performed the above 14 tests with
112 *> the parameter RANGE = 'A', 'N' and 'I', respectively.
113 *>
114 *> The "sizes" are specified by an array NN(1:NSIZES); the value
115 *> of each element NN(j) specifies one size.
116 *> The "types" are specified by a logical array DOTYPE( 1:NTYPES );
117 *> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
118 *> This type is used for the matrix A which has half-bandwidth KA.
119 *> B is generated as a well-conditioned positive definite matrix
120 *> with half-bandwidth KB (<= KA).
121 *> Currently, the list of possible types for A is:
122 *>
123 *> (1) The zero matrix.
124 *> (2) The identity matrix.
125 *>
126 *> (3) A diagonal matrix with evenly spaced entries
127 *> 1, ..., ULP and random signs.
128 *> (ULP = (first number larger than 1) - 1 )
129 *> (4) A diagonal matrix with geometrically spaced entries
130 *> 1, ..., ULP and random signs.
131 *> (5) A diagonal matrix with "clustered" entries
132 *> 1, ULP, ..., ULP and random signs.
133 *>
134 *> (6) Same as (4), but multiplied by SQRT( overflow threshold )
135 *> (7) Same as (4), but multiplied by SQRT( underflow threshold )
136 *>
137 *> (8) A matrix of the form U* D U, where U is orthogonal and
138 *> D has evenly spaced entries 1, ..., ULP with random signs
139 *> on the diagonal.
140 *>
141 *> (9) A matrix of the form U* D U, where U is orthogonal and
142 *> D has geometrically spaced entries 1, ..., ULP with random
143 *> signs on the diagonal.
144 *>
145 *> (10) A matrix of the form U* D U, where U is orthogonal and
146 *> D has "clustered" entries 1, ULP,..., ULP with random
147 *> signs on the diagonal.
148 *>
149 *> (11) Same as (8), but multiplied by SQRT( overflow threshold )
150 *> (12) Same as (8), but multiplied by SQRT( underflow threshold )
151 *>
152 *> (13) symmetric matrix with random entries chosen from (-1,1).
153 *> (14) Same as (13), but multiplied by SQRT( overflow threshold )
154 *> (15) Same as (13), but multiplied by SQRT( underflow threshold)
155 *>
156 *> (16) Same as (8), but with KA = 1 and KB = 1
157 *> (17) Same as (8), but with KA = 2 and KB = 1
158 *> (18) Same as (8), but with KA = 2 and KB = 2
159 *> (19) Same as (8), but with KA = 3 and KB = 1
160 *> (20) Same as (8), but with KA = 3 and KB = 2
161 *> (21) Same as (8), but with KA = 3 and KB = 3
162 *> \endverbatim
163 *
164 * Arguments:
165 * ==========
166 *
167 *> \verbatim
168 *> NSIZES INTEGER
169 *> The number of sizes of matrices to use. If it is zero,
170 *> SDRVSG does nothing. It must be at least zero.
171 *> Not modified.
172 *>
173 *> NN INTEGER array, dimension (NSIZES)
174 *> An array containing the sizes to be used for the matrices.
175 *> Zero values will be skipped. The values must be at least
176 *> zero.
177 *> Not modified.
178 *>
179 *> NTYPES INTEGER
180 *> The number of elements in DOTYPE. If it is zero, SDRVSG
181 *> does nothing. It must be at least zero. If it is MAXTYP+1
182 *> and NSIZES is 1, then an additional type, MAXTYP+1 is
183 *> defined, which is to use whatever matrix is in A. This
184 *> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
185 *> DOTYPE(MAXTYP+1) is .TRUE. .
186 *> Not modified.
187 *>
188 *> DOTYPE LOGICAL array, dimension (NTYPES)
189 *> If DOTYPE(j) is .TRUE., then for each size in NN a
190 *> matrix of that size and of type j will be generated.
191 *> If NTYPES is smaller than the maximum number of types
192 *> defined (PARAMETER MAXTYP), then types NTYPES+1 through
193 *> MAXTYP will not be generated. If NTYPES is larger
194 *> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
195 *> will be ignored.
196 *> Not modified.
197 *>
198 *> ISEED INTEGER array, dimension (4)
199 *> On entry ISEED specifies the seed of the random number
200 *> generator. The array elements should be between 0 and 4095;
201 *> if not they will be reduced mod 4096. Also, ISEED(4) must
202 *> be odd. The random number generator uses a linear
203 *> congruential sequence limited to small integers, and so
204 *> should produce machine independent random numbers. The
205 *> values of ISEED are changed on exit, and can be used in the
206 *> next call to SDRVSG to continue the same random number
207 *> sequence.
208 *> Modified.
209 *>
210 *> THRESH REAL
211 *> A test will count as "failed" if the "error", computed as
212 *> described above, exceeds THRESH. Note that the error
213 *> is scaled to be O(1), so THRESH should be a reasonably
214 *> small multiple of 1, e.g., 10 or 100. In particular,
215 *> it should not depend on the precision (single vs. double)
216 *> or the size of the matrix. It must be at least zero.
217 *> Not modified.
218 *>
219 *> NOUNIT INTEGER
220 *> The FORTRAN unit number for printing out error messages
221 *> (e.g., if a routine returns IINFO not equal to 0.)
222 *> Not modified.
223 *>
224 *> A REAL array, dimension (LDA , max(NN))
225 *> Used to hold the matrix whose eigenvalues are to be
226 *> computed. On exit, A contains the last matrix actually
227 *> used.
228 *> Modified.
229 *>
230 *> LDA INTEGER
231 *> The leading dimension of A and AB. It must be at
232 *> least 1 and at least max( NN ).
233 *> Not modified.
234 *>
235 *> B REAL array, dimension (LDB , max(NN))
236 *> Used to hold the symmetric positive definite matrix for
237 *> the generailzed problem.
238 *> On exit, B contains the last matrix actually
239 *> used.
240 *> Modified.
241 *>
242 *> LDB INTEGER
243 *> The leading dimension of B and BB. It must be at
244 *> least 1 and at least max( NN ).
245 *> Not modified.
246 *>
247 *> D REAL array, dimension (max(NN))
248 *> The eigenvalues of A. On exit, the eigenvalues in D
249 *> correspond with the matrix in A.
250 *> Modified.
251 *>
252 *> Z REAL array, dimension (LDZ, max(NN))
253 *> The matrix of eigenvectors.
254 *> Modified.
255 *>
256 *> LDZ INTEGER
257 *> The leading dimension of Z. It must be at least 1 and
258 *> at least max( NN ).
259 *> Not modified.
260 *>
261 *> AB REAL array, dimension (LDA, max(NN))
262 *> Workspace.
263 *> Modified.
264 *>
265 *> BB REAL array, dimension (LDB, max(NN))
266 *> Workspace.
267 *> Modified.
268 *>
269 *> AP REAL array, dimension (max(NN)**2)
270 *> Workspace.
271 *> Modified.
272 *>
273 *> BP REAL array, dimension (max(NN)**2)
274 *> Workspace.
275 *> Modified.
276 *>
277 *> WORK REAL array, dimension (NWORK)
278 *> Workspace.
279 *> Modified.
280 *>
281 *> NWORK INTEGER
282 *> The number of entries in WORK. This must be at least
283 *> 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and
284 *> lg( N ) = smallest integer k such that 2**k >= N.
285 *> Not modified.
286 *>
287 *> IWORK INTEGER array, dimension (LIWORK)
288 *> Workspace.
289 *> Modified.
290 *>
291 *> LIWORK INTEGER
292 *> The number of entries in WORK. This must be at least 6*N.
293 *> Not modified.
294 *>
295 *> RESULT REAL array, dimension (70)
296 *> The values computed by the 70 tests described above.
297 *> Modified.
298 *>
299 *> INFO INTEGER
300 *> If 0, then everything ran OK.
301 *> -1: NSIZES < 0
302 *> -2: Some NN(j) < 0
303 *> -3: NTYPES < 0
304 *> -5: THRESH < 0
305 *> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
306 *> -16: LDZ < 1 or LDZ < NMAX.
307 *> -21: NWORK too small.
308 *> -23: LIWORK too small.
309 *> If SLATMR, SLATMS, SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD,
310 *> SSBGVD, SSYGVX, SSPGVX or SSBGVX returns an error code,
311 *> the absolute value of it is returned.
312 *> Modified.
313 *>
314 *> ----------------------------------------------------------------------
315 *>
316 *> Some Local Variables and Parameters:
317 *> ---- ----- --------- --- ----------
318 *> ZERO, ONE Real 0 and 1.
319 *> MAXTYP The number of types defined.
320 *> NTEST The number of tests that have been run
321 *> on this matrix.
322 *> NTESTT The total number of tests for this call.
323 *> NMAX Largest value in NN.
324 *> NMATS The number of matrices generated so far.
325 *> NERRS The number of tests which have exceeded THRESH
326 *> so far (computed by SLAFTS).
327 *> COND, IMODE Values to be passed to the matrix generators.
328 *> ANORM Norm of A; passed to matrix generators.
329 *>
330 *> OVFL, UNFL Overflow and underflow thresholds.
331 *> ULP, ULPINV Finest relative precision and its inverse.
332 *> RTOVFL, RTUNFL Square roots of the previous 2 values.
333 *> The following four arrays decode JTYPE:
334 *> KTYPE(j) The general type (1-10) for type "j".
335 *> KMODE(j) The MODE value to be passed to the matrix
336 *> generator for type "j".
337 *> KMAGN(j) The order of magnitude ( O(1),
338 *> O(overflow^(1/2) ), O(underflow^(1/2) )
339 *> \endverbatim
340 *
341 * Authors:
342 * ========
343 *
344 *> \author Univ. of Tennessee
345 *> \author Univ. of California Berkeley
346 *> \author Univ. of Colorado Denver
347 *> \author NAG Ltd.
348 *
349 *> \date November 2011
350 *
351 *> \ingroup single_eig
352 *
353 * =====================================================================
354  SUBROUTINE sdrvsg( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
355  $ nounit, a, lda, b, ldb, d, z, ldz, ab, bb, ap,
356  $ bp, work, nwork, iwork, liwork, result, info )
357 *
358 * -- LAPACK test routine (version 3.4.0) --
359 * -- LAPACK is a software package provided by Univ. of Tennessee, --
360 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
361 * November 2011
362 *
363 * .. Scalar Arguments ..
364  INTEGER info, lda, ldb, ldz, liwork, nounit, nsizes,
365  $ ntypes, nwork
366  REAL thresh
367 * ..
368 * .. Array Arguments ..
369  LOGICAL dotype( * )
370  INTEGER iseed( 4 ), iwork( * ), nn( * )
371  REAL a( lda, * ), ab( lda, * ), ap( * ),
372  $ b( ldb, * ), bb( ldb, * ), bp( * ), d( * ),
373  $ result( * ), work( * ), z( ldz, * )
374 * ..
375 *
376 * =====================================================================
377 *
378 * .. Parameters ..
379  REAL zero, one, ten
380  parameter( zero = 0.0e0, one = 1.0e0, ten = 10.0e0 )
381  INTEGER maxtyp
382  parameter( maxtyp = 21 )
383 * ..
384 * .. Local Scalars ..
385  LOGICAL badnn
386  CHARACTER uplo
387  INTEGER i, ibtype, ibuplo, iinfo, ij, il, imode, itemp,
388  $ itype, iu, j, jcol, jsize, jtype, ka, ka9, kb,
389  $ kb9, m, mtypes, n, nerrs, nmats, nmax, ntest,
390  $ ntestt
391  REAL abstol, aninv, anorm, cond, ovfl, rtovfl,
392  $ rtunfl, ulp, ulpinv, unfl, vl, vu
393 * ..
394 * .. Local Arrays ..
395  INTEGER idumma( 1 ), ioldsd( 4 ), iseed2( 4 ),
396  $ kmagn( maxtyp ), kmode( maxtyp ),
397  $ ktype( maxtyp )
398 * ..
399 * .. External Functions ..
400  LOGICAL lsame
401  REAL slamch, slarnd
402  EXTERNAL lsame, slamch, slarnd
403 * ..
404 * .. External Subroutines ..
405  EXTERNAL slabad, slacpy, slafts, slaset, slasum, slatmr,
406  $ slatms, ssbgv, ssbgvd, ssbgvx, ssgt01, sspgv,
407  $ sspgvd, sspgvx, ssygv, ssygvd, ssygvx, xerbla
408 * ..
409 * .. Intrinsic Functions ..
410  INTRINSIC abs, max, min, REAL, sqrt
411 * ..
412 * .. Data statements ..
413  DATA ktype / 1, 2, 5*4, 5*5, 3*8, 6*9 /
414  DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
415  $ 2, 3, 6*1 /
416  DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
417  $ 0, 0, 6*4 /
418 * ..
419 * .. Executable Statements ..
420 *
421 * 1) Check for errors
422 *
423  ntestt = 0
424  info = 0
425 *
426  badnn = .false.
427  nmax = 0
428  DO 10 j = 1, nsizes
429  nmax = max( nmax, nn( j ) )
430  IF( nn( j ).LT.0 )
431  $ badnn = .true.
432  10 continue
433 *
434 * Check for errors
435 *
436  IF( nsizes.LT.0 ) THEN
437  info = -1
438  ELSE IF( badnn ) THEN
439  info = -2
440  ELSE IF( ntypes.LT.0 ) THEN
441  info = -3
442  ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
443  info = -9
444  ELSE IF( ldz.LE.1 .OR. ldz.LT.nmax ) THEN
445  info = -16
446  ELSE IF( 2*max( nmax, 3 )**2.GT.nwork ) THEN
447  info = -21
448  ELSE IF( 2*max( nmax, 3 )**2.GT.liwork ) THEN
449  info = -23
450  END IF
451 *
452  IF( info.NE.0 ) THEN
453  CALL xerbla( 'SDRVSG', -info )
454  return
455  END IF
456 *
457 * Quick return if possible
458 *
459  IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
460  $ return
461 *
462 * More Important constants
463 *
464  unfl = slamch( 'Safe minimum' )
465  ovfl = slamch( 'Overflow' )
466  CALL slabad( unfl, ovfl )
467  ulp = slamch( 'Epsilon' )*slamch( 'Base' )
468  ulpinv = one / ulp
469  rtunfl = sqrt( unfl )
470  rtovfl = sqrt( ovfl )
471 *
472  DO 20 i = 1, 4
473  iseed2( i ) = iseed( i )
474  20 continue
475 *
476 * Loop over sizes, types
477 *
478  nerrs = 0
479  nmats = 0
480 *
481  DO 650 jsize = 1, nsizes
482  n = nn( jsize )
483  aninv = one / REAL( MAX( 1, N ) )
484 *
485  IF( nsizes.NE.1 ) THEN
486  mtypes = min( maxtyp, ntypes )
487  ELSE
488  mtypes = min( maxtyp+1, ntypes )
489  END IF
490 *
491  ka9 = 0
492  kb9 = 0
493  DO 640 jtype = 1, mtypes
494  IF( .NOT.dotype( jtype ) )
495  $ go to 640
496  nmats = nmats + 1
497  ntest = 0
498 *
499  DO 30 j = 1, 4
500  ioldsd( j ) = iseed( j )
501  30 continue
502 *
503 * 2) Compute "A"
504 *
505 * Control parameters:
506 *
507 * KMAGN KMODE KTYPE
508 * =1 O(1) clustered 1 zero
509 * =2 large clustered 2 identity
510 * =3 small exponential (none)
511 * =4 arithmetic diagonal, w/ eigenvalues
512 * =5 random log hermitian, w/ eigenvalues
513 * =6 random (none)
514 * =7 random diagonal
515 * =8 random hermitian
516 * =9 banded, w/ eigenvalues
517 *
518  IF( mtypes.GT.maxtyp )
519  $ go to 90
520 *
521  itype = ktype( jtype )
522  imode = kmode( jtype )
523 *
524 * Compute norm
525 *
526  go to( 40, 50, 60 )kmagn( jtype )
527 *
528  40 continue
529  anorm = one
530  go to 70
531 *
532  50 continue
533  anorm = ( rtovfl*ulp )*aninv
534  go to 70
535 *
536  60 continue
537  anorm = rtunfl*n*ulpinv
538  go to 70
539 *
540  70 continue
541 *
542  iinfo = 0
543  cond = ulpinv
544 *
545 * Special Matrices -- Identity & Jordan block
546 *
547  IF( itype.EQ.1 ) THEN
548 *
549 * Zero
550 *
551  ka = 0
552  kb = 0
553  CALL slaset( 'Full', lda, n, zero, zero, a, lda )
554 *
555  ELSE IF( itype.EQ.2 ) THEN
556 *
557 * Identity
558 *
559  ka = 0
560  kb = 0
561  CALL slaset( 'Full', lda, n, zero, zero, a, lda )
562  DO 80 jcol = 1, n
563  a( jcol, jcol ) = anorm
564  80 continue
565 *
566  ELSE IF( itype.EQ.4 ) THEN
567 *
568 * Diagonal Matrix, [Eigen]values Specified
569 *
570  ka = 0
571  kb = 0
572  CALL slatms( n, n, 'S', iseed, 'S', work, imode, cond,
573  $ anorm, 0, 0, 'N', a, lda, work( n+1 ),
574  $ iinfo )
575 *
576  ELSE IF( itype.EQ.5 ) THEN
577 *
578 * symmetric, eigenvalues specified
579 *
580  ka = max( 0, n-1 )
581  kb = ka
582  CALL slatms( n, n, 'S', iseed, 'S', work, imode, cond,
583  $ anorm, n, n, 'N', a, lda, work( n+1 ),
584  $ iinfo )
585 *
586  ELSE IF( itype.EQ.7 ) THEN
587 *
588 * Diagonal, random eigenvalues
589 *
590  ka = 0
591  kb = 0
592  CALL slatmr( n, n, 'S', iseed, 'S', work, 6, one, one,
593  $ 'T', 'N', work( n+1 ), 1, one,
594  $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
595  $ zero, anorm, 'NO', a, lda, iwork, iinfo )
596 *
597  ELSE IF( itype.EQ.8 ) THEN
598 *
599 * symmetric, random eigenvalues
600 *
601  ka = max( 0, n-1 )
602  kb = ka
603  CALL slatmr( n, n, 'S', iseed, 'H', work, 6, one, one,
604  $ 'T', 'N', work( n+1 ), 1, one,
605  $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
606  $ zero, anorm, 'NO', a, lda, iwork, iinfo )
607 *
608  ELSE IF( itype.EQ.9 ) THEN
609 *
610 * symmetric banded, eigenvalues specified
611 *
612 * The following values are used for the half-bandwidths:
613 *
614 * ka = 1 kb = 1
615 * ka = 2 kb = 1
616 * ka = 2 kb = 2
617 * ka = 3 kb = 1
618 * ka = 3 kb = 2
619 * ka = 3 kb = 3
620 *
621  kb9 = kb9 + 1
622  IF( kb9.GT.ka9 ) THEN
623  ka9 = ka9 + 1
624  kb9 = 1
625  END IF
626  ka = max( 0, min( n-1, ka9 ) )
627  kb = max( 0, min( n-1, kb9 ) )
628  CALL slatms( n, n, 'S', iseed, 'S', work, imode, cond,
629  $ anorm, ka, ka, 'N', a, lda, work( n+1 ),
630  $ iinfo )
631 *
632  ELSE
633 *
634  iinfo = 1
635  END IF
636 *
637  IF( iinfo.NE.0 ) THEN
638  WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
639  $ ioldsd
640  info = abs( iinfo )
641  return
642  END IF
643 *
644  90 continue
645 *
646  abstol = unfl + unfl
647  IF( n.LE.1 ) THEN
648  il = 1
649  iu = n
650  ELSE
651  il = 1 + ( n-1 )*slarnd( 1, iseed2 )
652  iu = 1 + ( n-1 )*slarnd( 1, iseed2 )
653  IF( il.GT.iu ) THEN
654  itemp = il
655  il = iu
656  iu = itemp
657  END IF
658  END IF
659 *
660 * 3) Call SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD, SSBGVD,
661 * SSYGVX, SSPGVX, and SSBGVX, do tests.
662 *
663 * loop over the three generalized problems
664 * IBTYPE = 1: A*x = (lambda)*B*x
665 * IBTYPE = 2: A*B*x = (lambda)*x
666 * IBTYPE = 3: B*A*x = (lambda)*x
667 *
668  DO 630 ibtype = 1, 3
669 *
670 * loop over the setting UPLO
671 *
672  DO 620 ibuplo = 1, 2
673  IF( ibuplo.EQ.1 )
674  $ uplo = 'U'
675  IF( ibuplo.EQ.2 )
676  $ uplo = 'L'
677 *
678 * Generate random well-conditioned positive definite
679 * matrix B, of bandwidth not greater than that of A.
680 *
681  CALL slatms( n, n, 'U', iseed, 'P', work, 5, ten, one,
682  $ kb, kb, uplo, b, ldb, work( n+1 ),
683  $ iinfo )
684 *
685 * Test SSYGV
686 *
687  ntest = ntest + 1
688 *
689  CALL slacpy( ' ', n, n, a, lda, z, ldz )
690  CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
691 *
692  CALL ssygv( ibtype, 'V', uplo, n, z, ldz, bb, ldb, d,
693  $ work, nwork, iinfo )
694  IF( iinfo.NE.0 ) THEN
695  WRITE( nounit, fmt = 9999 )'SSYGV(V,' // uplo //
696  $ ')', iinfo, n, jtype, ioldsd
697  info = abs( iinfo )
698  IF( iinfo.LT.0 ) THEN
699  return
700  ELSE
701  result( ntest ) = ulpinv
702  go to 100
703  END IF
704  END IF
705 *
706 * Do Test
707 *
708  CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
709  $ ldz, d, work, result( ntest ) )
710 *
711 * Test SSYGVD
712 *
713  ntest = ntest + 1
714 *
715  CALL slacpy( ' ', n, n, a, lda, z, ldz )
716  CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
717 *
718  CALL ssygvd( ibtype, 'V', uplo, n, z, ldz, bb, ldb, d,
719  $ work, nwork, iwork, liwork, iinfo )
720  IF( iinfo.NE.0 ) THEN
721  WRITE( nounit, fmt = 9999 )'SSYGVD(V,' // uplo //
722  $ ')', iinfo, n, jtype, ioldsd
723  info = abs( iinfo )
724  IF( iinfo.LT.0 ) THEN
725  return
726  ELSE
727  result( ntest ) = ulpinv
728  go to 100
729  END IF
730  END IF
731 *
732 * Do Test
733 *
734  CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
735  $ ldz, d, work, result( ntest ) )
736 *
737 * Test SSYGVX
738 *
739  ntest = ntest + 1
740 *
741  CALL slacpy( ' ', n, n, a, lda, ab, lda )
742  CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
743 *
744  CALL ssygvx( ibtype, 'V', 'A', uplo, n, ab, lda, bb,
745  $ ldb, vl, vu, il, iu, abstol, m, d, z,
746  $ ldz, work, nwork, iwork( n+1 ), iwork,
747  $ iinfo )
748  IF( iinfo.NE.0 ) THEN
749  WRITE( nounit, fmt = 9999 )'SSYGVX(V,A' // uplo //
750  $ ')', iinfo, n, jtype, ioldsd
751  info = abs( iinfo )
752  IF( iinfo.LT.0 ) THEN
753  return
754  ELSE
755  result( ntest ) = ulpinv
756  go to 100
757  END IF
758  END IF
759 *
760 * Do Test
761 *
762  CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
763  $ ldz, d, work, result( ntest ) )
764 *
765  ntest = ntest + 1
766 *
767  CALL slacpy( ' ', n, n, a, lda, ab, lda )
768  CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
769 *
770 * since we do not know the exact eigenvalues of this
771 * eigenpair, we just set VL and VU as constants.
772 * It is quite possible that there are no eigenvalues
773 * in this interval.
774 *
775  vl = zero
776  vu = anorm
777  CALL ssygvx( ibtype, 'V', 'V', uplo, n, ab, lda, bb,
778  $ ldb, vl, vu, il, iu, abstol, m, d, z,
779  $ ldz, work, nwork, iwork( n+1 ), iwork,
780  $ iinfo )
781  IF( iinfo.NE.0 ) THEN
782  WRITE( nounit, fmt = 9999 )'SSYGVX(V,V,' //
783  $ uplo // ')', iinfo, n, jtype, ioldsd
784  info = abs( iinfo )
785  IF( iinfo.LT.0 ) THEN
786  return
787  ELSE
788  result( ntest ) = ulpinv
789  go to 100
790  END IF
791  END IF
792 *
793 * Do Test
794 *
795  CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
796  $ ldz, d, work, result( ntest ) )
797 *
798  ntest = ntest + 1
799 *
800  CALL slacpy( ' ', n, n, a, lda, ab, lda )
801  CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
802 *
803  CALL ssygvx( ibtype, 'V', 'I', uplo, n, ab, lda, bb,
804  $ ldb, vl, vu, il, iu, abstol, m, d, z,
805  $ ldz, work, nwork, iwork( n+1 ), iwork,
806  $ iinfo )
807  IF( iinfo.NE.0 ) THEN
808  WRITE( nounit, fmt = 9999 )'SSYGVX(V,I,' //
809  $ uplo // ')', iinfo, n, jtype, ioldsd
810  info = abs( iinfo )
811  IF( iinfo.LT.0 ) THEN
812  return
813  ELSE
814  result( ntest ) = ulpinv
815  go to 100
816  END IF
817  END IF
818 *
819 * Do Test
820 *
821  CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
822  $ ldz, d, work, result( ntest ) )
823 *
824  100 continue
825 *
826 * Test SSPGV
827 *
828  ntest = ntest + 1
829 *
830 * Copy the matrices into packed storage.
831 *
832  IF( lsame( uplo, 'U' ) ) THEN
833  ij = 1
834  DO 120 j = 1, n
835  DO 110 i = 1, j
836  ap( ij ) = a( i, j )
837  bp( ij ) = b( i, j )
838  ij = ij + 1
839  110 continue
840  120 continue
841  ELSE
842  ij = 1
843  DO 140 j = 1, n
844  DO 130 i = j, n
845  ap( ij ) = a( i, j )
846  bp( ij ) = b( i, j )
847  ij = ij + 1
848  130 continue
849  140 continue
850  END IF
851 *
852  CALL sspgv( ibtype, 'V', uplo, n, ap, bp, d, z, ldz,
853  $ work, iinfo )
854  IF( iinfo.NE.0 ) THEN
855  WRITE( nounit, fmt = 9999 )'SSPGV(V,' // uplo //
856  $ ')', iinfo, n, jtype, ioldsd
857  info = abs( iinfo )
858  IF( iinfo.LT.0 ) THEN
859  return
860  ELSE
861  result( ntest ) = ulpinv
862  go to 310
863  END IF
864  END IF
865 *
866 * Do Test
867 *
868  CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
869  $ ldz, d, work, result( ntest ) )
870 *
871 * Test SSPGVD
872 *
873  ntest = ntest + 1
874 *
875 * Copy the matrices into packed storage.
876 *
877  IF( lsame( uplo, 'U' ) ) THEN
878  ij = 1
879  DO 160 j = 1, n
880  DO 150 i = 1, j
881  ap( ij ) = a( i, j )
882  bp( ij ) = b( i, j )
883  ij = ij + 1
884  150 continue
885  160 continue
886  ELSE
887  ij = 1
888  DO 180 j = 1, n
889  DO 170 i = j, n
890  ap( ij ) = a( i, j )
891  bp( ij ) = b( i, j )
892  ij = ij + 1
893  170 continue
894  180 continue
895  END IF
896 *
897  CALL sspgvd( ibtype, 'V', uplo, n, ap, bp, d, z, ldz,
898  $ work, nwork, iwork, liwork, iinfo )
899  IF( iinfo.NE.0 ) THEN
900  WRITE( nounit, fmt = 9999 )'SSPGVD(V,' // uplo //
901  $ ')', iinfo, n, jtype, ioldsd
902  info = abs( iinfo )
903  IF( iinfo.LT.0 ) THEN
904  return
905  ELSE
906  result( ntest ) = ulpinv
907  go to 310
908  END IF
909  END IF
910 *
911 * Do Test
912 *
913  CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
914  $ ldz, d, work, result( ntest ) )
915 *
916 * Test SSPGVX
917 *
918  ntest = ntest + 1
919 *
920 * Copy the matrices into packed storage.
921 *
922  IF( lsame( uplo, 'U' ) ) THEN
923  ij = 1
924  DO 200 j = 1, n
925  DO 190 i = 1, j
926  ap( ij ) = a( i, j )
927  bp( ij ) = b( i, j )
928  ij = ij + 1
929  190 continue
930  200 continue
931  ELSE
932  ij = 1
933  DO 220 j = 1, n
934  DO 210 i = j, n
935  ap( ij ) = a( i, j )
936  bp( ij ) = b( i, j )
937  ij = ij + 1
938  210 continue
939  220 continue
940  END IF
941 *
942  CALL sspgvx( ibtype, 'V', 'A', uplo, n, ap, bp, vl,
943  $ vu, il, iu, abstol, m, d, z, ldz, work,
944  $ iwork( n+1 ), iwork, info )
945  IF( iinfo.NE.0 ) THEN
946  WRITE( nounit, fmt = 9999 )'SSPGVX(V,A' // uplo //
947  $ ')', iinfo, n, jtype, ioldsd
948  info = abs( iinfo )
949  IF( iinfo.LT.0 ) THEN
950  return
951  ELSE
952  result( ntest ) = ulpinv
953  go to 310
954  END IF
955  END IF
956 *
957 * Do Test
958 *
959  CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
960  $ ldz, d, work, result( ntest ) )
961 *
962  ntest = ntest + 1
963 *
964 * Copy the matrices into packed storage.
965 *
966  IF( lsame( uplo, 'U' ) ) THEN
967  ij = 1
968  DO 240 j = 1, n
969  DO 230 i = 1, j
970  ap( ij ) = a( i, j )
971  bp( ij ) = b( i, j )
972  ij = ij + 1
973  230 continue
974  240 continue
975  ELSE
976  ij = 1
977  DO 260 j = 1, n
978  DO 250 i = j, n
979  ap( ij ) = a( i, j )
980  bp( ij ) = b( i, j )
981  ij = ij + 1
982  250 continue
983  260 continue
984  END IF
985 *
986  vl = zero
987  vu = anorm
988  CALL sspgvx( ibtype, 'V', 'V', uplo, n, ap, bp, vl,
989  $ vu, il, iu, abstol, m, d, z, ldz, work,
990  $ iwork( n+1 ), iwork, info )
991  IF( iinfo.NE.0 ) THEN
992  WRITE( nounit, fmt = 9999 )'SSPGVX(V,V' // uplo //
993  $ ')', iinfo, n, jtype, ioldsd
994  info = abs( iinfo )
995  IF( iinfo.LT.0 ) THEN
996  return
997  ELSE
998  result( ntest ) = ulpinv
999  go to 310
1000  END IF
1001  END IF
1002 *
1003 * Do Test
1004 *
1005  CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1006  $ ldz, d, work, result( ntest ) )
1007 *
1008  ntest = ntest + 1
1009 *
1010 * Copy the matrices into packed storage.
1011 *
1012  IF( lsame( uplo, 'U' ) ) THEN
1013  ij = 1
1014  DO 280 j = 1, n
1015  DO 270 i = 1, j
1016  ap( ij ) = a( i, j )
1017  bp( ij ) = b( i, j )
1018  ij = ij + 1
1019  270 continue
1020  280 continue
1021  ELSE
1022  ij = 1
1023  DO 300 j = 1, n
1024  DO 290 i = j, n
1025  ap( ij ) = a( i, j )
1026  bp( ij ) = b( i, j )
1027  ij = ij + 1
1028  290 continue
1029  300 continue
1030  END IF
1031 *
1032  CALL sspgvx( ibtype, 'V', 'I', uplo, n, ap, bp, vl,
1033  $ vu, il, iu, abstol, m, d, z, ldz, work,
1034  $ iwork( n+1 ), iwork, info )
1035  IF( iinfo.NE.0 ) THEN
1036  WRITE( nounit, fmt = 9999 )'SSPGVX(V,I' // uplo //
1037  $ ')', iinfo, n, jtype, ioldsd
1038  info = abs( iinfo )
1039  IF( iinfo.LT.0 ) THEN
1040  return
1041  ELSE
1042  result( ntest ) = ulpinv
1043  go to 310
1044  END IF
1045  END IF
1046 *
1047 * Do Test
1048 *
1049  CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1050  $ ldz, d, work, result( ntest ) )
1051 *
1052  310 continue
1053 *
1054  IF( ibtype.EQ.1 ) THEN
1055 *
1056 * TEST SSBGV
1057 *
1058  ntest = ntest + 1
1059 *
1060 * Copy the matrices into band storage.
1061 *
1062  IF( lsame( uplo, 'U' ) ) THEN
1063  DO 340 j = 1, n
1064  DO 320 i = max( 1, j-ka ), j
1065  ab( ka+1+i-j, j ) = a( i, j )
1066  320 continue
1067  DO 330 i = max( 1, j-kb ), j
1068  bb( kb+1+i-j, j ) = b( i, j )
1069  330 continue
1070  340 continue
1071  ELSE
1072  DO 370 j = 1, n
1073  DO 350 i = j, min( n, j+ka )
1074  ab( 1+i-j, j ) = a( i, j )
1075  350 continue
1076  DO 360 i = j, min( n, j+kb )
1077  bb( 1+i-j, j ) = b( i, j )
1078  360 continue
1079  370 continue
1080  END IF
1081 *
1082  CALL ssbgv( 'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1083  $ d, z, ldz, work, iinfo )
1084  IF( iinfo.NE.0 ) THEN
1085  WRITE( nounit, fmt = 9999 )'SSBGV(V,' //
1086  $ uplo // ')', iinfo, n, jtype, ioldsd
1087  info = abs( iinfo )
1088  IF( iinfo.LT.0 ) THEN
1089  return
1090  ELSE
1091  result( ntest ) = ulpinv
1092  go to 620
1093  END IF
1094  END IF
1095 *
1096 * Do Test
1097 *
1098  CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1099  $ ldz, d, work, result( ntest ) )
1100 *
1101 * TEST SSBGVD
1102 *
1103  ntest = ntest + 1
1104 *
1105 * Copy the matrices into band storage.
1106 *
1107  IF( lsame( uplo, 'U' ) ) THEN
1108  DO 400 j = 1, n
1109  DO 380 i = max( 1, j-ka ), j
1110  ab( ka+1+i-j, j ) = a( i, j )
1111  380 continue
1112  DO 390 i = max( 1, j-kb ), j
1113  bb( kb+1+i-j, j ) = b( i, j )
1114  390 continue
1115  400 continue
1116  ELSE
1117  DO 430 j = 1, n
1118  DO 410 i = j, min( n, j+ka )
1119  ab( 1+i-j, j ) = a( i, j )
1120  410 continue
1121  DO 420 i = j, min( n, j+kb )
1122  bb( 1+i-j, j ) = b( i, j )
1123  420 continue
1124  430 continue
1125  END IF
1126 *
1127  CALL ssbgvd( 'V', uplo, n, ka, kb, ab, lda, bb,
1128  $ ldb, d, z, ldz, work, nwork, iwork,
1129  $ liwork, iinfo )
1130  IF( iinfo.NE.0 ) THEN
1131  WRITE( nounit, fmt = 9999 )'SSBGVD(V,' //
1132  $ uplo // ')', iinfo, n, jtype, ioldsd
1133  info = abs( iinfo )
1134  IF( iinfo.LT.0 ) THEN
1135  return
1136  ELSE
1137  result( ntest ) = ulpinv
1138  go to 620
1139  END IF
1140  END IF
1141 *
1142 * Do Test
1143 *
1144  CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1145  $ ldz, d, work, result( ntest ) )
1146 *
1147 * Test SSBGVX
1148 *
1149  ntest = ntest + 1
1150 *
1151 * Copy the matrices into band storage.
1152 *
1153  IF( lsame( uplo, 'U' ) ) THEN
1154  DO 460 j = 1, n
1155  DO 440 i = max( 1, j-ka ), j
1156  ab( ka+1+i-j, j ) = a( i, j )
1157  440 continue
1158  DO 450 i = max( 1, j-kb ), j
1159  bb( kb+1+i-j, j ) = b( i, j )
1160  450 continue
1161  460 continue
1162  ELSE
1163  DO 490 j = 1, n
1164  DO 470 i = j, min( n, j+ka )
1165  ab( 1+i-j, j ) = a( i, j )
1166  470 continue
1167  DO 480 i = j, min( n, j+kb )
1168  bb( 1+i-j, j ) = b( i, j )
1169  480 continue
1170  490 continue
1171  END IF
1172 *
1173  CALL ssbgvx( 'V', 'A', uplo, n, ka, kb, ab, lda,
1174  $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1175  $ iu, abstol, m, d, z, ldz, work,
1176  $ iwork( n+1 ), iwork, iinfo )
1177  IF( iinfo.NE.0 ) THEN
1178  WRITE( nounit, fmt = 9999 )'SSBGVX(V,A' //
1179  $ uplo // ')', iinfo, n, jtype, ioldsd
1180  info = abs( iinfo )
1181  IF( iinfo.LT.0 ) THEN
1182  return
1183  ELSE
1184  result( ntest ) = ulpinv
1185  go to 620
1186  END IF
1187  END IF
1188 *
1189 * Do Test
1190 *
1191  CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1192  $ ldz, d, work, result( ntest ) )
1193 *
1194 *
1195  ntest = ntest + 1
1196 *
1197 * Copy the matrices into band storage.
1198 *
1199  IF( lsame( uplo, 'U' ) ) THEN
1200  DO 520 j = 1, n
1201  DO 500 i = max( 1, j-ka ), j
1202  ab( ka+1+i-j, j ) = a( i, j )
1203  500 continue
1204  DO 510 i = max( 1, j-kb ), j
1205  bb( kb+1+i-j, j ) = b( i, j )
1206  510 continue
1207  520 continue
1208  ELSE
1209  DO 550 j = 1, n
1210  DO 530 i = j, min( n, j+ka )
1211  ab( 1+i-j, j ) = a( i, j )
1212  530 continue
1213  DO 540 i = j, min( n, j+kb )
1214  bb( 1+i-j, j ) = b( i, j )
1215  540 continue
1216  550 continue
1217  END IF
1218 *
1219  vl = zero
1220  vu = anorm
1221  CALL ssbgvx( 'V', 'V', uplo, n, ka, kb, ab, lda,
1222  $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1223  $ iu, abstol, m, d, z, ldz, work,
1224  $ iwork( n+1 ), iwork, iinfo )
1225  IF( iinfo.NE.0 ) THEN
1226  WRITE( nounit, fmt = 9999 )'SSBGVX(V,V' //
1227  $ uplo // ')', iinfo, n, jtype, ioldsd
1228  info = abs( iinfo )
1229  IF( iinfo.LT.0 ) THEN
1230  return
1231  ELSE
1232  result( ntest ) = ulpinv
1233  go to 620
1234  END IF
1235  END IF
1236 *
1237 * Do Test
1238 *
1239  CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1240  $ ldz, d, work, result( ntest ) )
1241 *
1242  ntest = ntest + 1
1243 *
1244 * Copy the matrices into band storage.
1245 *
1246  IF( lsame( uplo, 'U' ) ) THEN
1247  DO 580 j = 1, n
1248  DO 560 i = max( 1, j-ka ), j
1249  ab( ka+1+i-j, j ) = a( i, j )
1250  560 continue
1251  DO 570 i = max( 1, j-kb ), j
1252  bb( kb+1+i-j, j ) = b( i, j )
1253  570 continue
1254  580 continue
1255  ELSE
1256  DO 610 j = 1, n
1257  DO 590 i = j, min( n, j+ka )
1258  ab( 1+i-j, j ) = a( i, j )
1259  590 continue
1260  DO 600 i = j, min( n, j+kb )
1261  bb( 1+i-j, j ) = b( i, j )
1262  600 continue
1263  610 continue
1264  END IF
1265 *
1266  CALL ssbgvx( 'V', 'I', uplo, n, ka, kb, ab, lda,
1267  $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1268  $ iu, abstol, m, d, z, ldz, work,
1269  $ iwork( n+1 ), iwork, iinfo )
1270  IF( iinfo.NE.0 ) THEN
1271  WRITE( nounit, fmt = 9999 )'SSBGVX(V,I' //
1272  $ uplo // ')', iinfo, n, jtype, ioldsd
1273  info = abs( iinfo )
1274  IF( iinfo.LT.0 ) THEN
1275  return
1276  ELSE
1277  result( ntest ) = ulpinv
1278  go to 620
1279  END IF
1280  END IF
1281 *
1282 * Do Test
1283 *
1284  CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1285  $ ldz, d, work, result( ntest ) )
1286 *
1287  END IF
1288 *
1289  620 continue
1290  630 continue
1291 *
1292 * End of Loop -- Check for RESULT(j) > THRESH
1293 *
1294  ntestt = ntestt + ntest
1295  CALL slafts( 'SSG', n, n, jtype, ntest, result, ioldsd,
1296  $ thresh, nounit, nerrs )
1297  640 continue
1298  650 continue
1299 *
1300 * Summary
1301 *
1302  CALL slasum( 'SSG', nounit, nerrs, ntestt )
1303 *
1304  return
1305 *
1306 * End of SDRVSG
1307 *
1308  9999 format( ' SDRVSG: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1309  $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1310  END