166 INTEGER nmax, nn, nout, nrhs
171 INTEGER iwork( * ), nval( * )
172 REAL a( * ), afac( * ), ainv( * ), b( * ),
173 $ rwork( * ), work( * ), x( * ), xact( * )
180 parameter ( one = 1.0e+0, zero = 0.0e+0 )
181 INTEGER ntypes, ntests
182 parameter ( ntypes = 10, ntests = 6 )
184 parameter ( nfact = 2 )
188 CHARACTER dist, fact, packit,
TYPE, uplo, xtype
190 INTEGER i, i1, i2, ifact, imat, in, info, ioff, iuplo,
191 $ izero, j, k, k1, kl, ku, lda, lwork, mode, n,
192 $ nerrs, nfail, nimat, npp, nrun, nt
193 REAL ainvnm, anorm, cndnum, rcond, rcondc
196 CHARACTER facts( nfact )
197 INTEGER iseed( 4 ), iseedy( 4 )
198 REAL result( ntests )
215 COMMON / infoc / infot, nunit, ok, lerr
216 COMMON / srnamc / srnamt
222 DATA iseedy / 1988, 1989, 1990, 1991 /
223 DATA facts /
'F',
'N' /
229 path( 1: 1 ) =
'Single precision'
235 iseed( i ) = iseedy( i )
237 lwork = max( 2*nmax, nmax*nrhs )
242 $
CALL serrvx( path, nout )
256 DO 170 imat = 1, nimat
260 IF( .NOT.dotype( imat ) )
265 zerot = imat.GE.3 .AND. imat.LE.6
266 IF( zerot .AND. n.LT.imat-2 )
272 IF( iuplo.EQ.1 )
THEN
283 CALL slatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
287 CALL slatms( n, n, dist, iseed,
TYPE, rwork, mode,
288 $ cndnum, anorm, kl, ku, packit, a, lda, work,
294 CALL alaerh( path,
'SLATMS', info, 0, uplo, n, n, -1,
295 $ -1, -1, imat, nfail, nerrs, nout )
305 ELSE IF( imat.EQ.4 )
THEN
315 IF( iuplo.EQ.1 )
THEN
316 ioff = ( izero-1 )*izero / 2
317 DO 20 i = 1, izero - 1
327 DO 40 i = 1, izero - 1
338 IF( iuplo.EQ.1 )
THEN
366 DO 150 ifact = 1, nfact
370 fact = facts( ifact )
380 ELSE IF( ifact.EQ.1 )
THEN
384 anorm =
slansp(
'1', uplo, n, a, rwork )
388 CALL scopy( npp, a, 1, afac, 1 )
389 CALL ssptrf( uplo, n, afac, iwork, info )
393 CALL scopy( npp, afac, 1, ainv, 1 )
394 CALL ssptri( uplo, n, ainv, iwork, work, info )
395 ainvnm =
slansp(
'1', uplo, n, ainv, rwork )
399 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
402 rcondc = ( one / anorm ) / ainvnm
409 CALL slarhs( path, xtype, uplo,
' ', n, n, kl, ku,
410 $ nrhs, a, lda, xact, lda, b, lda, iseed,
416 IF( ifact.EQ.2 )
THEN
417 CALL scopy( npp, a, 1, afac, 1 )
418 CALL slacpy(
'Full', n, nrhs, b, lda, x, lda )
423 CALL sspsv( uplo, n, nrhs, afac, iwork, x, lda,
432 IF( iwork( k ).LT.0 )
THEN
433 IF( iwork( k ).NE.-k )
THEN
437 ELSE IF( iwork( k ).NE.k )
THEN
446 CALL alaerh( path,
'SSPSV ', info, k, uplo, n,
447 $ n, -1, -1, nrhs, imat, nfail,
450 ELSE IF( info.NE.0 )
THEN
457 CALL sspt01( uplo, n, a, afac, iwork, ainv, lda,
458 $ rwork, result( 1 ) )
462 CALL slacpy(
'Full', n, nrhs, b, lda, work, lda )
463 CALL sppt02( uplo, n, nrhs, a, x, lda, work, lda,
464 $ rwork, result( 2 ) )
468 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
476 IF( result( k ).GE.thresh )
THEN
477 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
478 $
CALL aladhd( nout, path )
479 WRITE( nout, fmt = 9999 )
'SSPSV ', uplo, n,
480 $ imat, k, result( k )
490 IF( ifact.EQ.2 .AND. npp.GT.0 )
491 $
CALL slaset(
'Full', npp, 1, zero, zero, afac,
493 CALL slaset(
'Full', n, nrhs, zero, zero, x, lda )
499 CALL sspsvx( fact, uplo, n, nrhs, a, afac, iwork, b,
500 $ lda, x, lda, rcond, rwork,
501 $ rwork( nrhs+1 ), work, iwork( n+1 ),
510 IF( iwork( k ).LT.0 )
THEN
511 IF( iwork( k ).NE.-k )
THEN
515 ELSE IF( iwork( k ).NE.k )
THEN
524 CALL alaerh( path,
'SSPSVX', info, k, fact // uplo,
525 $ n, n, -1, -1, nrhs, imat, nfail,
531 IF( ifact.GE.2 )
THEN
536 CALL sspt01( uplo, n, a, afac, iwork, ainv, lda,
537 $ rwork( 2*nrhs+1 ), result( 1 ) )
545 CALL slacpy(
'Full', n, nrhs, b, lda, work, lda )
546 CALL sppt02( uplo, n, nrhs, a, x, lda, work, lda,
547 $ rwork( 2*nrhs+1 ), result( 2 ) )
551 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
556 CALL sppt05( uplo, n, nrhs, a, b, lda, x, lda,
557 $ xact, lda, rwork, rwork( nrhs+1 ),
566 result( 6 ) =
sget06( rcond, rcondc )
572 IF( result( k ).GE.thresh )
THEN
573 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
574 $
CALL aladhd( nout, path )
575 WRITE( nout, fmt = 9998 )
'SSPSVX', fact, uplo,
576 $ n, imat, k, result( k )
590 CALL alasvm( path, nout, nfail, nrun, nerrs )
592 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i2,
593 $
', test ', i2,
', ratio =', g12.5 )
594 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N =', i5,
595 $
', type ', i2,
', test ', i2,
', ratio =', g12.5 )
subroutine sspsv(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
SSPSV computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
real function slansp(NORM, UPLO, N, AP, WORK)
SLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.
subroutine sppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPPT05
real function sget06(RCOND, RCONDC)
SGET06
subroutine sspsvx(FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
SSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
subroutine ssptrf(UPLO, N, AP, IPIV, INFO)
SSPTRF
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine sppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
SPPT02
subroutine sspt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
SSPT01
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine ssptri(UPLO, N, AP, IPIV, WORK, INFO)
SSPTRI
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY