## Prog S000850

(* On a Power Mac, this Mathematica program takes about 40 minutes *)

nn = PrimePi[8191];

t1 = {2};

t5 = {31, 1801};

t7 = {127};

t13 = {8191}; found = Union[t1, t5, t7, t13]; t2 = {};

Do[ps = Position[(2^Range[k/2] + 1)/k, _?(IntegerQ[#] &), 1, 1];

If[ps != {}, AppendTo[found, k]; AppendTo[t2, {k, ps[[1, 1]]}]], {k,

Prime[Range[2, nn]]}]; Length[found]

t3 = {};

Do[Do[If[! MemberQ[found, k],

ps = Position[(2^j + 2^Range[j - 1] + 1)/k, _?(IntegerQ[#] &), 1, 1];

If[ps != {}, AppendTo[found, k];

AppendTo[t3, {k, j, ps[[1, 1]]}]; Break[]]], {j, 2, k/3}], {k,

Prime[Range[2, nn]]}]; Length[found]

t4 = {};

Do[Do[If[! MemberQ[found, k],

ps = Position[(2^j + 2^i + 2^Range[i - 1] + 1)/k, _?(IntegerQ[#] &), 1, 1];

If[ps != {}, AppendTo[found, k];

AppendTo[t4, {k, j, i, ps[[1, 1]]}]; Break[]]], {j, 3, k/10}, {i, 2, j}],

{k, Prime[Range[2, nn]]}]; Length[found]

x1 = {Append[t1, 1]};

x2 = Transpose[t2][[1]]; x2 = Transpose[{x2, Table[2, {Length[x2]}]}];

x3 = Transpose[t3][[1]]; x3 = Transpose[{x3, Table[3, {Length[x3]}]}];

x4 = Transpose[t4][[1]]; x4 = Transpose[{x4, Table[4, {Length[x4]}]}];

x5 = Transpose[{t5, Table[5, {Length[t5]}]}];

x7 = {Append[t7, 7]};

x13 = {Append[t13, 13]};

seq = Sort[Join[x1, x2, x3, x4, x5, x7, x13]];

t = Transpose[seq][[2]];