LAPACK  3.9.1
LAPACK: Linear Algebra PACKage
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 *> \ingroup double_lin
170 *
171 * =====================================================================
172  SUBROUTINE ddrvgb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
173  $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
174  $ RWORK, IWORK, NOUT )
175 *
176 * -- LAPACK test routine --
177 * -- LAPACK is a software package provided by Univ. of Tennessee, --
178 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
179 *
180 * .. Scalar Arguments ..
181  LOGICAL TSTERR
182  INTEGER LA, LAFB, NN, NOUT, NRHS
183  DOUBLE PRECISION THRESH
184 * ..
185 * .. Array Arguments ..
186  LOGICAL DOTYPE( * )
187  INTEGER IWORK( * ), NVAL( * )
188  DOUBLE PRECISION A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
189  $ rwork( * ), s( * ), work( * ), x( * ),
190  $ xact( * )
191 * ..
192 *
193 * =====================================================================
194 *
195 * .. Parameters ..
196  DOUBLE PRECISION ONE, ZERO
197  PARAMETER ( ONE = 1.0d+0, zero = 0.0d+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  $ n_err_bnds
214  DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
215  $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
216  $ roldc, roldi, roldo, rowcnd, rpvgrw,
217  $ rpvgrw_svxx
218 * ..
219 * .. Local Arrays ..
220  CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
221  INTEGER ISEED( 4 ), ISEEDY( 4 )
222  DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ),
223  $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
224 * ..
225 * .. External Functions ..
226  LOGICAL LSAME
227  DOUBLE PRECISION DGET06, DLAMCH, DLANGB, DLANGE, DLANTB,
228  $ dla_gbrpvgrw
229  EXTERNAL lsame, dget06, dlamch, dlangb, dlange, dlantb,
230  $ dla_gbrpvgrw
231 * ..
232 * .. External Subroutines ..
233  EXTERNAL aladhd, alaerh, alasvm, derrvx, dgbequ, dgbsv,
234  $ dgbsvx, dgbt01, dgbt02, dgbt05, dgbtrf, dgbtrs,
235  $ dget04, dlacpy, dlaqgb, dlarhs, dlaset, dlatb4,
236  $ dlatms, xlaenv, dgbsvxx, dgbequb
237 * ..
238 * .. Intrinsic Functions ..
239  INTRINSIC abs, max, min
240 * ..
241 * .. Scalars in Common ..
242  LOGICAL LERR, OK
243  CHARACTER*32 SRNAMT
244  INTEGER INFOT, NUNIT
245 * ..
246 * .. Common blocks ..
247  COMMON / infoc / infot, nunit, ok, lerr
248  COMMON / srnamc / srnamt
249 * ..
250 * .. Data statements ..
251  DATA iseedy / 1988, 1989, 1990, 1991 /
252  DATA transs / 'N', 'T', 'C' /
253  DATA facts / 'F', 'N', 'E' /
254  DATA equeds / 'N', 'R', 'C', 'B' /
255 * ..
256 * .. Executable Statements ..
257 *
258 * Initialize constants and the random number seed.
259 *
260  path( 1: 1 ) = 'Double precision'
261  path( 2: 3 ) = 'GB'
262  nrun = 0
263  nfail = 0
264  nerrs = 0
265  DO 10 i = 1, 4
266  iseed( i ) = iseedy( i )
267  10 CONTINUE
268 *
269 * Test the error exits
270 *
271  IF( tsterr )
272  $ CALL derrvx( path, nout )
273  infot = 0
274 *
275 * Set the block size and minimum block size for testing.
276 *
277  nb = 1
278  nbmin = 2
279  CALL xlaenv( 1, nb )
280  CALL xlaenv( 2, nbmin )
281 *
282 * Do for each value of N in NVAL
283 *
284  DO 150 in = 1, nn
285  n = nval( in )
286  ldb = max( n, 1 )
287  xtype = 'N'
288 *
289 * Set limits on the number of loop iterations.
290 *
291  nkl = max( 1, min( n, 4 ) )
292  IF( n.EQ.0 )
293  $ nkl = 1
294  nku = nkl
295  nimat = ntypes
296  IF( n.LE.0 )
297  $ nimat = 1
298 *
299  DO 140 ikl = 1, nkl
300 *
301 * Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes
302 * it easier to skip redundant values for small values of N.
303 *
304  IF( ikl.EQ.1 ) THEN
305  kl = 0
306  ELSE IF( ikl.EQ.2 ) THEN
307  kl = max( n-1, 0 )
308  ELSE IF( ikl.EQ.3 ) THEN
309  kl = ( 3*n-1 ) / 4
310  ELSE IF( ikl.EQ.4 ) THEN
311  kl = ( n+1 ) / 4
312  END IF
313  DO 130 iku = 1, nku
314 *
315 * Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order
316 * makes it easier to skip redundant values for small
317 * values of N.
318 *
319  IF( iku.EQ.1 ) THEN
320  ku = 0
321  ELSE IF( iku.EQ.2 ) THEN
322  ku = max( n-1, 0 )
323  ELSE IF( iku.EQ.3 ) THEN
324  ku = ( 3*n-1 ) / 4
325  ELSE IF( iku.EQ.4 ) THEN
326  ku = ( n+1 ) / 4
327  END IF
328 *
329 * Check that A and AFB are big enough to generate this
330 * matrix.
331 *
332  lda = kl + ku + 1
333  ldafb = 2*kl + ku + 1
334  IF( lda*n.GT.la .OR. ldafb*n.GT.lafb ) THEN
335  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
336  $ CALL aladhd( nout, path )
337  IF( lda*n.GT.la ) THEN
338  WRITE( nout, fmt = 9999 )la, n, kl, ku,
339  $ n*( kl+ku+1 )
340  nerrs = nerrs + 1
341  END IF
342  IF( ldafb*n.GT.lafb ) THEN
343  WRITE( nout, fmt = 9998 )lafb, n, kl, ku,
344  $ n*( 2*kl+ku+1 )
345  nerrs = nerrs + 1
346  END IF
347  GO TO 130
348  END IF
349 *
350  DO 120 imat = 1, nimat
351 *
352 * Do the tests only if DOTYPE( IMAT ) is true.
353 *
354  IF( .NOT.dotype( imat ) )
355  $ GO TO 120
356 *
357 * Skip types 2, 3, or 4 if the matrix is too small.
358 *
359  zerot = imat.GE.2 .AND. imat.LE.4
360  IF( zerot .AND. n.LT.imat-1 )
361  $ GO TO 120
362 *
363 * Set up parameters with DLATB4 and generate a
364 * test matrix with DLATMS.
365 *
366  CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
367  $ MODE, CNDNUM, DIST )
368  rcondc = one / cndnum
369 *
370  srnamt = 'DLATMS'
371  CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
372  $ cndnum, anorm, kl, ku, 'Z', a, lda, work,
373  $ info )
374 *
375 * Check the error code from DLATMS.
376 *
377  IF( info.NE.0 ) THEN
378  CALL alaerh( path, 'DLATMS', info, 0, ' ', n, n,
379  $ kl, ku, -1, imat, nfail, nerrs, nout )
380  GO TO 120
381  END IF
382 *
383 * For types 2, 3, and 4, zero one or more columns of
384 * the matrix to test that INFO is returned correctly.
385 *
386  izero = 0
387  IF( zerot ) THEN
388  IF( imat.EQ.2 ) THEN
389  izero = 1
390  ELSE IF( imat.EQ.3 ) THEN
391  izero = n
392  ELSE
393  izero = n / 2 + 1
394  END IF
395  ioff = ( izero-1 )*lda
396  IF( imat.LT.4 ) THEN
397  i1 = max( 1, ku+2-izero )
398  i2 = min( kl+ku+1, ku+1+( n-izero ) )
399  DO 20 i = i1, i2
400  a( ioff+i ) = zero
401  20 CONTINUE
402  ELSE
403  DO 40 j = izero, n
404  DO 30 i = max( 1, ku+2-j ),
405  $ min( kl+ku+1, ku+1+( n-j ) )
406  a( ioff+i ) = zero
407  30 CONTINUE
408  ioff = ioff + lda
409  40 CONTINUE
410  END IF
411  END IF
412 *
413 * Save a copy of the matrix A in ASAV.
414 *
415  CALL dlacpy( 'Full', kl+ku+1, n, a, lda, asav, lda )
416 *
417  DO 110 iequed = 1, 4
418  equed = equeds( iequed )
419  IF( iequed.EQ.1 ) THEN
420  nfact = 3
421  ELSE
422  nfact = 1
423  END IF
424 *
425  DO 100 ifact = 1, nfact
426  fact = facts( ifact )
427  prefac = lsame( fact, 'F' )
428  nofact = lsame( fact, 'N' )
429  equil = lsame( fact, 'E' )
430 *
431  IF( zerot ) THEN
432  IF( prefac )
433  $ GO TO 100
434  rcondo = zero
435  rcondi = zero
436 *
437  ELSE IF( .NOT.nofact ) THEN
438 *
439 * Compute the condition number for comparison
440 * with the value returned by DGESVX (FACT =
441 * 'N' reuses the condition number from the
442 * previous iteration with FACT = 'F').
443 *
444  CALL dlacpy( 'Full', kl+ku+1, n, asav, lda,
445  $ afb( kl+1 ), ldafb )
446  IF( equil .OR. iequed.GT.1 ) THEN
447 *
448 * Compute row and column scale factors to
449 * equilibrate the matrix A.
450 *
451  CALL dgbequ( n, n, kl, ku, afb( kl+1 ),
452  $ ldafb, s, s( n+1 ), rowcnd,
453  $ colcnd, amax, info )
454  IF( info.EQ.0 .AND. n.GT.0 ) THEN
455  IF( lsame( equed, 'R' ) ) THEN
456  rowcnd = zero
457  colcnd = one
458  ELSE IF( lsame( equed, 'C' ) ) THEN
459  rowcnd = one
460  colcnd = zero
461  ELSE IF( lsame( equed, 'B' ) ) THEN
462  rowcnd = zero
463  colcnd = zero
464  END IF
465 *
466 * Equilibrate the matrix.
467 *
468  CALL dlaqgb( n, n, kl, ku, afb( kl+1 ),
469  $ ldafb, s, s( n+1 ),
470  $ rowcnd, colcnd, amax,
471  $ equed )
472  END IF
473  END IF
474 *
475 * Save the condition number of the
476 * non-equilibrated system for use in DGET04.
477 *
478  IF( equil ) THEN
479  roldo = rcondo
480  roldi = rcondi
481  END IF
482 *
483 * Compute the 1-norm and infinity-norm of A.
484 *
485  anormo = dlangb( '1', n, kl, ku, afb( kl+1 ),
486  $ ldafb, rwork )
487  anormi = dlangb( 'I', n, kl, ku, afb( kl+1 ),
488  $ ldafb, rwork )
489 *
490 * Factor the matrix A.
491 *
492  CALL dgbtrf( n, n, kl, ku, afb, ldafb, iwork,
493  $ info )
494 *
495 * Form the inverse of A.
496 *
497  CALL dlaset( 'Full', n, n, zero, one, work,
498  $ ldb )
499  srnamt = 'DGBTRS'
500  CALL dgbtrs( 'No transpose', n, kl, ku, n,
501  $ afb, ldafb, iwork, work, ldb,
502  $ info )
503 *
504 * Compute the 1-norm condition number of A.
505 *
506  ainvnm = dlange( '1', n, n, work, ldb,
507  $ rwork )
508  IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
509  rcondo = one
510  ELSE
511  rcondo = ( one / anormo ) / ainvnm
512  END IF
513 *
514 * Compute the infinity-norm condition number
515 * of A.
516 *
517  ainvnm = dlange( 'I', n, n, work, ldb,
518  $ rwork )
519  IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
520  rcondi = one
521  ELSE
522  rcondi = ( one / anormi ) / ainvnm
523  END IF
524  END IF
525 *
526  DO 90 itran = 1, ntran
527 *
528 * Do for each value of TRANS.
529 *
530  trans = transs( itran )
531  IF( itran.EQ.1 ) THEN
532  rcondc = rcondo
533  ELSE
534  rcondc = rcondi
535  END IF
536 *
537 * Restore the matrix A.
538 *
539  CALL dlacpy( 'Full', kl+ku+1, n, asav, lda,
540  $ a, lda )
541 *
542 * Form an exact solution and set the right hand
543 * side.
544 *
545  srnamt = 'DLARHS'
546  CALL dlarhs( path, xtype, 'Full', trans, n,
547  $ n, kl, ku, nrhs, a, lda, xact,
548  $ ldb, b, ldb, iseed, info )
549  xtype = 'C'
550  CALL dlacpy( 'Full', n, nrhs, b, ldb, bsav,
551  $ ldb )
552 *
553  IF( nofact .AND. itran.EQ.1 ) THEN
554 *
555 * --- Test DGBSV ---
556 *
557 * Compute the LU factorization of the matrix
558 * and solve the system.
559 *
560  CALL dlacpy( 'Full', kl+ku+1, n, a, lda,
561  $ afb( kl+1 ), ldafb )
562  CALL dlacpy( 'Full', n, nrhs, b, ldb, x,
563  $ ldb )
564 *
565  srnamt = 'DGBSV '
566  CALL dgbsv( n, kl, ku, nrhs, afb, ldafb,
567  $ iwork, x, ldb, info )
568 *
569 * Check error code from DGBSV .
570 *
571  IF( info.NE.izero )
572  $ CALL alaerh( path, 'DGBSV ', info,
573  $ izero, ' ', n, n, kl, ku,
574  $ nrhs, imat, nfail, nerrs,
575  $ nout )
576 *
577 * Reconstruct matrix from factors and
578 * compute residual.
579 *
580  CALL dgbt01( n, n, kl, ku, a, lda, afb,
581  $ ldafb, iwork, work,
582  $ result( 1 ) )
583  nt = 1
584  IF( izero.EQ.0 ) THEN
585 *
586 * Compute residual of the computed
587 * solution.
588 *
589  CALL dlacpy( 'Full', n, nrhs, b, ldb,
590  $ work, ldb )
591  CALL dgbt02( 'No transpose', n, n, kl,
592  $ ku, nrhs, a, lda, x, ldb,
593  $ work, ldb, result( 2 ) )
594 *
595 * Check solution from generated exact
596 * solution.
597 *
598  CALL dget04( n, nrhs, x, ldb, xact,
599  $ ldb, rcondc, result( 3 ) )
600  nt = 3
601  END IF
602 *
603 * Print information about the tests that did
604 * not pass the threshold.
605 *
606  DO 50 k = 1, nt
607  IF( result( k ).GE.thresh ) THEN
608  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
609  $ CALL aladhd( nout, path )
610  WRITE( nout, fmt = 9997 )'DGBSV ',
611  $ n, kl, ku, imat, k, result( k )
612  nfail = nfail + 1
613  END IF
614  50 CONTINUE
615  nrun = nrun + nt
616  END IF
617 *
618 * --- Test DGBSVX ---
619 *
620  IF( .NOT.prefac )
621  $ CALL dlaset( 'Full', 2*kl+ku+1, n, zero,
622  $ zero, afb, ldafb )
623  CALL dlaset( 'Full', n, nrhs, zero, zero, x,
624  $ ldb )
625  IF( iequed.GT.1 .AND. n.GT.0 ) THEN
626 *
627 * Equilibrate the matrix if FACT = 'F' and
628 * EQUED = 'R', 'C', or 'B'.
629 *
630  CALL dlaqgb( n, n, kl, ku, a, lda, s,
631  $ s( n+1 ), rowcnd, colcnd,
632  $ amax, equed )
633  END IF
634 *
635 * Solve the system and compute the condition
636 * number and error bounds using DGBSVX.
637 *
638  srnamt = 'DGBSVX'
639  CALL dgbsvx( fact, trans, n, kl, ku, nrhs, a,
640  $ lda, afb, ldafb, iwork, equed,
641  $ s, s( n+1 ), b, ldb, x, ldb,
642  $ rcond, rwork, rwork( nrhs+1 ),
643  $ work, iwork( n+1 ), info )
644 *
645 * Check the error code from DGBSVX.
646 *
647  IF( info.NE.izero )
648  $ CALL alaerh( path, 'DGBSVX', info, izero,
649  $ fact // trans, n, n, kl, ku,
650  $ nrhs, imat, nfail, nerrs,
651  $ nout )
652 *
653 * Compare WORK(1) from DGBSVX with the computed
654 * reciprocal pivot growth factor RPVGRW
655 *
656  IF( info.NE.0 ) THEN
657  anrmpv = zero
658  DO 70 j = 1, info
659  DO 60 i = max( ku+2-j, 1 ),
660  $ min( n+ku+1-j, kl+ku+1 )
661  anrmpv = max( anrmpv,
662  $ abs( a( i+( j-1 )*lda ) ) )
663  60 CONTINUE
664  70 CONTINUE
665  rpvgrw = dlantb( 'M', 'U', 'N', info,
666  $ min( info-1, kl+ku ),
667  $ afb( max( 1, kl+ku+2-info ) ),
668  $ ldafb, work )
669  IF( rpvgrw.EQ.zero ) THEN
670  rpvgrw = one
671  ELSE
672  rpvgrw = anrmpv / rpvgrw
673  END IF
674  ELSE
675  rpvgrw = dlantb( 'M', 'U', 'N', n, kl+ku,
676  $ afb, ldafb, work )
677  IF( rpvgrw.EQ.zero ) THEN
678  rpvgrw = one
679  ELSE
680  rpvgrw = dlangb( 'M', n, kl, ku, a,
681  $ lda, work ) / rpvgrw
682  END IF
683  END IF
684  result( 7 ) = abs( rpvgrw-work( 1 ) ) /
685  $ max( work( 1 ), rpvgrw ) /
686  $ dlamch( 'E' )
687 *
688  IF( .NOT.prefac ) THEN
689 *
690 * Reconstruct matrix from factors and
691 * compute residual.
692 *
693  CALL dgbt01( n, n, kl, ku, a, lda, afb,
694  $ ldafb, iwork, work,
695  $ result( 1 ) )
696  k1 = 1
697  ELSE
698  k1 = 2
699  END IF
700 *
701  IF( info.EQ.0 ) THEN
702  trfcon = .false.
703 *
704 * Compute residual of the computed solution.
705 *
706  CALL dlacpy( 'Full', n, nrhs, bsav, ldb,
707  $ work, ldb )
708  CALL dgbt02( trans, n, n, kl, ku, nrhs,
709  $ asav, lda, x, ldb, work, ldb,
710  $ result( 2 ) )
711 *
712 * Check solution from generated exact
713 * solution.
714 *
715  IF( nofact .OR. ( prefac .AND.
716  $ lsame( equed, 'N' ) ) ) THEN
717  CALL dget04( n, nrhs, x, ldb, xact,
718  $ ldb, rcondc, result( 3 ) )
719  ELSE
720  IF( itran.EQ.1 ) THEN
721  roldc = roldo
722  ELSE
723  roldc = roldi
724  END IF
725  CALL dget04( n, nrhs, x, ldb, xact,
726  $ ldb, roldc, result( 3 ) )
727  END IF
728 *
729 * Check the error bounds from iterative
730 * refinement.
731 *
732  CALL dgbt05( trans, n, kl, ku, nrhs, asav,
733  $ lda, b, ldb, x, ldb, xact,
734  $ ldb, rwork, rwork( nrhs+1 ),
735  $ result( 4 ) )
736  ELSE
737  trfcon = .true.
738  END IF
739 *
740 * Compare RCOND from DGBSVX with the computed
741 * value in RCONDC.
742 *
743  result( 6 ) = dget06( rcond, rcondc )
744 *
745 * Print information about the tests that did
746 * not pass the threshold.
747 *
748  IF( .NOT.trfcon ) THEN
749  DO 80 k = k1, ntests
750  IF( result( k ).GE.thresh ) THEN
751  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
752  $ CALL aladhd( nout, path )
753  IF( prefac ) THEN
754  WRITE( nout, fmt = 9995 )
755  $ 'DGBSVX', fact, trans, n, kl,
756  $ ku, equed, imat, k,
757  $ result( k )
758  ELSE
759  WRITE( nout, fmt = 9996 )
760  $ 'DGBSVX', fact, trans, n, kl,
761  $ ku, imat, k, result( k )
762  END IF
763  nfail = nfail + 1
764  END IF
765  80 CONTINUE
766  nrun = nrun + 7 - k1
767  ELSE
768  IF( result( 1 ).GE.thresh .AND. .NOT.
769  $ prefac ) THEN
770  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
771  $ CALL aladhd( nout, path )
772  IF( prefac ) THEN
773  WRITE( nout, fmt = 9995 )'DGBSVX',
774  $ fact, trans, n, kl, ku, equed,
775  $ imat, 1, result( 1 )
776  ELSE
777  WRITE( nout, fmt = 9996 )'DGBSVX',
778  $ fact, trans, n, kl, ku, imat, 1,
779  $ result( 1 )
780  END IF
781  nfail = nfail + 1
782  nrun = nrun + 1
783  END IF
784  IF( result( 6 ).GE.thresh ) THEN
785  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
786  $ CALL aladhd( nout, path )
787  IF( prefac ) THEN
788  WRITE( nout, fmt = 9995 )'DGBSVX',
789  $ fact, trans, n, kl, ku, equed,
790  $ imat, 6, result( 6 )
791  ELSE
792  WRITE( nout, fmt = 9996 )'DGBSVX',
793  $ fact, trans, n, kl, ku, imat, 6,
794  $ result( 6 )
795  END IF
796  nfail = nfail + 1
797  nrun = nrun + 1
798  END IF
799  IF( result( 7 ).GE.thresh ) THEN
800  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
801  $ CALL aladhd( nout, path )
802  IF( prefac ) THEN
803  WRITE( nout, fmt = 9995 )'DGBSVX',
804  $ fact, trans, n, kl, ku, equed,
805  $ imat, 7, result( 7 )
806  ELSE
807  WRITE( nout, fmt = 9996 )'DGBSVX',
808  $ fact, trans, n, kl, ku, imat, 7,
809  $ result( 7 )
810  END IF
811  nfail = nfail + 1
812  nrun = nrun + 1
813  END IF
814 *
815  END IF
816 *
817 * --- Test DGBSVXX ---
818 *
819 * Restore the matrices A and B.
820 *
821  CALL dlacpy( 'Full', kl+ku+1, n, asav, lda, a,
822  $ lda )
823  CALL dlacpy( 'Full', n, nrhs, bsav, ldb, b, ldb )
824 
825  IF( .NOT.prefac )
826  $ CALL dlaset( 'Full', 2*kl+ku+1, n, zero, zero,
827  $ afb, ldafb )
828  CALL dlaset( 'Full', n, nrhs, zero, zero, x, ldb )
829  IF( iequed.GT.1 .AND. n.GT.0 ) THEN
830 *
831 * Equilibrate the matrix if FACT = 'F' and
832 * EQUED = 'R', 'C', or 'B'.
833 *
834  CALL dlaqgb( n, n, kl, ku, a, lda, s, s( n+1 ),
835  $ rowcnd, colcnd, amax, equed )
836  END IF
837 *
838 * Solve the system and compute the condition number
839 * and error bounds using DGBSVXX.
840 *
841  srnamt = 'DGBSVXX'
842  n_err_bnds = 3
843  CALL dgbsvxx( fact, trans, n, kl, ku, nrhs, a, lda,
844  $ afb, ldafb, iwork, equed, s, s( n+1 ), b, ldb,
845  $ x, ldb, rcond, rpvgrw_svxx, berr, n_err_bnds,
846  $ errbnds_n, errbnds_c, 0, zero, work,
847  $ iwork( n+1 ), info )
848 *
849 * Check the error code from DGBSVXX.
850 *
851  IF( info.EQ.n+1 ) GOTO 90
852  IF( info.NE.izero ) THEN
853  CALL alaerh( path, 'DGBSVXX', info, izero,
854  $ fact // trans, n, n, -1, -1, nrhs,
855  $ imat, nfail, nerrs, nout )
856  GOTO 90
857  END IF
858 *
859 * Compare rpvgrw_svxx from DGBSVXX with the computed
860 * reciprocal pivot growth factor RPVGRW
861 *
862 
863  IF ( info .GT. 0 .AND. info .LT. n+1 ) THEN
864  rpvgrw = dla_gbrpvgrw(n, kl, ku, info, a, lda,
865  $ afb, ldafb)
866  ELSE
867  rpvgrw = dla_gbrpvgrw(n, kl, ku, n, a, lda,
868  $ afb, ldafb)
869  ENDIF
870 
871  result( 7 ) = abs( rpvgrw-rpvgrw_svxx ) /
872  $ max( rpvgrw_svxx, rpvgrw ) /
873  $ dlamch( 'E' )
874 *
875  IF( .NOT.prefac ) THEN
876 *
877 * Reconstruct matrix from factors and compute
878 * residual.
879 *
880  CALL dgbt01( n, n, kl, ku, a, lda, afb, ldafb,
881  $ iwork, work, result( 1 ) )
882  k1 = 1
883  ELSE
884  k1 = 2
885  END IF
886 *
887  IF( info.EQ.0 ) THEN
888  trfcon = .false.
889 *
890 * Compute residual of the computed solution.
891 *
892  CALL dlacpy( 'Full', n, nrhs, bsav, ldb, work,
893  $ ldb )
894  CALL dgbt02( trans, n, n, kl, ku, nrhs, asav,
895  $ lda, x, ldb, work, ldb,
896  $ result( 2 ) )
897 *
898 * Check solution from generated exact solution.
899 *
900  IF( nofact .OR. ( prefac .AND. lsame( equed,
901  $ 'N' ) ) ) THEN
902  CALL dget04( n, nrhs, x, ldb, xact, ldb,
903  $ rcondc, result( 3 ) )
904  ELSE
905  IF( itran.EQ.1 ) THEN
906  roldc = roldo
907  ELSE
908  roldc = roldi
909  END IF
910  CALL dget04( n, nrhs, x, ldb, xact, ldb,
911  $ roldc, result( 3 ) )
912  END IF
913  ELSE
914  trfcon = .true.
915  END IF
916 *
917 * Compare RCOND from DGBSVXX with the computed value
918 * in RCONDC.
919 *
920  result( 6 ) = dget06( rcond, rcondc )
921 *
922 * Print information about the tests that did not pass
923 * the threshold.
924 *
925  IF( .NOT.trfcon ) THEN
926  DO 45 k = k1, ntests
927  IF( result( k ).GE.thresh ) THEN
928  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
929  $ CALL aladhd( nout, path )
930  IF( prefac ) THEN
931  WRITE( nout, fmt = 9995 )'DGBSVXX',
932  $ fact, trans, n, kl, ku, equed,
933  $ imat, k, result( k )
934  ELSE
935  WRITE( nout, fmt = 9996 )'DGBSVXX',
936  $ fact, trans, n, kl, ku, imat, k,
937  $ result( k )
938  END IF
939  nfail = nfail + 1
940  END IF
941  45 CONTINUE
942  nrun = nrun + 7 - k1
943  ELSE
944  IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
945  $ THEN
946  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
947  $ CALL aladhd( nout, path )
948  IF( prefac ) THEN
949  WRITE( nout, fmt = 9995 )'DGBSVXX', fact,
950  $ trans, n, kl, ku, equed, imat, 1,
951  $ result( 1 )
952  ELSE
953  WRITE( nout, fmt = 9996 )'DGBSVXX', fact,
954  $ trans, n, kl, ku, imat, 1,
955  $ result( 1 )
956  END IF
957  nfail = nfail + 1
958  nrun = nrun + 1
959  END IF
960  IF( result( 6 ).GE.thresh ) THEN
961  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
962  $ CALL aladhd( nout, path )
963  IF( prefac ) THEN
964  WRITE( nout, fmt = 9995 )'DGBSVXX', fact,
965  $ trans, n, kl, ku, equed, imat, 6,
966  $ result( 6 )
967  ELSE
968  WRITE( nout, fmt = 9996 )'DGBSVXX', fact,
969  $ trans, n, kl, ku, imat, 6,
970  $ result( 6 )
971  END IF
972  nfail = nfail + 1
973  nrun = nrun + 1
974  END IF
975  IF( result( 7 ).GE.thresh ) THEN
976  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
977  $ CALL aladhd( nout, path )
978  IF( prefac ) THEN
979  WRITE( nout, fmt = 9995 )'DGBSVXX', fact,
980  $ trans, n, kl, ku, equed, imat, 7,
981  $ result( 7 )
982  ELSE
983  WRITE( nout, fmt = 9996 )'DGBSVXX', fact,
984  $ trans, n, kl, ku, imat, 7,
985  $ result( 7 )
986  END IF
987  nfail = nfail + 1
988  nrun = nrun + 1
989  END IF
990 *
991  END IF
992  90 CONTINUE
993  100 CONTINUE
994  110 CONTINUE
995  120 CONTINUE
996  130 CONTINUE
997  140 CONTINUE
998  150 CONTINUE
999 *
1000 * Print a summary of the results.
1001 *
1002  CALL alasvm( path, nout, nfail, nrun, nerrs )
1003 
1004 * Test Error Bounds from DGBSVXX
1005 
1006  CALL debchvxx(thresh, path)
1007 
1008  9999 FORMAT( ' *** In DDRVGB, LA=', i5, ' is too small for N=', i5,
1009  $ ', KU=', i5, ', KL=', i5, / ' ==> Increase LA to at least ',
1010  $ i5 )
1011  9998 FORMAT( ' *** In DDRVGB, LAFB=', i5, ' is too small for N=', i5,
1012  $ ', KU=', i5, ', KL=', i5, /
1013  $ ' ==> Increase LAFB to at least ', i5 )
1014  9997 FORMAT( 1x, a, ', N=', i5, ', KL=', i5, ', KU=', i5, ', type ',
1015  $ i1, ', test(', i1, ')=', g12.5 )
1016  9996 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
1017  $ i5, ',...), type ', i1, ', test(', i1, ')=', g12.5 )
1018  9995 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
1019  $ i5, ',...), EQUED=''', a1, ''', type ', i1, ', test(', i1,
1020  $ ')=', g12.5 )
1021 *
1022  RETURN
1023 *
1024 * End of DDRVGB
1025 *
1026  END
dlacpy
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
Definition: dlacpy.f:103
dlaset
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: dlaset.f:110
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:73
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:81
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:90
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:147
dlarhs
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
Definition: dlarhs.f:204
dget04
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
Definition: dget04.f:102
dgbt01
subroutine dgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
DGBT01
Definition: dgbt01.f:126
dgbt05
subroutine dgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DGBT05
Definition: dgbt05.f:176
dgbt02
subroutine dgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
DGBT02
Definition: dgbt02.f:139
ddrvgb
subroutine ddrvgb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
DDRVGB
Definition: ddrvgb.f:172
dlatb4
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
Definition: dlatb4.f:120
derrvx
subroutine derrvx(PATH, NUNIT)
DERRVX
Definition: derrvx.f:55
debchvxx
subroutine debchvxx(THRESH, PATH)
DEBCHVXX
Definition: debchvxx.f:96
dlatms
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
Definition: dlatms.f:321
dlaqgb
subroutine dlaqgb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED)
DLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ.
Definition: dlaqgb.f:159
dla_gbrpvgrw
double precision function dla_gbrpvgrw(N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB)
DLA_GBRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a general banded matrix.
Definition: dla_gbrpvgrw.f:117
dgbtrs
subroutine dgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
DGBTRS
Definition: dgbtrs.f:138
dgbequb
subroutine dgbequb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
DGBEQUB
Definition: dgbequb.f:160
dgbtrf
subroutine dgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
DGBTRF
Definition: dgbtrf.f:144
dgbequ
subroutine dgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
DGBEQU
Definition: dgbequ.f:153
dgbsvx
subroutine dgbsvx(FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
DGBSVX computes the solution to system of linear equations A * X = B for GB matrices
Definition: dgbsvx.f:369
dgbsvxx
subroutine dgbsvxx(FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO)
DGBSVXX computes the solution to system of linear equations A * X = B for GB matrices
Definition: dgbsvxx.f:560
dgbsv
subroutine dgbsv(N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
DGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver)
Definition: dgbsv.f:162