LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
zdrvgbx.f
Go to the documentation of this file.
1 *> \brief \b ZDRVGBX
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 ZDRVGB( 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 RWORK( * ), S( * )
24 * COMPLEX*16 A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
25 * $ WORK( * ), X( * ), XACT( * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> ZDRVGB tests the driver routines ZGBSV, -SVX, and -SVXX.
35 *>
36 *> Note that this file is used only when the XBLAS are available,
37 *> otherwise zdrvgb.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 COMPLEX*16 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*16 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*16 array, dimension (LA)
111 *> \endverbatim
112 *>
113 *> \param[out] B
114 *> \verbatim
115 *> B is COMPLEX*16 array, dimension (NMAX*NRHS)
116 *> \endverbatim
117 *>
118 *> \param[out] BSAV
119 *> \verbatim
120 *> BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
121 *> \endverbatim
122 *>
123 *> \param[out] X
124 *> \verbatim
125 *> X is COMPLEX*16 array, dimension (NMAX*NRHS)
126 *> \endverbatim
127 *>
128 *> \param[out] XACT
129 *> \verbatim
130 *> XACT is COMPLEX*16 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 COMPLEX*16 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 (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 complex16_lin
172 *
173 * =====================================================================
174  SUBROUTINE zdrvgb( 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 rwork( * ), s( * )
192  COMPLEX*16 a( * ), afb( * ), asav( * ), b( * ), bsav( * ),
193  $ work( * ), x( * ), 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 rdum( 1 ), 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, zlangb, zlange, zlantb,
231  $ zla_gbrpvgrw
232  EXTERNAL lsame, dget06, dlamch, zlangb, zlange, zlantb,
233  $ zla_gbrpvgrw
234 * ..
235 * .. External Subroutines ..
236  EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zgbequ,
237  $ zgbsv, zgbsvx, zgbt01, zgbt02, zgbt05, zgbtrf,
238  $ zgbtrs, zget04, zlacpy, zlaqgb, zlarhs, zlaset,
239  $ zlatb4, zlatms, zgbsvxx
240 * ..
241 * .. Intrinsic Functions ..
242  INTRINSIC abs, dcmplx, 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 ) = 'Zomplex 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 zerrvx( 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 ZLATB4 and generate a
367 * test matrix with ZLATMS.
368 *
369  CALL zlatb4( path, imat, n, n, type, kl, ku, anorm,
370  $ mode, cndnum, dist )
371  rcondc = one / cndnum
372 *
373  srnamt = 'ZLATMS'
374  CALL zlatms( 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 ZLATMS.
379 *
380  IF( info.NE.0 ) THEN
381  CALL alaerh( path, 'ZLATMS', 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 zlacpy( '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 zlacpy( '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 zgbequ( 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 zlaqgb( 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 ZGET04.
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 = zlangb( '1', n, kl, ku, afb( kl+1 ),
489  $ ldafb, rwork )
490  anormi = zlangb( 'I', n, kl, ku, afb( kl+1 ),
491  $ ldafb, rwork )
492 *
493 * Factor the matrix A.
494 *
495  CALL zgbtrf( n, n, kl, ku, afb, ldafb, iwork,
496  $ info )
497 *
498 * Form the inverse of A.
499 *
500  CALL zlaset( 'Full', n, n, dcmplx( zero ),
501  $ dcmplx( one ), work, ldb )
502  srnamt = 'ZGBTRS'
503  CALL zgbtrs( '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 = zlange( '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 = zlange( '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 zlacpy( '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 = 'ZLARHS'
549  CALL zlarhs( path, xtype, 'Full', trans, n,
550  $ n, kl, ku, nrhs, a, lda, xact,
551  $ ldb, b, ldb, iseed, info )
552  xtype = 'C'
553  CALL zlacpy( 'Full', n, nrhs, b, ldb, bsav,
554  $ ldb )
555 *
556  IF( nofact .AND. itran.EQ.1 ) THEN
557 *
558 * --- Test ZGBSV ---
559 *
560 * Compute the LU factorization of the matrix
561 * and solve the system.
562 *
563  CALL zlacpy( 'Full', kl+ku+1, n, a, lda,
564  $ afb( kl+1 ), ldafb )
565  CALL zlacpy( 'Full', n, nrhs, b, ldb, x,
566  $ ldb )
567 *
568  srnamt = 'ZGBSV '
569  CALL zgbsv( n, kl, ku, nrhs, afb, ldafb,
570  $ iwork, x, ldb, info )
571 *
572 * Check error code from ZGBSV .
573 *
574  IF( info.NE.izero )
575  $ CALL alaerh( path, 'ZGBSV ', 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 zgbt01( 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 zlacpy( 'Full', n, nrhs, b, ldb,
593  $ work, ldb )
594  CALL zgbt02( '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 zget04( 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 )'ZGBSV ',
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 ZGBSVX ---
622 *
623  IF( .NOT.prefac )
624  $ CALL zlaset( 'Full', 2*kl+ku+1, n,
625  $ dcmplx( zero ),
626  $ dcmplx( zero ), afb, ldafb )
627  CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
628  $ dcmplx( 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 zlaqgb( 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 ZGBSVX.
641 *
642  srnamt = 'ZGBSVX'
643  CALL zgbsvx( 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 ZGBSVX.
650 *
651  IF( info.NE.izero )
652  $ CALL alaerh( path, 'ZGBSVX', info, izero,
653  $ fact // trans, n, n, kl, ku,
654  $ nrhs, imat, nfail, nerrs,
655  $ nout )
656 *
657 * Compare RWORK(2*NRHS+1) from ZGBSVX 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 = zlantb( '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 = zlantb( 'M', 'U', 'N', n, kl+ku,
680  $ afb, ldafb, rdum )
681  IF( rpvgrw.EQ.zero ) THEN
682  rpvgrw = one
683  ELSE
684  rpvgrw = zlangb( '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 ) / dlamch( 'E' )
691 *
692  IF( .NOT.prefac ) THEN
693 *
694 * Reconstruct matrix from factors and
695 * compute residual.
696 *
697  CALL zgbt01( 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 zlacpy( 'Full', n, nrhs, bsav, ldb,
711  $ work, ldb )
712  CALL zgbt02( 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 zget04( 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 zget04( 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 zgbt05( 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 ZGBSVX with the computed
745 * value in RCONDC.
746 *
747  result( 6 ) = dget06( 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  $ 'ZGBSVX', fact, trans, n, kl,
760  $ ku, equed, imat, k,
761  $ result( k )
762  ELSE
763  WRITE( nout, fmt = 9996 )
764  $ 'ZGBSVX', 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 )'ZGBSVX',
778  $ fact, trans, n, kl, ku, equed,
779  $ imat, 1, result( 1 )
780  ELSE
781  WRITE( nout, fmt = 9996 )'ZGBSVX',
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 )'ZGBSVX',
793  $ fact, trans, n, kl, ku, equed,
794  $ imat, 6, result( 6 )
795  ELSE
796  WRITE( nout, fmt = 9996 )'ZGBSVX',
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 )'ZGBSVX',
808  $ fact, trans, n, kl, ku, equed,
809  $ imat, 7, result( 7 )
810  ELSE
811  WRITE( nout, fmt = 9996 )'ZGBSVX',
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 ZGBSVXX ---
821 
822 * Restore the matrices A and B.
823 
824 c write(*,*) 'begin zgbsvxx testing'
825 
826  CALL zlacpy( 'Full', kl+ku+1, n, asav, lda, a,
827  $ lda )
828  CALL zlacpy( 'Full', n, nrhs, bsav, ldb, b, ldb )
829 
830  IF( .NOT.prefac )
831  $ CALL zlaset( 'Full', 2*kl+ku+1, n,
832  $ dcmplx( zero ), dcmplx( zero ),
833  $ afb, ldafb )
834  CALL zlaset( 'Full', n, nrhs,
835  $ dcmplx( zero ), dcmplx( 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 zlaqgb( 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 ZGBSVXX.
848 *
849  srnamt = 'ZGBSVXX'
850  n_err_bnds = 3
851  CALL zgbsvxx( 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 ZGBSVXX.
858 *
859  IF( info.EQ.n+1 ) goto 90
860  IF( info.NE.izero ) THEN
861  CALL alaerh( path, 'ZGBSVXX', 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 ZGESVXX with the computed
868 * reciprocal pivot growth factor RPVGRW
869 *
870 
871  IF ( info .GT. 0 .AND. info .LT. n+1 ) THEN
872  rpvgrw = zla_gbrpvgrw(n, kl, ku, info, a, lda,
873  $ afb, ldafb)
874  ELSE
875  rpvgrw = zla_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  $ dlamch( 'E' )
882 *
883  IF( .NOT.prefac ) THEN
884 *
885 * Reconstruct matrix from factors and compute
886 * residual.
887 *
888  CALL zgbt01( 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 zlacpy( 'Full', n, nrhs, bsav, ldb, work,
901  $ ldb )
902  CALL zgbt02( 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 zget04( 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 zget04( 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 ZGBSVXX with the computed value
925 * in RCONDC.
926 *
927  result( 6 ) = dget06( 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 )'ZGBSVXX',
939  $ fact, trans, n, kl, ku, equed,
940  $ imat, k, result( k )
941  ELSE
942  WRITE( nout, fmt = 9996 )'ZGBSVXX',
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 )'ZGBSVXX', fact,
957  $ trans, n, kl, ku, equed, imat, 1,
958  $ result( 1 )
959  ELSE
960  WRITE( nout, fmt = 9996 )'ZGBSVXX', 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 )'ZGBSVXX', fact,
972  $ trans, n, kl, ku, equed, imat, 6,
973  $ result( 6 )
974  ELSE
975  WRITE( nout, fmt = 9996 )'ZGBSVXX', 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 )'ZGBSVXX', fact,
987  $ trans, n, kl, ku, equed, imat, 7,
988  $ result( 7 )
989  ELSE
990  WRITE( nout, fmt = 9996 )'ZGBSVXX', 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 ZGBSVXX
1014 
1015  CALL zebchvxx(thresh, path)
1016 
1017  9999 format( ' *** In ZDRVGB, LA=', i5, ' is too small for N=', i5,
1018  $ ', KU=', i5, ', KL=', i5, / ' ==> Increase LA to at least ',
1019  $ i5 )
1020  9998 format( ' *** In ZDRVGB, 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 ZDRVGB
1034 *
1035  END