Highly Composite Number

Author

Eric W. Weisstein
November 12, 2002

This notebook downloaded from http://mathworld.wolfram.com/notebooks/IntegerSequences/HighlyCompositeNumber.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/HighlyCompositeNumber.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Table

FoldList/Position

Timing[l=FoldList[Max,1,Table[DivisorSigma[0,n],{n,2,10^6}]];
Flatten[Position[l,#,1,1]&/@Union[l]]
]

FoldList/Split

v4.2

(l=Drop[FoldList[Plus,1,Length/@Split[FoldList[Max,1,Table[DivisorSigma[0,n],{n,2,10^6}]]]
],-1])//Timing

(l=Drop[FoldList[Plus,1,Length/@Split[FoldList[Max,1,Table[DivisorSigma[0,n],{n,2,10^7}]]]
],-1])//Timing

v5.0

(l=Drop[FoldList[Plus,1,Length/@Split[FoldList[Max,1,Table[DivisorSigma[0,n],{n,2,10^7}]]]
],-1])//Timing

(l=Drop[FoldList[Plus,1,Length/@Split[FoldList[Max,1,Table[DivisorSigma[0,n],{n,2,10^8}]]]
],-1])//Timing

Do Loop

v4.2

Timing[l={};a=0; Do[b=DivisorSigma[0, n]; If[b>a, a=b;l={l,n}], {n, 10^6}];
Flatten[l]]

v5.0

Timing[l={};a=0; Do[b=DivisorSigma[0, n]; If[b>a, a=b;l={l,n}], {n, 10^6}];
Flatten[l]]

Number of divisors

A002182

highly={1,2,4,6,12,24,36,48,60,120,180,240,360,720,840,1260,1680,2520,5040,7560,10080,15120,20160,25200,27720,45360,50400,55440,83160,110880,166320,221760,277200,332640,498960,554400,665280,720720,1081080,1441440,2162160,2882880,3603600,4324320,6486480,7207200,8648640,10810800,14414400,17297280,21621600,32432400,36756720,43243200,61261200,73513440};

A002183

DivisorSigma[0,#]&/@highly

Check Prime Factorization

CheckQ[i_]:=Module[{p,a},
{p,a}=Transpose[FactorInteger[i]];
p==Table[Prime[n],{n,PrimePi[p[[1]]],PrimePi[p[[-1]]]}]&&OrderedQ[Reverse[a]]&&a[[-1]]==If[i==4||i==36,2,1]
]

highly={1,2,4,6,12,24,36,48,60,120,180,240,360,720,840,1260,1680,2520,5040,7560,10080,15120,20160,25200,27720,45360,50400,55440,83160,110880,166320,221760,277200,332640,498960,554400,665280,720720,1081080,1441440,2162160,2882880,3603600,4324320,6486480,7207200,8648640};

Transpose[FactorInteger[#]]&/@{4,36,8648640}//ColumnForm

CheckQ/@Rest[highly]

Not Highly Composite

not={29331862500,293318625600,6746328388800};

CheckQ/@not

Transpose[FactorInteger[#]]&/@not//ColumnForm

Prime highly composites

Select[l,IntegerQ[Sqrt[#+1]]&]

Sqrt[#+1]&/@%

4159^2

Factors

l={1,2,4,6,12,24,36,48,60,120,180,240,360,720,840,1260,1680,2520,5040,7560,10080,15120,20160,25200,27720,45360,50400,55440,83160,110880,166320,221760,277200,332640,498960,554400,665280,720720,1081080,1441440,2162160,2882880,3603600,4324320,6486480,7207200,8648640};

1. J#(n)<J#(n+1)≤2 J#(n);
2. J#=2^p2 3^p3 5^p5 7^p7...P^pP
where P is a prime;(The number of factors of J#.is (p2+1) (p3+1) (p5+1)...(pP+1))
3. pP=1 or 2 always
4. p2≥p3≥p5≥p7≥....pP>0

Plus@@(Last/@FactorInteger[#])&/@l

ColumnForm[FactorInteger/@l]