LAPACK 3.12.0
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:103
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:141
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:229
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
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:137
strrfs
subroutine strrfs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, iwork, info)
STRRFS
Definition strrfs.f:182
strtri
subroutine strtri(uplo, diag, n, a, lda, info)
STRTRI
Definition strtri.f:109
strtrs
subroutine strtrs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
STRTRS
Definition strtrs.f:140
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: