166 SUBROUTINE ddrvpp( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
167 $ a, afac, asav, b, bsav, x, xact, s, work,
168 $ rwork, iwork, nout )
177 INTEGER NMAX, NN, NOUT, NRHS
178 DOUBLE PRECISION THRESH
182 INTEGER IWORK( * ), NVAL( * )
183 DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
184 $ bsav( * ), rwork( * ), s( * ), work( * ),
191 DOUBLE PRECISION ONE, ZERO
192 parameter( one = 1.0d+0, zero = 0.0d+0 )
194 parameter( ntypes = 9 )
196 parameter( ntests = 6 )
199 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
200 CHARACTER DIST, EQUED, FACT, PACKIT,
TYPE, UPLO, XTYPE
202 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
203 $ izero, k, k1, kl, ku, lda, mode, n, nerrs,
204 $ nfact, nfail, nimat, npp, nrun, nt
205 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
209 CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 )
210 INTEGER ISEED( 4 ), ISEEDY( 4 )
211 DOUBLE PRECISION RESULT( ntests )
215 DOUBLE PRECISION DGET06, DLANSP
216 EXTERNAL lsame, dget06, dlansp
230 COMMON / infoc / infot, nunit, ok, lerr
231 COMMON / srnamc / srnamt
237 DATA iseedy / 1988, 1989, 1990, 1991 /
238 DATA uplos /
'U',
'L' / , facts /
'F',
'N',
'E' / ,
239 $ packs /
'C',
'R' / , equeds /
'N',
'Y' /
245 path( 1: 1 ) =
'Double precision'
251 iseed( i ) = iseedy( i )
257 $ CALL
derrvx( path, nout )
271 DO 130 imat = 1, nimat
275 IF( .NOT.dotype( imat ) )
280 zerot = imat.GE.3 .AND. imat.LE.5
281 IF( zerot .AND. n.LT.imat-2 )
287 uplo = uplos( iuplo )
288 packit = packs( iuplo )
293 CALL
dlatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
295 rcondc = one / cndnum
298 CALL
dlatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
299 $ cndnum, anorm, kl, ku, packit, a, lda, work,
305 CALL
alaerh( path,
'DLATMS', info, 0, uplo, n, n, -1,
306 $ -1, -1, imat, nfail, nerrs, nout )
316 ELSE IF( imat.EQ.4 )
THEN
324 IF( iuplo.EQ.1 )
THEN
325 ioff = ( izero-1 )*izero / 2
326 DO 20 i = 1, izero - 1
336 DO 40 i = 1, izero - 1
351 CALL
dcopy( npp, a, 1, asav, 1 )
354 equed = equeds( iequed )
355 IF( iequed.EQ.1 )
THEN
361 DO 100 ifact = 1, nfact
362 fact = facts( ifact )
363 prefac = lsame( fact,
'F' )
364 nofact = lsame( fact,
'N' )
365 equil = lsame( fact,
'E' )
372 ELSE IF( .NOT.lsame( fact,
'N' ) )
THEN
379 CALL
dcopy( npp, asav, 1, afac, 1 )
380 IF( equil .OR. iequed.GT.1 )
THEN
385 CALL
dppequ( uplo, n, afac, s, scond, amax,
387 IF( info.EQ.0 .AND. n.GT.0 )
THEN
393 CALL
dlaqsp( uplo, n, afac, s, scond,
406 anorm = dlansp(
'1', uplo, n, afac, rwork )
410 CALL
dpptrf( uplo, n, afac, info )
414 CALL
dcopy( npp, afac, 1, a, 1 )
415 CALL
dpptri( uplo, n, a, info )
419 ainvnm = dlansp(
'1', uplo, n, a, rwork )
420 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
423 rcondc = ( one / anorm ) / ainvnm
429 CALL
dcopy( npp, asav, 1, a, 1 )
434 CALL
dlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
435 $ nrhs, a, lda, xact, lda, b, lda,
438 CALL
dlacpy(
'Full', n, nrhs, b, lda, bsav, lda )
447 CALL
dcopy( npp, a, 1, afac, 1 )
448 CALL
dlacpy(
'Full', n, nrhs, b, lda, x, lda )
451 CALL
dppsv( uplo, n, nrhs, afac, x, lda, info )
455 IF( info.NE.izero )
THEN
456 CALL
alaerh( path,
'DPPSV ', info, izero,
457 $ uplo, n, n, -1, -1, nrhs, imat,
458 $ nfail, nerrs, nout )
460 ELSE IF( info.NE.0 )
THEN
467 CALL
dppt01( uplo, n, a, afac, rwork,
472 CALL
dlacpy(
'Full', n, nrhs, b, lda, work,
474 CALL
dppt02( uplo, n, nrhs, a, x, lda, work,
475 $ lda, rwork, result( 2 ) )
479 CALL
dget04( n, nrhs, x, lda, xact, lda, rcondc,
487 IF( result( k ).GE.thresh )
THEN
488 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
489 $ CALL
aladhd( nout, path )
490 WRITE( nout, fmt = 9999 )
'DPPSV ', uplo,
491 $ n, imat, k, result( k )
501 IF( .NOT.prefac .AND. npp.GT.0 )
502 $ CALL
dlaset(
'Full', npp, 1, zero, zero, afac,
504 CALL
dlaset(
'Full', n, nrhs, zero, zero, x, lda )
505 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
510 CALL
dlaqsp( uplo, n, a, s, scond, amax, equed )
517 CALL
dppsvx( fact, uplo, n, nrhs, a, afac, equed,
518 $ s, b, lda, x, lda, rcond, rwork,
519 $ rwork( nrhs+1 ), work, iwork, info )
523 IF( info.NE.izero )
THEN
524 CALL
alaerh( path,
'DPPSVX', info, izero,
525 $ fact // uplo, n, n, -1, -1, nrhs,
526 $ imat, nfail, nerrs, nout )
531 IF( .NOT.prefac )
THEN
536 CALL
dppt01( uplo, n, a, afac,
537 $ rwork( 2*nrhs+1 ), result( 1 ) )
545 CALL
dlacpy(
'Full', n, nrhs, bsav, lda, work,
547 CALL
dppt02( uplo, n, nrhs, asav, x, lda, work,
548 $ lda, rwork( 2*nrhs+1 ),
553 IF( nofact .OR. ( prefac .AND. lsame( equed,
555 CALL
dget04( n, nrhs, x, lda, xact, lda,
556 $ rcondc, result( 3 ) )
558 CALL
dget04( n, nrhs, x, lda, xact, lda,
559 $ roldc, result( 3 ) )
565 CALL
dppt05( uplo, n, nrhs, asav, b, lda, x,
566 $ lda, xact, lda, rwork,
567 $ rwork( nrhs+1 ), result( 4 ) )
575 result( 6 ) = dget06( rcond, rcondc )
581 IF( result( k ).GE.thresh )
THEN
582 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
583 $ CALL
aladhd( nout, path )
585 WRITE( nout, fmt = 9997 )
'DPPSVX', fact,
586 $ uplo, n, equed, imat, k, result( k )
588 WRITE( nout, fmt = 9998 )
'DPPSVX', fact,
589 $ uplo, n, imat, k, result( k )
604 CALL
alasvm( path, nout, nfail, nrun, nerrs )
606 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i1,
607 $
', test(', i1,
')=', g12.5 )
608 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
609 $
', type ', i1,
', test(', i1,
')=', g12.5 )
610 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
611 $
', EQUED=''', a1,
''', type ', i1,
', test(', i1,
')=',
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dppsvx(FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
DPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine derrvx(PATH, NUNIT)
DERRVX
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
subroutine dlaqsp(UPLO, N, AP, S, SCOND, AMAX, EQUED)
DLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppeq...
subroutine dpptri(UPLO, N, AP, INFO)
DPPTRI
subroutine dppt01(UPLO, N, A, AFAC, RWORK, RESID)
DPPT01
subroutine dpptrf(UPLO, N, AP, INFO)
DPPTRF
subroutine dppequ(UPLO, N, AP, S, SCOND, AMAX, INFO)
DPPEQU
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine dppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPPT05
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 ddrvpp(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
DDRVPP
subroutine dppsv(UPLO, N, NRHS, AP, B, LDB, INFO)
DPPSV computes the solution to system of linear equations A * X = B for OTHER matrices ...