Hoffman-Wohlgemuth

Four ends and genus 2. Embedded (Wohlgemuth)

<<Own`Mesh`

Weierstrass Data

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

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

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

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

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

Period Condition

cp=I;

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

FindRoot[tst[xx,yy]==0,{{xx,.3},{yy,.4}}]

Clear[a,b,ρ]

a=0.5936584192684387`;
b=0.8240789231309994`;

tst[a,b]

δ=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]]

ϵ=0.00000001;

Surface Parametrization

t0=Re[Log[(((b^2)-(a^2) (b^2))/((a^2) (-1+(b^2))))]]

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

t1=Re[Log[-1/ρ]]

xa=-1.5;
xb=5.;
n1=8;
n2=4;

xr=Union[NRange[xa,0,n1],NRange[0,t1,n2],NRange[t1,t0,n2],NRange[t0,xb,n1],SameTest->AlmostEqual];

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

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

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

Show[DomainToGraphics[dm2],AspectRatio->Automatic,Axes->True]

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},0]]];
fr4=MeshJoin[fr3,MeshReflect[fr3,Plane[{0,1,0},f[(a+b)/2][[2]]]]];

Show[gr=Mesh3DToGraphics3D[fr4]]