LAPACK  3.9.1
LAPACK: Linear Algebra PACKage
cdrvgb.f
Go to the documentation of this file.
1 *> \brief \b CDRVGB
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 and -SVX.
35 *> \endverbatim
36 *
37 * Arguments:
38 * ==========
39 *
40 *> \param[in] DOTYPE
41 *> \verbatim
42 *> DOTYPE is LOGICAL array, dimension (NTYPES)
43 *> The matrix types to be used for testing. Matrices of type j
44 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
45 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
46 *> \endverbatim
47 *>
48 *> \param[in] NN
49 *> \verbatim
50 *> NN is INTEGER
51 *> The number of values of N contained in the vector NVAL.
52 *> \endverbatim
53 *>
54 *> \param[in] NVAL
55 *> \verbatim
56 *> NVAL is INTEGER array, dimension (NN)
57 *> The values of the matrix column dimension N.
58 *> \endverbatim
59 *>
60 *> \param[in] NRHS
61 *> \verbatim
62 *> NRHS is INTEGER
63 *> The number of right hand side vectors to be generated for
64 *> each linear system.
65 *> \endverbatim
66 *>
67 *> \param[in] THRESH
68 *> \verbatim
69 *> THRESH is REAL
70 *> The threshold value for the test ratios. A result is
71 *> included in the output file if RESULT >= THRESH. To have
72 *> every test ratio printed, use THRESH = 0.
73 *> \endverbatim
74 *>
75 *> \param[in] TSTERR
76 *> \verbatim
77 *> TSTERR is LOGICAL
78 *> Flag that indicates whether error exits are to be tested.
79 *> \endverbatim
80 *>
81 *> \param[out] A
82 *> \verbatim
83 *> A is COMPLEX array, dimension (LA)
84 *> \endverbatim
85 *>
86 *> \param[in] LA
87 *> \verbatim
88 *> LA is INTEGER
89 *> The length of the array A. LA >= (2*NMAX-1)*NMAX
90 *> where NMAX is the largest entry in NVAL.
91 *> \endverbatim
92 *>
93 *> \param[out] AFB
94 *> \verbatim
95 *> AFB is COMPLEX array, dimension (LAFB)
96 *> \endverbatim
97 *>
98 *> \param[in] LAFB
99 *> \verbatim
100 *> LAFB is INTEGER
101 *> The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX
102 *> where NMAX is the largest entry in NVAL.
103 *> \endverbatim
104 *>
105 *> \param[out] ASAV
106 *> \verbatim
107 *> ASAV is COMPLEX array, dimension (LA)
108 *> \endverbatim
109 *>
110 *> \param[out] B
111 *> \verbatim
112 *> B is COMPLEX array, dimension (NMAX*NRHS)
113 *> \endverbatim
114 *>
115 *> \param[out] BSAV
116 *> \verbatim
117 *> BSAV is COMPLEX array, dimension (NMAX*NRHS)
118 *> \endverbatim
119 *>
120 *> \param[out] X
121 *> \verbatim
122 *> X is COMPLEX array, dimension (NMAX*NRHS)
123 *> \endverbatim
124 *>
125 *> \param[out] XACT
126 *> \verbatim
127 *> XACT is COMPLEX array, dimension (NMAX*NRHS)
128 *> \endverbatim
129 *>
130 *> \param[out] S
131 *> \verbatim
132 *> S is REAL array, dimension (2*NMAX)
133 *> \endverbatim
134 *>
135 *> \param[out] WORK
136 *> \verbatim
137 *> WORK is COMPLEX array, dimension
138 *> (NMAX*max(3,NRHS,NMAX))
139 *> \endverbatim
140 *>
141 *> \param[out] RWORK
142 *> \verbatim
143 *> RWORK is REAL array, dimension
144 *> (max(NMAX,2*NRHS))
145 *> \endverbatim
146 *>
147 *> \param[out] IWORK
148 *> \verbatim
149 *> IWORK is INTEGER array, dimension (NMAX)
150 *> \endverbatim
151 *>
152 *> \param[in] NOUT
153 *> \verbatim
154 *> NOUT is INTEGER
155 *> The unit number for output.
156 *> \endverbatim
157 *
158 * Authors:
159 * ========
160 *
161 *> \author Univ. of Tennessee
162 *> \author Univ. of California Berkeley
163 *> \author Univ. of Colorado Denver
164 *> \author NAG Ltd.
165 *
166 *> \ingroup complex_lin
167 *
168 * =====================================================================
169  SUBROUTINE cdrvgb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
170  $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
171  $ RWORK, IWORK, NOUT )
172 *
173 * -- LAPACK test routine --
174 * -- LAPACK is a software package provided by Univ. of Tennessee, --
175 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176 *
177 * .. Scalar Arguments ..
178  LOGICAL TSTERR
179  INTEGER LA, LAFB, NN, NOUT, NRHS
180  REAL THRESH
181 * ..
182 * .. Array Arguments ..
183  LOGICAL DOTYPE( * )
184  INTEGER IWORK( * ), NVAL( * )
185  REAL RWORK( * ), S( * )
186  COMPLEX A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
187  $ work( * ), x( * ), xact( * )
188 * ..
189 *
190 * =====================================================================
191 *
192 * .. Parameters ..
193  REAL ONE, ZERO
194  PARAMETER ( ONE = 1.0e+0, zero = 0.0e+0 )
195  INTEGER NTYPES
196  parameter( ntypes = 8 )
197  INTEGER NTESTS
198  parameter( ntests = 7 )
199  INTEGER NTRAN
200  parameter( ntran = 3 )
201 * ..
202 * .. Local Scalars ..
203  LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
204  CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
205  CHARACTER*3 PATH
206  INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
207  $ info, ioff, itran, izero, j, k, k1, kl, ku,
208  $ lda, ldafb, ldb, mode, n, nb, nbmin, nerrs,
209  $ nfact, nfail, nimat, nkl, nku, nrun, nt
210  REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
211  $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
212  $ roldc, roldi, roldo, rowcnd, rpvgrw
213 * ..
214 * .. Local Arrays ..
215  CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
216  INTEGER ISEED( 4 ), ISEEDY( 4 )
217  REAL RDUM( 1 ), RESULT( NTESTS )
218 * ..
219 * .. External Functions ..
220  LOGICAL LSAME
221  REAL CLANGB, CLANGE, CLANTB, SGET06, SLAMCH
222  EXTERNAL lsame, clangb, clange, clantb, sget06, slamch
223 * ..
224 * .. External Subroutines ..
225  EXTERNAL aladhd, alaerh, alasvm, cerrvx, cgbequ, cgbsv,
226  $ cgbsvx, cgbt01, cgbt02, cgbt05, cgbtrf, cgbtrs,
227  $ cget04, clacpy, claqgb, clarhs, claset, clatb4,
228  $ clatms, xlaenv
229 * ..
230 * .. Intrinsic Functions ..
231  INTRINSIC abs, cmplx, max, min
232 * ..
233 * .. Scalars in Common ..
234  LOGICAL LERR, OK
235  CHARACTER*32 SRNAMT
236  INTEGER INFOT, NUNIT
237 * ..
238 * .. Common blocks ..
239  COMMON / infoc / infot, nunit, ok, lerr
240  COMMON / srnamc / srnamt
241 * ..
242 * .. Data statements ..
243  DATA iseedy / 1988, 1989, 1990, 1991 /
244  DATA transs / 'N', 'T', 'C' /
245  DATA facts / 'F', 'N', 'E' /
246  DATA equeds / 'N', 'R', 'C', 'B' /
247 * ..
248 * .. Executable Statements ..
249 *
250 * Initialize constants and the random number seed.
251 *
252  path( 1: 1 ) = 'Complex precision'
253  path( 2: 3 ) = 'GB'
254  nrun = 0
255  nfail = 0
256  nerrs = 0
257  DO 10 i = 1, 4
258  iseed( i ) = iseedy( i )
259  10 CONTINUE
260 *
261 * Test the error exits
262 *
263  IF( tsterr )
264  $ CALL cerrvx( path, nout )
265  infot = 0
266 *
267 * Set the block size and minimum block size for testing.
268 *
269  nb = 1
270  nbmin = 2
271  CALL xlaenv( 1, nb )
272  CALL xlaenv( 2, nbmin )
273 *
274 * Do for each value of N in NVAL
275 *
276  DO 150 in = 1, nn
277  n = nval( in )
278  ldb = max( n, 1 )
279  xtype = 'N'
280 *
281 * Set limits on the number of loop iterations.
282 *
283  nkl = max( 1, min( n, 4 ) )
284  IF( n.EQ.0 )
285  $ nkl = 1
286  nku = nkl
287  nimat = ntypes
288  IF( n.LE.0 )
289  $ nimat = 1
290 *
291  DO 140 ikl = 1, nkl
292 *
293 * Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes
294 * it easier to skip redundant values for small values of N.
295 *
296  IF( ikl.EQ.1 ) THEN
297  kl = 0
298  ELSE IF( ikl.EQ.2 ) THEN
299  kl = max( n-1, 0 )
300  ELSE IF( ikl.EQ.3 ) THEN
301  kl = ( 3*n-1 ) / 4
302  ELSE IF( ikl.EQ.4 ) THEN
303  kl = ( n+1 ) / 4
304  END IF
305  DO 130 iku = 1, nku
306 *
307 * Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order
308 * makes it easier to skip redundant values for small
309 * values of N.
310 *
311  IF( iku.EQ.1 ) THEN
312  ku = 0
313  ELSE IF( iku.EQ.2 ) THEN
314  ku = max( n-1, 0 )
315  ELSE IF( iku.EQ.3 ) THEN
316  ku = ( 3*n-1 ) / 4
317  ELSE IF( iku.EQ.4 ) THEN
318  ku = ( n+1 ) / 4
319  END IF
320 *
321 * Check that A and AFB are big enough to generate this
322 * matrix.
323 *
324  lda = kl + ku + 1
325  ldafb = 2*kl + ku + 1
326  IF( lda*n.GT.la .OR. ldafb*n.GT.lafb ) THEN
327  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
328  $ CALL aladhd( nout, path )
329  IF( lda*n.GT.la ) THEN
330  WRITE( nout, fmt = 9999 )la, n, kl, ku,
331  $ n*( kl+ku+1 )
332  nerrs = nerrs + 1
333  END IF
334  IF( ldafb*n.GT.lafb ) THEN
335  WRITE( nout, fmt = 9998 )lafb, n, kl, ku,
336  $ n*( 2*kl+ku+1 )
337  nerrs = nerrs + 1
338  END IF
339  GO TO 130
340  END IF
341 *
342  DO 120 imat = 1, nimat
343 *
344 * Do the tests only if DOTYPE( IMAT ) is true.
345 *
346  IF( .NOT.dotype( imat ) )
347  $ GO TO 120
348 *
349 * Skip types 2, 3, or 4 if the matrix is too small.
350 *
351  zerot = imat.GE.2 .AND. imat.LE.4
352  IF( zerot .AND. n.LT.imat-1 )
353  $ GO TO 120
354 *
355 * Set up parameters with CLATB4 and generate a
356 * test matrix with CLATMS.
357 *
358  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm,
359  $ mode, cndnum, dist )
360  rcondc = one / cndnum
361 *
362  srnamt = 'CLATMS'
363  CALL clatms( n, n, dist, iseed, TYPE, rwork, mode,
364  $ cndnum, anorm, kl, ku, 'Z', a, lda, work,
365  $ info )
366 *
367 * Check the error code from CLATMS.
368 *
369  IF( info.NE.0 ) THEN
370  CALL alaerh( path, 'CLATMS', info, 0, ' ', n, n,
371  $ kl, ku, -1, imat, nfail, nerrs, nout )
372  GO TO 120
373  END IF
374 *
375 * For types 2, 3, and 4, zero one or more columns of
376 * the matrix to test that INFO is returned correctly.
377 *
378  izero = 0
379  IF( zerot ) THEN
380  IF( imat.EQ.2 ) THEN
381  izero = 1
382  ELSE IF( imat.EQ.3 ) THEN
383  izero = n
384  ELSE
385  izero = n / 2 + 1
386  END IF
387  ioff = ( izero-1 )*lda
388  IF( imat.LT.4 ) THEN
389  i1 = max( 1, ku+2-izero )
390  i2 = min( kl+ku+1, ku+1+( n-izero ) )
391  DO 20 i = i1, i2
392  a( ioff+i ) = zero
393  20 CONTINUE
394  ELSE
395  DO 40 j = izero, n
396  DO 30 i = max( 1, ku+2-j ),
397  $ min( kl+ku+1, ku+1+( n-j ) )
398  a( ioff+i ) = zero
399  30 CONTINUE
400  ioff = ioff + lda
401  40 CONTINUE
402  END IF
403  END IF
404 *
405 * Save a copy of the matrix A in ASAV.
406 *
407  CALL clacpy( 'Full', kl+ku+1, n, a, lda, asav, lda )
408 *
409  DO 110 iequed = 1, 4
410  equed = equeds( iequed )
411  IF( iequed.EQ.1 ) THEN
412  nfact = 3
413  ELSE
414  nfact = 1
415  END IF
416 *
417  DO 100 ifact = 1, nfact
418  fact = facts( ifact )
419  prefac = lsame( fact, 'F' )
420  nofact = lsame( fact, 'N' )
421  equil = lsame( fact, 'E' )
422 *
423  IF( zerot ) THEN
424  IF( prefac )
425  $ GO TO 100
426  rcondo = zero
427  rcondi = zero
428 *
429  ELSE IF( .NOT.nofact ) THEN
430 *
431 * Compute the condition number for comparison
432 * with the value returned by SGESVX (FACT =
433 * 'N' reuses the condition number from the
434 * previous iteration with FACT = 'F').
435 *
436  CALL clacpy( 'Full', kl+ku+1, n, asav, lda,
437  $ afb( kl+1 ), ldafb )
438  IF( equil .OR. iequed.GT.1 ) THEN
439 *
440 * Compute row and column scale factors to
441 * equilibrate the matrix A.
442 *
443  CALL cgbequ( n, n, kl, ku, afb( kl+1 ),
444  $ ldafb, s, s( n+1 ), rowcnd,
445  $ colcnd, amax, info )
446  IF( info.EQ.0 .AND. n.GT.0 ) THEN
447  IF( lsame( equed, 'R' ) ) THEN
448  rowcnd = zero
449  colcnd = one
450  ELSE IF( lsame( equed, 'C' ) ) THEN
451  rowcnd = one
452  colcnd = zero
453  ELSE IF( lsame( equed, 'B' ) ) THEN
454  rowcnd = zero
455  colcnd = zero
456  END IF
457 *
458 * Equilibrate the matrix.
459 *
460  CALL claqgb( n, n, kl, ku, afb( kl+1 ),
461  $ ldafb, s, s( n+1 ),
462  $ rowcnd, colcnd, amax,
463  $ equed )
464  END IF
465  END IF
466 *
467 * Save the condition number of the
468 * non-equilibrated system for use in CGET04.
469 *
470  IF( equil ) THEN
471  roldo = rcondo
472  roldi = rcondi
473  END IF
474 *
475 * Compute the 1-norm and infinity-norm of A.
476 *
477  anormo = clangb( '1', n, kl, ku, afb( kl+1 ),
478  $ ldafb, rwork )
479  anormi = clangb( 'I', n, kl, ku, afb( kl+1 ),
480  $ ldafb, rwork )
481 *
482 * Factor the matrix A.
483 *
484  CALL cgbtrf( n, n, kl, ku, afb, ldafb, iwork,
485  $ info )
486 *
487 * Form the inverse of A.
488 *
489  CALL claset( 'Full', n, n, cmplx( zero ),
490  $ cmplx( one ), work, ldb )
491  srnamt = 'CGBTRS'
492  CALL cgbtrs( 'No transpose', n, kl, ku, n,
493  $ afb, ldafb, iwork, work, ldb,
494  $ info )
495 *
496 * Compute the 1-norm condition number of A.
497 *
498  ainvnm = clange( '1', n, n, work, ldb,
499  $ rwork )
500  IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
501  rcondo = one
502  ELSE
503  rcondo = ( one / anormo ) / ainvnm
504  END IF
505 *
506 * Compute the infinity-norm condition number
507 * of A.
508 *
509  ainvnm = clange( 'I', n, n, work, ldb,
510  $ rwork )
511  IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
512  rcondi = one
513  ELSE
514  rcondi = ( one / anormi ) / ainvnm
515  END IF
516  END IF
517 *
518  DO 90 itran = 1, ntran
519 *
520 * Do for each value of TRANS.
521 *
522  trans = transs( itran )
523  IF( itran.EQ.1 ) THEN
524  rcondc = rcondo
525  ELSE
526  rcondc = rcondi
527  END IF
528 *
529 * Restore the matrix A.
530 *
531  CALL clacpy( 'Full', kl+ku+1, n, asav, lda,
532  $ a, lda )
533 *
534 * Form an exact solution and set the right hand
535 * side.
536 *
537  srnamt = 'CLARHS'
538  CALL clarhs( path, xtype, 'Full', trans, n,
539  $ n, kl, ku, nrhs, a, lda, xact,
540  $ ldb, b, ldb, iseed, info )
541  xtype = 'C'
542  CALL clacpy( 'Full', n, nrhs, b, ldb, bsav,
543  $ ldb )
544 *
545  IF( nofact .AND. itran.EQ.1 ) THEN
546 *
547 * --- Test CGBSV ---
548 *
549 * Compute the LU factorization of the matrix
550 * and solve the system.
551 *
552  CALL clacpy( 'Full', kl+ku+1, n, a, lda,
553  $ afb( kl+1 ), ldafb )
554  CALL clacpy( 'Full', n, nrhs, b, ldb, x,
555  $ ldb )
556 *
557  srnamt = 'CGBSV '
558  CALL cgbsv( n, kl, ku, nrhs, afb, ldafb,
559  $ iwork, x, ldb, info )
560 *
561 * Check error code from CGBSV .
562 *
563  IF( info.NE.izero )
564  $ CALL alaerh( path, 'CGBSV ', info,
565  $ izero, ' ', n, n, kl, ku,
566  $ nrhs, imat, nfail, nerrs,
567  $ nout )
568 *
569 * Reconstruct matrix from factors and
570 * compute residual.
571 *
572  CALL cgbt01( n, n, kl, ku, a, lda, afb,
573  $ ldafb, iwork, work,
574  $ result( 1 ) )
575  nt = 1
576  IF( izero.EQ.0 ) THEN
577 *
578 * Compute residual of the computed
579 * solution.
580 *
581  CALL clacpy( 'Full', n, nrhs, b, ldb,
582  $ work, ldb )
583  CALL cgbt02( 'No transpose', n, n, kl,
584  $ ku, nrhs, a, lda, x, ldb,
585  $ work, ldb, result( 2 ) )
586 *
587 * Check solution from generated exact
588 * solution.
589 *
590  CALL cget04( n, nrhs, x, ldb, xact,
591  $ ldb, rcondc, result( 3 ) )
592  nt = 3
593  END IF
594 *
595 * Print information about the tests that did
596 * not pass the threshold.
597 *
598  DO 50 k = 1, nt
599  IF( result( k ).GE.thresh ) THEN
600  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
601  $ CALL aladhd( nout, path )
602  WRITE( nout, fmt = 9997 )'CGBSV ',
603  $ n, kl, ku, imat, k, result( k )
604  nfail = nfail + 1
605  END IF
606  50 CONTINUE
607  nrun = nrun + nt
608  END IF
609 *
610 * --- Test CGBSVX ---
611 *
612  IF( .NOT.prefac )
613  $ CALL claset( 'Full', 2*kl+ku+1, n,
614  $ cmplx( zero ), cmplx( zero ),
615  $ afb, ldafb )
616  CALL claset( 'Full', n, nrhs, cmplx( zero ),
617  $ cmplx( zero ), x, ldb )
618  IF( iequed.GT.1 .AND. n.GT.0 ) THEN
619 *
620 * Equilibrate the matrix if FACT = 'F' and
621 * EQUED = 'R', 'C', or 'B'.
622 *
623  CALL claqgb( n, n, kl, ku, a, lda, s,
624  $ s( n+1 ), rowcnd, colcnd,
625  $ amax, equed )
626  END IF
627 *
628 * Solve the system and compute the condition
629 * number and error bounds using CGBSVX.
630 *
631  srnamt = 'CGBSVX'
632  CALL cgbsvx( fact, trans, n, kl, ku, nrhs, a,
633  $ lda, afb, ldafb, iwork, equed,
634  $ s, s( ldb+1 ), b, ldb, x, ldb,
635  $ rcond, rwork, rwork( nrhs+1 ),
636  $ work, rwork( 2*nrhs+1 ), info )
637 *
638 * Check the error code from CGBSVX.
639 *
640  IF( info.NE.izero )
641  $ CALL alaerh( path, 'CGBSVX', info, izero,
642  $ fact // trans, n, n, kl, ku,
643  $ nrhs, imat, nfail, nerrs,
644  $ nout )
645 * Compare RWORK(2*NRHS+1) from CGBSVX with the
646 * computed reciprocal pivot growth RPVGRW
647 *
648  IF( info.NE.0 .AND. info.LE.n) THEN
649  anrmpv = zero
650  DO 70 j = 1, info
651  DO 60 i = max( ku+2-j, 1 ),
652  $ min( n+ku+1-j, kl+ku+1 )
653  anrmpv = max( anrmpv,
654  $ abs( a( i+( j-1 )*lda ) ) )
655  60 CONTINUE
656  70 CONTINUE
657  rpvgrw = clantb( 'M', 'U', 'N', info,
658  $ min( info-1, kl+ku ),
659  $ afb( max( 1, kl+ku+2-info ) ),
660  $ ldafb, rdum )
661  IF( rpvgrw.EQ.zero ) THEN
662  rpvgrw = one
663  ELSE
664  rpvgrw = anrmpv / rpvgrw
665  END IF
666  ELSE
667  rpvgrw = clantb( 'M', 'U', 'N', n, kl+ku,
668  $ afb, ldafb, rdum )
669  IF( rpvgrw.EQ.zero ) THEN
670  rpvgrw = one
671  ELSE
672  rpvgrw = clangb( 'M', n, kl, ku, a,
673  $ lda, rdum ) / rpvgrw
674  END IF
675  END IF
676  result( 7 ) = abs( rpvgrw-rwork( 2*nrhs+1 ) )
677  $ / max( rwork( 2*nrhs+1 ),
678  $ rpvgrw ) / slamch( 'E' )
679 *
680  IF( .NOT.prefac ) THEN
681 *
682 * Reconstruct matrix from factors and
683 * compute residual.
684 *
685  CALL cgbt01( n, n, kl, ku, a, lda, afb,
686  $ ldafb, iwork, work,
687  $ result( 1 ) )
688  k1 = 1
689  ELSE
690  k1 = 2
691  END IF
692 *
693  IF( info.EQ.0 ) THEN
694  trfcon = .false.
695 *
696 * Compute residual of the computed solution.
697 *
698  CALL clacpy( 'Full', n, nrhs, bsav, ldb,
699  $ work, ldb )
700  CALL cgbt02( trans, n, n, kl, ku, nrhs,
701  $ asav, lda, x, ldb, work, ldb,
702  $ result( 2 ) )
703 *
704 * Check solution from generated exact
705 * solution.
706 *
707  IF( nofact .OR. ( prefac .AND.
708  $ lsame( equed, 'N' ) ) ) THEN
709  CALL cget04( n, nrhs, x, ldb, xact,
710  $ ldb, rcondc, result( 3 ) )
711  ELSE
712  IF( itran.EQ.1 ) THEN
713  roldc = roldo
714  ELSE
715  roldc = roldi
716  END IF
717  CALL cget04( n, nrhs, x, ldb, xact,
718  $ ldb, roldc, result( 3 ) )
719  END IF
720 *
721 * Check the error bounds from iterative
722 * refinement.
723 *
724  CALL cgbt05( trans, n, kl, ku, nrhs, asav,
725  $ lda, bsav, ldb, x, ldb, xact,
726  $ ldb, rwork, rwork( nrhs+1 ),
727  $ result( 4 ) )
728  ELSE
729  trfcon = .true.
730  END IF
731 *
732 * Compare RCOND from CGBSVX with the computed
733 * value in RCONDC.
734 *
735  result( 6 ) = sget06( rcond, rcondc )
736 *
737 * Print information about the tests that did
738 * not pass the threshold.
739 *
740  IF( .NOT.trfcon ) THEN
741  DO 80 k = k1, ntests
742  IF( result( k ).GE.thresh ) THEN
743  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
744  $ CALL aladhd( nout, path )
745  IF( prefac ) THEN
746  WRITE( nout, fmt = 9995 )
747  $ 'CGBSVX', fact, trans, n, kl,
748  $ ku, equed, imat, k,
749  $ result( k )
750  ELSE
751  WRITE( nout, fmt = 9996 )
752  $ 'CGBSVX', fact, trans, n, kl,
753  $ ku, imat, k, result( k )
754  END IF
755  nfail = nfail + 1
756  END IF
757  80 CONTINUE
758  nrun = nrun + ntests - k1 + 1
759  ELSE
760  IF( result( 1 ).GE.thresh .AND. .NOT.
761  $ prefac ) THEN
762  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
763  $ CALL aladhd( nout, path )
764  IF( prefac ) THEN
765  WRITE( nout, fmt = 9995 )'CGBSVX',
766  $ fact, trans, n, kl, ku, equed,
767  $ imat, 1, result( 1 )
768  ELSE
769  WRITE( nout, fmt = 9996 )'CGBSVX',
770  $ fact, trans, n, kl, ku, imat, 1,
771  $ result( 1 )
772  END IF
773  nfail = nfail + 1
774  nrun = nrun + 1
775  END IF
776  IF( result( 6 ).GE.thresh ) THEN
777  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
778  $ CALL aladhd( nout, path )
779  IF( prefac ) THEN
780  WRITE( nout, fmt = 9995 )'CGBSVX',
781  $ fact, trans, n, kl, ku, equed,
782  $ imat, 6, result( 6 )
783  ELSE
784  WRITE( nout, fmt = 9996 )'CGBSVX',
785  $ fact, trans, n, kl, ku, imat, 6,
786  $ result( 6 )
787  END IF
788  nfail = nfail + 1
789  nrun = nrun + 1
790  END IF
791  IF( result( 7 ).GE.thresh ) THEN
792  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
793  $ CALL aladhd( nout, path )
794  IF( prefac ) THEN
795  WRITE( nout, fmt = 9995 )'CGBSVX',
796  $ fact, trans, n, kl, ku, equed,
797  $ imat, 7, result( 7 )
798  ELSE
799  WRITE( nout, fmt = 9996 )'CGBSVX',
800  $ fact, trans, n, kl, ku, imat, 7,
801  $ result( 7 )
802  END IF
803  nfail = nfail + 1
804  nrun = nrun + 1
805  END IF
806  END IF
807  90 CONTINUE
808  100 CONTINUE
809  110 CONTINUE
810  120 CONTINUE
811  130 CONTINUE
812  140 CONTINUE
813  150 CONTINUE
814 *
815 * Print a summary of the results.
816 *
817  CALL alasvm( path, nout, nfail, nrun, nerrs )
818 *
819  9999 FORMAT( ' *** In CDRVGB, LA=', i5, ' is too small for N=', i5,
820  $ ', KU=', i5, ', KL=', i5, / ' ==> Increase LA to at least ',
821  $ i5 )
822  9998 FORMAT( ' *** In CDRVGB, LAFB=', i5, ' is too small for N=', i5,
823  $ ', KU=', i5, ', KL=', i5, /
824  $ ' ==> Increase LAFB to at least ', i5 )
825  9997 FORMAT( 1x, a, ', N=', i5, ', KL=', i5, ', KU=', i5, ', type ',
826  $ i1, ', test(', i1, ')=', g12.5 )
827  9996 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
828  $ i5, ',...), type ', i1, ', test(', i1, ')=', g12.5 )
829  9995 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
830  $ i5, ',...), EQUED=''', a1, ''', type ', i1, ', test(', i1,
831  $ ')=', g12.5 )
832 *
833  RETURN
834 *
835 * End of CDRVGB
836 *
837  END
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:73
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:81
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:90
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:147
clarhs
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:209
clatb4
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:121
cget04
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:102
cgbt05
subroutine cgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CGBT05
Definition: cgbt05.f:176
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:172
cgbt01
subroutine cgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
CGBT01
Definition: cgbt01.f:126
cgbt02
subroutine cgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
CGBT02
Definition: cgbt02.f:139
cerrvx
subroutine cerrvx(PATH, NUNIT)
CERRVX
Definition: cerrvx.f:55
clatms
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:332
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:160
cgbtrf
subroutine cgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
CGBTRF
Definition: cgbtrf.f:144
cgbtrs
subroutine cgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
CGBTRS
Definition: cgbtrs.f:138
cgbequ
subroutine cgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
CGBEQU
Definition: cgbequ.f:154
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:370
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: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:106
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:103