LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ schktr()

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.

Definition at line 164 of file schktr.f.

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