625
626
627
628
629
630
631 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
632 $ NSIZES, NTYPES
633 REAL THRESH
634
635
636 LOGICAL DOTYPE( * )
637 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
638 REAL D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
639 $ RESULT( * ), RWORK( * ), SD( * ), SE( * ),
640 $ WA1( * ), WA2( * ), WA3( * ), WR( * )
641 COMPLEX A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ),
642 $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * )
643
644
645
646
647
648 REAL ZERO, ONE, TWO, EIGHT, TEN, HUN
649 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
650 $ eight = 8.0e0, ten = 10.0e0, hun = 100.0e0 )
651 COMPLEX CZERO, CONE
652 parameter( czero = ( 0.0e+0, 0.0e+0 ),
653 $ cone = ( 1.0e+0, 0.0e+0 ) )
654 REAL HALF
655 parameter( half = one / two )
656 INTEGER MAXTYP
657 parameter( maxtyp = 21 )
658 LOGICAL CRANGE
659 parameter( crange = .false. )
660 LOGICAL CREL
661 parameter( crel = .false. )
662
663
664 LOGICAL BADNN, TRYRAC
665 INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP,
666 $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN,
667 $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3,
668 $ MTYPES, N, NAP, NBLOCK, NERRS, NMATS, NMAX,
669 $ NSPLIT, NTEST, NTESTT, LH, LW
670 REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
671 $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP,
672 $ ULPINV, UNFL, VL, VU
673
674
675 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
676 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
677 $ KTYPE( MAXTYP )
678 REAL DUMMA( 1 )
679
680
681 INTEGER ILAENV
682 REAL SLAMCH, SLARND, SSXT1
684
685
691
692
693 INTRINSIC abs, real, conjg, int, log, max, min, sqrt
694
695
696 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
697 $ 8, 8, 9, 9, 9, 9, 9, 10 /
698 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
699 $ 2, 3, 1, 1, 1, 2, 3, 1 /
700 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
701 $ 0, 0, 4, 3, 1, 4, 4, 3 /
702
703
704
705
706 idumma( 1 ) = 1
707
708
709
710 ntestt = 0
711 info = 0
712
713
714
715 badnn = .false.
716 tryrac = .true.
717 nmax = 1
718 DO 10 j = 1, nsizes
719 nmax = max( nmax, nn( j ) )
720 IF( nn( j ).LT.0 )
721 $ badnn = .true.
722 10 CONTINUE
723
724 nblock =
ilaenv( 1,
'CHETRD',
'L', nmax, -1, -1, -1 )
725 nblock = min( nmax, max( 1, nblock ) )
726
727
728
729 IF( nsizes.LT.0 ) THEN
730 info = -1
731 ELSE IF( badnn ) THEN
732 info = -2
733 ELSE IF( ntypes.LT.0 ) THEN
734 info = -3
735 ELSE IF( lda.LT.nmax ) THEN
736 info = -9
737 ELSE IF( ldu.LT.nmax ) THEN
738 info = -23
739 ELSE IF( 2*max( 2, nmax )**2.GT.lwork ) THEN
740 info = -29
741 END IF
742
743 IF( info.NE.0 ) THEN
744 CALL xerbla(
'CCHKST2STG', -info )
745 RETURN
746 END IF
747
748
749
750 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
751 $ RETURN
752
753
754
755 unfl =
slamch(
'Safe minimum' )
756 ovfl = one / unfl
758 ulpinv = one / ulp
759 log2ui = int( log( ulpinv ) / log( two ) )
760 rtunfl = sqrt( unfl )
761 rtovfl = sqrt( ovfl )
762
763
764
765 DO 20 i = 1, 4
766 iseed2( i ) = iseed( i )
767 20 CONTINUE
768 nerrs = 0
769 nmats = 0
770
771 DO 310 jsize = 1, nsizes
772 n = nn( jsize )
773 IF( n.GT.0 ) THEN
774 lgn = int( log( real( n ) ) / log( two ) )
775 IF( 2**lgn.LT.n )
776 $ lgn = lgn + 1
777 IF( 2**lgn.LT.n )
778 $ lgn = lgn + 1
779 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
780 lrwedc = 1 + 3*n + 2*n*lgn + 4*n**2
781 liwedc = 6 + 6*n + 5*n*lgn
782 ELSE
783 lwedc = 8
784 lrwedc = 7
785 liwedc = 12
786 END IF
787 nap = ( n*( n+1 ) ) / 2
788 aninv = one / real( max( 1, n ) )
789
790 IF( nsizes.NE.1 ) THEN
791 mtypes = min( maxtyp, ntypes )
792 ELSE
793 mtypes = min( maxtyp+1, ntypes )
794 END IF
795
796 DO 300 jtype = 1, mtypes
797 IF( .NOT.dotype( jtype ) )
798 $ GO TO 300
799 nmats = nmats + 1
800 ntest = 0
801
802 DO 30 j = 1, 4
803 ioldsd( j ) = iseed( j )
804 30 CONTINUE
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822 IF( mtypes.GT.maxtyp )
823 $ GO TO 100
824
825 itype = ktype( jtype )
826 imode = kmode( jtype )
827
828
829
830 GO TO ( 40, 50, 60 )kmagn( jtype )
831
832 40 CONTINUE
833 anorm = one
834 GO TO 70
835
836 50 CONTINUE
837 anorm = ( rtovfl*ulp )*aninv
838 GO TO 70
839
840 60 CONTINUE
841 anorm = rtunfl*n*ulpinv
842 GO TO 70
843
844 70 CONTINUE
845
846 CALL claset(
'Full', lda, n, czero, czero, a, lda )
847 iinfo = 0
848 IF( jtype.LE.15 ) THEN
849 cond = ulpinv
850 ELSE
851 cond = ulpinv*aninv / ten
852 END IF
853
854
855
856
857
858 IF( itype.EQ.1 ) THEN
859 iinfo = 0
860
861 ELSE IF( itype.EQ.2 ) THEN
862
863
864
865 DO 80 jc = 1, n
866 a( jc, jc ) = anorm
867 80 CONTINUE
868
869 ELSE IF( itype.EQ.4 ) THEN
870
871
872
873 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
874 $ anorm, 0, 0, 'N', a, lda, work, iinfo )
875
876
877 ELSE IF( itype.EQ.5 ) THEN
878
879
880
881 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
882 $ anorm, n, n, 'N', a, lda, work, iinfo )
883
884 ELSE IF( itype.EQ.7 ) THEN
885
886
887
888 CALL clatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
889 $ 'T', 'N', work( n+1 ), 1, one,
890 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
891 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
892
893 ELSE IF( itype.EQ.8 ) THEN
894
895
896
897 CALL clatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
898 $ 'T', 'N', work( n+1 ), 1, one,
899 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
900 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
901
902 ELSE IF( itype.EQ.9 ) THEN
903
904
905
906 CALL clatms( n, n,
'S', iseed,
'P', rwork, imode, cond,
907 $ anorm, n, n, 'N', a, lda, work, iinfo )
908
909 ELSE IF( itype.EQ.10 ) THEN
910
911
912
913 CALL clatms( n, n,
'S', iseed,
'P', rwork, imode, cond,
914 $ anorm, 1, 1, 'N', a, lda, work, iinfo )
915 DO 90 i = 2, n
916 temp1 = abs( a( i-1, i ) )
917 temp2 = sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
918 IF( temp1.GT.half*temp2 ) THEN
919 a( i-1, i ) = a( i-1, i )*
920 $ ( half*temp2 / ( unfl+temp1 ) )
921 a( i, i-1 ) = conjg( a( i-1, i ) )
922 END IF
923 90 CONTINUE
924
925 ELSE
926
927 iinfo = 1
928 END IF
929
930 IF( iinfo.NE.0 ) THEN
931 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
932 $ ioldsd
933 info = abs( iinfo )
934 RETURN
935 END IF
936
937 100 CONTINUE
938
939
940
941
942 CALL clacpy(
'U', n, n, a, lda, v, ldu )
943
944 ntest = 1
945 CALL chetrd(
'U', n, v, ldu, sd, se, tau, work, lwork,
946 $ iinfo )
947
948 IF( iinfo.NE.0 ) THEN
949 WRITE( nounit, fmt = 9999 )'CHETRD(U)', iinfo, n, jtype,
950 $ ioldsd
951 info = abs( iinfo )
952 IF( iinfo.LT.0 ) THEN
953 RETURN
954 ELSE
955 result( 1 ) = ulpinv
956 GO TO 280
957 END IF
958 END IF
959
960 CALL clacpy(
'U', n, n, v, ldu, u, ldu )
961
962 ntest = 2
963 CALL cungtr(
'U', n, u, ldu, tau, work, lwork, iinfo )
964 IF( iinfo.NE.0 ) THEN
965 WRITE( nounit, fmt = 9999 )'CUNGTR(U)', iinfo, n, jtype,
966 $ ioldsd
967 info = abs( iinfo )
968 IF( iinfo.LT.0 ) THEN
969 RETURN
970 ELSE
971 result( 2 ) = ulpinv
972 GO TO 280
973 END IF
974 END IF
975
976
977
978 CALL chet21( 2,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
979 $ ldu, tau, work, rwork, result( 1 ) )
980 CALL chet21( 3,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
981 $ ldu, tau, work, rwork, result( 2 ) )
982
983
984
985
986
987
988
989
990 CALL scopy( n, sd, 1, d1, 1 )
991 IF( n.GT.0 )
992 $
CALL scopy( n-1, se, 1, rwork, 1 )
993
994 CALL csteqr(
'N', n, d1, rwork, work, ldu, rwork( n+1 ),
995 $ iinfo )
996 IF( iinfo.NE.0 ) THEN
997 WRITE( nounit, fmt = 9999 )'CSTEQR(N)', iinfo, n, jtype,
998 $ ioldsd
999 info = abs( iinfo )
1000 IF( iinfo.LT.0 ) THEN
1001 RETURN
1002 ELSE
1003 result( 3 ) = ulpinv
1004 GO TO 280
1005 END IF
1006 END IF
1007
1008
1009
1010
1011
1012
1013 CALL slaset(
'Full', n, 1, zero, zero, sd, n )
1014 CALL slaset(
'Full', n, 1, zero, zero, se, n )
1015 CALL clacpy(
'U', n, n, a, lda, v, ldu )
1016 lh = max(1, 4*n)
1017 lw = lwork - lh
1019 $ work, lh, work( lh+1 ), lw, iinfo )
1020
1021
1022
1023 CALL scopy( n, sd, 1, d2, 1 )
1024 IF( n.GT.0 )
1025 $
CALL scopy( n-1, se, 1, rwork, 1 )
1026
1027 ntest = 3
1028 CALL csteqr(
'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1029 $ iinfo )
1030 IF( iinfo.NE.0 ) THEN
1031 WRITE( nounit, fmt = 9999 )'CSTEQR(N)', iinfo, n, jtype,
1032 $ ioldsd
1033 info = abs( iinfo )
1034 IF( iinfo.LT.0 ) THEN
1035 RETURN
1036 ELSE
1037 result( 3 ) = ulpinv
1038 GO TO 280
1039 END IF
1040 END IF
1041
1042
1043
1044
1045
1046
1047 CALL slaset(
'Full', n, 1, zero, zero, sd, n )
1048 CALL slaset(
'Full', n, 1, zero, zero, se, n )
1049 CALL clacpy(
'L', n, n, a, lda, v, ldu )
1051 $ work, lh, work( lh+1 ), lw, iinfo )
1052
1053
1054
1055 CALL scopy( n, sd, 1, d3, 1 )
1056 IF( n.GT.0 )
1057 $
CALL scopy( n-1, se, 1, rwork, 1 )
1058
1059 ntest = 4
1060 CALL csteqr(
'N', n, d3, rwork, work, ldu, rwork( n+1 ),
1061 $ iinfo )
1062 IF( iinfo.NE.0 ) THEN
1063 WRITE( nounit, fmt = 9999 )'CSTEQR(N)', iinfo, n, jtype,
1064 $ ioldsd
1065 info = abs( iinfo )
1066 IF( iinfo.LT.0 ) THEN
1067 RETURN
1068 ELSE
1069 result( 4 ) = ulpinv
1070 GO TO 280
1071 END IF
1072 END IF
1073
1074
1075
1076
1077 ntest = 4
1078 temp1 = zero
1079 temp2 = zero
1080 temp3 = zero
1081 temp4 = zero
1082
1083 DO 151 j = 1, n
1084 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1085 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1086 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1087 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1088 151 CONTINUE
1089
1090 result( 3 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1091 result( 4 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1092
1093
1094
1095 i = 0
1096 DO 120 jc = 1, n
1097 DO 110 jr = 1, jc
1098 i = i + 1
1099 ap( i ) = a( jr, jc )
1100 110 CONTINUE
1101 120 CONTINUE
1102
1103
1104
1105 CALL ccopy( nap, ap, 1, vp, 1 )
1106
1107 ntest = 5
1108 CALL chptrd(
'U', n, vp, sd, se, tau, iinfo )
1109
1110 IF( iinfo.NE.0 ) THEN
1111 WRITE( nounit, fmt = 9999 )'CHPTRD(U)', iinfo, n, jtype,
1112 $ ioldsd
1113 info = abs( iinfo )
1114 IF( iinfo.LT.0 ) THEN
1115 RETURN
1116 ELSE
1117 result( 5 ) = ulpinv
1118 GO TO 280
1119 END IF
1120 END IF
1121
1122 ntest = 6
1123 CALL cupgtr(
'U', n, vp, tau, u, ldu, work, iinfo )
1124 IF( iinfo.NE.0 ) THEN
1125 WRITE( nounit, fmt = 9999 )'CUPGTR(U)', iinfo, n, jtype,
1126 $ ioldsd
1127 info = abs( iinfo )
1128 IF( iinfo.LT.0 ) THEN
1129 RETURN
1130 ELSE
1131 result( 6 ) = ulpinv
1132 GO TO 280
1133 END IF
1134 END IF
1135
1136
1137
1138 CALL chpt21( 2,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1139 $ work, rwork, result( 5 ) )
1140 CALL chpt21( 3,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1141 $ work, rwork, result( 6 ) )
1142
1143
1144
1145 i = 0
1146 DO 140 jc = 1, n
1147 DO 130 jr = jc, n
1148 i = i + 1
1149 ap( i ) = a( jr, jc )
1150 130 CONTINUE
1151 140 CONTINUE
1152
1153
1154
1155 CALL ccopy( nap, ap, 1, vp, 1 )
1156
1157 ntest = 7
1158 CALL chptrd(
'L', n, vp, sd, se, tau, iinfo )
1159
1160 IF( iinfo.NE.0 ) THEN
1161 WRITE( nounit, fmt = 9999 )'CHPTRD(L)', iinfo, n, jtype,
1162 $ ioldsd
1163 info = abs( iinfo )
1164 IF( iinfo.LT.0 ) THEN
1165 RETURN
1166 ELSE
1167 result( 7 ) = ulpinv
1168 GO TO 280
1169 END IF
1170 END IF
1171
1172 ntest = 8
1173 CALL cupgtr(
'L', n, vp, tau, u, ldu, work, iinfo )
1174 IF( iinfo.NE.0 ) THEN
1175 WRITE( nounit, fmt = 9999 )'CUPGTR(L)', iinfo, n, jtype,
1176 $ ioldsd
1177 info = abs( iinfo )
1178 IF( iinfo.LT.0 ) THEN
1179 RETURN
1180 ELSE
1181 result( 8 ) = ulpinv
1182 GO TO 280
1183 END IF
1184 END IF
1185
1186 CALL chpt21( 2,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1187 $ work, rwork, result( 7 ) )
1188 CALL chpt21( 3,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1189 $ work, rwork, result( 8 ) )
1190
1191
1192
1193
1194
1195 CALL scopy( n, sd, 1, d1, 1 )
1196 IF( n.GT.0 )
1197 $
CALL scopy( n-1, se, 1, rwork, 1 )
1198 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1199
1200 ntest = 9
1201 CALL csteqr(
'V', n, d1, rwork, z, ldu, rwork( n+1 ),
1202 $ iinfo )
1203 IF( iinfo.NE.0 ) THEN
1204 WRITE( nounit, fmt = 9999 )'CSTEQR(V)', iinfo, n, jtype,
1205 $ ioldsd
1206 info = abs( iinfo )
1207 IF( iinfo.LT.0 ) THEN
1208 RETURN
1209 ELSE
1210 result( 9 ) = ulpinv
1211 GO TO 280
1212 END IF
1213 END IF
1214
1215
1216
1217 CALL scopy( n, sd, 1, d2, 1 )
1218 IF( n.GT.0 )
1219 $
CALL scopy( n-1, se, 1, rwork, 1 )
1220
1221 ntest = 11
1222 CALL csteqr(
'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1223 $ iinfo )
1224 IF( iinfo.NE.0 ) THEN
1225 WRITE( nounit, fmt = 9999 )'CSTEQR(N)', iinfo, n, jtype,
1226 $ ioldsd
1227 info = abs( iinfo )
1228 IF( iinfo.LT.0 ) THEN
1229 RETURN
1230 ELSE
1231 result( 11 ) = ulpinv
1232 GO TO 280
1233 END IF
1234 END IF
1235
1236
1237
1238 CALL scopy( n, sd, 1, d3, 1 )
1239 IF( n.GT.0 )
1240 $
CALL scopy( n-1, se, 1, rwork, 1 )
1241
1242 ntest = 12
1243 CALL ssterf( n, d3, rwork, iinfo )
1244 IF( iinfo.NE.0 ) THEN
1245 WRITE( nounit, fmt = 9999 )'SSTERF', iinfo, n, jtype,
1246 $ ioldsd
1247 info = abs( iinfo )
1248 IF( iinfo.LT.0 ) THEN
1249 RETURN
1250 ELSE
1251 result( 12 ) = ulpinv
1252 GO TO 280
1253 END IF
1254 END IF
1255
1256
1257
1258 CALL cstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1259 $ result( 9 ) )
1260
1261
1262
1263 temp1 = zero
1264 temp2 = zero
1265 temp3 = zero
1266 temp4 = zero
1267
1268 DO 150 j = 1, n
1269 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1270 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1271 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1272 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1273 150 CONTINUE
1274
1275 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1276 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1277
1278
1279
1280
1281 ntest = 13
1282 temp1 = thresh*( half-ulp )
1283
1284 DO 160 j = 0, log2ui
1285 CALL sstech( n, sd, se, d1, temp1, rwork, iinfo )
1286 IF( iinfo.EQ.0 )
1287 $ GO TO 170
1288 temp1 = temp1*two
1289 160 CONTINUE
1290
1291 170 CONTINUE
1292 result( 13 ) = temp1
1293
1294
1295
1296
1297 IF( jtype.GT.15 ) THEN
1298
1299
1300
1301 CALL scopy( n, sd, 1, d4, 1 )
1302 IF( n.GT.0 )
1303 $
CALL scopy( n-1, se, 1, rwork, 1 )
1304 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1305
1306 ntest = 14
1307 CALL cpteqr(
'V', n, d4, rwork, z, ldu, rwork( n+1 ),
1308 $ iinfo )
1309 IF( iinfo.NE.0 ) THEN
1310 WRITE( nounit, fmt = 9999 )'CPTEQR(V)', iinfo, n,
1311 $ jtype, ioldsd
1312 info = abs( iinfo )
1313 IF( iinfo.LT.0 ) THEN
1314 RETURN
1315 ELSE
1316 result( 14 ) = ulpinv
1317 GO TO 280
1318 END IF
1319 END IF
1320
1321
1322
1323 CALL cstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1324 $ rwork, result( 14 ) )
1325
1326
1327
1328 CALL scopy( n, sd, 1, d5, 1 )
1329 IF( n.GT.0 )
1330 $
CALL scopy( n-1, se, 1, rwork, 1 )
1331
1332 ntest = 16
1333 CALL cpteqr(
'N', n, d5, rwork, z, ldu, rwork( n+1 ),
1334 $ iinfo )
1335 IF( iinfo.NE.0 ) THEN
1336 WRITE( nounit, fmt = 9999 )'CPTEQR(N)', iinfo, n,
1337 $ jtype, ioldsd
1338 info = abs( iinfo )
1339 IF( iinfo.LT.0 ) THEN
1340 RETURN
1341 ELSE
1342 result( 16 ) = ulpinv
1343 GO TO 280
1344 END IF
1345 END IF
1346
1347
1348
1349 temp1 = zero
1350 temp2 = zero
1351 DO 180 j = 1, n
1352 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1353 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1354 180 CONTINUE
1355
1356 result( 16 ) = temp2 / max( unfl,
1357 $ hun*ulp*max( temp1, temp2 ) )
1358 ELSE
1359 result( 14 ) = zero
1360 result( 15 ) = zero
1361 result( 16 ) = zero
1362 END IF
1363
1364
1365
1366
1367
1368
1369 vl = zero
1370 vu = zero
1371 il = 0
1372 iu = 0
1373 IF( jtype.EQ.21 ) THEN
1374 ntest = 17
1375 abstol = unfl + unfl
1376 CALL sstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se,
1377 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1378 $ rwork, iwork( 2*n+1 ), iinfo )
1379 IF( iinfo.NE.0 ) THEN
1380 WRITE( nounit, fmt = 9999 )'SSTEBZ(A,rel)', iinfo, n,
1381 $ jtype, ioldsd
1382 info = abs( iinfo )
1383 IF( iinfo.LT.0 ) THEN
1384 RETURN
1385 ELSE
1386 result( 17 ) = ulpinv
1387 GO TO 280
1388 END IF
1389 END IF
1390
1391
1392
1393 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1394 $ ( one-half )**4
1395
1396 temp1 = zero
1397 DO 190 j = 1, n
1398 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1399 $ ( abstol+abs( d4( j ) ) ) )
1400 190 CONTINUE
1401
1402 result( 17 ) = temp1 / temp2
1403 ELSE
1404 result( 17 ) = zero
1405 END IF
1406
1407
1408
1409 ntest = 18
1410 abstol = unfl + unfl
1411 CALL sstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se, m,
1412 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1413 $ iwork( 2*n+1 ), iinfo )
1414 IF( iinfo.NE.0 ) THEN
1415 WRITE( nounit, fmt = 9999 )'SSTEBZ(A)', iinfo, n, jtype,
1416 $ ioldsd
1417 info = abs( iinfo )
1418 IF( iinfo.LT.0 ) THEN
1419 RETURN
1420 ELSE
1421 result( 18 ) = ulpinv
1422 GO TO 280
1423 END IF
1424 END IF
1425
1426
1427
1428 temp1 = zero
1429 temp2 = zero
1430 DO 200 j = 1, n
1431 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1432 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1433 200 CONTINUE
1434
1435 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1436
1437
1438
1439
1440 ntest = 19
1441 IF( n.LE.1 ) THEN
1442 il = 1
1443 iu = n
1444 ELSE
1445 il = 1 + ( n-1 )*int(
slarnd( 1, iseed2 ) )
1446 iu = 1 + ( n-1 )*int(
slarnd( 1, iseed2 ) )
1447 IF( iu.LT.il ) THEN
1448 itemp = iu
1449 iu = il
1450 il = itemp
1451 END IF
1452 END IF
1453
1454 CALL sstebz(
'I',
'E', n, vl, vu, il, iu, abstol, sd, se,
1455 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1456 $ rwork, iwork( 2*n+1 ), iinfo )
1457 IF( iinfo.NE.0 ) THEN
1458 WRITE( nounit, fmt = 9999 )'SSTEBZ(I)', iinfo, n, jtype,
1459 $ ioldsd
1460 info = abs( iinfo )
1461 IF( iinfo.LT.0 ) THEN
1462 RETURN
1463 ELSE
1464 result( 19 ) = ulpinv
1465 GO TO 280
1466 END IF
1467 END IF
1468
1469
1470
1471
1472 IF( n.GT.0 ) THEN
1473 IF( il.NE.1 ) THEN
1474 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1475 $ ulp*anorm, two*rtunfl )
1476 ELSE
1477 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1478 $ ulp*anorm, two*rtunfl )
1479 END IF
1480 IF( iu.NE.n ) THEN
1481 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1482 $ ulp*anorm, two*rtunfl )
1483 ELSE
1484 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1485 $ ulp*anorm, two*rtunfl )
1486 END IF
1487 ELSE
1488 vl = zero
1489 vu = one
1490 END IF
1491
1492 CALL sstebz(
'V',
'E', n, vl, vu, il, iu, abstol, sd, se,
1493 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1494 $ rwork, iwork( 2*n+1 ), iinfo )
1495 IF( iinfo.NE.0 ) THEN
1496 WRITE( nounit, fmt = 9999 )'SSTEBZ(V)', iinfo, n, jtype,
1497 $ ioldsd
1498 info = abs( iinfo )
1499 IF( iinfo.LT.0 ) THEN
1500 RETURN
1501 ELSE
1502 result( 19 ) = ulpinv
1503 GO TO 280
1504 END IF
1505 END IF
1506
1507 IF( m3.EQ.0 .AND. n.NE.0 ) THEN
1508 result( 19 ) = ulpinv
1509 GO TO 280
1510 END IF
1511
1512
1513
1514 temp1 =
ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1515 temp2 =
ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1516 IF( n.GT.0 ) THEN
1517 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1518 ELSE
1519 temp3 = zero
1520 END IF
1521
1522 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1523
1524
1525
1526
1527
1528 ntest = 21
1529 CALL sstebz(
'A',
'B', n, vl, vu, il, iu, abstol, sd, se, m,
1530 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1531 $ iwork( 2*n+1 ), iinfo )
1532 IF( iinfo.NE.0 ) THEN
1533 WRITE( nounit, fmt = 9999 )'SSTEBZ(A,B)', iinfo, n,
1534 $ jtype, ioldsd
1535 info = abs( iinfo )
1536 IF( iinfo.LT.0 ) THEN
1537 RETURN
1538 ELSE
1539 result( 20 ) = ulpinv
1540 result( 21 ) = ulpinv
1541 GO TO 280
1542 END IF
1543 END IF
1544
1545 CALL cstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1546 $ ldu, rwork, iwork( 2*n+1 ), iwork( 3*n+1 ),
1547 $ iinfo )
1548 IF( iinfo.NE.0 ) THEN
1549 WRITE( nounit, fmt = 9999 )'CSTEIN', iinfo, n, jtype,
1550 $ ioldsd
1551 info = abs( iinfo )
1552 IF( iinfo.LT.0 ) THEN
1553 RETURN
1554 ELSE
1555 result( 20 ) = ulpinv
1556 result( 21 ) = ulpinv
1557 GO TO 280
1558 END IF
1559 END IF
1560
1561
1562
1563 CALL cstt21( n, 0, sd, se, wa1, dumma, z, ldu, work, rwork,
1564 $ result( 20 ) )
1565
1566
1567
1568
1569
1570 inde = 1
1571 indrwk = inde + n
1572 CALL scopy( n, sd, 1, d1, 1 )
1573 IF( n.GT.0 )
1574 $
CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1575 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1576
1577 ntest = 22
1578 CALL cstedc(
'I', n, d1, rwork( inde ), z, ldu, work, lwedc,
1579 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1580 IF( iinfo.NE.0 ) THEN
1581 WRITE( nounit, fmt = 9999 )'CSTEDC(I)', iinfo, n, jtype,
1582 $ ioldsd
1583 info = abs( iinfo )
1584 IF( iinfo.LT.0 ) THEN
1585 RETURN
1586 ELSE
1587 result( 22 ) = ulpinv
1588 GO TO 280
1589 END IF
1590 END IF
1591
1592
1593
1594 CALL cstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1595 $ result( 22 ) )
1596
1597
1598
1599
1600
1601 CALL scopy( n, sd, 1, d1, 1 )
1602 IF( n.GT.0 )
1603 $
CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1604 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1605
1606 ntest = 24
1607 CALL cstedc(
'V', n, d1, rwork( inde ), z, ldu, work, lwedc,
1608 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1609 IF( iinfo.NE.0 ) THEN
1610 WRITE( nounit, fmt = 9999 )'CSTEDC(V)', iinfo, n, jtype,
1611 $ ioldsd
1612 info = abs( iinfo )
1613 IF( iinfo.LT.0 ) THEN
1614 RETURN
1615 ELSE
1616 result( 24 ) = ulpinv
1617 GO TO 280
1618 END IF
1619 END IF
1620
1621
1622
1623 CALL cstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1624 $ result( 24 ) )
1625
1626
1627
1628
1629
1630 CALL scopy( n, sd, 1, d2, 1 )
1631 IF( n.GT.0 )
1632 $
CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1633 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1634
1635 ntest = 26
1636 CALL cstedc(
'N', n, d2, rwork( inde ), z, ldu, work, lwedc,
1637 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1638 IF( iinfo.NE.0 ) THEN
1639 WRITE( nounit, fmt = 9999 )'CSTEDC(N)', iinfo, n, jtype,
1640 $ ioldsd
1641 info = abs( iinfo )
1642 IF( iinfo.LT.0 ) THEN
1643 RETURN
1644 ELSE
1645 result( 26 ) = ulpinv
1646 GO TO 280
1647 END IF
1648 END IF
1649
1650
1651
1652 temp1 = zero
1653 temp2 = zero
1654
1655 DO 210 j = 1, n
1656 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1657 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1658 210 CONTINUE
1659
1660 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1661
1662
1663
1664 IF(
ilaenv( 10,
'CSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1665 $
ilaenv( 11,
'CSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 )
THEN
1666
1667
1668
1669
1670
1671
1672 vl = zero
1673 vu = zero
1674 il = 0
1675 iu = 0
1676 IF( jtype.EQ.21 .AND. crel ) THEN
1677 ntest = 27
1678 abstol = unfl + unfl
1679 CALL cstemr(
'V',
'A', n, sd, se, vl, vu, il, iu,
1680 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1681 $ rwork, lrwork, iwork( 2*n+1 ), lwork-2*n,
1682 $ iinfo )
1683 IF( iinfo.NE.0 ) THEN
1684 WRITE( nounit, fmt = 9999 )'CSTEMR(V,A,rel)',
1685 $ iinfo, n, jtype, ioldsd
1686 info = abs( iinfo )
1687 IF( iinfo.LT.0 ) THEN
1688 RETURN
1689 ELSE
1690 result( 27 ) = ulpinv
1691 GO TO 270
1692 END IF
1693 END IF
1694
1695
1696
1697 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1698 $ ( one-half )**4
1699
1700 temp1 = zero
1701 DO 220 j = 1, n
1702 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1703 $ ( abstol+abs( d4( j ) ) ) )
1704 220 CONTINUE
1705
1706 result( 27 ) = temp1 / temp2
1707
1708 il = 1 + ( n-1 )*int(
slarnd( 1, iseed2 ) )
1709 iu = 1 + ( n-1 )*int(
slarnd( 1, iseed2 ) )
1710 IF( iu.LT.il ) THEN
1711 itemp = iu
1712 iu = il
1713 il = itemp
1714 END IF
1715
1716 IF( crange ) THEN
1717 ntest = 28
1718 abstol = unfl + unfl
1719 CALL cstemr(
'V',
'I', n, sd, se, vl, vu, il, iu,
1720 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1721 $ rwork, lrwork, iwork( 2*n+1 ),
1722 $ lwork-2*n, iinfo )
1723
1724 IF( iinfo.NE.0 ) THEN
1725 WRITE( nounit, fmt = 9999 )'CSTEMR(V,I,rel)',
1726 $ iinfo, n, jtype, ioldsd
1727 info = abs( iinfo )
1728 IF( iinfo.LT.0 ) THEN
1729 RETURN
1730 ELSE
1731 result( 28 ) = ulpinv
1732 GO TO 270
1733 END IF
1734 END IF
1735
1736
1737
1738 temp2 = two*( two*n-one )*ulp*
1739 $ ( one+eight*half**2 ) / ( one-half )**4
1740
1741 temp1 = zero
1742 DO 230 j = il, iu
1743 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1744 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1745 230 CONTINUE
1746
1747 result( 28 ) = temp1 / temp2
1748 ELSE
1749 result( 28 ) = zero
1750 END IF
1751 ELSE
1752 result( 27 ) = zero
1753 result( 28 ) = zero
1754 END IF
1755
1756
1757
1758
1759
1760 CALL scopy( n, sd, 1, d5, 1 )
1761 IF( n.GT.0 )
1762 $
CALL scopy( n-1, se, 1, rwork, 1 )
1763 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1764
1765 IF( crange ) THEN
1766 ntest = 29
1767 il = 1 + ( n-1 )*int(
slarnd( 1, iseed2 ) )
1768 iu = 1 + ( n-1 )*int(
slarnd( 1, iseed2 ) )
1769 IF( iu.LT.il ) THEN
1770 itemp = iu
1771 iu = il
1772 il = itemp
1773 END IF
1774 CALL cstemr(
'V',
'I', n, d5, rwork, vl, vu, il, iu,
1775 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1776 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1777 $ liwork-2*n, iinfo )
1778 IF( iinfo.NE.0 ) THEN
1779 WRITE( nounit, fmt = 9999 )'CSTEMR(V,I)', iinfo,
1780 $ n, jtype, ioldsd
1781 info = abs( iinfo )
1782 IF( iinfo.LT.0 ) THEN
1783 RETURN
1784 ELSE
1785 result( 29 ) = ulpinv
1786 GO TO 280
1787 END IF
1788 END IF
1789
1790
1791
1792
1793
1794
1795
1796 CALL scopy( n, sd, 1, d5, 1 )
1797 IF( n.GT.0 )
1798 $
CALL scopy( n-1, se, 1, rwork, 1 )
1799
1800 ntest = 31
1801 CALL cstemr(
'N',
'I', n, d5, rwork, vl, vu, il, iu,
1802 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1803 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1804 $ liwork-2*n, iinfo )
1805 IF( iinfo.NE.0 ) THEN
1806 WRITE( nounit, fmt = 9999 )'CSTEMR(N,I)', iinfo,
1807 $ n, jtype, ioldsd
1808 info = abs( iinfo )
1809 IF( iinfo.LT.0 ) THEN
1810 RETURN
1811 ELSE
1812 result( 31 ) = ulpinv
1813 GO TO 280
1814 END IF
1815 END IF
1816
1817
1818
1819 temp1 = zero
1820 temp2 = zero
1821
1822 DO 240 j = 1, iu - il + 1
1823 temp1 = max( temp1, abs( d1( j ) ),
1824 $ abs( d2( j ) ) )
1825 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1826 240 CONTINUE
1827
1828 result( 31 ) = temp2 / max( unfl,
1829 $ ulp*max( temp1, temp2 ) )
1830
1831
1832
1833
1834
1835 CALL scopy( n, sd, 1, d5, 1 )
1836 IF( n.GT.0 )
1837 $
CALL scopy( n-1, se, 1, rwork, 1 )
1838 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1839
1840 ntest = 32
1841
1842 IF( n.GT.0 ) THEN
1843 IF( il.NE.1 ) THEN
1844 vl = d2( il ) - max( half*
1845 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1846 $ two*rtunfl )
1847 ELSE
1848 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1849 $ ulp*anorm, two*rtunfl )
1850 END IF
1851 IF( iu.NE.n ) THEN
1852 vu = d2( iu ) + max( half*
1853 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1854 $ two*rtunfl )
1855 ELSE
1856 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1857 $ ulp*anorm, two*rtunfl )
1858 END IF
1859 ELSE
1860 vl = zero
1861 vu = one
1862 END IF
1863
1864 CALL cstemr(
'V',
'V', n, d5, rwork, vl, vu, il, iu,
1865 $ m, d1, z, ldu, m, iwork( 1 ), tryrac,
1866 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1867 $ liwork-2*n, iinfo )
1868 IF( iinfo.NE.0 ) THEN
1869 WRITE( nounit, fmt = 9999 )'CSTEMR(V,V)', iinfo,
1870 $ n, jtype, ioldsd
1871 info = abs( iinfo )
1872 IF( iinfo.LT.0 ) THEN
1873 RETURN
1874 ELSE
1875 result( 32 ) = ulpinv
1876 GO TO 280
1877 END IF
1878 END IF
1879
1880
1881
1882 CALL cstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1883 $ m, rwork, result( 32 ) )
1884
1885
1886
1887
1888
1889 CALL scopy( n, sd, 1, d5, 1 )
1890 IF( n.GT.0 )
1891 $
CALL scopy( n-1, se, 1, rwork, 1 )
1892
1893 ntest = 34
1894 CALL cstemr(
'N',
'V', n, d5, rwork, vl, vu, il, iu,
1895 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1896 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1897 $ liwork-2*n, iinfo )
1898 IF( iinfo.NE.0 ) THEN
1899 WRITE( nounit, fmt = 9999 )'CSTEMR(N,V)', iinfo,
1900 $ n, jtype, ioldsd
1901 info = abs( iinfo )
1902 IF( iinfo.LT.0 ) THEN
1903 RETURN
1904 ELSE
1905 result( 34 ) = ulpinv
1906 GO TO 280
1907 END IF
1908 END IF
1909
1910
1911
1912 temp1 = zero
1913 temp2 = zero
1914
1915 DO 250 j = 1, iu - il + 1
1916 temp1 = max( temp1, abs( d1( j ) ),
1917 $ abs( d2( j ) ) )
1918 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1919 250 CONTINUE
1920
1921 result( 34 ) = temp2 / max( unfl,
1922 $ ulp*max( temp1, temp2 ) )
1923 ELSE
1924 result( 29 ) = zero
1925 result( 30 ) = zero
1926 result( 31 ) = zero
1927 result( 32 ) = zero
1928 result( 33 ) = zero
1929 result( 34 ) = zero
1930 END IF
1931
1932
1933
1934
1935
1936 CALL scopy( n, sd, 1, d5, 1 )
1937 IF( n.GT.0 )
1938 $
CALL scopy( n-1, se, 1, rwork, 1 )
1939
1940 ntest = 35
1941
1942 CALL cstemr(
'V',
'A', n, d5, rwork, vl, vu, il, iu,
1943 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1944 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1945 $ liwork-2*n, iinfo )
1946 IF( iinfo.NE.0 ) THEN
1947 WRITE( nounit, fmt = 9999 )'CSTEMR(V,A)', iinfo, n,
1948 $ jtype, ioldsd
1949 info = abs( iinfo )
1950 IF( iinfo.LT.0 ) THEN
1951 RETURN
1952 ELSE
1953 result( 35 ) = ulpinv
1954 GO TO 280
1955 END IF
1956 END IF
1957
1958
1959
1960 CALL cstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1961 $ rwork, result( 35 ) )
1962
1963
1964
1965
1966
1967 CALL scopy( n, sd, 1, d5, 1 )
1968 IF( n.GT.0 )
1969 $
CALL scopy( n-1, se, 1, rwork, 1 )
1970
1971 ntest = 37
1972 CALL cstemr(
'N',
'A', n, d5, rwork, vl, vu, il, iu,
1973 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1974 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1975 $ liwork-2*n, iinfo )
1976 IF( iinfo.NE.0 ) THEN
1977 WRITE( nounit, fmt = 9999 )'CSTEMR(N,A)', iinfo, n,
1978 $ jtype, ioldsd
1979 info = abs( iinfo )
1980 IF( iinfo.LT.0 ) THEN
1981 RETURN
1982 ELSE
1983 result( 37 ) = ulpinv
1984 GO TO 280
1985 END IF
1986 END IF
1987
1988
1989
1990 temp1 = zero
1991 temp2 = zero
1992
1993 DO 260 j = 1, n
1994 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1995 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1996 260 CONTINUE
1997
1998 result( 37 ) = temp2 / max( unfl,
1999 $ ulp*max( temp1, temp2 ) )
2000 END IF
2001 270 CONTINUE
2002 280 CONTINUE
2003 ntestt = ntestt + ntest
2004
2005
2006
2007
2008
2009 DO 290 jr = 1, ntest
2010 IF( result( jr ).GE.thresh ) THEN
2011
2012
2013
2014
2015 IF( nerrs.EQ.0 ) THEN
2016 WRITE( nounit, fmt = 9998 )'CST'
2017 WRITE( nounit, fmt = 9997 )
2018 WRITE( nounit, fmt = 9996 )
2019 WRITE( nounit, fmt = 9995 )'Hermitian'
2020 WRITE( nounit, fmt = 9994 )
2021
2022
2023
2024 WRITE( nounit, fmt = 9987 )
2025 END IF
2026 nerrs = nerrs + 1
2027 IF( result( jr ).LT.10000.0e0 ) THEN
2028 WRITE( nounit, fmt = 9989 )n, jtype, ioldsd, jr,
2029 $ result( jr )
2030 ELSE
2031 WRITE( nounit, fmt = 9988 )n, jtype, ioldsd, jr,
2032 $ result( jr )
2033 END IF
2034 END IF
2035 290 CONTINUE
2036 300 CONTINUE
2037 310 CONTINUE
2038
2039
2040
2041 CALL slasum(
'CST', nounit, nerrs, ntestt )
2042 RETURN
2043
2044 9999 FORMAT( ' CCHKST2STG: ', a, ' returned INFO=', i6, '.', / 9x,
2045 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2046
2047 9998 FORMAT( / 1x, a3, ' -- Complex Hermitian eigenvalue problem' )
2048 9997 FORMAT( ' Matrix types (see CCHKST2STG for details): ' )
2049
2050 9996 FORMAT( / ' Special Matrices:',
2051 $ / ' 1=Zero matrix. ',
2052 $ ' 5=Diagonal: clustered entries.',
2053 $ / ' 2=Identity matrix. ',
2054 $ ' 6=Diagonal: large, evenly spaced.',
2055 $ / ' 3=Diagonal: evenly spaced entries. ',
2056 $ ' 7=Diagonal: small, evenly spaced.',
2057 $ / ' 4=Diagonal: geometr. spaced entries.' )
2058 9995 FORMAT( ' Dense ', a, ' Matrices:',
2059 $ / ' 8=Evenly spaced eigenvals. ',
2060 $ ' 12=Small, evenly spaced eigenvals.',
2061 $ / ' 9=Geometrically spaced eigenvals. ',
2062 $ ' 13=Matrix with random O(1) entries.',
2063 $ / ' 10=Clustered eigenvalues. ',
2064 $ ' 14=Matrix with large random entries.',
2065 $ / ' 11=Large, evenly spaced eigenvals. ',
2066 $ ' 15=Matrix with small random entries.' )
2067 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues',
2068 $ / ' 17=Positive definite, geometrically spaced eigenvlaues',
2069 $ / ' 18=Positive definite, clustered eigenvalues',
2070 $ / ' 19=Positive definite, small evenly spaced eigenvalues',
2071 $ / ' 20=Positive definite, large evenly spaced eigenvalues',
2072 $ / ' 21=Diagonally dominant tridiagonal, geometrically',
2073 $ ' spaced eigenvalues' )
2074
2075 9989 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
2076 $ 4( i4, ',' ), ' result ', i3, ' is', 0p, f8.2 )
2077 9988 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
2078 $ 4( i4, ',' ), ' result ', i3, ' is', 1p, e10.3 )
2079
2080 9987 FORMAT( / 'Test performed: see CCHKST2STG for details.', / )
2081
2082
2083
subroutine xerbla(srname, info)
subroutine chet21(itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
CHET21
subroutine chpt21(itype, uplo, n, kband, ap, d, e, u, ldu, vp, tau, work, rwork, result)
CHPT21
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
subroutine cstt21(n, kband, ad, ae, sd, se, u, ldu, work, rwork, result)
CSTT21
subroutine cstt22(n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, rwork, result)
CSTT22
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
subroutine chetrd_2stage(vect, uplo, n, a, lda, d, e, tau, hous2, lhous2, work, lwork, info)
CHETRD_2STAGE
subroutine chetrd(uplo, n, a, lda, d, e, tau, work, lwork, info)
CHETRD
subroutine chptrd(uplo, n, ap, d, e, tau, info)
CHPTRD
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
real function slamch(cmach)
SLAMCH
subroutine slaset(uplo, m, n, alpha, beta, a, lda)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
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 cpteqr(compz, n, d, e, z, ldz, work, info)
CPTEQR
subroutine sstebz(range, order, n, vl, vu, il, iu, abstol, d, e, m, nsplit, w, iblock, isplit, work, iwork, info)
SSTEBZ
subroutine cstedc(compz, n, d, e, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
CSTEDC
subroutine cstein(n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
CSTEIN
subroutine cstemr(jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
CSTEMR
subroutine csteqr(compz, n, d, e, z, ldz, work, info)
CSTEQR
subroutine ssterf(n, d, e, info)
SSTERF
subroutine cungtr(uplo, n, a, lda, tau, work, lwork, info)
CUNGTR
subroutine cupgtr(uplo, n, ap, tau, q, ldq, work, info)
CUPGTR
real function slarnd(idist, iseed)
SLARND
subroutine slasum(type, iounit, ie, nrun)
SLASUM
subroutine sstech(n, a, b, eig, tol, work, info)
SSTECH
real function ssxt1(ijob, d1, n1, d2, n2, abstol, ulp, unfl)
SSXT1