k-Noids With Handle

<<Own`Mesh`

θ11[z_,τ_]:=-EllipticTheta[1.,π z,(E^(π I τ))];

Weierstrass Data

Now choose the number k of ends.Below we have precomputed data for k=3,4,5.

k=3;

The minimal surface has as underlying Riemann surface a rectangular torus spanned by 1 and kτ.The surface has a rotational symmetry of degree k,which is reflected on the torus as a translation by τ.The height differential is already defined on the τ-torus,and the Gauß map satisfies a simple functional equation:Translation by τ rotates the Gauß map value by 2π/k.

Height differential:

dh[z_,τ_]:=((θ11[z-(((1+τ)/2)-((k-1)/(2 k))),τ] θ11[z-(((1+τ)/2)+((k-1)/(2 k))),τ])/(θ11[z,τ] θ11[z-(1+τ),τ]))

G[z_,τ_]:=((θ11[z-(((1+τ)/2)+((k-1)/(2 k))),τ])/(θ11[z-(((1+τ)/2)-((k-1)/(2 k))),τ]));

(G[0.+ I,I]/G[0.,I])^k//Chop

With all the symmetry assumptions made, there is only one period condition to close: The A-period of the height differential must be purely imaginary. The relevant period is computed as a function of the lattice constant τ0 as

Adh[τ0_]:=NIntegrate[Evaluate[dh[τ0/2I+ t  ,τ0 I]],{t,0,1}];
Bdh[τ0_]:=NIntegrate[Evaluate[I dh[0.5+ t  I,τ0 I]],{t,0,τ0}];

Adh[τ0_]:=NIntegrate[dh[τ0/2I+ t  ,τ0 I],{t,0,1}];
Bdh[τ0_]:=NIntegrate[Evaluate[I dh[0.5+ t  I,τ0 I]],{t,0,τ0}];

Below we have precomputed values for the lattice parameter τ for k=3,4. In other case, you can follow the instructions below:

τ1=0.401471808402857277`; (* k=3 *)
k=3;
r0=8;

τ1=0.250270684306153468`; (* k=4 *)

τ1=0.17984522817466161`;(*k=5*)

Here we illustrate how to close the period for k=6. First, narrow down the interval by plotting the function:

k=6;

Plot[Re[Adh[t]],{t,0.05,0.12},PlotRange->All];

FindRoot[Re[Adh[u]]==0,{u,0.11,0.15}]

τ1=0.1390781873077091`;(*k=6*)

Surface Parametrization

This is the Weierstraß representation:

phi1[z_]:=G[z,τ1 I]dh[z,τ1 I];
phi2[z_]:=1/G[z,τ1 I]dh[z,τ1 I];

ω1[z_] :=(- phi1[z]+phi2[z] )/2;
ω2[z_] :=I( phi1[z]+phi2[z])/2;
ω3[z_]:=dh[z,τ1 I]

The periods of G dh will be needed to paste fundamental pieces of the image surface together. We are going to compute only 1/(4k) of the surface:

d1=Abs[NIntegrate[phi1[τ1/3I+ t ],{t,0,1}]]

d2=Abs[NIntegrate[phi1[0.5+ t  I ],{t,0,τ1}]]

On the fundamental rectangle, which is the lower left quarter of the (1,τ)-rectangle, the paramerization of the surface is now given by

f0[w_]:=Re[NIntegrate[Evaluate[{ω1[z],ω2[z],ω3[z]}],{z,0.25+τ1 I/4,w}]]

δ0=f0[.5+τ1 I/2];

f1[w_]:=f0[w]-δ0;

δ1=Drop[f1[.5],-1].{1,-Cot[Pi/k]};

f[w_]:=f1[w]-{δ1,0,0};

Because at the vertex (0,0) represents a catenoid end, we need to circumnavigate it by introducing polar coordinates. Therefore, we need a map from upper half plane to fundamental rectangle:

n[z_]:=StereographicProjection[G[z,τ1 I]]

ϵ=0.00000000001;

a=-Sqrt[ModularLambda[I /(τ1/2)]]

trf[x_]:= 1 -EllipticF[ArcSin[(1/( (Sqrt[1-a x])))],1-(a^2)]/EllipticK[1-(a^2)]

r0=8;

m0=MeshApply[Exp,
RectangularDomain[
Union[NRange[-r0,0,10],{Log[-a]},SameTest->AlmostEqual],
NRange[ϵ,Pi-ϵ,10]
]
];

m1=MeshApply[trf[#]&,m0];

Show[DomainToGraphics[m1],AspectRatio->Automatic,PlotRange->All,Axes->False]

Drawing the surface

mp1=MeshPlot3D[{f[x+I y],n[x+I y]},{x,y},m1];

mp2=MeshJoin[mp1,MeshReflect[mp1,Plane[{0,0,1},0]]];

mp3=MeshJoin[mp2,MeshReflect[mp2,Plane[{0,1,0},0]]];

mp4=MeshJoin@@Table[MeshRotateZ[mp3,2Pi/k i,0],{i,0,k-1}];

Show[g1=Mesh3DToGraphics3D[mp4],Axes->True,PlotRange->All]