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 = 11 )
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, dtemp, lam_max,
218 $ lam_min, rcond, rcondc
222 INTEGER iseed( 4 ), iseedy( 4 )
223 DOUBLE PRECISION result( ntests )
224 COMPLEX*16 block( 2, 2 ), zdummy( 1 )
237 INTRINSIC abs, 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 ) =
'SY'
272 iseed( i ) = iseedy( i )
278 $ CALL
zerrsy( 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 )
320 IF( imat.NE.ntypes )
THEN
325 CALL
zlatb4( matpath, imat, n, n, type, kl, ku, anorm,
326 $ mode, cndnum, dist )
331 CALL
zlatms( n, n, dist, iseed, type, rwork, mode,
332 $ cndnum, anorm, kl, ku, uplo, a, lda,
338 CALL
alaerh( path,
'ZLATMS', info, 0, uplo, n, n,
339 $ -1, -1, -1, imat, nfail, nerrs, nout )
353 ELSE IF( imat.EQ.4 )
THEN
363 IF( iuplo.EQ.1 )
THEN
364 ioff = ( izero-1 )*lda
365 DO 20 i = 1, izero - 1
375 DO 40 i = 1, izero - 1
385 IF( iuplo.EQ.1 )
THEN
421 CALL
zlatsy( uplo, n, a, lda, iseed )
442 CALL
zlacpy( uplo, n, n, a, lda, afac, lda )
449 lwork = max( 2, nb )*lda
450 srnamt =
'ZSYTRF_ROOK'
460 IF( iwork( k ).LT.0 )
THEN
461 IF( iwork( k ).NE.-k )
THEN
465 ELSE IF( iwork( k ).NE.k )
THEN
474 $ CALL
alaerh( path,
'ZSYTRF_ROOK', info, k,
475 $ uplo, n, n, -1, -1, nb, imat,
476 $ nfail, nerrs, nout )
489 CALL
zsyt01_rook( uplo, n, a, lda, afac, lda, iwork,
490 $ ainv, lda, rwork, result( 1 ) )
499 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
500 CALL
zlacpy( uplo, n, n, afac, lda, ainv, lda )
501 srnamt =
'ZSYTRI_ROOK'
508 $ CALL
alaerh( path,
'ZSYTRI_ROOK', info, -1,
509 $ uplo, n, n, -1, -1, -1, imat,
510 $ nfail, nerrs, nout )
515 CALL
zsyt03( uplo, n, a, lda, ainv, lda, work, lda,
516 $ rwork, rcondc, result( 2 ) )
524 IF( result( k ).GE.thresh )
THEN
525 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
526 $ CALL
alahd( nout, path )
527 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
540 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
543 IF( iuplo.EQ.1 )
THEN
552 IF( iwork( k ).GT.zero )
THEN
557 dtemp =
zlange(
'M', k-1, 1,
558 $ afac( ( k-1 )*lda+1 ), lda, rwork )
564 dtemp =
zlange(
'M', k-2, 2,
565 $ afac( ( k-2 )*lda+1 ), lda, rwork )
572 dtemp = dtemp - const + thresh
573 IF( dtemp.GT.result( 3 ) )
574 $ result( 3 ) = dtemp
590 IF( iwork( k ).GT.zero )
THEN
595 dtemp =
zlange(
'M', n-k, 1,
596 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
602 dtemp =
zlange(
'M', n-k-1, 2,
603 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
610 dtemp = dtemp - const + thresh
611 IF( dtemp.GT.result( 3 ) )
612 $ result( 3 ) = dtemp
627 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
628 $ ( ( one + alpha ) / ( one - alpha ) )
630 IF( iuplo.EQ.1 )
THEN
639 IF( iwork( k ).LT.zero )
THEN
644 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
645 block( 2, 1 ) = afac( ( k-2 )*lda+k )
646 block( 1, 2 ) = block( 2, 1 )
647 block( 2, 2 ) = afac( (k-1)*lda+k )
649 CALL
zgeevx(
'N',
'N',
'N',
'N', 2, block,
650 $ 2, work, zdummy, 1, zdummy, 1,
651 $ itemp, itemp2, rwork, dtemp,
652 $ rwork( 3 ), rwork( 5 ), work( 3 ),
653 $ 4, rwork( 7 ), info )
655 lam_max = max( abs( work( 1 ) ),
657 lam_min = min( abs( work( 1 ) ),
660 dtemp = lam_max / lam_min
664 dtemp = abs( dtemp ) - const + thresh
665 IF( dtemp.GT.result( 4 ) )
666 $ result( 4 ) = dtemp
685 IF( iwork( k ).LT.zero )
THEN
690 block( 1, 1 ) = afac( ( k-1 )*lda+k )
691 block( 2, 1 ) = afac( ( k-1 )*lda+k+1 )
692 block( 1, 2 ) = block( 2, 1 )
693 block( 2, 2 ) = afac( k*lda+k+1 )
695 CALL
zgeevx(
'N',
'N',
'N',
'N', 2, block,
696 $ 2, work, zdummy, 1, zdummy, 1,
697 $ itemp, itemp2, rwork, dtemp,
698 $ rwork( 3 ), rwork( 5 ), work( 3 ),
699 $ 4, rwork( 7 ), info )
701 lam_max = max( abs( work( 1 ) ),
703 lam_min = min( abs( work( 1 ) ),
706 dtemp = lam_max / lam_min
710 dtemp = abs( dtemp ) - const + thresh
711 IF( dtemp.GT.result( 4 ) )
712 $ result( 4 ) = dtemp
727 IF( result( k ).GE.thresh )
THEN
728 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
729 $ CALL
alahd( nout, path )
730 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
762 CALL
zlarhs( matpath, xtype, uplo,
' ', n, n,
763 $ kl, ku, nrhs, a, lda, xact, lda,
764 $
b, lda, iseed, info )
765 CALL
zlacpy(
'Full', n, nrhs,
b, lda, x, lda )
767 srnamt =
'ZSYTRS_ROOK'
774 $ CALL
alaerh( path,
'ZSYTRS_ROOK', info, 0,
775 $ uplo, n, n, -1, -1, nrhs, imat,
776 $ nfail, nerrs, nout )
778 CALL
zlacpy(
'Full', n, nrhs,
b, lda, work, lda )
782 CALL
zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
783 $ lda, rwork, result( 5 ) )
788 CALL
zget04( n, nrhs, x, lda, xact, lda, rcondc,
795 IF( result( k ).GE.thresh )
THEN
796 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
797 $ CALL
alahd( nout, path )
798 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
799 $ imat, k, result( k )
813 anorm =
zlansy(
'1', uplo, n, a, lda, rwork )
814 srnamt =
'ZSYCON_ROOK'
815 CALL
zsycon_rook( uplo, n, afac, lda, iwork, anorm,
816 $ rcond, work, info )
821 $ CALL
alaerh( path,
'ZSYCON_ROOK', info, 0,
822 $ uplo, n, n, -1, -1, -1, imat,
823 $ nfail, nerrs, nout )
827 result( 7 ) =
dget06( rcond, rcondc )
832 IF( result( 7 ).GE.thresh )
THEN
833 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
834 $ CALL
alahd( nout, path )
835 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
848 CALL
alasum( path, nout, nfail, nrun, nerrs )
850 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
851 $ i2,
', test ', i2,
', ratio =', g12.5 )
852 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
853 $ i2,
', test(', i2,
') =', g12.5 )
854 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
855 $
', test(', i2,
') =', g12.5 )
subroutine zsyt01_rook(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
ZSYT01_ROOK
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
double precision function zlansy(NORM, UPLO, N, A, LDA, WORK)
ZLANSY 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 symmetric matrix.
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zsyt02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
ZSYT02
subroutine zerrsy(PATH, NUNIT)
ZERRSY
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine zsytrf_rook(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
ZSYTRF_ROOK
subroutine zchksy_rook(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
ZCHKSY_ROOK
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine zlatsy(UPLO, N, X, LDX, ISEED)
ZLATSY
double precision function dget06(RCOND, RCONDC)
DGET06
subroutine zsytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZSYTRS_ROOK
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
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 ...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zsycon_rook(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO)
ZSYCON_ROOK
subroutine zgeevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO)
ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine zsyt03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
ZSYT03
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zsytri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
ZSYTRI_ROOK
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4