Reflection Group Surfaces (1|)

Initialization

<<Own`Mesh`

d90[v_]:={v[[2]],-v[[1]],0}

nrml[v_]:=v/Sqrt[v.v]

For two points no vertically abov each other, find vertical plane through these points :

VerticalPlane[p1_,p2_]:=Module[{n},n=nrml[d90[p2-p1]];Plane[n,n.p2]]

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

Choose lattice parameter (positive imaginary number). This will deform the surface.

τ=.3I;

Select one of the following reflection group triangles

{r,s,t}={2,4,4};

{r,s,t}={2,3,6};

{r,s,t}={2,6,3};

{r,s,t}={3,3,3};

{r,s,t}={3,2,6};

{r,s,t}={3,6,2};

{r,s,t}={4,4,2};

{r,s,t}={4,2,4};

{r,s,t}={6,2,3};

{r,s,t}={6,3,2};

Execute all below

Weierstrass Representation

p=((-r-s+r s)/(2 (-1+r) s));

G[z_]:= (θ11[z-p,τ]/θ11[z+p,τ])^((r-1)/r);
dh[z_]:=1

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]

ϵ=0;

cp=.25+τ/4.;

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

δ0=f0[p];

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

n[w_]:=StereographicProjection[G[w]]

y1=Im[τ]/2.;
nx=3;(*number of r-lines for catenoidal ends*)
ny=5;(*number of t-lines for all ends *)

xr=Union[NRange[0,p,nx],NRange[p,.5,2nx],SameTest->AlmostEqual];
yr=NRange[ϵ, y1,ny];

domain=RectangularDomain[xr,yr];

Surface Patch Creation

trans=(f[+τ/2]+ss n[τ/2])[[1]]/.Solve[(f[+τ/2]+ss n[τ/2])[[2]]==0,ss][[1]];

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

fr2=MeshJoin[fr1,MeshReflect[fr1,Plane[{0,0,1},f[.5][[3]]]]];

Here is a fundamental domain over the triangle :

Show[gr=Mesh3DToGraphics3D[fr2],Axes->True,AxesLabel->{x,y,z}]

Larger Build

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

fr3=MeshJoin@@Table[MeshRotateZ[fr3,i 2Pi/r,0],{i,0,r-1}];

fr4=MeshTranslate[fr3,-{trans,0,0}];

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

Show[{gr=Mesh3DToGraphics3D[fr5],gr2},Axes->True,AxesLabel->{x,y,z}]