182 INTEGER nmax, nn, nnb, nns, nout
187 INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
189 COMPLEX a( * ), afac( * ), ainv( * ), b( * ),
190 $ work( * ), x( * ), xact( * )
197 parameter ( zero = 0.0e+0, one = 1.0e+0 )
199 parameter ( onehalf = 0.5e+0 )
201 parameter ( eight = 8.0e+0, sevten = 17.0e+0 )
203 parameter ( czero = ( 0.0e+0, 0.0e+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 REAL alpha, anorm, cndnum, const, sing_max,
217 $ sing_min, rcond, rcondc, stemp
221 INTEGER iseed( 4 ), iseedy( 4 )
222 REAL result( ntests )
223 COMPLEX block( 2, 2 ), cdummy( 1 )
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 ) =
'Complex precision'
264 matpath( 1: 1 ) =
'Complex precision'
265 matpath( 2: 3 ) =
'HE'
271 iseed( i ) = iseedy( i )
277 $
CALL cerrhe( 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 clatb4( matpath, imat, n, n,
TYPE, kl, ku, anorm,
323 $ mode, cndnum, dist )
328 CALL clatms( n, n, dist, iseed,
TYPE, rwork, mode,
329 $ cndnum, anorm, kl, ku, uplo, a, lda,
335 CALL alaerh( path,
'CLATMS', 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 clacpy( uplo, n, n, a, lda, afac, lda )
436 lwork = max( 2, nb )*lda
437 srnamt =
'CHETRF_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,
'CHETRF_ROOK', info, k,
462 $ uplo, n, n, -1, -1, nb, imat,
463 $ nfail, nerrs, nout )
476 CALL chet01_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 clacpy( uplo, n, n, afac, lda, ainv, lda )
488 srnamt =
'CHETRI_ROOK'
495 $
CALL alaerh( path,
'CHETRI_ROOK', info, -1,
496 $ uplo, n, n, -1, -1, -1, imat,
497 $ nfail, nerrs, nout )
502 CALL cpot03( 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 stemp =
clange(
'M', k-1, 1,
545 $ afac( ( k-1 )*lda+1 ), lda, rwork )
551 stemp =
clange(
'M', k-2, 2,
552 $ afac( ( k-2 )*lda+1 ), lda, rwork )
559 stemp = stemp - const + thresh
560 IF( stemp.GT.result( 3 ) )
561 $ result( 3 ) = stemp
577 IF( iwork( k ).GT.zero )
THEN
582 stemp =
clange(
'M', n-k, 1,
583 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
589 stemp =
clange(
'M', n-k-1, 2,
590 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
597 stemp = stemp - const + thresh
598 IF( stemp.GT.result( 3 ) )
599 $ result( 3 ) = stemp
615 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
616 $ ( ( one + alpha ) / ( one - alpha ) )
617 CALL clacpy( 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 cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
640 $ cdummy, 1, cdummy, 1,
641 $ work, 6, rwork( 3 ), info )
644 sing_max = rwork( 1 )
645 sing_min = rwork( 2 )
647 stemp = sing_max / sing_min
651 stemp = stemp - const + thresh
652 IF( stemp.GT.result( 4 ) )
653 $ result( 4 ) = stemp
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 cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
684 $ cdummy, 1, cdummy, 1,
685 $ work, 6, rwork(3), info )
687 sing_max = rwork( 1 )
688 sing_min = rwork( 2 )
690 stemp = sing_max / sing_min
694 stemp = stemp - const + thresh
695 IF( stemp.GT.result( 4 ) )
696 $ result( 4 ) = stemp
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 clarhs( matpath, xtype, uplo,
' ', n, n,
750 $ kl, ku, nrhs, a, lda, xact, lda,
751 $ b, lda, iseed, info )
752 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
754 srnamt =
'CHETRS_ROOK'
761 $
CALL alaerh( path,
'CHETRS_ROOK', info, 0,
762 $ uplo, n, n, -1, -1, nrhs, imat,
763 $ nfail, nerrs, nout )
765 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
769 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
770 $ lda, rwork, result( 5 ) )
775 CALL cget04( 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 =
clanhe(
'1', uplo, n, a, lda, rwork )
801 srnamt =
'CHECON_ROOK'
802 CALL checon_rook( uplo, n, afac, lda, iwork, anorm,
803 $ rcond, work, info )
808 $
CALL alaerh( path,
'CHECON_ROOK', info, 0,
809 $ uplo, n, n, -1, -1, -1, imat,
810 $ nfail, nerrs, nout )
814 result( 7 ) =
sget06( 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 alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine chetri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
CHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch...
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 chetrf_rook(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bun...
real function sget06(RCOND, RCONDC)
SGET06
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
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 checon_rook(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO)
CHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization ob...
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
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 chet01_rook(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
CHET01_ROOK
real function clanhe(NORM, UPLO, N, A, LDA, WORK)
CLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix.
subroutine chetrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using fac...
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM