170 INTEGER NMAX, NN, NNS, NOUT
175 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
176 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
177 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
184 parameter( zero = 0.0e+0 )
186 parameter( ntypes = 10 )
188 parameter( ntests = 8 )
191 LOGICAL TRFCON, ZEROT
192 CHARACTER DIST, PACKIT,
TYPE, UPLO, XTYPE
194 INTEGER I, I1, I2, IMAT, IN, INFO, IOFF, IRHS, IUPLO,
195 $ IZERO, J, K, KL, KU, LDA, MODE, N, NERRS,
196 $ NFAIL, NIMAT, NPP, NRHS, NRUN, NT
197 REAL ANORM, CNDNUM, RCOND, RCONDC
201 INTEGER ISEED( 4 ), ISEEDY( 4 )
202 REAL RESULT( NTESTS )
224 COMMON / infoc / infot, nunit, ok, lerr
225 COMMON / srnamc / srnamt
228 DATA iseedy / 1988, 1989, 1990, 1991 /
229 DATA uplos /
'U',
'L' /
235 path( 1: 1 ) =
'Single precision'
241 iseed( i ) = iseedy( i )
247 $
CALL serrsy( path, nout )
261 DO 160 imat = 1, nimat
265 IF( .NOT.dotype( imat ) )
270 zerot = imat.GE.3 .AND. imat.LE.6
271 IF( zerot .AND. n.LT.imat-2 )
277 uplo = uplos( iuplo )
278 IF(
lsame( uplo,
'U' ) )
THEN
287 CALL slatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
291 CALL slatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
292 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
298 CALL alaerh( path,
'SLATMS', info, 0, uplo, n, n, -1,
299 $ -1, -1, imat, nfail, nerrs, nout )
309 ELSE IF( imat.EQ.4 )
THEN
319 IF( iuplo.EQ.1 )
THEN
320 ioff = ( izero-1 )*izero / 2
321 DO 20 i = 1, izero - 1
331 DO 40 i = 1, izero - 1
342 IF( iuplo.EQ.1 )
THEN
373 CALL scopy( npp, a, 1, afac, 1 )
375 CALL ssptrf( uplo, n, afac, iwork, info )
383 IF( iwork( k ).LT.0 )
THEN
384 IF( iwork( k ).NE.-k )
THEN
388 ELSE IF( iwork( k ).NE.k )
THEN
397 $
CALL alaerh( path,
'SSPTRF', info, k, uplo, n, n, -1,
398 $ -1, -1, imat, nfail, nerrs, nout )
408 CALL sspt01( uplo, n, a, afac, iwork, ainv, lda, rwork,
415 IF( .NOT.trfcon )
THEN
416 CALL scopy( npp, afac, 1, ainv, 1 )
418 CALL ssptri( uplo, n, ainv, iwork, work, info )
423 $
CALL alaerh( path,
'SSPTRI', info, 0, uplo, n, n,
424 $ -1, -1, -1, imat, nfail, nerrs, nout )
426 CALL sppt03( uplo, n, a, ainv, work, lda, rwork,
427 $ rcondc, result( 2 ) )
435 IF( result( k ).GE.thresh )
THEN
436 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
437 $
CALL alahd( nout, path )
438 WRITE( nout, fmt = 9999 )uplo, n, imat, k,
459 CALL slarhs( path, xtype, uplo,
' ', n, n, kl, ku,
460 $ nrhs, a, lda, xact, lda, b, lda, iseed,
462 CALL slacpy(
'Full', n, nrhs, b, lda, x, lda )
465 CALL ssptrs( uplo, n, nrhs, afac, iwork, x, lda,
471 $
CALL alaerh( path,
'SSPTRS', info, 0, uplo, n, n,
472 $ -1, -1, nrhs, imat, nfail, nerrs,
475 CALL slacpy(
'Full', n, nrhs, b, lda, work, lda )
476 CALL sppt02( uplo, n, nrhs, a, x, lda, work, lda,
477 $ rwork, result( 3 ) )
482 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
489 CALL ssprfs( uplo, n, nrhs, a, afac, iwork, b, lda, x,
490 $ lda, rwork, rwork( nrhs+1 ), work,
491 $ iwork( n+1 ), info )
496 $
CALL alaerh( path,
'SSPRFS', info, 0, uplo, n, n,
497 $ -1, -1, nrhs, imat, nfail, nerrs,
500 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
502 CALL sppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
503 $ lda, rwork, rwork( nrhs+1 ),
510 IF( result( k ).GE.thresh )
THEN
511 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
512 $
CALL alahd( nout, path )
513 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
525 anorm =
slansp(
'1', uplo, n, a, rwork )
527 CALL sspcon( uplo, n, afac, iwork, anorm, rcond, work,
528 $ iwork( n+1 ), info )
533 $
CALL alaerh( path,
'SSPCON', info, 0, uplo, n, n, -1,
534 $ -1, -1, imat, nfail, nerrs, nout )
536 result( 8 ) =
sget06( rcond, rcondc )
540 IF( result( 8 ).GE.thresh )
THEN
541 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
542 $
CALL alahd( nout, path )
543 WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
554 CALL alasum( path, nout, nfail, nrun, nerrs )
556 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', type ', i2,
', test ',
557 $ i2,
', ratio =', g12.5 )
558 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
559 $ i2,
', test(', i2,
') =', g12.5 )
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
logical function lsame(CA, CB)
LSAME
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
real function slansp(NORM, UPLO, N, AP, WORK)
SLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
subroutine ssptrf(UPLO, N, AP, IPIV, INFO)
SSPTRF
subroutine sspcon(UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
SSPCON
subroutine ssptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
SSPTRS
subroutine ssptri(UPLO, N, AP, IPIV, WORK, INFO)
SSPTRI
subroutine ssprfs(UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SSPRFS
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine serrsy(PATH, NUNIT)
SERRSY
subroutine sppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPPT05
subroutine sspt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
SSPT01
subroutine sppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
SPPT02
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
subroutine sppt03(UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, RESID)
SPPT03
real function sget06(RCOND, RCONDC)
SGET06