176 SUBROUTINE cchkhe_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
192 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
194 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
195 $ work( * ), x( * ), xact( * )
202 parameter ( zero = 0.0e+0, one = 1.0e+0 )
204 parameter ( onehalf = 0.5e+0 )
206 parameter ( eight = 8.0e+0, sevten = 17.0e+0 )
208 parameter ( czero = ( 0.0e+0, 0.0e+0 ) )
210 parameter ( ntypes = 10 )
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 REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
223 $ sing_min, rcond, rcondc, stemp
227 INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 )
228 REAL RESULT( ntests )
229 COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
232 REAL CLANGE, CLANHE, SGET06
233 EXTERNAL clange, clanhe, sget06
242 INTRINSIC conjg, 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 ) =
'Complex precision'
270 matpath( 1: 1 ) =
'Complex precision'
271 matpath( 2: 3 ) =
'HE'
277 iseed( i ) = iseedy( i )
283 $
CALL cerrhe( 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 )
328 CALL clatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
329 $ mode, cndnum, dist )
334 CALL clatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
335 $ cndnum, anorm, kl, ku, uplo, a, lda,
341 CALL alaerh( path,
'CLATMS', info, 0, uplo, n, n,
342 $ -1, -1, -1, imat, nfail, nerrs, nout )
356 ELSE IF( imat.EQ.4 )
THEN
366 IF( iuplo.EQ.1 )
THEN
367 ioff = ( izero-1 )*lda
368 DO 20 i = 1, izero - 1
378 DO 40 i = 1, izero - 1
388 IF( iuplo.EQ.1 )
THEN
435 CALL clacpy( uplo, n, n, a, lda, afac, lda )
442 lwork = max( 2, nb )*lda
444 CALL chetrf_rk( uplo, n, afac, lda, e, iwork, ainv,
453 IF( iwork( k ).LT.0 )
THEN
454 IF( iwork( k ).NE.-k )
THEN
458 ELSE IF( iwork( k ).NE.k )
THEN
467 $
CALL alaerh( path,
'CHETRF_RK', info, k,
468 $ uplo, n, n, -1, -1, nb, imat,
469 $ nfail, nerrs, nout )
482 CALL chet01_3( uplo, n, a, lda, afac, lda, e, iwork,
483 $ ainv, lda, rwork, result( 1 ) )
492 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
493 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
500 lwork = (n+nb+1)*(nb+3)
501 CALL chetri_3( uplo, n, ainv, lda, e, iwork, work,
507 $
CALL alaerh( path,
'CHETRI_3', info, -1,
508 $ uplo, n, n, -1, -1, -1, imat,
509 $ nfail, nerrs, nout )
514 CALL cpot03( uplo, n, a, lda, ainv, lda, work, lda,
515 $ rwork, rcondc, result( 2 ) )
523 IF( result( k ).GE.thresh )
THEN
524 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
525 $
CALL alahd( nout, path )
526 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
539 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
542 IF( iuplo.EQ.1 )
THEN
551 IF( iwork( k ).GT.zero )
THEN
556 stemp = clange(
'M', k-1, 1,
557 $ afac( ( k-1 )*lda+1 ), lda, rwork )
563 stemp = clange(
'M', k-2, 2,
564 $ afac( ( k-2 )*lda+1 ), lda, rwork )
571 stemp = stemp - const + thresh
572 IF( stemp.GT.result( 3 ) )
573 $ result( 3 ) = stemp
589 IF( iwork( k ).GT.zero )
THEN
594 stemp = clange(
'M', n-k, 1,
595 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
601 stemp = clange(
'M', n-k-1, 2,
602 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
609 stemp = stemp - const + thresh
610 IF( stemp.GT.result( 3 ) )
611 $ result( 3 ) = stemp
627 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
628 $ ( ( one + alpha ) / ( one - alpha ) )
629 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
631 IF( iuplo.EQ.1 )
THEN
640 IF( iwork( k ).LT.zero )
THEN
646 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
647 block( 1, 2 ) = e( k )
648 block( 2, 1 ) = conjg( block( 1, 2 ) )
649 block( 2, 2 ) = afac( (k-1)*lda+k )
651 CALL cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
652 $ cdummy, 1, cdummy, 1,
653 $ work, 6, rwork( 3 ), info )
656 sing_max = rwork( 1 )
657 sing_min = rwork( 2 )
659 stemp = sing_max / sing_min
663 stemp = stemp - const + thresh
664 IF( stemp.GT.result( 4 ) )
665 $ result( 4 ) = stemp
684 IF( iwork( k ).LT.zero )
THEN
690 block( 1, 1 ) = afac( ( k-1 )*lda+k )
691 block( 2, 1 ) = e( k )
692 block( 1, 2 ) = conjg( block( 2, 1 ) )
693 block( 2, 2 ) = afac( k*lda+k+1 )
695 CALL cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
696 $ cdummy, 1, cdummy, 1,
697 $ work, 6, rwork(3), info )
699 sing_max = rwork( 1 )
700 sing_min = rwork( 2 )
702 stemp = sing_max / sing_min
706 stemp = stemp - const + thresh
707 IF( stemp.GT.result( 4 ) )
708 $ result( 4 ) = stemp
723 IF( result( k ).GE.thresh )
THEN
724 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
725 $
CALL alahd( nout, path )
726 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
761 CALL clarhs( matpath, xtype, uplo,
' ', n, n,
762 $ kl, ku, nrhs, a, lda, xact, lda,
763 $ b, lda, iseed, info )
764 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
767 CALL chetrs_3( uplo, n, nrhs, afac, lda, e, iwork,
773 $
CALL alaerh( path,
'CHETRS_3', info, 0,
774 $ uplo, n, n, -1, -1, nrhs, imat,
775 $ nfail, nerrs, nout )
777 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
781 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
782 $ lda, rwork, result( 5 ) )
787 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
794 IF( result( k ).GE.thresh )
THEN
795 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
796 $
CALL alahd( nout, path )
797 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
798 $ imat, k, result( k )
812 anorm = clanhe(
'1', uplo, n, a, lda, rwork )
814 CALL checon_3( uplo, n, afac, lda, e, iwork, anorm,
815 $ rcond, work, info )
820 $
CALL alaerh( path,
'CHECON_3', info, 0,
821 $ uplo, n, n, -1, -1, -1, imat,
822 $ nfail, nerrs, nout )
826 result( 7 ) = sget06( rcond, rcondc )
831 IF( result( 7 ).GE.thresh )
THEN
832 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
833 $
CALL alahd( nout, path )
834 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
847 CALL alasum( path, nout, nfail, nrun, nerrs )
849 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
850 $ i2,
', test ', i2,
', ratio =', g12.5 )
851 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
852 $ i2,
', test ', i2,
', ratio =', g12.5 )
853 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
854 $
', test ', i2,
', ratio =', 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 clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine cgesvd(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO)
CGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine checon_3(UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, WORK, INFO)
CHECON_3
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine cpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPOT02
subroutine cerrhe(PATH, NUNIT)
CERRHE
subroutine chetri_3(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
CHETRI_3
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine cchkhe_rk(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
CCHKHE_RK
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine chet01_3(UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, LDC, RWORK, RESID)
CHET01_3
subroutine chetrs_3(UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO)
CHETRS_3
subroutine cpot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
CPOT03
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
subroutine chetrf_rk(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
CHETRF_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch...
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM