182 INTEGER nmax, nn, nnb, nns, nout
183 DOUBLE PRECISION thresh
187 INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
188 DOUBLE PRECISION a( * ), afac( * ), ainv( * ), b( * ),
189 $ rwork( * ), work( * ), x( * ), xact( * )
195 DOUBLE PRECISION zero
196 parameter ( zero = 0.0d+0 )
198 parameter ( ntypes = 9 )
200 parameter ( ntests = 8 )
204 CHARACTER dist,
TYPE, uplo, xtype
206 INTEGER i, imat, in, inb, info, ioff, irhs, iuplo,
207 $ izero, k, kl, ku, lda, mode, n, nb, nerrs,
208 $ nfail, nimat, nrhs, nrun
209 DOUBLE PRECISION anorm, cndnum, rcond, rcondc
213 INTEGER iseed( 4 ), iseedy( 4 )
214 DOUBLE PRECISION result( ntests )
232 COMMON / infoc / infot, nunit, ok, lerr
233 COMMON / srnamc / srnamt
239 DATA iseedy / 1988, 1989, 1990, 1991 /
240 DATA uplos /
'U',
'L' /
246 path( 1: 1 ) =
'Double precision'
252 iseed( i ) = iseedy( i )
258 $
CALL derrpo( path, nout )
273 DO 110 imat = 1, nimat
277 IF( .NOT.dotype( imat ) )
282 zerot = imat.GE.3 .AND. imat.LE.5
283 IF( zerot .AND. n.LT.imat-2 )
289 uplo = uplos( iuplo )
294 CALL dlatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
298 CALL dlatms( n, n, dist, iseed,
TYPE, rwork, mode,
299 $ cndnum, anorm, kl, ku, uplo, 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
321 ioff = ( izero-1 )*lda
325 IF( iuplo.EQ.1 )
THEN
326 DO 20 i = 1, izero - 1
336 DO 40 i = 1, izero - 1
357 CALL dlacpy( uplo, n, n, a, lda, afac, lda )
359 CALL dpotrf( uplo, n, afac, lda, info )
363 IF( info.NE.izero )
THEN
364 CALL alaerh( path,
'DPOTRF', info, izero, uplo, n,
365 $ n, -1, -1, nb, imat, nfail, nerrs,
378 CALL dlacpy( uplo, n, n, afac, lda, ainv, lda )
379 CALL dpot01( uplo, n, a, lda, ainv, lda, rwork,
385 CALL dlacpy( uplo, n, n, afac, lda, ainv, lda )
387 CALL dpotri( uplo, n, ainv, lda, info )
392 $
CALL alaerh( path,
'DPOTRI', info, 0, uplo, n, n,
393 $ -1, -1, -1, imat, nfail, nerrs, nout )
395 CALL dpot03( uplo, n, a, lda, ainv, lda, work, lda,
396 $ rwork, rcondc, result( 2 ) )
402 IF( result( k ).GE.thresh )
THEN
403 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
404 $
CALL alahd( nout, path )
405 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
425 CALL dlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
426 $ nrhs, a, lda, xact, lda, b, lda,
428 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
431 CALL dpotrs( uplo, n, nrhs, afac, lda, x, lda,
437 $
CALL alaerh( path,
'DPOTRS', info, 0, uplo, n,
438 $ n, -1, -1, nrhs, imat, nfail,
441 CALL dlacpy(
'Full', n, nrhs, b, lda, work, lda )
442 CALL dpot02( uplo, n, nrhs, a, lda, x, lda, work,
443 $ lda, rwork, result( 3 ) )
448 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
455 CALL dporfs( uplo, n, nrhs, a, lda, afac, lda, b,
456 $ lda, x, lda, rwork, rwork( nrhs+1 ),
457 $ work, iwork, info )
462 $
CALL alaerh( path,
'DPORFS', info, 0, uplo, n,
463 $ n, -1, -1, nrhs, imat, nfail,
466 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
468 CALL dpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
469 $ xact, lda, rwork, rwork( nrhs+1 ),
476 IF( result( k ).GE.thresh )
THEN
477 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
478 $
CALL alahd( nout, path )
479 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
480 $ imat, k, result( k )
490 anorm =
dlansy(
'1', uplo, n, a, lda, rwork )
492 CALL dpocon( uplo, n, afac, lda, anorm, rcond, work,
498 $
CALL alaerh( path,
'DPOCON', info, 0, uplo, n, n,
499 $ -1, -1, -1, imat, nfail, nerrs, nout )
501 result( 8 ) =
dget06( rcond, rcondc )
505 IF( result( 8 ).GE.thresh )
THEN
506 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
507 $
CALL alahd( nout, path )
508 WRITE( nout, fmt = 9997 )uplo, n, imat, 8,
520 CALL alasum( path, nout, nfail, nrun, nerrs )
522 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
523 $ i2,
', test ', i2,
', ratio =', g12.5 )
524 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
525 $ i2,
', test(', i2,
') =', g12.5 )
526 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
527 $
', test(', i2,
') =', g12.5 )
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine alahd(IOUNIT, PATH)
ALAHD
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 dpocon(UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO)
DPOCON
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine dpot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
DPOT03
subroutine dpotrs(UPLO, N, NRHS, A, LDA, B, LDB, INFO)
DPOTRS
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
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 dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dporfs(UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DPORFS
subroutine dpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPOT02
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine derrpo(PATH, NUNIT)
DERRPO
subroutine dpotri(UPLO, N, A, LDA, INFO)
DPOTRI