LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ 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(3)
!>
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 = 10 )
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, BIGNUM, DUMMY, RCOND, RCONDC,
202 $ RCONDI, RCONDO, RES, SCALE, SLAMCH
203* ..
204* .. Local Arrays ..
205 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
206 INTEGER ISEED( 4 ), ISEEDY( 4 )
207 REAL RESULT( NTESTS ), SCALE3( 2 )
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, slatrs3, slattr, sscal,
217 $ strcon, strrfs, strt01, strt02, strt03, strt05,
218 $ strt06, strtri, strtrs, xlaenv, slamch
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 bignum = slamch('Overflow') / slamch('Precision')
243 nrun = 0
244 nfail = 0
245 nerrs = 0
246 DO 10 i = 1, 4
247 iseed( i ) = iseedy( i )
248 10 CONTINUE
249*
250* Test the error exits
251*
252 IF( tsterr )
253 $ CALL serrtr( path, nout )
254 infot = 0
255 CALL xlaenv( 2, 2 )
256*
257 DO 120 in = 1, nn
258*
259* Do for each value of N in NVAL
260*
261 n = nval( in )
262 lda = max( 1, n )
263 xtype = 'N'
264*
265 DO 80 imat = 1, ntype1
266*
267* Do the tests only if DOTYPE( IMAT ) is true.
268*
269 IF( .NOT.dotype( imat ) )
270 $ GO TO 80
271*
272 DO 70 iuplo = 1, 2
273*
274* Do first for UPLO = 'U', then for UPLO = 'L'
275*
276 uplo = uplos( iuplo )
277*
278* Call SLATTR to generate a triangular test matrix.
279*
280 srnamt = 'SLATTR'
281 CALL slattr( imat, uplo, 'No transpose', diag, iseed, n,
282 $ a, lda, x, work, info )
283*
284* Set IDIAG = 1 for non-unit matrices, 2 for unit.
285*
286 IF( lsame( diag, 'N' ) ) THEN
287 idiag = 1
288 ELSE
289 idiag = 2
290 END IF
291*
292 DO 60 inb = 1, nnb
293*
294* Do for each blocksize in NBVAL
295*
296 nb = nbval( inb )
297 CALL xlaenv( 1, nb )
298*
299*+ TEST 1
300* Form the inverse of A.
301*
302 CALL slacpy( uplo, n, n, a, lda, ainv, lda )
303 srnamt = 'STRTRI'
304 CALL strtri( uplo, diag, n, ainv, lda, info )
305*
306* Check error code from STRTRI.
307*
308 IF( info.NE.0 )
309 $ CALL alaerh( path, 'STRTRI', info, 0, uplo // diag,
310 $ n, n, -1, -1, nb, imat, nfail, nerrs,
311 $ nout )
312*
313* Compute the infinity-norm condition number of A.
314*
315 anorm = slantr( 'I', uplo, diag, n, n, a, lda, rwork )
316 ainvnm = slantr( 'I', uplo, diag, n, n, ainv, lda,
317 $ rwork )
318 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
319 rcondi = one
320 ELSE
321 rcondi = ( one / anorm ) / ainvnm
322 END IF
323*
324* Compute the residual for the triangular matrix times
325* its inverse. Also compute the 1-norm condition number
326* of A.
327*
328 CALL strt01( uplo, diag, n, a, lda, ainv, lda, rcondo,
329 $ rwork, result( 1 ) )
330*
331* Print the test ratio if it is .GE. THRESH.
332*
333 IF( result( 1 ).GE.thresh ) THEN
334 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
335 $ CALL alahd( nout, path )
336 WRITE( nout, fmt = 9999 )uplo, diag, n, nb, imat,
337 $ 1, result( 1 )
338 nfail = nfail + 1
339 END IF
340 nrun = nrun + 1
341*
342* Skip remaining tests if not the first block size.
343*
344 IF( inb.NE.1 )
345 $ GO TO 60
346*
347 DO 40 irhs = 1, nns
348 nrhs = nsval( irhs )
349 xtype = 'N'
350*
351 DO 30 itran = 1, ntran
352*
353* Do for op(A) = A, A**T, or A**H.
354*
355 trans = transs( itran )
356 IF( itran.EQ.1 ) THEN
357 norm = 'O'
358 rcondc = rcondo
359 ELSE
360 norm = 'I'
361 rcondc = rcondi
362 END IF
363*
364*+ TEST 2
365* Solve and compute residual for op(A)*x = b.
366*
367 srnamt = 'SLARHS'
368 CALL slarhs( path, xtype, uplo, trans, n, n, 0,
369 $ idiag, nrhs, a, lda, xact, lda, b,
370 $ lda, iseed, info )
371 xtype = 'C'
372 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
373*
374 srnamt = 'STRTRS'
375 CALL strtrs( uplo, trans, diag, n, nrhs, a, lda,
376 $ x, lda, info )
377*
378* Check error code from STRTRS.
379*
380 IF( info.NE.0 )
381 $ CALL alaerh( path, 'STRTRS', info, 0,
382 $ uplo // trans // diag, n, n, -1,
383 $ -1, nrhs, imat, nfail, nerrs,
384 $ nout )
385*
386* This line is needed on a Sun SPARCstation.
387*
388 IF( n.GT.0 )
389 $ dummy = a( 1 )
390*
391 CALL strt02( uplo, trans, diag, n, nrhs, a, lda,
392 $ x, lda, b, lda, work, result( 2 ) )
393*
394*+ TEST 3
395* Check solution from generated exact solution.
396*
397 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
398 $ result( 3 ) )
399*
400*+ TESTS 4, 5, and 6
401* Use iterative refinement to improve the solution
402* and compute error bounds.
403*
404 srnamt = 'STRRFS'
405 CALL strrfs( uplo, trans, diag, n, nrhs, a, lda,
406 $ b, lda, x, lda, rwork,
407 $ rwork( nrhs+1 ), work, iwork,
408 $ info )
409*
410* Check error code from STRRFS.
411*
412 IF( info.NE.0 )
413 $ CALL alaerh( path, 'STRRFS', info, 0,
414 $ uplo // trans // diag, n, n, -1,
415 $ -1, nrhs, imat, nfail, nerrs,
416 $ nout )
417*
418 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
419 $ result( 4 ) )
420 CALL strt05( uplo, trans, diag, n, nrhs, a, lda,
421 $ b, lda, x, lda, xact, lda, rwork,
422 $ rwork( nrhs+1 ), result( 5 ) )
423*
424* Print information about the tests that did not
425* pass the threshold.
426*
427 DO 20 k = 2, 6
428 IF( result( k ).GE.thresh ) THEN
429 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
430 $ CALL alahd( nout, path )
431 WRITE( nout, fmt = 9998 )uplo, trans,
432 $ diag, n, nrhs, imat, k, result( k )
433 nfail = nfail + 1
434 END IF
435 20 CONTINUE
436 nrun = nrun + 5
437 30 CONTINUE
438 40 CONTINUE
439*
440*+ TEST 7
441* Get an estimate of RCOND = 1/CNDNUM.
442*
443 DO 50 itran = 1, 2
444 IF( itran.EQ.1 ) THEN
445 norm = 'O'
446 rcondc = rcondo
447 ELSE
448 norm = 'I'
449 rcondc = rcondi
450 END IF
451 srnamt = 'STRCON'
452 CALL strcon( norm, uplo, diag, n, a, lda, rcond,
453 $ work, iwork, info )
454*
455* Check error code from STRCON.
456*
457 IF( info.NE.0 )
458 $ CALL alaerh( path, 'STRCON', info, 0,
459 $ norm // uplo // diag, n, n, -1, -1,
460 $ -1, imat, nfail, nerrs, nout )
461*
462 CALL strt06( rcond, rcondc, uplo, diag, n, a, lda,
463 $ rwork, result( 7 ) )
464*
465* Print the test ratio if it is .GE. THRESH.
466*
467 IF( result( 7 ).GE.thresh ) THEN
468 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
469 $ CALL alahd( nout, path )
470 WRITE( nout, fmt = 9997 )norm, uplo, n, imat,
471 $ 7, result( 7 )
472 nfail = nfail + 1
473 END IF
474 nrun = nrun + 1
475 50 CONTINUE
476 60 CONTINUE
477 70 CONTINUE
478 80 CONTINUE
479*
480* Use pathological test matrices to test SLATRS.
481*
482 DO 110 imat = ntype1 + 1, ntypes
483*
484* Do the tests only if DOTYPE( IMAT ) is true.
485*
486 IF( .NOT.dotype( imat ) )
487 $ GO TO 110
488*
489 DO 100 iuplo = 1, 2
490*
491* Do first for UPLO = 'U', then for UPLO = 'L'
492*
493 uplo = uplos( iuplo )
494 DO 90 itran = 1, ntran
495*
496* Do for op(A) = A, A**T, and A**H.
497*
498 trans = transs( itran )
499*
500* Call SLATTR to generate a triangular test matrix.
501*
502 srnamt = 'SLATTR'
503 CALL slattr( imat, uplo, trans, diag, iseed, n, a,
504 $ lda, x, work, info )
505*
506*+ TEST 8
507* Solve the system op(A)*x = b.
508*
509 srnamt = 'SLATRS'
510 CALL scopy( n, x, 1, b, 1 )
511 CALL slatrs( uplo, trans, diag, 'N', n, a, lda, b,
512 $ scale, rwork, info )
513*
514* Check error code from SLATRS.
515*
516 IF( info.NE.0 )
517 $ CALL alaerh( path, 'SLATRS', info, 0,
518 $ uplo // trans // diag // 'N', n, n,
519 $ -1, -1, -1, imat, nfail, nerrs, nout )
520*
521 CALL strt03( uplo, trans, diag, n, 1, a, lda, scale,
522 $ rwork, one, b, lda, x, lda, work,
523 $ result( 8 ) )
524*
525*+ TEST 9
526* Solve op(A)*X = b again with NORMIN = 'Y'.
527*
528 CALL scopy( n, x, 1, b( n+1 ), 1 )
529 CALL slatrs( uplo, trans, diag, 'Y', n, a, lda,
530 $ b( n+1 ), scale, rwork, info )
531*
532* Check error code from SLATRS.
533*
534 IF( info.NE.0 )
535 $ CALL alaerh( path, 'SLATRS', info, 0,
536 $ uplo // trans // diag // 'Y', n, n,
537 $ -1, -1, -1, imat, nfail, nerrs, nout )
538*
539 CALL strt03( uplo, trans, diag, n, 1, a, lda, scale,
540 $ rwork, one, b( n+1 ), lda, x, lda, work,
541 $ result( 9 ) )
542*
543*+ TEST 10
544* Solve op(A)*X = B
545*
546 srnamt = 'SLATRS3'
547 CALL scopy( n, x, 1, b, 1 )
548 CALL scopy( n, x, 1, b( n+1 ), 1 )
549 CALL sscal( n, bignum, b( n+1 ), 1 )
550 CALL slatrs3( uplo, trans, diag, 'N', n, 2, a, lda,
551 $ b, max(1, n), scale3, rwork, work, nmax,
552 $ info )
553*
554* Check error code from SLATRS3.
555*
556 IF( info.NE.0 )
557 $ CALL alaerh( path, 'SLATRS3', info, 0,
558 $ uplo // trans // diag // 'N', n, n,
559 $ -1, -1, -1, imat, nfail, nerrs, nout )
560*
561 CALL strt03( uplo, trans, diag, n, 1, a, lda,
562 $ scale3( 1 ), rwork, one, b( 1 ), lda,
563 $ x, lda, work, result( 10 ) )
564 CALL sscal( n, bignum, x, 1 )
565 CALL strt03( uplo, trans, diag, n, 1, a, lda,
566 $ scale3( 2 ), rwork, one, b( n+1 ), lda,
567 $ x, lda, work, res )
568 result( 10 ) = max( result( 10 ), res )
569*
570* Print information about the tests that did not pass
571* the threshold.
572*
573 IF( result( 8 ).GE.thresh ) THEN
574 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
575 $ CALL alahd( nout, path )
576 WRITE( nout, fmt = 9996 )'SLATRS', uplo, trans,
577 $ diag, 'N', n, imat, 8, result( 8 )
578 nfail = nfail + 1
579 END IF
580 IF( result( 9 ).GE.thresh ) THEN
581 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
582 $ CALL alahd( nout, path )
583 WRITE( nout, fmt = 9996 )'SLATRS', uplo, trans,
584 $ diag, 'Y', n, imat, 9, result( 9 )
585 nfail = nfail + 1
586 END IF
587 IF( result( 10 ).GE.thresh ) THEN
588 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
589 $ CALL alahd( nout, path )
590 WRITE( nout, fmt = 9996 )'SLATRS3', uplo, trans,
591 $ diag, 'N', n, imat, 10, result( 10 )
592 nfail = nfail + 1
593 END IF
594 nrun = nrun + 3
595 90 CONTINUE
596 100 CONTINUE
597 110 CONTINUE
598 120 CONTINUE
599*
600* Print a summary of the results.
601*
602 CALL alasum( path, nout, nfail, nrun, nerrs )
603*
604 9999 FORMAT( ' UPLO=''', a1, ''', DIAG=''', a1, ''', N=', i5, ', NB=',
605 $ i4, ', type ', i2, ', test(', i2, ')= ', g12.5 )
606 9998 FORMAT( ' UPLO=''', a1, ''', TRANS=''', a1, ''', DIAG=''', a1,
607 $ ''', N=', i5, ', NB=', i4, ', type ', i2, ', test(',
608 $ i2, ')= ', g12.5 )
609 9997 FORMAT( ' NORM=''', a1, ''', UPLO =''', a1, ''', N=', i5, ',',
610 $ 11x, ' type ', i2, ', test(', i2, ')=', g12.5 )
611 9996 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
612 $ a1, ''',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
613 $ g12.5 )
614 RETURN
615*
616* End of SCHKTR
617*
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
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
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
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:101
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
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:140
slatrs3
subroutine slatrs3(uplo, trans, diag, normin, n, nrhs, a, lda, x, ldx, scale, cnorm, work, lwork, info)
SLATRS3 solves a triangular system of equations with the scale factors set to prevent overflow.
Definition slatrs3.f:233
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:237
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79
strcon
subroutine strcon(norm, uplo, diag, n, a, lda, rcond, work, iwork, info)
STRCON
Definition strcon.f:135
strrfs
subroutine strrfs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, iwork, info)
STRRFS
Definition strrfs.f:181
strtri
subroutine strtri(uplo, diag, n, a, lda, info)
STRTRI
Definition strtri.f:107
strtrs
subroutine strtrs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
STRTRS
Definition strtrs.f:144
serrtr
subroutine serrtr(path, nunit)
SERRTR
Definition serrtr.f:55
sget04
subroutine sget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
SGET04
Definition sget04.f:102
slattr
subroutine slattr(imat, uplo, trans, diag, iseed, n, a, lda, b, work, info)
SLATTR
Definition slattr.f:133
strt01
subroutine strt01(uplo, diag, n, a, lda, ainv, ldainv, rcond, work, resid)
STRT01
Definition strt01.f:124
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
strt06
subroutine strt06(rcond, rcondc, uplo, diag, n, a, lda, work, rat)
STRT06
Definition strt06.f:121
Here is the call graph for this function:
Here is the caller graph for this function: