Family of Schoen's FRD Surfaces

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

<< Own`Mesh`

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

Period Killing - do not use unless you want to

Clear[a, b, c, d, τ]

Choose lattice parameter:

τ =  .9  I;

dh[z_] := 1

G[z_, a_, b_, c_, 
        d_] := θ11[z - a, τ]^(-1/2. ) θ11[
            z + a, τ]^(1/2. )*
θ11[
            z - b, τ]^(-3/4. ) θ11[
            z + b, τ]^(3/4. )*
θ11[
            z - (c + τ/2), τ]^(3/4. ) θ11[
            z - (-c + τ/2), τ]^(-3/
              4. )*
θ11[
            z - (d + τ/2), τ]^(1/2. ) θ11[
            z - (-d + τ/2), τ]^(-1/2. )

G[z_, a_, b_] := G[z, a, b,  .5 - b,  .5 - a]

G[z_, a_] := G[z, a, (1 - 2*a)/3]

phi1[z_, t_] := G[z, t ] dh[z];
phi2[z_, t_] := 1/G[z, t] dh[z];

ω2[z_, t_]  := I ( phi2[z, t] + phi1[z, t] )/2

tst[a_] := 
      Block[{z}, 
        Re[NIntegrate[
            Evaluate[ω2[z, a]], {z, 
              a,  .5 - a + τ/2}]]]

Plot function to locate zero

Plot[tst[t], {t,  .1,  .2}];

FindRoot[tst[t] == 0, {t,  .18,  .19}]

Precomputed Surface Data

Execute one of the following:

τ =  .2  I; 
    a = 0.18291166075247375`;   
b = (1 - 2*a)/
        3;
c =  .5 - b;
d =  .5 - a;

τ =  .2  I; 
    a = 0.06916294332990686`;   
b = (1 - 2*a)/
        3;
c =  .5 - b;
d =  .5 - a;

τ =  .3  I; 
    a = 0.163860440685714`;   
b = (1 - 2*a)/
        3;
c =  .5 - b;
d =  .5 - a;

τ =  .35  I; 
    a = 0.1491650457558254`;   
b = (1 - 2*a)/
        3;
c =  .5 - b;
d =  .5 - a;

τ =  .4  I; a = 0.09465665268023503`;
b = (1 - 2*a)/3;
c =  .5 - b;
d =  .5 - a;

τ =  .4  I; a = 0.12451389951820327`;
b = (1 - 2*a)/3;
c =  .5 - b;
d =  .5 - a;

Weierstrass Data

G[z_] := 
      Sqrt[I] θ11[z - a, τ]^(-1/2. ) θ11[
            z + a, τ]^(1/2. )*
θ11[
            z - b, τ]^(-3/4. ) θ11[
            z + b, τ]^(3/4. )*
θ11[
            z - (c + τ/2), τ]^(3/4. ) θ11[
            z - (-c + τ/2), τ]^(-3/
              4. )*
θ11[
            z - (d + τ/2), τ]^(1/2. ) θ11[
            z - (-d + τ/2), τ]^(-1/2. )

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]

ϵ = 10^-12. ;

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

y1 = Im[τ]/2. ;

Mesh resolution:

nx = 4 ; (*number of r - 
        lines for catenoidal ends*) 

ny = 4 ; (*number of t - 
        lines for all ends *)

domain = 
        RectangularDomain[
          Union[NRange[0, a, nx], NRange[a, c, nx], NRange[c, b, nx], 
            NRange[b, d, nx], NRange[d,  .5, nx], 
            SameTest -> AlmostEqual], 
          NRange[ϵ, y1 - ϵ, ny]];

Surface Patch Creation

Ignore Nintegrate messages

v2 = f[a];

dd = v2 . {1, -1, 0}/Sqrt[2];

y2 = f[ .5 - b + τ/2][[2]]'

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

fr2 = 
        MeshJoin[fr1, 
          MeshReflect[fr1, Plane[{1, -1, 0}/Sqrt[2], dd]]];

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

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

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

gr = Mesh3DToGraphics3D[fr5];

Show[gr, Axes -> True];