155 SUBROUTINE sdrvsp( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
156 $ a, afac, ainv,
b,
x, xact, work, rwork, iwork,
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( 1
x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i2,
593 $
', test ', i2,
', ratio =', g12.5 )
594 9998
FORMAT( 1
x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N =', i5,
595 $
', type ', i2,
', test ', i2,
', ratio =', g12.5 )
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...
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 alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
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 ssptri(UPLO, N, AP, IPIV, WORK, INFO)
SSPTRI
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine sppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
SPPT02
REAL function sget06(RCOND, RCONDC)
SGET06
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine sdrvsp(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SDRVSP
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine ssptrf(UPLO, N, AP, IPIV, INFO)
SSPTRF
subroutine sspt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
SSPT01
subroutine aladhd(IOUNIT, PATH)
ALADHD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
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 sppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPPT05
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4