# Plotting a squashed sphere

It is easy to draw a sphere in Mathematica. The following command does the trick:

 ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f], Sin[th]}, {th, -Pi,
Pi}, {f, -Pi/2, Pi/2}, Mesh -> None, Axes -> None, Boxed -> False]


I am wondering if there is a way to plot a squashed sphere in Mathematica by manipulating the above command; namely a sphere that has two points that shrink like the one that is shown below

You have to imagine that this is a proper sphere with two points that shrink and you can understand that I am not a good painter.

The reason that I am asking how to manipulate the command of the ordinary round sphere, is that the ultimate goal is to create the following image:

The way that I have done it -by following some excellent answers here- is the following:

smallSphere1 =
ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f],
Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None,
PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red],
RegionFunction -> (#2 > .8 &)];
smallSphere2 =
ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f],
Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None,
PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red],
RegionFunction -> (#2 > .6 &)];
smallSphere3 =
ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f],
Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None,
PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red],
RegionFunction -> (#2 > .4 &)];
smallSphere4 =
ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f],
Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None,
PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red],
RegionFunction -> (#2 > .2 &)];
smallSphere5 =
ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f],
Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None,
PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red],
RegionFunction -> (#2 > .0 &)];
smallSphereng1 =
ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f],
Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None,
PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red],
RegionFunction -> (#2 > -.8 &)];
smallSphereneg2 =
ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f],
Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None,
PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red],
RegionFunction -> (#2 > -.6 &)];
smallSphereneg3 =
ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f],
Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None,
PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red],
RegionFunction -> (#2 > -.4 &)];
smallSphereneg4 =
ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f],
Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None,
PlotStyle -> {LightGreen}, BoundaryStyle -> Directive[Thick, Red],
RegionFunction -> (#2 > -.2 &)];
bigSphere =
ParametricPlot3D[{Cos[th] Sin[f], Cos[th] Cos[f],
Sin[th]}, {th, -Pi, Pi}, {f, -Pi/2, Pi/2}, Mesh -> None,
PlotStyle -> {LightGreen}, RegionFunction -> (#2 < 1 &)];
Show[bigSphere, smallSphere1, smallSphere2, smallSphere3, \
smallSphere4, smallSphere5, smallSphereng1, smallSphereneg2, \
smallSphereneg3, smallSphereneg4, PlotRange -> All, Axes -> None,
Boxed -> False]


Do you mean something like this?

RevolutionPlot3D[{Sin[t], t}, {t,
0, π}, {θ, -π, π}, MeshFunctions -> {#3 &},
BoundaryStyle -> None]


• Yes, thanks for this nice suggestion. I was not aware of the RevolutionPlot3D command
– user49048
May 8, 2021 at 10:14