Finding the value which gives a list total of zero

Is there a way to check if x will converge for Total[g] approaching zero in this code example? For n=15000000, 1.87 < x < 1.88, but takes awhile to run. Thanks.

cheers, Jamie

n = 500000;
a = Select[Range[n], FactorInteger[#][[1, 1]] >= 5 && ! PrimeQ[#] &];
x = 2;
b = Differences[a];
c = Range[x, Length[a]*x, x];
d = c - a;
AppendTo[b, 0];
e = c - b;
f = Abs[d] - Abs[e];
g = Drop[f, -1];
Total[g]


1 Answer

This is about ten times faster by starting with a list that does not contain any multiples of 2 and 3, so that the smallest integer factor is guaranteed to be at least 5 by construction. Thus we only need to check for primality and can leave away the integer factorization:

F[n_Integer?Positive, x_?NumericQ] := Module[{a, c},
a = Select[Union[Range[5, n, 6], Range[7, n, 6]], ! PrimeQ[#] &];
c = x*Range[Length[a]];
Total[Most[Abs[c - a]]] - Total[Abs[Most[c] - Differences[a]]]]


We gain another huge factor by noticing that the list a depends only on n, not on x, and can be reused between calls:

alist[n_Integer?Positive] := alist[n] =
Select[Union[Range[7, n, 6], Range[5, n, 6]], ! PrimeQ[#] &];
F[n_Integer?Positive, x_?NumericQ] := Module[{a, c},
a = alist[n];
c = x*Range[Length[a]];
Total[Most[Abs[c - a]]] - Total[Abs[Most[c] - Differences[a]]]]

FindRoot[F[15000000, x] == 0, {x, 2}]
(*    {x -> 1.877}    *)


Use higher working precision in order to get a more accurate result:

FindRoot[F[15000000, x] == 0, {x, 2}, WorkingPrecision -> 50]
(*    {x -> 1.8770030863174339272847074995530758016555733942289}    *)


update: more general case

If we want to be able to choose the smallest prime factor $$p$$, we modify the alist function:

Clear[alist];
alist[p_?PrimeQ, n_Integer?Positive] := alist[p, n] = Module[{L, P, A},
(* compute the repeating pattern *)
P = Select[Range[p - 1], PrimeQ];
L = Times @@ P;
A = Fold[Select[#1, Function[z, ! Divisible[z, #2]]] &, Range[0, L - 1], P];
(* repeat this pattern up to n *)
Select[Join @@ (A + # & /@ Range[0, Floor[n - 1, L], L]),
p <= # <= n && ! PrimeQ[#] &]]


The function now takes an extra parameter p that is the smallest prime factor:

F[p_?PrimeQ, n_Integer?Positive, x_?NumericQ] := Module[{a, c},
a = alist[p, n];
c = x*Range[Length[a]];
Total[Most[Abs[c - a]]] - Total[Abs[Most[c] - Differences[a]]]]


test:

FindRoot[F[2, 1000000, x] == 0, {x, 2}]
(*    {x -> 0.544595}    *)

FindRoot[F[3, 1000000, x] == 0, {x, 2}]
(*    {x -> 1.1958}    *)

FindRoot[F[5, 1000000, x] == 0, {x, 2}]
(*    {x -> 1.9882}    *)

FindRoot[F[7, 1000000, x] == 0, {x, 2}]
(*    {x -> 2.70512}    *)

FindRoot[F[11, 1000000, x] == 0, {x, 2}]
(*    {x -> 3.40701}    *)

FindRoot[F[13, 1000000, x] == 0, {x, 2}]
(*    {x -> 3.96854}    *)

FindRoot[F[17, 1000000, x] == 0, {x, 2}]
(*    {x -> 4.5446}    *)

FindRoot[F[19, 1000000, x] == 0, {x, 2}]
(*    {x -> 5.06328}    *)

• Thanks I tested it to n=100000000, x=1.8251, and for n=200000000 x=1.80954. Not sure if that will converge, but seems unlikely. For the larger n FindRoot gave a machinePrecision digits error on 64bit OS, ignoring that I also ran into system memory error. I would like to do the same for the list of composites with least prime factor p, ie instead of FactorInteger[#][[1, 1]] >= 5, it would be >=p for 2,3,5,7,11,.. and check the value of x in each case. Also since the larger p lists have sparse composites, it would be good to have the same list length for all p when calculating the x values. – Jamie M Jun 10 '19 at 18:38