login
Exponential weird numbers: numbers that are exponential abundant (A129575) but not exponential pseudoperfect (A318100).
8

%I #21 Feb 16 2025 08:33:57

%S 4900,14700,53900,63700,83300,93100,112700,142100,151900,161700,

%T 181300,191100,200900,210700,230300,249900,259700,279300,289100,

%U 298900,328300,338100,347900,357700,387100,406700,426300,436100,455700,475300,494900,504700,524300

%N Exponential weird numbers: numbers that are exponential abundant (A129575) but not exponential pseudoperfect (A318100).

%H Amiram Eldar, <a href="/A321146/b321146.txt">Table of n, a(n) for n = 1..10000</a> (terms 1..1000 from Robert Israel)

%H Eric Weisstein's World of Mathematics, <a href="https://mathworld.wolfram.com/e-Divisor.html">e-Divisor</a>.

%H Eric Weisstein's World of Mathematics, <a href="https://mathworld.wolfram.com/e-PerfectNumber.html">e-Perfect Number</a>.

%e 4900 is in the sequence since its proper exponential divisors, {70, 140, 350, 490, 700, 980, 2450} sum to 5180 > 4900, yet no subset of its divisors sums to 4900.

%p filter:= proc(n)

%p local L,m,P,i,j,T,S,t,v;

%p L:= ifactors(n)[2];

%p m:= nops(L);

%p P:= map(t -> numtheory:-divisors(t[2]),L);

%p if mul(add(L[i][1]^j, j=P[i]),i=1..m) <= 2*n then return false fi;

%p T:= combinat:-cartprod(P);

%p S:= {0}:

%p while not T[finished] do

%p t:= T:-nextvalue();

%p v:= mul(L[i][1]^t[i],i=1..m);

%p if v = n then next fi;

%p if member(n-v,S) then return false fi;

%p S:= S union select(`<=`,map(`+`,S,v),n);

%p od;

%p true

%p end proc:

%p select(filter, [$1..10^6]); # _Robert Israel_, Feb 19 2019

%t dQ[n_, m_] := (n>0&&m>0 &&Divisible[n, m]); expDivQ[n_, d_] := Module[ {ft=FactorInteger[n]}, And@@MapThread[dQ, {ft[[;; , 2]], IntegerExponent[ d, ft[[;; , 1]]]} ]]; eDivs[n_] := Module[ {d=Rest[Divisors[n]]}, Select[ d, expDivQ[n, #]&] ]; esigma[1]=1; esigma[n_] := Total@eDivs[n]; eAbundantQ[n_] := esigma[n] > 2 n; a = {}; n = 0; While[Length[a] < 30, n++; If[!eAbundantQ[n], Continue[]]; d = Most[eDivs[n]]; c = SeriesCoefficient[Series[Product[1 + x^d[[i]], {i, Length[d]}], {x, 0, n}], n]; If[c < 1, AppendTo[a, n]]]; a

%Y The exponential version of A006037.

%Y Cf. A129575, A318100.

%K nonn,changed

%O 1,1

%A _Amiram Eldar_, Oct 28 2018