cp's OEIS Frontend

A331365 Least k whose set of divisors contains exactly n Pythagorean quadruples, or 0 if no such k exists.

%I A331365 #15 Nov 18 2020 12:24:57
%S A331365 42,84,168,252,672,756,420,504,2592,1872,840,1008,1512,2940,1680,2016,
%T A331365 1260,4536,3360,3024,9450,4620,5880,6552,9504,6930,3780,8400,23184,
%U A331365 25704,2520,6300,31752,8820,19800,11088,10920,13104,15840,19152,19656,16632,38016
%N A331365 Least k whose set of divisors contains exactly n Pythagorean quadruples, or 0 if no such k exists.
%C A331365 a(n) == 0 (mod 6).
%H A331365 Chai Wah Wu, <a href="/A331365/b331365.txt">Table of n, a(n) for n = 1..1026</a>
%H A331365 Eric Weisstein's World of Mathematics, <a href="https://mathworld.wolfram.com/Pythagorean Quadruple.html">Pythagorean Quadruples</a>.
%e A331365 a(3) = 168 because the set of the divisors {1, 2, 3, 4, 6, 7, 8, 12, 14, 21, 24, 28, 42, 56, 84, 168} contains 3 Pythagorean quadruples {2, 3, 6, 7}, {4, 6, 12, 14} and {8, 12, 24, 28}.
%p A331365 with(numtheory):
%p A331365 for n from 1 to 52 do :
%p A331365 ii:=0:
%p A331365 for q from 3 to 10^8 while(ii=0) do:
%p A331365    d:=divisors(q):n0:=nops(d):it:=0:
%p A331365     for i from 1 to n0-3 do:
%p A331365      for j from i+1 to n0-2 do :
%p A331365       for k from j+1 to n0-1 do:
%p A331365       for l from k+1 to n0 do:
%p A331365        if d[i]^2 + d[j]^2 + d[k]^2 = d[l]^2
%p A331365         then
%p A331365         it:=it+1:
%p A331365         else
%p A331365        fi:
%p A331365       od:
%p A331365      od:
%p A331365     od:
%p A331365    od:
%p A331365     if it = n
%p A331365      then
%p A331365      ii:=1: printf(`%d %d \n`,n,q):
%p A331365      else
%p A331365     fi:
%p A331365 od:
%p A331365 od:
%t A331365 upto = 38016; nq[n_] := If[Mod[n, 6] > 0, 0, Block[{t, u, v, c=0, d = Divisors@ n, m}, m = Length@ d; Do[t = d[[i]]^2 + d[[j]]^2; Do[u = t + d[[h]]^2; If[u > n^2, Break[]]; If[Mod[n^2, u] == 0 && IntegerQ[v = Sqrt@ u] && Mod[n, v] == 0, c++], {h, j+1, m-1}], {i, m-3}, {j, i+1, m-2}]; c]]; w = ParallelTable[ {nq@ n, n}, {n, 6 Range[ upto / 6]}]; t=0 Range@ Max[First /@ w]; Do[{q, x} = e; If[q > 0 && t[[q]] == 0, t[[q]] = x], {e, w}]; AppendTo[t, 0]; TakeWhile[t, # > 0 &] (* _Giovanni Resta_, May 04 2020 *)
%Y A331365 Cf. A027750, A169580, A330893, A330894.
%K A331365 nonn
%O A331365 1,1
%A A331365 _Michel Lagneau_, May 03 2020