Riemann Surface

Author

Eric W. Weisstein
April 15, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/ComplexAnalysis/RiemannSurface.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/RiemannSurface.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

Riemann surface visualizations by
Michael Trott

LambertW

{Re[#],Im[#]}&@(# Exp[#]&@(u+I v))

{r,i}=ComplexExpand[%]

ParametricPlot3D[Evaluate[{r,i,v}],{u,-6,2},{v,-5,5},PlotPoints->{18,32},
Ticks->None,BoxRatios->{1,1,2}]

Trott

branchPoints[poly_, {w_, z_}] := 
  Union[z /. NSolve[{poly == 0, D[poly, w] == 0}, {z, w},
                    WorkingPrecision -> 200],
        SameTest -> (Abs[#1 - #2] < 10^-6&)]

sectors[poly_, {w_, z_}] := 
Module[{ε = 10^-5, 
       (* the branch points *)
       bps = branchPoints[poly, {w, z}], 
       arg, rMax, rList, φList}, 
       (* a relative of the Arg function; 
          defined at the origin *)
       arg[ξ_] := If[ξ == 0., 0``25, Arg[ξ]]; 
       rMax = (If[#1 == 0., 1, 12/10 #1] & )[
       Max[Abs[rList = Abs /@ bps]]]; 
       (* r and φ values *)
       rList = Union[Prepend[Append[rList, rMax], 0], 
                     SameTest -> (Abs[#1 - #2] < ε&)]; 
       φList = Union[arg /@ bps, SameTest -> 
                           (Abs[#1 - #2] < ε&)]; 
       φList = Append[φList, First[φList] + 2Pi]; 
       (* the sectors *)
       N[#1, 25]&[Flatten[Table[
        {rList[[i]] + ε, φList[[j]] + ε, 
         rList[[i + 1]] - ε, φList[[j + 1]] - ε}, 
        {i, Length[rList] - 1}, 
        {j, Length[φList] - 1}], 1]]]

ode[poly_, {w_, z_}] := 
Equal @@ Solve[D[poly /. w -> w[z], z] == 0, 
               w'[z]][[1, 1]]

odeφ[ode_, {w_, z_}, {ψ_, φ_}, r_] := 
  ode //. {(w'[z] == rhs_) -> 
                    (ψ'[φ] ==  rhs D[r Exp[I φ], φ]), 
           w[z] -> ψ[φ], z -> r Exp[I φ]}

oder[ode_, {w_, z_}, {ψ_, ρ_}, 𝒹_] := 
  ode //. {(w'[z] == rhs_) -> (ψ'[ρ] == rhs D[ρ 𝒹, ρ]), 
           w[z] -> ψ[ρ], z -> 𝒹 ρ}

SetOptions[NDSolve, PrecisionGoal -> 12, 
                    AccuracyGoal -> 12, MaxSteps -> 10000];

patch[reIm_, {poly_, {w_, z_}}, 
      {odeφ_, {ψ_, φ_}, r_}, {oder_, {ψ_, ρ_}, dir_},
      {r1_, φ1_, r2_, φ2_}, {ppφ_, ppr_}] :=
Module[{radialStartingValues, radialIFs, azimuthalIFs, 
        points, ra, φa},
		(* solve poly==0 to get initial values 
		   for the differential equation *)
	   radialStartingValues = w /. 
		     Solve[poly == 0 /. {z -> r1 Exp[I φ1]}, w];
		(* solve the differential equation radially *)
	   radialIFs = 
		NDSolve[{oder /. dir -> Exp[I φ1], 
		         ψ[r1] == #}, ψ, {ρ, r1, r2}][[1, 1, 2]]& /@
		                    radialStartingValues;
	    (* solve the differential equation azimuthally *)
	   azimuthalIFs = Table[ra = r1 + i/ppr(r2 - r1);
        NDSolve[{odeφ /. r -> ra, ψ[φ1] == radialIFs[[j]][ra]},
                ψ, {φ, φ1, φ2}][[1, 1, 2]],
				          {j,Length[radialIFs]}, {i, 0, ppr}];
	   (* calculate points for all sheets *)	
	   points = Table[ra = r1 + i/ppr(r2 - r1);
		               φa = φ1 + k/ppφ(φ2 - φ1);
				      {ra Cos[φa], ra Sin[φa],
				      reIm[azimuthalIFs[[j, i + 1]][φa]]},
				      {j, Length[radialIFs]}, 
				      {i, 0, ppr}, {k, 0, ppφ}];
    	(* make polygons for all sheets *)
	   Function[s, Apply[Polygon[Join[#1, Reverse[#2]]]&,
	                  Transpose /@ 
	      Partition[Partition[#, 2, 1]& /@ s, 2, 1],
	                                 {2}]] /@ points]

patchPlotPoints[{r1_, φ1_, r2_, φ2_}, rMax_, 
                {ppφ_, ppr_}] := 
Max[#, 1]& /@ 
    Round[{ppφ, ppr}*{φ2 - φ1, r2 - r1}/{2Pi, rMax}]

RiemannSurface[poly_, {w_, z_}, reIm_, {ppφ_, ppr_}]:=
Module[{s, rMax, odePoly, odePolyφ, odePolyr,
        ψ, φ, r, dir},
		(* subdivide the complex plane *)
		s = sectors[poly, {w, z}];
		rMax = Max[#[[3]]& /@ s];
		(* calculate differential equations *)
		odePoly = ode[poly, {w, z}];
		odePolyφ = odeφ[odePoly, {w, z}, {ψ, φ}, r];
     	odePolyr = oder[odePoly, {w, z}, {ψ ,ρ}, dir];
		(* calculating the patches *)
		 Table[patch[reIm, {poly, {w, z}},
	           {odePolyφ, {ψ, φ}, r}, 
	           {odePolyr, {ψ, ρ}, dir}, s[[i]], 
	           patchPlotPoints[s[[i]], rMax, {ppφ, ppr}]],
		     {i, Length[s]}]]

makeDiamond[Polygon[l_]] := Polygon[Apply[Plus, 
             Partition[Append[l, First[l]], 2, 1], {1}]/2]

Do[
Show[Graphics3D[{EdgeForm[],
SurfaceColor[Hue[0.8 (d-2)/3], Hue[0.8(1-(d-2)/3)], 2.6],
 RiemannSurface[w^d + w + z^(d-1), {w, z}, Im, {80, 30}]/.
                               p_Polygon :> makeDiamond[p]}], 
     PlotRange -> All, BoxRatios -> {1, 1, 2},
     ViewPoint -> {2, 2, 1}
     ];,{d, 2, 5}]

Description: Riemann surfaces of the solutions of the equations ((w(z))^d)+w+(z^(d-1))=0 for d=2,3,4,5.