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 alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine ssytri2(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
SSYTRI2
subroutine sdrvsy(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SDRVSY
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 sebchvxx(THRESH, PATH)
SEBCHVXX
subroutine ssytrf(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
SSYTRF
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 slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
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 ...
real function sget06(RCOND, RCONDC)
SGET06
subroutine spot05(UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPOT05
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
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 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
subroutine serrvx(PATH, NUNIT)
SERRVX
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 spot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPOT02
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine ssyt01(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
SSYT01
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.