11
$\begingroup$

I have the following function describing a molecular electronic Orbital.

f[r_] = E^-((r - R0)/\[CapitalDelta]r)^2;

r = Sqrt[x^2 + y^2 + z^2]; 
cosphi[x_, y_, z_] := If[x == 0 &&  y == 0 && z == 0, 0, z/r];

\[Rho][x_, y_, z_] = 
  f[Sqrt[x^2 + y^2 + z^2]] (c0 LegendreP[0, cosphi[x, y, z]] + 
     c1 LegendreP[1, cosphi[x, y, z]] + 
     c2 LegendreP[2, cosphi[x, y, z]] + 
     c3 LegendreP[3, cosphi[x, y, z]] + 
     c4 LegendreP[4, cosphi[x, y, z]] + 
     c5 LegendreP[5, cosphi[x, y, z]] + 
     c6 LegendreP[6, cosphi[x, y, z]] + 
     c7 LegendreP[7, cosphi[x, y, z]] + 
     c8 LegendreP[8, cosphi[x, y, z]]);


R0 = 0.55; \[CapitalDelta]r = 0.125;
c0 = 1; c1 = 0.1; c2 = 0.25; c3 = -0.3; c4 = 0.1; c5 = 0.1; c6 = \
-0.1; c7 = -0.05; c8 = 0.03;

In order to plot this I have to use the ListContourPlot3D:

data = Table[\[Rho][x, y, z], {x, -0.7, 0.7, .05}, {y, -0.7, 
    0.7, .05}, {z, -0.7, 0.7, .05}];
SO = ListContourPlot3D[data, Contours -> {0.75}, Mesh -> None, 
  DataRange -> {{-0.7, 0.7}, {-0.7, 0.7}, {-0.7, 0.7}}]

Now I need this Plot inside POV-Ray, so I adapted the workaround presented here :

vertices = SO[[1, 1]];
triangles = Cases[SO, Polygon[x_, ___] :> x, \[Infinity]][[1]];
normals = SO[[1, 3, 2]];

AccString[x_List] := 
 StringDrop[
  StringJoin[
   Map[ToString[AccountingForm[#, 20, NumberSigns -> {"-", ""}]] <> 
      "," &, x[[{1, 2, 3}]]]], -1]

POVsmoothtriangle[ind_List] := 
 StringJoin[{"smooth_triangle{<", AccString[vertices[[ind[[1]]]]], 
   ">,<", AccString[normals[[ind[[1]]]]], ">,<", 
   AccString[vertices[[ind[[2]]]]], ">,<", 
   AccString[normals[[ind[[2]]]]], ">,<", 
   AccString[vertices[[ind[[3]]]]], ">,<", 
   AccString[normals[[ind[[3]]]]], ">}"}]

Export["SO.inc", 
 Join[{"#declare SOsurface = mesh{"}, 
  Map[POVsmoothtriangle, triangles], {"}"}], "Lines"]

Doing so I encountered the following problem: It seems to be impossible to connect the individual triangles (polygons). This leads to unserviceable POVRay-Plots with huge gaps between the triangles. e.g. (Mathematica Plot top left) low res

Some suggest to just increase the resolution. Since the ListContourPlot3D needs precalculated data I found no option to increase the resolution of the plot other than increase the number of points saved in data by decreasing the stepwidth e.g.

 data = Table[\[Rho][x, y, z], {x, -0.7, 0.7, .01}, {y, -0.7, 0.7, .01}, {z, -0.7, 0.7, .01}];

This in fact produces more triangles but also shrinks them. So there is no improvement at all. high res Does anyone has a smart idea how to fix this?

$\endgroup$
  • 1
    $\begingroup$ I was doing the same thing as you, but I was plotting atomic orbitals. What I did is the following: 1. I plot the orbital in Mathematica in 2D using ContourPlot. 2. Extract the contours 3. Plot the 3D surface from the contours using RevolutionPlot3D. 4. Export the 3D object to povray and render. Hope that helps. $\endgroup$ – xslittlegrass Jun 22 '15 at 22:08

Your Answer

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

Browse other questions tagged or ask your own question.