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]