(*K atom  Kimball, sp-spheres 18.11.2013, W. Heinzelmann, 1963*)

Clear[k1,k2,k3,k4,sig1,sig2,sig3,c,z,R1,R2,R3,R4,a,b,k];
k = {k1 -> 1.0, k2 -> 1.0, k3->1.0, k4->1.0, sig1 -> 0.3, sig2 -> 0.3, sig3 -> 0.3};
z=19.0; si=Sin[π/3]; sk=Sqrt[3];
T = 2.25*k1/R1^2+9.0*k2/R2^2+9.0*k3/R3^2+1.125*k4/R4^2 /. k;
a = (R1+R2)/3+Sqrt[(R2+R3)^2-8*(R1+R2)^2/9];
b = a/3+Sqrt[(R3+R4)^2-8*a*a/9];
c = b+Sqrt[((R1+R2)/3)^2+8*(R1+R2)^2/9];
Vee = 3.0*sig1/R1+4.0*3.0*sig2/R2+4.0*3.0*sig3/R3+16/(R1+R2)+24/((R1+R2)*Sqrt[8/3])+
      16/a+48/(R2+R3)+16/(R1+R2+a)+24*Sqrt[3/8]/a+2/b+6/(R3+R4)+2/(a+b)+2/(b-R1-R2)+6/c /. k;
Vne = -3.0*z/R1-8*z/(R1+R2)-8*z/a-z/b;
Vir = (Vee+Vne)/T;
func = T+Vee+Vne;
t = FindMinimum[func, {R1,0.0727274}, {R2,0.25108}, {R3,0.689122}, {R4,1.9368},{Method→"Newton"},{MaxIterations→500}]

K19n3D1_1.gif

K19n3D1_2.gif

K19n3D1_3.gif

Show[Graphics[{Circle[{0,0},R1],Circle[{0,0},R2],Circle[{0,0},R3],Circle[{0,R1+R2},R2],
       Circle[{-si*(R1+R2),-(R1+R2)/2},R2],Circle[{si*(R1+R2),-(R1+R2)/2},R2],
        Circle[{-si*(R2+R3),(R2+R3)/2},R3],Circle[{si*(R2+R3),(R2+R3)/2},R3],
        Circle[{0,-(R2+R3)},R3],Circle[{0,0},R3],Circle[{-si*(R3+R4),-(R3+R4)/2},R4],
        Disk[{0,0},0.04],Disk[{-si*(R3+R4),-(R3+R4)/2},0.04],Disk[{0,R1+R2},0.04],
        Disk[{0,-(R2+R3)},0.04],Line[{{0,0},{-si*(R3+R4),-(R3+R4)/2}}],
        Line[{{0,R1+R2},{-si*(R3+R4),-(R3+R4)/2}}],Line[{{0,-(R2+R3)},{-si*(R3+R4),-(R3+R4)/2}}],
        Text[StyleForm["R3+R4", FontSize->16,FontWeight -> "Bold"],{-1.5,-1.3},{-1,0}],
        Text[StyleForm["b",FontSize->16,FontWeight -> "Bold"],{-1.3,-0.9},{-1,0}],
        Text[StyleForm["c",FontSize->16,FontWeight -> "Bold"],{-1.3,-0.4},{-1,0}]}] /. t[[2]],{AspectRatio → Automatic,
    Axes -> True,GridLines -> Automatic, PlotRange → {{-4.5,2.0},{-3.5,1.5}}, Frame -> True}]

K19n3D1_4.gif

K19n3D1_5.gif

K19n3D1_6.gif

K19n3D1_7.gif

K19n3D1_8.gif

K19n3D1_9.gif

K19n3D1_10.gif

K19n3D1_11.gif

K19n3D1_12.gif

K19n3D1_13.gif

Spikey Created with Wolfram Mathematica 9.0