175 SUBROUTINE schksy_rk( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
176 $ thresh, tsterr, nmax, a, afac, e, ainv, b,
177 $ x, xact, work, rwork, iwork, nout )
186 INTEGER NMAX, NN, NNB, NNS, NOUT
191 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
192 REAL A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
193 $ rwork( * ), work( * ), x( * ), xact( * )
200 parameter ( zero = 0.0e+0, one = 1.0e+0 )
202 parameter ( eight = 8.0e+0, sevten = 17.0e+0 )
204 parameter ( ntypes = 10 )
206 parameter ( ntests = 7 )
209 LOGICAL TRFCON, ZEROT
210 CHARACTER DIST,
TYPE, UPLO, XTYPE
211 CHARACTER*3 PATH, MATPATH
212 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
213 $ itemp, iuplo, izero, j, k, kl, ku, lda, lwork,
214 $ mode, n, nb, nerrs, nfail, nimat, nrhs, nrun,
216 REAL ALPHA, ANORM, CNDNUM, CONST, STEMP, SING_MAX,
217 $ sing_min, rcond, rcondc
221 INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 )
222 REAL BLOCK( 2, 2 ), SDUMMY( 1 ), RESULT( ntests )
225 REAL SGET06, SLANGE, SLANSY
226 EXTERNAL sget06, slange, slansy
235 INTRINSIC max, min, sqrt
243 COMMON / infoc / infot, nunit, ok, lerr
244 COMMON / srnamc / srnamt
247 DATA iseedy / 1988, 1989, 1990, 1991 /
248 DATA uplos /
'U',
'L' /
254 alpha = ( one+sqrt( sevten ) ) / eight
258 path( 1: 1 ) =
'Single precision'
263 matpath( 1: 1 ) =
'Single precision'
264 matpath( 2: 3 ) =
'SY'
270 iseed( i ) = iseedy( i )
276 $
CALL serrsy( path, nout )
298 DO 260 imat = 1, nimat
302 IF( .NOT.dotype( imat ) )
307 zerot = imat.GE.3 .AND. imat.LE.6
308 IF( zerot .AND. n.LT.imat-2 )
314 uplo = uplos( iuplo )
321 CALL slatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
322 $ mode, cndnum, dist )
327 CALL slatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
328 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
334 CALL alaerh( path,
'SLATMS', info, 0, uplo, n, n, -1,
335 $ -1, -1, imat, nfail, nerrs, nout )
349 ELSE IF( imat.EQ.4 )
THEN
359 IF( iuplo.EQ.1 )
THEN
360 ioff = ( izero-1 )*lda
361 DO 20 i = 1, izero - 1
371 DO 40 i = 1, izero - 1
381 IF( iuplo.EQ.1 )
THEN
428 CALL slacpy( uplo, n, n, a, lda, afac, lda )
435 lwork = max( 2, nb )*lda
437 CALL ssytrf_rk( uplo, n, afac, lda, e, iwork, ainv,
446 IF( iwork( k ).LT.0 )
THEN
447 IF( iwork( k ).NE.-k )
THEN
451 ELSE IF( iwork( k ).NE.k )
THEN
460 $
CALL alaerh( path,
'SSYTRF_RK', info, k,
461 $ uplo, n, n, -1, -1, nb, imat,
462 $ nfail, nerrs, nout )
475 CALL ssyt01_3( uplo, n, a, lda, afac, lda, e, iwork,
476 $ ainv, lda, rwork, result( 1 ) )
485 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
486 CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
493 lwork = (n+nb+1)*(nb+3)
494 CALL ssytri_3( uplo, n, ainv, lda, e, iwork, work,
500 $
CALL alaerh( path,
'SSYTRI_3', info, -1,
501 $ uplo, n, n, -1, -1, -1, imat,
502 $ nfail, nerrs, nout )
507 CALL spot03( uplo, n, a, lda, ainv, lda, work, lda,
508 $ rwork, rcondc, result( 2 ) )
516 IF( result( k ).GE.thresh )
THEN
517 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
518 $
CALL alahd( nout, path )
519 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
532 const = one / ( one-alpha )
534 IF( iuplo.EQ.1 )
THEN
543 IF( iwork( k ).GT.zero )
THEN
548 stemp = slange(
'M', k-1, 1,
549 $ afac( ( k-1 )*lda+1 ), lda, rwork )
555 stemp = slange(
'M', k-2, 2,
556 $ afac( ( k-2 )*lda+1 ), lda, rwork )
563 stemp = stemp - const + thresh
564 IF( stemp.GT.result( 3 ) )
565 $ result( 3 ) = stemp
581 IF( iwork( k ).GT.zero )
THEN
586 stemp = slange(
'M', n-k, 1,
587 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
593 stemp = slange(
'M', n-k-1, 2,
594 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
601 stemp = stemp - const + thresh
602 IF( stemp.GT.result( 3 ) )
603 $ result( 3 ) = stemp
618 const = ( one+alpha ) / ( one-alpha )
619 CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
621 IF( iuplo.EQ.1 )
THEN
630 IF( iwork( k ).LT.zero )
THEN
636 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
637 block( 1, 2 ) = e( k )
638 block( 2, 1 ) = block( 1, 2 )
639 block( 2, 2 ) = afac( (k-1)*lda+k )
641 CALL sgesvd(
'N',
'N', 2, 2, block, 2, rwork,
642 $ sdummy, 1, sdummy, 1,
645 sing_max = rwork( 1 )
646 sing_min = rwork( 2 )
648 stemp = sing_max / sing_min
652 stemp = stemp - const + thresh
653 IF( stemp.GT.result( 4 ) )
654 $ result( 4 ) = stemp
673 IF( iwork( k ).LT.zero )
THEN
679 block( 1, 1 ) = afac( ( k-1 )*lda+k )
680 block( 2, 1 ) = e( k )
681 block( 1, 2 ) = block( 2, 1 )
682 block( 2, 2 ) = afac( k*lda+k+1 )
684 CALL sgesvd(
'N',
'N', 2, 2, block, 2, rwork,
685 $ sdummy, 1, sdummy, 1,
689 sing_max = rwork( 1 )
690 sing_min = rwork( 2 )
692 stemp = sing_max / sing_min
696 stemp = stemp - const + thresh
697 IF( stemp.GT.result( 4 ) )
698 $ result( 4 ) = stemp
713 IF( result( k ).GE.thresh )
THEN
714 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
715 $
CALL alahd( nout, path )
716 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
748 CALL slarhs( matpath, xtype, uplo,
' ', n, n,
749 $ kl, ku, nrhs, a, lda, xact, lda,
750 $ b, lda, iseed, info )
751 CALL slacpy(
'Full', n, nrhs, b, lda, x, lda )
754 CALL ssytrs_3( uplo, n, nrhs, afac, lda, e, iwork,
760 $
CALL alaerh( path,
'SSYTRS_3', info, 0,
761 $ uplo, n, n, -1, -1, nrhs, imat,
762 $ nfail, nerrs, nout )
764 CALL slacpy(
'Full', n, nrhs, b, lda, work, lda )
768 CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
769 $ lda, rwork, result( 5 ) )
774 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
781 IF( result( k ).GE.thresh )
THEN
782 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
783 $
CALL alahd( nout, path )
784 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
785 $ imat, k, result( k )
799 anorm = slansy(
'1', uplo, n, a, lda, rwork )
801 CALL ssycon_3( uplo, n, afac, lda, e, iwork, anorm,
802 $ rcond, work, iwork( n+1 ), info )
807 $
CALL alaerh( path,
'SSYCON_3', info, 0,
808 $ uplo, n, n, -1, -1, -1, imat,
809 $ nfail, nerrs, nout )
813 result( 7 ) = sget06( rcond, rcondc )
818 IF( result( 7 ).GE.thresh )
THEN
819 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
820 $
CALL alahd( nout, path )
821 WRITE( nout, fmt = 9997 ) uplo, n, imat, 7,
834 CALL alasum( path, nout, nfail, nrun, nerrs )
836 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
837 $ i2,
', test ', i2,
', ratio =', g12.5 )
838 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
839 $ i2,
', test(', i2,
') =', g12.5 )
840 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
841 $
', 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_rk(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
SSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Ka...
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine ssytrs_3(UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO)
SSYTRS_3
subroutine ssytri_3(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
SSYTRI_3
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 schksy_rk(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
SCHKSY_RK
subroutine ssycon_3(UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
SSYCON_3
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 ssyt01_3(UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, LDC, RWORK, RESID)
SSYT01_3
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