LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
 All Classes Files Functions Variables Typedefs Macros
cchkhb.f
Go to the documentation of this file.
1 *> \brief \b CCHKHB
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 CCHKHB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED,
12 * THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK,
13 * LWORK, RWORK, RESULT, INFO )
14 *
15 * .. Scalar Arguments ..
16 * INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES,
17 * $ NWDTHS
18 * REAL THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER ISEED( 4 ), KK( * ), NN( * )
23 * REAL RESULT( * ), RWORK( * ), SD( * ), SE( * )
24 * COMPLEX A( LDA, * ), U( LDU, * ), WORK( * )
25 * ..
26 *
27 *
28 *> \par Purpose:
29 * =============
30 *>
31 *> \verbatim
32 *>
33 *> CCHKHB tests the reduction of a Hermitian band matrix to tridiagonal
34 *> from, used with the Hermitian eigenvalue problem.
35 *>
36 *> CHBTRD factors a Hermitian band matrix A as U S U* , where * means
37 *> conjugate transpose, S is symmetric tridiagonal, and U is unitary.
38 *> CHBTRD can use either just the lower or just the upper triangle
39 *> of A; CCHKHB checks both cases.
40 *>
41 *> When CCHKHB is called, a number of matrix "sizes" ("n's"), a number
42 *> of bandwidths ("k's"), and a number of matrix "types" are
43 *> specified. For each size ("n"), each bandwidth ("k") less than or
44 *> equal to "n", and each type of matrix, one matrix will be generated
45 *> and used to test the hermitian banded reduction routine. For each
46 *> matrix, a number of tests will be performed:
47 *>
48 *> (1) | A - V S V* | / ( |A| n ulp ) computed by CHBTRD with
49 *> UPLO='U'
50 *>
51 *> (2) | I - UU* | / ( n ulp )
52 *>
53 *> (3) | A - V S V* | / ( |A| n ulp ) computed by CHBTRD with
54 *> UPLO='L'
55 *>
56 *> (4) | I - UU* | / ( n ulp )
57 *>
58 *> The "sizes" are specified by an array NN(1:NSIZES); the value of
59 *> each element NN(j) specifies one size.
60 *> The "types" are specified by a logical array DOTYPE( 1:NTYPES );
61 *> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
62 *> Currently, the list of possible types is:
63 *>
64 *> (1) The zero matrix.
65 *> (2) The identity matrix.
66 *>
67 *> (3) A diagonal matrix with evenly spaced entries
68 *> 1, ..., ULP and random signs.
69 *> (ULP = (first number larger than 1) - 1 )
70 *> (4) A diagonal matrix with geometrically spaced entries
71 *> 1, ..., ULP and random signs.
72 *> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
73 *> and random signs.
74 *>
75 *> (6) Same as (4), but multiplied by SQRT( overflow threshold )
76 *> (7) Same as (4), but multiplied by SQRT( underflow threshold )
77 *>
78 *> (8) A matrix of the form U* D U, where U is unitary and
79 *> D has evenly spaced entries 1, ..., ULP with random signs
80 *> on the diagonal.
81 *>
82 *> (9) A matrix of the form U* D U, where U is unitary and
83 *> D has geometrically spaced entries 1, ..., ULP with random
84 *> signs on the diagonal.
85 *>
86 *> (10) A matrix of the form U* D U, where U is unitary and
87 *> D has "clustered" entries 1, ULP,..., ULP with random
88 *> signs on the diagonal.
89 *>
90 *> (11) Same as (8), but multiplied by SQRT( overflow threshold )
91 *> (12) Same as (8), but multiplied by SQRT( underflow threshold )
92 *>
93 *> (13) Hermitian matrix with random entries chosen from (-1,1).
94 *> (14) Same as (13), but multiplied by SQRT( overflow threshold )
95 *> (15) Same as (13), but multiplied by SQRT( underflow threshold )
96 *> \endverbatim
97 *
98 * Arguments:
99 * ==========
100 *
101 *> \param[in] NSIZES
102 *> \verbatim
103 *> NSIZES is INTEGER
104 *> The number of sizes of matrices to use. If it is zero,
105 *> CCHKHB does nothing. It must be at least zero.
106 *> \endverbatim
107 *>
108 *> \param[in] NN
109 *> \verbatim
110 *> NN is INTEGER array, dimension (NSIZES)
111 *> An array containing the sizes to be used for the matrices.
112 *> Zero values will be skipped. The values must be at least
113 *> zero.
114 *> \endverbatim
115 *>
116 *> \param[in] NWDTHS
117 *> \verbatim
118 *> NWDTHS is INTEGER
119 *> The number of bandwidths to use. If it is zero,
120 *> CCHKHB does nothing. It must be at least zero.
121 *> \endverbatim
122 *>
123 *> \param[in] KK
124 *> \verbatim
125 *> KK is INTEGER array, dimension (NWDTHS)
126 *> An array containing the bandwidths to be used for the band
127 *> matrices. The values must be at least zero.
128 *> \endverbatim
129 *>
130 *> \param[in] NTYPES
131 *> \verbatim
132 *> NTYPES is INTEGER
133 *> The number of elements in DOTYPE. If it is zero, CCHKHB
134 *> does nothing. It must be at least zero. If it is MAXTYP+1
135 *> and NSIZES is 1, then an additional type, MAXTYP+1 is
136 *> defined, which is to use whatever matrix is in A. This
137 *> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
138 *> DOTYPE(MAXTYP+1) is .TRUE. .
139 *> \endverbatim
140 *>
141 *> \param[in] DOTYPE
142 *> \verbatim
143 *> DOTYPE is LOGICAL array, dimension (NTYPES)
144 *> If DOTYPE(j) is .TRUE., then for each size in NN a
145 *> matrix of that size and of type j will be generated.
146 *> If NTYPES is smaller than the maximum number of types
147 *> defined (PARAMETER MAXTYP), then types NTYPES+1 through
148 *> MAXTYP will not be generated. If NTYPES is larger
149 *> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
150 *> will be ignored.
151 *> \endverbatim
152 *>
153 *> \param[in,out] ISEED
154 *> \verbatim
155 *> ISEED is INTEGER array, dimension (4)
156 *> On entry ISEED specifies the seed of the random number
157 *> generator. The array elements should be between 0 and 4095;
158 *> if not they will be reduced mod 4096. Also, ISEED(4) must
159 *> be odd. The random number generator uses a linear
160 *> congruential sequence limited to small integers, and so
161 *> should produce machine independent random numbers. The
162 *> values of ISEED are changed on exit, and can be used in the
163 *> next call to CCHKHB to continue the same random number
164 *> sequence.
165 *> \endverbatim
166 *>
167 *> \param[in] THRESH
168 *> \verbatim
169 *> THRESH is REAL
170 *> A test will count as "failed" if the "error", computed as
171 *> described above, exceeds THRESH. Note that the error
172 *> is scaled to be O(1), so THRESH should be a reasonably
173 *> small multiple of 1, e.g., 10 or 100. In particular,
174 *> it should not depend on the precision (single vs. double)
175 *> or the size of the matrix. It must be at least zero.
176 *> \endverbatim
177 *>
178 *> \param[in] NOUNIT
179 *> \verbatim
180 *> NOUNIT is INTEGER
181 *> The FORTRAN unit number for printing out error messages
182 *> (e.g., if a routine returns IINFO not equal to 0.)
183 *> \endverbatim
184 *>
185 *> \param[in,out] A
186 *> \verbatim
187 *> A is COMPLEX array, dimension
188 *> (LDA, max(NN))
189 *> Used to hold the matrix whose eigenvalues are to be
190 *> computed.
191 *> \endverbatim
192 *>
193 *> \param[in] LDA
194 *> \verbatim
195 *> LDA is INTEGER
196 *> The leading dimension of A. It must be at least 2 (not 1!)
197 *> and at least max( KK )+1.
198 *> \endverbatim
199 *>
200 *> \param[out] SD
201 *> \verbatim
202 *> SD is REAL array, dimension (max(NN))
203 *> Used to hold the diagonal of the tridiagonal matrix computed
204 *> by CHBTRD.
205 *> \endverbatim
206 *>
207 *> \param[out] SE
208 *> \verbatim
209 *> SE is REAL array, dimension (max(NN))
210 *> Used to hold the off-diagonal of the tridiagonal matrix
211 *> computed by CHBTRD.
212 *> \endverbatim
213 *>
214 *> \param[out] U
215 *> \verbatim
216 *> U is COMPLEX array, dimension (LDU, max(NN))
217 *> Used to hold the unitary matrix computed by CHBTRD.
218 *> \endverbatim
219 *>
220 *> \param[in] LDU
221 *> \verbatim
222 *> LDU is INTEGER
223 *> The leading dimension of U. It must be at least 1
224 *> and at least max( NN ).
225 *> \endverbatim
226 *>
227 *> \param[out] WORK
228 *> \verbatim
229 *> WORK is COMPLEX array, dimension (LWORK)
230 *> \endverbatim
231 *>
232 *> \param[in] LWORK
233 *> \verbatim
234 *> LWORK is INTEGER
235 *> The number of entries in WORK. This must be at least
236 *> max( LDA+1, max(NN)+1 )*max(NN).
237 *> \endverbatim
238 *>
239 *> \param[out] RWORK
240 *> \verbatim
241 *> RWORK is REAL array
242 *> \endverbatim
243 *>
244 *> \param[out] RESULT
245 *> \verbatim
246 *> RESULT is REAL array, dimension (4)
247 *> The values computed by the tests described above.
248 *> The values are currently limited to 1/ulp, to avoid
249 *> overflow.
250 *> \endverbatim
251 *>
252 *> \param[out] INFO
253 *> \verbatim
254 *> INFO is INTEGER
255 *> If 0, then everything ran OK.
256 *>
257 *>-----------------------------------------------------------------------
258 *>
259 *> Some Local Variables and Parameters:
260 *> ---- ----- --------- --- ----------
261 *> ZERO, ONE Real 0 and 1.
262 *> MAXTYP The number of types defined.
263 *> NTEST The number of tests performed, or which can
264 *> be performed so far, for the current matrix.
265 *> NTESTT The total number of tests performed so far.
266 *> NMAX Largest value in NN.
267 *> NMATS The number of matrices generated so far.
268 *> NERRS The number of tests which have exceeded THRESH
269 *> so far.
270 *> COND, IMODE Values to be passed to the matrix generators.
271 *> ANORM Norm of A; passed to matrix generators.
272 *>
273 *> OVFL, UNFL Overflow and underflow thresholds.
274 *> ULP, ULPINV Finest relative precision and its inverse.
275 *> RTOVFL, RTUNFL Square roots of the previous 2 values.
276 *> The following four arrays decode JTYPE:
277 *> KTYPE(j) The general type (1-10) for type "j".
278 *> KMODE(j) The MODE value to be passed to the matrix
279 *> generator for type "j".
280 *> KMAGN(j) The order of magnitude ( O(1),
281 *> O(overflow^(1/2) ), O(underflow^(1/2) )
282 *> \endverbatim
283 *
284 * Authors:
285 * ========
286 *
287 *> \author Univ. of Tennessee
288 *> \author Univ. of California Berkeley
289 *> \author Univ. of Colorado Denver
290 *> \author NAG Ltd.
291 *
292 *> \date November 2011
293 *
294 *> \ingroup complex_eig
295 *
296 * =====================================================================
297  SUBROUTINE cchkhb( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED,
298  $ thresh, nounit, a, lda, sd, se, u, ldu, work,
299  $ lwork, rwork, result, info )
300 *
301 * -- LAPACK test routine (version 3.4.0) --
302 * -- LAPACK is a software package provided by Univ. of Tennessee, --
303 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
304 * November 2011
305 *
306 * .. Scalar Arguments ..
307  INTEGER info, lda, ldu, lwork, nounit, nsizes, ntypes,
308  $ nwdths
309  REAL thresh
310 * ..
311 * .. Array Arguments ..
312  LOGICAL dotype( * )
313  INTEGER iseed( 4 ), kk( * ), nn( * )
314  REAL result( * ), rwork( * ), sd( * ), se( * )
315  COMPLEX a( lda, * ), u( ldu, * ), work( * )
316 * ..
317 *
318 * =====================================================================
319 *
320 * .. Parameters ..
321  COMPLEX czero, cone
322  parameter( czero = ( 0.0e+0, 0.0e+0 ),
323  $ cone = ( 1.0e+0, 0.0e+0 ) )
324  REAL zero, one, two, ten
325  parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
326  $ ten = 10.0e+0 )
327  REAL half
328  parameter( half = one / two )
329  INTEGER maxtyp
330  parameter( maxtyp = 15 )
331 * ..
332 * .. Local Scalars ..
333  LOGICAL badnn, badnnb
334  INTEGER i, iinfo, imode, itype, j, jc, jcol, jr, jsize,
335  $ jtype, jwidth, k, kmax, mtypes, n, nerrs,
336  $ nmats, nmax, ntest, ntestt
337  REAL aninv, anorm, cond, ovfl, rtovfl, rtunfl,
338  $ temp1, ulp, ulpinv, unfl
339 * ..
340 * .. Local Arrays ..
341  INTEGER idumma( 1 ), ioldsd( 4 ), kmagn( maxtyp ),
342  $ kmode( maxtyp ), ktype( maxtyp )
343 * ..
344 * .. External Functions ..
345  REAL slamch
346  EXTERNAL slamch
347 * ..
348 * .. External Subroutines ..
349  EXTERNAL chbt21, chbtrd, clacpy, clatmr, clatms, claset,
350  $ slasum, xerbla
351 * ..
352 * .. Intrinsic Functions ..
353  INTRINSIC abs, conjg, max, min, REAL, sqrt
354 * ..
355 * .. Data statements ..
356  DATA ktype / 1, 2, 5*4, 5*5, 3*8 /
357  DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
358  $ 2, 3 /
359  DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
360  $ 0, 0 /
361 * ..
362 * .. Executable Statements ..
363 *
364 * Check for errors
365 *
366  ntestt = 0
367  info = 0
368 *
369 * Important constants
370 *
371  badnn = .false.
372  nmax = 1
373  DO 10 j = 1, nsizes
374  nmax = max( nmax, nn( j ) )
375  IF( nn( j ).LT.0 )
376  $ badnn = .true.
377  10 CONTINUE
378 *
379  badnnb = .false.
380  kmax = 0
381  DO 20 j = 1, nsizes
382  kmax = max( kmax, kk( j ) )
383  IF( kk( j ).LT.0 )
384  $ badnnb = .true.
385  20 CONTINUE
386  kmax = min( nmax-1, kmax )
387 *
388 * Check for errors
389 *
390  IF( nsizes.LT.0 ) THEN
391  info = -1
392  ELSE IF( badnn ) THEN
393  info = -2
394  ELSE IF( nwdths.LT.0 ) THEN
395  info = -3
396  ELSE IF( badnnb ) THEN
397  info = -4
398  ELSE IF( ntypes.LT.0 ) THEN
399  info = -5
400  ELSE IF( lda.LT.kmax+1 ) THEN
401  info = -11
402  ELSE IF( ldu.LT.nmax ) THEN
403  info = -15
404  ELSE IF( ( max( lda, nmax )+1 )*nmax.GT.lwork ) THEN
405  info = -17
406  END IF
407 *
408  IF( info.NE.0 ) THEN
409  CALL xerbla( 'CCHKHB', -info )
410  RETURN
411  END IF
412 *
413 * Quick return if possible
414 *
415  IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
416  $ RETURN
417 *
418 * More Important constants
419 *
420  unfl = slamch( 'Safe minimum' )
421  ovfl = one / unfl
422  ulp = slamch( 'Epsilon' )*slamch( 'Base' )
423  ulpinv = one / ulp
424  rtunfl = sqrt( unfl )
425  rtovfl = sqrt( ovfl )
426 *
427 * Loop over sizes, types
428 *
429  nerrs = 0
430  nmats = 0
431 *
432  DO 190 jsize = 1, nsizes
433  n = nn( jsize )
434  aninv = one / REAL( MAX( 1, N ) )
435 *
436  DO 180 jwidth = 1, nwdths
437  k = kk( jwidth )
438  IF( k.GT.n )
439  $ go to 180
440  k = max( 0, min( n-1, k ) )
441 *
442  IF( nsizes.NE.1 ) THEN
443  mtypes = min( maxtyp, ntypes )
444  ELSE
445  mtypes = min( maxtyp+1, ntypes )
446  END IF
447 *
448  DO 170 jtype = 1, mtypes
449  IF( .NOT.dotype( jtype ) )
450  $ go to 170
451  nmats = nmats + 1
452  ntest = 0
453 *
454  DO 30 j = 1, 4
455  ioldsd( j ) = iseed( j )
456  30 CONTINUE
457 *
458 * Compute "A".
459 * Store as "Upper"; later, we will copy to other format.
460 *
461 * Control parameters:
462 *
463 * KMAGN KMODE KTYPE
464 * =1 O(1) clustered 1 zero
465 * =2 large clustered 2 identity
466 * =3 small exponential (none)
467 * =4 arithmetic diagonal, (w/ eigenvalues)
468 * =5 random log hermitian, w/ eigenvalues
469 * =6 random (none)
470 * =7 random diagonal
471 * =8 random hermitian
472 * =9 positive definite
473 * =10 diagonally dominant tridiagonal
474 *
475  IF( mtypes.GT.maxtyp )
476  $ go to 100
477 *
478  itype = ktype( jtype )
479  imode = kmode( jtype )
480 *
481 * Compute norm
482 *
483  go to( 40, 50, 60 )kmagn( jtype )
484 *
485  40 CONTINUE
486  anorm = one
487  go to 70
488 *
489  50 CONTINUE
490  anorm = ( rtovfl*ulp )*aninv
491  go to 70
492 *
493  60 CONTINUE
494  anorm = rtunfl*n*ulpinv
495  go to 70
496 *
497  70 CONTINUE
498 *
499  CALL claset( 'Full', lda, n, czero, czero, a, lda )
500  iinfo = 0
501  IF( jtype.LE.15 ) THEN
502  cond = ulpinv
503  ELSE
504  cond = ulpinv*aninv / ten
505  END IF
506 *
507 * Special Matrices -- Identity & Jordan block
508 *
509 * Zero
510 *
511  IF( itype.EQ.1 ) THEN
512  iinfo = 0
513 *
514  ELSE IF( itype.EQ.2 ) THEN
515 *
516 * Identity
517 *
518  DO 80 jcol = 1, n
519  a( k+1, jcol ) = anorm
520  80 CONTINUE
521 *
522  ELSE IF( itype.EQ.4 ) THEN
523 *
524 * Diagonal Matrix, [Eigen]values Specified
525 *
526  CALL clatms( n, n, 'S', iseed, 'H', rwork, imode,
527  $ cond, anorm, 0, 0, 'Q', a( k+1, 1 ), lda,
528  $ work, iinfo )
529 *
530  ELSE IF( itype.EQ.5 ) THEN
531 *
532 * Hermitian, eigenvalues specified
533 *
534  CALL clatms( n, n, 'S', iseed, 'H', rwork, imode,
535  $ cond, anorm, k, k, 'Q', a, lda, work,
536  $ iinfo )
537 *
538  ELSE IF( itype.EQ.7 ) THEN
539 *
540 * Diagonal, random eigenvalues
541 *
542  CALL clatmr( n, n, 'S', iseed, 'H', work, 6, one,
543  $ cone, 'T', 'N', work( n+1 ), 1, one,
544  $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
545  $ zero, anorm, 'Q', a( k+1, 1 ), lda,
546  $ idumma, iinfo )
547 *
548  ELSE IF( itype.EQ.8 ) THEN
549 *
550 * Hermitian, random eigenvalues
551 *
552  CALL clatmr( n, n, 'S', iseed, 'H', work, 6, one,
553  $ cone, 'T', 'N', work( n+1 ), 1, one,
554  $ work( 2*n+1 ), 1, one, 'N', idumma, k, k,
555  $ zero, anorm, 'Q', a, lda, idumma, iinfo )
556 *
557  ELSE IF( itype.EQ.9 ) THEN
558 *
559 * Positive definite, eigenvalues specified.
560 *
561  CALL clatms( n, n, 'S', iseed, 'P', rwork, imode,
562  $ cond, anorm, k, k, 'Q', a, lda,
563  $ work( n+1 ), iinfo )
564 *
565  ELSE IF( itype.EQ.10 ) THEN
566 *
567 * Positive definite tridiagonal, eigenvalues specified.
568 *
569  IF( n.GT.1 )
570  $ k = max( 1, k )
571  CALL clatms( n, n, 'S', iseed, 'P', rwork, imode,
572  $ cond, anorm, 1, 1, 'Q', a( k, 1 ), lda,
573  $ work, iinfo )
574  DO 90 i = 2, n
575  temp1 = abs( a( k, i ) ) /
576  $ sqrt( abs( a( k+1, i-1 )*a( k+1, i ) ) )
577  IF( temp1.GT.half ) THEN
578  a( k, i ) = half*sqrt( abs( a( k+1,
579  $ i-1 )*a( k+1, i ) ) )
580  END IF
581  90 CONTINUE
582 *
583  ELSE
584 *
585  iinfo = 1
586  END IF
587 *
588  IF( iinfo.NE.0 ) THEN
589  WRITE( nounit, fmt = 9999 )'Generator', iinfo, n,
590  $ jtype, ioldsd
591  info = abs( iinfo )
592  RETURN
593  END IF
594 *
595  100 CONTINUE
596 *
597 * Call CHBTRD to compute S and U from upper triangle.
598 *
599  CALL clacpy( ' ', k+1, n, a, lda, work, lda )
600 *
601  ntest = 1
602  CALL chbtrd( 'V', 'U', n, k, work, lda, sd, se, u, ldu,
603  $ work( lda*n+1 ), iinfo )
604 *
605  IF( iinfo.NE.0 ) THEN
606  WRITE( nounit, fmt = 9999 )'CHBTRD(U)', iinfo, n,
607  $ jtype, ioldsd
608  info = abs( iinfo )
609  IF( iinfo.LT.0 ) THEN
610  RETURN
611  ELSE
612  result( 1 ) = ulpinv
613  go to 150
614  END IF
615  END IF
616 *
617 * Do tests 1 and 2
618 *
619  CALL chbt21( 'Upper', n, k, 1, a, lda, sd, se, u, ldu,
620  $ work, rwork, result( 1 ) )
621 *
622 * Convert A from Upper-Triangle-Only storage to
623 * Lower-Triangle-Only storage.
624 *
625  DO 120 jc = 1, n
626  DO 110 jr = 0, min( k, n-jc )
627  a( jr+1, jc ) = conjg( a( k+1-jr, jc+jr ) )
628  110 CONTINUE
629  120 CONTINUE
630  DO 140 jc = n + 1 - k, n
631  DO 130 jr = min( k, n-jc ) + 1, k
632  a( jr+1, jc ) = zero
633  130 CONTINUE
634  140 CONTINUE
635 *
636 * Call CHBTRD to compute S and U from lower triangle
637 *
638  CALL clacpy( ' ', k+1, n, a, lda, work, lda )
639 *
640  ntest = 3
641  CALL chbtrd( 'V', 'L', n, k, work, lda, sd, se, u, ldu,
642  $ work( lda*n+1 ), iinfo )
643 *
644  IF( iinfo.NE.0 ) THEN
645  WRITE( nounit, fmt = 9999 )'CHBTRD(L)', iinfo, n,
646  $ jtype, ioldsd
647  info = abs( iinfo )
648  IF( iinfo.LT.0 ) THEN
649  RETURN
650  ELSE
651  result( 3 ) = ulpinv
652  go to 150
653  END IF
654  END IF
655  ntest = 4
656 *
657 * Do tests 3 and 4
658 *
659  CALL chbt21( 'Lower', n, k, 1, a, lda, sd, se, u, ldu,
660  $ work, rwork, result( 3 ) )
661 *
662 * End of Loop -- Check for RESULT(j) > THRESH
663 *
664  150 CONTINUE
665  ntestt = ntestt + ntest
666 *
667 * Print out tests which fail.
668 *
669  DO 160 jr = 1, ntest
670  IF( result( jr ).GE.thresh ) THEN
671 *
672 * If this is the first test to fail,
673 * print a header to the data file.
674 *
675  IF( nerrs.EQ.0 ) THEN
676  WRITE( nounit, fmt = 9998 )'CHB'
677  WRITE( nounit, fmt = 9997 )
678  WRITE( nounit, fmt = 9996 )
679  WRITE( nounit, fmt = 9995 )'Hermitian'
680  WRITE( nounit, fmt = 9994 )'unitary', '*',
681  $ 'conjugate transpose', ( '*', j = 1, 4 )
682  END IF
683  nerrs = nerrs + 1
684  WRITE( nounit, fmt = 9993 )n, k, ioldsd, jtype,
685  $ jr, result( jr )
686  END IF
687  160 CONTINUE
688 *
689  170 CONTINUE
690  180 CONTINUE
691  190 CONTINUE
692 *
693 * Summary
694 *
695  CALL slasum( 'CHB', nounit, nerrs, ntestt )
696  RETURN
697 *
698  9999 FORMAT( ' CCHKHB: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
699  $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
700  9998 FORMAT( / 1x, a3,
701  $ ' -- Complex Hermitian Banded Tridiagonal Reduction Routines'
702  $ )
703  9997 FORMAT( ' Matrix types (see SCHK23 for details): ' )
704 *
705  9996 FORMAT( / ' Special Matrices:',
706  $ / ' 1=Zero matrix. ',
707  $ ' 5=Diagonal: clustered entries.',
708  $ / ' 2=Identity matrix. ',
709  $ ' 6=Diagonal: large, evenly spaced.',
710  $ / ' 3=Diagonal: evenly spaced entries. ',
711  $ ' 7=Diagonal: small, evenly spaced.',
712  $ / ' 4=Diagonal: geometr. spaced entries.' )
713  9995 FORMAT( ' Dense ', a, ' Banded Matrices:',
714  $ / ' 8=Evenly spaced eigenvals. ',
715  $ ' 12=Small, evenly spaced eigenvals.',
716  $ / ' 9=Geometrically spaced eigenvals. ',
717  $ ' 13=Matrix with random O(1) entries.',
718  $ / ' 10=Clustered eigenvalues. ',
719  $ ' 14=Matrix with large random entries.',
720  $ / ' 11=Large, evenly spaced eigenvals. ',
721  $ ' 15=Matrix with small random entries.' )
722 *
723  9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', a, ',',
724  $ / 20x, a, ' means ', a, '.', / ' UPLO=''U'':',
725  $ / ' 1= | A - U S U', a1, ' | / ( |A| n ulp ) ',
726  $ ' 2= | I - U U', a1, ' | / ( n ulp )', / ' UPLO=''L'':',
727  $ / ' 3= | A - U S U', a1, ' | / ( |A| n ulp ) ',
728  $ ' 4= | I - U U', a1, ' | / ( n ulp )' )
729  9993 FORMAT( ' N=', i5, ', K=', i4, ', seed=', 4( i4, ',' ), ' type ',
730  $ i2, ', test(', i2, ')=', g10.3 )
731 *
732 * End of CCHKHB
733 *
734  END