LAPACK  3.6.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 *> \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
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
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:112
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
dlarhs
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
Definition: dlarhs.f:206
dgbt05
subroutine dgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DGBT05
Definition: dgbt05.f:178
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
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:119
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:105
debchvxx
subroutine debchvxx(THRESH, PATH)
DEBCHVXX
Definition: debchvxx.f:98
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:161
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
dlange
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: dlange.f:116
dgbequ
subroutine dgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
DGBEQU
Definition: dgbequ.f:155
dlangb
double precision function dlangb(NORM, N, KL, KU, AB, LDAB, WORK)
DLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: dlangb.f:126
dgbtrf
subroutine dgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
DGBTRF
Definition: dgbtrf.f:146
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:562
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:174
dgbt02
subroutine dgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
DGBT02
Definition: dgbt02.f:141
dlatb4
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
Definition: dlatb4.f:122
dget04
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
Definition: dget04.f:104
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:80
derrvx
subroutine derrvx(PATH, NUNIT)
DERRVX
Definition: derrvx.f:57
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:371
dgbequb
subroutine dgbequb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
DGBEQUB
Definition: dgbequb.f:162
dget06
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:57
dlantb
double precision function dlantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
DLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix.
Definition: dlantb.f:142
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:164
dgbt01
subroutine dgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
DGBT01
Definition: dgbt01.f:128
dlatms
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
Definition: dlatms.f:323
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
dgbtrs
subroutine dgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
DGBTRS
Definition: dgbtrs.f:140