Wohlgemuth's Surface with handle: Genus 3, 4 Ends

<<Own`Mesh`

Weierstrass Data

phi1[z_]:=(((z-a))^(3/2)) (((z-b))^(-3/2)) (1/(Sqrt[z-1]))(z-c)^(1/2) (((z+a))^(-3/2)) (1/(Sqrt[z+b])) (Sqrt[z+1])(z+c)^(-1/2);
phi2[z_]:=(((z-a))^(-3/2)) (1/(Sqrt[z-b])) (Sqrt[z-1]) (z-c)^(-1/2)(((z+a))^(3/2)) (((z+b))^(-3/2)) (1/(Sqrt[z+1]))(z+c)^(1/2);

dh[z_]:=(1/((-b+z) (b+z)));

G[z_]:=(((Sqrt[1+z]) (((-a+z))^(3/2)) (Sqrt[b+z]) (Sqrt[-c+z]))/((Sqrt[-1+z]) (((a+z))^(3/2)) (Sqrt[-b+z]) (Sqrt[c+z])))

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

Period Problem

phi1[z_,a_,b_,c_]:=(((z-a))^(3/2)) (((z-b))^(-3/2)) (1/(Sqrt[z-1]))(z-c)^(1/2) (((z+a))^(-3/2)) (1/(Sqrt[z+b])) (Sqrt[z+1])(z+c)^(-1/2);
phi2[z_,a_,b_,c_]:=(((z-a))^(-3/2)) (1/(Sqrt[z-b])) (Sqrt[z-1]) (z-c)^(-1/2)(((z+a))^(3/2)) (((z+b))^(-3/2)) (1/(Sqrt[z+1]))(z+c)^(1/2);

cp=I;

tst[a_,b_,c_]:={Im[NIntegrate[ phi1[z,a,b,c],{z,1,c}]-NIntegrate[ phi1[z,a,b,c],{z,-c,-1}]],
Re[NIntegrate[ phi1[z,a,b,c],{z,-1,-b}]-NIntegrate[ phi1[z,a,b,c],{z,(a+b)/2,cp,(c+1)/2}]],
Im[NIntegrate[ phi1[z,a,b,c],{z,1,c}]-NIntegrate[ phi1[z,a,b,c],{z,(b+1)/2,cp,0}]]
}

FindRoot[tst[xx,yy,zz]==0,{{xx,.5},{yy,.6},{zz,1.5}},EvaluationMonitor:> Print[{xx,yy,zz}]]

a=0.651898442408565`;
b=0.9141432185739523`;
c=3.083263210463687`;

Parametrization

δ=Re[{
		NIntegrate[ω1[z],{z,cp,0}],NIntegrate[ω2[z],{z,cp,0}],
	NIntegrate[ω3[z],{z,cp,0}]}]

f[w_]:=Re[{
		NIntegrate[ω1[z],{z,cp,w}],NIntegrate[ω2[z],{z,cp,w}],
	NIntegrate[ω3[z],{z,cp,w}]}]-δ;

n[z_]:=StereographicProjection[1/G[z]]

Domain Setup

ϵ=0.00000001;

xa=-1.5;
xb=5.;
n1=8;
n2=4;
n3=10;
ny=12;

ρ=((a^2)/(b^2));

{u1,u2,u3}=Sort[Re[{Log[-(((-1+(a^2)) (b^2))/((a^2) (-1+(b^2))))],Log[(((a^2)-(c^2))/((-(b^2)+(c^2)) ρ))],Log[b^2/a^2]}]]

xr=Union[NRange[xa,0,n1],NRange[0,u1,n2],NRange[u1,u2,n2],NRange[u2,u3,n3],NRange[u3,xb,n1],SameTest->AlmostEqual];

dm1=RectangularDomain[xr,NRange[ϵ,Pi-ϵ,ny]];

moeb[z_]:=(ρ b^2z+a^2)/(ρ z+1)

dm2=MeshApply[Sqrt[moeb[E^#]]&,dm1];

Surface Plotting

fr1=MeshPlot3D[{f[x+I y],n[x+I y]},{x,y},dm2];

fr2=MeshJoin[fr1,MeshReflect[fr1,Plane[{0,0,1},0]]];
fr3=MeshJoin[fr2,MeshReflect[fr2,Plane[{1,0,0},f[(a+b)/2][[1]]]]];
fr4=MeshJoin[fr3,MeshReflect[fr3,Plane[{0,1,0},f[(1+b)/2][[2]]]]];

Show[gr=Mesh3DToGraphics3D[fr4],PlotRange->All]