LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine schktb ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
real  THRESH,
logical  TSTERR,
integer  NMAX,
real, dimension( * )  AB,
real, dimension( * )  AINV,
real, dimension( * )  B,
real, dimension( * )  X,
real, dimension( * )  XACT,
real, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

SCHKTB

Purpose: 
 SCHKTB tests STBTRS, -RFS, and -CON, and SLATBS.
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 REAL array, dimension (NMAX*NMAX)
[out]AINV
          AINV is REAL array, dimension (NMAX*NMAX)
[out]B
          B is REAL array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is REAL array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is REAL array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is REAL array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is REAL array, dimension
                      (max(NMAX,2*NSMAX))
[out]IWORK
          IWORK is INTEGER array, dimension (NMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2011

Definition at line 157 of file schktb.f.

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