876
877
878
879
880
881
882
883
884 INTEGER IEFLAG, IJOB, INFO, MINP, MMAX, MOUT, N
885 REAL ABSTOL, LSAVE, PIVMIN, RELTOL
886
887
888 INTEGER INTVLCT( * ), NVAL( * )
889 REAL D( * ), INTVL( * )
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007 INTRINSIC abs, int, log,
max,
min
1008
1009
1011
1012
1013 REAL ZERO, TWO, HALF
1014 parameter( zero = 0.0e+0, two = 2.0e+0,
1015 $ half = 1.0e+0 / two )
1016
1017
1018 INTEGER I, ITMAX, J, K, KF, KL, KLNEW, L, LCNT, LREQ,
1019 $ NALPHA, NBETA, NMID, RCNT, RREQ
1020 REAL ALPHA, BETA, MID
1021
1022
1023
1024 kf = 1
1025 kl = minp + 1
1026 info = 0
1027 IF( intvl( 2 )-intvl( 1 ).LE.zero ) THEN
1028 info = minp
1029 mout = kf
1030 RETURN
1031 END IF
1032 IF( ijob.EQ.0 ) THEN
1033
1034
1035
1036 CALL pslaecv( 0, kf, kl, intvl, intvlct, nval,
1037 $
max( abstol, pivmin ), reltol )
1038 IF( kf.GE.kl )
1039 $ GO TO 60
1040
1041
1042
1043 itmax = int( ( log( intvl( 2 )-intvl( 1 )+pivmin )-
1044 $ log( pivmin ) ) / log( two ) ) + 2
1045
1046
1047
1048 DO 20 i = 1, itmax
1049 klnew = kl
1050 DO 10 j = kf, kl - 1
1051 k = 2*j
1052
1053
1054
1055 mid = half*( intvl( k-1 )+intvl( k ) )
1056 IF( ieflag.EQ.0 ) THEN
1057 CALL pslapdct( mid, n, d, pivmin, nmid )
1058 ELSE
1059 CALL pslaiect( mid, n, d, nmid )
1060 END IF
1061 lreq = nval( k-1 )
1062 rreq = nval( k )
1063 IF( kl.EQ.1 )
1064 $ nmid =
min( intvlct( k ),
1065 $
max( intvlct( k-1 ), nmid ) )
1066 IF( nmid.LE.nval( k-1 ) ) THEN
1067 intvl( k-1 ) = mid
1068 intvlct( k-1 ) = nmid
1069 END IF
1070 IF( nmid.GE.nval( k ) ) THEN
1071 intvl( k ) = mid
1072 intvlct( k ) = nmid
1073 END IF
1074 IF( nmid.GT.lreq .AND. nmid.LT.rreq ) THEN
1075 l = 2*klnew
1076 intvl( l-1 ) = mid
1077 intvl( l ) = intvl( k )
1078 intvlct( l-1 ) = nval( k )
1079 intvlct( l ) = intvlct( k )
1080 intvl( k ) = mid
1081 intvlct( k ) = nval( k-1 )
1082 nval( l-1 ) = nval( k )
1083 nval( l ) = nval( l-1 )
1084 nval( k ) = nval( k-1 )
1085 klnew = klnew + 1
1086 END IF
1087 10 CONTINUE
1088 kl = klnew
1089 CALL pslaecv( 0, kf, kl, intvl, intvlct, nval,
1090 $
max( abstol, pivmin ), reltol )
1091 IF( kf.GE.kl )
1092 $ GO TO 60
1093 20 CONTINUE
1094 ELSE IF( ijob.EQ.1 ) THEN
1095 alpha = intvl( 1 )
1096 beta = intvl( 2 )
1097 nalpha = intvlct( 1 )
1098 nbeta = intvlct( 2 )
1099 lsave = alpha
1100 lreq = nval( 1 )
1101 rreq = nval( 2 )
1102 30 CONTINUE
1103 IF( nbeta.NE.rreq .AND. beta-alpha.GT.
1104 $
max( abstol, reltol*
max( abs( alpha ), abs( beta ) ) ) )
1105 $ THEN
1106
1107
1108
1109 mid = half*( alpha+beta )
1110 IF( ieflag.EQ.0 ) THEN
1111 CALL pslapdct( mid, n, d, pivmin, nmid )
1112 ELSE
1113 CALL pslaiect( mid, n, d, nmid )
1114 END IF
1115 nmid =
min( nbeta,
max( nalpha, nmid ) )
1116 IF( nmid.GE.rreq ) THEN
1117 beta = mid
1118 nbeta = nmid
1119 ELSE
1120 alpha = mid
1121 nalpha = nmid
1122 IF( nmid.EQ.lreq )
1123 $ lsave = alpha
1124 END IF
1125 GO TO 30
1126 END IF
1127 kl = kf
1128 intvl( 1 ) = alpha
1129 intvl( 2 ) = beta
1130 intvlct( 1 ) = nalpha
1131 intvlct( 2 ) = nbeta
1132 ELSE IF( ijob.EQ.2 ) THEN
1133
1134
1135
1136 CALL pslaecv( 1, kf, kl, intvl, intvlct, nval,
1137 $
max( abstol, pivmin ), reltol )
1138 IF( kf.GE.kl )
1139 $ GO TO 60
1140
1141
1142
1143 itmax = int( ( log( intvl( 2 )-intvl( 1 )+pivmin )-
1144 $ log( pivmin ) ) / log( two ) ) + 2
1145
1146
1147
1148 DO 50 i = 1, itmax
1149 klnew = kl
1150 DO 40 j = kf, kl - 1
1151 k = 2*j
1152 mid = half*( intvl( k-1 )+intvl( k ) )
1153 IF( ieflag.EQ.0 ) THEN
1154 CALL pslapdct( mid, n, d, pivmin, nmid )
1155 ELSE
1156 CALL pslaiect( mid, n, d, nmid )
1157 END IF
1158 lcnt = intvlct( k-1 )
1159 rcnt = intvlct( k )
1160 nmid =
min( rcnt,
max( lcnt, nmid ) )
1161
1162
1163
1164 IF( nmid.EQ.lcnt ) THEN
1165 intvl( k-1 ) = mid
1166 ELSE IF( nmid.EQ.rcnt ) THEN
1167 intvl( k ) = mid
1168 ELSE IF( klnew.LT.mmax+1 ) THEN
1169 l = 2*klnew
1170 intvl( l-1 ) = mid
1171 intvl( l ) = intvl( k )
1172 intvlct( l-1 ) = nmid
1173 intvlct( l ) = intvlct( k )
1174 intvl( k ) = mid
1175 intvlct( k ) = nmid
1176 klnew = klnew + 1
1177 ELSE
1178 info = mmax + 1
1179 RETURN
1180 END IF
1181 40 CONTINUE
1182 kl = klnew
1183 CALL pslaecv( 1, kf, kl, intvl, intvlct, nval,
1184 $
max( abstol, pivmin ), reltol )
1185 IF( kf.GE.kl )
1186 $ GO TO 60
1187 50 CONTINUE
1188 END IF
1189 60 CONTINUE
1190 info =
max( kl-kf, 0 )
1191 mout = kl - 1
1192 RETURN
1193
1194
1195
subroutine pslaecv(ijob, kf, kl, intvl, intvlct, nval, abstol, reltol)
subroutine pslapdct(sigma, n, d, pivmin, count)