LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
cdrvgbx.f
Go to the documentation of this file.
1 *> \brief \b CDRVGBX
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 CDRVGB( 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 RWORK( * ), S( * )
24 * COMPLEX A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
25 * $ WORK( * ), X( * ), XACT( * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> CDRVGB tests the driver routines CGBSV, -SVX, and -SVXX.
35 *>
36 *> Note that this file is used only when the XBLAS are available,
37 *> otherwise cdrvgb.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 COMPLEX 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 COMPLEX 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 COMPLEX array, dimension (LA)
111 *> \endverbatim
112 *>
113 *> \param[out] B
114 *> \verbatim
115 *> B is COMPLEX array, dimension (NMAX*NRHS)
116 *> \endverbatim
117 *>
118 *> \param[out] BSAV
119 *> \verbatim
120 *> BSAV is COMPLEX array, dimension (NMAX*NRHS)
121 *> \endverbatim
122 *>
123 *> \param[out] X
124 *> \verbatim
125 *> X is COMPLEX array, dimension (NMAX*NRHS)
126 *> \endverbatim
127 *>
128 *> \param[out] XACT
129 *> \verbatim
130 *> XACT is COMPLEX 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 COMPLEX 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 (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 complex_lin
172 *
173 * =====================================================================
174  SUBROUTINE cdrvgb( 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 rwork( * ), s( * )
192  COMPLEX a( * ), afb( * ), asav( * ), b( * ), bsav( * ),
193  $ work( * ), x( * ), 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 rdum( 1 ), result( ntests ), berr( nrhs ),
226  $ errbnds_n( nrhs,3 ), errbnds_c( nrhs, 3 )
227 * ..
228 * .. External Functions ..
229  LOGICAL lsame
230  REAL clangb, clange, clantb, sget06, slamch,
231  $ cla_gbrpvgrw
232  EXTERNAL lsame, clangb, clange, clantb, sget06, slamch,
233  $ cla_gbrpvgrw
234 * ..
235 * .. External Subroutines ..
236  EXTERNAL aladhd, alaerh, alasvm, cerrvx, cgbequ, cgbsv,
237  $ cgbsvx, cgbt01, cgbt02, cgbt05, cgbtrf, cgbtrs,
238  $ cget04, clacpy, claqgb, clarhs, claset, clatb4,
239  $ clatms, xlaenv, cgbsvxx
240 * ..
241 * .. Intrinsic Functions ..
242  INTRINSIC abs, cmplx, 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 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a
367 * test matrix with CLATMS.
368 *
369  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm,
370  $ mode, cndnum, dist )
371  rcondc = one / cndnum
372 *
373  srnamt = 'CLATMS'
374  CALL clatms( 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 CLATMS.
379 *
380  IF( info.NE.0 ) THEN
381  CALL alaerh( path, 'CLATMS', 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 clacpy( '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 clacpy( '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 cgbequ( 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 claqgb( 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 CGET04.
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 = clangb( '1', n, kl, ku, afb( kl+1 ),
489  $ ldafb, rwork )
490  anormi = clangb( 'I', n, kl, ku, afb( kl+1 ),
491  $ ldafb, rwork )
492 *
493 * Factor the matrix A.
494 *
495  CALL cgbtrf( n, n, kl, ku, afb, ldafb, iwork,
496  $ info )
497 *
498 * Form the inverse of A.
499 *
500  CALL claset( 'Full', n, n, cmplx( zero ),
501  $ cmplx( one ), work, ldb )
502  srnamt = 'CGBTRS'
503  CALL cgbtrs( '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 = clange( '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 = clange( '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 clacpy( '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 = 'CLARHS'
549  CALL clarhs( path, xtype, 'Full', trans, n,
550  $ n, kl, ku, nrhs, a, lda, xact,
551  $ ldb, b, ldb, iseed, info )
552  xtype = 'C'
553  CALL clacpy( 'Full', n, nrhs, b, ldb, bsav,
554  $ ldb )
555 *
556  IF( nofact .AND. itran.EQ.1 ) THEN
557 *
558 * --- Test CGBSV ---
559 *
560 * Compute the LU factorization of the matrix
561 * and solve the system.
562 *
563  CALL clacpy( 'Full', kl+ku+1, n, a, lda,
564  $ afb( kl+1 ), ldafb )
565  CALL clacpy( 'Full', n, nrhs, b, ldb, x,
566  $ ldb )
567 *
568  srnamt = 'CGBSV '
569  CALL cgbsv( n, kl, ku, nrhs, afb, ldafb,
570  $ iwork, x, ldb, info )
571 *
572 * Check error code from CGBSV .
573 *
574  IF( info.NE.izero )
575  $ CALL alaerh( path, 'CGBSV ', 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 cgbt01( 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 clacpy( 'Full', n, nrhs, b, ldb,
593  $ work, ldb )
594  CALL cgbt02( '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 cget04( 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 )'CGBSV ',
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 CGBSVX ---
622 *
623  IF( .NOT.prefac )
624  $ CALL claset( 'Full', 2*kl+ku+1, n,
625  $ cmplx( zero ), cmplx( zero ),
626  $ afb, ldafb )
627  CALL claset( 'Full', n, nrhs, cmplx( zero ),
628  $ cmplx( zero ), x, ldb )
629  IF( iequed.GT.1 .AND. n.GT.0 ) THEN
630 *
631 * Equilibrate the matrix if FACT = 'F' and
632 * EQUED = 'R', 'C', or 'B'.
633 *
634  CALL claqgb( n, n, kl, ku, a, lda, s,
635  $ s( n+1 ), rowcnd, colcnd,
636  $ amax, equed )
637  END IF
638 *
639 * Solve the system and compute the condition
640 * number and error bounds using CGBSVX.
641 *
642  srnamt = 'CGBSVX'
643  CALL cgbsvx( fact, trans, n, kl, ku, nrhs, a,
644  $ lda, afb, ldafb, iwork, equed,
645  $ s, s( ldb+1 ), b, ldb, x, ldb,
646  $ rcond, rwork, rwork( nrhs+1 ),
647  $ work, rwork( 2*nrhs+1 ), info )
648 *
649 * Check the error code from CGBSVX.
650 *
651  IF( info.NE.izero )
652  $ CALL alaerh( path, 'CGBSVX', info, izero,
653  $ fact // trans, n, n, kl, ku,
654  $ nrhs, imat, nfail, nerrs,
655  $ nout )
656 *
657 * Compare RWORK(2*NRHS+1) from CGBSVX with the
658 * computed reciprocal pivot growth RPVGRW
659 *
660  IF( info.NE.0 ) THEN
661  anrmpv = zero
662  DO 70 j = 1, info
663  DO 60 i = max( ku+2-j, 1 ),
664  $ min( n+ku+1-j, kl+ku+1 )
665  anrmpv = max( anrmpv,
666  $ abs( a( i+( j-1 )*lda ) ) )
667  60 CONTINUE
668  70 CONTINUE
669  rpvgrw = clantb( 'M', 'U', 'N', info,
670  $ min( info-1, kl+ku ),
671  $ afb( max( 1, kl+ku+2-info ) ),
672  $ ldafb, rdum )
673  IF( rpvgrw.EQ.zero ) THEN
674  rpvgrw = one
675  ELSE
676  rpvgrw = anrmpv / rpvgrw
677  END IF
678  ELSE
679  rpvgrw = clantb( 'M', 'U', 'N', n, kl+ku,
680  $ afb, ldafb, rdum )
681  IF( rpvgrw.EQ.zero ) THEN
682  rpvgrw = one
683  ELSE
684  rpvgrw = clangb( 'M', n, kl, ku, a,
685  $ lda, rdum ) / rpvgrw
686  END IF
687  END IF
688  result( 7 ) = abs( rpvgrw-rwork( 2*nrhs+1 ) )
689  $ / max( rwork( 2*nrhs+1 ),
690  $ rpvgrw ) / slamch( 'E' )
691 *
692  IF( .NOT.prefac ) THEN
693 *
694 * Reconstruct matrix from factors and
695 * compute residual.
696 *
697  CALL cgbt01( n, n, kl, ku, a, lda, afb,
698  $ ldafb, iwork, work,
699  $ result( 1 ) )
700  k1 = 1
701  ELSE
702  k1 = 2
703  END IF
704 *
705  IF( info.EQ.0 ) THEN
706  trfcon = .false.
707 *
708 * Compute residual of the computed solution.
709 *
710  CALL clacpy( 'Full', n, nrhs, bsav, ldb,
711  $ work, ldb )
712  CALL cgbt02( trans, n, n, kl, ku, nrhs,
713  $ asav, lda, x, ldb, work, ldb,
714  $ result( 2 ) )
715 *
716 * Check solution from generated exact
717 * solution.
718 *
719  IF( nofact .OR. ( prefac .AND.
720  $ lsame( equed, 'N' ) ) ) THEN
721  CALL cget04( n, nrhs, x, ldb, xact,
722  $ ldb, rcondc, result( 3 ) )
723  ELSE
724  IF( itran.EQ.1 ) THEN
725  roldc = roldo
726  ELSE
727  roldc = roldi
728  END IF
729  CALL cget04( n, nrhs, x, ldb, xact,
730  $ ldb, roldc, result( 3 ) )
731  END IF
732 *
733 * Check the error bounds from iterative
734 * refinement.
735 *
736  CALL cgbt05( trans, n, kl, ku, nrhs, asav,
737  $ lda, bsav, ldb, x, ldb, xact,
738  $ ldb, rwork, rwork( nrhs+1 ),
739  $ result( 4 ) )
740  ELSE
741  trfcon = .true.
742  END IF
743 *
744 * Compare RCOND from CGBSVX with the computed
745 * value in RCONDC.
746 *
747  result( 6 ) = sget06( rcond, rcondc )
748 *
749 * Print information about the tests that did
750 * not pass the threshold.
751 *
752  IF( .NOT.trfcon ) THEN
753  DO 80 k = k1, ntests
754  IF( result( k ).GE.thresh ) THEN
755  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
756  $ CALL aladhd( nout, path )
757  IF( prefac ) THEN
758  WRITE( nout, fmt = 9995 )
759  $ 'CGBSVX', fact, trans, n, kl,
760  $ ku, equed, imat, k,
761  $ result( k )
762  ELSE
763  WRITE( nout, fmt = 9996 )
764  $ 'CGBSVX', fact, trans, n, kl,
765  $ ku, imat, k, result( k )
766  END IF
767  nfail = nfail + 1
768  END IF
769  80 CONTINUE
770  nrun = nrun + 7 - k1
771  ELSE
772  IF( result( 1 ).GE.thresh .AND. .NOT.
773  $ prefac ) THEN
774  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
775  $ CALL aladhd( nout, path )
776  IF( prefac ) THEN
777  WRITE( nout, fmt = 9995 )'CGBSVX',
778  $ fact, trans, n, kl, ku, equed,
779  $ imat, 1, result( 1 )
780  ELSE
781  WRITE( nout, fmt = 9996 )'CGBSVX',
782  $ fact, trans, n, kl, ku, imat, 1,
783  $ result( 1 )
784  END IF
785  nfail = nfail + 1
786  nrun = nrun + 1
787  END IF
788  IF( result( 6 ).GE.thresh ) THEN
789  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
790  $ CALL aladhd( nout, path )
791  IF( prefac ) THEN
792  WRITE( nout, fmt = 9995 )'CGBSVX',
793  $ fact, trans, n, kl, ku, equed,
794  $ imat, 6, result( 6 )
795  ELSE
796  WRITE( nout, fmt = 9996 )'CGBSVX',
797  $ fact, trans, n, kl, ku, imat, 6,
798  $ result( 6 )
799  END IF
800  nfail = nfail + 1
801  nrun = nrun + 1
802  END IF
803  IF( result( 7 ).GE.thresh ) THEN
804  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
805  $ CALL aladhd( nout, path )
806  IF( prefac ) THEN
807  WRITE( nout, fmt = 9995 )'CGBSVX',
808  $ fact, trans, n, kl, ku, equed,
809  $ imat, 7, result( 7 )
810  ELSE
811  WRITE( nout, fmt = 9996 )'CGBSVX',
812  $ fact, trans, n, kl, ku, imat, 7,
813  $ result( 7 )
814  END IF
815  nfail = nfail + 1
816  nrun = nrun + 1
817  END IF
818  END IF
819 
820 * --- Test CGBSVXX ---
821 
822 * Restore the matrices A and B.
823 
824 c write(*,*) 'begin cgbsvxx testing'
825 
826  CALL clacpy( 'Full', kl+ku+1, n, asav, lda, a,
827  $ lda )
828  CALL clacpy( 'Full', n, nrhs, bsav, ldb, b, ldb )
829 
830  IF( .NOT.prefac )
831  $ CALL claset( 'Full', 2*kl+ku+1, n,
832  $ cmplx( zero ), cmplx( zero ),
833  $ afb, ldafb )
834  CALL claset( 'Full', n, nrhs,
835  $ cmplx( zero ), cmplx( zero ),
836  $ x, ldb )
837  IF( iequed.GT.1 .AND. n.GT.0 ) THEN
838 *
839 * Equilibrate the matrix if FACT = 'F' and
840 * EQUED = 'R', 'C', or 'B'.
841 *
842  CALL claqgb( n, n, kl, ku, a, lda, s,
843  $ s( n+1 ), rowcnd, colcnd, amax, equed )
844  END IF
845 *
846 * Solve the system and compute the condition number
847 * and error bounds using CGBSVXX.
848 *
849  srnamt = 'CGBSVXX'
850  n_err_bnds = 3
851  CALL cgbsvxx( fact, trans, n, kl, ku, nrhs, a, lda,
852  $ afb, ldafb, iwork, equed, s, s( n+1 ), b, ldb,
853  $ x, ldb, rcond, rpvgrw_svxx, berr, n_err_bnds,
854  $ errbnds_n, errbnds_c, 0, zero, work,
855  $ rwork, info )
856 *
857 * Check the error code from CGBSVXX.
858 *
859  IF( info.EQ.n+1 ) GOTO 90
860  IF( info.NE.izero ) THEN
861  CALL alaerh( path, 'CGBSVXX', info, izero,
862  $ fact // trans, n, n, -1, -1, nrhs,
863  $ imat, nfail, nerrs, nout )
864  GOTO 90
865  END IF
866 *
867 * Compare rpvgrw_svxx from CGESVXX with the computed
868 * reciprocal pivot growth factor RPVGRW
869 *
870 
871  IF ( info .GT. 0 .AND. info .LT. n+1 ) THEN
872  rpvgrw = cla_gbrpvgrw(n, kl, ku, info, a, lda,
873  $ afb, ldafb)
874  ELSE
875  rpvgrw = cla_gbrpvgrw(n, kl, ku, n, a, lda,
876  $ afb, ldafb)
877  ENDIF
878 
879  result( 7 ) = abs( rpvgrw-rpvgrw_svxx ) /
880  $ max( rpvgrw_svxx, rpvgrw ) /
881  $ slamch( 'E' )
882 *
883  IF( .NOT.prefac ) THEN
884 *
885 * Reconstruct matrix from factors and compute
886 * residual.
887 *
888  CALL cgbt01( n, n, kl, ku, a, lda, afb, ldafb,
889  $ iwork, work( 2*nrhs+1 ), result( 1 ) )
890  k1 = 1
891  ELSE
892  k1 = 2
893  END IF
894 *
895  IF( info.EQ.0 ) THEN
896  trfcon = .false.
897 *
898 * Compute residual of the computed solution.
899 *
900  CALL clacpy( 'Full', n, nrhs, bsav, ldb, work,
901  $ ldb )
902  CALL cgbt02( trans, n, n, kl, ku, nrhs, asav,
903  $ lda, x, ldb, work, ldb, result( 2 ) )
904 *
905 * Check solution from generated exact solution.
906 *
907  IF( nofact .OR. ( prefac .AND. lsame( equed,
908  $ 'N' ) ) ) THEN
909  CALL cget04( n, nrhs, x, ldb, xact, ldb,
910  $ rcondc, result( 3 ) )
911  ELSE
912  IF( itran.EQ.1 ) THEN
913  roldc = roldo
914  ELSE
915  roldc = roldi
916  END IF
917  CALL cget04( n, nrhs, x, ldb, xact, ldb,
918  $ roldc, result( 3 ) )
919  END IF
920  ELSE
921  trfcon = .true.
922  END IF
923 *
924 * Compare RCOND from CGBSVXX with the computed value
925 * in RCONDC.
926 *
927  result( 6 ) = sget06( rcond, rcondc )
928 *
929 * Print information about the tests that did not pass
930 * the threshold.
931 *
932  IF( .NOT.trfcon ) THEN
933  DO 45 k = k1, ntests
934  IF( result( k ).GE.thresh ) THEN
935  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
936  $ CALL aladhd( nout, path )
937  IF( prefac ) THEN
938  WRITE( nout, fmt = 9995 )'CGBSVXX',
939  $ fact, trans, n, kl, ku, equed,
940  $ imat, k, result( k )
941  ELSE
942  WRITE( nout, fmt = 9996 )'CGBSVXX',
943  $ fact, trans, n, kl, ku, imat, k,
944  $ result( k )
945  END IF
946  nfail = nfail + 1
947  END IF
948  45 CONTINUE
949  nrun = nrun + 7 - k1
950  ELSE
951  IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
952  $ THEN
953  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
954  $ CALL aladhd( nout, path )
955  IF( prefac ) THEN
956  WRITE( nout, fmt = 9995 )'CGBSVXX', fact,
957  $ trans, n, kl, ku, equed, imat, 1,
958  $ result( 1 )
959  ELSE
960  WRITE( nout, fmt = 9996 )'CGBSVXX', fact,
961  $ trans, n, kl, ku, imat, 1,
962  $ result( 1 )
963  END IF
964  nfail = nfail + 1
965  nrun = nrun + 1
966  END IF
967  IF( result( 6 ).GE.thresh ) THEN
968  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
969  $ CALL aladhd( nout, path )
970  IF( prefac ) THEN
971  WRITE( nout, fmt = 9995 )'CGBSVXX', fact,
972  $ trans, n, kl, ku, equed, imat, 6,
973  $ result( 6 )
974  ELSE
975  WRITE( nout, fmt = 9996 )'CGBSVXX', fact,
976  $ trans, n, kl, ku, imat, 6,
977  $ result( 6 )
978  END IF
979  nfail = nfail + 1
980  nrun = nrun + 1
981  END IF
982  IF( result( 7 ).GE.thresh ) THEN
983  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
984  $ CALL aladhd( nout, path )
985  IF( prefac ) THEN
986  WRITE( nout, fmt = 9995 )'CGBSVXX', fact,
987  $ trans, n, kl, ku, equed, imat, 7,
988  $ result( 7 )
989  ELSE
990  WRITE( nout, fmt = 9996 )'CGBSVXX', fact,
991  $ trans, n, kl, ku, imat, 7,
992  $ result( 7 )
993  END IF
994  nfail = nfail + 1
995  nrun = nrun + 1
996  END IF
997 *
998  END IF
999 *
1000  90 CONTINUE
1001  100 CONTINUE
1002  110 CONTINUE
1003  120 CONTINUE
1004  130 CONTINUE
1005  140 CONTINUE
1006  150 CONTINUE
1007 *
1008 * Print a summary of the results.
1009 *
1010  CALL alasvm( path, nout, nfail, nrun, nerrs )
1011 *
1012 
1013 * Test Error Bounds from CGBSVXX
1014 
1015  CALL cebchvxx(thresh, path)
1016 
1017  9999 FORMAT( ' *** In CDRVGB, LA=', i5, ' is too small for N=', i5,
1018  $ ', KU=', i5, ', KL=', i5, / ' ==> Increase LA to at least ',
1019  $ i5 )
1020  9998 FORMAT( ' *** In CDRVGB, LAFB=', i5, ' is too small for N=', i5,
1021  $ ', KU=', i5, ', KL=', i5, /
1022  $ ' ==> Increase LAFB to at least ', i5 )
1023  9997 FORMAT( 1x, a, ', N=', i5, ', KL=', i5, ', KU=', i5, ', type ',
1024  $ i1, ', test(', i1, ')=', g12.5 )
1025  9996 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
1026  $ i5, ',...), type ', i1, ', test(', i1, ')=', g12.5 )
1027  9995 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
1028  $ i5, ',...), EQUED=''', a1, ''', type ', i1, ', test(', i1,
1029  $ ')=', g12.5 )
1030 *
1031  RETURN
1032 *
1033 * End of CDRVGB
1034 *
1035  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
clarhs
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:211
cdrvgb
subroutine cdrvgb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
CDRVGB
Definition: cdrvgb.f:174
cgbtrf
subroutine cgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
CGBTRF
Definition: cgbtrf.f:146
cgbsv
subroutine cgbsv(N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
CGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver) ...
Definition: cgbsv.f:164
cgbt02
subroutine cgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
CGBT02
Definition: cgbt02.f:141
cgbt01
subroutine cgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
CGBT01
Definition: cgbt01.f:128
cebchvxx
subroutine cebchvxx(THRESH, PATH)
CEBCHVXX
Definition: cebchvxx.f:98
cerrvx
subroutine cerrvx(PATH, NUNIT)
CERRVX
Definition: cerrvx.f:57
sget06
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
clange
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: clange.f:117
clantb
real function clantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
CLANTB 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: clantb.f:143
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
claqgb
subroutine claqgb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED)
CLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ...
Definition: claqgb.f:162
claset
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: claset.f:108
clatms
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:80
cgbt05
subroutine cgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CGBT05
Definition: cgbt05.f:178
cgbsvx
subroutine cgbsvx(FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CGBSVX computes the solution to system of linear equations A * X = B for GB matrices ...
Definition: cgbsvx.f:372
cgbsvxx
subroutine cgbsvxx(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, RWORK, INFO)
CGBSVXX computes the solution to system of linear equations A * X = B for GB matrices ...
Definition: cgbsvxx.f:565
clangb
real function clangb(NORM, N, KL, KU, AB, LDAB, WORK)
CLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: clangb.f:127
cgbequ
subroutine cgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
CGBEQU
Definition: cgbequ.f:156
clacpy
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:105
slamch
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
clatb4
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
cget04
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
cla_gbrpvgrw
real function cla_gbrpvgrw(N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB)
CLA_GBRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a general banded matrix...
Definition: cla_gbrpvgrw.f:119
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
cgbtrs
subroutine cgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
CGBTRS
Definition: cgbtrs.f:140