171 SUBROUTINE zchksy_rook( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
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 $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
215 $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
216 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX,
217 $ sing_min, rcond, rcondc
221 INTEGER ISEED( 4 ), ISEEDY( 4 )
222 DOUBLE PRECISION RESULT( ntests )
223 COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
226 DOUBLE PRECISION DGET06, ZLANGE, ZLANSY
227 EXTERNAL dget06, zlange, zlansy
236 INTRINSIC 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 ) =
'Zomplex precision'
264 matpath( 1: 1 ) =
'Zomplex precision'
265 matpath( 2: 3 ) =
'SY'
271 iseed( i ) = iseedy( i )
277 $
CALL zerrsy( 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 )
319 IF( imat.NE.ntypes )
THEN
324 CALL zlatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
325 $ mode, cndnum, dist )
330 CALL zlatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
331 $ cndnum, anorm, kl, ku, uplo, a, lda,
337 CALL alaerh( path,
'ZLATMS', info, 0, uplo, n, n,
338 $ -1, -1, -1, imat, nfail, nerrs, nout )
352 ELSE IF( imat.EQ.4 )
THEN
362 IF( iuplo.EQ.1 )
THEN
363 ioff = ( izero-1 )*lda
364 DO 20 i = 1, izero - 1
374 DO 40 i = 1, izero - 1
384 IF( iuplo.EQ.1 )
THEN
420 CALL zlatsy( uplo, n, a, lda, iseed )
441 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
448 lwork = max( 2, nb )*lda
449 srnamt =
'ZSYTRF_ROOK'
459 IF( iwork( k ).LT.0 )
THEN
460 IF( iwork( k ).NE.-k )
THEN
464 ELSE IF( iwork( k ).NE.k )
THEN
473 $
CALL alaerh( path,
'ZSYTRF_ROOK', info, k,
474 $ uplo, n, n, -1, -1, nb, imat,
475 $ nfail, nerrs, nout )
488 CALL zsyt01_rook( uplo, n, a, lda, afac, lda, iwork,
489 $ ainv, lda, rwork, result( 1 ) )
498 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
499 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
500 srnamt =
'ZSYTRI_ROOK'
507 $
CALL alaerh( path,
'ZSYTRI_ROOK', info, -1,
508 $ uplo, n, n, -1, -1, -1, imat,
509 $ nfail, nerrs, nout )
514 CALL zsyt03( 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 dtemp = zlange(
'M', k-1, 1,
557 $ afac( ( k-1 )*lda+1 ), lda, rwork )
563 dtemp = zlange(
'M', k-2, 2,
564 $ afac( ( k-2 )*lda+1 ), lda, rwork )
571 dtemp = dtemp - const + thresh
572 IF( dtemp.GT.result( 3 ) )
573 $ result( 3 ) = dtemp
589 IF( iwork( k ).GT.zero )
THEN
594 dtemp = zlange(
'M', n-k, 1,
595 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
601 dtemp = zlange(
'M', n-k-1, 2,
602 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
609 dtemp = dtemp - const + thresh
610 IF( dtemp.GT.result( 3 ) )
611 $ 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
645 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
646 block( 1, 2 ) = afac( (k-1)*lda+k-1 )
647 block( 2, 1 ) = block( 1, 2 )
648 block( 2, 2 ) = afac( (k-1)*lda+k )
650 CALL zgesvd(
'N',
'N', 2, 2, block, 2, rwork,
651 $ zdummy, 1, zdummy, 1,
652 $ work, 6, rwork( 3 ), info )
655 sing_max = rwork( 1 )
656 sing_min = rwork( 2 )
658 dtemp = sing_max / sing_min
662 dtemp = dtemp - const + thresh
663 IF( dtemp.GT.result( 4 ) )
664 $ result( 4 ) = dtemp
683 IF( iwork( k ).LT.zero )
THEN
689 block( 1, 1 ) = afac( ( k-1 )*lda+k )
690 block( 2, 1 ) = afac( ( k-1 )*lda+k+1 )
691 block( 1, 2 ) = block( 2, 1 )
692 block( 2, 2 ) = afac( k*lda+k+1 )
694 CALL zgesvd(
'N',
'N', 2, 2, block, 2, rwork,
695 $ zdummy, 1, zdummy, 1,
696 $ work, 6, rwork(3), info )
698 sing_max = rwork( 1 )
699 sing_min = rwork( 2 )
701 dtemp = sing_max / sing_min
705 dtemp = dtemp - const + thresh
706 IF( dtemp.GT.result( 4 ) )
707 $ result( 4 ) = dtemp
722 IF( result( k ).GE.thresh )
THEN
723 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
724 $
CALL alahd( nout, path )
725 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
757 CALL zlarhs( matpath, xtype, uplo,
' ', n, n,
758 $ kl, ku, nrhs, a, lda, xact, lda,
759 $ b, lda, iseed, info )
760 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
762 srnamt =
'ZSYTRS_ROOK'
769 $
CALL alaerh( path,
'ZSYTRS_ROOK', info, 0,
770 $ uplo, n, n, -1, -1, nrhs, imat,
771 $ nfail, nerrs, nout )
773 CALL zlacpy(
'Full', n, nrhs, b, lda, work, lda )
777 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
778 $ lda, rwork, result( 5 ) )
783 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
790 IF( result( k ).GE.thresh )
THEN
791 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
792 $
CALL alahd( nout, path )
793 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
794 $ imat, k, result( k )
808 anorm = zlansy(
'1', uplo, n, a, lda, rwork )
809 srnamt =
'ZSYCON_ROOK'
810 CALL zsycon_rook( uplo, n, afac, lda, iwork, anorm,
811 $ rcond, work, info )
816 $
CALL alaerh( path,
'ZSYCON_ROOK', info, 0,
817 $ uplo, n, n, -1, -1, -1, imat,
818 $ nfail, nerrs, nout )
822 result( 7 ) = dget06( rcond, rcondc )
827 IF( result( 7 ).GE.thresh )
THEN
828 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
829 $
CALL alahd( nout, path )
830 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
843 CALL alasum( path, nout, nfail, nrun, nerrs )
845 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
846 $ i2,
', test ', i2,
', ratio =', g12.5 )
847 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
848 $ i2,
', test(', i2,
') =', g12.5 )
849 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
850 $
', test(', i2,
') =', 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 zsyt01_rook(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
ZSYT01_ROOK
subroutine zerrsy(PATH, NUNIT)
ZERRSY
subroutine zsytri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
ZSYTRI_ROOK
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
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
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine zlatsy(UPLO, N, X, LDX, ISEED)
ZLATSY
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
subroutine zsyt03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
ZSYT03
subroutine zsycon_rook(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO)
ZSYCON_ROOK
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 zsyt02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
ZSYT02
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zsytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZSYTRS_ROOK
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM