LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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
zlaqgb
subroutine zlaqgb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED)
ZLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ...
Definition: zlaqgb.f:162
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
zla_gbrpvgrw
double precision function zla_gbrpvgrw(N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB)
ZLA_GBRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a general banded matrix...
Definition: zla_gbrpvgrw.f:119
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
zgbtrs
subroutine zgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
ZGBTRS
Definition: zgbtrs.f:140
zlacpy
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:105
zgbt02
subroutine zgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
ZGBT02
Definition: zgbt02.f:141
zget04
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
Definition: zget04.f:104
zgbsv
subroutine zgbsv(N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
ZGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver) ...
Definition: zgbsv.f:164
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
zlarhs
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
Definition: zlarhs.f:211
zgbsvxx
subroutine zgbsvxx(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)
ZGBSVXX computes the solution to system of linear equations A * X = B for GB matrices ...
Definition: zgbsvxx.f:562
zgbequ
subroutine zgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
ZGBEQU
Definition: zgbequ.f:156
zlaset
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: zlaset.f:108
zgbt01
subroutine zgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
ZGBT01
Definition: zgbt01.f:128
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
zlantb
double precision function zlantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
ZLANTB 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: zlantb.f:143
zgbsvx
subroutine zgbsvx(FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
ZGBSVX computes the solution to system of linear equations A * X = B for GB matrices ...
Definition: zgbsvx.f:372
zgbtrf
subroutine zgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
ZGBTRF
Definition: zgbtrf.f:146
zlatb4
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
Definition: zlatb4.f:123
zlange
double precision function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: zlange.f:117
zebchvxx
subroutine zebchvxx(THRESH, PATH)
ZEBCHVXX
Definition: zebchvxx.f:98
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:80
zdrvgb
subroutine zdrvgb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
ZDRVGB
Definition: zdrvgb.f:174
dget06
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:57
zerrvx
subroutine zerrvx(PATH, NUNIT)
ZERRVX
Definition: zerrvx.f:57
zlatms
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
Definition: zlatms.f:334
zgbt05
subroutine zgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZGBT05
Definition: zgbt05.f:178
zlangb
double precision function zlangb(NORM, N, KL, KU, AB, LDAB, WORK)
ZLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: zlangb.f:127
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55