155 SUBROUTINE sdrvsy( 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, equed, fact, 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 $ nb, nbmin, nerrs, nfail, nimat, nrun, nt,
194 REAL ainvnm, anorm, cndnum, rcond, rcondc,
198 CHARACTER facts( nfact ), uplos( 2 )
199 INTEGER iseed( 4 ), iseedy( 4 )
200 REAL result( ntests ), berr( nrhs ),
201 $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
219 COMMON / infoc / infot, nunit, ok, lerr
220 COMMON / srnamc / srnamt
226 DATA iseedy / 1988, 1989, 1990, 1991 /
227 DATA uplos /
'U',
'L' / , facts /
'F',
'N' /
233 path( 1: 1 ) =
'Single precision'
239 iseed( i ) = iseedy( i )
241 lwork = max( 2*nmax, nmax*nrhs )
246 $ CALL
serrvx( path, nout )
266 DO 170 imat = 1, nimat
270 IF( .NOT.dotype( imat ) )
275 zerot = imat.GE.3 .AND. imat.LE.6
276 IF( zerot .AND. n.LT.imat-2 )
282 uplo = uplos( iuplo )
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, uplo, 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 )*lda
321 DO 20 i = 1, izero - 1
331 DO 40 i = 1, izero - 1
342 IF( iuplo.EQ.1 )
THEN
370 DO 150 ifact = 1, nfact
374 fact = facts( ifact )
384 ELSE IF( ifact.EQ.1 )
THEN
388 anorm =
slansy(
'1', uplo, n, a, lda, rwork )
392 CALL
slacpy( uplo, n, n, a, lda, afac, lda )
393 CALL
ssytrf( uplo, n, afac, lda, iwork, work,
398 CALL
slacpy( uplo, n, n, afac, lda, ainv, lda )
399 lwork = (n+nb+1)*(nb+3)
400 CALL
ssytri2( uplo, n, ainv, lda, iwork, work,
402 ainvnm =
slansy(
'1', uplo, n, ainv, lda, rwork )
406 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
409 rcondc = ( one / anorm ) / ainvnm
416 CALL
slarhs( path, xtype, uplo,
' ', n, n, kl, ku,
417 $ nrhs, a, lda, xact, lda,
b, lda, iseed,
423 IF( ifact.EQ.2 )
THEN
424 CALL
slacpy( uplo, n, n, a, lda, afac, lda )
425 CALL
slacpy(
'Full', n, nrhs,
b, lda, x, lda )
430 CALL
ssysv( uplo, n, nrhs, afac, lda, iwork, x,
431 $ lda, work, lwork, info )
439 IF( iwork( k ).LT.0 )
THEN
440 IF( iwork( k ).NE.-k )
THEN
444 ELSE IF( iwork( k ).NE.k )
THEN
453 CALL
alaerh( path,
'SSYSV ', info, k, uplo, n,
454 $ n, -1, -1, nrhs, imat, nfail,
457 ELSE IF( info.NE.0 )
THEN
464 CALL
ssyt01( uplo, n, a, lda, afac, lda, iwork,
465 $ ainv, lda, rwork, result( 1 ) )
469 CALL
slacpy(
'Full', n, nrhs,
b, lda, work, lda )
470 CALL
spot02( uplo, n, nrhs, a, lda, x, lda, work,
471 $ lda, rwork, result( 2 ) )
475 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
483 IF( result( k ).GE.thresh )
THEN
484 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
485 $ CALL
aladhd( nout, path )
486 WRITE( nout, fmt = 9999 )
'SSYSV ', uplo, n,
487 $ imat, k, result( k )
498 $ CALL
slaset( uplo, n, n, zero, zero, afac, lda )
499 CALL
slaset(
'Full', n, nrhs, zero, zero, x, lda )
505 CALL
ssysvx( fact, uplo, n, nrhs, a, lda, afac, lda,
506 $ iwork,
b, lda, x, lda, rcond, rwork,
507 $ rwork( nrhs+1 ), work, lwork,
508 $ iwork( n+1 ), info )
516 IF( iwork( k ).LT.0 )
THEN
517 IF( iwork( k ).NE.-k )
THEN
521 ELSE IF( iwork( k ).NE.k )
THEN
530 CALL
alaerh( path,
'SSYSVX', info, k, fact // uplo,
531 $ n, n, -1, -1, nrhs, imat, nfail,
537 IF( ifact.GE.2 )
THEN
542 CALL
ssyt01( uplo, n, a, lda, afac, lda, iwork,
543 $ ainv, lda, rwork( 2*nrhs+1 ),
552 CALL
slacpy(
'Full', n, nrhs,
b, lda, work, lda )
553 CALL
spot02( uplo, n, nrhs, a, lda, x, lda, work,
554 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
558 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
563 CALL
spot05( uplo, n, nrhs, a, lda,
b, lda, x, lda,
564 $ xact, lda, rwork, rwork( nrhs+1 ),
573 result( 6 ) =
sget06( rcond, rcondc )
579 IF( result( k ).GE.thresh )
THEN
580 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
581 $ CALL
aladhd( nout, path )
582 WRITE( nout, fmt = 9998 )
'SSYSVX', fact, uplo,
583 $ n, imat, k, result( k )
594 $ CALL
slaset( uplo, n, n, zero, zero, afac, lda )
595 CALL
slaset(
'Full', n, nrhs, zero, zero, x, lda )
603 CALL
ssysvxx( fact, uplo, n, nrhs, a, lda, afac,
604 $ lda, iwork, equed, work( n+1 ),
b, lda, x,
605 $ lda, rcond, rpvgrw_svxx, berr, n_err_bnds,
606 $ errbnds_n, errbnds_c, 0, zero, work,
607 $ iwork( n+1 ), info )
615 IF( iwork( k ).LT.0 )
THEN
616 IF( iwork( k ).NE.-k )
THEN
620 ELSE IF( iwork( k ).NE.k )
THEN
628 IF( info.NE.k .AND. info.LE.n )
THEN
629 CALL
alaerh( path,
'SSYSVXX', info, k,
630 $ fact // uplo, n, n, -1, -1, nrhs, imat, nfail,
636 IF( ifact.GE.2 )
THEN
641 CALL
ssyt01( uplo, n, a, lda, afac, lda, iwork,
642 $ ainv, lda, rwork(2*nrhs+1),
651 CALL
slacpy(
'Full', n, nrhs,
b, lda, work, lda )
652 CALL
spot02( uplo, n, nrhs, a, lda, x, lda, work,
653 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
657 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
662 CALL
spot05( uplo, n, nrhs, a, lda,
b, lda, x, lda,
663 $ xact, lda, rwork, rwork( nrhs+1 ),
672 result( 6 ) =
sget06( rcond, rcondc )
678 IF( result( k ).GE.thresh )
THEN
679 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
680 $ CALL
aladhd( nout, path )
681 WRITE( nout, fmt = 9998 )
'SSYSVXX',
682 $ fact, uplo, n, imat, k,
697 CALL
alasvm( path, nout, nfail, nrun, nerrs )
704 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i2,
705 $
', test ', i2,
', ratio =', g12.5 )
706 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N =', i5,
707 $
', 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...
subroutine ssysv(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO)
SSYSV computes the solution to system of linear equations A * X = B for SY matrices ...
subroutine ssyt01(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
SSYT01
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine spot05(UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPOT05
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine spot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPOT02
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
real function sget06(RCOND, RCONDC)
SGET06
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine ssysvx(FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO)
SSYSVX computes the solution to system of linear equations A * X = B for SY matrices ...
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 sebchvxx(THRESH, PATH)
SEBCHVXX
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine ssysvxx(FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO)
SSYSVXX
subroutine ssytrf(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
SSYTRF
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine aladhd(IOUNIT, PATH)
ALADHD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine sdrvsy(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SDRVSY
real function slansy(NORM, UPLO, N, A, LDA, WORK)
SLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix.
subroutine ssytri2(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
SSYTRI2
subroutine serrvx(PATH, NUNIT)
SERRVX
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4