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