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