%I #6 May 20 2023 14:43:49
%S 1,1,2,1,6,1,6,1,2,2,6,1,6,2,2,1,20,1,20,1,2,6,20,1,6,6,2,1,20,1,20,1,
%T 2,6,6,1,20,6,2,1,20,1,20,2,2,6,28,1,6,2,6,2,28,1,6,1,6,6,30,1,30,20,
%U 2,1,6,1,30,6,6,2,30,1,30,20,2,6,6,1,42,1,2,20,42,1,6,20,6,1,42,1,6,6,6,20,6,1,42,2,2,1
%N Least positive integer k with k primitive practical and k*n practical.
%C For all integers n>0 there exists k such that k*n is practical and k is primitive practical. For example, n*prime(f)# is practical where k = prime(f)# = A002110(f) is a primorial number and f is the prime index of the largest prime number in the factorization of n. All primorials are primitive practical numbers. The sequence above gives least k.
%e a(5)=6 since 6*5=30 is practical and 6 is primitive practical. Also 4*5=20 is practical but 4 is not primitive practical.
%t PracticalQ[n_] := Module[{f, p, e, prod=1, ok=True}, If[n<1||(n>1&&OddQ[n]), False, If[n==1, True, f=FactorInteger[n]; {p, e}=Transpose[f]; Do[If[p[[i]]>1+DivisorSigma[1, prod], ok=False; Break[]]; prod=prod*p[[i]]^e[[i]], {i, Length[p]}]; ok]]];
%t DivFreeQ[n_] := Module[{plst=First/@Select[FactorInteger[n], #[[2]]>1 &], m, ok=False}, Do[If[!PracticalQ[n/plst[[m]]], ok = True, ok = False; Break[]], {m, 1, Length@plst}]; ok];
%t PPracticalQ[n_] := PracticalQ[n]&&(SquareFreeQ[n]||DivFreeQ[n]);
%t lst = {}; Do[m=0; While[!PPracticalQ[m]||(!PracticalQ[m*n]&&m<10000), m++]; AppendTo[lst, m], {n, 1, 500}]; lst
%Y Cf. A005153, A210445, A267124.
%K nonn
%O 1,3
%A _Frank M Jackson_, May 03 2023