170 SUBROUTINE schksy_rook( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
171 $ thresh, tsterr, nmax, a, afac, ainv, b, x,
172 $ xact, work, rwork, iwork, nout )
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 $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
209 $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
210 REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
211 $ sing_min, rcond, rcondc, stemp
215 INTEGER ISEED( 4 ), ISEEDY( 4 )
216 REAL BLOCK( 2, 2 ), RESULT( ntests ), SDUMMY( 1 )
219 REAL SGET06, SLANGE, SLANSY
220 EXTERNAL sget06, slange, slansy
229 INTRINSIC max, min, sqrt
237 COMMON / infoc / infot, nunit, ok, lerr
238 COMMON / srnamc / srnamt
241 DATA iseedy / 1988, 1989, 1990, 1991 /
242 DATA uplos /
'U',
'L' /
248 alpha = ( one+sqrt( sevten ) ) / eight
252 path( 1: 1 ) =
'Single precision'
257 matpath( 1: 1 ) =
'Single precision'
258 matpath( 2: 3 ) =
'SY'
264 iseed( i ) = iseedy( i )
270 $
CALL serrsy( path, nout )
292 DO 260 imat = 1, nimat
296 IF( .NOT.dotype( imat ) )
301 zerot = imat.GE.3 .AND. imat.LE.6
302 IF( zerot .AND. n.LT.imat-2 )
308 uplo = uplos( iuplo )
315 CALL slatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
316 $ mode, cndnum, dist )
321 CALL slatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
322 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
328 CALL alaerh( path,
'SLATMS', info, 0, uplo, n, n, -1,
329 $ -1, -1, imat, nfail, nerrs, nout )
343 ELSE IF( imat.EQ.4 )
THEN
353 IF( iuplo.EQ.1 )
THEN
354 ioff = ( izero-1 )*lda
355 DO 20 i = 1, izero - 1
365 DO 40 i = 1, izero - 1
375 IF( iuplo.EQ.1 )
THEN
422 CALL slacpy( uplo, n, n, a, lda, afac, lda )
429 lwork = max( 2, nb )*lda
430 srnamt =
'SSYTRF_ROOK'
440 IF( iwork( k ).LT.0 )
THEN
441 IF( iwork( k ).NE.-k )
THEN
445 ELSE IF( iwork( k ).NE.k )
THEN
454 $
CALL alaerh( path,
'SSYTRF_ROOK', info, k,
455 $ uplo, n, n, -1, -1, nb, imat,
456 $ nfail, nerrs, nout )
469 CALL ssyt01_rook( uplo, n, a, lda, afac, lda, iwork,
470 $ ainv, lda, rwork, result( 1 ) )
479 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
480 CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
481 srnamt =
'SSYTRI_ROOK'
488 $
CALL alaerh( path,
'SSYTRI_ROOK', info, -1,
489 $ uplo, n, n, -1, -1, -1, imat,
490 $ nfail, nerrs, nout )
495 CALL spot03( uplo, n, a, lda, ainv, lda, work, lda,
496 $ rwork, rcondc, result( 2 ) )
504 IF( result( k ).GE.thresh )
THEN
505 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
506 $
CALL alahd( nout, path )
507 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
520 const = one / ( one-alpha )
522 IF( iuplo.EQ.1 )
THEN
531 IF( iwork( k ).GT.zero )
THEN
536 stemp = slange(
'M', k-1, 1,
537 $ afac( ( k-1 )*lda+1 ), lda, rwork )
543 stemp = slange(
'M', k-2, 2,
544 $ afac( ( k-2 )*lda+1 ), lda, rwork )
551 stemp = stemp - const + thresh
552 IF( stemp.GT.result( 3 ) )
553 $ result( 3 ) = stemp
569 IF( iwork( k ).GT.zero )
THEN
574 stemp = slange(
'M', n-k, 1,
575 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
581 stemp = slange(
'M', n-k-1, 2,
582 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
589 stemp = stemp - const + thresh
590 IF( stemp.GT.result( 3 ) )
591 $ 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
625 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
626 block( 1, 2 ) = afac( (k-1)*lda+k-1 )
627 block( 2, 1 ) = block( 1, 2 )
628 block( 2, 2 ) = afac( (k-1)*lda+k )
630 CALL sgesvd(
'N',
'N', 2, 2, block, 2, rwork,
631 $ sdummy, 1, sdummy, 1,
635 sing_max = rwork( 1 )
636 sing_min = rwork( 2 )
638 stemp = sing_max / sing_min
642 stemp = stemp - const + thresh
643 IF( stemp.GT.result( 4 ) )
644 $ result( 4 ) = stemp
663 IF( iwork( k ).LT.zero )
THEN
669 block( 1, 1 ) = afac( ( k-1 )*lda+k )
670 block( 2, 1 ) = afac( ( k-1 )*lda+k+1 )
671 block( 1, 2 ) = block( 2, 1 )
672 block( 2, 2 ) = afac( k*lda+k+1 )
674 CALL sgesvd(
'N',
'N', 2, 2, block, 2, rwork,
675 $ sdummy, 1, sdummy, 1,
679 sing_max = rwork( 1 )
680 sing_min = rwork( 2 )
682 stemp = sing_max / sing_min
686 stemp = stemp - const + thresh
687 IF( stemp.GT.result( 4 ) )
688 $ result( 4 ) = stemp
703 IF( result( k ).GE.thresh )
THEN
704 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
705 $
CALL alahd( nout, path )
706 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
738 CALL slarhs( matpath, xtype, uplo,
' ', n, n,
739 $ kl, ku, nrhs, a, lda, xact, lda,
740 $ b, lda, iseed, info )
741 CALL slacpy(
'Full', n, nrhs, b, lda, x, lda )
743 srnamt =
'SSYTRS_ROOK'
750 $
CALL alaerh( path,
'SSYTRS_ROOK', info, 0,
751 $ uplo, n, n, -1, -1, nrhs, imat,
752 $ nfail, nerrs, nout )
754 CALL slacpy(
'Full', n, nrhs, b, lda, work, lda )
758 CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
759 $ lda, rwork, result( 5 ) )
764 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
771 IF( result( k ).GE.thresh )
THEN
772 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
773 $
CALL alahd( nout, path )
774 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
775 $ imat, k, result( k )
789 anorm = slansy(
'1', uplo, n, a, lda, rwork )
790 srnamt =
'SSYCON_ROOK'
791 CALL ssycon_rook( uplo, n, afac, lda, iwork, anorm,
792 $ rcond, work, iwork( n+1 ), info )
797 $
CALL alaerh( path,
'SSYCON_ROOK', info, 0,
798 $ uplo, n, n, -1, -1, -1, imat,
799 $ nfail, nerrs, nout )
803 result( 7 ) = sget06( rcond, rcondc )
808 IF( result( 7 ).GE.thresh )
THEN
809 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
810 $
CALL alahd( nout, path )
811 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
824 CALL alasum( path, nout, nfail, nrun, nerrs )
826 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
827 $ i2,
', test ', i2,
', ratio =', g12.5 )
828 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
829 $ i2,
', test(', i2,
') =', g12.5 )
830 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
831 $
', test(', i2,
') =', g12.5 )
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine ssytrf_rook(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
SSYTRF_ROOK
subroutine ssyt01_rook(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
SSYT01_ROOK
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
subroutine ssycon_rook(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
SSYCON_ROOK
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine ssytri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
SSYTRI_ROOK
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
subroutine spot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
SPOT03
subroutine ssytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
SSYTRS_ROOK
subroutine schksy_rook(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SCHKSY_ROOK
subroutine serrsy(PATH, NUNIT)
SERRSY
subroutine sgesvd(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO)
SGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine spot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPOT02
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM