176 SUBROUTINE zchksy_rk( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
177 $ thresh, tsterr, nmax, a, afac, e, ainv, b,
178 $ x, xact, work, rwork, iwork, nout )
187 INTEGER NMAX, NN, NNB, NNS, NOUT
188 DOUBLE PRECISION THRESH
192 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
193 DOUBLE PRECISION RWORK( * )
194 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
195 $ work( * ), x( * ), xact( * )
201 DOUBLE PRECISION ZERO, ONE
202 parameter ( zero = 0.0d+0, one = 1.0d+0 )
203 DOUBLE PRECISION ONEHALF
204 parameter ( onehalf = 0.5d+0 )
205 DOUBLE PRECISION EIGHT, SEVTEN
206 parameter ( eight = 8.0d+0, sevten = 17.0d+0 )
208 parameter ( czero = ( 0.0d+0, 0.0d+0 ) )
210 parameter ( ntypes = 11 )
212 parameter ( ntests = 7 )
215 LOGICAL TRFCON, ZEROT
216 CHARACTER DIST,
TYPE, UPLO, XTYPE
217 CHARACTER*3 PATH, MATPATH
218 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
219 $ itemp, itemp2, iuplo, izero, j, k, kl, ku, lda,
220 $ lwork, mode, n, nb, nerrs, nfail, nimat, nrhs,
222 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX,
223 $ sing_min, rcond, rcondc
227 INTEGER ISEED( 4 ), ISEEDY( 4 )
228 DOUBLE PRECISION RESULT( ntests )
229 COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
232 DOUBLE PRECISION DGET06, ZLANGE, ZLANSY
233 EXTERNAL dget06, zlange, zlansy
242 INTRINSIC max, min, sqrt
250 COMMON / infoc / infot, nunit, ok, lerr
251 COMMON / srnamc / srnamt
254 DATA iseedy / 1988, 1989, 1990, 1991 /
255 DATA uplos /
'U',
'L' /
261 alpha = ( one+sqrt( sevten ) ) / eight
265 path( 1: 1 ) =
'Zomplex precision'
270 matpath( 1: 1 ) =
'Zomplex precision'
271 matpath( 2: 3 ) =
'SY'
277 iseed( i ) = iseedy( i )
283 $
CALL zerrsy( path, nout )
305 DO 260 imat = 1, nimat
309 IF( .NOT.dotype( imat ) )
314 zerot = imat.GE.3 .AND. imat.LE.6
315 IF( zerot .AND. n.LT.imat-2 )
321 uplo = uplos( iuplo )
325 IF( imat.NE.ntypes )
THEN
330 CALL zlatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
331 $ mode, cndnum, dist )
336 CALL zlatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
337 $ cndnum, anorm, kl, ku, uplo, a, lda,
343 CALL alaerh( path,
'ZLATMS', info, 0, uplo, n, n,
344 $ -1, -1, -1, imat, nfail, nerrs, nout )
358 ELSE IF( imat.EQ.4 )
THEN
368 IF( iuplo.EQ.1 )
THEN
369 ioff = ( izero-1 )*lda
370 DO 20 i = 1, izero - 1
380 DO 40 i = 1, izero - 1
390 IF( iuplo.EQ.1 )
THEN
426 CALL zlatsy( uplo, n, a, lda, iseed )
447 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
454 lwork = max( 2, nb )*lda
456 CALL zsytrf_rk( uplo, n, afac, lda, e, iwork, ainv,
465 IF( iwork( k ).LT.0 )
THEN
466 IF( iwork( k ).NE.-k )
THEN
470 ELSE IF( iwork( k ).NE.k )
THEN
479 $
CALL alaerh( path,
'ZSYTRF_RK', info, k,
480 $ uplo, n, n, -1, -1, nb, imat,
481 $ nfail, nerrs, nout )
494 CALL zsyt01_3( uplo, n, a, lda, afac, lda, e, iwork,
495 $ ainv, lda, rwork, result( 1 ) )
504 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
505 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
512 lwork = (n+nb+1)*(nb+3)
513 CALL zsytri_3( uplo, n, ainv, lda, e, iwork, work,
519 $
CALL alaerh( path,
'ZSYTRI_3', info, -1,
520 $ uplo, n, n, -1, -1, -1, imat,
521 $ nfail, nerrs, nout )
526 CALL zsyt03( uplo, n, a, lda, ainv, lda, work, lda,
527 $ rwork, rcondc, result( 2 ) )
535 IF( result( k ).GE.thresh )
THEN
536 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
537 $
CALL alahd( nout, path )
538 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
551 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
554 IF( iuplo.EQ.1 )
THEN
563 IF( iwork( k ).GT.zero )
THEN
568 dtemp = zlange(
'M', k-1, 1,
569 $ afac( ( k-1 )*lda+1 ), lda, rwork )
575 dtemp = zlange(
'M', k-2, 2,
576 $ afac( ( k-2 )*lda+1 ), lda, rwork )
583 dtemp = dtemp - const + thresh
584 IF( dtemp.GT.result( 3 ) )
585 $ result( 3 ) = dtemp
601 IF( iwork( k ).GT.zero )
THEN
606 dtemp = zlange(
'M', n-k, 1,
607 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
613 dtemp = zlange(
'M', n-k-1, 2,
614 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
621 dtemp = dtemp - const + thresh
622 IF( dtemp.GT.result( 3 ) )
623 $ result( 3 ) = dtemp
639 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
640 $ ( ( one + alpha ) / ( one - alpha ) )
642 IF( iuplo.EQ.1 )
THEN
651 IF( iwork( k ).LT.zero )
THEN
657 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
658 block( 1, 2 ) = e( k )
659 block( 2, 1 ) = block( 1, 2 )
660 block( 2, 2 ) = afac( (k-1)*lda+k )
662 CALL zgesvd(
'N',
'N', 2, 2, block, 2, rwork,
663 $ zdummy, 1, zdummy, 1,
664 $ work, 6, rwork( 3 ), info )
667 sing_max = rwork( 1 )
668 sing_min = rwork( 2 )
670 dtemp = sing_max / sing_min
674 dtemp = dtemp - const + thresh
675 IF( dtemp.GT.result( 4 ) )
676 $ result( 4 ) = dtemp
695 IF( iwork( k ).LT.zero )
THEN
701 block( 1, 1 ) = afac( ( k-1 )*lda+k )
702 block( 2, 1 ) = e( k )
703 block( 1, 2 ) = block( 2, 1 )
704 block( 2, 2 ) = afac( k*lda+k+1 )
706 CALL zgesvd(
'N',
'N', 2, 2, block, 2, rwork,
707 $ zdummy, 1, zdummy, 1,
708 $ work, 6, rwork(3), info )
710 sing_max = rwork( 1 )
711 sing_min = rwork( 2 )
713 dtemp = sing_max / sing_min
717 dtemp = dtemp - const + thresh
718 IF( dtemp.GT.result( 4 ) )
719 $ result( 4 ) = dtemp
734 IF( result( k ).GE.thresh )
THEN
735 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
736 $
CALL alahd( nout, path )
737 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
769 CALL zlarhs( matpath, xtype, uplo,
' ', n, n,
770 $ kl, ku, nrhs, a, lda, xact, lda,
771 $ b, lda, iseed, info )
772 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
775 CALL zsytrs_3( uplo, n, nrhs, afac, lda, e, iwork,
781 $
CALL alaerh( path,
'ZSYTRS_3', info, 0,
782 $ uplo, n, n, -1, -1, nrhs, imat,
783 $ nfail, nerrs, nout )
785 CALL zlacpy(
'Full', n, nrhs, b, lda, work, lda )
789 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
790 $ lda, rwork, result( 5 ) )
795 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
802 IF( result( k ).GE.thresh )
THEN
803 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
804 $
CALL alahd( nout, path )
805 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
806 $ imat, k, result( k )
820 anorm = zlansy(
'1', uplo, n, a, lda, rwork )
822 CALL zsycon_3( uplo, n, afac, lda, e, iwork, anorm,
823 $ rcond, work, info )
828 $
CALL alaerh( path,
'ZSYCON_3', info, 0,
829 $ uplo, n, n, -1, -1, -1, imat,
830 $ nfail, nerrs, nout )
834 result( 7 ) = dget06( rcond, rcondc )
839 IF( result( 7 ).GE.thresh )
THEN
840 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
841 $
CALL alahd( nout, path )
842 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
855 CALL alasum( path, nout, nfail, nrun, nerrs )
857 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
858 $ i2,
', test ', i2,
', ratio =', g12.5 )
859 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
860 $ i2,
', test(', i2,
') =', g12.5 )
861 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
862 $
', 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 zerrsy(PATH, NUNIT)
ZERRSY
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
subroutine zsytri_3(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
ZSYTRI_3
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zsytrs_3(UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO)
ZSYTRS_3
subroutine zsyt01_3(UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, LDC, RWORK, RESID)
ZSYT01_3
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine zlatsy(UPLO, N, X, LDX, ISEED)
ZLATSY
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
subroutine zsyt03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
ZSYT03
subroutine zsytrf_rk(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
ZSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch...
subroutine zgesvd(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO)
ZGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine zsyt02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
ZSYT02
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zsycon_3(UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, WORK, INFO)
ZSYCON_3
subroutine zchksy_rk(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
ZCHKSY_RK
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM