LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
sdrvgb.f
Go to the documentation of this file.
1 *> \brief \b SDRVGB
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 SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
12 * AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
13 * RWORK, IWORK, NOUT )
14 *
15 * .. Scalar Arguments ..
16 * LOGICAL TSTERR
17 * INTEGER LA, LAFB, NN, NOUT, NRHS
18 * REAL THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER IWORK( * ), NVAL( * )
23 * REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
24 * $ RWORK( * ), S( * ), WORK( * ), X( * ),
25 * $ XACT( * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> SDRVGB tests the driver routines SGBSV and -SVX.
35 *> \endverbatim
36 *
37 * Arguments:
38 * ==========
39 *
40 *> \param[in] DOTYPE
41 *> \verbatim
42 *> DOTYPE is LOGICAL array, dimension (NTYPES)
43 *> The matrix types to be used for testing. Matrices of type j
44 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
45 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
46 *> \endverbatim
47 *>
48 *> \param[in] NN
49 *> \verbatim
50 *> NN is INTEGER
51 *> The number of values of N contained in the vector NVAL.
52 *> \endverbatim
53 *>
54 *> \param[in] NVAL
55 *> \verbatim
56 *> NVAL is INTEGER array, dimension (NN)
57 *> The values of the matrix column dimension N.
58 *> \endverbatim
59 *>
60 *> \param[in] NRHS
61 *> \verbatim
62 *> NRHS is INTEGER
63 *> The number of right hand side vectors to be generated for
64 *> each linear system.
65 *> \endverbatim
66 *>
67 *> \param[in] THRESH
68 *> \verbatim
69 *> THRESH is REAL
70 *> The threshold value for the test ratios. A result is
71 *> included in the output file if RESULT >= THRESH. To have
72 *> every test ratio printed, use THRESH = 0.
73 *> \endverbatim
74 *>
75 *> \param[in] TSTERR
76 *> \verbatim
77 *> TSTERR is LOGICAL
78 *> Flag that indicates whether error exits are to be tested.
79 *> \endverbatim
80 *>
81 *> \param[out] A
82 *> \verbatim
83 *> A is REAL array, dimension (LA)
84 *> \endverbatim
85 *>
86 *> \param[in] LA
87 *> \verbatim
88 *> LA is INTEGER
89 *> The length of the array A. LA >= (2*NMAX-1)*NMAX
90 *> where NMAX is the largest entry in NVAL.
91 *> \endverbatim
92 *>
93 *> \param[out] AFB
94 *> \verbatim
95 *> AFB is REAL array, dimension (LAFB)
96 *> \endverbatim
97 *>
98 *> \param[in] LAFB
99 *> \verbatim
100 *> LAFB is INTEGER
101 *> The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX
102 *> where NMAX is the largest entry in NVAL.
103 *> \endverbatim
104 *>
105 *> \param[out] ASAV
106 *> \verbatim
107 *> ASAV is REAL array, dimension (LA)
108 *> \endverbatim
109 *>
110 *> \param[out] B
111 *> \verbatim
112 *> B is REAL array, dimension (NMAX*NRHS)
113 *> \endverbatim
114 *>
115 *> \param[out] BSAV
116 *> \verbatim
117 *> BSAV is REAL array, dimension (NMAX*NRHS)
118 *> \endverbatim
119 *>
120 *> \param[out] X
121 *> \verbatim
122 *> X is REAL array, dimension (NMAX*NRHS)
123 *> \endverbatim
124 *>
125 *> \param[out] XACT
126 *> \verbatim
127 *> XACT is REAL array, dimension (NMAX*NRHS)
128 *> \endverbatim
129 *>
130 *> \param[out] S
131 *> \verbatim
132 *> S is REAL array, dimension (2*NMAX)
133 *> \endverbatim
134 *>
135 *> \param[out] WORK
136 *> \verbatim
137 *> WORK is REAL array, dimension
138 *> (NMAX*max(3,NRHS,NMAX))
139 *> \endverbatim
140 *>
141 *> \param[out] RWORK
142 *> \verbatim
143 *> RWORK is REAL array, dimension
144 *> (max(NMAX,2*NRHS))
145 *> \endverbatim
146 *>
147 *> \param[out] IWORK
148 *> \verbatim
149 *> IWORK is INTEGER array, dimension (2*NMAX)
150 *> \endverbatim
151 *>
152 *> \param[in] NOUT
153 *> \verbatim
154 *> NOUT is INTEGER
155 *> The unit number for output.
156 *> \endverbatim
157 *
158 * Authors:
159 * ========
160 *
161 *> \author Univ. of Tennessee
162 *> \author Univ. of California Berkeley
163 *> \author Univ. of Colorado Denver
164 *> \author NAG Ltd.
165 *
166 *> \date November 2011
167 *
168 *> \ingroup single_lin
169 *
170 * =====================================================================
171  SUBROUTINE sdrvgb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
172  $ afb, lafb, asav, b, bsav, x, xact, s, work,
173  $ rwork, iwork, nout )
174 *
175 * -- LAPACK test routine (version 3.4.0) --
176 * -- LAPACK is a software package provided by Univ. of Tennessee, --
177 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
178 * November 2011
179 *
180 * .. Scalar Arguments ..
181  LOGICAL tsterr
182  INTEGER la, lafb, nn, nout, nrhs
183  REAL thresh
184 * ..
185 * .. Array Arguments ..
186  LOGICAL dotype( * )
187  INTEGER iwork( * ), nval( * )
188  REAL a( * ), afb( * ), asav( * ), b( * ), bsav( * ),
189  $ rwork( * ), s( * ), work( * ), x( * ),
190  $ xact( * )
191 * ..
192 *
193 * =====================================================================
194 *
195 * .. Parameters ..
196  REAL one, zero
197  parameter( one = 1.0e+0, zero = 0.0e+0 )
198  INTEGER ntypes
199  parameter( ntypes = 8 )
200  INTEGER ntests
201  parameter( ntests = 7 )
202  INTEGER ntran
203  parameter( ntran = 3 )
204 * ..
205 * .. Local Scalars ..
206  LOGICAL equil, nofact, prefac, trfcon, zerot
207  CHARACTER dist, equed, fact, trans, type, xtype
208  CHARACTER*3 path
209  INTEGER i, i1, i2, iequed, ifact, ikl, iku, imat, in,
210  $ info, ioff, itran, izero, j, k, k1, kl, ku,
211  $ lda, ldafb, ldb, mode, n, nb, nbmin, nerrs,
212  $ nfact, nfail, nimat, nkl, nku, nrun, nt
213  REAL ainvnm, amax, anorm, anormi, anormo, anrmpv,
214  $ cndnum, colcnd, rcond, rcondc, rcondi, rcondo,
215  $ roldc, roldi, roldo, rowcnd, rpvgrw
216 * ..
217 * .. Local Arrays ..
218  CHARACTER equeds( 4 ), facts( 3 ), transs( ntran )
219  INTEGER iseed( 4 ), iseedy( 4 )
220  REAL result( ntests )
221 * ..
222 * .. External Functions ..
223  LOGICAL lsame
224  REAL sget06, slamch, slangb, slange, slantb
225  EXTERNAL lsame, sget06, slamch, slangb, slange, slantb
226 * ..
227 * .. External Subroutines ..
228  EXTERNAL aladhd, alaerh, alasvm, serrvx, sgbequ, sgbsv,
229  $ sgbsvx, sgbt01, sgbt02, sgbt05, sgbtrf, sgbtrs,
230  $ sget04, slacpy, slaqgb, slarhs, slaset, slatb4,
231  $ slatms, xlaenv
232 * ..
233 * .. Intrinsic Functions ..
234  INTRINSIC abs, max, min
235 * ..
236 * .. Scalars in Common ..
237  LOGICAL lerr, ok
238  CHARACTER*32 srnamt
239  INTEGER infot, nunit
240 * ..
241 * .. Common blocks ..
242  common / infoc / infot, nunit, ok, lerr
243  common / srnamc / srnamt
244 * ..
245 * .. Data statements ..
246  DATA iseedy / 1988, 1989, 1990, 1991 /
247  DATA transs / 'N', 'T', 'C' /
248  DATA facts / 'F', 'N', 'E' /
249  DATA equeds / 'N', 'R', 'C', 'B' /
250 * ..
251 * .. Executable Statements ..
252 *
253 * Initialize constants and the random number seed.
254 *
255  path( 1: 1 ) = 'Single precision'
256  path( 2: 3 ) = 'GB'
257  nrun = 0
258  nfail = 0
259  nerrs = 0
260  DO 10 i = 1, 4
261  iseed( i ) = iseedy( i )
262  10 continue
263 *
264 * Test the error exits
265 *
266  IF( tsterr )
267  $ CALL serrvx( path, nout )
268  infot = 0
269 *
270 * Set the block size and minimum block size for testing.
271 *
272  nb = 1
273  nbmin = 2
274  CALL xlaenv( 1, nb )
275  CALL xlaenv( 2, nbmin )
276 *
277 * Do for each value of N in NVAL
278 *
279  DO 150 in = 1, nn
280  n = nval( in )
281  ldb = max( n, 1 )
282  xtype = 'N'
283 *
284 * Set limits on the number of loop iterations.
285 *
286  nkl = max( 1, min( n, 4 ) )
287  IF( n.EQ.0 )
288  $ nkl = 1
289  nku = nkl
290  nimat = ntypes
291  IF( n.LE.0 )
292  $ nimat = 1
293 *
294  DO 140 ikl = 1, nkl
295 *
296 * Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes
297 * it easier to skip redundant values for small values of N.
298 *
299  IF( ikl.EQ.1 ) THEN
300  kl = 0
301  ELSE IF( ikl.EQ.2 ) THEN
302  kl = max( n-1, 0 )
303  ELSE IF( ikl.EQ.3 ) THEN
304  kl = ( 3*n-1 ) / 4
305  ELSE IF( ikl.EQ.4 ) THEN
306  kl = ( n+1 ) / 4
307  END IF
308  DO 130 iku = 1, nku
309 *
310 * Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order
311 * makes it easier to skip redundant values for small
312 * values of N.
313 *
314  IF( iku.EQ.1 ) THEN
315  ku = 0
316  ELSE IF( iku.EQ.2 ) THEN
317  ku = max( n-1, 0 )
318  ELSE IF( iku.EQ.3 ) THEN
319  ku = ( 3*n-1 ) / 4
320  ELSE IF( iku.EQ.4 ) THEN
321  ku = ( n+1 ) / 4
322  END IF
323 *
324 * Check that A and AFB are big enough to generate this
325 * matrix.
326 *
327  lda = kl + ku + 1
328  ldafb = 2*kl + ku + 1
329  IF( lda*n.GT.la .OR. ldafb*n.GT.lafb ) THEN
330  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
331  $ CALL aladhd( nout, path )
332  IF( lda*n.GT.la ) THEN
333  WRITE( nout, fmt = 9999 )la, n, kl, ku,
334  $ n*( kl+ku+1 )
335  nerrs = nerrs + 1
336  END IF
337  IF( ldafb*n.GT.lafb ) THEN
338  WRITE( nout, fmt = 9998 )lafb, n, kl, ku,
339  $ n*( 2*kl+ku+1 )
340  nerrs = nerrs + 1
341  END IF
342  go to 130
343  END IF
344 *
345  DO 120 imat = 1, nimat
346 *
347 * Do the tests only if DOTYPE( IMAT ) is true.
348 *
349  IF( .NOT.dotype( imat ) )
350  $ go to 120
351 *
352 * Skip types 2, 3, or 4 if the matrix is too small.
353 *
354  zerot = imat.GE.2 .AND. imat.LE.4
355  IF( zerot .AND. n.LT.imat-1 )
356  $ go to 120
357 *
358 * Set up parameters with SLATB4 and generate a
359 * test matrix with SLATMS.
360 *
361  CALL slatb4( path, imat, n, n, type, kl, ku, anorm,
362  $ mode, cndnum, dist )
363  rcondc = one / cndnum
364 *
365  srnamt = 'SLATMS'
366  CALL slatms( n, n, dist, iseed, type, rwork, mode,
367  $ cndnum, anorm, kl, ku, 'Z', a, lda, work,
368  $ info )
369 *
370 * Check the error code from SLATMS.
371 *
372  IF( info.NE.0 ) THEN
373  CALL alaerh( path, 'SLATMS', info, 0, ' ', n, n,
374  $ kl, ku, -1, imat, nfail, nerrs, nout )
375  go to 120
376  END IF
377 *
378 * For types 2, 3, and 4, zero one or more columns of
379 * the matrix to test that INFO is returned correctly.
380 *
381  izero = 0
382  IF( zerot ) THEN
383  IF( imat.EQ.2 ) THEN
384  izero = 1
385  ELSE IF( imat.EQ.3 ) THEN
386  izero = n
387  ELSE
388  izero = n / 2 + 1
389  END IF
390  ioff = ( izero-1 )*lda
391  IF( imat.LT.4 ) THEN
392  i1 = max( 1, ku+2-izero )
393  i2 = min( kl+ku+1, ku+1+( n-izero ) )
394  DO 20 i = i1, i2
395  a( ioff+i ) = zero
396  20 continue
397  ELSE
398  DO 40 j = izero, n
399  DO 30 i = max( 1, ku+2-j ),
400  $ min( kl+ku+1, ku+1+( n-j ) )
401  a( ioff+i ) = zero
402  30 continue
403  ioff = ioff + lda
404  40 continue
405  END IF
406  END IF
407 *
408 * Save a copy of the matrix A in ASAV.
409 *
410  CALL slacpy( 'Full', kl+ku+1, n, a, lda, asav, lda )
411 *
412  DO 110 iequed = 1, 4
413  equed = equeds( iequed )
414  IF( iequed.EQ.1 ) THEN
415  nfact = 3
416  ELSE
417  nfact = 1
418  END IF
419 *
420  DO 100 ifact = 1, nfact
421  fact = facts( ifact )
422  prefac = lsame( fact, 'F' )
423  nofact = lsame( fact, 'N' )
424  equil = lsame( fact, 'E' )
425 *
426  IF( zerot ) THEN
427  IF( prefac )
428  $ go to 100
429  rcondo = zero
430  rcondi = zero
431 *
432  ELSE IF( .NOT.nofact ) THEN
433 *
434 * Compute the condition number for comparison
435 * with the value returned by SGESVX (FACT =
436 * 'N' reuses the condition number from the
437 * previous iteration with FACT = 'F').
438 *
439  CALL slacpy( 'Full', kl+ku+1, n, asav, lda,
440  $ afb( kl+1 ), ldafb )
441  IF( equil .OR. iequed.GT.1 ) THEN
442 *
443 * Compute row and column scale factors to
444 * equilibrate the matrix A.
445 *
446  CALL sgbequ( n, n, kl, ku, afb( kl+1 ),
447  $ ldafb, s, s( n+1 ), rowcnd,
448  $ colcnd, amax, info )
449  IF( info.EQ.0 .AND. n.GT.0 ) THEN
450  IF( lsame( equed, 'R' ) ) THEN
451  rowcnd = zero
452  colcnd = one
453  ELSE IF( lsame( equed, 'C' ) ) THEN
454  rowcnd = one
455  colcnd = zero
456  ELSE IF( lsame( equed, 'B' ) ) THEN
457  rowcnd = zero
458  colcnd = zero
459  END IF
460 *
461 * Equilibrate the matrix.
462 *
463  CALL slaqgb( n, n, kl, ku, afb( kl+1 ),
464  $ ldafb, s, s( n+1 ),
465  $ rowcnd, colcnd, amax,
466  $ equed )
467  END IF
468  END IF
469 *
470 * Save the condition number of the
471 * non-equilibrated system for use in SGET04.
472 *
473  IF( equil ) THEN
474  roldo = rcondo
475  roldi = rcondi
476  END IF
477 *
478 * Compute the 1-norm and infinity-norm of A.
479 *
480  anormo = slangb( '1', n, kl, ku, afb( kl+1 ),
481  $ ldafb, rwork )
482  anormi = slangb( 'I', n, kl, ku, afb( kl+1 ),
483  $ ldafb, rwork )
484 *
485 * Factor the matrix A.
486 *
487  CALL sgbtrf( n, n, kl, ku, afb, ldafb, iwork,
488  $ info )
489 *
490 * Form the inverse of A.
491 *
492  CALL slaset( 'Full', n, n, zero, one, work,
493  $ ldb )
494  srnamt = 'SGBTRS'
495  CALL sgbtrs( 'No transpose', n, kl, ku, n,
496  $ afb, ldafb, iwork, work, ldb,
497  $ info )
498 *
499 * Compute the 1-norm condition number of A.
500 *
501  ainvnm = slange( '1', n, n, work, ldb,
502  $ rwork )
503  IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
504  rcondo = one
505  ELSE
506  rcondo = ( one / anormo ) / ainvnm
507  END IF
508 *
509 * Compute the infinity-norm condition number
510 * of A.
511 *
512  ainvnm = slange( 'I', n, n, work, ldb,
513  $ rwork )
514  IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
515  rcondi = one
516  ELSE
517  rcondi = ( one / anormi ) / ainvnm
518  END IF
519  END IF
520 *
521  DO 90 itran = 1, ntran
522 *
523 * Do for each value of TRANS.
524 *
525  trans = transs( itran )
526  IF( itran.EQ.1 ) THEN
527  rcondc = rcondo
528  ELSE
529  rcondc = rcondi
530  END IF
531 *
532 * Restore the matrix A.
533 *
534  CALL slacpy( 'Full', kl+ku+1, n, asav, lda,
535  $ a, lda )
536 *
537 * Form an exact solution and set the right hand
538 * side.
539 *
540  srnamt = 'SLARHS'
541  CALL slarhs( path, xtype, 'Full', trans, n,
542  $ n, kl, ku, nrhs, a, lda, xact,
543  $ ldb, b, ldb, iseed, info )
544  xtype = 'C'
545  CALL slacpy( 'Full', n, nrhs, b, ldb, bsav,
546  $ ldb )
547 *
548  IF( nofact .AND. itran.EQ.1 ) THEN
549 *
550 * --- Test SGBSV ---
551 *
552 * Compute the LU factorization of the matrix
553 * and solve the system.
554 *
555  CALL slacpy( 'Full', kl+ku+1, n, a, lda,
556  $ afb( kl+1 ), ldafb )
557  CALL slacpy( 'Full', n, nrhs, b, ldb, x,
558  $ ldb )
559 *
560  srnamt = 'SGBSV '
561  CALL sgbsv( n, kl, ku, nrhs, afb, ldafb,
562  $ iwork, x, ldb, info )
563 *
564 * Check error code from SGBSV .
565 *
566  IF( info.NE.izero )
567  $ CALL alaerh( path, 'SGBSV ', info,
568  $ izero, ' ', n, n, kl, ku,
569  $ nrhs, imat, nfail, nerrs,
570  $ nout )
571 *
572 * Reconstruct matrix from factors and
573 * compute residual.
574 *
575  CALL sgbt01( n, n, kl, ku, a, lda, afb,
576  $ ldafb, iwork, work,
577  $ result( 1 ) )
578  nt = 1
579  IF( izero.EQ.0 ) THEN
580 *
581 * Compute residual of the computed
582 * solution.
583 *
584  CALL slacpy( 'Full', n, nrhs, b, ldb,
585  $ work, ldb )
586  CALL sgbt02( 'No transpose', n, n, kl,
587  $ ku, nrhs, a, lda, x, ldb,
588  $ work, ldb, result( 2 ) )
589 *
590 * Check solution from generated exact
591 * solution.
592 *
593  CALL sget04( n, nrhs, x, ldb, xact,
594  $ ldb, rcondc, result( 3 ) )
595  nt = 3
596  END IF
597 *
598 * Print information about the tests that did
599 * not pass the threshold.
600 *
601  DO 50 k = 1, nt
602  IF( result( k ).GE.thresh ) THEN
603  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
604  $ CALL aladhd( nout, path )
605  WRITE( nout, fmt = 9997 )'SGBSV ',
606  $ n, kl, ku, imat, k, result( k )
607  nfail = nfail + 1
608  END IF
609  50 continue
610  nrun = nrun + nt
611  END IF
612 *
613 * --- Test SGBSVX ---
614 *
615  IF( .NOT.prefac )
616  $ CALL slaset( 'Full', 2*kl+ku+1, n, zero,
617  $ zero, afb, ldafb )
618  CALL slaset( 'Full', n, nrhs, zero, zero, x,
619  $ ldb )
620  IF( iequed.GT.1 .AND. n.GT.0 ) THEN
621 *
622 * Equilibrate the matrix if FACT = 'F' and
623 * EQUED = 'R', 'C', or 'B'.
624 *
625  CALL slaqgb( n, n, kl, ku, a, lda, s,
626  $ s( n+1 ), rowcnd, colcnd,
627  $ amax, equed )
628  END IF
629 *
630 * Solve the system and compute the condition
631 * number and error bounds using SGBSVX.
632 *
633  srnamt = 'SGBSVX'
634  CALL sgbsvx( fact, trans, n, kl, ku, nrhs, a,
635  $ lda, afb, ldafb, iwork, equed,
636  $ s, s( n+1 ), b, ldb, x, ldb,
637  $ rcond, rwork, rwork( nrhs+1 ),
638  $ work, iwork( n+1 ), info )
639 *
640 * Check the error code from SGBSVX.
641 *
642  IF( info.NE.izero )
643  $ CALL alaerh( path, 'SGBSVX', info, izero,
644  $ fact // trans, n, n, kl, ku,
645  $ nrhs, imat, nfail, nerrs,
646  $ nout )
647 *
648 * Compare WORK(1) from SGBSVX with the computed
649 * reciprocal pivot growth factor RPVGRW
650 *
651  IF( info.NE.0 .AND. info.LE.n) THEN
652  anrmpv = zero
653  DO 70 j = 1, info
654  DO 60 i = max( ku+2-j, 1 ),
655  $ min( n+ku+1-j, kl+ku+1 )
656  anrmpv = max( anrmpv,
657  $ abs( a( i+( j-1 )*lda ) ) )
658  60 continue
659  70 continue
660  rpvgrw = slantb( 'M', 'U', 'N', info,
661  $ min( info-1, kl+ku ),
662  $ afb( max( 1, kl+ku+2-info ) ),
663  $ ldafb, work )
664  IF( rpvgrw.EQ.zero ) THEN
665  rpvgrw = one
666  ELSE
667  rpvgrw = anrmpv / rpvgrw
668  END IF
669  ELSE
670  rpvgrw = slantb( 'M', 'U', 'N', n, kl+ku,
671  $ afb, ldafb, work )
672  IF( rpvgrw.EQ.zero ) THEN
673  rpvgrw = one
674  ELSE
675  rpvgrw = slangb( 'M', n, kl, ku, a,
676  $ lda, work ) / rpvgrw
677  END IF
678  END IF
679  result( 7 ) = abs( rpvgrw-work( 1 ) ) /
680  $ max( work( 1 ), rpvgrw ) /
681  $ slamch( 'E' )
682 *
683  IF( .NOT.prefac ) THEN
684 *
685 * Reconstruct matrix from factors and
686 * compute residual.
687 *
688  CALL sgbt01( n, n, kl, ku, a, lda, afb,
689  $ ldafb, iwork, work,
690  $ result( 1 ) )
691  k1 = 1
692  ELSE
693  k1 = 2
694  END IF
695 *
696  IF( info.EQ.0 ) THEN
697  trfcon = .false.
698 *
699 * Compute residual of the computed solution.
700 *
701  CALL slacpy( 'Full', n, nrhs, bsav, ldb,
702  $ work, ldb )
703  CALL sgbt02( trans, n, n, kl, ku, nrhs,
704  $ asav, lda, x, ldb, work, ldb,
705  $ result( 2 ) )
706 *
707 * Check solution from generated exact
708 * solution.
709 *
710  IF( nofact .OR. ( prefac .AND.
711  $ lsame( equed, 'N' ) ) ) THEN
712  CALL sget04( n, nrhs, x, ldb, xact,
713  $ ldb, rcondc, result( 3 ) )
714  ELSE
715  IF( itran.EQ.1 ) THEN
716  roldc = roldo
717  ELSE
718  roldc = roldi
719  END IF
720  CALL sget04( n, nrhs, x, ldb, xact,
721  $ ldb, roldc, result( 3 ) )
722  END IF
723 *
724 * Check the error bounds from iterative
725 * refinement.
726 *
727  CALL sgbt05( trans, n, kl, ku, nrhs, asav,
728  $ lda, b, ldb, x, ldb, xact,
729  $ ldb, rwork, rwork( nrhs+1 ),
730  $ result( 4 ) )
731  ELSE
732  trfcon = .true.
733  END IF
734 *
735 * Compare RCOND from SGBSVX with the computed
736 * value in RCONDC.
737 *
738  result( 6 ) = sget06( rcond, rcondc )
739 *
740 * Print information about the tests that did
741 * not pass the threshold.
742 *
743  IF( .NOT.trfcon ) THEN
744  DO 80 k = k1, ntests
745  IF( result( k ).GE.thresh ) THEN
746  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
747  $ CALL aladhd( nout, path )
748  IF( prefac ) THEN
749  WRITE( nout, fmt = 9995 )
750  $ 'SGBSVX', fact, trans, n, kl,
751  $ ku, equed, imat, k,
752  $ result( k )
753  ELSE
754  WRITE( nout, fmt = 9996 )
755  $ 'SGBSVX', fact, trans, n, kl,
756  $ ku, imat, k, result( k )
757  END IF
758  nfail = nfail + 1
759  END IF
760  80 continue
761  nrun = nrun + 7 - k1
762  ELSE
763  IF( result( 1 ).GE.thresh .AND. .NOT.
764  $ prefac ) THEN
765  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
766  $ CALL aladhd( nout, path )
767  IF( prefac ) THEN
768  WRITE( nout, fmt = 9995 )'SGBSVX',
769  $ fact, trans, n, kl, ku, equed,
770  $ imat, 1, result( 1 )
771  ELSE
772  WRITE( nout, fmt = 9996 )'SGBSVX',
773  $ fact, trans, n, kl, ku, imat, 1,
774  $ result( 1 )
775  END IF
776  nfail = nfail + 1
777  nrun = nrun + 1
778  END IF
779  IF( result( 6 ).GE.thresh ) THEN
780  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
781  $ CALL aladhd( nout, path )
782  IF( prefac ) THEN
783  WRITE( nout, fmt = 9995 )'SGBSVX',
784  $ fact, trans, n, kl, ku, equed,
785  $ imat, 6, result( 6 )
786  ELSE
787  WRITE( nout, fmt = 9996 )'SGBSVX',
788  $ fact, trans, n, kl, ku, imat, 6,
789  $ result( 6 )
790  END IF
791  nfail = nfail + 1
792  nrun = nrun + 1
793  END IF
794  IF( result( 7 ).GE.thresh ) THEN
795  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
796  $ CALL aladhd( nout, path )
797  IF( prefac ) THEN
798  WRITE( nout, fmt = 9995 )'SGBSVX',
799  $ fact, trans, n, kl, ku, equed,
800  $ imat, 7, result( 7 )
801  ELSE
802  WRITE( nout, fmt = 9996 )'SGBSVX',
803  $ fact, trans, n, kl, ku, imat, 7,
804  $ result( 7 )
805  END IF
806  nfail = nfail + 1
807  nrun = nrun + 1
808  END IF
809 *
810  END IF
811  90 continue
812  100 continue
813  110 continue
814  120 continue
815  130 continue
816  140 continue
817  150 continue
818 *
819 * Print a summary of the results.
820 *
821  CALL alasvm( path, nout, nfail, nrun, nerrs )
822 *
823  9999 format( ' *** In SDRVGB, LA=', i5, ' is too small for N=', i5,
824  $ ', KU=', i5, ', KL=', i5, / ' ==> Increase LA to at least ',
825  $ i5 )
826  9998 format( ' *** In SDRVGB, LAFB=', i5, ' is too small for N=', i5,
827  $ ', KU=', i5, ', KL=', i5, /
828  $ ' ==> Increase LAFB to at least ', i5 )
829  9997 format( 1x, a, ', N=', i5, ', KL=', i5, ', KU=', i5, ', type ',
830  $ i1, ', test(', i1, ')=', g12.5 )
831  9996 format( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
832  $ i5, ',...), type ', i1, ', test(', i1, ')=', g12.5 )
833  9995 format( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
834  $ i5, ',...), EQUED=''', a1, ''', type ', i1, ', test(', i1,
835  $ ')=', g12.5 )
836 *
837  return
838 *
839 * End of SDRVGB
840 *
841  END