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 )