151 SUBROUTINE ddrvsy( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
152 $ a, afac, ainv,
b, x, xact, work, rwork, iwork,
162 INTEGER nmax, nn, nout, nrhs
163 DOUBLE PRECISION thresh
167 INTEGER iwork( * ), nval( * )
168 DOUBLE PRECISION a( * ), afac( * ), ainv( * ),
b( * ),
169 $ rwork( * ), work( * ), x( * ), xact( * )
175 DOUBLE PRECISION one, zero
176 parameter( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION ainvnm, anorm, cndnum, rcond, rcondc
192 CHARACTER facts( nfact ), uplos( 2 )
193 INTEGER iseed( 4 ), iseedy( 4 )
194 DOUBLE PRECISION 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 ) =
'Double precision'
231 iseed( i ) = iseedy( i )
233 lwork = max( 2*nmax, nmax*nrhs )
238 $ CALL
derrvx( 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
dlatb4( path, imat, n, n, type, kl, ku, anorm, mode,
283 CALL
dlatms( n, n, dist, iseed, type, rwork, mode,
284 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
290 CALL
alaerh( path,
'DLATMS', 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 =
dlansy(
'1', uplo, n, a, lda, rwork )
384 CALL
dlacpy( uplo, n, n, a, lda, afac, lda )
385 CALL
dsytrf( uplo, n, afac, lda, iwork, work,
390 CALL
dlacpy( uplo, n, n, afac, lda, ainv, lda )
391 lwork = (n+nb+1)*(nb+3)
392 CALL
dsytri2( uplo, n, ainv, lda, iwork, work,
394 ainvnm =
dlansy(
'1', uplo, n, ainv, lda, rwork )
398 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
401 rcondc = ( one / anorm ) / ainvnm
408 CALL
dlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
409 $ nrhs, a, lda, xact, lda,
b, lda, iseed,
415 IF( ifact.EQ.2 )
THEN
416 CALL
dlacpy( uplo, n, n, a, lda, afac, lda )
417 CALL
dlacpy(
'Full', n, nrhs,
b, lda, x, lda )
422 CALL
dsysv( 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,
'DSYSV ', info, k, uplo, n,
446 $ n, -1, -1, nrhs, imat, nfail,
449 ELSE IF( info.NE.0 )
THEN
456 CALL
dsyt01( uplo, n, a, lda, afac, lda, iwork,
457 $ ainv, lda, rwork, result( 1 ) )
461 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
462 CALL
dpot02( uplo, n, nrhs, a, lda, x, lda, work,
463 $ lda, rwork, result( 2 ) )
467 CALL
dget04( 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 )
'DSYSV ', uplo, n,
479 $ imat, k, result( k )
490 $ CALL
dlaset( uplo, n, n, zero, zero, afac, lda )
491 CALL
dlaset(
'Full', n, nrhs, zero, zero, x, lda )
497 CALL
dsysvx( 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,
'DSYSVX', info, k, fact // uplo,
523 $ n, n, -1, -1, nrhs, imat, nfail,
529 IF( ifact.GE.2 )
THEN
534 CALL
dsyt01( uplo, n, a, lda, afac, lda, iwork,
535 $ ainv, lda, rwork( 2*nrhs+1 ),
544 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
545 CALL
dpot02( uplo, n, nrhs, a, lda, x, lda, work,
546 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
550 CALL
dget04( n, nrhs, x, lda, xact, lda, rcondc,
555 CALL
dpot05( uplo, n, nrhs, a, lda,
b, lda, x, lda,
556 $ xact, lda, rwork, rwork( nrhs+1 ),
565 result( 6 ) =
dget06( 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 )
'DSYSVX', 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 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 ...
double precision function dget06(RCOND, RCONDC)
DGET06
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 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