LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
sdrvgbx.f
Go to the documentation of this file.
1 *> \brief \b SDRVGBX
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, -SVX, and -SVXX.
35 *>
36 *> Note that this file is used only when the XBLAS are available,
37 *> otherwise sdrvgb.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 REAL
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 REAL 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 REAL 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 REAL array, dimension (LA)
111 *> \endverbatim
112 *>
113 *> \param[out] B
114 *> \verbatim
115 *> B is REAL array, dimension (NMAX*NRHS)
116 *> \endverbatim
117 *>
118 *> \param[out] BSAV
119 *> \verbatim
120 *> BSAV is REAL array, dimension (NMAX*NRHS)
121 *> \endverbatim
122 *>
123 *> \param[out] X
124 *> \verbatim
125 *> X is REAL array, dimension (NMAX*NRHS)
126 *> \endverbatim
127 *>
128 *> \param[out] XACT
129 *> \verbatim
130 *> XACT is REAL array, dimension (NMAX*NRHS)
131 *> \endverbatim
132 *>
133 *> \param[out] S
134 *> \verbatim
135 *> S is REAL array, dimension (2*NMAX)
136 *> \endverbatim
137 *>
138 *> \param[out] WORK
139 *> \verbatim
140 *> WORK is REAL array, dimension
141 *> (NMAX*max(3,NRHS,NMAX))
142 *> \endverbatim
143 *>
144 *> \param[out] RWORK
145 *> \verbatim
146 *> RWORK is REAL 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 single_lin
172 *
173 * =====================================================================
174  SUBROUTINE sdrvgb( 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  REAL thresh
187 * ..
188 * .. Array Arguments ..
189  LOGICAL dotype( * )
190  INTEGER iwork( * ), nval( * )
191  REAL a( * ), afb( * ), asav( * ), b( * ), bsav( * ),
192  $ rwork( * ), s( * ), work( * ), x( * ),
193  $ xact( * )
194 * ..
195 *
196 * =====================================================================
197 *
198 * .. Parameters ..
199  REAL one, zero
200  parameter ( one = 1.0e+0, zero = 0.0e+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  REAL 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  REAL result( ntests ), berr( nrhs ),
226  $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
227 * ..
228 * .. External Functions ..
229  LOGICAL lsame
230  REAL sget06, slamch, slangb, slange, slantb,
231  $ sla_gbrpvgrw
232  EXTERNAL lsame, sget06, slamch, slangb, slange, slantb,
233  $ sla_gbrpvgrw
234 * ..
235 * .. External Subroutines ..
236  EXTERNAL aladhd, alaerh, alasvm, serrvx, sgbequ, sgbsv,
237  $ sgbsvx, sgbt01, sgbt02, sgbt05, sgbtrf, sgbtrs,
238  $ sget04, slacpy, slaqgb, slarhs, slaset, slatb4,
239  $ slatms, xlaenv, sgbsvxx
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 ) = 'Single 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 serrvx( 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 SLATB4 and generate a
367 * test matrix with SLATMS.
368 *
369  CALL slatb4( path, imat, n, n, TYPE, kl, ku, anorm,
370  $ mode, cndnum, dist )
371  rcondc = one / cndnum
372 *
373  srnamt = 'SLATMS'
374  CALL slatms( 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 SLATMS.
379 *
380  IF( info.NE.0 ) THEN
381  CALL alaerh( path, 'SLATMS', 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 slacpy( '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 SGESVX (FACT =
444 * 'N' reuses the condition number from the
445 * previous iteration with FACT = 'F').
446 *
447  CALL slacpy( '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 sgbequ( 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 slaqgb( 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 SGET04.
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 = slangb( '1', n, kl, ku, afb( kl+1 ),
489  $ ldafb, rwork )
490  anormi = slangb( 'I', n, kl, ku, afb( kl+1 ),
491  $ ldafb, rwork )
492 *
493 * Factor the matrix A.
494 *
495  CALL sgbtrf( n, n, kl, ku, afb, ldafb, iwork,
496  $ info )
497 *
498 * Form the inverse of A.
499 *
500  CALL slaset( 'Full', n, n, zero, one, work,
501  $ ldb )
502  srnamt = 'SGBTRS'
503  CALL sgbtrs( '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 = slange( '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 = slange( '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 slacpy( '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 = 'SLARHS'
549  CALL slarhs( path, xtype, 'Full', trans, n,
550  $ n, kl, ku, nrhs, a, lda, xact,
551  $ ldb, b, ldb, iseed, info )
552  xtype = 'C'
553  CALL slacpy( 'Full', n, nrhs, b, ldb, bsav,
554  $ ldb )
555 *
556  IF( nofact .AND. itran.EQ.1 ) THEN
557 *
558 * --- Test SGBSV ---
559 *
560 * Compute the LU factorization of the matrix
561 * and solve the system.
562 *
563  CALL slacpy( 'Full', kl+ku+1, n, a, lda,
564  $ afb( kl+1 ), ldafb )
565  CALL slacpy( 'Full', n, nrhs, b, ldb, x,
566  $ ldb )
567 *
568  srnamt = 'SGBSV '
569  CALL sgbsv( n, kl, ku, nrhs, afb, ldafb,
570  $ iwork, x, ldb, info )
571 *
572 * Check error code from SGBSV .
573 *
574  IF( info.NE.izero )
575  $ CALL alaerh( path, 'SGBSV ', 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 sgbt01( 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 slacpy( 'Full', n, nrhs, b, ldb,
593  $ work, ldb )
594  CALL sgbt02( '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 sget04( 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 )'SGBSV ',
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 SGBSVX ---
622 *
623  IF( .NOT.prefac )
624  $ CALL slaset( 'Full', 2*kl+ku+1, n, zero,
625  $ zero, afb, ldafb )
626  CALL slaset( '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 slaqgb( 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 SGBSVX.
640 *
641  srnamt = 'SGBSVX'
642  CALL sgbsvx( 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 SGBSVX.
649 *
650  IF( info.NE.izero )
651  $ CALL alaerh( path, 'SGBSVX', info, izero,
652  $ fact // trans, n, n, kl, ku,
653  $ nrhs, imat, nfail, nerrs,
654  $ nout )
655 *
656 * Compare WORK(1) from SGBSVX 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 = slantb( '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 = slantb( 'M', 'U', 'N', n, kl+ku,
679  $ afb, ldafb, work )
680  IF( rpvgrw.EQ.zero ) THEN
681  rpvgrw = one
682  ELSE
683  rpvgrw = slangb( '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  $ slamch( 'E' )
690 *
691  IF( .NOT.prefac ) THEN
692 *
693 * Reconstruct matrix from factors and
694 * compute residual.
695 *
696  CALL sgbt01( 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 slacpy( 'Full', n, nrhs, bsav, ldb,
710  $ work, ldb )
711  CALL sgbt02( 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 sget04( 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 sget04( 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 sgbt05( 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 SGBSVX with the computed
744 * value in RCONDC.
745 *
746  result( 6 ) = sget06( 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  $ 'SGBSVX', fact, trans, n, kl,
759  $ ku, equed, imat, k,
760  $ result( k )
761  ELSE
762  WRITE( nout, fmt = 9996 )
763  $ 'SGBSVX', 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 )'SGBSVX',
777  $ fact, trans, n, kl, ku, equed,
778  $ imat, 1, result( 1 )
779  ELSE
780  WRITE( nout, fmt = 9996 )'SGBSVX',
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 )'SGBSVX',
792  $ fact, trans, n, kl, ku, equed,
793  $ imat, 6, result( 6 )
794  ELSE
795  WRITE( nout, fmt = 9996 )'SGBSVX',
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 )'SGBSVX',
807  $ fact, trans, n, kl, ku, equed,
808  $ imat, 7, result( 7 )
809  ELSE
810  WRITE( nout, fmt = 9996 )'SGBSVX',
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 SGBSVXX ---
821 *
822 * Restore the matrices A and B.
823 *
824  CALL slacpy( 'Full', kl+ku+1, n, asav, lda, a,
825  $ lda )
826  CALL slacpy( 'Full', n, nrhs, bsav, ldb, b, ldb )
827 
828  IF( .NOT.prefac )
829  $ CALL slaset( 'Full', 2*kl+ku+1, n, zero, zero,
830  $ afb, ldafb )
831  CALL slaset( '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 slaqgb( n, n, kl, ku, a, lda, s,
838  $ s( n+1 ), rowcnd, colcnd, amax, equed )
839  END IF
840 *
841 * Solve the system and compute the condition number
842 * and error bounds using SGBSVXX.
843 *
844  srnamt = 'SGBSVXX'
845  n_err_bnds = 3
846  CALL sgbsvxx( 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 SGBSVXX.
853 *
854  IF( info.EQ.n+1 ) GOTO 90
855  IF( info.NE.izero ) THEN
856  CALL alaerh( path, 'SGBSVXX', 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 SGBSVXX with the computed
863 * reciprocal pivot growth factor RPVGRW
864 *
865 
866  IF ( info .GT. 0 .AND. info .LT. n+1 ) THEN
867  rpvgrw = sla_gbrpvgrw(n, kl, ku, info, a, lda,
868  $ afb, ldafb )
869  ELSE
870  rpvgrw = sla_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  $ slamch( 'E' )
877 *
878  IF( .NOT.prefac ) THEN
879 *
880 * Reconstruct matrix from factors and compute
881 * residual.
882 *
883  CALL sgbt01( n, n, kl, ku, a, lda, afb, ldafb,
884  $ iwork, work,
885  $ result( 1 ) )
886  k1 = 1
887  ELSE
888  k1 = 2
889  END IF
890 *
891  IF( info.EQ.0 ) THEN
892  trfcon = .false.
893 *
894 * Compute residual of the computed solution.
895 *
896  CALL slacpy( 'Full', n, nrhs, bsav, ldb, work,
897  $ ldb )
898  CALL sgbt02( trans, n, n, kl, ku, nrhs, asav,
899  $ lda, x, ldb, work, ldb,
900  $ result( 2 ) )
901 *
902 * Check solution from generated exact solution.
903 *
904  IF( nofact .OR. ( prefac .AND. lsame( equed,
905  $ 'N' ) ) ) THEN
906  CALL sget04( n, nrhs, x, ldb, xact, ldb,
907  $ rcondc, result( 3 ) )
908  ELSE
909  IF( itran.EQ.1 ) THEN
910  roldc = roldo
911  ELSE
912  roldc = roldi
913  END IF
914  CALL sget04( n, nrhs, x, ldb, xact, ldb,
915  $ roldc, result( 3 ) )
916  END IF
917  ELSE
918  trfcon = .true.
919  END IF
920 *
921 * Compare RCOND from SGBSVXX with the computed value
922 * in RCONDC.
923 *
924  result( 6 ) = sget06( rcond, rcondc )
925 *
926 * Print information about the tests that did not pass
927 * the threshold.
928 *
929  IF( .NOT.trfcon ) THEN
930  DO 45 k = k1, ntests
931  IF( result( k ).GE.thresh ) THEN
932  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
933  $ CALL aladhd( nout, path )
934  IF( prefac ) THEN
935  WRITE( nout, fmt = 9995 )'SGBSVXX',
936  $ fact, trans, n, kl, ku, equed,
937  $ imat, k, result( k )
938  ELSE
939  WRITE( nout, fmt = 9996 )'SGBSVXX',
940  $ fact, trans, n, kl, ku, imat, k,
941  $ result( k )
942  END IF
943  nfail = nfail + 1
944  END IF
945  45 CONTINUE
946  nrun = nrun + 7 - k1
947  ELSE
948  IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
949  $ THEN
950  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
951  $ CALL aladhd( nout, path )
952  IF( prefac ) THEN
953  WRITE( nout, fmt = 9995 )'SGBSVXX', fact,
954  $ trans, n, kl, ku, equed, imat, 1,
955  $ result( 1 )
956  ELSE
957  WRITE( nout, fmt = 9996 )'SGBSVXX', fact,
958  $ trans, n, kl, ku, imat, 1,
959  $ result( 1 )
960  END IF
961  nfail = nfail + 1
962  nrun = nrun + 1
963  END IF
964  IF( result( 6 ).GE.thresh ) THEN
965  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
966  $ CALL aladhd( nout, path )
967  IF( prefac ) THEN
968  WRITE( nout, fmt = 9995 )'SGBSVXX', fact,
969  $ trans, n, kl, ku, equed, imat, 6,
970  $ result( 6 )
971  ELSE
972  WRITE( nout, fmt = 9996 )'SGBSVXX', fact,
973  $ trans, n, kl, ku, imat, 6,
974  $ result( 6 )
975  END IF
976  nfail = nfail + 1
977  nrun = nrun + 1
978  END IF
979  IF( result( 7 ).GE.thresh ) THEN
980  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
981  $ CALL aladhd( nout, path )
982  IF( prefac ) THEN
983  WRITE( nout, fmt = 9995 )'SGBSVXX', fact,
984  $ trans, n, kl, ku, equed, imat, 7,
985  $ result( 7 )
986  ELSE
987  WRITE( nout, fmt = 9996 )'SGBSVXX', fact,
988  $ trans, n, kl, ku, imat, 7,
989  $ result( 7 )
990  END IF
991  nfail = nfail + 1
992  nrun = nrun + 1
993  END IF
994 
995  END IF
996 *
997  90 CONTINUE
998  100 CONTINUE
999  110 CONTINUE
1000  120 CONTINUE
1001  130 CONTINUE
1002  140 CONTINUE
1003  150 CONTINUE
1004 *
1005 * Print a summary of the results.
1006 *
1007  CALL alasvm( path, nout, nfail, nrun, nerrs )
1008 *
1009 
1010 * Test Error Bounds from SGBSVXX
1011 
1012  CALL sebchvxx(thresh, path)
1013 
1014  9999 FORMAT( ' *** In SDRVGB, LA=', i5, ' is too small for N=', i5,
1015  $ ', KU=', i5, ', KL=', i5, / ' ==> Increase LA to at least ',
1016  $ i5 )
1017  9998 FORMAT( ' *** In SDRVGB, LAFB=', i5, ' is too small for N=', i5,
1018  $ ', KU=', i5, ', KL=', i5, /
1019  $ ' ==> Increase LAFB to at least ', i5 )
1020  9997 FORMAT( 1x, a, ', N=', i5, ', KL=', i5, ', KU=', i5, ', type ',
1021  $ i1, ', test(', i1, ')=', g12.5 )
1022  9996 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
1023  $ i5, ',...), type ', i1, ', test(', i1, ')=', g12.5 )
1024  9995 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
1025  $ i5, ',...), EQUED=''', a1, ''', type ', i1, ', test(', i1,
1026  $ ')=', g12.5 )
1027 *
1028  RETURN
1029 *
1030 * End of SDRVGB
1031 *
1032  END
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
sgbt05
subroutine sgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SGBT05
Definition: sgbt05.f:178
slatb4
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:122
sebchvxx
subroutine sebchvxx(THRESH, PATH)
SEBCHVXX
Definition: sebchvxx.f:98
sgbsv
subroutine sgbsv(N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
SGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver) ...
Definition: sgbsv.f:164
sgbsvx
subroutine sgbsvx(FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
SGBSVX computes the solution to system of linear equations A * X = B for GB matrices ...
Definition: sgbsvx.f:370
sla_gbrpvgrw
real function sla_gbrpvgrw(N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB)
SLA_GBRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a general banded matrix...
Definition: sla_gbrpvgrw.f:119
sgbsvxx
subroutine sgbsvxx(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)
SGBSVXX computes the solution to system of linear equations A * X = B for GB matrices ...
Definition: sgbsvxx.f:565
slarhs
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
Definition: slarhs.f:206
slantb
real function slantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
SLANTB 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: slantb.f:142
slaqgb
subroutine slaqgb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED)
SLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ...
Definition: slaqgb.f:161
sdrvgb
subroutine sdrvgb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
SDRVGB
Definition: sdrvgb.f:174
sgbt02
subroutine sgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
SGBT02
Definition: sgbt02.f:141
sget06
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
slacpy
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
slatms
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
slaset
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: slaset.f:112
slange
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slange.f:116
sget04
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:104
sgbequ
subroutine sgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
SGBEQU
Definition: sgbequ.f:155
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:80
serrvx
subroutine serrvx(PATH, NUNIT)
SERRVX
Definition: serrvx.f:57
sgbtrs
subroutine sgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
SGBTRS
Definition: sgbtrs.f:140
slangb
real function slangb(NORM, N, KL, KU, AB, LDAB, WORK)
SLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slangb.f:126
slamch
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
sgbt01
subroutine sgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
SGBT01
Definition: sgbt01.f:128
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
sgbtrf
subroutine sgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
SGBTRF
Definition: sgbtrf.f:146