LAPACK  3.6.1 LAPACK: Linear Algebra PACKage
 subroutine zchktb ( logical, dimension( * ) DOTYPE, integer NN, integer, dimension( * ) NVAL, integer NNS, integer, dimension( * ) NSVAL, double precision THRESH, logical TSTERR, integer NMAX, complex*16, dimension( * ) AB, complex*16, dimension( * ) AINV, complex*16, dimension( * ) B, complex*16, dimension( * ) X, complex*16, dimension( * ) XACT, complex*16, dimension( * ) WORK, double precision, dimension( * ) RWORK, integer NOUT )

ZCHKTB

Purpose:
` ZCHKTB tests ZTBTRS, -RFS, and -CON, and ZLATBS.`
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 DOUBLE PRECISION 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*16 array, dimension (NMAX*NMAX)` [out] AINV ` AINV is COMPLEX*16 array, dimension (NMAX*NMAX)` [out] B ``` B is COMPLEX*16 array, dimension (NMAX*NSMAX) where NSMAX is the largest entry in NSVAL.``` [out] X ` X is COMPLEX*16 array, dimension (NMAX*NSMAX)` [out] XACT ` XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)` [out] WORK ``` WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))``` [out] RWORK ``` RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))``` [in] NOUT ``` NOUT is INTEGER The unit number for output.```
Date
November 2011

Definition at line 151 of file zchktb.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: