Fischer-Koch BC2

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

Definitions

<< Own`Mesh`

idh[z_] := EllipticF[ArcSin[z], (1/(a^2))]/a

ϵ = 0.0000000001;

phi1[a_, b_, c_] := 
      NIntegrate[(z + a)^(-3/4) (z - b)^(1/2) (z + 
                  1)^(-1/4) (z - 1)^(-1/2) (z - 
                  c)^(-1/2) (z - a)^(-1/2), {z, 
            c + ϵ, 1 + ϵ, -1 + ϵ, 
            b + ϵ}]/
        Re[ NIntegrate[(z + a)^(-3/4) (z - b)^(1/
                    2) (z + 1)^(-1/4) (z - 1)^(-1/
                    2) (z - c)^(-1/2) (z - a)^(-1/
                    2), {z, -a, b, -1}]]

reim[z_] := {Re[z], Im[z]}

reim2[z_] := {Re[z], Im[z]/2}

per[a_, b_, c_] := 
      Abs[phi1[a, b, c] - Conjugate[phi2[a, b, c]]]

per[a_, b_, c_] := 
      reim[phi1[a, b, c] - Conjugate[phi2[a, b, c]]]

phi2[a_, b_, c_] := 
      NIntegrate[(z + a)^(-1/4) (z - b)^(-1/2) (z + 
                  1)^(-3/4) (z - 1)^(-1/2) (z - 
                  c)^(1/2) (z - a)^(-1/2), {z, 
            c + ϵ, 1 + ϵ, -1 + ϵ, 
            b + ϵ}]/
        Re[NIntegrate[(z + a)^(-1/4) (z - b)^(-1/
                    2) (z + 1)^(-3/4) (z - 1)^(-1/
                    2) (z - c)^(1/2) (z - a)^(-1/
                    2), {z, -a, b, -1}]]

dimensions[a_] := 
      reim2[Conjugate[EllipticF[ArcSin[a], (1/(a^2))]/a]]

dimensions[a_, b_] := 
      reim[EllipticF[ArcSin[b + ϵ I], (1/(a^2))]/a] - {0, dimensions[a][[2]]}

Package addition

RectangleToUpperHalfPlane[xr_, yr_, z_] := 
      Module[{
xw, 
yw, 
m1, a, b
}, 
xw = 
          Last[xr] - 
            First[xr]; 
yw = (Last[yr] - First[yr])/
            xw; 

a = 
          ModularLambda[(2.  I) yw]; 
        Print[a]; 
b = 
          2 EllipticK[a]; 
JacobiSN[
          b ((z - First[xr] - I First[yr])/xw -  .5), 
          a]
]

RectangleToUpperHalfPlane[xr_, yr_] := 
      Module[{
xw, 
yw, 
m1, a, b
}, 
xw = 
          Last[xr] - 
            First[xr]; 
yw = (Last[yr] - First[yr])/
            xw; 
m1 = 
          RectangularDomain[(xr - First[xr])/
                xw -  .5, (yr - First[yr])/xw]; 
a = 
          ModularLambda[(2.  I) yw]; 
        Print[a]; 
b = 
          2 EllipticK[a]; 
MeshApply[
          JacobiSN[b #, a] + 0.000000001  I &, 
          m1]
]

aValue[xr_, yr_] := 
      Re[RectangleToUpperHalfPlane[xr, yr, 
          Last[xr] + I Last[yr]]]

Period Computations --- do not evaluate

You need only to evaluate this part if you want/need to change the parameter a

tst[a_, b_, c_] := 
      reim[phi1[a, b, c] - Conjugate[phi2[a, b, c]]]

a = 4. ;

FindRoot[
      tst[a, u, v] == 
        0, {{u, -3.9, -1.1}, {v, 1.1, 3.9}}]

{b, c} = {u, v} /. %

Surface Patch Parametrization

Precomputed surface data to close periods

a = 4. ;
{b, c} = {-1.178009849763873`, 
          2.1538497468735116`};

{x0, y0} = dimensions[a];

b0 = dimensions[a, b][[2]];

c0 = dimensions[a, c][[2]];

yspec = Union[{-y0, b0, c0, y0}];

fff[{x_, y_}] := NRange[x, y, 6];
yr = 
        Union[Flatten[fff /@ Partition[yspec, 2, 1]], 
          SameTest -> AlmostEqual];

xr = NRange[-x0, x0, 20];

m1 = RectangularDomain[xr, yr];

m2 = RectangleToUpperHalfPlane[xr, yr];

phi1[w_] := 
      NIntegrate[(z + a)^(-3/4) (z - b)^(1/2) (z + 
                1)^(-1/4) (z - 1)^(-1/2) (z - 
                c)^(-1/2) (z - a)^(-1/2), {z, I, 
          w}]

phi2[w_] := 
      NIntegrate[(z + a)^(-1/4) (z - b)^(-1/2) (z + 
                1)^(-3/4) (z - 1)^(-1/2) (z - 
                c)^(1/2) (z - a)^(-1/2), {z, I, 
          w}]

f2[z_]  := 
        I ( ρ phi1[z] + phi2[z]/ρ )/2;
f1[z_]  := ( ρ phi1[z] - phi2[z]/ρ)/2;
f3[z_] := idh[z];

ρ = 
        Sqrt[Re[NIntegrate[(z + a)^(-1/4) (z - b)^(-1/
                        2) (z + 1)^(-3/4) (z - 1)^(-1/
                        2) (z - c)^(1/2) (z - a)^(-1/
                        2), {z, -a, b, -1}]]/
            Re[ NIntegrate[(z + a)^(-3/4) (z - b)^(1/
                        2) (z + 1)^(-1/4) (z - 1)^(-1/
                        2) (z - c)^(-1/2) (z - a)^(-1/
                        2), {z, -a, b, -1}]]];

f[z_] := Re[{f1[z], f2[z], f3[z]}]

G[z_] := ρ ((((((1 + z))^(1/4)) (Sqrt[-b + z]))/((((a + z))^(1/4)) (Sqrt[-c + z]))))

nrm[x_] := x/Sqrt[x . x]

δ = 0.001;

ttt[{u_, v_, w_}] := {-u, v, -w}

nst[
        x_] := {nrm[
          Cross[f[x] - f[x + δ], f[x] - f[x + δ I]]], 
        n[x]}

n[z_] := ttt[StereographicProjection[G[z]]]

<< RealTime3D`

<< Default3D`

Ignore error messages from NIntegrate:

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

fr2 = 
        MeshJoin[fr1, 
          MeshReflect[fr1, 
            Plane[{1, 0, 
                0}, f[-a][[1]]]]];
fr3 = 
        MeshJoin[fr2, 
          MeshReflect[fr2, 
            Plane[{0, 1, 
                0}, f[-a][[2]]]]];
fr4 = 
        MeshJoin[fr3, 
          MeshRotate[fr3, 
            StraightLine[f[-a], f[b]]]];

gr = Mesh3DToGraphics3D[fr4];

Show[gr, Axes -> False, Boxed -> False];