用Mathematica画3D地球、地形

研一的时候闲着无聊就一直想做3D模型，由于自己本身是做地学的，想画一个地球仪也是理所当然，于是就有了stackoverflow上各种问道，问题被close，表述不清，经历很多风雨只有，在一位外国有人的热心提示下做出了自己想要的东西，时隔两年，今天把当年的努力过程整理一下，算是献给的第一篇文章。

(*elev data input*)
elev1d = BinaryReadList[ "D:\\topo\\ETOPO5.DAT", {"Integer16"}, ByteOrdering -> +1];
elev2d = ArrayReshape[elev1d, {2160, 4320}];
lati = Flatten@Transpose@Table[Rest@Table[i, {i, 90, -90, -1/12}], {4320}];
long = Flatten@Table[Rest@Table[i, {i, 0, 360, 1/12}], {2160}];
(*make a {lat,lon,altitude} matrix*)
elevlatlon = Transpose@{lati, long, Flatten@elev1d};
(*select part of the huge amount of data,add mean earth radius to altitude*)
elevlatlonInUse = (elevlatlon[[;; ;; 12, All]] /. {m_, n_, o_} -> {m, n, o/200 + 6721}) /. {x_, y /; y > 180, z_} -> {x, y - 360, z};
coordsToXYZ[list_] := Transpose[{Cos[#[[1]]*Pi/180.]*Cos[#[[2]]*Pi/180.]*#[[3]], Cos[#[[1]]*Pi/180.]*Sin[#[[2]]*Pi/180.]*#[[3]], Sin[#[[1]]*Pi/180.]*#[[3]]} &@Transpose[list]]
xyz = First[coordsToXYZ /@ {elevlatlonInUse}];
ListPointPlot3D[xyz, BoxRatios -> {1, 1, 1}]
ListSurfacePlot3D[xyz, BoxRatios -> {1, 1, 1}]

结果显示并不是我想要的，因为mma无法差值到一个3D的球面，最后可能出于方差最小之类的考虑，给我了这样一个乱七八糟的平面：

乱七八糟的平面

事实上，画出点的分布，发现也是没错的：

点的分布

所以，ListSurfacePlot3D被证明不适合画这样大数据量的差值表面，只能用球坐标函数搞定了：

elev1d = BinaryReadList["D:\\topo\\ETOPO5.DAT", {"Integer16"}, ByteOrdering -> +1];
elev2d = ArrayReshape[elev1d, {2160, 4320}]/5 + 6731;
elevplot2d = ListContourPlot[elev2d[[2160 ;; 1 ;; -6, 1 ;; 4320 ;; 6]], ContourStyle -> None, ColorFunction -> "Topographic", Frame -> None, AspectRatio -> 0.5, ImageSize -> Full, PlotRangePadding -> None];
sealevel3d = ParametricPlot3D[ {6731*Cos[lon]*Sin[lat], 6731*Sin[lon]*Sin[lat], 6731*Cos[lat]}, {lon, 0, 2 Pi}, {lat, -Pi, 0}, Lighting -> "Neutral", RotationAction -> "Clip", Mesh -> None, Axes -> False, Boxed -> False, PlotStyle -> Directive[Opacity[0.5], Blue] ];
terr3d = ParametricPlot3D[ {elev2d[[Round@(lat/Pi*180*12), Round@(lon/Pi*180*12)]]*Cos[lon]* Sin[lat], elev2d[[Round@(lat/Pi*180*12), Round@(lon/Pi*180*12)]]*Sin[lon]* Sin[lat], elev2d[[Round@(lat/Pi*180*12), Round@(lon/Pi*180*12)]]*Cos[lat]}, {lon, 0, 2 Pi}, {lat, -Pi, 0}, TextureCoordinateFunction -> ({1-#4, 1 - #5} &), PlotStyle -> Texture[Show[elevplot2d, ImageSize -> 1000]], Lighting -> "Neutral", RotationAction -> "Clip", Mesh -> None, Axes -> False, PlotPoints -> 35, Boxed -> False ];
Show[sealevel3d, terr3d]

成品是这样的（配色依然有点丑，别介意诸位）：

当然，不画球状的3D地形还是很简单的：

elev1d = BinaryReadList["D:\\project\\mma\\topo\\ETOPO5.DAT", {"Integer16"},ByteOrdering -> +1];
lati = Flatten@Transpose@Table[Rest@Table[i, {i, 90, -90, -1/12}], {4320}];
long = Flatten@Table[Rest@Table[i, {i, 0, 360, 1/12}], {2160}];
elevlatlon =   Transpose@{long, lati, Flatten@elev1d} /. {x_ /; x > 180, y_, z_} -> {x - 360, y, z};
elevplot3d = 
 ListPlot3D[
  Cases[elevlatlon[[;; ;; 6, All]], {x_ /; x > 70 && x < 105, 
    y_ /; y > 25 && y < 45, _}], Mesh -> None, 
  ColorFunction -> "Topographic", MeshFunctions -> {#3 &}, 
  BoxRatios -> {2, 1, 0.1}, ImageSize -> Full]

QQ图片20161101104343.jpg

最后贴上地形数据源：ETOPO5.dat