3
$\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$
0

1 Answer 1

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$
2
  • $\begingroup$ For some reason, I find that plot to be exceptionally beautiful. $\endgroup$
    – QuantumDot
    Jun 12, 2018 at 2:50
  • $\begingroup$ Thank you! I guess it's the specularity... $\endgroup$ Jun 12, 2018 at 6:09

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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