181 INTEGER nmax, nn, nnb, nns, nout
186 INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
187 REAL a( * ), afac( * ), ainv( * ), b( * ),
188 $ rwork( * ), work( * ), x( * ), xact( * )
195 parameter( zero = 0.0d+0, one = 1.0d+0 )
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 REAL alpha, anorm, cndnum, const, lam_max, lam_min,
212 $ rcond, rcondc, stemp
216 INTEGER idummy( 1 ), iseed( 4 ), iseedy( 4 )
217 REAL result( ntests ), sdummy( 1 )
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 ) =
'Single precision'
258 matpath( 1: 1 ) =
'Single precision'
259 matpath( 2: 3 ) =
'SY'
265 iseed( i ) = iseedy( i )
271 $
CALL serrsy( 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 slatb4( matpath, imat, n, n,
TYPE, kl, ku, anorm,
317 $ mode, cndnum, dist )
322 CALL slatms( n, n, dist, iseed,
TYPE, rwork, mode,
323 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
329 CALL alaerh( path,
'SLATMS', 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 slacpy( uplo, n, n, a, lda, afac, lda )
430 lwork = max( 2, nb )*lda
431 srnamt =
'SSYTRF_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,
'SSYTRF_ROOK', info, k,
456 $ uplo, n, n, -1, -1, nb, imat,
457 $ nfail, nerrs, nout )
470 CALL ssyt01_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 slacpy( uplo, n, n, afac, lda, ainv, lda )
482 srnamt =
'SSYTRI_ROOK'
489 $
CALL alaerh( path,
'SSYTRI_ROOK', info, -1,
490 $ uplo, n, n, -1, -1, -1, imat,
491 $ nfail, nerrs, nout )
496 CALL spot03( 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 stemp =
slange(
'M', k-1, 1,
538 $ afac( ( k-1 )*lda+1 ), lda, rwork )
544 stemp =
slange(
'M', k-2, 2,
545 $ afac( ( k-2 )*lda+1 ), lda, rwork )
552 stemp = stemp - const + thresh
553 IF( stemp.GT.result( 3 ) )
554 $ result( 3 ) = stemp
570 IF( iwork( k ).GT.zero )
THEN
575 stemp =
slange(
'M', n-k, 1,
576 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
582 stemp =
slange(
'M', n-k-1, 2,
583 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
590 stemp = stemp - const + thresh
591 IF( stemp.GT.result( 3 ) )
592 $ result( 3 ) = stemp
607 const = ( one+alpha ) / ( one-alpha )
608 CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
610 IF( iuplo.EQ.1 )
THEN
619 IF( iwork( k ).LT.zero )
THEN
624 CALL ssyevx(
'N',
'A', uplo, 2,
625 $ ainv( ( k-2 )*lda+k-1 ), lda, stemp,
626 $ stemp, itemp, itemp, zero, itemp,
627 $ rwork, sdummy, 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 stemp = lam_max / lam_min
639 stemp = abs( stemp ) - const + thresh
640 IF( stemp.GT.result( 4 ) )
641 $ result( 4 ) = stemp
660 IF( iwork( k ).LT.zero )
THEN
665 CALL ssyevx(
'N',
'A', uplo, 2,
666 $ ainv( ( k-1 )*lda+k ), lda, stemp,
667 $ stemp, itemp, itemp, zero, itemp,
668 $ rwork, sdummy, 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 stemp = lam_max / lam_min
680 stemp = abs( stemp ) - const + thresh
681 IF( stemp.GT.result( 4 ) )
682 $ result( 4 ) = stemp
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 slarhs( matpath, xtype, uplo,
' ', n, n,
733 $ kl, ku, nrhs, a, lda, xact, lda,
734 $ b, lda, iseed, info )
735 CALL slacpy(
'Full', n, nrhs, b, lda, x, lda )
737 srnamt =
'SSYTRS_ROOK'
744 $
CALL alaerh( path,
'SSYTRS_ROOK', info, 0,
745 $ uplo, n, n, -1, -1, nrhs, imat,
746 $ nfail, nerrs, nout )
748 CALL slacpy(
'Full', n, nrhs, b, lda, work, lda )
752 CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
753 $ lda, rwork, result( 5 ) )
758 CALL sget04( 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 =
slansy(
'1', uplo, n, a, lda, rwork )
784 srnamt =
'SSYCON_ROOK'
785 CALL ssycon_rook( uplo, n, afac, lda, iwork, anorm,
786 $ rcond, work, iwork( n+1 ), info )
791 $
CALL alaerh( path,
'SSYCON_ROOK', info, 0,
792 $ uplo, n, n, -1, -1, -1, imat,
793 $ nfail, nerrs, nout )
797 result( 7 ) =
sget06( 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 ssytrf_rook(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
SSYTRF_ROOK
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine ssytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
SSYTRS_ROOK
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine ssycon_rook(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
SSYCON_ROOK
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine spot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPOT02
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
real function sget06(RCOND, RCONDC)
SGET06
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
subroutine ssyevx(JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO)
SSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices ...
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine serrsy(PATH, NUNIT)
SERRSY
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine spot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
SPOT03
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine ssyt01_rook(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
SSYT01_ROOK
real function slansy(NORM, UPLO, N, A, LDA, WORK)
SLANSY 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 ssytri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
SSYTRI_ROOK
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4