155 SUBROUTINE ddrvsy( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
156 $ a, afac, ainv,
b, x, xact, work, rwork, iwork,
166 INTEGER nmax, nn, nout, nrhs
167 DOUBLE PRECISION thresh
171 INTEGER iwork( * ), nval( * )
172 DOUBLE PRECISION a( * ), afac( * ), ainv( * ),
b( * ),
173 $ rwork( * ), work( * ), x( * ), xact( * )
179 DOUBLE PRECISION one, zero
180 parameter( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION ainvnm, anorm, cndnum, rcond, rcondc,
198 CHARACTER facts( nfact ), uplos( 2 )
199 INTEGER iseed( 4 ), iseedy( 4 )
200 DOUBLE PRECISION 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 ) =
'Double precision'
239 iseed( i ) = iseedy( i )
241 lwork = max( 2*nmax, nmax*nrhs )
246 $ CALL
derrvx( 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
dlatb4( path, imat, n, n, type, kl, ku, anorm, mode,
291 CALL
dlatms( n, n, dist, iseed, type, rwork, mode,
292 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
298 CALL
alaerh( path,
'DLATMS', 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 =
dlansy(
'1', uplo, n, a, lda, rwork )
392 CALL
dlacpy( uplo, n, n, a, lda, afac, lda )
393 CALL
dsytrf( uplo, n, afac, lda, iwork, work,
398 CALL
dlacpy( uplo, n, n, afac, lda, ainv, lda )
399 lwork = (n+nb+1)*(nb+3)
400 CALL
dsytri2( uplo, n, ainv, lda, iwork, work,
402 ainvnm =
dlansy(
'1', uplo, n, ainv, lda, rwork )
406 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
409 rcondc = ( one / anorm ) / ainvnm
416 CALL
dlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
417 $ nrhs, a, lda, xact, lda,
b, lda, iseed,
423 IF( ifact.EQ.2 )
THEN
424 CALL
dlacpy( uplo, n, n, a, lda, afac, lda )
425 CALL
dlacpy(
'Full', n, nrhs,
b, lda, x, lda )
430 CALL
dsysv( 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,
'DSYSV ', info, k, uplo, n,
454 $ n, -1, -1, nrhs, imat, nfail,
457 ELSE IF( info.NE.0 )
THEN
464 CALL
dsyt01( uplo, n, a, lda, afac, lda, iwork,
465 $ ainv, lda, rwork, result( 1 ) )
469 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
470 CALL
dpot02( uplo, n, nrhs, a, lda, x, lda, work,
471 $ lda, rwork, result( 2 ) )
475 CALL
dget04( 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 )
'DSYSV ', uplo, n,
487 $ imat, k, result( k )
498 $ CALL
dlaset( uplo, n, n, zero, zero, afac, lda )
499 CALL
dlaset(
'Full', n, nrhs, zero, zero, x, lda )
505 CALL
dsysvx( 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,
'DSYSVX', info, k, fact // uplo,
531 $ n, n, -1, -1, nrhs, imat, nfail,
537 IF( ifact.GE.2 )
THEN
542 CALL
dsyt01( uplo, n, a, lda, afac, lda, iwork,
543 $ ainv, lda, rwork( 2*nrhs+1 ),
552 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
553 CALL
dpot02( uplo, n, nrhs, a, lda, x, lda, work,
554 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
558 CALL
dget04( n, nrhs, x, lda, xact, lda, rcondc,
563 CALL
dpot05( uplo, n, nrhs, a, lda,
b, lda, x, lda,
564 $ xact, lda, rwork, rwork( nrhs+1 ),
573 result( 6 ) =
dget06( 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 )
'DSYSVX', fact, uplo,
583 $ n, imat, k, result( k )
594 $ CALL
dlaset( uplo, n, n, zero, zero, afac, lda )
595 CALL
dlaset(
'Full', n, nrhs, zero, zero, x, lda )
603 CALL
dsysvxx( 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,
'DSYSVXX', info, k,
630 $ fact // uplo, n, n, -1, -1, nrhs, imat, nfail,
636 IF( ifact.GE.2 )
THEN
641 CALL
dsyt01( uplo, n, a, lda, afac, lda, iwork,
642 $ ainv, lda, rwork(2*nrhs+1),
651 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
652 CALL
dpot02( uplo, n, nrhs, a, lda, x, lda, work,
653 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
657 CALL
dget04( n, nrhs, x, lda, xact, lda, rcondc,
662 CALL
dpot05( uplo, n, nrhs, a, lda,
b, lda, x, lda,
663 $ xact, lda, rwork, rwork( nrhs+1 ),
672 result( 6 ) =
dget06( 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 )
'DSYSVXX',
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 ddrvsy(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
DDRVSY
subroutine dsysvx(FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO)
DSYSVX computes the solution to system of linear equations A * X = B for SY matrices ...
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPOT02
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine dpot05(UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPOT05
subroutine derrvx(PATH, NUNIT)
DERRVX
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dsysv(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO)
DSYSV computes the solution to system of linear equations A * X = B for SY matrices ...
subroutine dsysvxx(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)
DSYSVXX
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine debchvxx(THRESH, PATH)
DEBCHVXX
subroutine aladhd(IOUNIT, PATH)
ALADHD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dsytri2(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
DSYTRI2
double precision function dlansy(NORM, UPLO, N, A, LDA, WORK)
DLANSY 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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dsyt01(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
DSYT01
subroutine dsytrf(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
DSYTRF