155 SUBROUTINE ddrvsp( 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, fact, packit, 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 $ nerrs, nfail, nimat, npp, nrun, nt
193 DOUBLE PRECISION ainvnm, anorm, cndnum, rcond, rcondc
196 CHARACTER facts( nfact )
197 INTEGER iseed( 4 ), iseedy( 4 )
198 DOUBLE PRECISION result( ntests )
215 COMMON / infoc / infot, nunit, ok, lerr
216 COMMON / srnamc / srnamt
222 DATA iseedy / 1988, 1989, 1990, 1991 /
223 DATA facts /
'F',
'N' /
229 path( 1: 1 ) =
'Double precision'
235 iseed( i ) = iseedy( i )
237 lwork = max( 2*nmax, nmax*nrhs )
242 $ CALL
derrvx( path, nout )
256 DO 170 imat = 1, nimat
260 IF( .NOT.dotype( imat ) )
265 zerot = imat.GE.3 .AND. imat.LE.6
266 IF( zerot .AND. n.LT.imat-2 )
272 IF( iuplo.EQ.1 )
THEN
283 CALL
dlatb4( path, imat, n, n, type, kl, ku, anorm, mode,
287 CALL
dlatms( n, n, dist, iseed, type, rwork, mode,
288 $ cndnum, anorm, kl, ku, packit, a, lda, work,
294 CALL
alaerh( path,
'DLATMS', info, 0, uplo, n, n, -1,
295 $ -1, -1, imat, nfail, nerrs, nout )
305 ELSE IF( imat.EQ.4 )
THEN
315 IF( iuplo.EQ.1 )
THEN
316 ioff = ( izero-1 )*izero / 2
317 DO 20 i = 1, izero - 1
327 DO 40 i = 1, izero - 1
338 IF( iuplo.EQ.1 )
THEN
366 DO 150 ifact = 1, nfact
370 fact = facts( ifact )
380 ELSE IF( ifact.EQ.1 )
THEN
384 anorm =
dlansp(
'1', uplo, n, a, rwork )
388 CALL
dcopy( npp, a, 1, afac, 1 )
389 CALL
dsptrf( uplo, n, afac, iwork, info )
393 CALL
dcopy( npp, afac, 1, ainv, 1 )
394 CALL
dsptri( uplo, n, ainv, iwork, work, info )
395 ainvnm =
dlansp(
'1', uplo, n, ainv, rwork )
399 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
402 rcondc = ( one / anorm ) / ainvnm
409 CALL
dlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
410 $ nrhs, a, lda, xact, lda,
b, lda, iseed,
416 IF( ifact.EQ.2 )
THEN
417 CALL
dcopy( npp, a, 1, afac, 1 )
418 CALL
dlacpy(
'Full', n, nrhs,
b, lda,
x, lda )
423 CALL
dspsv( uplo, n, nrhs, afac, iwork,
x, lda,
432 IF( iwork( k ).LT.0 )
THEN
433 IF( iwork( k ).NE.-k )
THEN
437 ELSE IF( iwork( k ).NE.k )
THEN
446 CALL
alaerh( path,
'DSPSV ', info, k, uplo, n,
447 $ n, -1, -1, nrhs, imat, nfail,
450 ELSE IF( info.NE.0 )
THEN
457 CALL
dspt01( uplo, n, a, afac, iwork, ainv, lda,
458 $ rwork, result( 1 ) )
462 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
463 CALL
dppt02( uplo, n, nrhs, a,
x, lda, work, lda,
464 $ rwork, result( 2 ) )
468 CALL
dget04( n, nrhs,
x, lda, xact, lda, rcondc,
476 IF( result( k ).GE.thresh )
THEN
477 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
478 $ CALL
aladhd( nout, path )
479 WRITE( nout, fmt = 9999 )
'DSPSV ', uplo, n,
480 $ imat, k, result( k )
490 IF( ifact.EQ.2 .AND. npp.GT.0 )
491 $ CALL
dlaset(
'Full', npp, 1, zero, zero, afac,
493 CALL
dlaset(
'Full', n, nrhs, zero, zero,
x, lda )
499 CALL
dspsvx( fact, uplo, n, nrhs, a, afac, iwork,
b,
500 $ lda,
x, lda, rcond, rwork,
501 $ rwork( nrhs+1 ), work, iwork( n+1 ),
510 IF( iwork( k ).LT.0 )
THEN
511 IF( iwork( k ).NE.-k )
THEN
515 ELSE IF( iwork( k ).NE.k )
THEN
524 CALL
alaerh( path,
'DSPSVX', info, k, fact // uplo,
525 $ n, n, -1, -1, nrhs, imat, nfail,
531 IF( ifact.GE.2 )
THEN
536 CALL
dspt01( uplo, n, a, afac, iwork, ainv, lda,
537 $ rwork( 2*nrhs+1 ), result( 1 ) )
545 CALL
dlacpy(
'Full', n, nrhs,
b, lda, work, lda )
546 CALL
dppt02( uplo, n, nrhs, a,
x, lda, work, lda,
547 $ rwork( 2*nrhs+1 ), result( 2 ) )
551 CALL
dget04( n, nrhs,
x, lda, xact, lda, rcondc,
556 CALL
dppt05( uplo, n, nrhs, a,
b, lda,
x, lda,
557 $ xact, lda, rwork, rwork( nrhs+1 ),
566 result( 6 ) =
dget06( rcond, rcondc )
572 IF( result( k ).GE.thresh )
THEN
573 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
574 $ CALL
aladhd( nout, path )
575 WRITE( nout, fmt = 9998 )
'DSPSVX', fact, uplo,
576 $ n, imat, k, result( k )
590 CALL
alasvm( path, nout, nfail, nrun, nerrs )
592 9999
FORMAT( 1
x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i2,
593 $
', test ', i2,
', ratio =', g12.5 )
594 9998
FORMAT( 1
x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N =', i5,
595 $
', type ', i2,
', test ', i2,
', ratio =', g12.5 )
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine ddrvsp(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
DDRVSP
subroutine derrvx(PATH, NUNIT)
DERRVX
subroutine dspt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
DSPT01
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
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 dppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
DPPT02
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
DOUBLE PRECISION function dget06(RCOND, RCONDC)
DGET06
subroutine dsptri(UPLO, N, AP, IPIV, WORK, INFO)
DSPTRI
subroutine dspsvx(FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
DSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine aladhd(IOUNIT, PATH)
ALADHD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dsptrf(UPLO, N, AP, IPIV, INFO)
DSPTRF
subroutine dppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPPT05
DOUBLE PRECISION function dlansp(NORM, UPLO, N, AP, WORK)
DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.
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 dspsv(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
DSPSV computes the solution to system of linear equations A * X = B for OTHER matrices ...