2
$\begingroup$

Lets say I wanted to make a highly detailed graph of a 3D function. Generally I use something like

Plot3D[(x^2 + y^2)*Sin[1/Sqrt[x^2 + y^2]], {x, -1/8, 1/8}, {y, -1/8, 1/8}, PlotPoints -> {800, 800}]

That literally takes about 2 minutes to evaluate. Looking at the task manager I see that Mathematica does not use as much processing power as it could:

enter image description here

So actually there is no need to make it faster but I wonder if its possible to use mroe processing power.

$\endgroup$
7
$\begingroup$

(Salvaging from this post.)

On my machine, thes following produces the image in about seven seconds. Note that over 95 percent of that time are spent solely by in the frontend, so further optimization is out of reach for me.

range = {{-1/8, 1/8}, {-1/8, 1/8}};
plotpoints = {100, 100} 8;
mesh = {16, 16};
f = {x, y} \[Function] Evaluate[(x^2 + y^2)*Sin[1/Sqrt[x^2 + y^2]]];
νf = {x, y} \[Function] 
   Evaluate[-Cross @@ Transpose[D[{x, y, f[x, y]}, {{x, y}, 1}]]];

cfsurface = With[{code = {
      Compile`GetElement[X, 1],
      Compile`GetElement[X, 2],
      f[Compile`GetElement[X, 1], Compile`GetElement[X, 2]]}
    },
   Compile[{{X, _Real, 1}}, code, RuntimeAttributes -> {Listable}, Parallelization -> True]];

cνf = 
  With[{code = νf[Compile`GetElement[X, 1], Compile`GetElement[X, 2]]}, 
   Compile[{{X, _Real, 1}}, code, RuntimeAttributes -> {Listable}, Parallelization -> True]];

getQuads = 
  Compile[{{m, _Integer}, {n, _Integer}}, 
   Flatten[Table[{m (j - 1) + i, m (j - 1) + i + 1, m j + i + 1, m j + i}, {j, 1, n - 1}, {i, 1, m - 1}], 1], 
   CompilationTarget -> "C", RuntimeOptions -> "Speed"];


xran = Sequence @@ N[range[[1]]];
yran = Sequence @@ N[range[[2]]];
xcoords = Subdivide[xran, plotpoints[[1]] - 1];
ycoords = Subdivide[yran, plotpoints[[2]] - 1];
pts2D = Tuples[{xcoords, ycoords}];
xlines = cfsurface@Outer[List, Subdivide[xran, mesh[[2]] - 1], ycoords];
ylines = Transpose@cfsurface@Outer[List, xcoords, Subdivide[yran, mesh[[2]] - 1]];

Graphics3D[{
  GraphicsComplex[
   cfsurface[pts2D],
   {EdgeForm[], Orange, Specularity[White, 30], 
    Polygon[getQuads @@ plotpoints]},
   VertexNormals -> cνf[pts2D]
   ],
  Line@xlines,
  Line@ylines
  },
 Lighting -> "Neutral"]

enter image description here

$\endgroup$
  • $\begingroup$ For some reason, I find that plot to be exceptionally beautiful. $\endgroup$ – QuantumDot Jun 12 '18 at 2:50
  • $\begingroup$ Thank you! I guess it's the specularity... $\endgroup$ – Henrik Schumacher Jun 12 '18 at 6:09

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.