# Removing all prime factors less than n from a number

Is there an efficient way to check a number x and remove all prime factors in the number which are less than some n? For example for n = 200:

x=88984589931961415442566827779929187431222364934742868664124547963532933

FactorInteger[x]

{{29, 2}, {31, 1}, {37, 2}, {269, 1}, {271,
1}, {34200471605536976187361939984030218061598132568100785528233,
1}}


After removing all prime factors < n from x gives:

2493180179572040027082498062895818866472442266081979164222657467


I'd like to use as large n as possible and then use PrimeQ to check the remaining number, which is faster than checking for large prime factors.

I made this code which works but may be slow:

x=2*53*6571*18313*31259

n=20000;
n=PrimePi[n];
listWithSmallPrimeFactorsRemoved={};
AppendTo[listWithSmallPrimeFactorsRemoved,x];
For[i=1,i<=n,i++,
z=Last[listWithSmallPrimeFactorsRemoved];
a=IntegerExponent[z,Prime[i]];
z=z/(Prime[i]^a);
AppendTo[listWithSmallPrimeFactorsRemoved,z];
]
CountDistinct[listWithSmallPrimeFactorsRemoved]-1 (*count of how many prime factors were removed*)

Last[listWithSmallPrimeFactorsRemoved] (*the remaining number after removing prime factors \[LessEqual] n*)


cheers, Jamie

• The combination of For and AppendTo is a good indicator for bad code in Mathematica. Commented Feb 16, 2020 at 18:01

Wasteful but works:

x = 88984589931961415442566827779929187431222364934742868664124547963532933;
n = 200;

FixedPoint[Numerator[#/n!] &, x]

(*    2493180179572040027082498062895818866472442266081979164222657467    *)


A bit less wasteful (Thanks @evanb!): only use prime factors,

A = Times @@ Prime[Range[PrimePi[n]]];
FixedPoint[Numerator[#/A] &, x]

(*    2493180179572040027082498062895818866472442266081979164222657467    *)


Or a bit more direct but much slower:

y = x;
Do[While[Divisible[y, i], y /= i], {i, 2, n}];
y

(*    2493180179572040027082498062895818866472442266081979164222657467    *)

• You can accelerate the loop by just iterating over primes: y = x; i = 2; While[ i <= n, While[Divisible[y, i], y /= i]; i = NextPrime[i] ]; Commented Feb 16, 2020 at 17:15

Select should help you in this case:

n=200;

Select[FactorInteger[x], #[[1]] > n &]


{{269, 1}, {271, 1},{34200471605536976187361939984030218061598132568100785528233, 1}}

• Hi, I will edit the question to be more clear, I actually don't need to factor the remaining number, only PrimeQ it. Commented Feb 16, 2020 at 15:31