171 SUBROUTINE cchksy_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
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 = 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 REAL ALPHA, ANORM, CNDNUM, CONST, LAM_MAX, LAM_MIN,
218 $ rcond, rcondc, stemp
222 INTEGER ISEED( 4 ), ISEEDY( 4 )
223 REAL RESULT( ntests )
224 COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
227 REAL CLANGE, CLANSY, SGET06
228 EXTERNAL clange, clansy, sget06
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 ) =
'Complex precision'
265 matpath( 1: 1 ) =
'Complex precision'
266 matpath( 2: 3 ) =
'SY'
272 iseed( i ) = iseedy( i )
278 $
CALL cerrsy( 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 clatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
326 $ mode, cndnum, dist )
331 CALL clatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
332 $ cndnum, anorm, kl, ku, uplo, a, lda,
338 CALL alaerh( path,
'CLATMS', 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 clatsy( uplo, n, a, lda, iseed )
442 CALL clacpy( uplo, n, n, a, lda, afac, lda )
449 lwork = max( 2, nb )*lda
450 srnamt =
'CSYTRF_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,
'CSYTRF_ROOK', info, k,
475 $ uplo, n, n, -1, -1, nb, imat,
476 $ nfail, nerrs, nout )
489 CALL csyt01_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 clacpy( uplo, n, n, afac, lda, ainv, lda )
501 srnamt =
'CSYTRI_ROOK'
508 $
CALL alaerh( path,
'CSYTRI_ROOK', info, -1,
509 $ uplo, n, n, -1, -1, -1, imat,
510 $ nfail, nerrs, nout )
515 CALL csyt03( 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 stemp = clange(
'M', k-1, 1,
558 $ afac( ( k-1 )*lda+1 ), lda, rwork )
564 stemp = clange(
'M', k-2, 2,
565 $ afac( ( k-2 )*lda+1 ), lda, rwork )
572 stemp = stemp - const + thresh
573 IF( stemp.GT.result( 3 ) )
574 $ result( 3 ) = stemp
590 IF( iwork( k ).GT.zero )
THEN
595 stemp = clange(
'M', n-k, 1,
596 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
602 stemp = clange(
'M', n-k-1, 2,
603 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
610 stemp = stemp - const + thresh
611 IF( stemp.GT.result( 3 ) )
612 $ result( 3 ) = stemp
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 cgeevx(
'N',
'N',
'N',
'N', 2, block,
650 $ 2, work, cdummy, 1, cdummy, 1,
651 $ itemp, itemp2, rwork, stemp,
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 stemp = lam_max / lam_min
664 stemp = abs( stemp ) - const + thresh
665 IF( stemp.GT.result( 4 ) )
666 $ result( 4 ) = stemp
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 cgeevx(
'N',
'N',
'N',
'N', 2, block,
696 $ 2, work, cdummy, 1, cdummy, 1,
697 $ itemp, itemp2, rwork, stemp,
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 stemp = lam_max / lam_min
710 stemp = abs( stemp ) - const + thresh
711 IF( stemp.GT.result( 4 ) )
712 $ result( 4 ) = stemp
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 clarhs( matpath, xtype, uplo,
' ', n, n,
763 $ kl, ku, nrhs, a, lda, xact, lda,
764 $ b, lda, iseed, info )
765 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
767 srnamt =
'CSYTRS_ROOK'
774 $
CALL alaerh( path,
'CSYTRS_ROOK', info, 0,
775 $ uplo, n, n, -1, -1, nrhs, imat,
776 $ nfail, nerrs, nout )
778 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
782 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
783 $ lda, rwork, result( 5 ) )
788 CALL cget04( 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 = clansy(
'1', uplo, n, a, lda, rwork )
814 srnamt =
'CSYCON_ROOK'
815 CALL csycon_rook( uplo, n, afac, lda, iwork, anorm,
816 $ rcond, work, info )
821 $
CALL alaerh( path,
'CSYCON_ROOK', info, 0,
822 $ uplo, n, n, -1, -1, -1, imat,
823 $ nfail, nerrs, nout )
827 result( 7 ) = sget06( 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 clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine clatsy(UPLO, N, X, LDX, ISEED)
CLATSY
subroutine csyt03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
CSYT03
subroutine csytrf_rook(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CSYTRF_ROOK
subroutine cchksy_rook(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
CCHKSY_ROOK
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine csytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CSYTRS_ROOK
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine csyt01_rook(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
CSYT01_ROOK
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine cerrsy(PATH, NUNIT)
CERRSY
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine csyt02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CSYT02
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine cgeevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO)
CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine csytri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
CSYTRI_ROOK
subroutine csycon_rook(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO)
CSYCON_ROOK