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 $ itemp, itemp2, iuplo, izero, j, k, kl, ku, lda,
215 $ lwork, mode, n, nb, nerrs, nfail, nimat, nrhs,
217 DOUBLE PRECISION alpha, anorm, cndnum, const, sing_max,
218 $ sing_min, rcond, rcondc, dtemp
222 INTEGER iseed( 4 ), iseedy( 4 ), idummy( 1 )
223 DOUBLE PRECISION result( ntests )
224 COMPLEX*16 block( 2, 2 ), zdummy( 1 )
237 INTRINSIC conjg, max, min, sqrt
245 COMMON / infoc / infot, nunit, ok, lerr
246 COMMON / srnamc / srnamt
249 DATA iseedy / 1988, 1989, 1990, 1991 /
250 DATA uplos /
'U',
'L' /
256 alpha = ( one+sqrt( sevten ) ) / eight
260 path( 1: 1 ) =
'Zomplex precision'
265 matpath( 1: 1 ) =
'Zomplex precision'
266 matpath( 2: 3 ) =
'HE'
272 iseed( i ) = iseedy( i )
278 $
CALL zerrhe( path, nout )
300 DO 260 imat = 1, nimat
304 IF( .NOT.dotype( imat ) )
309 zerot = imat.GE.3 .AND. imat.LE.6
310 IF( zerot .AND. n.LT.imat-2 )
316 uplo = uplos( iuplo )
323 CALL zlatb4( matpath, imat, n, n,
TYPE, kl, ku, anorm,
324 $ mode, cndnum, dist )
329 CALL zlatms( n, n, dist, iseed,
TYPE, rwork, mode,
330 $ cndnum, anorm, kl, ku, uplo, a, lda,
336 CALL alaerh( path,
'ZLATMS', info, 0, uplo, n, n,
337 $ -1, -1, -1, imat, nfail, nerrs, nout )
351 ELSE IF( imat.EQ.4 )
THEN
361 IF( iuplo.EQ.1 )
THEN
362 ioff = ( izero-1 )*lda
363 DO 20 i = 1, izero - 1
373 DO 40 i = 1, izero - 1
383 IF( iuplo.EQ.1 )
THEN
430 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
437 lwork = max( 2, nb )*lda
438 srnamt =
'ZHETRF_ROOK'
448 IF( iwork( k ).LT.0 )
THEN
449 IF( iwork( k ).NE.-k )
THEN
453 ELSE IF( iwork( k ).NE.k )
THEN
462 $
CALL alaerh( path,
'ZHETRF_ROOK', info, k,
463 $ uplo, n, n, -1, -1, nb, imat,
464 $ nfail, nerrs, nout )
477 CALL zhet01_rook( uplo, n, a, lda, afac, lda, iwork,
478 $ ainv, lda, rwork, result( 1 ) )
487 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
488 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
489 srnamt =
'ZHETRI_ROOK'
496 $
CALL alaerh( path,
'ZHETRI_ROOK', info, -1,
497 $ uplo, n, n, -1, -1, -1, imat,
498 $ nfail, nerrs, nout )
503 CALL zpot03( uplo, n, a, lda, ainv, lda, work, lda,
504 $ rwork, rcondc, result( 2 ) )
512 IF( result( k ).GE.thresh )
THEN
513 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
514 $
CALL alahd( nout, path )
515 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
528 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
531 IF( iuplo.EQ.1 )
THEN
540 IF( iwork( k ).GT.zero )
THEN
545 dtemp =
zlange(
'M', k-1, 1,
546 $ afac( ( k-1 )*lda+1 ), lda, rwork )
552 dtemp =
zlange(
'M', k-2, 2,
553 $ afac( ( k-2 )*lda+1 ), lda, rwork )
560 dtemp = dtemp - const + thresh
561 IF( dtemp.GT.result( 3 ) )
562 $ result( 3 ) = dtemp
578 IF( iwork( k ).GT.zero )
THEN
583 dtemp =
zlange(
'M', n-k, 1,
584 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
590 dtemp =
zlange(
'M', n-k-1, 2,
591 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
598 dtemp = dtemp - const + thresh
599 IF( dtemp.GT.result( 3 ) )
600 $ result( 3 ) = dtemp
616 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
617 $ ( ( one + alpha ) / ( one - alpha ) )
618 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
620 IF( iuplo.EQ.1 )
THEN
629 IF( iwork( k ).LT.zero )
THEN
635 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
636 block( 1, 2 ) = afac( (k-1)*lda+k-1 )
637 block( 2, 1 ) = conjg( block( 1, 2 ) )
638 block( 2, 2 ) = afac( (k-1)*lda+k )
640 CALL zgesvd(
'N',
'N', 2, 2, block, 2, rwork,
641 $ zdummy, 1, zdummy, 1,
642 $ work, 6, rwork( 3 ), info )
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 ) = afac( ( k-1 )*lda+k+1 )
681 block( 1, 2 ) = conjg( block( 2, 1 ) )
682 block( 2, 2 ) = afac( k*lda+k+1 )
684 CALL zgesvd(
'N',
'N', 2, 2, block, 2, rwork,
685 $ zdummy, 1, zdummy, 1,
686 $ work, 6, rwork(3), info )
688 sing_max = rwork( 1 )
689 sing_min = rwork( 2 )
691 dtemp = sing_max / sing_min
695 dtemp = dtemp - const + thresh
696 IF( dtemp.GT.result( 4 ) )
697 $ result( 4 ) = dtemp
712 IF( result( k ).GE.thresh )
THEN
713 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
714 $
CALL alahd( nout, path )
715 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
750 CALL zlarhs( matpath, xtype, uplo,
' ', n, n,
751 $ kl, ku, nrhs, a, lda, xact, lda,
752 $ b, lda, iseed, info )
753 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
755 srnamt =
'ZHETRS_ROOK'
762 $
CALL alaerh( path,
'ZHETRS_ROOK', info, 0,
763 $ uplo, n, n, -1, -1, nrhs, imat,
764 $ nfail, nerrs, nout )
766 CALL zlacpy(
'Full', n, nrhs, b, lda, work, lda )
770 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
771 $ lda, rwork, result( 5 ) )
776 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
783 IF( result( k ).GE.thresh )
THEN
784 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
785 $
CALL alahd( nout, path )
786 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
787 $ imat, k, result( k )
801 anorm =
zlanhe(
'1', uplo, n, a, lda, rwork )
802 srnamt =
'ZHECON_ROOK'
803 CALL zhecon_rook( uplo, n, afac, lda, iwork, anorm,
804 $ rcond, work, info )
809 $
CALL alaerh( path,
'ZHECON_ROOK', info, 0,
810 $ uplo, n, n, -1, -1, -1, imat,
811 $ nfail, nerrs, nout )
815 result( 7 ) =
dget06( rcond, rcondc )
820 IF( result( 7 ).GE.thresh )
THEN
821 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
822 $
CALL alahd( nout, path )
823 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
836 CALL alasum( path, nout, nfail, nrun, nerrs )
838 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
839 $ i2,
', test ', i2,
', ratio =', g12.5 )
840 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
841 $ i2,
', test ', i2,
', ratio =', g12.5 )
842 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
843 $
', 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 alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
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 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 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 obt...
double precision function zlanhe(NORM, UPLO, N, A, LDA, WORK)
ZLANHE 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 zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
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 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...
double precision function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
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 alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM