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

SCHKTR

Purpose: 
 SCHKTR tests STRTRI, -TRS, -RFS, and -CON, and SLATRS
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]NNB
          NNB is INTEGER
          The number of values of NB contained in the vector NBVAL.
[in]NBVAL
          NBVAL is INTEGER array, dimension (NNB)
          The values of the blocksize NB.
[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]A
          A 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 169 of file schktr.f.

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