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' )
531 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
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,
'.', / 9x,
'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,
',', 9x,
1094 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
1096 9997
FORMAT(
' CCHKHS: Selected ', a,
' Eigenvectors from ', a,
1097 $
' do not match other eigenvectors ', 9x,
'N=', i6,
1098 $
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
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 chseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO)
CHSEQR
subroutine ctrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
CTREVC
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 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 slafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
SLAFTS
subroutine chst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RWORK, RESULT)
CHST01
subroutine chsein(SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO)
CHSEIN
subroutine cunmhr(SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMHR
subroutine cget10(M, N, A, LDA, B, LDB, WORK, RWORK, RESULT)
CGET10
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
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 slabad(SMALL, LARGE)
SLABAD
subroutine cget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, WORK, RWORK, RESULT)
CGET22
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine cgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
CGEHRD
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
subroutine cunghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
CUNGHR