Kummer Surface

Author

Eric W. Weisstein
June 6, 2008

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Surfaces/KummerSurface.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/KummerSurface.html.

©2008 Wolfram Research, Inc. except for portions noted otherwise

Initialization

Kummer[mu_,lambda_]:=(x^2+y^2+z^2-mu^2 w^2)^2-lambda(w-z-Sqrt[2]x)(w-z+Sqrt[2]x)(w+z+Sqrt[2]y)(w+z-Sqrt[2]y)
Kummer[mu_]:=Kummer[mu,(3mu^2-1)/(3-mu^2)]
KummerDegen:=(w-z-Sqrt[2]x)(w-z+Sqrt[2]x)(w+z+Sqrt[2]y)(w+z-Sqrt[2]y)

Special Cases

(μ^2)<1/3

Block[{w=1,r=1},ContourPlot3D[Kummer[Sqrt[1/3-1/10]]==0,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,Mesh->None,PlotPoints->50]]

SingularPoints[Kummer[Sqrt[1/3-1/10]],{x,y,z,w},WorkingPrecision->100]

Length[nodes=SingularPoints[Kummer[Sqrt[1/3-1/10]]/.w->1,{x,y,z},WorkingPrecision->100]]

Select[nodes,Im[#]==0.{1,1,1}&]//Length

Length[%]

(μ^2)==1/3

Block[{w=1,r=1},ContourPlot3D[Kummer[Sqrt[1/3]]==0,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,Mesh->None,PlotPoints->50]]

Numerator[Factor[Expand[Kummer[Sqrt[1/3]]/.w->1]]]

Length[nodes=SingularPoints[Kummer[Sqrt[1/3]]/.w->1,{x,y,z},WorkingPrecision->100]]

Select[nodes,Im[#]==0.{1,1,1}&]//Length

(μ^2)==1/3+1/10

Block[{w=1,r=1},ContourPlot3D[Kummer[Sqrt[1/3+1/10]]==0,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,Mesh->None,PlotPoints->50]]

Length[nodes=SingularPoints[Kummer[Sqrt[1/3+1/10]]/.w->1,{x,y,z},WorkingPrecision->100]]

Select[nodes,Im[#]==0.{1,1,1}&]//Length

(μ^2)==2/3

Block[{w=1,r=1},ContourPlot3D[Kummer[Sqrt[2/3]]==0,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,Mesh->None,PlotPoints->50]]

(μ^2)==1

Block[{w=1,r=1.2},ContourPlot3D[Kummer[Sqrt[1]]==0,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,Mesh->None,PlotPoints->20]]

Factor[Expand[Kummer[Sqrt[1]]/.w->1]]

Length[nodes=SingularPoints[Kummer[Sqrt[1]]/.w->1,{x,y,z}]]

Union[nodes]

Length[nodes=SingularPoints[Kummer[Sqrt[1]]/.w->1,{x,y,z},WorkingPrecision->200]]

Select[nodes,Im[#]==0.{1,1,1}&]//N

Length[%]

(μ^2)==(Sqrt[3])

Block[{w=1,r=2},ContourPlot3D[Kummer[Sqrt[(Sqrt[3])]]==0,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,Mesh->None,PlotPoints->20,RegionFunction->(#1^2+#2^2+#3^2<r^2&)]]

Factor[Limit[Kummer[μ],μ->(3^(1/4))]/.w->1]

Length[nodes=SingularPoints[Kummer[(3^(1/4))]/.w->1,{x,y,z},WorkingPrecision->100]]

Select[nodes,Im[#]==0.{1,1,1}&]//N

Length[%]

(μ^2)==2

Block[{w=1,r=2},ContourPlot3D[Kummer[Sqrt[2]]==0,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,Mesh->None,PlotPoints->20,RegionFunction->(#1^2+#2^2+#3^2<r^2&)]]

Factor[Kummer[(Sqrt[2])]/.w->1]

Length[nodes=SingularPoints[Kummer[(Sqrt[2])]/.w->1,{x,y,z},WorkingPrecision->100]]

Select[nodes,Im[#]==0.{1,1,1}&]//N

Length[%]

(μ^2)==3

Block[{w=1,r=4.5},ContourPlot3D[(-2 (x^2)+(((-1+z))^2)) (2 (y^2)-(((1+z))^2))==0,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,Mesh->None,PlotPoints->20,RegionFunction->(#1^2+#2^2+#3^2<r^2&)]]

Limit[Kummer[μ]/.w->1,μ->(3^(1/2))]

Length[nodes=SingularPoints[Kummer[(Sqrt[3])]/.w->1,{x,y,z},WorkingPrecision->100]]

Select[nodes,Im[#]==0.{1,1,1}&]//N

Length[%]

(μ^2)==5

Block[{w=1,r=4.5},ContourPlot3D[Kummer[Sqrt[5]]==0,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,Mesh->None,PlotPoints->20,RegionFunction->(#1^2+#2^2+#3^2<r^2&)]]

Length[nodes=SingularPoints[Kummer[(Sqrt[5])]/.w->1,{x,y,z},WorkingPrecision->100]]

Select[nodes,Im[#]==0.{1,1,1}&]//N

Length[%]

POVRay

<<POVray`

POVCoefficients[Expand[Kummer[μ,λ]] /. w->1,{x,y,z}]

{1, 0, 0, 0, var1, 0, 0, var2, var3, 
  var4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, var2, 
  var5, var4, 0, 0, 0, 0, var5, 0, 
  var4, 0, var6} /. {
var1   -> 2 - 4*lamb,
var2   -> 2 + 2*lamb,
var3   -> 4*lamb,
var4   -> 2*lamb - 2*mu*mu,
var5   -> -4*lamb,
var5   -> 1 - lamb,
var6   -> -lamb + mu*mu*mu*mu} /. lamb -> (3*mu*mu-1)/(3-mu*mu) /.
		mu     -> Sqrt[1./3]

Solve[(Kummer[μ]  /. w->1)==0,{x,y,z}]

POVCoefficients[Expand[Kummer[.3] /. w->1],{x,y,z}]

Simplify[Expand[Kummer[Sqrt[1/3]] /. w->1]]

POVCoefficients[Expand[Kummer[Sqrt[1/3.]]] /. w->1,{x,y,z}]

Expand[Kummer[Sqrt[2/3]]/.w->1]

POVCoefficients[Kummer[Sqrt[2/3.]]/.w->1,{x,y,z}]

Expand[Kummer[1]/.w->1]

POVCoefficients[Expand[Kummer[1]] /. w->1]

Expand[Kummer[Sqrt[2]]/.w->1]

POVCoefficients[Expand[Kummer[Sqrt[2]]] /. w->1]

Simplify[Expand[KummerDegen /.w->1]]

POVCoefficients[KummerDegen /. w->1]

POVCoefficients[Expand[Kummer[2]] /. w->1]

POVCoefficients[Expand[Kummer[5.]] /. w->1]

KummerNordstrand=x^4+y^4+z^4-x^2-y^2-z^2-x^2y^2-x^2z^2-y^2z^2+1

Plot

V5.2

r=3;
ImplicitPlot3D[x^4+y^4+z^4-(y^2 z^2+z^2 x^2+x^2 y^2)-(x^2+y^2+z^2)+1,{x,-r,r},{y,-r,r},{z,-r,r}]

V6

eqns=Limit[Kummer[μ],μ->Sqrt[#]]&/@{1/3,2/3,1,2,3,5}/.w->1

eqns=Transpose[{{(1/9) (((1-3 ((x^2)+(y^2)+(z^2))))^2),(1/63) (1+108 ((x^2)-(y^2)) z-30 ((x^2)+(y^2)+(z^2))+9 (7 (x^4)+7 (y^4)+20 (y^2) (z^2)+4 (z^4)+2 (x^2) ((y^2)+10 (z^2)))),(x^4)+(y^2) ((y^2)+4 (-1+z) z)+(x^2) (-2 (y^2)+4 z (1+z)),-1+(x^4)+(y^4)+20 ((x^2)-(y^2)) z+12 (y^2) (z^2)-4 (z^4)-6 (x^2) (3 (y^2)-2 (z^2))+6 ((x^2)+(y^2)+(z^2)),(1-2 (x^2)-2 z+(z^2)) (1-2 (y^2)+2 z+(z^2)),32+(x^4)+(y^4)-28 ((x^2)-(y^2)) z-12 (y^2) (z^2)+8 (z^4)+6 (x^2) (5 (y^2)-2 (z^2))-24 ((x^2)+(y^2)+(z^2))},{}];

ContourPlot3D[(1-3 ((x^2)+(y^2)+(z^2)))==0,{x,-.7,.7},{y,-.7,.7},{z,-.7,.7}]

ContourPlot3D[(((1-3 ((x^2)+(y^2)+(z^2))))^2)==0,{x,-.7,.7},{y,-.7,.7},{z,-.7,.7}]

With[{r=3},
ContourPlot3D[#==0,{x,-r,r},{y,-r,r},{z,-r,r},RegionFunction->(#1^2+#2^2+#3^2<r^2&),Mesh->None,Boxed->False,BoxRatios->{1,1,1},Axes->False]
]&/@eqns