vector fields on spheres
- To: mathgroup at smc.vnet.net
- Subject: [mg14809] vector fields on spheres
- From: wself at viking.emcmt.edu (Will Self)
- Date: Wed, 18 Nov 1998 01:29:11 -0500
- Sender: owner-wri-mathgroup at wolfram.com
David Farrelly and Naum Phleger recently discussed plotting vector
fields on spheres.
Below is an approach to creating vector field plots on spheres. I start
with an icosahedron and subdivide it (repeatedly, if desired) to make a
Buckminster-Fuller-dome-like approximation to a sphere. I show a
vector of the vector field at each vertex of the approximate sphere.
An advantage of this approach, over, say, using lines of longitude and
latitude, is that the points at which the vectors are drawn are
distributed evenly about the sphere.
My homely picture of a vector is a line segment together with an
enlarged point at its tail. It's missing its head. If you really
wanted heads on your vectors, you could use a different function in
place of the function vec below. You can of course adjust the
PointSize[.015] to suit your taste.
You may need to adjust the length of all the vectors to get a good
picture. In the function g below, the factor .4 works pretty well if
you are using a 2-stage subdivision, as shown, but it is somewhat large
if you use a 3-stage subdivision; the vectors crowd into each other.
(By the way, the function g gives a tangent vector field on the sphere,
which does indeed vanish at at least one point (two, really), as
required by the Hairy Ball Theorem.)
You can show just the vector field, or just the sphere, or both
together, as below.
I assume that the sphere is of radius 1. The basic icosahedron is taken
from the Polyhedra package, but normalized so as to be inscribed in a
sphere of radius 1.
Write me if you want any details explained.
Will Self
vec[v_, w_] := (* a vector from point v to point w *) {{PointSize[.015],
Point[v]}, Line[{v, w}]} normalize[{x_, y_, z_}] := {x, y,
z}/Sqrt[x^2+y^2+z^2]; ubary[Polygon[{p_, q_, r_}]] :=
Module[{pq = normalize[(p + q)/2],
pr = normalize[(p + r)/2],
qr = normalize[(r + q)/2],}, {Polygon[{p, pq, pr}], Polygon[{q,
pq, qr}],
Polygon[{r, pr, qr}], Polygon[{pr, pq, qr}]}]; SetAttributes[ubary,
Listable];
<<Graphics`Polyhedra`;
Unprotect[Times];
Times[x_, Polygon[y_]] := Polygon[x y]; Protect[Times];
basicIcos = Icosahedron[]/Icosahedron[][[1, 1, 1, 3]]; sphereApprox[n_]
:= Nest[Flatten[ubary[#]]&, basicIcos, n]; (* EXAMPLE *)
g[{x_, y_, z_}] := .4 {Sqrt[1-z^2] y, -Sqrt[1-z^2] x, 0}; sph2 =
sphereApprox[2];
verts2 = Union[Flatten[List@@#& /@ sph2, 2]];
(* extracting the set of vertices *) field2 =
Graphics3D[vec[#,#+g[#]]& /@ verts2];
(* generating the list of headless arrows *) Show[field2,
Graphics3D[EdgeForm[], sph2], Boxed -> False]