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 $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
215 $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
216 REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
217 $ sing_min, rcond, rcondc, stemp
221 INTEGER ISEED( 4 ), ISEEDY( 4 )
222 REAL RESULT( ntests )
223 COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
226 REAL CLANGE, CLANSY, SGET06
227 EXTERNAL clange, clansy, sget06
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 ) =
'Complex precision'
264 matpath( 1: 1 ) =
'Complex precision'
265 matpath( 2: 3 ) =
'SY'
271 iseed( i ) = iseedy( i )
277 $
CALL cerrsy( 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 clatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
325 $ mode, cndnum, dist )
330 CALL clatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
331 $ cndnum, anorm, kl, ku, uplo, a, lda,
337 CALL alaerh( path,
'CLATMS', 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 clatsy( uplo, n, a, lda, iseed )
441 CALL clacpy( uplo, n, n, a, lda, afac, lda )
448 lwork = max( 2, nb )*lda
449 srnamt =
'CSYTRF_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,
'CSYTRF_ROOK', info, k,
474 $ uplo, n, n, -1, -1, nb, imat,
475 $ nfail, nerrs, nout )
488 CALL csyt01_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 clacpy( uplo, n, n, afac, lda, ainv, lda )
500 srnamt =
'CSYTRI_ROOK'
507 $
CALL alaerh( path,
'CSYTRI_ROOK', info, -1,
508 $ uplo, n, n, -1, -1, -1, imat,
509 $ nfail, nerrs, nout )
514 CALL csyt03( 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 stemp = clange(
'M', k-1, 1,
557 $ afac( ( k-1 )*lda+1 ), lda, rwork )
563 stemp = clange(
'M', k-2, 2,
564 $ afac( ( k-2 )*lda+1 ), lda, rwork )
571 stemp = stemp - const + thresh
572 IF( stemp.GT.result( 3 ) )
573 $ result( 3 ) = stemp
589 IF( iwork( k ).GT.zero )
THEN
594 stemp = clange(
'M', n-k, 1,
595 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
601 stemp = clange(
'M', n-k-1, 2,
602 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
609 stemp = stemp - const + thresh
610 IF( stemp.GT.result( 3 ) )
611 $ 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
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 cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
651 $ cdummy, 1, cdummy, 1,
652 $ work, 6, rwork( 3 ), info )
655 sing_max = rwork( 1 )
656 sing_min = rwork( 2 )
658 stemp = sing_max / sing_min
662 stemp = stemp - const + thresh
663 IF( stemp.GT.result( 4 ) )
664 $ result( 4 ) = stemp
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 cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
695 $ cdummy, 1, cdummy, 1,
696 $ work, 6, rwork(3), info )
698 sing_max = rwork( 1 )
699 sing_min = rwork( 2 )
701 stemp = sing_max / sing_min
705 stemp = stemp - const + thresh
706 IF( stemp.GT.result( 4 ) )
707 $ result( 4 ) = stemp
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 clarhs( matpath, xtype, uplo,
' ', n, n,
758 $ kl, ku, nrhs, a, lda, xact, lda,
759 $ b, lda, iseed, info )
760 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
762 srnamt =
'CSYTRS_ROOK'
769 $
CALL alaerh( path,
'CSYTRS_ROOK', info, 0,
770 $ uplo, n, n, -1, -1, nrhs, imat,
771 $ nfail, nerrs, nout )
773 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
777 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
778 $ lda, rwork, result( 5 ) )
783 CALL cget04( 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 = clansy(
'1', uplo, n, a, lda, rwork )
809 srnamt =
'CSYCON_ROOK'
810 CALL csycon_rook( uplo, n, afac, lda, iwork, anorm,
811 $ rcond, work, info )
816 $
CALL alaerh( path,
'CSYCON_ROOK', info, 0,
817 $ uplo, n, n, -1, -1, -1, imat,
818 $ nfail, nerrs, nout )
822 result( 7 ) = sget06( 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 csytri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
CSYTRI_ROOK
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine clatsy(UPLO, N, X, LDX, ISEED)
CLATSY
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine csyt02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CSYT02
subroutine cgesvd(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO)
CGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine cerrsy(PATH, NUNIT)
CERRSY
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine csytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CSYTRS_ROOK
subroutine csyt03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
CSYT03
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine csytrf_rook(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CSYTRF_ROOK
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine csycon_rook(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO)
CSYCON_ROOK
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
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 csyt01_rook(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
CSYT01_ROOK
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM