Alan Schoen's I-WP surface

Matthias Weber
Indiana University
http://www.indiana.edu/~minimal

<< Own`Mesh`

Weierstrass Data

Choose lattice parameter

τ = 1.  I;

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

dh[z_] := 1
ρ = 1. ;
a0 = 1/6. ; b0 = 1/3. ;
G[z_] := 
      Sqrt[I] θ11[z - a0, τ]^(3/4)/θ11[
              z + a0, τ]^(3/4) θ11[
              z + b0 + τ/2, τ]^(3/4)/θ11[
              z - b0 + τ/2, τ]^(3/4)

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]

ϵ = 10^-9. ;

cp =  .25 + τ/4. ;

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

δ0 = f0[0];

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

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

Surface Parameterization

y1 = Im[τ]/2. ;

    nx = 3;  


    ny = 6 ;

domain = 
        RectangularDomain[
          Union[NRange[0, a0, nx], NRange[a0, b0, nx], NRange[b0,  .5, nx], 
            SameTest -> AlmostEqual], 
          NRange[ϵ, y1, ny]];

Surface Patch Creation

Ignore NIntegrate warnings

fa0 = f[a0];
fb0 = f[b0 + τ/2];

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

fr2 = 
        MeshJoin[fr1, 
          MeshReflect[fr1, Plane[{1, 0, 0}, fa0 . {1, 0, 0}]]];

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

fr4 = 
        MeshJoin[fr3, 
          MeshReflect[fr3, 
            Plane[{1, 1, 0}/Sqrt[2], fb0 . {1, 1, 0}/Sqrt[2]]]];

fr5 = 
        MeshJoin[fr4, 
          MeshReflect[fr4, 
            Plane[{1, -1, 0}/Sqrt[2], 
              fb0 . {1, -1, 0}/Sqrt[2]]]];

gr = Mesh3DToGraphics3D[fr5];

<< RealTime3D`

<< Default3D`

Show[gr, Axes -> True];