Message Boards Message Boards

[GIF] Visualising minute variations in the earth's gravitational field

GROUPS:

The earth's gravitational field changes ever so slightly as we move on the earth, see also here. We can exaggerate the effect and plot a distorted "potato earth" to visualise this effect. The Wolfram Language's built in GeogravityModelData is perfect to produce 3d images like this one:

enter image description here

Generating this is actually quite trivial. We first load the built in data:

data = QuantityMagnitude@GeogravityModelData[{{-90, -180.}, {90, 180.}}, "Magnitude", GeoZoomLevel -> 0];
datamedium = Table[data[[k]]/Mean[data[[k]]], {k, 1, 128}];

You can play a bit with the GeoZoomLevel if you feel like it. We now have to translate this into changing radii of the globe. I therefore calculate deviations for averages over longitudes or alternatively latitudes to compare:

radius = 
 ListInterpolation[1. + 0.3 ((datamedium - Mean[Flatten@datamedium])/Differences[MinMax@datamedium][[1]]), {{0, Pi}, {0, 2 Pi}}, 
 InterpolationOrder -> 1]

or

radius2 = 
 ListInterpolation[1. + 0.3 Transpose@((Transpose@datamedium - Mean[Flatten@Transpose@datamedium])/
 Differences[MinMax@Transpose@datamedium][[1]]), {{0, Pi}, {0, 2 Pi}}, InterpolationOrder -> 1]

Note that I plot the gravitational strength at the surface as a change of the radius of the earth.

We can plot this on a 2D map; I do not like this particularly much, because I have the ugly fudge factor of 0.11 in the function, but it appears to work more or less.

ImageCompose[
ImageResize[ContourPlot[radius2[y, x], {x, 0 + 0.11, 2 Pi + 0.11}, {y, 0, Pi}, PlotRange -> All, Contours -> 75, ContourStyle -> None, 
ColorFunction -> "TemperatureMap", ImagePadding -> None, Frame -> False, AspectRatio -> 1/2], 1.04 ImageDimensions[worldmap]], {worldmap, 0.3}]

enter image description here

I will use a background image for the following plot, that is also in the documentation. I will attach it to this post. You might have to adjust the path to the image in the function.

SphericalPlot3D[radius[Pi - u, v], {u, 0, Pi}, {v, 0, 2 Pi}, TextureCoordinateFunction -> ({#5, 1 - #4} &), Mesh -> None, 
 PlotStyle -> Directive[Specularity[White, 10], Texture[Import["/Users/thiel/Desktop/backgroundimage.gif"]]], 
 Lighting -> "Neutral", Axes -> False, RotationAction -> "Clip", Boxed -> False, PlotPoints -> 60]

For radius2 the function is trivially like this:

SphericalPlot3D[radius2[Pi - u, v], {u, 0, Pi}, {v, 0, 2 Pi}, TextureCoordinateFunction -> ({#5, 1 - #4} &), Mesh -> None, 
     PlotStyle -> Directive[Specularity[White, 10], Texture[Import["/Users/thiel/Desktop/backgroundimage.gif"]]], 
     Lighting -> "Neutral", Axes -> False, RotationAction -> "Clip", Boxed -> False, PlotPoints -> 60]

This is, of course, quite trivial, but I liked the effect. I hope that I haven't made a mistake with the coordinates (it's late - 2:20am), but the 3d image looks good. There are strong peaks at the Rocky Mountains and the Andes, as well as the Himalayas.

Of course this applies to other data, too. If you want to try the magnetic field, this might work:

datamag = QuantityMagnitude@GeomagneticModelData[{{-90, -180.}, {90, 180.}}, "Magnitude", GeoZoomLevel -> 0];
datamediummag = Table[datamag[[k]]/Mean[datamag[[k]]], {k, 1, 128}];
radiusmag = ListInterpolation[1. + 0.3 ((datamediummag - Mean[Flatten@datamediummag])/Differences[MinMax@datamediummag][[1]]), {{0, Pi}, {0, 2 Pi}}, InterpolationOrder -> 1];
SphericalPlot3D[radiusmag[Pi - u, v], {u, 0, Pi}, {v, 0, 2 Pi}, TextureCoordinateFunction -> ({#5, 1 - #4} &), Mesh -> None, 
PlotStyle -> Directive[Specularity[White, 10], Texture[Import["/Users/thiel/Desktop/backgroundimage.gif"]]], Lighting -> "Neutral", Axes -> False, RotationAction -> "Clip", Boxed -> False, PlotPoints -> 60]

You will see that the surface is much smoother. This one really looks like a potato earth...

enter image description here

Cheers,

M.

Attachment

Attachments:
POSTED BY: Marco Thiel
Answer
1 year ago

enter image description here - another post of yours has been selected for the Staff Picks group, congratulations !

We are happy to see you at the top of the "Featured Contributor" board. Thank you for your wonderful contributions, and please keep them coming!

POSTED BY: Moderation Team
Answer
1 year ago

Group Abstract Group Abstract