171 $ thresh, tsterr, nmax, a, afac, ainv, b, x,
172 $ xact, work, rwork, iwork, nout )
181 INTEGER NMAX, NN, NNB, NNS, NOUT
182 DOUBLE PRECISION THRESH
186 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
187 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
188 $ rwork( * ), work( * ), x( * ), xact( * )
194 DOUBLE PRECISION ZERO, ONE
195 parameter( zero = 0.0d+0, one = 1.0d+0 )
196 DOUBLE PRECISION EIGHT, SEVTEN
197 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
199 parameter( ntypes = 10 )
201 parameter( ntests = 7 )
204 LOGICAL TRFCON, ZEROT
205 CHARACTER DIST,
TYPE, UPLO, XTYPE
206 CHARACTER*3 PATH, MATPATH
207 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
208 $ itemp, iuplo, izero, j, k, kl, ku, lda, lwork,
209 $ mode, n, nb, nerrs, nfail, nimat, nrhs, nrun,
211 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, LAM_MAX,
212 $ lam_min, rcond, rcondc
216 INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 )
217 DOUBLE PRECISION DDUMMY( 1 ), RESULT( ntests )
220 DOUBLE PRECISION DGET06, DLANGE, DLANSY
221 EXTERNAL dget06, dlange, dlansy
230 INTRINSIC abs, max, min, sqrt
238 COMMON / infoc / infot, nunit, ok, lerr
239 COMMON / srnamc / srnamt
242 DATA iseedy / 1988, 1989, 1990, 1991 /
243 DATA uplos /
'U',
'L' /
249 alpha = ( one+sqrt( sevten ) ) / eight
253 path( 1: 1 ) =
'Double precision'
258 matpath( 1: 1 ) =
'Double precision'
259 matpath( 2: 3 ) =
'SY'
265 iseed( i ) = iseedy( i )
271 $ CALL
derrsy( path, nout )
293 DO 260 imat = 1, nimat
297 IF( .NOT.dotype( imat ) )
302 zerot = imat.GE.3 .AND. imat.LE.6
303 IF( zerot .AND. n.LT.imat-2 )
309 uplo = uplos( iuplo )
316 CALL
dlatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
317 $ mode, cndnum, dist )
322 CALL
dlatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
323 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
329 CALL
alaerh( path,
'DLATMS', info, 0, uplo, n, n, -1,
330 $ -1, -1, imat, nfail, nerrs, nout )
344 ELSE IF( imat.EQ.4 )
THEN
354 IF( iuplo.EQ.1 )
THEN
355 ioff = ( izero-1 )*lda
356 DO 20 i = 1, izero - 1
366 DO 40 i = 1, izero - 1
376 IF( iuplo.EQ.1 )
THEN
423 CALL
dlacpy( uplo, n, n, a, lda, afac, lda )
430 lwork = max( 2, nb )*lda
431 srnamt =
'DSYTRF_ROOK'
441 IF( iwork( k ).LT.0 )
THEN
442 IF( iwork( k ).NE.-k )
THEN
446 ELSE IF( iwork( k ).NE.k )
THEN
455 $ CALL
alaerh( path,
'DSYTRF_ROOK', info, k,
456 $ uplo, n, n, -1, -1, nb, imat,
457 $ nfail, nerrs, nout )
470 CALL
dsyt01_rook( uplo, n, a, lda, afac, lda, iwork,
471 $ ainv, lda, rwork, result( 1 ) )
480 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
481 CALL
dlacpy( uplo, n, n, afac, lda, ainv, lda )
482 srnamt =
'DSYTRI_ROOK'
489 $ CALL
alaerh( path,
'DSYTRI_ROOK', info, -1,
490 $ uplo, n, n, -1, -1, -1, imat,
491 $ nfail, nerrs, nout )
496 CALL
dpot03( uplo, n, a, lda, ainv, lda, work, lda,
497 $ rwork, rcondc, result( 2 ) )
505 IF( result( k ).GE.thresh )
THEN
506 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
507 $ CALL
alahd( nout, path )
508 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
521 const = one / ( one-alpha )
523 IF( iuplo.EQ.1 )
THEN
532 IF( iwork( k ).GT.zero )
THEN
537 dtemp = dlange(
'M', k-1, 1,
538 $ afac( ( k-1 )*lda+1 ), lda, rwork )
544 dtemp = dlange(
'M', k-2, 2,
545 $ afac( ( k-2 )*lda+1 ), lda, rwork )
552 dtemp = dtemp - const + thresh
553 IF( dtemp.GT.result( 3 ) )
554 $ result( 3 ) = dtemp
570 IF( iwork( k ).GT.zero )
THEN
575 dtemp = dlange(
'M', n-k, 1,
576 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
582 dtemp = dlange(
'M', n-k-1, 2,
583 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
590 dtemp = dtemp - const + thresh
591 IF( dtemp.GT.result( 3 ) )
592 $ result( 3 ) = dtemp
607 const = ( one+alpha ) / ( one-alpha )
608 CALL
dlacpy( uplo, n, n, afac, lda, ainv, lda )
610 IF( iuplo.EQ.1 )
THEN
619 IF( iwork( k ).LT.zero )
THEN
624 CALL
dsyevx(
'N',
'A', uplo, 2,
625 $ ainv( ( k-2 )*lda+k-1 ), lda, dtemp,
626 $ dtemp, itemp, itemp, zero, itemp,
627 $ rwork, ddummy, 1, work, 16,
628 $ iwork( n+1 ), idummy, info )
630 lam_max = max( abs( rwork( 1 ) ),
631 $ abs( rwork( 2 ) ) )
632 lam_min = min( abs( rwork( 1 ) ),
633 $ abs( rwork( 2 ) ) )
635 dtemp = lam_max / lam_min
639 dtemp = abs( dtemp ) - const + thresh
640 IF( dtemp.GT.result( 4 ) )
641 $ result( 4 ) = dtemp
660 IF( iwork( k ).LT.zero )
THEN
665 CALL
dsyevx(
'N',
'A', uplo, 2,
666 $ ainv( ( k-1 )*lda+k ), lda, dtemp,
667 $ dtemp, itemp, itemp, zero, itemp,
668 $ rwork, ddummy, 1, work, 16,
669 $ iwork( n+1 ), idummy, info )
671 lam_max = max( abs( rwork( 1 ) ),
672 $ abs( rwork( 2 ) ) )
673 lam_min = min( abs( rwork( 1 ) ),
674 $ abs( rwork( 2 ) ) )
676 dtemp = lam_max / lam_min
680 dtemp = abs( dtemp ) - const + thresh
681 IF( dtemp.GT.result( 4 ) )
682 $ result( 4 ) = dtemp
697 IF( result( k ).GE.thresh )
THEN
698 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
699 $ CALL
alahd( nout, path )
700 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
732 CALL
dlarhs( matpath, xtype, uplo,
' ', n, n,
733 $ kl, ku, nrhs, a, lda, xact, lda,
734 $ b, lda, iseed, info )
735 CALL
dlacpy(
'Full', n, nrhs, b, lda, x, lda )
737 srnamt =
'DSYTRS_ROOK'
744 $ CALL
alaerh( path,
'DSYTRS_ROOK', info, 0,
745 $ uplo, n, n, -1, -1, nrhs, imat,
746 $ nfail, nerrs, nout )
748 CALL
dlacpy(
'Full', n, nrhs, b, lda, work, lda )
752 CALL
dpot02( uplo, n, nrhs, a, lda, x, lda, work,
753 $ lda, rwork, result( 5 ) )
758 CALL
dget04( n, nrhs, x, lda, xact, lda, rcondc,
765 IF( result( k ).GE.thresh )
THEN
766 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
767 $ CALL
alahd( nout, path )
768 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
769 $ imat, k, result( k )
783 anorm = dlansy(
'1', uplo, n, a, lda, rwork )
784 srnamt =
'DSYCON_ROOK'
785 CALL
dsycon_rook( uplo, n, afac, lda, iwork, anorm,
786 $ rcond, work, iwork( n+1 ), info )
791 $ CALL
alaerh( path,
'DSYCON_ROOK', info, 0,
792 $ uplo, n, n, -1, -1, -1, imat,
793 $ nfail, nerrs, nout )
797 result( 7 ) = dget06( rcond, rcondc )
802 IF( result( 7 ).GE.thresh )
THEN
803 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
804 $ CALL
alahd( nout, path )
805 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
818 CALL
alasum( path, nout, nfail, nrun, nerrs )
820 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
821 $ i2,
', test ', i2,
', ratio =', g12.5 )
822 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
823 $ i2,
', test(', i2,
') =', g12.5 )
824 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
825 $
', test(', i2,
') =', g12.5 )
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dsytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
DSYTRS_ROOK
subroutine dpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPOT02
subroutine derrsy(PATH, NUNIT)
DERRSY
subroutine dsytrf_rook(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
DSYTRF_ROOK
subroutine dsyevx(JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO)
DSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices ...
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 dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine dpot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
DPOT03
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine dsyt01_rook(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
DSYT01_ROOK
subroutine dsycon_rook(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
DSYCON_ROOK
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 dsytri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
DSYTRI_ROOK
subroutine dchksy_rook(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
DCHKSY_ROOK