Plot Taylor–Couette flow ilustratation plot

Question

I am trying to plot a set up for a classic problem of physics of fluids using Mathematica, see Wikipedia for a reference.

The problem is the movement of two concentric cylinders with two radii and velocities, as is shown in the figure.

I could generate two concentric cylinders using the following lines

 u1 = ContourPlot3D[4 == x^2 + y^2, {x, -3, 3}, {y, -3, 3}, {z, -2, 2},
   Mesh -> None, PlotPoints -> 20, ColorFunction -> Black];

u2 = ContourPlot3D[x^2 + y^2 == 1, {x, -3, 3}, {y, -3, 3}, {z, -2, 2},
    Mesh -> None, ColorFunction -> Blue];

Show[{u1, u2}]

It is possible to add vectors, radii, velocities? Any suggestions are welcome.

Answer 1

color = RGBColor[0.454, 0.695, 0.875];

u1u2 = ContourPlot3D[{4 == x^2 + y^2, x^2 + y^2 == 1}, 
      {x, -3, 3}, {y, -3, 3}, {z, -2, 2}, 
   Mesh -> None, PlotPoints -> 20, Lighting -> {{"Ambient", White}},
   ContourStyle -> {FaceForm[Opacity[0], Opacity[1, color]], 
   Opacity[1, LightGray]}];

arrows = Graphics3D[{FaceForm[Opacity[1, color]], 
   Polygon[Append[#, -2] & /@ CirclePoints[{0, 0}, {2, π}, 100]],
   Arrowheads[Large, Appearance -> "Projected"], 
   Arrow[{{0, 0, 2}, {#2 Cos@#, #2 Sin@#, 2}} & @@@ Transpose[{{0, - π/2}, {2, 1}}]], 
   Arrow[Append[Reverse@#, 3] & /@ CirclePoints[{0, 0}, {1, 0}, 100]], 
   Arrow[Append[#, -3] & /@ CirclePoints[{0, 0}, {2, 0}, 100]],
   Arrowheads[{{-.03, 1}, {-.03, 1/3}, {-.03, 2/3}}, Appearance -> "Projected"] , 
   Table[Arrow[Append[#, i] & /@ CirclePoints[{0, 0}, {1.5, π}, 100]], 
       {i, Subdivide[-1, 1, 2]}]}];

texts = Graphics3D[{ Text[Style[Subscript["R", 2], 12], {.7, 0, 2.2} ],
  Text[Style[Subscript["R", 1], 12], {-.2, -.5, 2.2} ],
  Text[Style[Subscript["Ω", 1], 14], {-Cos[π/4], Sin[π/4], 3.2} ],
  Text[Style[Subscript["Ω", 2], 14], 1.65 {-Cos[-2 π + π/16], Sin[-2 π + π/16], -3} ]}];


Show[u1u2, arrows, texts,
  PlotRange -> All, Boxed -> False, Axes -> False, BoxRatios -> {1, 1, 3}]

Answer 2

You can do this with graphics primitives. The only real problem I encountered was the size of the arrowheads. For some reason, they blow up randomly...

polygonPts = 
  Table[{Cos[th], Sin[th], z}, {z, {0, 3}}, {th, 0, Pi, Pi/50}];
polygons = 
  MapThread[Polygon@Join[#, Reverse[#2]] &, 
   Partition[#, 2, 1] & /@ polygonPts];
arrowPts = 
  Transpose@
   Table[{((1 + r)/2) Cos[th], ((1 + r)/2) Sin[th], z}, {th, 0, 2 Pi, 
     Pi/50}, {z, {0.8, 1.6, 2.4}}];
cylinderOutlinePts = 
  Table[{Cos[th], Sin[th], 3}, {th, 0, Pi, Pi/50}];
lowerArrowPts = 
  Table[{0.9 Cos[th], 0.9 Sin[th], -0.5}, {th, -Pi/2, 2 Pi - Pi/2, 
    Pi/50}];
upperArrowPts = 
  Table[{0.5 Cos[th], 0.5 Sin[th], 3.25}, {th, -Pi/2, 2 Pi - Pi/2, 
    Pi/50}];

r = 0.6;
Graphics3D[{
  Line[{{-r, 0, 0}, {-r, 0, 3}}],
  Line[{{r, 0, 0}, {r, 0, 3}}],
  Line[{{-1, 0, 0}, {-1, 0, 3}}],
  Line[{{1, 0, 0}, {1, 0, 3}}],
  Line[cylinderOutlinePts],
  Arrow[lowerArrowPts],
  Arrow[upperArrowPts],
  Arrowheads[{{Automatic, 0}, {Automatic, 0.5}}, 
   Appearance -> "Projected"],
  Arrow[arrowPts],
  LightGray,
  Cylinder[{{0, 0, 0}, {0, 0, 3}}, r],
  LightBlue,
  Cylinder[{{0, 0, 0}, {0, 0, 0.001}}],
  EdgeForm[None],
  polygons
  }, Lighting -> {"Ambient", White}, Boxed -> False]