151 SUBROUTINE sdrvsy( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
152 $ a, afac, ainv,
b, x, xact, work, rwork, iwork,
162 INTEGER nmax, nn, nout, nrhs
167 INTEGER iwork( * ), nval( * )
168 REAL a( * ), afac( * ), ainv( * ),
b( * ),
169 $ rwork( * ), work( * ), x( * ), xact( * )
176 parameter( one = 1.0e+0, zero = 0.0e+0 )
177 INTEGER ntypes, ntests
178 parameter( ntypes = 10, ntests = 6 )
180 parameter( nfact = 2 )
184 CHARACTER dist, fact, type, uplo, xtype
186 INTEGER i, i1, i2, ifact, imat, in, info, ioff, iuplo,
187 $ izero,
j, k, k1, kl, ku, lda, lwork, mode, n,
188 $ nb, nbmin, nerrs, nfail, nimat, nrun, nt
189 REAL ainvnm, anorm, cndnum, rcond, rcondc
192 CHARACTER facts( nfact ), uplos( 2 )
193 INTEGER iseed( 4 ), iseedy( 4 )
194 REAL result( ntests )
211 COMMON / infoc / infot, nunit, ok, lerr
212 COMMON / srnamc / srnamt
218 DATA iseedy / 1988, 1989, 1990, 1991 /
219 DATA uplos /
'U',
'L' / , facts /
'F',
'N' /
225 path( 1: 1 ) =
'Single precision'
231 iseed( i ) = iseedy( i )
233 lwork = max( 2*nmax, nmax*nrhs )
238 $ CALL
serrvx( path, nout )
258 DO 170 imat = 1, nimat
262 IF( .NOT.dotype( imat ) )
267 zerot = imat.GE.3 .AND. imat.LE.6
268 IF( zerot .AND. n.LT.imat-2 )
274 uplo = uplos( iuplo )
279 CALL
slatb4( path, imat, n, n, type, kl, ku, anorm, mode,
283 CALL
slatms( n, n, dist, iseed, type, rwork, mode,
284 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
290 CALL
alaerh( path,
'SLATMS', info, 0, uplo, n, n, -1,
291 $ -1, -1, imat, nfail, nerrs, nout )
301 ELSE IF( imat.EQ.4 )
THEN
311 IF( iuplo.EQ.1 )
THEN
312 ioff = ( izero-1 )*lda
313 DO 20 i = 1, izero - 1
323 DO 40 i = 1, izero - 1
334 IF( iuplo.EQ.1 )
THEN
362 DO 150 ifact = 1, nfact
366 fact = facts( ifact )
376 ELSE IF( ifact.EQ.1 )
THEN
380 anorm =
slansy(
'1', uplo, n, a, lda, rwork )
384 CALL
slacpy( uplo, n, n, a, lda, afac, lda )
385 CALL
ssytrf( uplo, n, afac, lda, iwork, work,
390 CALL
slacpy( uplo, n, n, afac, lda, ainv, lda )
391 lwork = (n+nb+1)*(nb+3)
392 CALL
ssytri2( uplo, n, ainv, lda, iwork, work,
394 ainvnm =
slansy(
'1', uplo, n, ainv, lda, rwork )
398 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
401 rcondc = ( one / anorm ) / ainvnm
408 CALL
slarhs( path, xtype, uplo,
' ', n, n, kl, ku,
409 $ nrhs, a, lda, xact, lda,
b, lda, iseed,
415 IF( ifact.EQ.2 )
THEN
416 CALL
slacpy( uplo, n, n, a, lda, afac, lda )
417 CALL
slacpy(
'Full', n, nrhs,
b, lda, x, lda )
422 CALL
ssysv( uplo, n, nrhs, afac, lda, iwork, x,
423 $ lda, work, lwork, info )
431 IF( iwork( k ).LT.0 )
THEN
432 IF( iwork( k ).NE.-k )
THEN
436 ELSE IF( iwork( k ).NE.k )
THEN
445 CALL
alaerh( path,
'SSYSV ', info, k, uplo, n,
446 $ n, -1, -1, nrhs, imat, nfail,
449 ELSE IF( info.NE.0 )
THEN
456 CALL
ssyt01( uplo, n, a, lda, afac, lda, iwork,
457 $ ainv, lda, rwork, result( 1 ) )
461 CALL
slacpy(
'Full', n, nrhs,
b, lda, work, lda )
462 CALL
spot02( uplo, n, nrhs, a, lda, x, lda, work,
463 $ lda, rwork, result( 2 ) )
467 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
475 IF( result( k ).GE.thresh )
THEN
476 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
477 $ CALL
aladhd( nout, path )
478 WRITE( nout, fmt = 9999 )
'SSYSV ', uplo, n,
479 $ imat, k, result( k )
490 $ CALL
slaset( uplo, n, n, zero, zero, afac, lda )
491 CALL
slaset(
'Full', n, nrhs, zero, zero, x, lda )
497 CALL
ssysvx( fact, uplo, n, nrhs, a, lda, afac, lda,
498 $ iwork,
b, lda, x, lda, rcond, rwork,
499 $ rwork( nrhs+1 ), work, lwork,
500 $ iwork( n+1 ), info )
508 IF( iwork( k ).LT.0 )
THEN
509 IF( iwork( k ).NE.-k )
THEN
513 ELSE IF( iwork( k ).NE.k )
THEN
522 CALL
alaerh( path,
'SSYSVX', info, k, fact // uplo,
523 $ n, n, -1, -1, nrhs, imat, nfail,
529 IF( ifact.GE.2 )
THEN
534 CALL
ssyt01( uplo, n, a, lda, afac, lda, iwork,
535 $ ainv, lda, rwork( 2*nrhs+1 ),
544 CALL
slacpy(
'Full', n, nrhs,
b, lda, work, lda )
545 CALL
spot02( uplo, n, nrhs, a, lda, x, lda, work,
546 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
550 CALL
sget04( n, nrhs, x, lda, xact, lda, rcondc,
555 CALL
spot05( uplo, n, nrhs, a, lda,
b, lda, x, lda,
556 $ xact, lda, rwork, rwork( nrhs+1 ),
565 result( 6 ) =
sget06( rcond, rcondc )
571 IF( result( k ).GE.thresh )
THEN
572 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
573 $ CALL
aladhd( nout, path )
574 WRITE( nout, fmt = 9998 )
'SSYSVX', fact, uplo,
575 $ n, imat, k, result( k )
589 CALL
alasvm( path, nout, nfail, nrun, nerrs )
591 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i2,
592 $
', test ', i2,
', ratio =', g12.5 )
593 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N =', i5,
594 $
', 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 slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
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