%I #10 Feb 04 2020 03:56:50
%S 2,6,8,17,29,31,55,79,91,115,121,175,181,211,295,301,361,391,421,481,
%T 511,571,631,781,841,991,1051,1231,1261,1471,1561,1651,1681,1891,2101,
%U 2311,2731,3151,3361,3571,3991,4201,4291,4411,4621,5251,5461,6091,6511,6931
%N Bi-unitary highly touchable numbers: numbers m > 1 such that a record number of numbers k have m as the sum of the proper bi-unitary divisors of k.
%C The corresponding record values are 0, 1, 2, 3, 4, 6, 8, 9, 10, 11, 14, 15, ...
%C The bi-unitary version of A238895.
%H Amiram Eldar, <a href="/A331972/b331972.txt">Table of n, a(n) for n = 1..73</a> (terms below 30000)
%e a(1) = 2 since it is the first number which is not the sum of proper bi-unitary divisors of any number.
%e a(2) = 6 since it is the least number which is the sum of proper bi-unitary divisors of one number: 6 = A331970(6).
%e a(3) = 8 since it is the least number which is the sum of proper bi-unitary divisors of 2 numbers: 8 = A331970(10) = A331970(12).
%t fun[p_, e_] := If[OddQ[e], (p^(e+1)-1)/(p-1), (p^(e+1)-1)/(p-1)-p^(e/2)]; bsigma[1] = 1; bsigma[n_] := Times @@ (fun @@@ FactorInteger[n]); bs[n_] := bsigma[n] - n; m = 300; v = Table[0, {m}]; Do[b = bs[k]; If[2 <= b <= m, v[[b]]++], {k, 1, m^2}]; s = {}; vm = -1; Do[If[v[[k]] > vm, vm = v[[k]]; AppendTo[s, k]], {k, 2, m}]; s
%Y Cf. A188999, A238895, A324276, A325177, A331970, A331974.
%K nonn
%O 1,1
%A _Amiram Eldar_, Feb 03 2020