LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ cchktb()

subroutine cchktb ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
real  THRESH,
logical  TSTERR,
integer  NMAX,
complex, dimension( * )  AB,
complex, dimension( * )  AINV,
complex, dimension( * )  B,
complex, dimension( * )  X,
complex, dimension( * )  XACT,
complex, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer  NOUT 
)

CCHKTB

Purpose:
 CCHKTB tests CTBTRS, -RFS, and -CON, and CLATBS.
Parameters
[in]DOTYPE
          DOTYPE is LOGICAL array, dimension (NTYPES)
          The matrix types to be used for testing.  Matrices of type j
          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
[in]NN
          NN is INTEGER
          The number of values of N contained in the vector NVAL.
[in]NVAL
          NVAL is INTEGER array, dimension (NN)
          The values of the matrix column dimension N.
[in]NNS
          NNS is INTEGER
          The number of values of NRHS contained in the vector NSVAL.
[in]NSVAL
          NSVAL is INTEGER array, dimension (NNS)
          The values of the number of right hand sides NRHS.
[in]THRESH
          THRESH is REAL
          The threshold value for the test ratios.  A result is
          included in the output file if RESULT >= THRESH.  To have
          every test ratio printed, use THRESH = 0.
[in]TSTERR
          TSTERR is LOGICAL
          Flag that indicates whether error exits are to be tested.
[in]NMAX
          NMAX is INTEGER
          The leading dimension of the work arrays.
          NMAX >= the maximum value of N in NVAL.
[out]AB
          AB is COMPLEX array, dimension (NMAX*NMAX)
[out]AINV
          AINV is COMPLEX array, dimension (NMAX*NMAX)
[out]B
          B is COMPLEX array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is COMPLEX array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is COMPLEX array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is COMPLEX array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is REAL array, dimension
                      (max(NMAX,2*NSMAX))
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 147 of file cchktb.f.

149 *
150 * -- LAPACK test routine --
151 * -- LAPACK is a software package provided by Univ. of Tennessee, --
152 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153 *
154 * .. Scalar Arguments ..
155  LOGICAL TSTERR
156  INTEGER NMAX, NN, NNS, NOUT
157  REAL THRESH
158 * ..
159 * .. Array Arguments ..
160  LOGICAL DOTYPE( * )
161  INTEGER NSVAL( * ), NVAL( * )
162  REAL RWORK( * )
163  COMPLEX AB( * ), AINV( * ), B( * ), WORK( * ), X( * ),
164  $ XACT( * )
165 * ..
166 *
167 * =====================================================================
168 *
169 * .. Parameters ..
170  INTEGER NTYPE1, NTYPES
171  parameter( ntype1 = 9, ntypes = 17 )
172  INTEGER NTESTS
173  parameter( ntests = 8 )
174  INTEGER NTRAN
175  parameter( ntran = 3 )
176  REAL ONE, ZERO
177  parameter( one = 1.0e+0, zero = 0.0e+0 )
178 * ..
179 * .. Local Scalars ..
180  CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
181  CHARACTER*3 PATH
182  INTEGER I, IDIAG, IK, IMAT, IN, INFO, IRHS, ITRAN,
183  $ IUPLO, J, K, KD, LDA, LDAB, N, NERRS, NFAIL,
184  $ NIMAT, NIMAT2, NK, NRHS, NRUN
185  REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
186  $ SCALE
187 * ..
188 * .. Local Arrays ..
189  CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
190  INTEGER ISEED( 4 ), ISEEDY( 4 )
191  REAL RESULT( NTESTS )
192 * ..
193 * .. External Functions ..
194  LOGICAL LSAME
195  REAL CLANTB, CLANTR
196  EXTERNAL lsame, clantb, clantr
197 * ..
198 * .. External Subroutines ..
199  EXTERNAL alaerh, alahd, alasum, ccopy, cerrtr, cget04,
202  $ ctbtrs
203 * ..
204 * .. Scalars in Common ..
205  LOGICAL LERR, OK
206  CHARACTER*32 SRNAMT
207  INTEGER INFOT, IOUNIT
208 * ..
209 * .. Common blocks ..
210  COMMON / infoc / infot, iounit, ok, lerr
211  COMMON / srnamc / srnamt
212 * ..
213 * .. Intrinsic Functions ..
214  INTRINSIC cmplx, max, min
215 * ..
216 * .. Data statements ..
217  DATA iseedy / 1988, 1989, 1990, 1991 /
218  DATA uplos / 'U', 'L' / , transs / 'N', 'T', 'C' /
219 * ..
220 * .. Executable Statements ..
221 *
222 * Initialize constants and the random number seed.
223 *
224  path( 1: 1 ) = 'Complex precision'
225  path( 2: 3 ) = 'TB'
226  nrun = 0
227  nfail = 0
228  nerrs = 0
229  DO 10 i = 1, 4
230  iseed( i ) = iseedy( i )
231  10 CONTINUE
232 *
233 * Test the error exits
234 *
235  IF( tsterr )
236  $ CALL cerrtr( path, nout )
237  infot = 0
238 *
239  DO 140 in = 1, nn
240 *
241 * Do for each value of N in NVAL
242 *
243  n = nval( in )
244  lda = max( 1, n )
245  xtype = 'N'
246  nimat = ntype1
247  nimat2 = ntypes
248  IF( n.LE.0 ) THEN
249  nimat = 1
250  nimat2 = ntype1 + 1
251  END IF
252 *
253  nk = min( n+1, 4 )
254  DO 130 ik = 1, nk
255 *
256 * Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes
257 * it easier to skip redundant values for small values of N.
258 *
259  IF( ik.EQ.1 ) THEN
260  kd = 0
261  ELSE IF( ik.EQ.2 ) THEN
262  kd = max( n, 0 )
263  ELSE IF( ik.EQ.3 ) THEN
264  kd = ( 3*n-1 ) / 4
265  ELSE IF( ik.EQ.4 ) THEN
266  kd = ( n+1 ) / 4
267  END IF
268  ldab = kd + 1
269 *
270  DO 90 imat = 1, nimat
271 *
272 * Do the tests only if DOTYPE( IMAT ) is true.
273 *
274  IF( .NOT.dotype( imat ) )
275  $ GO TO 90
276 *
277  DO 80 iuplo = 1, 2
278 *
279 * Do first for UPLO = 'U', then for UPLO = 'L'
280 *
281  uplo = uplos( iuplo )
282 *
283 * Call CLATTB to generate a triangular test matrix.
284 *
285  srnamt = 'CLATTB'
286  CALL clattb( imat, uplo, 'No transpose', diag, iseed,
287  $ n, kd, ab, ldab, x, work, rwork, info )
288 *
289 * Set IDIAG = 1 for non-unit matrices, 2 for unit.
290 *
291  IF( lsame( diag, 'N' ) ) THEN
292  idiag = 1
293  ELSE
294  idiag = 2
295  END IF
296 *
297 * Form the inverse of A so we can get a good estimate
298 * of RCONDC = 1/(norm(A) * norm(inv(A))).
299 *
300  CALL claset( 'Full', n, n, cmplx( zero ),
301  $ cmplx( one ), ainv, lda )
302  IF( lsame( uplo, 'U' ) ) THEN
303  DO 20 j = 1, n
304  CALL ctbsv( uplo, 'No transpose', diag, j, kd,
305  $ ab, ldab, ainv( ( j-1 )*lda+1 ), 1 )
306  20 CONTINUE
307  ELSE
308  DO 30 j = 1, n
309  CALL ctbsv( uplo, 'No transpose', diag, n-j+1,
310  $ kd, ab( ( j-1 )*ldab+1 ), ldab,
311  $ ainv( ( j-1 )*lda+j ), 1 )
312  30 CONTINUE
313  END IF
314 *
315 * Compute the 1-norm condition number of A.
316 *
317  anorm = clantb( '1', uplo, diag, n, kd, ab, ldab,
318  $ rwork )
319  ainvnm = clantr( '1', uplo, diag, n, n, ainv, lda,
320  $ rwork )
321  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
322  rcondo = one
323  ELSE
324  rcondo = ( one / anorm ) / ainvnm
325  END IF
326 *
327 * Compute the infinity-norm condition number of A.
328 *
329  anorm = clantb( 'I', uplo, diag, n, kd, ab, ldab,
330  $ rwork )
331  ainvnm = clantr( 'I', uplo, diag, n, n, ainv, lda,
332  $ rwork )
333  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
334  rcondi = one
335  ELSE
336  rcondi = ( one / anorm ) / ainvnm
337  END IF
338 *
339  DO 60 irhs = 1, nns
340  nrhs = nsval( irhs )
341  xtype = 'N'
342 *
343  DO 50 itran = 1, ntran
344 *
345 * Do for op(A) = A, A**T, or A**H.
346 *
347  trans = transs( itran )
348  IF( itran.EQ.1 ) THEN
349  norm = 'O'
350  rcondc = rcondo
351  ELSE
352  norm = 'I'
353  rcondc = rcondi
354  END IF
355 *
356 *+ TEST 1
357 * Solve and compute residual for op(A)*x = b.
358 *
359  srnamt = 'CLARHS'
360  CALL clarhs( path, xtype, uplo, trans, n, n, kd,
361  $ idiag, nrhs, ab, ldab, xact, lda,
362  $ b, lda, iseed, info )
363  xtype = 'C'
364  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
365 *
366  srnamt = 'CTBTRS'
367  CALL ctbtrs( uplo, trans, diag, n, kd, nrhs, ab,
368  $ ldab, x, lda, info )
369 *
370 * Check error code from CTBTRS.
371 *
372  IF( info.NE.0 )
373  $ CALL alaerh( path, 'CTBTRS', info, 0,
374  $ uplo // trans // diag, n, n, kd,
375  $ kd, nrhs, imat, nfail, nerrs,
376  $ nout )
377 *
378  CALL ctbt02( uplo, trans, diag, n, kd, nrhs, ab,
379  $ ldab, x, lda, b, lda, work, rwork,
380  $ result( 1 ) )
381 *
382 *+ TEST 2
383 * Check solution from generated exact solution.
384 *
385  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
386  $ result( 2 ) )
387 *
388 *+ TESTS 3, 4, and 5
389 * Use iterative refinement to improve the solution
390 * and compute error bounds.
391 *
392  srnamt = 'CTBRFS'
393  CALL ctbrfs( uplo, trans, diag, n, kd, nrhs, ab,
394  $ ldab, b, lda, x, lda, rwork,
395  $ rwork( nrhs+1 ), work,
396  $ rwork( 2*nrhs+1 ), info )
397 *
398 * Check error code from CTBRFS.
399 *
400  IF( info.NE.0 )
401  $ CALL alaerh( path, 'CTBRFS', info, 0,
402  $ uplo // trans // diag, n, n, kd,
403  $ kd, nrhs, imat, nfail, nerrs,
404  $ nout )
405 *
406  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
407  $ result( 3 ) )
408  CALL ctbt05( uplo, trans, diag, n, kd, nrhs, ab,
409  $ ldab, b, lda, x, lda, xact, lda,
410  $ rwork, rwork( nrhs+1 ),
411  $ result( 4 ) )
412 *
413 * Print information about the tests that did not
414 * pass the threshold.
415 *
416  DO 40 k = 1, 5
417  IF( result( k ).GE.thresh ) THEN
418  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
419  $ CALL alahd( nout, path )
420  WRITE( nout, fmt = 9999 )uplo, trans,
421  $ diag, n, kd, nrhs, imat, k, result( k )
422  nfail = nfail + 1
423  END IF
424  40 CONTINUE
425  nrun = nrun + 5
426  50 CONTINUE
427  60 CONTINUE
428 *
429 *+ TEST 6
430 * Get an estimate of RCOND = 1/CNDNUM.
431 *
432  DO 70 itran = 1, 2
433  IF( itran.EQ.1 ) THEN
434  norm = 'O'
435  rcondc = rcondo
436  ELSE
437  norm = 'I'
438  rcondc = rcondi
439  END IF
440  srnamt = 'CTBCON'
441  CALL ctbcon( norm, uplo, diag, n, kd, ab, ldab,
442  $ rcond, work, rwork, info )
443 *
444 * Check error code from CTBCON.
445 *
446  IF( info.NE.0 )
447  $ CALL alaerh( path, 'CTBCON', info, 0,
448  $ norm // uplo // diag, n, n, kd, kd,
449  $ -1, imat, nfail, nerrs, nout )
450 *
451  CALL ctbt06( rcond, rcondc, uplo, diag, n, kd, ab,
452  $ ldab, rwork, result( 6 ) )
453 *
454 * Print the test ratio if it is .GE. THRESH.
455 *
456  IF( result( 6 ).GE.thresh ) THEN
457  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
458  $ CALL alahd( nout, path )
459  WRITE( nout, fmt = 9998 ) 'CTBCON', norm, uplo,
460  $ diag, n, kd, imat, 6, result( 6 )
461  nfail = nfail + 1
462  END IF
463  nrun = nrun + 1
464  70 CONTINUE
465  80 CONTINUE
466  90 CONTINUE
467 *
468 * Use pathological test matrices to test CLATBS.
469 *
470  DO 120 imat = ntype1 + 1, nimat2
471 *
472 * Do the tests only if DOTYPE( IMAT ) is true.
473 *
474  IF( .NOT.dotype( imat ) )
475  $ GO TO 120
476 *
477  DO 110 iuplo = 1, 2
478 *
479 * Do first for UPLO = 'U', then for UPLO = 'L'
480 *
481  uplo = uplos( iuplo )
482  DO 100 itran = 1, ntran
483 *
484 * Do for op(A) = A, A**T, and A**H.
485 *
486  trans = transs( itran )
487 *
488 * Call CLATTB to generate a triangular test matrix.
489 *
490  srnamt = 'CLATTB'
491  CALL clattb( imat, uplo, trans, diag, iseed, n, kd,
492  $ ab, ldab, x, work, rwork, info )
493 *
494 *+ TEST 7
495 * Solve the system op(A)*x = b
496 *
497  srnamt = 'CLATBS'
498  CALL ccopy( n, x, 1, b, 1 )
499  CALL clatbs( uplo, trans, diag, 'N', n, kd, ab,
500  $ ldab, b, scale, rwork, info )
501 *
502 * Check error code from CLATBS.
503 *
504  IF( info.NE.0 )
505  $ CALL alaerh( path, 'CLATBS', info, 0,
506  $ uplo // trans // diag // 'N', n, n,
507  $ kd, kd, -1, imat, nfail, nerrs,
508  $ nout )
509 *
510  CALL ctbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
511  $ scale, rwork, one, b, lda, x, lda,
512  $ work, result( 7 ) )
513 *
514 *+ TEST 8
515 * Solve op(A)*x = b again with NORMIN = 'Y'.
516 *
517  CALL ccopy( n, x, 1, b, 1 )
518  CALL clatbs( uplo, trans, diag, 'Y', n, kd, ab,
519  $ ldab, b, scale, rwork, info )
520 *
521 * Check error code from CLATBS.
522 *
523  IF( info.NE.0 )
524  $ CALL alaerh( path, 'CLATBS', info, 0,
525  $ uplo // trans // diag // 'Y', n, n,
526  $ kd, kd, -1, imat, nfail, nerrs,
527  $ nout )
528 *
529  CALL ctbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
530  $ scale, rwork, one, b, lda, x, lda,
531  $ work, result( 8 ) )
532 *
533 * Print information about the tests that did not pass
534 * the threshold.
535 *
536  IF( result( 7 ).GE.thresh ) THEN
537  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
538  $ CALL alahd( nout, path )
539  WRITE( nout, fmt = 9997 )'CLATBS', uplo, trans,
540  $ diag, 'N', n, kd, imat, 7, result( 7 )
541  nfail = nfail + 1
542  END IF
543  IF( result( 8 ).GE.thresh ) THEN
544  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
545  $ CALL alahd( nout, path )
546  WRITE( nout, fmt = 9997 )'CLATBS', uplo, trans,
547  $ diag, 'Y', n, kd, imat, 8, result( 8 )
548  nfail = nfail + 1
549  END IF
550  nrun = nrun + 2
551  100 CONTINUE
552  110 CONTINUE
553  120 CONTINUE
554  130 CONTINUE
555  140 CONTINUE
556 *
557 * Print a summary of the results.
558 *
559  CALL alasum( path, nout, nfail, nrun, nerrs )
560 *
561  9999 FORMAT( ' UPLO=''', a1, ''', TRANS=''', a1, ''',
562  $ DIAG=''', a1, ''', N=', i5, ', KD=', i5, ', NRHS=', i5,
563  $ ', type ', i2, ', test(', i2, ')=', g12.5 )
564  9998 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''',',
565  $ i5, ',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
566  $ g12.5 )
567  9997 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
568  $ a1, ''',', i5, ',', i5, ', ... ), type ', i2, ', test(',
569  $ i1, ')=', g12.5 )
570  RETURN
571 *
572 * End of CCHKTB
573 *
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:73
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:147
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:81
subroutine ctbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
CTBSV
Definition: ctbsv.f:189
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:208
subroutine ctbt03(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
CTBT03
Definition: ctbt03.f:177
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:102
subroutine ctbt06(RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, RWORK, RAT)
CTBT06
Definition: ctbt06.f:126
subroutine ctbt05(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CTBT05
Definition: ctbt05.f:189
subroutine clattb(IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, LDAB, B, WORK, RWORK, INFO)
CLATTB
Definition: clattb.f:141
subroutine ctbt02(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, LDX, B, LDB, WORK, RWORK, RESID)
CTBT02
Definition: ctbt02.f:161
subroutine cerrtr(PATH, NUNIT)
CERRTR
Definition: cerrtr.f:54
real function clantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
CLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition: clantb.f:141
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: claset.f:106
real function clantr(NORM, UPLO, DIAG, M, N, A, LDA, WORK)
CLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition: clantr.f:142
subroutine clatbs(UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO)
CLATBS solves a triangular banded system of equations.
Definition: clatbs.f:243
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:103
subroutine ctbrfs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CTBRFS
Definition: ctbrfs.f:188
subroutine ctbcon(NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO)
CTBCON
Definition: ctbcon.f:143
subroutine ctbtrs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
CTBTRS
Definition: ctbtrs.f:146
Here is the call graph for this function:
Here is the caller graph for this function: