186 INTEGER nmax, nn, nnb, nns, nout
187 DOUBLE PRECISION thresh
191 INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
192 DOUBLE PRECISION a( * ), afac( * ), ainv( * ), b( * ), e( * ),
193 $ rwork( * ), work( * ), x( * ), xact( * )
199 DOUBLE PRECISION zero, one
200 parameter ( zero = 0.0d+0, one = 1.0d+0 )
201 DOUBLE PRECISION eight, sevten
202 parameter ( eight = 8.0d+0, sevten = 17.0d+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 DOUBLE PRECISION alpha, anorm, cndnum, const, dtemp, sing_max,
217 $ sing_min, rcond, rcondc
221 INTEGER idummy( 1 ), iseed( 4 ), iseedy( 4 )
222 DOUBLE PRECISION block( 2, 2 ), ddummy( 1 ), result( ntests )
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 ) =
'Double precision'
263 matpath( 1: 1 ) =
'Double precision'
264 matpath( 2: 3 ) =
'SY'
270 iseed( i ) = iseedy( i )
276 $
CALL derrsy( 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 dlatb4( matpath, imat, n, n,
TYPE, kl, ku, anorm,
322 $ mode, cndnum, dist )
327 CALL dlatms( n, n, dist, iseed,
TYPE, rwork, mode,
328 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
334 CALL alaerh( path,
'DLATMS', 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 dlacpy( uplo, n, n, a, lda, afac, lda )
435 lwork = max( 2, nb )*lda
437 CALL dsytrf_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,
'DSYTRF_RK', info, k,
461 $ uplo, n, n, -1, -1, nb, imat,
462 $ nfail, nerrs, nout )
475 CALL dsyt01_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 dlacpy( uplo, n, n, afac, lda, ainv, lda )
493 lwork = (n+nb+1)*(nb+3)
494 CALL dsytri_3( uplo, n, ainv, lda, e, iwork, work,
500 $
CALL alaerh( path,
'DSYTRI_3', info, -1,
501 $ uplo, n, n, -1, -1, -1, imat,
502 $ nfail, nerrs, nout )
507 CALL dpot03( 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 dtemp =
dlange(
'M', k-1, 1,
549 $ afac( ( k-1 )*lda+1 ), lda, rwork )
555 dtemp =
dlange(
'M', k-2, 2,
556 $ afac( ( k-2 )*lda+1 ), lda, rwork )
563 dtemp = dtemp - const + thresh
564 IF( dtemp.GT.result( 3 ) )
565 $ result( 3 ) = dtemp
581 IF( iwork( k ).GT.zero )
THEN
586 dtemp =
dlange(
'M', n-k, 1,
587 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
593 dtemp =
dlange(
'M', n-k-1, 2,
594 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
601 dtemp = dtemp - const + thresh
602 IF( dtemp.GT.result( 3 ) )
603 $ result( 3 ) = dtemp
618 const = ( one+alpha ) / ( one-alpha )
619 CALL dlacpy( 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 dgesvd(
'N',
'N', 2, 2, block, 2, rwork,
642 $ ddummy, 1, ddummy, 1,
645 sing_max = rwork( 1 )
646 sing_min = rwork( 2 )
648 dtemp = sing_max / sing_min
652 dtemp = dtemp - const + thresh
653 IF( dtemp.GT.result( 4 ) )
654 $ result( 4 ) = dtemp
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 dgesvd(
'N',
'N', 2, 2, block, 2, rwork,
685 $ ddummy, 1, ddummy, 1,
689 sing_max = rwork( 1 )
690 sing_min = rwork( 2 )
692 dtemp = sing_max / sing_min
696 dtemp = dtemp - const + thresh
697 IF( dtemp.GT.result( 4 ) )
698 $ result( 4 ) = dtemp
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 dlarhs( matpath, xtype, uplo,
' ', n, n,
749 $ kl, ku, nrhs, a, lda, xact, lda,
750 $ b, lda, iseed, info )
751 CALL dlacpy(
'Full', n, nrhs, b, lda, x, lda )
754 CALL dsytrs_3( uplo, n, nrhs, afac, lda, e, iwork,
760 $
CALL alaerh( path,
'DSYTRS_3', info, 0,
761 $ uplo, n, n, -1, -1, nrhs, imat,
762 $ nfail, nerrs, nout )
764 CALL dlacpy(
'Full', n, nrhs, b, lda, work, lda )
768 CALL dpot02( uplo, n, nrhs, a, lda, x, lda, work,
769 $ lda, rwork, result( 5 ) )
774 CALL dget04( 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 =
dlansy(
'1', uplo, n, a, lda, rwork )
801 CALL dsycon_3( uplo, n, afac, lda, e, iwork, anorm,
802 $ rcond, work, iwork( n+1 ), info )
807 $
CALL alaerh( path,
'DSYCON_3', info, 0,
808 $ uplo, n, n, -1, -1, -1, imat,
809 $ nfail, nerrs, nout )
813 result( 7 ) =
dget06( 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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine alahd(IOUNIT, PATH)
ALAHD
double precision function dlansy(NORM, UPLO, N, A, LDA, WORK)
DLANSY 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 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 dsycon_3(UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
DSYCON_3
subroutine dsytri_3(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
DSYTRI_3
subroutine dsyt01_3(UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, LDC, RWORK, RESID)
DSYT01_3
subroutine dsytrf_rk(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
DSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Ka...
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine dpot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
DPOT03
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
subroutine derrsy(PATH, NUNIT)
DERRSY
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine dsytrs_3(UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO)
DSYTRS_3
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dgesvd(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO)
DGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine dpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPOT02
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM