409 SUBROUTINE cchkhs( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
410 $ nounit, a, lda, h, t1, t2, u, ldu, z, uz, w1,
411 $ w3, evectl, evectr, evecty, evectx, uu, tau,
412 $ work, nwork, rwork, iwork,
SELECT, result,
421 INTEGER info, lda, ldu, nounit, nsizes, ntypes, nwork
425 LOGICAL dotype( * ), select( * )
426 INTEGER iseed( 4 ), iwork( * ), nn( * )
427 REAL result( 14 ), rwork( * )
428 COMPLEX a( lda, * ), evectl( ldu, * ),
429 $ evectr( ldu, * ), evectx( ldu, * ),
430 $ evecty( ldu, * ), h( lda, * ), t1( lda, * ),
431 $ t2( lda, * ), tau( * ), u( ldu, * ),
432 $ uu( ldu, * ), uz( ldu, * ), w1( * ), w3( * ),
433 $ work( * ), z( ldu, * )
440 parameter( zero = 0.0e+0, one = 1.0e+0 )
442 parameter( czero = ( 0.0e+0, 0.0e+0 ),
443 $ cone = ( 1.0e+0, 0.0e+0 ) )
445 parameter( maxtyp = 21 )
449 INTEGER i, ihi, iinfo, ilo, imode, in, itype,
j, jcol,
450 $ jj, jsize, jtype, k, mtypes, n, n1, nerrs,
451 $ nmats, nmax, ntest, ntestt
452 REAL aninv, anorm, cond, conds, ovfl, rtovfl, rtulp,
453 $ rtulpi, rtunfl, temp1, temp2, ulp, ulpinv, unfl
456 INTEGER idumma( 1 ), ioldsd( 4 ), kconds( maxtyp ),
457 $ kmagn( maxtyp ), kmode( maxtyp ),
473 INTRINSIC abs, max, min,
REAL, sqrt
476 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
477 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
479 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
480 $ 1, 5, 5, 5, 4, 3, 1 /
481 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
493 nmax = max( nmax, nn(
j ) )
500 IF( nsizes.LT.0 )
THEN
502 ELSE IF( badnn )
THEN
504 ELSE IF( ntypes.LT.0 )
THEN
506 ELSE IF( thresh.LT.zero )
THEN
508 ELSE IF( lda.LE.1 .OR. lda.LT.nmax )
THEN
510 ELSE IF( ldu.LE.1 .OR. ldu.LT.nmax )
THEN
512 ELSE IF( 4*nmax*nmax+2.GT.nwork )
THEN
517 CALL
xerbla(
'CCHKHS', -info )
523 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
528 unfl =
slamch(
'Safe minimum' )
529 ovfl =
slamch(
'Overflow' )
533 rtunfl = sqrt( unfl )
534 rtovfl = sqrt( ovfl )
543 DO 260 jsize = 1, nsizes
548 aninv = one /
REAL( n1 )
550 IF( nsizes.NE.1 )
THEN
551 mtypes = min( maxtyp, ntypes )
553 mtypes = min( maxtyp+1, ntypes )
556 DO 250 jtype = 1, mtypes
557 IF( .NOT.dotype( jtype ) )
565 ioldsd(
j ) = iseed(
j )
590 IF( mtypes.GT.maxtyp )
593 itype = ktype( jtype )
594 imode = kmode( jtype )
598 go to( 40, 50, 60 )kmagn( jtype )
605 anorm = ( rtovfl*ulp )*aninv
609 anorm = rtunfl*n*ulpinv
614 CALL
claset(
'Full', lda, n, czero, czero, a, lda )
620 IF( itype.EQ.1 )
THEN
625 ELSE IF( itype.EQ.2 )
THEN
630 a( jcol, jcol ) = anorm
633 ELSE IF( itype.EQ.3 )
THEN
638 a( jcol, jcol ) = anorm
640 $ a( jcol, jcol-1 ) = one
643 ELSE IF( itype.EQ.4 )
THEN
647 CALL
clatmr( n, n,
'D', iseed,
'N', work, imode, cond,
648 $ cone,
'T',
'N', work( n+1 ), 1, one,
649 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
650 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
652 ELSE IF( itype.EQ.5 )
THEN
656 CALL
clatms( n, n,
'D', iseed,
'H', rwork, imode, cond,
657 $ anorm, n, n,
'N', a, lda, work, iinfo )
659 ELSE IF( itype.EQ.6 )
THEN
663 IF( kconds( jtype ).EQ.1 )
THEN
665 ELSE IF( kconds( jtype ).EQ.2 )
THEN
671 CALL
clatme( n,
'D', iseed, work, imode, cond, cone,
672 $
'T',
'T',
'T', rwork, 4, conds, n, n, anorm,
673 $ a, lda, work( n+1 ), iinfo )
675 ELSE IF( itype.EQ.7 )
THEN
679 CALL
clatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
680 $
'T',
'N', work( n+1 ), 1, one,
681 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
682 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
684 ELSE IF( itype.EQ.8 )
THEN
688 CALL
clatmr( n, n,
'D', iseed,
'H', work, 6, one, cone,
689 $
'T',
'N', work( n+1 ), 1, one,
690 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
691 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
693 ELSE IF( itype.EQ.9 )
THEN
697 CALL
clatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
698 $
'T',
'N', work( n+1 ), 1, one,
699 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
700 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
702 ELSE IF( itype.EQ.10 )
THEN
706 CALL
clatmr( n, n,
'D', iseed,
'N', work, 6, one, cone,
707 $
'T',
'N', work( n+1 ), 1, one,
708 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
709 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
716 IF( iinfo.NE.0 )
THEN
717 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
727 CALL
clacpy(
' ', n, n, a, lda, h, lda )
733 CALL
cgehrd( n, ilo, ihi, h, lda, work, work( n+1 ),
736 IF( iinfo.NE.0 )
THEN
738 WRITE( nounit, fmt = 9999 )
'CGEHRD', iinfo, n, jtype,
747 u( i,
j ) = h( i,
j )
748 uu( i,
j ) = h( i,
j )
752 CALL
ccopy( n-1, work, 1, tau, 1 )
753 CALL
cunghr( n, ilo, ihi, u, ldu, work, work( n+1 ),
757 CALL
chst01( n, ilo, ihi, a, lda, h, lda, u, ldu, work,
758 $ nwork, rwork, result( 1 ) )
764 CALL
clacpy(
' ', n, n, h, lda, t2, lda )
768 CALL
chseqr(
'E',
'N', n, ilo, ihi, t2, lda, w3, uz, ldu,
769 $ work, nwork, iinfo )
770 IF( iinfo.NE.0 )
THEN
771 WRITE( nounit, fmt = 9999 )
'CHSEQR(E)', iinfo, n, jtype,
773 IF( iinfo.LE.n+2 )
THEN
781 CALL
clacpy(
' ', n, n, h, lda, t2, lda )
783 CALL
chseqr(
'S',
'N', n, ilo, ihi, t2, lda, w1, uz, ldu,
784 $ work, nwork, iinfo )
785 IF( iinfo.NE.0 .AND. iinfo.LE.n+2 )
THEN
786 WRITE( nounit, fmt = 9999 )
'CHSEQR(S)', iinfo, n, jtype,
794 CALL
clacpy(
' ', n, n, h, lda, t1, lda )
795 CALL
clacpy(
' ', n, n, u, ldu, uz, ldu )
797 CALL
chseqr(
'S',
'V', n, ilo, ihi, t1, lda, w1, uz, ldu,
798 $ work, nwork, iinfo )
799 IF( iinfo.NE.0 .AND. iinfo.LE.n+2 )
THEN
800 WRITE( nounit, fmt = 9999 )
'CHSEQR(V)', iinfo, n, jtype,
808 CALL
cgemm(
'C',
'N', n, n, n, cone, u, ldu, uz, ldu, czero,
815 CALL
chst01( n, ilo, ihi, h, lda, t1, lda, z, ldu, work,
816 $ nwork, rwork, result( 3 ) )
821 CALL
chst01( n, ilo, ihi, a, lda, t1, lda, uz, ldu, work,
822 $ nwork, rwork, result( 5 ) )
826 CALL
cget10( n, n, t2, lda, t1, lda, work, rwork,
834 temp1 = max( temp1, abs( w1(
j ) ), abs( w3(
j ) ) )
835 temp2 = max( temp2, abs( w1(
j )-w3(
j ) ) )
838 result( 8 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
850 SELECT(
j ) = .false.
855 CALL
ctrevc(
'Right',
'All',
SELECT, n, t1, lda, cdumma,
856 $ ldu, evectr, ldu, n, in, work, rwork, iinfo )
857 IF( iinfo.NE.0 )
THEN
858 WRITE( nounit, fmt = 9999 )
'CTREVC(R,A)', iinfo, n,
866 CALL
cget22(
'N',
'N',
'N', n, t1, lda, evectr, ldu, w1,
867 $ work, rwork, dumma( 1 ) )
868 result( 9 ) = dumma( 1 )
869 IF( dumma( 2 ).GT.thresh )
THEN
870 WRITE( nounit, fmt = 9998 )
'Right',
'CTREVC',
871 $ dumma( 2 ), n, jtype, ioldsd
877 CALL
ctrevc(
'Right',
'Some',
SELECT, n, t1, lda, cdumma,
878 $ ldu, evectl, ldu, n, in, work, rwork, iinfo )
879 IF( iinfo.NE.0 )
THEN
880 WRITE( nounit, fmt = 9999 )
'CTREVC(R,S)', iinfo, n,
889 IF(
SELECT(
j ) )
THEN
891 IF( evectr( jj,
j ).NE.evectl( jj, k ) )
THEN
901 $
WRITE( nounit, fmt = 9997 )
'Right',
'CTREVC', n, jtype,
907 result( 10 ) = ulpinv
908 CALL
ctrevc(
'Left',
'All',
SELECT, n, t1, lda, evectl, ldu,
909 $ cdumma, ldu, n, in, work, rwork, iinfo )
910 IF( iinfo.NE.0 )
THEN
911 WRITE( nounit, fmt = 9999 )
'CTREVC(L,A)', iinfo, n,
919 CALL
cget22(
'C',
'N',
'C', n, t1, lda, evectl, ldu, w1,
920 $ work, rwork, dumma( 3 ) )
921 result( 10 ) = dumma( 3 )
922 IF( dumma( 4 ).GT.thresh )
THEN
923 WRITE( nounit, fmt = 9998 )
'Left',
'CTREVC', dumma( 4 ),
930 CALL
ctrevc(
'Left',
'Some',
SELECT, n, t1, lda, evectr,
931 $ ldu, cdumma, ldu, n, in, work, rwork, iinfo )
932 IF( iinfo.NE.0 )
THEN
933 WRITE( nounit, fmt = 9999 )
'CTREVC(L,S)', iinfo, n,
942 IF(
SELECT(
j ) )
THEN
944 IF( evectl( jj,
j ).NE.evectr( jj, k ) )
THEN
954 $
WRITE( nounit, fmt = 9997 )
'Left',
'CTREVC', n, jtype,
960 result( 11 ) = ulpinv
965 CALL
chsein(
'Right',
'Qr',
'Ninitv',
SELECT, n, h, lda, w3,
966 $ cdumma, ldu, evectx, ldu, n1, in, work, rwork,
967 $ iwork, iwork, iinfo )
968 IF( iinfo.NE.0 )
THEN
969 WRITE( nounit, fmt = 9999 )
'CHSEIN(R)', iinfo, n, jtype,
980 CALL
cget22(
'N',
'N',
'N', n, h, lda, evectx, ldu, w3,
981 $ work, rwork, dumma( 1 ) )
982 IF( dumma( 1 ).LT.ulpinv )
983 $ result( 11 ) = dumma( 1 )*aninv
984 IF( dumma( 2 ).GT.thresh )
THEN
985 WRITE( nounit, fmt = 9998 )
'Right',
'CHSEIN',
986 $ dumma( 2 ), n, jtype, ioldsd
993 result( 12 ) = ulpinv
998 CALL
chsein(
'Left',
'Qr',
'Ninitv',
SELECT, n, h, lda, w3,
999 $ evecty, ldu, cdumma, ldu, n1, in, work, rwork,
1000 $ iwork, iwork, iinfo )
1001 IF( iinfo.NE.0 )
THEN
1002 WRITE( nounit, fmt = 9999 )
'CHSEIN(L)', iinfo, n, jtype,
1013 CALL
cget22(
'C',
'N',
'C', n, h, lda, evecty, ldu, w3,
1014 $ work, rwork, dumma( 3 ) )
1015 IF( dumma( 3 ).LT.ulpinv )
1016 $ result( 12 ) = dumma( 3 )*aninv
1017 IF( dumma( 4 ).GT.thresh )
THEN
1018 WRITE( nounit, fmt = 9998 )
'Left',
'CHSEIN',
1019 $ dumma( 4 ), n, jtype, ioldsd
1026 result( 13 ) = ulpinv
1028 CALL
cunmhr(
'Left',
'No transpose', n, n, ilo, ihi, uu,
1029 $ ldu, tau, evectx, ldu, work, nwork, iinfo )
1030 IF( iinfo.NE.0 )
THEN
1031 WRITE( nounit, fmt = 9999 )
'CUNMHR(L)', iinfo, n, jtype,
1042 CALL
cget22(
'N',
'N',
'N', n, a, lda, evectx, ldu, w3,
1043 $ work, rwork, dumma( 1 ) )
1044 IF( dumma( 1 ).LT.ulpinv )
1045 $ result( 13 ) = dumma( 1 )*aninv
1051 result( 14 ) = ulpinv
1053 CALL
cunmhr(
'Left',
'No transpose', n, n, ilo, ihi, uu,
1054 $ ldu, tau, evecty, ldu, work, nwork, iinfo )
1055 IF( iinfo.NE.0 )
THEN
1056 WRITE( nounit, fmt = 9999 )
'CUNMHR(L)', iinfo, n, jtype,
1067 CALL
cget22(
'C',
'N',
'C', n, a, lda, evecty, ldu, w3,
1068 $ work, rwork, dumma( 3 ) )
1069 IF( dumma( 3 ).LT.ulpinv )
1070 $ result( 14 ) = dumma( 3 )*aninv
1077 ntestt = ntestt + ntest
1078 CALL
slafts(
'CHS', n, n, jtype, ntest, result, ioldsd,
1079 $ thresh, nounit, nerrs )
1086 CALL
slasum(
'CHS', nounit, nerrs, ntestt )
1090 9999
FORMAT(
' CCHKHS: ', a,
' returned INFO=', i6,
'.', / 9
x,
'N=',
1091 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
1092 9998
FORMAT(
' CCHKHS: ', a,
' Eigenvectors from ', a,
' incorrectly ',
1093 $
'normalized.', /
' Bits of error=', 0p, g10.3,
',', 9
x,
1094 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
1096 9997
FORMAT(
' CCHKHS: Selected ', a,
' Eigenvectors from ', a,
1097 $
' do not match other eigenvectors ', 9
x,
'N=', i6,
1098 $
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine clatmr(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, PACK, A, LDA, IWORK, INFO)
CLATMR
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
REAL function slamch(CMACH)
SLAMCH
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cget10(M, N, A, LDA, B, LDB, WORK, RWORK, RESULT)
CGET10
subroutine cunmhr(SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMHR
subroutine chst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RWORK, RESULT)
CHST01
subroutine clatme(N, DIST, ISEED, D, MODE, COND, DMAX, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
CLATME
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine chseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO)
CHSEQR
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine cgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
CGEHRD
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM
subroutine cget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, WORK, RWORK, RESULT)
CGET22
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cchkhs(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, W1, W3, EVECTL, EVECTR, EVECTY, EVECTX, UU, TAU, WORK, NWORK, RWORK, IWORK, SELECT, RESULT, INFO)
CCHKHS
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
subroutine ctrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
CTREVC
subroutine slafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
SLAFTS
subroutine chsein(SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO)
CHSEIN
subroutine cunghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
CUNGHR