LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ schktb()

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.

Definition at line 152 of file schktb.f.

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