167 SUBROUTINE dchksy( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
168 $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
169 $ XACT, WORK, RWORK, IWORK, NOUT )
177 INTEGER NMAX, NN, NNB, NNS, NOUT
178 DOUBLE PRECISION THRESH
182 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
183 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
184 $ rwork( * ), work( * ), x( * ), xact( * )
190 DOUBLE PRECISION ZERO
191 PARAMETER ( ZERO = 0.0d+0 )
193 parameter( ntypes = 10 )
195 parameter( ntests = 9 )
198 LOGICAL TRFCON, ZEROT
199 CHARACTER DIST,
TYPE, UPLO, XTYPE
201 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
202 $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
203 $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
204 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
208 INTEGER ISEED( 4 ), ISEEDY( 4 )
209 DOUBLE PRECISION RESULT( NTESTS )
212 DOUBLE PRECISION DGET06, DLANSY
213 EXTERNAL DGET06, DLANSY
230 COMMON / infoc / infot, nunit, ok, lerr
231 COMMON / srnamc / srnamt
234 DATA iseedy / 1988, 1989, 1990, 1991 /
235 DATA uplos /
'U',
'L' /
241 path( 1: 1 ) =
'Double precision'
247 iseed( i ) = iseedy( i )
253 $
CALL derrsy( path, nout )
275 DO 170 imat = 1, nimat
279 IF( .NOT.dotype( imat ) )
284 zerot = imat.GE.3 .AND. imat.LE.6
285 IF( zerot .AND. n.LT.imat-2 )
291 uplo = uplos( iuplo )
299 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 )
327 ELSE IF( imat.EQ.4 )
THEN
337 IF( iuplo.EQ.1 )
THEN
338 ioff = ( izero-1 )*lda
339 DO 20 i = 1, izero - 1
349 DO 40 i = 1, izero - 1
359 IF( iuplo.EQ.1 )
THEN
405 CALL dlacpy( uplo, n, n, a, lda, afac, lda )
412 lwork = max( 2, nb )*lda
414 CALL dsytrf( uplo, n, afac, lda, iwork, ainv, lwork,
423 IF( iwork( k ).LT.0 )
THEN
424 IF( iwork( k ).NE.-k )
THEN
428 ELSE IF( iwork( k ).NE.k )
THEN
437 $
CALL alaerh( path,
'DSYTRF', info, k, uplo, n, n,
438 $ -1, -1, nb, imat, nfail, nerrs, nout )
451 CALL dsyt01( uplo, n, a, lda, afac, lda, iwork, ainv,
452 $ lda, rwork, result( 1 ) )
461 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
462 CALL dlacpy( uplo, n, n, afac, lda, ainv, lda )
464 lwork = (n+nb+1)*(nb+3)
465 CALL dsytri2( uplo, n, ainv, lda, iwork, work,
471 $
CALL alaerh( path,
'DSYTRI2', info, -1, uplo, n,
472 $ n, -1, -1, -1, imat, nfail, nerrs,
478 CALL dpot03( uplo, n, a, lda, ainv, lda, work, lda,
479 $ rwork, rcondc, result( 2 ) )
487 IF( result( k ).GE.thresh )
THEN
488 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
489 $
CALL alahd( nout, path )
490 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
522 CALL dlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
523 $ nrhs, a, lda, xact, lda, b, lda,
525 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
528 CALL dsytrs( uplo, n, nrhs, afac, lda, iwork, x,
534 $
CALL alaerh( path,
'DSYTRS', info, 0, uplo, n,
535 $ n, -1, -1, nrhs, imat, nfail,
538 CALL dlacpy(
'Full', n, nrhs, b, lda, work, lda )
542 CALL dpot02( uplo, n, nrhs, a, lda, x, lda, work,
543 $ lda, rwork, result( 3 ) )
553 CALL dlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
554 $ nrhs, a, lda, xact, lda, b, lda,
556 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
559 CALL dsytrs2( uplo, n, nrhs, afac, lda, iwork, x,
565 $
CALL alaerh( path,
'DSYTRS2', info, 0, uplo, n,
566 $ n, -1, -1, nrhs, imat, nfail,
569 CALL dlacpy(
'Full', n, nrhs, b, lda, work, lda )
573 CALL dpot02( uplo, n, nrhs, a, lda, x, lda, work,
574 $ lda, rwork, result( 4 ) )
579 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
586 CALL dsyrfs( uplo, n, nrhs, a, lda, afac, lda,
587 $ iwork, b, lda, x, lda, rwork,
588 $ rwork( nrhs+1 ), work, iwork( n+1 ),
594 $
CALL alaerh( path,
'DSYRFS', info, 0, uplo, n,
595 $ n, -1, -1, nrhs, imat, nfail,
598 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
600 CALL dpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
601 $ xact, lda, rwork, rwork( nrhs+1 ),
608 IF( result( k ).GE.thresh )
THEN
609 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
610 $
CALL alahd( nout, path )
611 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
612 $ imat, k, result( k )
626 anorm = dlansy(
'1', uplo, n, a, lda, rwork )
628 CALL dsycon( uplo, n, afac, lda, iwork, anorm, rcond,
629 $ work, iwork( n+1 ), info )
634 $
CALL alaerh( path,
'DSYCON', info, 0, uplo, n, n,
635 $ -1, -1, -1, imat, nfail, nerrs, nout )
639 result( 9 ) = dget06( rcond, rcondc )
644 IF( result( 9 ).GE.thresh )
THEN
645 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
646 $
CALL alahd( nout, path )
647 WRITE( nout, fmt = 9997 )uplo, n, imat, 9,
660 CALL alasum( path, nout, nfail, nrun, nerrs )
662 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
663 $ i2,
', test ', i2,
', ratio =', g12.5 )
664 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
665 $ i2,
', test(', i2,
') =', g12.5 )
666 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
667 $
', test(', i2,
') =', g12.5 )
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
subroutine dlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
DLARHS
subroutine xlaenv(ispec, nvalue)
XLAENV
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine alahd(iounit, path)
ALAHD
subroutine dchksy(dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
DCHKSY
subroutine derrsy(path, nunit)
DERRSY
subroutine dget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
DGET04
subroutine dlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
DLATB4
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 dpot03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
DPOT03
subroutine dpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DPOT05
subroutine dsyt01(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
DSYT01
subroutine dsycon(uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
DSYCON
subroutine dsyrfs(uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DSYRFS
subroutine dsytrf(uplo, n, a, lda, ipiv, work, lwork, info)
DSYTRF
subroutine dsytri2(uplo, n, a, lda, ipiv, work, lwork, info)
DSYTRI2
subroutine dsytrs2(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
DSYTRS2
subroutine dsytrs(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
DSYTRS
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.