171 SUBROUTINE zchkhe_rook( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
172 $ thresh, tsterr, nmax, a, afac, ainv, b, x,
173 $ xact, work, rwork, iwork, nout )
182 INTEGER NMAX, NN, NNB, NNS, NOUT
183 DOUBLE PRECISION THRESH
187 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
188 DOUBLE PRECISION RWORK( * )
189 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
190 $ work( * ), x( * ), xact( * )
196 DOUBLE PRECISION ZERO, ONE
197 parameter ( zero = 0.0d+0, one = 1.0d+0 )
198 DOUBLE PRECISION ONEHALF
199 parameter ( onehalf = 0.5d+0 )
200 DOUBLE PRECISION EIGHT, SEVTEN
201 parameter ( eight = 8.0d+0, sevten = 17.0d+0 )
203 parameter ( czero = ( 0.0d+0, 0.0d+0 ) )
205 parameter ( ntypes = 10 )
207 parameter ( ntests = 7 )
210 LOGICAL TRFCON, ZEROT
211 CHARACTER DIST,
TYPE, UPLO, XTYPE
212 CHARACTER*3 PATH, MATPATH
213 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
214 $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
215 $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
216 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
217 $ sing_min, rcond, rcondc, dtemp
221 INTEGER ISEED( 4 ), ISEEDY( 4 )
222 DOUBLE PRECISION RESULT( ntests )
223 COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
226 DOUBLE PRECISION ZLANGE, ZLANHE, DGET06
227 EXTERNAL zlange, zlanhe, dget06
236 INTRINSIC conjg, max, min, sqrt
244 COMMON / infoc / infot, nunit, ok, lerr
245 COMMON / srnamc / srnamt
248 DATA iseedy / 1988, 1989, 1990, 1991 /
249 DATA uplos /
'U',
'L' /
255 alpha = ( one+sqrt( sevten ) ) / eight
259 path( 1: 1 ) =
'Zomplex precision'
264 matpath( 1: 1 ) =
'Zomplex precision'
265 matpath( 2: 3 ) =
'HE'
271 iseed( i ) = iseedy( i )
277 $
CALL zerrhe( path, nout )
299 DO 260 imat = 1, nimat
303 IF( .NOT.dotype( imat ) )
308 zerot = imat.GE.3 .AND. imat.LE.6
309 IF( zerot .AND. n.LT.imat-2 )
315 uplo = uplos( iuplo )
322 CALL zlatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
323 $ mode, cndnum, dist )
328 CALL zlatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
329 $ cndnum, anorm, kl, ku, uplo, a, lda,
335 CALL alaerh( path,
'ZLATMS', info, 0, uplo, n, n,
336 $ -1, -1, -1, imat, nfail, nerrs, nout )
350 ELSE IF( imat.EQ.4 )
THEN
360 IF( iuplo.EQ.1 )
THEN
361 ioff = ( izero-1 )*lda
362 DO 20 i = 1, izero - 1
372 DO 40 i = 1, izero - 1
382 IF( iuplo.EQ.1 )
THEN
429 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
436 lwork = max( 2, nb )*lda
437 srnamt =
'ZHETRF_ROOK'
447 IF( iwork( k ).LT.0 )
THEN
448 IF( iwork( k ).NE.-k )
THEN
452 ELSE IF( iwork( k ).NE.k )
THEN
461 $
CALL alaerh( path,
'ZHETRF_ROOK', info, k,
462 $ uplo, n, n, -1, -1, nb, imat,
463 $ nfail, nerrs, nout )
476 CALL zhet01_rook( uplo, n, a, lda, afac, lda, iwork,
477 $ ainv, lda, rwork, result( 1 ) )
486 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
487 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
488 srnamt =
'ZHETRI_ROOK'
495 $
CALL alaerh( path,
'ZHETRI_ROOK', info, -1,
496 $ uplo, n, n, -1, -1, -1, imat,
497 $ nfail, nerrs, nout )
502 CALL zpot03( uplo, n, a, lda, ainv, lda, work, lda,
503 $ rwork, rcondc, result( 2 ) )
511 IF( result( k ).GE.thresh )
THEN
512 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
513 $
CALL alahd( nout, path )
514 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
527 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
530 IF( iuplo.EQ.1 )
THEN
539 IF( iwork( k ).GT.zero )
THEN
544 dtemp = zlange(
'M', k-1, 1,
545 $ afac( ( k-1 )*lda+1 ), lda, rwork )
551 dtemp = zlange(
'M', k-2, 2,
552 $ afac( ( k-2 )*lda+1 ), lda, rwork )
559 dtemp = dtemp - const + thresh
560 IF( dtemp.GT.result( 3 ) )
561 $ result( 3 ) = dtemp
577 IF( iwork( k ).GT.zero )
THEN
582 dtemp = zlange(
'M', n-k, 1,
583 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
589 dtemp = zlange(
'M', n-k-1, 2,
590 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
597 dtemp = dtemp - const + thresh
598 IF( dtemp.GT.result( 3 ) )
599 $ result( 3 ) = dtemp
615 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
616 $ ( ( one + alpha ) / ( one - alpha ) )
617 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
619 IF( iuplo.EQ.1 )
THEN
628 IF( iwork( k ).LT.zero )
THEN
634 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
635 block( 1, 2 ) = afac( (k-1)*lda+k-1 )
636 block( 2, 1 ) = conjg( block( 1, 2 ) )
637 block( 2, 2 ) = afac( (k-1)*lda+k )
639 CALL zgesvd(
'N',
'N', 2, 2, block, 2, rwork,
640 $ zdummy, 1, zdummy, 1,
641 $ work, 6, rwork( 3 ), info )
644 sing_max = rwork( 1 )
645 sing_min = rwork( 2 )
647 dtemp = sing_max / sing_min
651 dtemp = dtemp - const + thresh
652 IF( dtemp.GT.result( 4 ) )
653 $ result( 4 ) = dtemp
672 IF( iwork( k ).LT.zero )
THEN
678 block( 1, 1 ) = afac( ( k-1 )*lda+k )
679 block( 2, 1 ) = afac( ( k-1 )*lda+k+1 )
680 block( 1, 2 ) = conjg( block( 2, 1 ) )
681 block( 2, 2 ) = afac( k*lda+k+1 )
683 CALL zgesvd(
'N',
'N', 2, 2, block, 2, rwork,
684 $ zdummy, 1, zdummy, 1,
685 $ work, 6, rwork(3), info )
687 sing_max = rwork( 1 )
688 sing_min = rwork( 2 )
690 dtemp = sing_max / sing_min
694 dtemp = dtemp - const + thresh
695 IF( dtemp.GT.result( 4 ) )
696 $ result( 4 ) = dtemp
711 IF( result( k ).GE.thresh )
THEN
712 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
713 $
CALL alahd( nout, path )
714 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
749 CALL zlarhs( matpath, xtype, uplo,
' ', n, n,
750 $ kl, ku, nrhs, a, lda, xact, lda,
751 $ b, lda, iseed, info )
752 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
754 srnamt =
'ZHETRS_ROOK'
761 $
CALL alaerh( path,
'ZHETRS_ROOK', info, 0,
762 $ uplo, n, n, -1, -1, nrhs, imat,
763 $ nfail, nerrs, nout )
765 CALL zlacpy(
'Full', n, nrhs, b, lda, work, lda )
769 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
770 $ lda, rwork, result( 5 ) )
775 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
782 IF( result( k ).GE.thresh )
THEN
783 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
784 $
CALL alahd( nout, path )
785 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
786 $ imat, k, result( k )
800 anorm = zlanhe(
'1', uplo, n, a, lda, rwork )
801 srnamt =
'ZHECON_ROOK'
802 CALL zhecon_rook( uplo, n, afac, lda, iwork, anorm,
803 $ rcond, work, info )
808 $
CALL alaerh( path,
'ZHECON_ROOK', info, 0,
809 $ uplo, n, n, -1, -1, -1, imat,
810 $ nfail, nerrs, nout )
814 result( 7 ) = dget06( rcond, rcondc )
819 IF( result( 7 ).GE.thresh )
THEN
820 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
821 $
CALL alahd( nout, path )
822 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
835 CALL alasum( path, nout, nfail, nrun, nerrs )
837 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
838 $ i2,
', test ', i2,
', ratio =', g12.5 )
839 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
840 $ i2,
', test ', i2,
', ratio =', g12.5 )
841 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
842 $
', test ', i2,
', ratio =', g12.5 )
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine zhet01_rook(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
ZHET01_ROOK
subroutine zchkhe_rook(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
ZCHKHE_ROOK
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
subroutine zerrhe(PATH, NUNIT)
ZERRHE
subroutine zpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
ZPOT02
subroutine zhecon_rook(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO)
ZHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization ob...
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 xlaenv(ISPEC, NVALUE)
XLAENV
subroutine zpot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
ZPOT03
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
subroutine zhetrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using fac...
subroutine zhetrf_rook(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
ZHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bun...
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 zhetri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
ZHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch...
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM