Home
Browse Files
  1       SUBROUTINE CDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
  2      $                   AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
  3      $                   RWORK, IWORK, NOUT )
  4 *
  5 *  -- LAPACK test routine (version 3.2.2) --
  6 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
  7 *     April 2009
  8 *
  9 *     .. Scalar Arguments ..
 10       LOGICAL            TSTERR
 11       INTEGER            LA, LAFB, NN, NOUT, NRHS
 12       REAL               THRESH
 13 *     ..
 14 *     .. Array Arguments ..
 15       LOGICAL            DOTYPE( * )
 16       INTEGER            IWORK( * ), NVAL( * )
 17       REAL               RWORK( * ), S( * )
 18       COMPLEX            A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
 19      $                   WORK( * ), X( * ), XACT( * )
 20 *     ..
 21 *
 22 *  Purpose
 23 *  =======
 24 *
 25 *  CDRVGB tests the driver routines CGBSV, -SVX, and -SVXX.
 26 *
 27 *  Note that this file is used only when the XBLAS are available,
 28 *  otherwise cdrvgb.f defines this subroutine.
 29 *
 30 *  Arguments
 31 *  =========
 32 *
 33 *  DOTYPE  (input) LOGICAL array, dimension (NTYPES)
 34 *          The matrix types to be used for testing.  Matrices of type j
 35 *          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
 36 *          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
 37 *
 38 *  NN      (input) INTEGER
 39 *          The number of values of N contained in the vector NVAL.
 40 *
 41 *  NVAL    (input) INTEGER array, dimension (NN)
 42 *          The values of the matrix column dimension N.
 43 *
 44 *  NRHS    (input) INTEGER
 45 *          The number of right hand side vectors to be generated for
 46 *          each linear system.
 47 *
 48 *  THRESH  (input) REAL
 49 *          The threshold value for the test ratios.  A result is
 50 *          included in the output file if RESULT >= THRESH.  To have
 51 *          every test ratio printed, use THRESH = 0.
 52 *
 53 *  TSTERR  (input) LOGICAL
 54 *          Flag that indicates whether error exits are to be tested.
 55 *
 56 *  A       (workspace) COMPLEX array, dimension (LA)
 57 *
 58 *  LA      (input) INTEGER
 59 *          The length of the array A.  LA >= (2*NMAX-1)*NMAX
 60 *          where NMAX is the largest entry in NVAL.
 61 *
 62 *  AFB     (workspace) COMPLEX array, dimension (LAFB)
 63 *
 64 *  LAFB    (input) INTEGER
 65 *          The length of the array AFB.  LAFB >= (3*NMAX-2)*NMAX
 66 *          where NMAX is the largest entry in NVAL.
 67 *
 68 *  ASAV    (workspace) COMPLEX array, dimension (LA)
 69 *
 70 *  B       (workspace) COMPLEX array, dimension (NMAX*NRHS)
 71 *
 72 *  BSAV    (workspace) COMPLEX array, dimension (NMAX*NRHS)
 73 *
 74 *  X       (workspace) COMPLEX array, dimension (NMAX*NRHS)
 75 *
 76 *  XACT    (workspace) COMPLEX array, dimension (NMAX*NRHS)
 77 *
 78 *  S       (workspace) REAL array, dimension (2*NMAX)
 79 *
 80 *  WORK    (workspace) COMPLEX array, dimension
 81 *                      (NMAX*max(3,NRHS,NMAX))
 82 *
 83 *  RWORK   (workspace) REAL array, dimension
 84 *                      (max(NMAX,2*NRHS))
 85 *
 86 *  IWORK   (workspace) INTEGER array, dimension (NMAX)
 87 *
 88 *  NOUT    (input) INTEGER
 89 *          The unit number for output.
 90 *
 91 *  =====================================================================
 92 *
 93 *     .. Parameters ..
 94       REAL               ONE, ZERO
 95       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
 96       INTEGER            NTYPES
 97       PARAMETER          ( NTYPES = 8 )
 98       INTEGER            NTESTS
 99       PARAMETER          ( NTESTS = 7 )
100       INTEGER            NTRAN
101       PARAMETER          ( NTRAN = 3 )
102 *     ..
103 *     .. Local Scalars ..
104       LOGICAL            EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
105       CHARACTER          DIST, EQUED, FACT, TRANS, TYPE, XTYPE
106       CHARACTER*3        PATH
107       INTEGER            I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
108      $                   INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU,
109      $                   LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS,
110      $                   NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT,
111      $                   N_ERR_BNDS
112       REAL               AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
113      $                   CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
114      $                   ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW,
115      $                   RPVGRW_SVXX
116 *     ..
117 *     .. Local Arrays ..
118       CHARACTER          EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
119       INTEGER            ISEED( 4 ), ISEEDY( 4 )
120       REAL               RDUM( 1 ), RESULT( NTESTS ), BERR( NRHS ),
121      $                   ERRBNDS_N( NRHS,3 ), ERRBNDS_C( NRHS, 3 )
122 *     ..
123 *     .. External Functions ..
124       LOGICAL            LSAME
125       REAL               CLANGB, CLANGE, CLANTB, SGET06, SLAMCH,
126      $                   CLA_GBRPVGRW
127       EXTERNAL           LSAME, CLANGB, CLANGE, CLANTB, SGET06, SLAMCH,
128      $                   CLA_GBRPVGRW
129 *     ..
130 *     .. External Subroutines ..
131       EXTERNAL           ALADHD, ALAERH, ALASVM, CERRVX, CGBEQU, CGBSV,
132      $                   CGBSVX, CGBT01, CGBT02, CGBT05, CGBTRF, CGBTRS,
133      $                   CGET04, CLACPY, CLAQGB, CLARHS, CLASET, CLATB4,
134      $                   CLATMS, XLAENV, CGBSVXX
135 *     ..
136 *     .. Intrinsic Functions ..
137       INTRINSIC          ABS, CMPLX, MAX, MIN
138 *     ..
139 *     .. Scalars in Common ..
140       LOGICAL            LERR, OK
141       CHARACTER*32       SRNAMT
142       INTEGER            INFOT, NUNIT
143 *     ..
144 *     .. Common blocks ..
145       COMMON             / INFOC / INFOT, NUNIT, OK, LERR
146       COMMON             / SRNAMC / SRNAMT
147 *     ..
148 *     .. Data statements ..
149       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
150       DATA               TRANSS / 'N', 'T', 'C' /
151       DATA               FACTS / 'F', 'N', 'E' /
152       DATA               EQUEDS / 'N', 'R', 'C', 'B' /
153 *     ..
154 *     .. Executable Statements ..
155 *
156 *     Initialize constants and the random number seed.
157 *
158       PATH( 1: 1 ) = 'Complex precision'
159       PATH( 2: 3 ) = 'GB'
160       NRUN = 0
161       NFAIL = 0
162       NERRS = 0
163       DO 10 I = 1, 4
164          ISEED( I ) = ISEEDY( I )
165    10 CONTINUE
166 *
167 *     Test the error exits
168 *
169       IF( TSTERR )
170      $   CALL CERRVX( PATH, NOUT )
171       INFOT = 0
172 *
173 *     Set the block size and minimum block size for testing.
174 *
175       NB = 1
176       NBMIN = 2
177       CALL XLAENV( 1, NB )
178       CALL XLAENV( 2, NBMIN )
179 *
180 *     Do for each value of N in NVAL
181 *
182       DO 150 IN = 1, NN
183          N = NVAL( IN )
184          LDB = MAX( N, 1 )
185          XTYPE = 'N'
186 *
187 *        Set limits on the number of loop iterations.
188 *
189          NKL = MAX( 1, MIN( N, 4 ) )
190          IF( N.EQ.0 )
191      $      NKL = 1
192          NKU = NKL
193          NIMAT = NTYPES
194          IF( N.LE.0 )
195      $      NIMAT = 1
196 *
197          DO 140 IKL = 1, NKL
198 *
199 *           Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes
200 *           it easier to skip redundant values for small values of N.
201 *
202             IF( IKL.EQ.1 ) THEN
203                KL = 0
204             ELSE IF( IKL.EQ.2 ) THEN
205                KL = MAX( N-1, 0 )
206             ELSE IF( IKL.EQ.3 ) THEN
207                KL = ( 3*N-1 ) / 4
208             ELSE IF( IKL.EQ.4 ) THEN
209                KL = ( N+1 ) / 4
210             END IF
211             DO 130 IKU = 1, NKU
212 *
213 *              Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order
214 *              makes it easier to skip redundant values for small
215 *              values of N.
216 *
217                IF( IKU.EQ.1 ) THEN
218                   KU = 0
219                ELSE IF( IKU.EQ.2 ) THEN
220                   KU = MAX( N-1, 0 )
221                ELSE IF( IKU.EQ.3 ) THEN
222                   KU = ( 3*N-1 ) / 4
223                ELSE IF( IKU.EQ.4 ) THEN
224                   KU = ( N+1 ) / 4
225                END IF
226 *
227 *              Check that A and AFB are big enough to generate this
228 *              matrix.
229 *
230                LDA = KL + KU + 1
231                LDAFB = 2*KL + KU + 1
232                IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN
233                   IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
234      $               CALL ALADHD( NOUT, PATH )
235                   IF( LDA*N.GT.LA ) THEN
236                      WRITE( NOUT, FMT = 9999 )LA, N, KL, KU,
237      $                  N*( KL+KU+1 )
238                      NERRS = NERRS + 1
239                   END IF
240                   IF( LDAFB*N.GT.LAFB ) THEN
241                      WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU,
242      $                  N*( 2*KL+KU+1 )
243                      NERRS = NERRS + 1
244                   END IF
245                   GO TO 130
246                END IF
247 *
248                DO 120 IMAT = 1, NIMAT
249 *
250 *                 Do the tests only if DOTYPE( IMAT ) is true.
251 *
252                   IF( .NOT.DOTYPE( IMAT ) )
253      $               GO TO 120
254 *
255 *                 Skip types 2, 3, or 4 if the matrix is too small.
256 *
257                   ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
258                   IF( ZEROT .AND. N.LT.IMAT-1 )
259      $               GO TO 120
260 *
261 *                 Set up parameters with CLATB4 and generate a
262 *                 test matrix with CLATMS.
263 *
264                   CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
265      $                         MODE, CNDNUM, DIST )
266                   RCONDC = ONE / CNDNUM
267 *
268                   SRNAMT = 'CLATMS'
269                   CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
270      $                         CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK,
271      $                         INFO )
272 *
273 *                 Check the error code from CLATMS.
274 *
275                   IF( INFO.NE.0 ) THEN
276                      CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', N, N,
277      $                            KL, KU, -1, IMAT, NFAIL, NERRS, NOUT )
278                      GO TO 120
279                   END IF
280 *
281 *                 For types 2, 3, and 4, zero one or more columns of
282 *                 the matrix to test that INFO is returned correctly.
283 *
284                   IZERO = 0
285                   IF( ZEROT ) THEN
286                      IF( IMAT.EQ.2 ) THEN
287                         IZERO = 1
288                      ELSE IF( IMAT.EQ.3 ) THEN
289                         IZERO = N
290                      ELSE
291                         IZERO = N / 2 + 1
292                      END IF
293                      IOFF = ( IZERO-1 )*LDA
294                      IF( IMAT.LT.4 ) THEN
295                         I1 = MAX( 1, KU+2-IZERO )
296                         I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) )
297                         DO 20 I = I1, I2
298                            A( IOFF+I ) = ZERO
299    20                   CONTINUE
300                      ELSE
301                         DO 40 J = IZERO, N
302                            DO 30 I = MAX( 1, KU+2-J ),
303      $                             MIN( KL+KU+1, KU+1+( N-J ) )
304                               A( IOFF+I ) = ZERO
305    30                      CONTINUE
306                            IOFF = IOFF + LDA
307    40                   CONTINUE
308                      END IF
309                   END IF
310 *
311 *                 Save a copy of the matrix A in ASAV.
312 *
313                   CALL CLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA )
314 *
315                   DO 110 IEQUED = 1, 4
316                      EQUED = EQUEDS( IEQUED )
317                      IF( IEQUED.EQ.1 ) THEN
318                         NFACT = 3
319                      ELSE
320                         NFACT = 1
321                      END IF
322 *
323                      DO 100 IFACT = 1, NFACT
324                         FACT = FACTS( IFACT )
325                         PREFAC = LSAME( FACT, 'F' )
326                         NOFACT = LSAME( FACT, 'N' )
327                         EQUIL = LSAME( FACT, 'E' )
328 *
329                         IF( ZEROT ) THEN
330                            IF( PREFAC )
331      $                        GO TO 100
332                            RCONDO = ZERO
333                            RCONDI = ZERO
334 *
335                         ELSE IF( .NOT.NOFACT ) THEN
336 *
337 *                          Compute the condition number for comparison
338 *                          with the value returned by SGESVX (FACT =
339 *                          'N' reuses the condition number from the
340 *                          previous iteration with FACT = 'F').
341 *
342                            CALL CLACPY( 'Full', KL+KU+1, N, ASAV, LDA,
343      $                                  AFB( KL+1 ), LDAFB )
344                            IF( EQUIL .OR. IEQUED.GT.1 ) THEN
345 *
346 *                             Compute row and column scale factors to
347 *                             equilibrate the matrix A.
348 *
349                               CALL CGBEQU( N, N, KL, KU, AFB( KL+1 ),
350      $                                     LDAFB, S, S( N+1 ), ROWCND,
351      $                                     COLCND, AMAX, INFO )
352                               IF( INFO.EQ.0 .AND. N.GT.0 ) THEN
353                                  IF( LSAME( EQUED, 'R' ) ) THEN
354                                     ROWCND = ZERO
355                                     COLCND = ONE
356                                  ELSE IF( LSAME( EQUED, 'C' ) ) THEN
357                                     ROWCND = ONE
358                                     COLCND = ZERO
359                                  ELSE IF( LSAME( EQUED, 'B' ) ) THEN
360                                     ROWCND = ZERO
361                                     COLCND = ZERO
362                                  END IF
363 *
364 *                                Equilibrate the matrix.
365 *
366                                  CALL CLAQGB( N, N, KL, KU, AFB( KL+1 ),
367      $                                        LDAFB, S, S( N+1 ),
368      $                                        ROWCND, COLCND, AMAX,
369      $                                        EQUED )
370                               END IF
371                            END IF
372 *
373 *                          Save the condition number of the
374 *                          non-equilibrated system for use in CGET04.
375 *
376                            IF( EQUIL ) THEN
377                               ROLDO = RCONDO
378                               ROLDI = RCONDI
379                            END IF
380 *
381 *                          Compute the 1-norm and infinity-norm of A.
382 *
383                            ANORMO = CLANGB( '1', N, KL, KU, AFB( KL+1 ),
384      $                              LDAFB, RWORK )
385                            ANORMI = CLANGB( 'I', N, KL, KU, AFB( KL+1 ),
386      $                              LDAFB, RWORK )
387 *
388 *                          Factor the matrix A.
389 *
390                            CALL CGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK,
391      $                                  INFO )
392 *
393 *                          Form the inverse of A.
394 *
395                            CALL CLASET( 'Full', N, N, CMPLX( ZERO ),
396      $                                  CMPLX( ONE ), WORK, LDB )
397                            SRNAMT = 'CGBTRS'
398                            CALL CGBTRS( 'No transpose', N, KL, KU, N,
399      $                                  AFB, LDAFB, IWORK, WORK, LDB,
400      $                                  INFO )
401 *
402 *                          Compute the 1-norm condition number of A.
403 *
404                            AINVNM = CLANGE( '1', N, N, WORK, LDB,
405      $                              RWORK )
406                            IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
407                               RCONDO = ONE
408                            ELSE
409                               RCONDO = ( ONE / ANORMO ) / AINVNM
410                            END IF
411 *
412 *                          Compute the infinity-norm condition number
413 *                          of A.
414 *
415                            AINVNM = CLANGE( 'I', N, N, WORK, LDB,
416      $                              RWORK )
417                            IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
418                               RCONDI = ONE
419                            ELSE
420                               RCONDI = ( ONE / ANORMI ) / AINVNM
421                            END IF
422                         END IF
423 *
424                         DO 90 ITRAN = 1, NTRAN
425 *
426 *                          Do for each value of TRANS.
427 *
428                            TRANS = TRANSS( ITRAN )
429                            IF( ITRAN.EQ.1 ) THEN
430                               RCONDC = RCONDO
431                            ELSE
432                               RCONDC = RCONDI
433                            END IF
434 *
435 *                          Restore the matrix A.
436 *
437                            CALL CLACPY( 'Full', KL+KU+1, N, ASAV, LDA,
438      $                                  A, LDA )
439 *
440 *                          Form an exact solution and set the right hand
441 *                          side.
442 *
443                            SRNAMT = 'CLARHS'
444                            CALL CLARHS( PATH, XTYPE, 'Full', TRANS, N,
445      $                                  N, KL, KU, NRHS, A, LDA, XACT,
446      $                                  LDB, B, LDB, ISEED, INFO )
447                            XTYPE = 'C'
448                            CALL CLACPY( 'Full', N, NRHS, B, LDB, BSAV,
449      $                                  LDB )
450 *
451                            IF( NOFACT .AND. ITRAN.EQ.1 ) THEN
452 *
453 *                             --- Test CGBSV  ---
454 *
455 *                             Compute the LU factorization of the matrix
456 *                             and solve the system.
457 *
458                               CALL CLACPY( 'Full', KL+KU+1, N, A, LDA,
459      $                                     AFB( KL+1 ), LDAFB )
460                               CALL CLACPY( 'Full', N, NRHS, B, LDB, X,
461      $                                     LDB )
462 *
463                               SRNAMT = 'CGBSV '
464                               CALL CGBSV( N, KL, KU, NRHS, AFB, LDAFB,
465      $                                    IWORK, X, LDB, INFO )
466 *
467 *                             Check error code from CGBSV .
468 *
469                               IF( INFO.NE.IZERO )
470      $                           CALL ALAERH( PATH, 'CGBSV ', INFO,
471      $                                        IZERO, ' ', N, N, KL, KU,
472      $                                        NRHS, IMAT, NFAIL, NERRS,
473      $                                        NOUT )
474 *
475 *                             Reconstruct matrix from factors and
476 *                             compute residual.
477 *
478                               CALL CGBT01( N, N, KL, KU, A, LDA, AFB,
479      $                                     LDAFB, IWORK, WORK,
480      $                                     RESULT( 1 ) )
481                               NT = 1
482                               IF( IZERO.EQ.0 ) THEN
483 *
484 *                                Compute residual of the computed
485 *                                solution.
486 *
487                                  CALL CLACPY( 'Full', N, NRHS, B, LDB,
488      $                                        WORK, LDB )
489                                  CALL CGBT02( 'No transpose', N, N, KL,
490      $                                        KU, NRHS, A, LDA, X, LDB,
491      $                                        WORK, LDB, RESULT( 2 ) )
492 *
493 *                                Check solution from generated exact
494 *                                solution.
495 *
496                                  CALL CGET04( N, NRHS, X, LDB, XACT,
497      $                                        LDB, RCONDC, RESULT( 3 ) )
498                                  NT = 3
499                               END IF
500 *
501 *                             Print information about the tests that did
502 *                             not pass the threshold.
503 *
504                               DO 50 K = 1, NT
505                                  IF( RESULT( K ).GE.THRESH ) THEN
506                                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
507      $                                 CALL ALADHD( NOUT, PATH )
508                                     WRITE( NOUT, FMT = 9997 )'CGBSV ',
509      $                                 N, KL, KU, IMAT, K, RESULT( K )
510                                     NFAIL = NFAIL + 1
511                                  END IF
512    50                         CONTINUE
513                               NRUN = NRUN + NT
514                            END IF
515 *
516 *                          --- Test CGBSVX ---
517 *
518                            IF( .NOT.PREFAC )
519      $                        CALL CLASET( 'Full', 2*KL+KU+1, N,
520      $                                     CMPLX( ZERO ), CMPLX( ZERO ),
521      $                                     AFB, LDAFB )
522                            CALL CLASET( 'Full', N, NRHS, CMPLX( ZERO ),
523      $                                  CMPLX( ZERO ), X, LDB )
524                            IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
525 *
526 *                             Equilibrate the matrix if FACT = 'F' and
527 *                             EQUED = 'R', 'C', or 'B'.
528 *
529                               CALL CLAQGB( N, N, KL, KU, A, LDA, S,
530      $                                     S( N+1 ), ROWCND, COLCND,
531      $                                     AMAX, EQUED )
532                            END IF
533 *
534 *                          Solve the system and compute the condition
535 *                          number and error bounds using CGBSVX.
536 *
537                            SRNAMT = 'CGBSVX'
538                            CALL CGBSVX( FACT, TRANS, N, KL, KU, NRHS, A,
539      $                                  LDA, AFB, LDAFB, IWORK, EQUED,
540      $                                  S, S( LDB+1 ), B, LDB, X, LDB,
541      $                                  RCOND, RWORK, RWORK( NRHS+1 ),
542      $                                  WORK, RWORK( 2*NRHS+1 ), INFO )
543 *
544 *                          Check the error code from CGBSVX.
545 *
546                            IF( INFO.NE.IZERO )
547      $                        CALL ALAERH( PATH, 'CGBSVX', INFO, IZERO,
548      $                                     FACT // TRANS, N, N, KL, KU,
549      $                                     NRHS, IMAT, NFAIL, NERRS,
550      $                                     NOUT )
551 *
552 *                          Compare RWORK(2*NRHS+1) from CGBSVX with the
553 *                          computed reciprocal pivot growth RPVGRW
554 *
555                            IF( INFO.NE.0 ) THEN
556                               ANRMPV = ZERO
557                               DO 70 J = 1, INFO
558                                  DO 60 I = MAX( KU+2-J, 1 ),
559      $                                   MIN( N+KU+1-J, KL+KU+1 )
560                                     ANRMPV = MAX( ANRMPV,
561      $                                       ABS( A( I+( J-1 )*LDA ) ) )
562    60                            CONTINUE
563    70                         CONTINUE
564                               RPVGRW = CLANTB( 'M', 'U', 'N', INFO,
565      $                                 MIN( INFO-1, KL+KU ),
566      $                                 AFB( MAX( 1, KL+KU+2-INFO ) ),
567      $                                 LDAFB, RDUM )
568                               IF( RPVGRW.EQ.ZERO ) THEN
569                                  RPVGRW = ONE
570                               ELSE
571                                  RPVGRW = ANRMPV / RPVGRW
572                               END IF
573                            ELSE
574                               RPVGRW = CLANTB( 'M', 'U', 'N', N, KL+KU,
575      $                                 AFB, LDAFB, RDUM )
576                               IF( RPVGRW.EQ.ZERO ) THEN
577                                  RPVGRW = ONE
578                               ELSE
579                                  RPVGRW = CLANGB( 'M', N, KL, KU, A,
580      $                                    LDA, RDUM ) / RPVGRW
581                               END IF
582                            END IF
583                            RESULT( 7 ) = ABS( RPVGRW-RWORK( 2*NRHS+1 ) )
584      $                                    / MAX( RWORK( 2*NRHS+1 ),
585      $                                   RPVGRW ) / SLAMCH( 'E' )
586 *
587                            IF( .NOT.PREFAC ) THEN
588 *
589 *                             Reconstruct matrix from factors and
590 *                             compute residual.
591 *
592                               CALL CGBT01( N, N, KL, KU, A, LDA, AFB,
593      $                                     LDAFB, IWORK, WORK,
594      $                                     RESULT( 1 ) )
595                               K1 = 1
596                            ELSE
597                               K1 = 2
598                            END IF
599 *
600                            IF( INFO.EQ.0 ) THEN
601                               TRFCON = .FALSE.
602 *
603 *                             Compute residual of the computed solution.
604 *
605                               CALL CLACPY( 'Full', N, NRHS, BSAV, LDB,
606      $                                     WORK, LDB )
607                               CALL CGBT02( TRANS, N, N, KL, KU, NRHS,
608      $                                     ASAV, LDA, X, LDB, WORK, LDB,
609      $                                     RESULT( 2 ) )
610 *
611 *                             Check solution from generated exact
612 *                             solution.
613 *
614                               IF( NOFACT .OR. ( PREFAC .AND.
615      $                            LSAME( EQUED, 'N' ) ) ) THEN
616                                  CALL CGET04( N, NRHS, X, LDB, XACT,
617      $                                        LDB, RCONDC, RESULT( 3 ) )
618                               ELSE
619                                  IF( ITRAN.EQ.1 ) THEN
620                                     ROLDC = ROLDO
621                                  ELSE
622                                     ROLDC = ROLDI
623                                  END IF
624                                  CALL CGET04( N, NRHS, X, LDB, XACT,
625      $                                        LDB, ROLDC, RESULT( 3 ) )
626                               END IF
627 *
628 *                             Check the error bounds from iterative
629 *                             refinement.
630 *
631                               CALL CGBT05( TRANS, N, KL, KU, NRHS, ASAV,
632      $                                     LDA, BSAV, LDB, X, LDB, XACT,
633      $                                     LDB, RWORK, RWORK( NRHS+1 ),
634      $                                     RESULT( 4 ) )
635                            ELSE
636                               TRFCON = .TRUE.
637                            END IF
638 *
639 *                          Compare RCOND from CGBSVX with the computed
640 *                          value in RCONDC.
641 *
642                            RESULT( 6 ) = SGET06( RCOND, RCONDC )
643 *
644 *                          Print information about the tests that did
645 *                          not pass the threshold.
646 *
647                            IF( .NOT.TRFCON ) THEN
648                               DO 80 K = K1, NTESTS
649                                  IF( RESULT( K ).GE.THRESH ) THEN
650                                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
651      $                                 CALL ALADHD( NOUT, PATH )
652                                     IF( PREFAC ) THEN
653                                        WRITE( NOUT, FMT = 9995 )
654      $                                    'CGBSVX', FACT, TRANS, N, KL,
655      $                                    KU, EQUED, IMAT, K,
656      $                                    RESULT( K )
657                                     ELSE
658                                        WRITE( NOUT, FMT = 9996 )
659      $                                    'CGBSVX', FACT, TRANS, N, KL,
660      $                                    KU, IMAT, K, RESULT( K )
661                                     END IF
662                                     NFAIL = NFAIL + 1
663                                  END IF
664    80                         CONTINUE
665                               NRUN = NRUN + 7 - K1
666                            ELSE
667                               IF( RESULT( 1 ).GE.THRESH .AND. .NOT.
668      $                            PREFAC ) THEN
669                                  IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
670      $                              CALL ALADHD( NOUT, PATH )
671                                  IF( PREFAC ) THEN
672                                     WRITE( NOUT, FMT = 9995 )'CGBSVX',
673      $                                 FACT, TRANS, N, KL, KU, EQUED,
674      $                                 IMAT, 1, RESULT( 1 )
675                                  ELSE
676                                     WRITE( NOUT, FMT = 9996 )'CGBSVX',
677      $                                 FACT, TRANS, N, KL, KU, IMAT, 1,
678      $                                 RESULT( 1 )
679                                  END IF
680                                  NFAIL = NFAIL + 1
681                                  NRUN = NRUN + 1
682                               END IF
683                               IF( RESULT( 6 ).GE.THRESH ) THEN
684                                  IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
685      $                              CALL ALADHD( NOUT, PATH )
686                                  IF( PREFAC ) THEN
687                                     WRITE( NOUT, FMT = 9995 )'CGBSVX',
688      $                                 FACT, TRANS, N, KL, KU, EQUED,
689      $                                 IMAT, 6, RESULT( 6 )
690                                  ELSE
691                                     WRITE( NOUT, FMT = 9996 )'CGBSVX',
692      $                                 FACT, TRANS, N, KL, KU, IMAT, 6,
693      $                                 RESULT( 6 )
694                                  END IF
695                                  NFAIL = NFAIL + 1
696                                  NRUN = NRUN + 1
697                               END IF
698                               IF( RESULT( 7 ).GE.THRESH ) THEN
699                                  IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
700      $                              CALL ALADHD( NOUT, PATH )
701                                  IF( PREFAC ) THEN
702                                     WRITE( NOUT, FMT = 9995 )'CGBSVX',
703      $                                 FACT, TRANS, N, KL, KU, EQUED,
704      $                                 IMAT, 7, RESULT( 7 )
705                                  ELSE
706                                     WRITE( NOUT, FMT = 9996 )'CGBSVX',
707      $                                 FACT, TRANS, N, KL, KU, IMAT, 7,
708      $                                 RESULT( 7 )
709                                  END IF
710                                  NFAIL = NFAIL + 1
711                                  NRUN = NRUN + 1
712                               END IF
713                            END IF
714 
715 *                    --- Test CGBSVXX ---
716 
717 *                    Restore the matrices A and B.
718 
719 c                     write(*,*) 'begin cgbsvxx testing'
720 
721                      CALL CLACPY( 'Full', KL+KU+1, N, ASAV, LDA, A,
722      $                          LDA )
723                      CALL CLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB )
724 
725                      IF( .NOT.PREFAC )
726      $                  CALL CLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO,
727      $                    AFB, LDAFB )
728                      CALL CLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDB )
729                      IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN
730 *
731 *                       Equilibrate the matrix if FACT = 'F' and
732 *                       EQUED = 'R', 'C', or 'B'.
733 *
734                         CALL CLAQGB( N, N, KL, KU, A, LDA, S,
735      $                       S( N+1 ), ROWCND, COLCND, AMAX, EQUED )
736                      END IF
737 *
738 *                    Solve the system and compute the condition number
739 *                    and error bounds using CGBSVXX.
740 *
741                      SRNAMT = 'CGBSVXX'
742                      N_ERR_BNDS = 3
743                      CALL CGBSVXX( FACT, TRANS, N, KL, KU, NRHS, A, LDA,
744      $                    AFB, LDAFB, IWORK, EQUED, S, S( N+1 ), B, LDB,
745      $                    X, LDB, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS,
746      $                    ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK,
747      $                    RWORK, INFO )
748 *
749 *                    Check the error code from CGBSVXX.
750 *
751                      IF( INFO.EQ.N+1 ) GOTO 90
752                      IF( INFO.NE.IZERO ) THEN
753                         CALL ALAERH( PATH, 'CGBSVXX', INFO, IZERO,
754      $                               FACT // TRANS, N, N, -1, -1, NRHS,
755      $                               IMAT, NFAIL, NERRS, NOUT )
756                         GOTO 90
757                      END IF
758 *
759 *                    Compare rpvgrw_svxx from CGESVXX with the computed
760 *                    reciprocal pivot growth factor RPVGRW
761 *
762 
763                      IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN
764                         RPVGRW = CLA_GBRPVGRW(N, KL, KU, INFO, A, LDA,
765      $                       AFB, LDAFB)
766                      ELSE
767                         RPVGRW = CLA_GBRPVGRW(N, KL, KU, N, A, LDA,
768      $                       AFB, LDAFB)
769                      ENDIF
770 
771                      RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) /
772      $                             MAX( rpvgrw_svxx, RPVGRW ) /
773      $                             SLAMCH( 'E' )
774 *
775                      IF( .NOT.PREFAC ) THEN
776 *
777 *                       Reconstruct matrix from factors and compute
778 *                       residual.
779 *
780                         CALL CGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB,
781      $                       IWORK, RWORK( 2*NRHS+1 ), RESULT( 1 ) )
782                         K1 = 1
783                      ELSE
784                         K1 = 2
785                      END IF
786 *
787                      IF( INFO.EQ.0 ) THEN
788                         TRFCON = .FALSE.
789 *
790 *                       Compute residual of the computed solution.
791 *
792                         CALL CLACPY( 'Full', N, NRHS, BSAV, LDB, WORK,
793      $                               LDB )
794                         CALL CGBT02( TRANS, N, N, KL, KU, NRHS, ASAV,
795      $                       LDA, X, LDB, WORK, LDB, RWORK( 2*NRHS+1 ),
796      $                               RESULT( 2 ) )
797 *
798 *                       Check solution from generated exact solution.
799 *
800                         IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED,
801      $                      'N' ) ) ) THEN
802                            CALL CGET04( N, NRHS, X, LDB, XACT, LDB,
803      $                                  RCONDC, RESULT( 3 ) )
804                         ELSE
805                            IF( ITRAN.EQ.1 ) THEN
806                               ROLDC = ROLDO
807                            ELSE
808                               ROLDC = ROLDI
809                            END IF
810                            CALL CGET04( N, NRHS, X, LDB, XACT, LDB,
811      $                                  ROLDC, RESULT( 3 ) )
812                         END IF
813                      ELSE
814                         TRFCON = .TRUE.
815                      END IF
816 *
817 *                    Compare RCOND from CGBSVXX with the computed value
818 *                    in RCONDC.
819 *
820                      RESULT( 6 ) = SGET06( RCOND, RCONDC )
821 *
822 *                    Print information about the tests that did not pass
823 *                    the threshold.
824 *
825                      IF( .NOT.TRFCON ) THEN
826                         DO 45 K = K1, NTESTS
827                            IF( RESULT( K ).GE.THRESH ) THEN
828                               IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
829      $                           CALL ALADHD( NOUT, PATH )
830                               IF( PREFAC ) THEN
831                                  WRITE( NOUT, FMT = 9995 )'CGBSVXX',
832      $                                FACT, TRANS, N, KL, KU, EQUED,
833      $                                IMAT, K, RESULT( K )
834                               ELSE
835                                  WRITE( NOUT, FMT = 9996 )'CGBSVXX',
836      $                                FACT, TRANS, N, KL, KU, IMAT, K,
837      $                                RESULT( K )
838                               END IF
839                               NFAIL = NFAIL + 1
840                            END IF
841  45                     CONTINUE
842                         NRUN = NRUN + 7 - K1
843                      ELSE
844                         IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC )
845      $                       THEN
846                            IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
847      $                        CALL ALADHD( NOUT, PATH )
848                            IF( PREFAC ) THEN
849                               WRITE( NOUT, FMT = 9995 )'CGBSVXX', FACT,
850      $                             TRANS, N, KL, KU, EQUED, IMAT, 1,
851      $                             RESULT( 1 )
852                            ELSE
853                               WRITE( NOUT, FMT = 9996 )'CGBSVXX', FACT,
854      $                             TRANS, N, KL, KU, IMAT, 1,
855      $                             RESULT( 1 )
856                            END IF
857                            NFAIL = NFAIL + 1
858                            NRUN = NRUN + 1
859                         END IF
860                         IF( RESULT( 6 ).GE.THRESH ) THEN
861                            IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
862      $                        CALL ALADHD( NOUT, PATH )
863                            IF( PREFAC ) THEN
864                               WRITE( NOUT, FMT = 9995 )'CGBSVXX', FACT,
865      $                             TRANS, N, KL, KU, EQUED, IMAT, 6,
866      $                             RESULT( 6 )
867                            ELSE
868                               WRITE( NOUT, FMT = 9996 )'CGBSVXX', FACT,
869      $                             TRANS, N, KL, KU, IMAT, 6,
870      $                             RESULT( 6 )
871                            END IF
872                            NFAIL = NFAIL + 1
873                            NRUN = NRUN + 1
874                         END IF
875                         IF( RESULT( 7 ).GE.THRESH ) THEN
876                            IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
877      $                        CALL ALADHD( NOUT, PATH )
878                            IF( PREFAC ) THEN
879                               WRITE( NOUT, FMT = 9995 )'CGBSVXX', FACT,
880      $                             TRANS, N, KL, KU, EQUED, IMAT, 7,
881      $                             RESULT( 7 )
882                            ELSE
883                               WRITE( NOUT, FMT = 9996 )'CGBSVXX', FACT,
884      $                             TRANS, N, KL, KU, IMAT, 7,
885      $                             RESULT( 7 )
886                            END IF
887                            NFAIL = NFAIL + 1
888                            NRUN = NRUN + 1
889                         END IF
890 *
891                      END IF
892 *
893    90                   CONTINUE
894   100                CONTINUE
895   110             CONTINUE
896   120          CONTINUE
897   130       CONTINUE
898   140    CONTINUE
899   150 CONTINUE
900 *
901 *     Print a summary of the results.
902 *
903       CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
904 *
905 
906 *     Test Error Bounds from CGBSVXX
907 
908       CALL CEBCHVXX(THRESH, PATH)
909 
910  9999 FORMAT( ' *** In CDRVGB, LA=', I5, ' is too small for N=', I5,
911      $      ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ',
912      $      I5 )
913  9998 FORMAT( ' *** In CDRVGB, LAFB=', I5, ' is too small for N=', I5,
914      $      ', KU=', I5, ', KL=', I5, /
915      $      ' ==> Increase LAFB to at least ', I5 )
916  9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ',
917      $      I1, ', test(', I1, ')=', G12.5 )
918  9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
919      $      I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 )
920  9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',
921      $      I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1,
922      $      ')=', G12.5 )
923 *
924       RETURN
925 *
926 *     End of CDRVGB
927 *
928       END
Home