187 INTEGER nmax, nn, nnb, nns, nout
192 INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
194 COMPLEX a( * ), afac( * ), ainv( * ), b( * ), e( * ),
195 $ work( * ), x( * ), xact( * )
202 parameter ( zero = 0.0e+0, one = 1.0e+0 )
204 parameter ( onehalf = 0.5e+0 )
206 parameter ( eight = 8.0e+0, sevten = 17.0e+0 )
208 parameter ( czero = ( 0.0e+0, 0.0e+0 ) )
210 parameter ( ntypes = 11 )
212 parameter ( ntests = 7 )
215 LOGICAL trfcon, zerot
216 CHARACTER dist,
TYPE, uplo, xtype
217 CHARACTER*3 path, matpath
218 INTEGER i, i1, i2, imat, in, inb, info, ioff, irhs,
219 $ itemp, itemp2, iuplo, izero, j, k, kl, ku, lda,
220 $ lwork, mode, n, nb, nerrs, nfail, nimat, nrhs,
222 REAL alpha, anorm, cndnum, const, sing_max,
223 $ sing_min, rcond, rcondc, stemp
227 INTEGER iseed( 4 ), iseedy( 4 )
228 REAL result( ntests )
229 COMPLEX block( 2, 2 ), cdummy( 1 )
242 INTRINSIC max, min, sqrt
250 COMMON / infoc / infot, nunit, ok, lerr
251 COMMON / srnamc / srnamt
254 DATA iseedy / 1988, 1989, 1990, 1991 /
255 DATA uplos /
'U',
'L' /
261 alpha = ( one+sqrt( sevten ) ) / eight
265 path( 1: 1 ) =
'Complex precision'
270 matpath( 1: 1 ) =
'Complex precision'
271 matpath( 2: 3 ) =
'SY'
277 iseed( i ) = iseedy( i )
283 $
CALL cerrsy( path, nout )
305 DO 260 imat = 1, nimat
309 IF( .NOT.dotype( imat ) )
314 zerot = imat.GE.3 .AND. imat.LE.6
315 IF( zerot .AND. n.LT.imat-2 )
321 uplo = uplos( iuplo )
325 IF( imat.NE.ntypes )
THEN
330 CALL clatb4( matpath, imat, n, n,
TYPE, kl, ku, anorm,
331 $ mode, cndnum, dist )
336 CALL clatms( n, n, dist, iseed,
TYPE, rwork, mode,
337 $ cndnum, anorm, kl, ku, uplo, a, lda,
343 CALL alaerh( path,
'CLATMS', info, 0, uplo, n, n,
344 $ -1, -1, -1, imat, nfail, nerrs, nout )
358 ELSE IF( imat.EQ.4 )
THEN
368 IF( iuplo.EQ.1 )
THEN
369 ioff = ( izero-1 )*lda
370 DO 20 i = 1, izero - 1
380 DO 40 i = 1, izero - 1
390 IF( iuplo.EQ.1 )
THEN
426 CALL clatsy( uplo, n, a, lda, iseed )
447 CALL clacpy( uplo, n, n, a, lda, afac, lda )
454 lwork = max( 2, nb )*lda
456 CALL csytrf_rk( uplo, n, afac, lda, e, iwork, ainv,
465 IF( iwork( k ).LT.0 )
THEN
466 IF( iwork( k ).NE.-k )
THEN
470 ELSE IF( iwork( k ).NE.k )
THEN
479 $
CALL alaerh( path,
'CSYTRF_RK', info, k,
480 $ uplo, n, n, -1, -1, nb, imat,
481 $ nfail, nerrs, nout )
494 CALL csyt01_3( uplo, n, a, lda, afac, lda, e, iwork,
495 $ ainv, lda, rwork, result( 1 ) )
504 IF( inb.EQ.1 .AND. .NOT.trfcon )
THEN
505 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
512 lwork = (n+nb+1)*(nb+3)
513 CALL csytri_3( uplo, n, ainv, lda, e, iwork, work,
519 $
CALL alaerh( path,
'CSYTRI_3', info, -1,
520 $ uplo, n, n, -1, -1, -1, imat,
521 $ nfail, nerrs, nout )
526 CALL csyt03( uplo, n, a, lda, ainv, lda, work, lda,
527 $ rwork, rcondc, result( 2 ) )
535 IF( result( k ).GE.thresh )
THEN
536 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
537 $
CALL alahd( nout, path )
538 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
551 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
554 IF( iuplo.EQ.1 )
THEN
563 IF( iwork( k ).GT.zero )
THEN
568 stemp =
clange(
'M', k-1, 1,
569 $ afac( ( k-1 )*lda+1 ), lda, rwork )
575 stemp =
clange(
'M', k-2, 2,
576 $ afac( ( k-2 )*lda+1 ), lda, rwork )
583 stemp = stemp - const + thresh
584 IF( stemp.GT.result( 3 ) )
585 $ result( 3 ) = stemp
601 IF( iwork( k ).GT.zero )
THEN
606 stemp =
clange(
'M', n-k, 1,
607 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
613 stemp =
clange(
'M', n-k-1, 2,
614 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
621 stemp = stemp - const + thresh
622 IF( stemp.GT.result( 3 ) )
623 $ result( 3 ) = stemp
639 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
640 $ ( ( one + alpha ) / ( one - alpha ) )
642 IF( iuplo.EQ.1 )
THEN
651 IF( iwork( k ).LT.zero )
THEN
657 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
658 block( 1, 2 ) = e( k )
659 block( 2, 1 ) = block( 1, 2 )
660 block( 2, 2 ) = afac( (k-1)*lda+k )
662 CALL cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
663 $ cdummy, 1, cdummy, 1,
664 $ work, 6, rwork( 3 ), info )
667 sing_max = rwork( 1 )
668 sing_min = rwork( 2 )
670 stemp = sing_max / sing_min
674 stemp = stemp - const + thresh
675 IF( stemp.GT.result( 4 ) )
676 $ result( 4 ) = stemp
695 IF( iwork( k ).LT.zero )
THEN
701 block( 1, 1 ) = afac( ( k-1 )*lda+k )
702 block( 2, 1 ) = e( k )
703 block( 1, 2 ) = block( 2, 1 )
704 block( 2, 2 ) = afac( k*lda+k+1 )
706 CALL cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
707 $ cdummy, 1, cdummy, 1,
708 $ work, 6, rwork(3), info )
710 sing_max = rwork( 1 )
711 sing_min = rwork( 2 )
713 stemp = sing_max / sing_min
717 stemp = stemp - const + thresh
718 IF( stemp.GT.result( 4 ) )
719 $ result( 4 ) = stemp
734 IF( result( k ).GE.thresh )
THEN
735 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
736 $
CALL alahd( nout, path )
737 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
769 CALL clarhs( matpath, xtype, uplo,
' ', n, n,
770 $ kl, ku, nrhs, a, lda, xact, lda,
771 $ b, lda, iseed, info )
772 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
775 CALL csytrs_3( uplo, n, nrhs, afac, lda, e, iwork,
781 $
CALL alaerh( path,
'CSYTRS_3', info, 0,
782 $ uplo, n, n, -1, -1, nrhs, imat,
783 $ nfail, nerrs, nout )
785 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
789 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
790 $ lda, rwork, result( 5 ) )
795 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
802 IF( result( k ).GE.thresh )
THEN
803 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
804 $
CALL alahd( nout, path )
805 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
806 $ imat, k, result( k )
820 anorm =
clansy(
'1', uplo, n, a, lda, rwork )
822 CALL csycon_3( uplo, n, afac, lda, e, iwork, anorm,
823 $ rcond, work, info )
828 $
CALL alaerh( path,
'CSYCON_3', info, 0,
829 $ uplo, n, n, -1, -1, -1, imat,
830 $ nfail, nerrs, nout )
834 result( 7 ) =
sget06( rcond, rcondc )
839 IF( result( 7 ).GE.thresh )
THEN
840 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
841 $
CALL alahd( nout, path )
842 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
855 CALL alasum( path, nout, nfail, nrun, nerrs )
857 9999
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NB =', i4,
', type ',
858 $ i2,
', test ', i2,
', ratio =', g12.5 )
859 9998
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
', NRHS=', i3,
', type ',
860 $ i2,
', test(', i2,
') =', g12.5 )
861 9997
FORMAT(
' UPLO = ''', a1,
''', N =', i5,
',', 10x,
' type ', i2,
862 $
', 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 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 csycon_3(UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, WORK, INFO)
CSYCON_3
subroutine csytrf_rk(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
CSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch...
real function sget06(RCOND, RCONDC)
SGET06
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
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 clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine csytrs_3(UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO)
CSYTRS_3
subroutine csyt01_3(UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, LDC, RWORK, RESID)
CSYT01_3
subroutine csytri_3(UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO)
CSYTRI_3
real function clansy(NORM, UPLO, N, A, LDA, WORK)
CLANSY 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 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 alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM