Base Elemet Box Code

ClearAll["Global`*"]
In[]:=
ver3={X31,X32,X33,X34};​​runl34={X31:>X41,X32:>X42,X33:>X43,X34:>X44};​​B3=1/16(s^2t^2+2s^2tX31+s^2X31^2+2st^2X32+2stX31X32+t^2X32^2+2st^2X33+2stX31X33-4stX32X33-2t^2X32X33+t^2X33^2+2s(s(t-X31)+t(-2X31+X32+X33))X34+s^2X34^2+m1^4(t^2+(X31-X34)^2+2t(X31+X34))+m2^4(t^2+(X31-X34)^2+2t(X31+X34))-2m1^2(t(X32-X33)(t+X31-2X33+X34)+s((t+X31)^2+2(t-X31)X34+X34^2)+m2^2(t^2+(X31-X34)^2+2t(X31+X34)))-2m2^2(-t(X32-X33)(t+X31-2X32+X34)+s(t^2+(X31-X34)^2+2t(X31+X34))));​​B34=B3//.runl34
Out[]=
1
16
(
2
s
2
t
+2
2
s
tX41+
2
s
2
X41
+2s
2
t
X42+2stX41X42+
2
t
2
X42
+2s
2
t
X43+2stX41X43-4stX42X43-2
2
t
X42X43+
2
t
2
X43
+2s(s(t-X41)+t(-2X41+X42+X43))X44+
2
s
2
X44
+
4
m1
(
2
t
+
2
(X41-X44)
+2t(X41+X44))+
4
m2
(
2
t
+
2
(X41-X44)
+2t(X41+X44))-2
2
m1
(t(X42-X43)(t+X41-2X43+X44)+s(
2
(t+X41)
+2(t-X41)X44+
2
X44
)+
2
m2
(
2
t
+
2
(X41-X44)
+2t(X41+X44)))-2
2
m2
(-t(X42-X43)(t+X41-2X42+X44)+s(
2
t
+
2
(X41-X44)
+2t(X41+X44))))
In[]:=
FullSimplify[B34-B4]
Out[]=
1
16
(2(
2
m1
+
2
m2
-s)-t)t(t+X41-2X42+X44)(t+X41-2X43+X44)
In[]:=
ureg3=Product[ver3[[i]]^rho3[i],{i,1,4}]*B3^((d-5)/2);
In[]:=
uregnum3=ureg3/.{s:>17,t:>23,m1:>37,m2:>43,d:>1/97,rho[1]:>1/113,rho[2]:>1/149,rho[3]:>1/173,rho[4]:>1/197};
In[]:=
subsets3=Subsets[ver3]
Out[]=
{{},{X31},{X32},{X33},{X34},{X31,X32},{X31,X33},{X31,X34},{X32,X33},{X32,X34},{X33,X34},{X31,X32,X33},{X31,X32,X34},{X31,X33,X34},{X32,X33,X34},{X31,X32,X33,X34}}
In[]:=
Do[​​currentvars3=subsets3[[k]];​​remvars3=Join[Complement[ver3,currentvars3],{s,t,d,m1,m2,rho3[1],rho3[2],rho3[3],rho3[4]}];​​numrules3=Table[remvars3[[i]]->1/Prime[23+45*i],{i,Length[remvars3]}];​​dlistdo3=Table[Simplify[D[Log[ureg3/.numrules3],currentvars3[[j]]]],{j,1,Length[currentvars3]}];​​SOLdo3=Solve[dlistdo3==0,currentvars3];​​lenSOLdo3=Length[SOLdo3];​​Print[k,"/",Length[subsets3]," ",currentvars3," ",lenSOLdo3];​​,{k,2,Length[subsets3]}];
2/16 {X31} 2
3/16 {X32} 2
4/16 {X33} 2
5/16 {X34} 2
6/16 {X31,X32} 4
7/16 {X31,X33} 4
8/16 {X31,X34} 4
9/16 {X32,X33} 4
10/16 {X32,X34} 4
11/16 {X33,X34} 4
12/16 {X31,X32,X33} 8
13/16 {X31,X32,X34} 8
14/16 {X31,X33,X34} 8
15/16 {X32,X33,X34} 8
16/16 {X31,X32,X33,X34} 7
In[]:=
Do[​​currentvars3=Take[ver3,ii];​​Print["\nFor set ",currentvars3," :"];​​remvars3=Join[Complement[ver3,currentvars3],{s,t,d,m1,m2,rho3[1],rho3[2],rho3[3],rho3[4]}];​​numrules3=Table[remvars3[[i]]->1/Prime[23+45*i],{i,Length[remvars3]}];​​Do[​​currentset3=subsets3[[k]];​​ureg32=Product[currentset3[[i]]^rho3[i],{i,1,Length[currentset3]}]*B3^((d-5)/2);​​ureg32=ureg32/.numrules3;​​dlistdo3=Table[Simplify[D[Log[ureg32],currentvars3[[j]]]],{j,1,Length[currentvars3]}];​​SOLdo3=Solve[dlistdo3==0,currentvars3];​​lenSOLdo3=Length[SOLdo3];​​Print[k,"/",Length[subsets3]," ",currentset3," ",lenSOLdo3];​​,{k,1,Length[subsets3]}];​​,{ii,1,4}];
For set {X31} :
1/16 {} 1
2/16 {X31} 2
3/16 {X32} 1
4/16 {X33} 1
5/16 {X34} 1
6/16 {X31,X32} 2
7/16 {X31,X33} 2
8/16 {X31,X34} 2
9/16 {X32,X33} 1
10/16 {X32,X34} 1
11/16 {X33,X34} 1
12/16 {X31,X32,X33} 2
13/16 {X31,X32,X34} 2
14/16 {X31,X33,X34} 2
15/16 {X32,X33,X34} 1
16/16 {X31,X32,X33,X34} 2
For set {X31,X32} :
1/16 {} 1
2/16 {X31} 2
3/16 {X32} 2
4/16 {X33} 1
5/16 {X34} 1
6/16 {X31,X32} 4
7/16 {X31,X33} 2
8/16 {X31,X34} 2
9/16 {X32,X33} 2
10/16 {X32,X34} 2
11/16 {X33,X34} 1
12/16 {X31,X32,X33} 4
13/16 {X31,X32,X34} 4
14/16 {X31,X33,X34} 2
15/16 {X32,X33,X34} 2
16/16 {X31,X32,X33,X34} 4
For set {X31,X32,X33} :
1/16 {} 1
2/16 {X31} 2
3/16 {X32} 2
4/16 {X33} 2
5/16 {X34} 1
6/16 {X31,X32} 4
7/16 {X31,X33} 4
8/16 {X31,X34} 2
9/16 {X32,X33} 4
10/16 {X32,X34} 2
11/16 {X33,X34} 2
12/16 {X31,X32,X33} 8
13/16 {X31,X32,X34} 4
14/16 {X31,X33,X34} 4
15/16 {X32,X33,X34} 4
16/16 {X31,X32,X33,X34} 8
For set {X31,X32,X33,X34} :
1/16 {} 0
2/16 {X31} 0
3/16 {X32} 1
4/16 {X33} 1
5/16 {X34} 0
6/16 {X31,X32} 1
7/16 {X31,X33} 1
8/16 {X31,X34} 1
9/16 {X32,X33} 3
10/16 {X32,X34} 1
11/16 {X33,X34} 1
12/16 {X31,X32,X33} 3
13/16 {X31,X32,X34} 3
14/16 {X31,X33,X34} 3

Cros Box