166 SUBROUTINE ddrvpo( 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,
TYPE, uplo, xtype
202 INTEGER i, iequed, ifact, imat, in, info, ioff, iuplo,
203 $ izero, k, k1, kl, ku, lda, mode, n, nb, nbmin,
204 $ nerrs, nfact, nfail, nimat, nrun, nt,
206 DOUBLE PRECISION ainvnm, amax, anorm, cndnum, rcond, rcondc,
207 $ roldc, scond, rpvgrw_svxx
210 CHARACTER equeds( 2 ), facts( 3 ), uplos( 2 )
211 INTEGER iseed( 4 ), iseedy( 4 )
212 DOUBLE PRECISION result( ntests ), berr( nrhs ),
213 $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
235 COMMON / infoc / infot, nunit, ok, lerr
236 COMMON / srnamc / srnamt
239 DATA iseedy / 1988, 1989, 1990, 1991 /
240 DATA uplos /
'U',
'L' /
241 DATA facts /
'F',
'N',
'E' /
242 DATA equeds /
'N',
'Y' /
248 path( 1: 1 ) =
'Double precision'
254 iseed( i ) = iseedy( i )
260 $
CALL derrvx( path, nout )
280 DO 120 imat = 1, nimat
284 IF( .NOT.dotype( imat ) )
289 zerot = imat.GE.3 .AND. imat.LE.5
290 IF( zerot .AND. n.LT.imat-2 )
296 uplo = uplos( iuplo )
301 CALL dlatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
305 CALL dlatms( n, n, dist, iseed,
TYPE, rwork, mode,
306 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
312 CALL alaerh( path,
'DLATMS', info, 0, uplo, n, n, -1,
313 $ -1, -1, imat, nfail, nerrs, nout )
323 ELSE IF( imat.EQ.4 )
THEN
328 ioff = ( izero-1 )*lda
332 IF( iuplo.EQ.1 )
THEN
333 DO 20 i = 1, izero - 1
343 DO 40 i = 1, izero - 1
358 CALL dlacpy( uplo, n, n, a, lda, asav, lda )
361 equed = equeds( iequed )
362 IF( iequed.EQ.1 )
THEN
368 DO 90 ifact = 1, nfact
369 fact = facts( ifact )
370 prefac =
lsame( fact,
'F' )
371 nofact =
lsame( fact,
'N' )
372 equil =
lsame( fact,
'E' )
379 ELSE IF( .NOT.
lsame( fact,
'N' ) )
THEN
386 CALL dlacpy( uplo, n, n, asav, lda, afac, lda )
387 IF( equil .OR. iequed.GT.1 )
THEN
392 CALL dpoequ( n, afac, lda, s, scond, amax,
394 IF( info.EQ.0 .AND. n.GT.0 )
THEN
400 CALL dlaqsy( uplo, n, afac, lda, s, scond,
413 anorm =
dlansy(
'1', uplo, n, afac, lda, rwork )
417 CALL dpotrf( uplo, n, afac, lda, info )
421 CALL dlacpy( uplo, n, n, afac, lda, a, lda )
422 CALL dpotri( uplo, n, a, lda, info )
426 ainvnm =
dlansy(
'1', uplo, n, a, lda, rwork )
427 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
430 rcondc = ( one / anorm ) / ainvnm
436 CALL dlacpy( uplo, n, n, asav, lda, a, lda )
441 CALL dlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
442 $ nrhs, a, lda, xact, lda, b, lda,
445 CALL dlacpy(
'Full', n, nrhs, b, lda, bsav, lda )
454 CALL dlacpy( uplo, n, n, a, lda, afac, lda )
455 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
458 CALL dposv( uplo, n, nrhs, afac, lda, x, lda,
463 IF( info.NE.izero )
THEN
464 CALL alaerh( path,
'DPOSV ', info, izero,
465 $ uplo, n, n, -1, -1, nrhs, imat,
466 $ nfail, nerrs, nout )
468 ELSE IF( info.NE.0 )
THEN
475 CALL dpot01( uplo, n, a, lda, afac, lda, rwork,
480 CALL dlacpy(
'Full', n, nrhs, b, lda, work,
482 CALL dpot02( uplo, n, nrhs, a, lda, x, lda,
483 $ work, lda, rwork, result( 2 ) )
487 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
495 IF( result( k ).GE.thresh )
THEN
496 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
497 $
CALL aladhd( nout, path )
498 WRITE( nout, fmt = 9999 )
'DPOSV ', uplo,
499 $ n, imat, k, result( k )
510 $
CALL dlaset( uplo, n, n, zero, zero, afac, lda )
511 CALL dlaset(
'Full', n, nrhs, zero, zero, x, lda )
512 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
517 CALL dlaqsy( uplo, n, a, lda, s, scond, amax,
525 CALL dposvx( fact, uplo, n, nrhs, a, lda, afac,
526 $ lda, equed, s, b, lda, x, lda, rcond,
527 $ rwork, rwork( nrhs+1 ), work, iwork,
532 IF( info.NE.izero )
THEN
533 CALL alaerh( path,
'DPOSVX', info, izero,
534 $ fact // uplo, n, n, -1, -1, nrhs,
535 $ imat, nfail, nerrs, nout )
540 IF( .NOT.prefac )
THEN
545 CALL dpot01( uplo, n, a, lda, afac, lda,
546 $ rwork( 2*nrhs+1 ), result( 1 ) )
554 CALL dlacpy(
'Full', n, nrhs, bsav, lda, work,
556 CALL dpot02( uplo, n, nrhs, asav, lda, x, lda,
557 $ work, lda, rwork( 2*nrhs+1 ),
562 IF( nofact .OR. ( prefac .AND.
lsame( equed,
564 CALL dget04( n, nrhs, x, lda, xact, lda,
565 $ rcondc, result( 3 ) )
567 CALL dget04( n, nrhs, x, lda, xact, lda,
568 $ roldc, result( 3 ) )
574 CALL dpot05( uplo, n, nrhs, asav, lda, b, lda,
575 $ x, lda, xact, lda, rwork,
576 $ rwork( nrhs+1 ), result( 4 ) )
584 result( 6 ) =
dget06( rcond, rcondc )
590 IF( result( k ).GE.thresh )
THEN
591 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
592 $
CALL aladhd( nout, path )
594 WRITE( nout, fmt = 9997 )
'DPOSVX', fact,
595 $ uplo, n, equed, imat, k, result( k )
597 WRITE( nout, fmt = 9998 )
'DPOSVX', fact,
598 $ uplo, n, imat, k, result( k )
609 CALL dlacpy(
'Full', n, n, asav, lda, a, lda )
610 CALL dlacpy(
'Full', n, nrhs, bsav, lda, b, lda )
613 $
CALL dlaset( uplo, n, n, zero, zero, afac, lda )
614 CALL dlaset(
'Full', n, nrhs, zero, zero, x, lda )
615 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
620 CALL dlaqsy( uplo, n, a, lda, s, scond, amax,
629 CALL dposvxx( fact, uplo, n, nrhs, a, lda, afac,
630 $ lda, equed, s, b, lda, x,
631 $ lda, rcond, rpvgrw_svxx, berr, n_err_bnds,
632 $ errbnds_n, errbnds_c, 0, zero, work,
637 IF( info.EQ.n+1 )
GOTO 90
638 IF( info.NE.izero )
THEN
639 CALL alaerh( path,
'DPOSVXX', info, izero,
640 $ fact // uplo, n, n, -1, -1, nrhs,
641 $ imat, nfail, nerrs, nout )
646 IF( .NOT.prefac )
THEN
651 CALL dpot01( uplo, n, a, lda, afac, lda,
652 $ rwork( 2*nrhs+1 ), result( 1 ) )
660 CALL dlacpy(
'Full', n, nrhs, bsav, lda, work,
662 CALL dpot02( uplo, n, nrhs, asav, lda, x, lda,
663 $ work, lda, rwork( 2*nrhs+1 ),
668 IF( nofact .OR. ( prefac .AND.
lsame( equed,
670 CALL dget04( n, nrhs, x, lda, xact, lda,
671 $ rcondc, result( 3 ) )
673 CALL dget04( n, nrhs, x, lda, xact, lda,
674 $ roldc, result( 3 ) )
680 CALL dpot05( uplo, n, nrhs, asav, lda, b, lda,
681 $ x, lda, xact, lda, rwork,
682 $ rwork( nrhs+1 ), result( 4 ) )
690 result( 6 ) =
dget06( rcond, rcondc )
696 IF( result( k ).GE.thresh )
THEN
697 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
698 $
CALL aladhd( nout, path )
700 WRITE( nout, fmt = 9997 )
'DPOSVXX', fact,
701 $ uplo, n, equed, imat, k, result( k )
703 WRITE( nout, fmt = 9998 )
'DPOSVXX', fact,
704 $ uplo, n, imat, k, result( k )
718 CALL alasvm( path, nout, nfail, nrun, nerrs )
725 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i1,
726 $
', test(', i1,
')=', g12.5 )
727 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
728 $
', type ', i1,
', test(', i1,
')=', g12.5 )
729 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
730 $
', EQUED=''', a1,
''', type ', i1,
', test(', i1,
') =',
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
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 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 dpotrf(UPLO, N, A, LDA, INFO)
DPOTRF
subroutine ddrvpo(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
DDRVPO
subroutine debchvxx(THRESH, PATH)
DEBCHVXX
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 dposv(UPLO, N, NRHS, A, LDA, B, LDB, INFO)
DPOSV computes the solution to system of linear equations A * X = B for PO matrices ...
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine dlaqsy(UPLO, N, A, LDA, S, SCOND, AMAX, EQUED)
DLAQSY scales a symmetric/Hermitian matrix, using scaling factors computed by spoequ.
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine aladhd(IOUNIT, PATH)
ALADHD
logical function lsame(CA, CB)
LSAME
subroutine derrvx(PATH, NUNIT)
DERRVX
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine dpot01(UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID)
DPOT01
subroutine dpot05(UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
DPOT05
subroutine dposvx(FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
DPOSVX computes the solution to system of linear equations A * X = B for PO matrices ...
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dpoequ(N, A, LDA, S, SCOND, AMAX, INFO)
DPOEQU
subroutine dpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPOT02
subroutine dposvxx(FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO)
DPOSVXX computes the solution to system of linear equations A * X = B for PO matrices ...
subroutine dpotri(UPLO, N, A, LDA, INFO)
DPOTRI