Symmetric k-Noids with k Handles

<<Own`Mesh`

θ11[z_,τ_]:=EllipticTheta[1,Pi z,Exp[ Pi I  τ]]

Weierstraß Data

Choose the number k of ends.

k=4;

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

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

G[z_, τ_,s1_]:=G[z,τ,s1,1/(2)-k/(k-1)s1]

Closing the Periods

rho=1;

ω1[z_,τ1_,s1_]:=rho G[z,τ1 I,s1]dh[z,τ1 I,s1];
ω2[z_,τ1_,s1_]:=1/G[z,τ1 I,s1]/rho dh[z,τ1 I,s1];

A1[τ0_,s1_]:=NIntegrate[ω1[τ0/3I+ t  ,τ0 ,s1],{t,0,1}];
A2[τ0_,s1_]:=NIntegrate[ω2[τ0/3I+ t  ,τ0 ,s1],{t,0,1}];
B1[τ0_,s1_]:=NIntegrate[I ω1[0.5+ t  I,τ0 ,s1],{t,0,τ0}];
B2[τ0_,s1_]:=NIntegrate[I ω2[0.5+ t  I,τ0 ,s1],{t,0,τ0}];

ff[τ0_,s1_]:={Re[B1[τ0,s1]],Re[Adh[τ0,s1]]}

FindRoot[ff[tt,ss]=={0,0},{tt,0.9,1.1},{ss,.25,.27},MaxIterations->100]

Weierstrass Data

Precomputed solutions

k=3;
s1=0.267381688362031466`;
τ1=0.924245367734896561`;

k=4;
s1=0.27414302855846456`;
τ1=0.818518088154285`;

τ=τ1 I;

s2=1/(2)-k/(k-1)s1;

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

G0[z_]:=(θ11[z-((1+τ)/2+s1),τ])(-θ11[z-(1/2+1/(2)-k/(k-1)s1),τ])^(1-1/k)/
			((θ11[z-((1+τ)/2-s1),τ])(θ11[z-(1/2-(1/(2)-k/(k-1)s1)),τ])^(1-1/k))

rho=G0[0];

G[z_]:=G0[z]/rho

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

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

cp=(1+τ)/2.;

f0[w_]:=Re[{
		NIntegrate[ω1[z],{z,cp,w}],NIntegrate[ω2[z],{z,cp,w}],
	NIntegrate[dh[z],{z,cp,w}]}];

n0[z_]:=StereographicProjection[G[z]]

Surface Parametrization

a=-1/ModularLambda[τ]+1;

f[x_]:=2 I  EllipticF[ArcSin[((Sqrt[x])/(Sqrt[a]))],a]

x1=f[0]-f[a];

y1=(f[1]-f[0]);

g[x_]:=(-f[x]+y1-x1)/y1/2

eps=10^-20;

xa=-tt/.FindRoot[Im[g[tt]]+Re[g[tt]]==.5,{tt,-.7,-.5},MaxIterations->40][[1]];

xb=-tt/.FindRoot[Re[g[tt]]==.5-s2,{tt,-2,-1}][[1]]

nx=2;
ny=10;
xx=Union[NRange[0,xa,2nx],NRange[xa,xb,nx],NRange[xb,1,nx],NRange[1,4,2nx],SameTest->AlmostEqual];
yy=NRange[0,Pi,ny];

dm1=PolarDomain[xx,yy];

dm2=MeshApply[g[eps I+#]&,dm1];

e1=-f0[0.5-s2+10^-9I][[2]];

pp={-e1 Cot[Pi/k],e1,0};

Generate Surface

fr1=MeshPlot3D[{f0[x+I y],n0[x+I y]},{x,y},dm2];

fr2=MeshTranslate[fr1,pp];

fr3=MeshJoin[fr2,MeshReflect[fr2,Plane[{0,0,1},0]]];

fr4=MeshJoin[fr3,MeshReflect[fr3,Plane[{0,1,0},0]]];

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

gr=Mesh3DToGraphics3D[fr5]