LAPACK  3.8.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.```
Date
December 2016

Definition at line 157 of file schktb.f.

157 *
158 * -- LAPACK test routine (version 3.7.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 * December 2016
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,
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 *
subroutine stbt06(RCOND, RCONDC, UPLO, DIAG, N, KD, AB, LDAB, WORK, RAT)
STBT06
Definition: stbt06.f:127
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:149
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
subroutine slattb(IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, LDAB, B, WORK, INFO)
SLATTB
Definition: slattb.f:137
subroutine serrtr(PATH, NUNIT)
SERRTR
Definition: serrtr.f:57
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:104
subroutine stbt02(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, X, LDX, B, LDB, WORK, RESID)
STBT02
Definition: stbt02.f:156
subroutine stbt03(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
STBT03
Definition: stbt03.f:177
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
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
subroutine stbrfs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
STBRFS
Definition: stbrfs.f:190
subroutine stbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
STBSV
Definition: stbsv.f:191
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
subroutine stbt05(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
STBT05
Definition: stbt05.f:191
subroutine stbtrs(UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
STBTRS
Definition: stbtrs.f:148
subroutine stbcon(NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO)
STBCON
Definition: stbcon.f:145
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
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
Definition: slarhs.f:206
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:84
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
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: