LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ zchktb()

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.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 147 of file zchktb.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  DOUBLE PRECISION THRESH
158 * ..
159 * .. Array Arguments ..
160  LOGICAL DOTYPE( * )
161  INTEGER NSVAL( * ), NVAL( * )
162  DOUBLE PRECISION RWORK( * )
163  COMPLEX*16 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  DOUBLE PRECISION ONE, ZERO
177  parameter( one = 1.0d+0, zero = 0.0d+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  DOUBLE PRECISION 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  DOUBLE PRECISION RESULT( NTESTS )
192 * ..
193 * .. External Functions ..
194  LOGICAL LSAME
195  DOUBLE PRECISION ZLANTB, ZLANTR
196  EXTERNAL lsame, zlantb, zlantr
197 * ..
198 * .. External Subroutines ..
199  EXTERNAL alaerh, alahd, alasum, zcopy, zerrtr, zget04,
202  $ ztbtrs
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 dcmplx, 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 ) = 'Zomplex 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 zerrtr( 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 ZLATTB to generate a triangular test matrix.
284 *
285  srnamt = 'ZLATTB'
286  CALL zlattb( 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 zlaset( 'Full', n, n, dcmplx( zero ),
301  $ dcmplx( one ), ainv, lda )
302  IF( lsame( uplo, 'U' ) ) THEN
303  DO 20 j = 1, n
304  CALL ztbsv( 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 ztbsv( 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 = zlantb( '1', uplo, diag, n, kd, ab, ldab,
318  $ rwork )
319  ainvnm = zlantr( '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 = zlantb( 'I', uplo, diag, n, kd, ab, ldab,
330  $ rwork )
331  ainvnm = zlantr( '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 = 'ZLARHS'
360  CALL zlarhs( path, xtype, uplo, trans, n, n, kd,
361  $ idiag, nrhs, ab, ldab, xact, lda,
362  $ b, lda, iseed, info )
363  xtype = 'C'
364  CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
365 *
366  srnamt = 'ZTBTRS'
367  CALL ztbtrs( uplo, trans, diag, n, kd, nrhs, ab,
368  $ ldab, x, lda, info )
369 *
370 * Check error code from ZTBTRS.
371 *
372  IF( info.NE.0 )
373  $ CALL alaerh( path, 'ZTBTRS', info, 0,
374  $ uplo // trans // diag, n, n, kd,
375  $ kd, nrhs, imat, nfail, nerrs,
376  $ nout )
377 *
378  CALL ztbt02( 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 zget04( 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 = 'ZTBRFS'
393  CALL ztbrfs( 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 ZTBRFS.
399 *
400  IF( info.NE.0 )
401  $ CALL alaerh( path, 'ZTBRFS', info, 0,
402  $ uplo // trans // diag, n, n, kd,
403  $ kd, nrhs, imat, nfail, nerrs,
404  $ nout )
405 *
406  CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
407  $ result( 3 ) )
408  CALL ztbt05( 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 = 'ZTBCON'
441  CALL ztbcon( norm, uplo, diag, n, kd, ab, ldab,
442  $ rcond, work, rwork, info )
443 *
444 * Check error code from ZTBCON.
445 *
446  IF( info.NE.0 )
447  $ CALL alaerh( path, 'ZTBCON', info, 0,
448  $ norm // uplo // diag, n, n, kd, kd,
449  $ -1, imat, nfail, nerrs, nout )
450 *
451  CALL ztbt06( 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 ) 'ZTBCON', 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 ZLATBS.
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 ZLATTB to generate a triangular test matrix.
489 *
490  srnamt = 'ZLATTB'
491  CALL zlattb( 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 = 'ZLATBS'
498  CALL zcopy( n, x, 1, b, 1 )
499  CALL zlatbs( uplo, trans, diag, 'N', n, kd, ab,
500  $ ldab, b, scale, rwork, info )
501 *
502 * Check error code from ZLATBS.
503 *
504  IF( info.NE.0 )
505  $ CALL alaerh( path, 'ZLATBS', info, 0,
506  $ uplo // trans // diag // 'N', n, n,
507  $ kd, kd, -1, imat, nfail, nerrs,
508  $ nout )
509 *
510  CALL ztbt03( 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 zcopy( n, x, 1, b, 1 )
518  CALL zlatbs( uplo, trans, diag, 'Y', n, kd, ab,
519  $ ldab, b, scale, rwork, info )
520 *
521 * Check error code from ZLATBS.
522 *
523  IF( info.NE.0 )
524  $ CALL alaerh( path, 'ZLATBS', info, 0,
525  $ uplo // trans // diag // 'Y', n, n,
526  $ kd, kd, -1, imat, nfail, nerrs,
527  $ nout )
528 *
529  CALL ztbt03( 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 )'ZLATBS', 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 )'ZLATBS', 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 ZCHKTB
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 zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:81
subroutine ztbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
ZTBSV
Definition: ztbsv.f:189
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
Definition: zlarhs.f:208
subroutine zlattb(IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, LDAB, B, WORK, RWORK, INFO)
ZLATTB
Definition: zlattb.f:141
subroutine ztbt06(RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, RWORK, RAT)
ZTBT06
Definition: ztbt06.f:126
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
Definition: zget04.f:102
subroutine ztbt02(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, LDX, B, LDB, WORK, RWORK, RESID)
ZTBT02
Definition: ztbt02.f:161
subroutine ztbt03(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
ZTBT03
Definition: ztbt03.f:177
subroutine ztbt05(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZTBT05
Definition: ztbt05.f:189
subroutine zerrtr(PATH, NUNIT)
ZERRTR
Definition: zerrtr.f:54
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,...
Definition: zlantr.f:142
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:103
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:106
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,...
Definition: zlantb.f:141
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:243
subroutine ztbrfs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZTBRFS
Definition: ztbrfs.f:188
subroutine ztbtrs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
ZTBTRS
Definition: ztbtrs.f:146
subroutine ztbcon(NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO)
ZTBCON
Definition: ztbcon.f:143
Here is the call graph for this function:
Here is the caller graph for this function: