166 SUBROUTINE sdrvpp( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
167 $ a, afac, asav, b, bsav, x, xact, s, work,
168 $ rwork, iwork, nout )
177 INTEGER NMAX, NN, NOUT, NRHS
182 INTEGER IWORK( * ), NVAL( * )
183 REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
184 $ bsav( * ), rwork( * ), s( * ), work( * ),
192 parameter( one = 1.0e+0, zero = 0.0e+0 )
194 parameter( ntypes = 9 )
196 parameter( ntests = 6 )
199 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
200 CHARACTER DIST, EQUED, FACT, PACKIT,
TYPE, UPLO, XTYPE
202 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
203 $ izero, k, k1, kl, ku, lda, mode, n, nerrs,
204 $ nfact, nfail, nimat, npp, nrun, nt
205 REAL AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
209 CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 )
210 INTEGER ISEED( 4 ), ISEEDY( 4 )
211 REAL RESULT( ntests )
216 EXTERNAL lsame, sget06, slansp
230 COMMON / infoc / infot, nunit, ok, lerr
231 COMMON / srnamc / srnamt
237 DATA iseedy / 1988, 1989, 1990, 1991 /
238 DATA uplos /
'U',
'L' / , facts /
'F',
'N',
'E' / ,
239 $ packs /
'C',
'R' / , equeds /
'N',
'Y' /
245 path( 1: 1 ) =
'Single precision'
251 iseed( i ) = iseedy( i )
257 $ CALL
serrvx( path, nout )
271 DO 130 imat = 1, nimat
275 IF( .NOT.dotype( imat ) )
280 zerot = imat.GE.3 .AND. imat.LE.5
281 IF( zerot .AND. n.LT.imat-2 )
287 uplo = uplos( iuplo )
288 packit = packs( iuplo )
293 CALL
slatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
295 rcondc = one / cndnum
298 CALL
slatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
299 $ cndnum, anorm, kl, ku, packit, a, lda, work,
305 CALL
alaerh( path,
'SLATMS', info, 0, uplo, n, n, -1,
306 $ -1, -1, imat, nfail, nerrs, nout )
316 ELSE IF( imat.EQ.4 )
THEN
324 IF( iuplo.EQ.1 )
THEN
325 ioff = ( izero-1 )*izero / 2
326 DO 20 i = 1, izero - 1
336 DO 40 i = 1, izero - 1
351 CALL
scopy( npp, a, 1, asav, 1 )
354 equed = equeds( iequed )
355 IF( iequed.EQ.1 )
THEN
361 DO 100 ifact = 1, nfact
362 fact = facts( ifact )
363 prefac = lsame( fact,
'F' )
364 nofact = lsame( fact,
'N' )
365 equil = lsame( fact,
'E' )
372 ELSE IF( .NOT.lsame( fact,
'N' ) )
THEN
379 CALL
scopy( npp, asav, 1, afac, 1 )
380 IF( equil .OR. iequed.GT.1 )
THEN
385 CALL
sppequ( uplo, n, afac, s, scond, amax,
387 IF( info.EQ.0 .AND. n.GT.0 )
THEN
393 CALL
slaqsp( uplo, n, afac, s, scond,
406 anorm = slansp(
'1', uplo, n, afac, rwork )
410 CALL
spptrf( uplo, n, afac, info )
414 CALL
scopy( npp, afac, 1, a, 1 )
415 CALL
spptri( uplo, n, a, info )
419 ainvnm = slansp(
'1', uplo, n, a, rwork )
420 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
423 rcondc = ( one / anorm ) / ainvnm
429 CALL
scopy( npp, asav, 1, a, 1 )
434 CALL
slarhs( path, xtype, uplo,
' ', n, n, kl, ku,
435 $ nrhs, a, lda, xact, lda, b, lda,
438 CALL
slacpy(
'Full', n, nrhs, b, lda, bsav, lda )
447 CALL
scopy( npp, a, 1, afac, 1 )
448 CALL
slacpy(
'Full', n, nrhs, b, lda, x, lda )
451 CALL
sppsv( uplo, n, nrhs, afac, x, lda, info )
455 IF( info.NE.izero )
THEN
456 CALL
alaerh( path,
'SPPSV ', info, izero,
457 $ uplo, n, n, -1, -1, nrhs, imat,
458 $ nfail, nerrs, nout )
460 ELSE IF( info.NE.0 )
THEN
467 CALL
sppt01( uplo, n, a, afac, rwork,
472 CALL
slacpy(
'Full', n, nrhs, b, lda, work,
474 CALL
sppt02( uplo, n, nrhs, a, x, lda, work,
475 $ lda, rwork, result( 2 ) )
479 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
487 IF( result( k ).GE.thresh )
THEN
488 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
489 $ CALL
aladhd( nout, path )
490 WRITE( nout, fmt = 9999 )
'SPPSV ', uplo,
491 $ n, imat, k, result( k )
501 IF( .NOT.prefac .AND. npp.GT.0 )
502 $ CALL
slaset(
'Full', npp, 1, zero, zero, afac,
504 CALL
slaset(
'Full', n, nrhs, zero, zero, x, lda )
505 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
510 CALL
slaqsp( uplo, n, a, s, scond, amax, equed )
517 CALL
sppsvx( fact, uplo, n, nrhs, a, afac, equed,
518 $ s, b, lda, x, lda, rcond, rwork,
519 $ rwork( nrhs+1 ), work, iwork, info )
523 IF( info.NE.izero )
THEN
524 CALL
alaerh( path,
'SPPSVX', info, izero,
525 $ fact // uplo, n, n, -1, -1, nrhs,
526 $ imat, nfail, nerrs, nout )
531 IF( .NOT.prefac )
THEN
536 CALL
sppt01( uplo, n, a, afac,
537 $ rwork( 2*nrhs+1 ), result( 1 ) )
545 CALL
slacpy(
'Full', n, nrhs, bsav, lda, work,
547 CALL
sppt02( uplo, n, nrhs, asav, x, lda, work,
548 $ lda, rwork( 2*nrhs+1 ),
553 IF( nofact .OR. ( prefac .AND. lsame( equed,
555 CALL
sget04( n, nrhs, x, lda, xact, lda,
556 $ rcondc, result( 3 ) )
558 CALL
sget04( n, nrhs, x, lda, xact, lda,
559 $ roldc, result( 3 ) )
565 CALL
sppt05( uplo, n, nrhs, asav, b, lda, x,
566 $ lda, xact, lda, rwork,
567 $ rwork( nrhs+1 ), result( 4 ) )
575 result( 6 ) = sget06( rcond, rcondc )
581 IF( result( k ).GE.thresh )
THEN
582 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
583 $ CALL
aladhd( nout, path )
585 WRITE( nout, fmt = 9997 )
'SPPSVX', fact,
586 $ uplo, n, equed, imat, k, result( k )
588 WRITE( nout, fmt = 9998 )
'SPPSVX', fact,
589 $ uplo, n, imat, k, result( k )
604 CALL
alasvm( path, nout, nfail, nrun, nerrs )
606 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i1,
607 $
', test(', i1,
')=', g12.5 )
608 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
609 $
', type ', i1,
', test(', i1,
')=', g12.5 )
610 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
611 $
', EQUED=''', a1,
''', type ', i1,
', test(', i1,
')=',
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 sppsvx(FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
SPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine sdrvpp(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
SDRVPP
subroutine sppsv(UPLO, N, NRHS, AP, B, LDB, INFO)
SPPSV 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 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
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
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 sppequ(UPLO, N, AP, S, SCOND, AMAX, INFO)
SPPEQU
subroutine sppt01(UPLO, N, A, AFAC, RWORK, RESID)
SPPT01
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine slaqsp(UPLO, N, AP, S, SCOND, AMAX, EQUED)
SLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppeq...
subroutine sppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPPT05
subroutine spptrf(UPLO, N, AP, INFO)
SPPTRF
subroutine spptri(UPLO, N, AP, INFO)
SPPTRI
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4