Genus 2 Catenoids - Horizontal

Vertical Handles

Weierstrass Data

Clear[c1,c2,c3,c4,λ1,λ2,λ3,λ4]

G[z_]:=1/Sqrt[z]/Sqrt[z-1/3] Sqrt[z-1/2]/Sqrt[z-2] Sqrt[z-3]

dh[z_]:=1/z

ω1[z_] :=  1/2(1/G[z]-G[z])dh[z]+λ1/w[z]+λ2 z/w[z];
ω2[z_] := I /2(1/G[z]+G[z])dh[z]+λ3/w[z]+λ4 z/w[z];
ω3[z_] :=dh[z];

w[z_]:=Sqrt[z]Sqrt[z-1/2]Sqrt[z-1/3]Sqrt[z-2]Sqrt[z-3]

Close periods

π1=NIntegrate[1/2(1/G[z]-G[z])dh[z],{z,-2/5,I,2/5}]

π2=NIntegrate[1/2(1/G[z]-G[z])dh[z],{z,1/3,1/2}]

π3=NIntegrate[1/2(1/G[z]-G[z])dh[z],{z,-5/2,I,5/2}]

π4=NIntegrate[1/2(1/G[z]-G[z])dh[z],{z,2,3}]

π5=NIntegrate[1/2(1/G[z]-G[z])dh[z],{z,1/2,2}]

δ1=NIntegrate[I/2(1/G[z]+G[z])dh[z],{z,-2/5,I,2/5}]

δ2=NIntegrate[I/2(1/G[z]+G[z])dh[z],{z,1/3,1/2}]

δ3=NIntegrate[I/2(1/G[z]+G[z])dh[z],{z,-5/2,I,5/2}]

δ4=NIntegrate[I/2(1/G[z]+G[z])dh[z],{z,2,3}]

δ5=NIntegrate[I/2(1/G[z]+G[z])dh[z],{z,1/2,2}]

δ6=NIntegrate[I/2(1/G[z]+G[z])dh[z],{z,1/2,1}]

η1=NIntegrate[1/w[z],{z,-2/5,I,2/5}]

η2=NIntegrate[1/w[z],{z,1/3,1/2}]

η3=NIntegrate[1/w[z],{z,-5/2,I,5/2}]

η4=NIntegrate[1/w[z],{z,2,3}]

η5=NIntegrate[1/w[z],{z,1/2,2}]

η6=NIntegrate[1/w[z],{z,1/2,1}]

ψ1=NIntegrate[z/w[z],{z,-2/5,I,2/5}]

ψ2=NIntegrate[z/w[z],{z,1/3,1/2}]

ψ3=NIntegrate[z/w[z],{z,-5/2,I,5/2}]

ψ4=NIntegrate[z/w[z],{z,2,3}]

ψ5=NIntegrate[z/w[z],{z,1/2,2}]

ψ6=NIntegrate[z/w[z],{z,1/2,1}]

ComplexExpand[Re[π1+(c1+I c2)η1+(c3+I c4)ψ1]]==0&&ComplexExpand[Re[π3+(c1+I c2)η3+(c3+I c4)ψ3]]==0&&ComplexExpand[Re[π4+(c1+I c2)η4+(c3+I c4)ψ4]]==0&&ComplexExpand[Re[π2+(c1+I c2)η2+(c3+I c4)ψ2]]==0

Solve[%]

λ1=c1+I c2/.%[[1]];λ2=c3+I c4/.%[[1]];

ComplexExpand[Re[δ2+(c1+I c2)η2+(c3+I c4)ψ2]]==0&&ComplexExpand[Re[δ4+(c1+I c2)η4+(c3+I c4)ψ4]]==0&&ComplexExpand[Re[δ5+(c1+I c2)η5+(c3+I c4)ψ5]]==0&&ComplexExpand[Re[δ6+(c1+I c2)η6+(c3+I c4)ψ6]]==0

Solve[%]

λ3=c1+I c2/.%[[1]];λ4=c3+I c4/.%[[1]];

Integrate

<<Own`Mesh`

f0[w_] := Re[NIntegrate[{ω1[z], ω2[z], ω3[z]}, {z,   I, w}]];
δ0 = f0[2/5];
f[w_] := f0[w] - δ0
n[w_] := StereographicProjection[w];

f[2/5]

f[1]

Parametrize

r0=.1;
r1=15;
nr=5;
nt=10;

domain=PolarDomain[Union[NRange[r0,1/3,nr],NRange[1/3,1/2,nr],NRange[1/2,2,nr],NRange[2,3,nr],NRange[3,r1,nr]],NRange[0,Pi,nt]];

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

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

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

Show[Mesh3DToGraphics3D[mp3], Axes->True,AxesLabel->{x,y,z}]

Horizontal Handles

Weierstrass Data

Clear[a1,a2,a3,λ1,λ2,λ3,λ4]

{a1,a2,a3}={.75,.5,.25};

phi1[z_]:=(z-a1)^(-1/2)(z-a2)^(1/2)(z-a3)^(-1/2)(z+a3)^(1/2)(z+a2)^(-1/2)(z+a1)^(1/2);
phi2[z_]:=(z-a1)^(1/2)(z-a2)^(-1/2)(z-a3)^(1/2)(z+a3)^(-1/2)(z+a2)^(1/2)(z+a1)^(-1/2);
dh[z_]:=1;
G[z_]:=(((Sqrt[a1+z]) (Sqrt[-a2+z]) (Sqrt[a3+z]))/((Sqrt[-a1+z]) (Sqrt[a2+z]) (Sqrt[-a3+z])))

ω1[z_] :=  1/2(1/G[z]-G[z])dh[z]+λ1/w[z]+λ2 z/w[z];
ω2[z_] := I /2(1/G[z]+G[z])dh[z]+λ3/w[z]+λ4 z/w[z];
ω3[z_] :=dh[z];

Clear[λ1,λ3,λ2,λ4]

w[z_]:=(z-a1)^(1/2)(z-a2)^(1/2)(z-a3)^(1/2)(z+a3)^(1/2)(z+a2)^(1/2)(z+a1)^(1/2)

Close periods

π1=NIntegrate[1/2(1/G[z]-G[z])dh[z],{z,-a1,-a2}]

π2=NIntegrate[1/2(1/G[z]-G[z])dh[z],{z,-a2,-a3}]

π3=NIntegrate[1/2(1/G[z]-G[z])dh[z],{z,-a3,a3}]

π4=NIntegrate[1/2(1/G[z]-G[z])dh[z],{z,a3,a2}]

δ1=NIntegrate[I/2(1/G[z]+G[z])dh[z],{z,-a1,-a2}]

δ2=NIntegrate[I/2(1/G[z]+G[z])dh[z],{z,-a2,-a3}]

δ3=NIntegrate[I/2(1/G[z]+G[z])dh[z],{z,-a3,a3}]

δ4=NIntegrate[I/2(1/G[z]+G[z])dh[z],{z,a3,a2}]

η1=NIntegrate[1/w[z],{z,-a1,-a2}]

η2=NIntegrate[1/w[z],{z,-a2,-a3}]

η3=NIntegrate[1/w[z],{z,-a3,a3}]

η4=NIntegrate[1/w[z],{z,a3,a2}]

ψ1=NIntegrate[z/w[z],{z,-a1,-a2}]

ψ2=NIntegrate[z/w[z],{z,-a2,-a3}]

ψ3=NIntegrate[z/w[z],{z,-a3,a3}]

ψ4=NIntegrate[z/w[z],{z,a3,a2}]

ComplexExpand[Re[π1+(c1+I c2)η1+(c3+I c4)ψ1]]==0&&ComplexExpand[Re[π3+(c1+I c2)η3+(c3+I c4)ψ3]]==0&&
ComplexExpand[Re[π4+(c1+I c2)η4+(c3+I c4)ψ4]]==0&&
ComplexExpand[Re[π2+(c1+I c2)η2+(c3+I c4)ψ2]]==0

Solve[%]

{λ1,λ2}={c1+I c2,c3+I c4}/.%[[1]]

ComplexExpand[Re[δ1+(c1+I c2)η1+(c3+I c4)ψ1]]==0&&ComplexExpand[Re[δ3+(c1+I c2)η3+(c3+I c4)ψ3]]==0&&
ComplexExpand[Re[δ4+(c1+I c2)η4+(c3+I c4)ψ4]]==0&&
ComplexExpand[Re[δ2+(c1+I c2)η2+(c3+I c4)ψ2]]==0

Solve[%]

{λ3,λ4}={c1+I c2,λ4=c3+I c4}/.%[[1]]

Integrate

nrmlz[v_]:=v/Sqrt[v.v];
eps=0.001;
n[w_]:=nrmlz[((f[w+eps]-f[w])/eps)\[Cross]((f[w+eps I]-f[w])/eps)];

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

Parametrize

r0=.1;
r1=1;
nr=5;
nt=10;

xspec={0,a3,a2,a1,1.5};

fff[{x_,y_}]:=NRange[x,y,nr];
xr=Union[Flatten[fff/@Partition[xspec,2,1]],SameTest->AlmostEqual];
domain=PolarDomain[xr,NRange[0,Pi,nt]];

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

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

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

Show[Mesh3DToGraphics3D[mp3], Axes->True,AxesLabel->{x,y,z}]