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