167 INTEGER nmax, nn, nns, nout
172 INTEGER iwork( * ), nsval( * ), nval( * )
173 REAL ainvp( * ), ap( * ), b( * ), rwork( * ),
174 $ work( * ), x( * ), xact( * )
180 INTEGER ntype1, ntypes
181 parameter ( ntype1 = 10, ntypes = 18 )
183 parameter ( ntests = 9 )
185 parameter ( ntran = 3 )
187 parameter ( one = 1.0e+0, zero = 0.0e+0 )
190 CHARACTER diag, norm, trans, uplo, xtype
192 INTEGER i, idiag, imat, in, info, irhs, itran, iuplo,
193 $ k, lap, lda, n, nerrs, nfail, nrhs, nrun
194 REAL ainvnm, anorm, rcond, rcondc, rcondi, rcondo,
198 CHARACTER transs( ntran ), uplos( 2 )
199 INTEGER iseed( 4 ), iseedy( 4 )
200 REAL result( ntests )
216 INTEGER infot, iounit
219 COMMON / infoc / infot, iounit, ok, lerr
220 COMMON / srnamc / srnamt
226 DATA iseedy / 1988, 1989, 1990, 1991 /
227 DATA uplos /
'U',
'L' / , transs /
'N',
'T',
'C' /
233 path( 1: 1 ) =
'Single precision'
239 iseed( i ) = iseedy( i )
245 $
CALL serrtr( path, nout )
254 lap = lda*( lda+1 ) / 2
257 DO 70 imat = 1, ntype1
261 IF( .NOT.dotype( imat ) )
268 uplo = uplos( iuplo )
273 CALL slattp( imat, uplo,
'No transpose', diag, iseed, n,
274 $ ap, x, work, info )
278 IF(
lsame( diag,
'N' ) )
THEN
288 $
CALL scopy( lap, ap, 1, ainvp, 1 )
290 CALL stptri( uplo, diag, n, ainvp, info )
295 $
CALL alaerh( path,
'STPTRI', info, 0, uplo // diag, n,
296 $ n, -1, -1, -1, imat, nfail, nerrs, nout )
300 anorm =
slantp(
'I', uplo, diag, n, ap, rwork )
301 ainvnm =
slantp(
'I', uplo, diag, n, ainvp, rwork )
302 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
305 rcondi = ( one / anorm ) / ainvnm
311 CALL stpt01( uplo, diag, n, ap, ainvp, rcondo, rwork,
316 IF( result( 1 ).GE.thresh )
THEN
317 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
318 $
CALL alahd( nout, path )
319 WRITE( nout, fmt = 9999 )uplo, diag, n, imat, 1,
329 DO 30 itran = 1, ntran
333 trans = transs( itran )
334 IF( itran.EQ.1 )
THEN
346 CALL slarhs( path, xtype, uplo, trans, n, n, 0,
347 $ idiag, nrhs, ap, lap, xact, lda, b,
350 CALL slacpy(
'Full', n, nrhs, b, lda, x, lda )
353 CALL stptrs( uplo, trans, diag, n, nrhs, ap, x,
359 $
CALL alaerh( path,
'STPTRS', info, 0,
360 $ uplo // trans // diag, n, n, -1,
361 $ -1, -1, imat, nfail, nerrs, nout )
363 CALL stpt02( uplo, trans, diag, n, nrhs, ap, x,
364 $ lda, b, lda, work, result( 2 ) )
369 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
377 CALL stprfs( uplo, trans, diag, n, nrhs, ap, b,
378 $ lda, x, lda, rwork, rwork( nrhs+1 ),
379 $ work, iwork, info )
384 $
CALL alaerh( path,
'STPRFS', info, 0,
385 $ uplo // trans // diag, n, n, -1,
386 $ -1, nrhs, imat, nfail, nerrs,
389 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
391 CALL stpt05( uplo, trans, diag, n, nrhs, ap, b,
392 $ lda, x, lda, xact, lda, rwork,
393 $ rwork( nrhs+1 ), result( 5 ) )
399 IF( result( k ).GE.thresh )
THEN
400 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
401 $
CALL alahd( nout, path )
402 WRITE( nout, fmt = 9998 )uplo, trans, diag,
403 $ n, nrhs, imat, k, result( k )
415 IF( itran.EQ.1 )
THEN
424 CALL stpcon( norm, uplo, diag, n, ap, rcond, work,
430 $
CALL alaerh( path,
'STPCON', info, 0,
431 $ norm // uplo // diag, n, n, -1, -1,
432 $ -1, imat, nfail, nerrs, nout )
434 CALL stpt06( rcond, rcondc, uplo, diag, n, ap, rwork,
439 IF( result( 7 ).GE.thresh )
THEN
440 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
441 $
CALL alahd( nout, path )
442 WRITE( nout, fmt = 9997 )
'STPCON', norm, uplo,
443 $ diag, n, imat, 7, result( 7 )
453 DO 100 imat = ntype1 + 1, ntypes
457 IF( .NOT.dotype( imat ) )
464 uplo = uplos( iuplo )
465 DO 80 itran = 1, ntran
469 trans = transs( itran )
474 CALL slattp( imat, uplo, trans, diag, iseed, n, ap, x,
481 CALL scopy( n, x, 1, b, 1 )
482 CALL slatps( uplo, trans, diag,
'N', n, ap, b, scale,
488 $
CALL alaerh( path,
'SLATPS', info, 0,
489 $ uplo // trans // diag //
'N', n, n,
490 $ -1, -1, -1, imat, nfail, nerrs, nout )
492 CALL stpt03( uplo, trans, diag, n, 1, ap, scale,
493 $ rwork, one, b, lda, x, lda, work,
499 CALL scopy( n, x, 1, b( n+1 ), 1 )
500 CALL slatps( uplo, trans, diag,
'Y', n, ap, b( n+1 ),
501 $ scale, rwork, info )
506 $
CALL alaerh( path,
'SLATPS', info, 0,
507 $ uplo // trans // diag //
'Y', n, n,
508 $ -1, -1, -1, imat, nfail, nerrs, nout )
510 CALL stpt03( uplo, trans, diag, n, 1, ap, scale,
511 $ rwork, one, b( n+1 ), lda, x, lda, work,
517 IF( result( 8 ).GE.thresh )
THEN
518 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
519 $
CALL alahd( nout, path )
520 WRITE( nout, fmt = 9996 )
'SLATPS', uplo, trans,
521 $ diag,
'N', n, imat, 8, result( 8 )
524 IF( result( 9 ).GE.thresh )
THEN
525 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
526 $
CALL alahd( nout, path )
527 WRITE( nout, fmt = 9996 )
'SLATPS', uplo, trans,
528 $ diag,
'Y', n, imat, 9, result( 9 )
539 CALL alasum( path, nout, nfail, nrun, nerrs )
541 9999
FORMAT(
' UPLO=''', a1,
''', DIAG=''', a1,
''', N=', i5,
542 $
', type ', i2,
', test(', i2,
')= ', g12.5 )
543 9998
FORMAT(
' UPLO=''', a1,
''', TRANS=''', a1,
''', DIAG=''', a1,
544 $
''', N=', i5,
''', NRHS=', i5,
', type ', i2,
', test(',
546 9997
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''',',
547 $ i5,
', ... ), type ', i2,
', test(', i2,
')=', g12.5 )
548 9996
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''', ''',
549 $ a1,
''',', i5,
', ... ), type ', i2,
', test(', i2,
')=',
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine slattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, INFO)
SLATTP
subroutine stpt03(UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
STPT03
subroutine stpt01(UPLO, DIAG, N, AP, AINVP, RCOND, WORK, RESID)
STPT01
subroutine stpcon(NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO)
STPCON
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
subroutine stptrs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO)
STPTRS
subroutine stprfs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
STPRFS
subroutine slatps(UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO)
SLATPS solves a triangular system of equations with the matrix held in packed storage.
subroutine stpt05(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
STPT05
subroutine stptri(UPLO, DIAG, N, AP, INFO)
STPTRI
subroutine serrtr(PATH, NUNIT)
SERRTR
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
logical function lsame(CA, CB)
LSAME
subroutine stpt02(UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, WORK, RESID)
STPT02
subroutine stpt06(RCOND, RCONDC, UPLO, DIAG, N, AP, WORK, RAT)
STPT06
real function slantp(NORM, UPLO, DIAG, N, AP, WORK)
SLANTP 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 matrix supplied in packed form.
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM