3
$\begingroup$

I am trying to calculate mean curvature of a parametric surface(like sphere), and I wrote this code based on this discussion. Here is my code:

MeanCurvature[(f_)?VectorQ, {u_, v_}] := 
Simplify[(-2*D[f, {u}] . D[f, {v}]*
   Det[{D[f, {u}, {v}], D[f, {u}], D[f, {v}]}] + 

  Abs[D[f, {v}] . D[f, {v}]]*
   Det[{D[f, {u, 2}], D[f, {u}], D[f, {v}]}] + 
  Abs[D[f, {u}] . D[f, {u}]]*
   Det[{D[f, {v, 2}], D[f, {u}], D[f, {v}]}])/
     (2*
  PowerExpand[
   Simplify[
     Abs[D[f, {u}] . D[f, {u}]]*
       Abs[D[f, {v}] . D[f, {v}]] - (D[f, {u}] . D[f, {v}])^2]^(3/
      2)])]; 
Options[gccolor] = 
Select[Options[ParametricPlot3D], 
FreeQ[#1, ColorFunctionScaling] & ]; 
Off[RuleDelayed::rhs]; 
signgccolor[f_, {u_, ura__}, {v_, vra__}, (opts___)?OptionQ] := 
  Module[{cf, gc, rng}, 
   cf = ColorFunction /. {opts} /. Options[gccolor]; 
        If[cf === Automatic, 
    cf = Which[Positive[#1], RGBColor[#1/(#1 + 1), 0, 0], 
       Negative[#1], RGBColor[0, 0, -(#1/(1 - #1))], True, 
                RGBColor[1, 1, 1]] & ]; 
   gc[u_, v_] = MeanCurvature[f, {u, v}]; 
   ParametricPlot3D[f, {u, ura}, {v, vra}, 
          ColorFunction -> Function[{x, y, z, u, v}, cf[gc[u, v]]], 
    ColorFunctionScaling -> False, 
    Evaluate[FilterRules[{opts}, Options[gccolor]]]]]; 
On[RuleDelayed::rhs]; 
rng = {NMinValue[{MeanCurvature[{Cos[u]*Cos[v], Sin[u]*Cos[v], 
      Sin[v]}, {u, v}], -(Pi/2) < u < Pi/2 && 0 < v < 2*Pi}, {u, v}], 
     NMaxValue[{MeanCurvature[{Cos[u]*Cos[v], Sin[u]*Cos[v], 
      Sin[v]}, {u, v}], -(Pi/2) < u < Pi/2 && 0 < v < 2*Pi}, {u, v}]}

range = {-1.0000000000000002, 1.0000000000000002} this is the first problem! mean curvature of a sphere is a constant positive number.

twist = signgccolor[{Cos[u]*Cos[v], Sin[u]*Cos[v], 
   Sin[v]}, {u, -(Pi/2), Pi/2}, {v, 0, 2*Pi}, 
     ColorFunction -> (Glow[
      Which[Positive[#1], Lighter[Red, Rescale[#1, {0, 1}, {1, 0}]], 
       Negative[#1], Lighter[Blue, Rescale[#1, {0, -1}, {1, 0}]], 
       True, 
              White]] & )]
 Animate[With[{v = RotationTransform[θ, {0, 0, 1}][{3, 0, 3}]}, 
  Show[twist, ViewPoint -> v, SphericalRegion -> True, 
   Boxed -> False, Axes -> False]], 
   {θ, 0, 2*Pi}, AnimationRate -> 0.1, 
 AnimationRunning -> True]

and the output looks like this:

enter image description here

$\endgroup$
  • 1
    $\begingroup$ Take look at this $\endgroup$ – Junho Lee Oct 19 '14 at 13:11
  • $\begingroup$ The main problem is that you've got the domains of u and v reversed in your plot: Try {v, -(Pi/2), Pi/2}, {u, 0, 2*Pi}. Whether the mean curvature of the unit sphere is +1 or -1 depends on its (surface) orientation that arise from the parametrization. Try switching Sin[v] and Cos[v], which will switch the orientation. $\endgroup$ – Michael E2 Oct 19 '14 at 18:07
2
$\begingroup$

My output looks a little bit different

sphere = {Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]};

MeanCurvature[f_] :=
  With[{du = D[f, u], dv = D[f, v]},
      Simplify[(Det[{D[du, u], du, dv}] * dv.dv -
       2 Det[{D[f, u, v], du, dv}] * du.dv + Det[{D[dv, v], du, dv}] * du.du) /
            (2 Simplify[(du.du * dv.dv - (du.dv)^2)]^(3/2))]];

mean = MeanCurvature[sphere]

enter image description here

plo = Plot[mean, {v, 0, 2 Pi}]

enter image description here

range = Last[PlotRange /. AbsoluteOptions[plo, PlotRange]]

{-1., 1.}

ParametricPlot3D[sphere, {u, 0, Pi}, {v, 0, 2 Pi},
 Mesh -> 10,
 ColorFunction -> Function[{x, y, z, u, v},
   ColorData["TemperatureMap"][Rescale[mean, range]]],
 ColorFunctionScaling -> False]

enter image description here

To answer your comment: Unlike "GaussianCurvature" "MeanCurvature" gives misleading results for "closed" surfaces like spheres or ellipsoids (a unit sphere has constant positive curvature of 1). Another example:

ellipsoid = {3/2 Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}; 

It is important to precede the following with Abs

mean = Abs @ MeanCurvature[ellipsoid];

plo =
 Plot3D[mean, {u, 0, Pi}, {v, 0, 2 Pi},
  ColorFunction -> "TemperatureMap",
  PlotRange -> All]

enter image description here

range = Last[PlotRange /. AbsoluteOptions[plo, PlotRange]];

ParametricPlot3D[ellipsoid, {u, 0, Pi}, {v, 0, 2 Pi},
 Mesh -> 10,
 MeshFunctions -> Function[{x, y, z, u, v}, Rescale[mean, range]],
 ColorFunction -> Function[{x, y, z, u, v},
   ColorData["TemperatureMap"][Rescale[mean, range]]],
 ColorFunctionScaling -> False]

enter image description here

$\endgroup$
  • $\begingroup$ See update of answer $\endgroup$ – eldo Oct 19 '14 at 14:05

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.