1
$\begingroup$

I have tried to plot on the surface of a sphere the spherical harmonic functions by closely following this demonstration

http://demonstrations.wolfram.com/NodalDomainsOfSphericalHarmonics/

I've copied the script from the picture available from the site as closely as I could, but when I run it the image doesn't change when I change the Manipulate settings.

    Manipulate[If[Abs[m] > l, m = Sign[m] l]; 
 coloredSphere[l, m, reim, ControlActive[30, pp]],
 {{reim, Re, "view"}, {Re -> "real", Im -> "imaginary"}},
 {{l, 6, "l"}, 0, 12, 1},
 {{m, 3, "m"}, -l, l, 1},
 {{pp, 40, "points"}, 3, 50, 1},
 Initialization :>
  {makeColoredSphereGraphicsComplex[points_, normals_, colors_] :=
    Module[{lOuter = Length[points], lInner = Length[points[[1]]]},
     GraphicsComplex[Flatten[N[points], 1], {EdgeForm[],
       GraphicsGroup[{Polygon[Flatten[#, 1] &@

           Table[{i lInner + j, 
             i lInner + j + 1, (i + 1) lInner + j + 
              1, (i + 1) lInner + j}, {i, 0, lOuter - 2}, {j, 
             lInner - 1}]]}]},
      VertexNormals -> Flatten[N[normals], 1],
      VertexColors -> Flatten[N[normals], 1]]
     ];
   spherePoints[n_] := spherePoints[n] =
     Module[{\[Psi]s = 2. Pi (Range[0, 2 n]/(2 n)), \[Phi]s = 
        1. Pi (Range[0, n]/n)},
      c\[Psi]s = Cos[\[Psi]s]; s\[Psi]s = Sin[\[Psi]s];
      c\[Phi]s = Cos[\[Phi]s]; s\[Phi]s = Sin[\[Phi]s];
      \[Psi]ones = Table[1., {k, 0, 2 n}];
      xs = Outer[Times, c\[Psi]s, s\[Phi]s];
      ys = Outer[Times, s\[Psi]s, s\[Phi]s];
      zs = Outer[Times, \[Psi]ones, c\[Phi]s];
      Transpose[{xs, ys, zs}, {3, 1, 2}]
      ];
   colors[n_, {l_, m_}, reim_] := colors[n, {l, m}, reim] =
     Module[{\[Psi]s = 2. Pi Range[0, 2 n]/(2 n), \[Phi]s = 
        1. Pi Range[0, n]/n, \[Psi]L, \[Phi]L, 
       hueData, \[CapitalDelta]h},
      \[Psi]L = reim[Exp[I m \[Psi]s]];
      \[Phi]L = LegendreP[l, m, Cos[\[Phi]s]];
      hueData = Outer[Times, \[Psi]L, \[Phi]L];
      \[CapitalDelta]h = 
       If[Max[hueData] == Min[hueData], 1, 
        Max[hueData] - Min[hueData]];
      Map[Hue, 0.8 (hueData - Min[hueData])/\[CapitalDelta]h, {2}]
      ];
   coloredSphere[l_, m_, reim_, pp_] :=
    Graphics3D[
     makeColoredSphereGraphicsComplex[spherePoints[pp], 
      spherePoints[pp], colors[pp, {l, m}, reim]], Boxed -> False, 
     ImageSize -> {400, 350}, SphericalRegion -> True, 
     ViewAngle -> \[Pi]/10];}]

I went through the script thinking something was wrong but I simply cannot understand what's going on with the GraphicsComplex function.

$\endgroup$
  • $\begingroup$ @Henrik Schumacher Thank you, that worked beautifully. If you write it as an answer I'll select it as best answer. $\endgroup$ – Mike D. Danh Feb 24 '18 at 15:28
1
$\begingroup$

Just replace VertexNormals -> Flatten[N[normals], 1] by VertexColors -> Flatten[colors, 1] in makeColoredSphereGraphicsComplex.

|improve this answer|||||
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.