login
Infinitary aspiring numbers.
3

%I #19 Mar 11 2023 08:04:21

%S 30,42,54,66,72,78,100,140,148,152,192,194,196,208,220,238,244,252,

%T 268,274,292,296,298,300,336,348,350,360,364,372,374,380,382,386,400,

%U 416,420,424,476,482,492,516,520,532,540,542,544,550,572,576,578,586,592

%N Infinitary aspiring numbers.

%C Numbers whose infinitary aliquot sequences end in an infinitary perfect number, but are not infinitary perfect numbers themselves.

%H Amiram Eldar, <a href="/A127663/b127663.txt">Table of n, a(n) for n = 1..72</a>

%H Graeme L. Cohen, <a href="http://dx.doi.org/10.1090/S0025-5718-1990-0993927-5">On an integer's infinitary divisors</a>, Math. Comp., 54 (1990), 395-411.

%H J. O. M. Pedersen, <a href="http://amicable.homepage.dk/tables.htm">Tables of Aliquot Cycles</a>. [Broken link]

%H J. O. M. Pedersen, <a href="http://web.archive.org/web/20140502102524/http://amicable.homepage.dk/tables.htm">Tables of Aliquot Cycles</a>. [Via Internet Archive Wayback-Machine]

%H J. O. M. Pedersen, <a href="/A063990/a063990.pdf">Tables of Aliquot Cycles</a>. [Cached copy, pdf file only]

%e a(5) = 72 because the fifth non-infinitary perfect number whose infinitary aliquot sequence ends in an infinitary perfect number is 72.

%t ExponentList[n_Integer,factors_List]:={#,IntegerExponent[n,# ]}&/@factors;InfinitaryDivisors[1]:={1}; InfinitaryDivisors[n_Integer?Positive]:=Module[ { factors=First/@FactorInteger[n], d=Divisors[n] }, d[[Flatten[Position[ Transpose[ Thread[Function[{f,g}, BitOr[f,g]==g][ #,Last[ # ]]]&/@ Transpose[Last/@ExponentList[ #,factors]&/@d]],_?(And@@#&),{1}]] ]] ] Null;properinfinitarydivisorsum[k_]:=Plus@@InfinitaryDivisors[k]-k;g[n_] := If[n > 0,properinfinitarydivisorsum[n], 0];iTrajectory[n_] := Most[NestWhileList[g, n, UnsameQ, All]];InfinitaryPerfectNumberQ[0]=False;InfinitaryPerfectNumberQ[k_Integer] :=If[properinfinitarydivisorsum[k]==k,True,False];Select[Range[750],InfinitaryPerfectNumberQ[Last[iTrajectory[ # ]]] && !InfinitaryPerfectNumberQ[ # ]&]

%t f[p_, e_] := Module[{b = IntegerDigits[e, 2]}, m = Length[b]; Product[If[b[[j]] > 0, 1 + p^(2^(m - j)), 1], {j, 1, m}]]; s[n_] := Times @@ f @@@ FactorInteger[n] - n; s[0] = s[1] = 0; q[n_] := Module[{v = NestWhileList[s, n, UnsameQ, All]}, n != v[[-2]] == v[[-1]] > 0]; Select[Range[839], q] (* _Amiram Eldar_, Mar 11 2023 *)

%Y Cf. A007357, A126168, A127661, A127662, A127664, A127665, A127666, A127667.

%K hard,nonn

%O 1,1

%A _Ant King_, Jan 26 2007