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 )
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 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 sppequ(UPLO, N, AP, S, SCOND, AMAX, INFO)
SPPEQU
subroutine spptrf(UPLO, N, AP, INFO)
SPPTRF
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 slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
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 sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
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 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
logical function lsame(CA, CB)
LSAME
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine spptri(UPLO, N, AP, INFO)
SPPTRI
subroutine sppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
SPPT02
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 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 sppt01(UPLO, N, A, AFAC, RWORK, RESID)
SPPT01