https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Numerical Computation with no replies sorted by most likes. https://community.wolfram.com/groups/-/m/t/3208866 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=wss24-cosinor.jpg&userId=596617 [2]: https://www.wolframcloud.com/obj/b6b57d60-e946-42d1-b3b9-7cfdf0cbe02e Chase Turner 2024-07-09T18:45:38Z https://community.wolfram.com/groups/-/m/t/241732 A short post inspired by [url=http://mathematica.stackexchange.com/q/46398/13]this[/url] question. Please also see this literature: [url=http://mathworld.wolfram.com/DuffingDifferentialEquation.html]1[/url] , [url=http://en.wikipedia.org/wiki/Duffing_equation]2[/url] , [url=http://www.scholarpedia.org/article/Duffing_oscillator]3[/url]. Duffing oscillator is one of the simplest system that exhibit chaos. It is a periodically forced oscillator with a nonlinear elasticity. We will use the following from: [mcode]eq = x''[t] + ? x'[t] - x[t] + x[t]^3 == ? Cos[ t]; eq // TraditionalForm[/mcode] [img=width: 350px; height: 39px;]/c/portal/getImageAttachment?filename=ScreenShot2014-04-23at3.27.10PM.png&userId=11733[/img] The unforced undamped case with gamma and delta equal to zero is a Hamiltonian system with potential energy representing a double well potential. So basically a general case is when a driving force bounces a point between to potential minima with friction present. Usually it is associated with a model of a periodically forced steel beam which is deflected toward the two magnets: [img=width: 425px; height: 455px;]/c/portal/getImageAttachment?filename=Duffing-MagnetelasticBeam.gif&userId=11733[/img] When the system in non-chaotic regime it is synchronized perfectly with the periodic force. In the phase space of x[t] and x'[t] the trajectory of the system is passing always through the same point and is a closed lopped trajectory over a period 2 PI of the force. When we are in chaotic regie the trajectory will split and visit many close points during different periods - with points forming an attractor which can be visualized via a Poincaré section: [img=width: 280px; height: 240px;]/c/portal/getImageAttachment?filename=Duffing_rotating_anim.gif&userId=11733[/img] Imagine you will move the Poincaré section in above picture around the complete circle - how would attractor change shape? It is inefficient to run NDSolve for every new Poincaré section and we better get all the sections within one single run of NDSolve. To do that we need 2 things: 1) Specify events to track by NDSolve with WhenEvent 2) Differentiate between events so at the end they won't pile up in mixed data Here is a simple case of tracking 6 events distant at Pi/3 - all events on one figure colored differently: [mcode]evs = Mod[t, 2 \[Pi]] == # & /@ (Range[0, 2 Pi - #, #] &@(2 Pi/6)) Out[] = {Mod[t, 2 ?] == 0, Mod[t, 2 ?] == ?/3, Mod[t, 2 ?] == (2 ?)/3, Mod[t, 2 ?] == ?, Mod[t, 2 ?] == (4 ?)/3, Mod[t, 2 ?] == (5 ?)/3} [/mcode] Note that Sow function has a 2nd argument - which is a tag that allows to Reap events separately. [mcode]data = Block[{? = 0.15, ? = 0.3}, Reap[NDSolve[{eq, x[0] == 0, x'[0] == 0, WhenEvent[Evaluate@evs, Sow[{x[t], x'[t]}, Round[100 Mod[t, 2 ?]]]]}, {}, {t, 0, 200000}, MaxSteps -> ?]]]; ListPlot[data[[2]], PlotStyle -> Directive[Opacity[.5], PointSize[.002]], PlotRange -> {1.8 {-1, 1}, 1.3 {-1, 1}}, AspectRatio -> 1, Frame -> True, ImageSize -> 450][/mcode] [img=width: 450px; height: 443px;]/c/portal/getImageAttachment?filename=ewfdsfjkgioyiuyue56w4.png&userId=11733[/img] And here is a more complicated cases of 50 events shown as animation that runs while we move Poincaré section around full circle: [mcode]evs = Mod[t, 2 ?] == # & /@ (Range[0, 2 Pi - #, #] &@(2 Pi/50)); data = Block[{? = 0.15, ? = 0.3},  Reap[NDSolve[{eq, x[0] == 0, x'[0] == 0, WhenEvent[Evaluate@evs,  Sow[{x[t], x'[t]}, Round[100 Mod[t, 2 ?]]]]}, {}, {t, 0, 200000}, MaxSteps -> ?]]]; Manipulate[ ListPlot[data[[2]][[k]], PlotStyle -> PointSize[0], PlotRange -> {1.8 {-1, 1}, 1.3 {-1, 1}}, AspectRatio -> 1, Frame -> True, ImageSize -> 450], {k, 1, 50, 1}][/mcode] [img=width: 450px; height: 443px;]http://i.stack.imgur.com/sHG3f.gif[/img] Vitaliy Kaurov 2014-04-23T20:55:52Z https://community.wolfram.com/groups/-/m/t/1140010 Introduction ------------ ---------- For the past 2 weeks at the Wolfram High School Summer Camp, I have been working on a project studying Voronoi diagrams and how I could connect it to sports. My first thought was, "This will never work. How can sports be connected to something from Wolfram Language?" But then I realized that Wolfram Language can do many things to help me achieve my goal. My problem is to find a way that optimizes the offense based on the defense of a basketball team using Voronoi diagrams. I went through multiple methods trying to find a way that could represent this problem. Creating a Voronoi Diagram -------------------------- -------------------------- Here is how to create a Voronoi diagram with different colored points that represent offensive and defensive players. pt = RandomReal[{0, 10}, {10, 2}];(*creates a 10 by 2 array of points between 0 and 10*) Show[ VoronoiMesh[pt], Graphics[{PointSize@Medium, Red, Point[pt[[1 ;; 5]]], Blue, Point[pt[[6 ;; 10]]]}] ](*creates the diagram showing the points and the cells*) ![enter image description here][1] 1st Trial --------- ---------- <h3> Using the NearestNeighborGraph to connect the offensive points </h3> <p>This was one of my methods used to find a way that best optimizes the offense. The idea for this method was to use the NearestNeighborGraph function to create a polygon by connecting all the offensive(red) points. This will allow for us to calculate the area of the polygon which was created by all the offensive points.<p> ptt = RandomReal[{0, 10}, {10, 2}];(*creates a 10 by 2 array of points between 0 and 10*) ntt = NearestNeighborGraph[ptt[[1 ;; 5]], 4];(*finds the 4 nearest neighbors of the offensive(red)points*) Show[ Show[ VoronoiMesh[ptt], ntt ], Graphics[{ PointSize@Medium, Red, Point[ptt[[1 ;; 5]]], Blue, Point[ ptt[[6 ;; 10]]]}](*creates the colored points- red for offense, blue for \ defense*) ] The result: ![enter image description here][2] Now we could find the area of the polygon created from the connected offensive(red) points. ptt // Polygon@# & // RegionMeasure@# & This should return 10.145, the area of the polygon from the previous code. We can infer that the area is significant because a greater area created from these offensive points allow for more space for the offensive players to interact. A greater area created from the offensive players also infers that less space is taken up on the court by the defensive(blue) points and more space is taken up by the offensive points. Later, I found out this method was not as efficient as other methods and had some errors such as the points not being in realistic positions like it would be on a real basketball court. So what next... --------------- ---------- Once I realized that the previous method wasn't as good as I hoped it would have been, I quickly needed to find another way. So I went to my mentor. My mentor gave me a lot of information and ways I could further improve the situation. <h3>Connected Components Function (2nd method)</h3> This function allows the user to input their points into the function, creating a Voronoi diagram of the offensive and defensive players separated by the red and blue color. The user-inputted points can allow the user to choose which players are on offense and defense, allowing for more interaction between the user and the code. It will also provide the area of the respective colors cells, giving the user the information needed to infer a conclusion from the function. <h3>The FUNCTION</h3> connectedComp[points_] := Block[{off, def, oprims, oconnect, dconnect, a, b}, VoronoiMesh[points](*Voronoi Mesh creates Voronoi cells out of the \ specified points*)// MeshPrimitives[#, 2] &(*this line generates the polygon coordinates created by \ each cell*)// #[[ Ordering[(*orders the list by giving the position of the order*) Position[(*finds the position where the RegionMember \ returns true*) Outer[(*This will return a list of True or False depending \ on if the points in the Voronoi cells are located inside the region \ of the polygons created from MeshPrimitives[VoronoiMesh[points] ,2]*) RegionMember, MeshPrimitives[ VoronoiMesh[points] , 2], points, 1] , True][[All, 2]] ] ]] & // (oprims = #) &; off = Flatten[ oprims[[1 ;; Length[points]/ 2]] //(*creates the offensive points(5 points)*) SimpleGraph@RelationGraph[ Not@*RegionDisjoint,(*This provides a graph of the edges and vertices of the points when the polygons are not disjoint*) #, VertexLabels -> None] & // ConnectedComponents@# & //(*This line connects the components \ of the relation graph*) (oconnect = #) &];(*returns the first five(offensive)points*) def = Flatten[ oprims[[Length[points]/2 + 1 ;; -1]] //(*creates the defensive points(5 points)*) SimpleGraph@RelationGraph[ Not@*RegionDisjoint,(*This provides a graph of the edges and vertices of the points when the polygons are not disjoint*) #, VertexLabels -> None] & // ConnectedComponents@# & //(*This line connects the components \ of the relation graph*) (dconnect = #) &];(*returns the last five(defensive)points*) a = MaximalBy[ oconnect, Total[Area /@ #] & ] // First(*connected area of offensive team*); b = MaximalBy[ dconnect, Total[Area /@ #] & ] // First(*connected area of defensive team*); red = RGBColor["#E86850"]; blue = RGBColor["#587498"]; Show[Graphics[ {EdgeForm[Black], Lighter@blue, Complement[def, b], Lighter@red, Complement[off, a], blue, b, red, a, Black, PointSize@Medium, Point[points]}, PlotLabel -> Grid[{{"Total Area of Offense: " <> ToString[ Total[RegionMeasure /@ off]/(Total[RegionMeasure /@ off] + Total[RegionMeasure /@ def])], "Total Area of Defense: " <> ToString[ Total[RegionMeasure /@ def]/(Total[RegionMeasure /@ off] + Total[RegionMeasure /@ def])]}, {"Area of Connected Offensive Cells: " <> ToString[ Total[RegionMeasure /@ a]/Total[RegionMeasure /@ off]], "Area of Connected Defensive Cells: " <> ToString[ Total[RegionMeasure /@ b]/Total[RegionMeasure /@ def]]}}, Frame -> All, FrameStyle -> {Thick, Directive[Black]}]]]](*This graphic will show the Voronoi diagram and create a frame with the areas of the respective regions inside*) Here is a random example of what the function returns: connectedComp[RandomReal[{0,10},{10,2}]] ![enter image description here][3] The user could also input their own points: connectedComp[{{0.4, 1}, {1.4, 1.4}, {4.6, 2.5}, {8.5, 2.1}, {9.4, 8.6}, {0.5, 0.6}, {3.4, 0.9}, {6.2, 1.2}, {8.2, 0.4}, {9.7, 0.2}}] Which will return: ![enter image description here][4] This is an example of an efficient offense because of the large offensive area. This is an example of an inefficient offense because of the large connecting area of the defensive cells. connectedComp[{{0.5, 0.2}, {3.4, 0.2}, {6.2, 0.5}, {8.2, 1.4}, {9.7, 0.2}, {0.4, 9.4}, {1.4, 1.4}, {5, 2.5}, {8.7, 2.1}, {9.4, 0.2}}] ![enter image description here][5] Conclusion ---------- ---------- This function provides a very detailed diagram of the interaction between the offensive and defensive players. The red-colored cells represent the offensive players, while the blue-colored cells represent the defensive players. The lighter-colored red cells represent the offensive cells that are not connected to the rest of the the offensive cells, while the lighter-colored blue cells represent the defensive cells that are not connected to the rest of the defensive cells. The diagram also gives information about the area, in percentage, of the offensive and defensive cells. It will give you a decimal number that is determined from the area of the total offensive or defensive cells divided by the total of both the offensive and defensive cells, which represents how much space either the offense or defense covers on the court. It also provides us with data on the area of the connecting cells of offensive or defensive players. The graphic will show us a decimal number which represents the greatest connecting area for each side, calculated from maximum connected area of one side divided by the total area of that side. All of this information is significant because the greater total area of the offense allows for the offense to cover up more space on the court than the defense, giving them a better opportunity to score or advance the ball. However, a greater total area of the defense gives the offense a smaller opportunity to get a good shot and effectively run their plays. The area of connecting offensive cells shows how much space the offense could utilize without being interfered by the defense, so a greater area of connecting offensive cells would be better for optimizing the offense. Future Work ----------- ---------- Some of the ideas in the project have room for improvement. For example, I could make it to be more user-friendly. Instead of making the user enter the points for both the offense and defense, I could use the Locator function to allow the user to drag the defense to wherever the user wants and then place the offensive points at the most optimal places based on the defense the user chose. I also could have used a more efficient code by creating a code that will use less space and make the runtime faster. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-07-06at7.13.02PM.png&userId=1134707 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-07-06at7.01.35PM.png&userId=1134707 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-07-06at5.32.57PM.png&userId=1134707 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-07-06at7.43.12PM.png&userId=1134707 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-07-06at7.56.51PM.png&userId=1134707 Jordan Wang 2017-07-07T00:08:53Z https://community.wolfram.com/groups/-/m/t/931494 *NOTE: All utility functions are defined at the end and also in the attached notebook.* ---------- You can compute the first million digits of $\pi$ without printing them in < 1 second (the 1st number in the the time of computation without printing, and the printed later image is actually only a minuscule part of the whole 10^6 digits): tim[N[Pi, 10^6]] > 0.314149, 0 ![enter image description here][1] and then print the last 99: tim[Mod[Round[10^10^6*%], 10^99]] > 0.021651,0 > 315614033321272849194418437150696552087542450598956787961303311646283996346460422090106105779458151 Far better than digits is a continued fraction: longer[Pi, 9] ![enter image description here][2] This expression = $\pi$ Simplify[ReleaseHold[%]] > ? and can be freely lengthened (or shortened): longer[%%] ![enter image description here][3] Notice that $e$, unlike $\pi$, has a pattern: longer[E, 9] ![enter image description here][4] But proving that ? will never develop a pattern is one of the great unsolved problems. For faster, but non-resumable continued fractions, Mathematica has, e.g., ContinuedFraction[Pi, 9] > {3, 7, 15, 1, 292, 1, 1, 1, 2} Note the largish term at position 431: Take[ContinuedFraction[Pi, 433], -4] > {1, 4, 20776, 1} Around 1986, in a calculation taking several weeks, I found tim[Take[ContinuedFraction[Pi, 11504932], -4]] > 8.36905,4 > {1, 1, 878783625, 6} I thought Eric Weisstein found a bigger one, but [Pi Continued Fraction page][5] doesn't seem to say. Simple functions of e also have patterns: longer[(E^2 + 1)/(E^2 - 1), 9] ![enter image description here][6] $e^x$ has a nice infinite series: SeriesCoefficient[E^x, {x, 0, n}] ![enter image description here][7] This means (#1 == Activate[#1] & )[Inactive[Sum][x^n/n!, {n, 0, Infinity}]] ![enter image description here][8] Taking a few terms ser = Activate[%[[1]] /. Infinity -> 9] ![enter image description here][9] we can numerically test Euler's celebrated (#1 == Activate[#1] & )[E^Inactivate[I*Pi]] ![enter image description here][10] N[ser /. x -> I*Pi] > -0.976022 + 0.00692527 I The square root of Euler's identity is (#1 == Activate[#1] & )[E^(Inactivate[I*Pi]/2)] ![enter image description here][11] N[ser /. x -> I*(Pi/2)] > 0.0000247373 + 1. I We can even use Euler's identity to calculate ? by solving eq = E^(I*x) + 1 == 0 ![enter image description here][12] This has infinitely many solutions! Simplify[Solve[eq]] ![enter image description here][13] Unprotect[C]; Table[%[[1, 1]], {C[1], -2, 2}] > {x -> -3 ?, x -> -?, x -> ?, x -> 3 ?, x -> 5 ?} Newton's iteration says: to solve $f(x)=0$, choose an initial guess for x and iterate $g(g(...g(x)))$ where $g = x - f/ df/dx$ g[x] = Simplify[x - eq[[1]]/D[eq[[1]], x]] ![enter image description here][14] Starting with a very precise value of 3 NestList[I/E^(I*#1) + #1 + I & , 3.`69., 7] ![enter image description here][15] Each iteration of Newton's method typically doubles the number of correct digits. But isn't it slightly cockeyed to seek a real answer by applying a complex function to a real approximation? Suppose we just took the real part of $g$: ComplexExpand[Re[g[x]]] > x + Sin[x] (Remembering that Euler's identity generalizes to Euler's formula:) (#1 == ComplexExpand[#1] & )[E^(I*x)] ![enter image description here][16] Using this new $g$ NestList[#1 + Sin[#1] & , 3.`69., 5] ![enter image description here][17] triples the accuracy each time! What if we start with 9 instead of 3? NestList[#1 + Sin[#1] & , 9.`69., 5] ![enter image description here][18] Dividing the last approximation by 3 Last[%]/3 > 3.1415926535897932384626433832795028841971693993751058209749445923078 ---------- Utility functions ----------------- These are definitions of all utility functions you will need for the above evaluations. Clear[tim]; tim[xp_]:=(Print[#[[1]],",",Length[#[[2]]]]; If[#[[1]]>69,Speak[#[[1]]]];#[[2]])&@AbsoluteTiming[xp] SetAttributes[tim,HoldAll] Clear[shorter]; shorter[cf_,0]:=cf shorter[cf_,n_: 1]:=shorter[cf/.(a_: 0)+1/HoldForm[r_]:>HoldForm@@{(a+1/r)},n-1] Clear[longer]; longer[cf_,0]:=cf longer[x_?NumericQ,n_: 1]:=longer[HoldForm@@{x},n] longer[cf_,n_: 1]:=longer[cf/.HoldForm[r:Except[_Integer]]:> Floor[r]+1/HoldForm@@{Simplify@Together[1/Mod[r,1]]},n-1] tail[cf_]:=Cases[cf,HoldForm[x_]->x,\[Infinity]][[1]] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.58.04PM.png&userId=11733 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.08.37PM.png&userId=11733 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.11.21PM.png&userId=11733 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.13.18PM.png&userId=11733 [5]: http://mathworld.wolfram.com/PiContinuedFraction.html [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.18.18PM.png&userId=11733 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.20.10PM.png&userId=11733 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.22.04PM.png&userId=11733 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4017ScreenShot2016-09-29at5.22.44PM.png&userId=11733 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.23.59PM.png&userId=11733 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.25.08PM.png&userId=11733 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.26.38PM.png&userId=11733 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.27.20PM.png&userId=11733 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.30.04PM.png&userId=11733 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.30.54PM.png&userId=11733 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.32.42PM.png&userId=11733 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.33.27PM.png&userId=11733 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-09-29at5.34.24PM.png&userId=11733 Bill Gosper 2016-09-29T22:37:49Z https://community.wolfram.com/groups/-/m/t/3379973 ![functionaliterationroots][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=proj-6-cover.jpeg&userId=911151 [2]: https://www.wolframcloud.com/obj/930a433a-2ab4-478c-8542-f153add19e0f Wolfram Education Programs 2025-02-04T15:30:58Z https://community.wolfram.com/groups/-/m/t/3215276 ![Logarithmic objective function 3D plot][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2024-07-11at2.41.44%E2%80%AFPM.png&userId=3215211 [2]: https://www.wolframcloud.com/obj/0ad9a6c0-6331-46e0-93c3-7f067a610ba3 Manvik Bhadoria 2024-07-11T18:57:04Z https://community.wolfram.com/groups/-/m/t/3094917 ![SIR Models][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4037image.jpeg&userId=911151 [2]: https://www.wolframcloud.com/obj/47b57cbc-985d-4ea2-8431-9cef59ce865e Wolfram Education Programs 2024-01-02T17:29:29Z https://community.wolfram.com/groups/-/m/t/583974 Awhile ago I showed a [Unit Distance Heawood Graph][1]. Here is the McGee graph as a unit-distance graph. ![McGee graph as unit distance graph][2] Here's some gory looking code for the points: McGeePoints =RootReduce[{{0,1/2},{0,-1/2},{1/2,0},{-1/2,0}, {Sqrt[2]/4,Sqrt[2]/4},{-Sqrt[2]/4,Sqrt[2]/4},{Sqrt[2]/4,-Sqrt[2]/4},{-Sqrt[2]/4,-Sqrt[2]/4}, {Cos[a],1/2+Sin[a]},{-Cos[a],1/2+Sin[a]},{Cos[a],-1/2-Sin[a]},{-Cos[a],-1/2-Sin[a]}, {1/2+Sin[a],Cos[a]},{-1/2-Sin[a],Cos[a]},{1/2+Sin[a],-Cos[a]},{-1/2-Sin[a],-Cos[a]}, {Root[81+2592 #1+24192 #1^2+81792 #1^3+149760 #1^4+215040 #1^5-1777664 #1^6-11354112 #1^7-23052288 #1^8-15728640 #1^9+6291456 #1^10+12582912 #1^11+4194304 #1^12&,7],Root[81-2592 #1+24192 #1^2-81792 #1^3+149760 #1^4-215040 #1^5-1777664 #1^6+11354112 #1^7-23052288 #1^8+15728640 #1^9+6291456 #1^10-12582912 #1^11+4194304 #1^12&,8]}, {-Root[81+2592 #1+24192 #1^2+81792 #1^3+149760 #1^4+215040 #1^5-1777664 #1^6-11354112 #1^7-23052288 #1^8-15728640 #1^9+6291456 #1^10+12582912 #1^11+4194304 #1^12&,7],Root[81-2592 #1+24192 #1^2-81792 #1^3+149760 #1^4-215040 #1^5-1777664 #1^6+11354112 #1^7-23052288 #1^8+15728640 #1^9+6291456 #1^10-12582912 #1^11+4194304 #1^12&,8]}, {Root[81+2592 #1+24192 #1^2+81792 #1^3+149760 #1^4+215040 #1^5-1777664 #1^6-11354112 #1^7-23052288 #1^8-15728640 #1^9+6291456 #1^10+12582912 #1^11+4194304 #1^12&,7],-Root[81-2592 #1+24192 #1^2-81792 #1^3+149760 #1^4-215040 #1^5-1777664 #1^6+11354112 #1^7-23052288 #1^8+15728640 #1^9+6291456 #1^10-12582912 #1^11+4194304 #1^12&,8]}, {-Root[81+2592 #1+24192 #1^2+81792 #1^3+149760 #1^4+215040 #1^5-1777664 #1^6-11354112 #1^7-23052288 #1^8-15728640 #1^9+6291456 #1^10+12582912 #1^11+4194304 #1^12&,7],-Root[81-2592 #1+24192 #1^2-81792 #1^3+149760 #1^4-215040 #1^5-1777664 #1^6+11354112 #1^7-23052288 #1^8+15728640 #1^9+6291456 #1^10-12582912 #1^11+4194304 #1^12&,8]}, {Root[81-2592 #1+24192 #1^2-81792 #1^3+149760 #1^4-215040 #1^5-1777664 #1^6+11354112 #1^7-23052288 #1^8+15728640 #1^9+6291456 #1^10-12582912 #1^11+4194304 #1^12&,8], Root[81+2592 #1+24192 #1^2+81792 #1^3+149760 #1^4+215040 #1^5-1777664 #1^6-11354112 #1^7-23052288 #1^8-15728640 #1^9+6291456 #1^10+12582912 #1^11+4194304 #1^12&,7]}, {-Root[81-2592 #1+24192 #1^2-81792 #1^3+149760 #1^4-215040 #1^5-1777664 #1^6+11354112 #1^7-23052288 #1^8+15728640 #1^9+6291456 #1^10-12582912 #1^11+4194304 #1^12&,8], Root[81+2592 #1+24192 #1^2+81792 #1^3+149760 #1^4+215040 #1^5-1777664 #1^6-11354112 #1^7-23052288 #1^8-15728640 #1^9+6291456 #1^10+12582912 #1^11+4194304 #1^12&,7]}, {Root[81-2592 #1+24192 #1^2-81792 #1^3+149760 #1^4-215040 #1^5-1777664 #1^6+11354112 #1^7-23052288 #1^8+15728640 #1^9+6291456 #1^10-12582912 #1^11+4194304 #1^12&,8], -Root[81+2592 #1+24192 #1^2+81792 #1^3+149760 #1^4+215040 #1^5-1777664 #1^6-11354112 #1^7-23052288 #1^8-15728640 #1^9+6291456 #1^10+12582912 #1^11+4194304 #1^12&,7]}, {-Root[81-2592 #1+24192 #1^2-81792 #1^3+149760 #1^4-215040 #1^5-1777664 #1^6+11354112 #1^7-23052288 #1^8+15728640 #1^9+6291456 #1^10-12582912 #1^11+4194304 #1^12&,8], -Root[81+2592 #1+24192 #1^2+81792 #1^3+149760 #1^4+215040 #1^5-1777664 #1^6-11354112 #1^7-23052288 #1^8-15728640 #1^9+6291456 #1^10+12582912 #1^11+4194304 #1^12&,7]} }/.a->ArcSin[Root[-71+624 #1+192 #1^2-2688 #1^3-1152 #1^4+3072 #1^5+2048 #1^6&,2]]]; The lines: McGeeLines={{1,2},{1,9},{1,10},{2,11},{2,12},{3,4},{3,13},{3,15},{4,14},{4,16},{5,8},{5,17},{5,21},{6,7},{6,18},{6,22},{7,19},{7,23},{8,20},{8,24},{9,17},{9,23},{10,18},{10,24},{11,19},{11,21},{12,20},{12,22},{13,18},{13,21},{14,17},{14,22},{15,20},{15,23},{16,19},{16,24}}; That these are unit distance lines can be verified: Select[McGeeLines, RootReduce[EuclideanDistance[McGeePoints[[#[[1]]]], McGeePoints[[#[[2]]]]]] == 1 &] From the points and lines we can get the graphic. Graphics[{Line[McGeePoints[[#]]]&/@McGeeLines,Black,Disk[#,.03]&/@McGeePoints, White,Disk[#,.02]&/@McGeePoints}] To solve this, I started from GraphData["McGeeGraph", "AllImages"][[1]] and put an octagon of diameter 1 at the center. Then I added eight points of the form `{Cos[a], 1/2 + Sin[a]}`, reflected with mirror symmetries. ![McGee graph][3] I needed a point at distance 1 from two of the points. {x, y} /. FullSimplify[Solve[EuclideanDistance[{x, y}, #] == 1 & /@ {{Cos[a], 1/2 + Sin[a]}, {-1/2 - Sin[a], Cos[a]}}, {x, y}]] The second solution in terms of "a" was the one I wanted. That point needed to be a distance of 1 from `{Sqrt[2]/4,Sqrt[2]/4}`, so I solved for "a" with NSolve to a thousand digits. RootApproximant didn't recognize it, but did recognize sin(a) as Root[-71 + 624 #1 + 192 #1^2 - 2688 #1^3 - 1152 #1^4 + 3072 #1^5 + 2048 #1^6 &, 2] Plugging that into the previous equation gave a pair of order twelve root objects as solutions. Done. More details are in the attached notebook. [1]: http://community.wolfram.com/groups/-/m/t/518461 [2]: /c/portal/getImageAttachment?filename=McGeeGraph.gif&userId=21530 [3]: /c/portal/getImageAttachment?filename=McGee2.gif&userId=21530 Ed Pegg 2015-10-16T18:17:06Z https://community.wolfram.com/groups/-/m/t/1184139 Why this question affects my choice of finite element solver ------------------------------------------------------------ In my project, I am importing a complex geometry from an STL file into Mathematica as a `MeshRegion`. I would like to edit this mesh significantly: For instance, drastically reduce or increase the number of elements (for finite element analysis) or make boolean operations. But I am not sure if Mathematica can re-mesh a `MeshRegion` that is obtained from discrete data. This question is of personal importance for me because it will help decide if I can go ahead with using `NDSolve` for the finite element analysis of my project: If re-meshing is very problematic in Mathematica, it may be wiser to import volume meshes from external software, or do all of the finite element analysis in a dedicated solver like Comsol. Re-meshing an already discretized `MeshRegion` -------------------------------------------- Let me illustrate. When I work with an `ImplicitRegion`, I seem to have full control, I can make a mesh with very many or few elements, and apply boolean operations too: IR = ImplicitRegion[ x^6 - 5 x^4 y + 3 x^4 y^2 + 10 x^2 y^3 + 3 x^2 y^4 - y^5 + y^6 + z^2 <= 1, {x, y, z}]; << NDSolve`FEM` ToElementMesh[IR, MaxCellMeasure -> Infinity, AccuracyGoal -> 0]["Wireframe"] ToElementMesh[RegionDifference[IR, Cuboid[]], MaxCellMeasure -> 0.001]["Wireframe"] ![enter image description here][1] Next, I create a `MeshRegion` by applying `DiscretizeRegion`. This leaves me in basically the same situation as importing some STL mesh into Mathematica as `MeshRegion`: MR = DiscretizeRegion[IR]; (* same as MR = Import["filename.stl", "MeshRegion"] *) Now I can no longer downsample: ToElementMesh[MR, MaxCellMeasure -> Infinity, AccuracyGoal -> 0] ToElementMesh[MR] ![enter image description here][2] Same thing! No downsampling appears to have happened. Possibly no re-meshing whatsoever. Mathematica returns basically the same number of elements (`TetrahedronElement["<" 16793 ">"]` vs `TetrahedronElement["<" 16841 ">"]`, respectively). Also I can no longer apply boolean operations: RegionDifference[MR, Cuboid[]] // DiscretizeRegion returns an error ![enter image description here][3] Is there some way I could gain control of the `DiscretizeRegion` in the same way as `ImplicitRegion`? In practice, I am presented with discrete data (STL file) and I would like to be able to re-mesh it, do boolean operations, and run FEM in full control of my mesh. Is that possible? Bad brute force solution ----- You can brute force Mathematica to re-mesh using this hack: MR2 = DiscretizeGraphics[ RegionPlot3D[ RegionMember[MR, {x, y, z}] == True && RegionMember[Cuboid[], {x, y, z}] == False, {x, -2, 2}, {y, -2, 2}, {z, -2, 2}, PlotPoints -> 20]] ToElementMesh[MR2, MaxCellMeasure -> Infinity, AccuracyGoal -> 0] ![enter image description here][4] However, converting the `MeshRegion` (picture above, left) with `ToElementMesh` hopelessly overmeshes things (picture above, right). I get about 500k tetrahedral elements. Once again I don't know how to control my mesh for finite element analysis. Disclaimer ----- I have posted this question to Mathematica Stackexchange [here][5], where it has gone unanswered for several days. Because of the importance of this question for my modeling work (I need to decide if I can go ahead with Mathematica for the finite element analysis part of my project), I decided to post it to the Wolfram Community to hopefully get some developer feedback. I am happy to summarise the insights of this this discussion for the Stackexchange community once we have (hopefully) reached some conclusions. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1.png&userId=1184102 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2.png&userId=1184102 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3.png&userId=1184102 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4.png&userId=1184102 [5]: https://mathematica.stackexchange.com/questions/155484/is-it-possible-to-re-mesh-downsample-upsample-a-discretizeregion-object Alexander Erlich 2017-09-13T17:30:32Z https://community.wolfram.com/groups/-/m/t/3642901 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/f58b42ce-750f-48f1-9529-f640d895b1cc Michael Rogers 2026-02-21T02:40:03Z https://community.wolfram.com/groups/-/m/t/1351062 *Cross-posted from [Mathematica.StackExchange](https://mathematica.stackexchange.com/questions/173616)* #Motivation Mathematica ships a variety of linear solvers through the interface LinearSolve[A, b, Method -> method] the most notable for sparse matrix `A` being: - `"Multifrontal"` - the default solver for sparse arrays; direct solver based on a spare LU-factorization performed with UMFPACK. Big advantage: `LinearSolve[A]` creates a `LinearSolveFunction` object that can be reused. - `"Cholesky"` - a direct solver using the sparse Cholesky-factorization provided by TAUCS. Also produces a `LinearSolveFunction` but limited to positive-definite matrices. - `"Pardiso"` - a parallelized direct solver from the Intel MKL; undocumented but much faster and not nearly as memory hungry as `"Multifrontal"`. `LinearSolve[A, Method -> "Pardiso"]` creates a reusable `LinearSolveFunction` object as well. The original Intel MKL Pardiso solver can do quite a lot more! Unfortunately, many of its features such as reusing symbolic factorizations are not accessible via `LinearSolve`. (Or are they? That would be great to know!) - `"Krylov"` with the submethods `"ConjugateGradient"`, `"GMRES"`, and `"BiCGSTAB"` - iterative solvers that require good preconditioners and good starting values. These are supposed to work quite well for transient PDEs with smoothly varying coefficients. See [this site](http://reference.wolfram.com/language/tutorial/LinearAlgebraMatrixComputations.html#81663253) for reference. (It is a bit outdated but I don't think that any essential changes were made in the meantime - apart from `"Pardiso"`.). I mostly use linear solvers to solve PDEs, mostly elliptic ones, but also parabolic ones every now and then. On the one hand, the direct solvers hit the wall when dealing with meshes with several million degrees of freedom. And in particular, if the meshes are 3-dimensional, factorization times explode due to the high fill-in. On the other hand, the iterative solvers within Mathematica -- if I am honest -- perform so poorly on elliptic problems that I used to question the mental sanity of several numericists who told me that I had to use an iterative solver for _every_ linear system of size larger than $5 \times 5$. **Some time ago, I learned that the really big thing would be multigrid solvers. So I wonder wether one can implement such a solver in Mathematica (be it in the native language or via LibraryLink) and how it would compare to the built-in linear solvers.** #Background Details about multigrid solvers can be found in this [pretty neat script](https://www.google.com/search?client=safari&rls=en&q=multi+grid+solver&ie=UTF-8&oe=UTF-8) by Volker John. That's basically the source from which I drew the information to implement the V-cycle solver below. In a nutshell, a multigrid solver builds on two ingredients: A hierarchy of linear systems (with so-called _prolongation operators_ mapping between them) and a family of _smoothers_. #Implementation ##CG-method as smoother I use an iterative conjugate-gradient solver as smoother. For some reason, Mathematica's conjugate-gradient solver has an exorbitantly high latency, so I use my own implementation which I wrote several years ago. It's really easy to implement; all necessary details can be found, e.g., [here](https://en.wikipedia.org/wiki/Conjugate_gradient_method#The_resulting_algorithm). Note that my implementation returns an `Association` that also provides some information on the solving process. (In particular for transient PDE with varying coefficients, the number of needed iterations is often a valuable information that one might want to use for determining wether the preconditioner has to be updated.) Options[CGLinearSolve] = { "Tolerance" -> 10^(-8), "StartingVector" -> Automatic, MaxIterations -> 1000, "Preconditioner" -> Identity }; CGLinearSolve[A_?SquareMatrixQ, b_?MatrixQ, opts : OptionsPattern[]] := CGLinearSolve[A, #, opts] & /@ Transpose[b] CGLinearSolve[A_?SquareMatrixQ, b_?VectorQ, OptionsPattern[]] := Module[{r, u, ?, ?0, p, ?, ?old, z, ?, ?, x, TOL, iter, P, precdata, normb, maxiter}, P = OptionValue["Preconditioner"]; maxiter = OptionValue[MaxIterations]; normb = Sqrt[b.b]; If[Head[P] === String, precdata = SparseArray`SparseMatrixILU[A, "Method" -> P]; P = x \[Function] SparseArray`SparseMatrixApplyILU[precdata, x]; ]; If[P === Automatic, precdata = SparseArray`SparseMatrixILU[A, "Method" -> "ILU0"]; P = x \[Function] SparseArray`SparseMatrixApplyILU[precdata, x]; ]; TOL = normb OptionValue["Tolerance"]; If[OptionValue["StartingVector"] === Automatic, x = ConstantArray[0., Dimensions[A][[2]]]; r = b , x = OptionValue["StartingVector"]; r = b - A.x; ]; z = P[r]; p = z; ? = r.z; ?0 = ? = Sqrt[r.r]; iter = 0; While[? > TOL && iter < maxiter, iter++; u = A.p; ? = ?/(p.u); x = x + ? p; ?old = ?; r = r - ? u; ? = Sqrt[r.r]; z = P[r]; ? = r.z; ? = ?/?old; p = z + ? p; ]; Association[ "Solution" -> x, "Iterations" -> iter, "Residual" -> ?, "RelativeResidual" -> Quiet[Check[?/?0, ?]], "NormalizedResidual" -> Quiet[Check[?/normb, ?]] ] ]; ##Weighted Jacobi smoother The [weighted Jacobi method](https://en.wikipedia.org/wiki/Jacobi_method#Convergence_in_the_symmetric_positive_definite_case) is a very simply iterative solver that employs Richardson iterations with the diagonal of the matrix as preconditioner (the matrix must not have any zero elements on the diagonal!) and a bit of damping. Works in general only for diagonally dominant matrices and positive-definite matrices (if the `"Weight"` is chosen sufficiently small). It's not really bad but it is not excellent either. In the test problem below, it usually necessitates one more V-cycle as the CG smoother. Options[JacobiLinearSolve] = { "Tolerance" -> 10^(-8), "StartingVector" -> Automatic, MaxIterations -> 1000, "Weight" -> 2./3. }; JacobiLinearSolve[A_?SquareMatrixQ, b_?MatrixQ, opts : OptionsPattern[]] := JacobiLinearSolve[A, #, opts] & /@ Transpose[b] JacobiLinearSolve[A_?SquareMatrixQ, b_?VectorQ, OptionsPattern[]] := Module[{?, x, r, ?d, dd, iter, ?, ?0, normb, TOL, maxiter}, ? = OptionValue["Weight"]; maxiter = OptionValue[MaxIterations]; normb = Max[Abs[b]]; TOL = normb OptionValue["Tolerance"]; If[OptionValue["StartingVector"] === Automatic, x = ConstantArray[0., Dimensions[A][[2]]]; r = b; , x = OptionValue["StartingVector"]; r = b - A.x; ]; ?d = ?/Normal[Diagonal[A]]; ? = ?0 = Max[Abs[r]]; iter = 0; While[? > TOL && iter < maxiter, iter++; x += ?d r; r = (b - A.x); ? = Max[Abs[r]]; ]; Association[ "Solution" -> x, "Iterations" -> iter, "Residual" -> ?, "RelativeResidual" -> Quiet[Check[?/?0, ?]], "NormalizedResidual" -> Quiet[Check[?/normb, ?]] ] ]; ##Setting up the solver Next is a function that takes the system matrix `Matrix` and a family of prologation operators `Prolongations` and creates a `GMGLinearSolveFunction` object. This object contains a linear solving method for the deepest level in the hierarchy, the prolongation operators, and - derived from `Matrix` and `Prolongations` - a linear system matrix for each level in the hierarchy. As it is the core idea of Galerkin schemes in FEM, we interpret the system matrix `Matrix` on the finest grid as a linear operator $A_0 \colon X_0 \to X_0'$, where $X_0$ denotes the finite element function space of continuous, piecwise-linear functions on the finest mesh and $X_0'$ denotes its dual space. Denoting the finite element function space on the $i$-th subgrid by $X_i$ and interpreting the prolongation operators in the list `Prolongations` as linear embeddings $J_i \colon X_{i} \hookrightarrow X_{i-1}$, we obtain the linear operators $A_i \colon X_i \to X_i'$ by _Galerkin subspace <s>projection</s> injection_, i.e. by requiring that the following diagram is commutative: ![enter image description here][1] Per default, `LinearSolve` is used as solver for the coarsest grid, but the user may specify any other function `F` via the option `"CoarsestGridSolver" -> F`. Some pretty-printing for the created `GMGLinearSolveFunction` objects is also added. GMGLinearSolve[ Matrix_?SquareMatrixQ, Prolongations_List, OptionsPattern[{ "CoarsestGridSolver" -> LinearSolve }] ] := Module[{A}, (*Galerkin subspace projections of the system matrix*) A = FoldList[Transpose[#2].#1.#2 &, Matrix, Prolongations]; GMGLinearSolveFunction[ Association[ "MatrixHierarchy" -> A, "Prolongations" -> Prolongations, "CoarsestGridSolver" -> OptionValue["CoarsestGridSolver"][A[[-1]]], "CoarsestGridSolverFunction" -> OptionValue["CoarsestGridSolver"] ] ] ]; GMGLinearSolveFunction /: MakeBoxes[S_GMGLinearSolveFunction, StandardForm] := BoxForm`ArrangeSummaryBox[GMGLinearSolveFunction, "", BoxForm`GenericIcon[LinearSolveFunction], { { BoxForm`MakeSummaryItem[{"Specified elements: ", Length[S[[1, "MatrixHierarchy", 1]]["NonzeroValues"]]}, StandardForm] }, { BoxForm`MakeSummaryItem[{"Dimensions: ", Dimensions[S[[1, "MatrixHierarchy", 1]]]}, StandardForm], BoxForm`MakeSummaryItem[{"Depth: ", Length[S[[1, "MatrixHierarchy"]]]}, StandardForm] } }, { BoxForm`MakeSummaryItem[{ Invisible["Dimensions: "], Column[Dimensions /@ S[[1, "MatrixHierarchy", 2 ;;]]]}, StandardForm], BoxForm`MakeSummaryItem[{ "CoarsestGridSolver: ", S[[1, "CoarsestGridSolverFunction"]] }, StandardForm] }, StandardForm, "Interpretable" -> False ]; ##The solver The following is the actual V-cycle solver. To my own surpise, the algorithm was not that hard to implement. As always, most work had to be invested into the user interface (and its still not complete as it lacks bulletproofing against 1D-10T errors). Actually, this V-cycle solver is a purely algebraic solver (AMG); the _geometry_ in "geometric multigrid solver" lies within the way the matrix hierarchie was constructed (namely by geometrically nested grids and Galerkin subspace methods). Options[GMGLinearSolveFunction] = { "StartingVector" -> Automatic, "Tolerance" -> 1. 10^-8, "MaxIterations" -> 25, "StartingVectorSmoothingCounts" -> 12, "PreSmoothingCounts" -> 8, "PostSmoothingCounts" -> 8, "Smoother" -> Function[ {A, b, x0, ?, p}, ( CGLinearSolve[A, b, MaxIterations -> ?, "StartingVector" -> x0, "Tolerance" -> 10^-12 ]["Solution"] ) ], "SmootherParameters" -> None }; GMGLinearSolveFunction /: GMGLinearSolveFunction[a_Association][ Rhs_?VectorQ, opts0 : OptionsPattern[] ] := With[{ J = a["Prolongations"], A = a["MatrixHierarchy"], Asol = a["CoarsestGridSolver"] }, Module[{smoother, Rhsnorm, p, n, v, f, depth, allocationtime, startingvector, startingvectortime, solvetime, startingvectorresidual, residual, ?0, ?1, ?2, tol, maxiter, iter, opts}, opts = Merge[{ Options[GMGLinearSolveFunction], opts0 }, Last ]; n = Length /@ A; depth = Length[n]; smoother = opts["Smoother"]; p = opts["SmootherParameters"]; If[p === None, p = ConstantArray[{}, depth];]; (* allocate memory for computations *) allocationtime = AbsoluteTiming[ v = ConstantArray[0., #] & /@ n; f = Join[{Rhs}, ConstantArray[0., #] & /@ Most[n]]; ][[1]]; (* compute starting vector *) startingvectortime = AbsoluteTiming[ If[VectorQ[opts["StartingVector"]], v[[1]] = opts["StartingVector"]; , If[opts["StartingVector"] =!= "Null", opts["StartingVector"] == Automatic];]; If[opts["StartingVector"] === Automatic, Module[{b}, ?0 = opts["StartingVectorSmoothingCounts"]; If[! ListQ[?0], ?0 = If[IntegerQ[?0], ConstantArray[?0, Length[n] - 1], ?0 /@ Range[depth]]]; b = FoldList[#1.#2 &, Rhs, J]; v[[depth]] = Asol[b[[depth]]]; Do[v[[i]] = smoother[A[[i]], b[[i]], J[[i]].v[[i + 1]], ?0[[i]], p[[i]]], {i, depth - 1, 1, -1}]; ]; , ?0 = None; ]; ][[1]]; startingvector = v[[1]]; residual = startingvectorresidual = Max[Abs[Rhs - A[[1]].startingvector]]; (* perform V-cycles until tolerance is met *) solvetime = AbsoluteTiming[ ?1 = opts["PreSmoothingCounts"]; If[! ListQ[?1], ?1 = If[IntegerQ[?1], ConstantArray[?1, Length[n] - 1], ?1 /@ Range[depth]]]; ?2 = opts["PostSmoothingCounts"]; If[! ListQ[?2], ?2 = If[IntegerQ[?2], ConstantArray[?2, Length[n] - 1], ?2 /@ Range[depth]]]; Rhsnorm = Max[Abs[Rhs]]; tol = opts["Tolerance"] Rhsnorm; maxiter = opts["MaxIterations"]; iter = 0; While[ residual > tol && iter < maxiter, iter++; Do[ v[[i]] = smoother[A[[i]], f[[i]], N[Boole[i == 1]] v[[i]], ?1[[i]], p[[i]]]; f[[i + 1]] = (f[[i]] - A[[i]].v[[i]]).J[[i]], {i, 1, depth - 1}]; (* solve at deepest level with "CoarsestGridSolver" *) v[[depth]] = Asol[f[[depth]]]; Do[ v[[i]] = smoother[A[[i]], f[[i]], v[[i]] + J[[i]].v[[i + 1]], ?2[[i]], p[[i]]], {i, depth - 1, 1, -1}]; residual = Max[Abs[Subtract[Rhs, A[[1]].v[[1]]]]]; ]; ][[1]]; Association[ "Solution" -> v[[1]], "StartingVectorResidual" -> startingvectorresidual, "StartingVectorNormalizedResidual" -> startingvectorresidual/Rhsnorm, "Residual" -> residual, "NormalizedResidual" -> residual/Rhsnorm, "SuccessQ" -> residual < tol, "Timings" -> Dataset@Association[ "Total" -> allocationtime + startingvectortime + solvetime, "Allocation" -> allocationtime, "StartingVector" -> startingvectortime, "V-Cycle" -> solvetime ], "V-CycleCount" -> iter, "SmootingCounts" -> Dataset@Association[ "StartingVector" -> {?0}, "Pre" -> {?1}, "Post" -> {?2} ], "StartingVector" -> startingvector, "Smoother" -> smoother, "Depth" -> depth ] ] ]; #Applications ##2D Example What we need now is a test case! _Just by chance_, I have recently updated my [Loop subdivision routine](http://community.wolfram.com/groups/-/m/t/1338790) such that it also returns the subdivision matrix if we ask kindly. We can use these subdivision matrices as prolongation operators! So, let's start with a rather coarse mesh on the unit disk and refine it by Loop subdivision (you will need the code for [LoopSubdivide](http://community.wolfram.com/groups/-/m/t/1338790) if you want to try this): R = DiscretizeRegion[Disk[], MaxCellMeasure -> 0.001]; depth = 5; {R, J} = {Last[#1], Reverse[Rest[#2]]} & @@ Transpose@NestList[LoopSubdivide, {R, {{0}}}, depth - 1]; Let's solve the following elliptic problem with Neumann boundary conditions on the disk $\varOmega$: $$\begin{array}{rcll} (\varepsilon - \Delta) \, u &= &f, & \text{in $\varOmega\setminus \partial \varOmega$,}\\ \nu \,u&= &0, & \text{on $\partial \varOmega$.} \end{array}$$ We can use Mathematica's FEM capacities to assemble the system matrix and the right hand side for us: f = X \[Function] 16. Sinc[4. Pi Sqrt[Abs[Dot[X + 0.5, X + 0.5]]]] - 16. Sinc[4. Pi Sqrt[Abs[Dot[X - 0.5, X - 0.5]]]] + N[Sign[X[[2]]]] + N[Sign[X[[1]]]]; fvec = Map[f, MeshCoordinates[R]]; Needs["NDSolve`FEM`"] Rdiscr = ToElementMesh[ R, "MeshOrder" -> 1, "NodeReordering" -> False, MeshQualityGoal -> 0 ]; vd = NDSolve`VariableData[{"DependentVariables", "Space"} -> {{u}, {x, y}}]; sd = NDSolve`SolutionData[{"Space"} -> {Rdiscr}]; cdata = InitializePDECoefficients[vd, sd, "DiffusionCoefficients" -> {{-IdentityMatrix[2]}}, "MassCoefficients" -> {{1}}, "LoadCoefficients" -> {{f[{x, y}]}}]; bcdata = InitializeBoundaryConditions[vd sd, {DirichletCondition[u[x, y] == 0., True]}]; mdata = InitializePDEMethodData[vd, sd]; dpde = DiscretizePDE[cdata, mdata, sd]; {b, L, damping, M} = dpde["All"]; b = Flatten[Normal[b]]; A = L + 0.0001 M; Now we create a `GMGLinearSolveFunction` object and solve the equation: S = GMGLinearSolve[A, J]; // AbsoluteTiming // First xGMG = S[b, "Tolerance" -> 1. 10^-8, "StartingVectorSmoothingCounts" -> 12, "PreSmoothingCounts" -> 8, "PostSmoothingCounts" -> 8 ]["Solution"]; // AbsoluteTiming // First > 0.835408 > > 1.04969 ###Timings Here are the timings for some other solvers: xKrylov = LinearSolve[A, b, Method -> { "Krylov", "Method" -> "ConjugateGradient", "Preconditioner" -> "ILU0" }]; // AbsoluteTiming // First xTAUCS = LinearSolve[A, b, "Method" -> "Cholesky"]; // AbsoluteTiming // First xUMFPACK = LinearSolve[A, b]; // AbsoluteTiming // First xPardiso = LinearSolve[A, b, "Method" -> "Pardiso"]; // AbsoluteTiming // First > 67.948 > > 6.89134 > > 6.0961 > > 2.30715 Three things to observe here: 1. Mathematica's `"ConjugateGradient"` is the _absolute_ looser here. (But don't ask me for `"GMRES"` or `"BiCGSTAB"`; I was not in the mood of waiting for them.) 2. `"Cholesky"` cannot convert its limitation to positive-definite matrices into any advantage. That's also why I never it. 3. `GMGLinearSolve` is actually a bit faster than `"Pardiso"`. ###Errors Here are the errors; I use the UMFPACK 's solution as "ground truth" (it doesn't matter, though). Max[Abs[xUMFPACK - xGMG]] Max[Abs[xUMFPACK - xTAUCS]] Max[Abs[xUMFPACK - xPardiso]] Max[Abs[xUMFPACK - xKrylov]] > 3.90012*10^-10 > > 1.14953*10^-9 > > 2.45955*10^-10 > > 6.27234*10^-10 They all have comparable accuracy. So, this simple multigrid solver, implemented within a long afternoon, seems to be at least on par with Pardiso. Not bad, is it? ###Multiple solves are still faster with direct solvers on 2D grids Once the factorizations of the direct solvers are computed and stored in `LinearSolveFunction` objects, the actual solves (triangle forward and backward substitutions) are _much_ faster. Note that this is not necessarily the usage spectrum of iterative methods. Anyways, here are some timings: solUMFPACK = Quiet[LinearSolve[A]]; // AbsoluteTiming // First xUMFPACK = solUMFPACK[b]; // AbsoluteTiming // First solTAUCS = LinearSolve[A, "Method" -> "Cholesky"]; // AbsoluteTiming // First xTAUCS = solTAUCS[b]; // AbsoluteTiming // First solPardiso = LinearSolve[A, "Method" -> "Pardiso"]; // AbsoluteTiming // First xPardiso = solPardiso[b]; // AbsoluteTiming // First > 6.07364 > > 0.142823 > > 7.28346 > > 0.183195 > > 2.13817 > > 0.236214 Note that I used `Quiet` for UMFPACK because it complains about a bad condition number of the system and the error handling would add about 20(!) seconds to the timings. There is however no problem with the numerical errors: Max[Abs[xGMG - xUMFPACK]] Max[Abs[xGMG - xTAUCS]] Max[Abs[xGMG - xPardiso]] 3.90012*10^-10 7.59533*10^-10 1.44077*10^-10 ##3D Example The problem with direct solvers is that starting in 3 dimensions, their performance for dealing with matrices stemming from PDEs drops rapidly. This is why I wanted to show at least one 3-dimensional example. As there is no immediate analogon for Loop subdivision of tetrahedral meshes, I use hexahedral meshes instead. ###Preparation Here are some helper functions for generating the grid hierachy and the prolongation mappings. Prolongation is performed by hex-wise trilinear interpolation. This fits well since we are going to use first-order meshes. Needs["NDSolve`FEM`"] cubemesh[n_] := Module[{R}, R = ArrayMesh[ConstantArray[1, ConstantArray[n, 3]], DataRange -> ConstantArray[{0, 1}, 3]]; ToElementMesh[ "Coordinates" -> MeshCoordinates[R], "MeshElements" -> {HexahedronElement[ MeshCells[R, 3, "Multicells" -> True][[1, 1]]]}, "MeshOrder" -> 1, "NodeReordering" -> False, MeshQualityGoal -> 0 ] ] getEdges = Compile[{{i, _Integer}, {idx, _Integer, 1}}, Table[{i, Compile`GetElement[idx, j]}, {j, 1, Length[idx]}], CompilationTarget -> "C", RuntimeAttributes -> {Listable}, Parallelization -> True, RuntimeOptions -> "Speed" ]; getProlongationOperator[Rfine_ElementMesh, Rcoarse_ElementMesh, h_] := Module[{pfine, pcoarse}, pfine = Rfine["Coordinates"]; pcoarse = Rcoarse["Coordinates"]; #/Total[#, {2}] &@SparseArray[ Join @@ getEdges[ Range[Length[pfine]], Nearest[pcoarse -> Automatic, pfine, {?, h 1.1}, DistanceFunction -> ChessboardDistance] ] -> 1., {Length[pfine], Length[pcoarse]}, 0. ] ]; This creates the actual grid hierarchy and the prolongation mappings. dList = Range[6, 2, -1]; nList = 2^dList; hList = 1./(2^(dList)); RList = cubemesh /@ nList; // AbsoluteTiming // First J = Table[ getProlongationOperator[RList[[i]], RList[[i + 1]], hList[[i]]], {i, 1, Length[RList] - 1}]; // AbsoluteTiming // First > 3.84804 > > 0.603694 Again, we solve a linear elliptic problem with homogeneous Neumann boundary conditions (this is easier to implement than Dirichlet conditions). Moreover, I thought it would be a good idea to prescribe an analytic solution, so that we can discretize its right-hand side of the equation, solve the discretized PDE, and compare with the analytic solution in the end. (Note that it is essential that `v` below satisfies the homogeneous Neumann boundary conditions.) ? = 1.; Quiet[ XX = {X[[1]], X[[2]], X[[3]]}; v = X \[Function] Cos[5 Pi X[[1]]] Cos[Pi X[[2]]] Cos[3 Pi X[[3]]]; ?v = X \[Function] Evaluate[Tr[D[v[XX], {XX, 2}]]]; f = X \[Function] Evaluate[? v[XX] - ?v[XX]] ]; vd = NDSolve`VariableData[{"DependentVariables", "Space"} -> {{u}, {x, y, z}}]; sd = NDSolve`SolutionData[{"Space"} -> {RList[[1]]}]; cdata = InitializePDECoefficients[vd, sd, "DiffusionCoefficients" -> {{-IdentityMatrix[3]}}, "MassCoefficients" -> {{1}}, "LoadCoefficients" -> {{f[{x, y, z}]}} ]; bcdata = InitializeBoundaryConditions[vd, sd, {DirichletCondition[u[x, y, z] == 0., True]}]; mdata = InitializePDEMethodData[vd, sd]; dpde = DiscretizePDE[cdata, mdata, sd]; // AbsoluteTiming // First {b, L, damping, M} = dpde["All"]; b = Flatten[Normal[b]]; A = L + ? M; > 2.21493 The finest mesh `RList[[1]]` consists of `262144` hexahedra. The system matrix has size `{274625, 274625}` and contains `7189057` nonzero values. ###Timings Let's get to the timings. This time, we see that the conjugate gradient solver (with "ILU0" preconditioner) performs _much_ better than the direct solvers: xUMFPACK = LinearSolve[A, b]; // AbsoluteTiming // First xPardiso = LinearSolve[A, b, Method -> "Pardiso"]; // AbsoluteTiming // First solCG = CGLinearSolve[A, b, "Tolerance" -> 1. 10^-6, "Preconditioner" -> "ILU0"]; // AbsoluteTiming // First xCG = solCG["Solution"]; > 141.175 > > 32.0759 > > 1.70319 I'd like to point out that a major part of the time needed by UMFPACK is due to the OS's memory management (I have only 16 GB of RAM installed.) With slightly fine tuned parameters, the geometric multigrid solver performs even better: S = GMGLinearSolve[A, J]; // AbsoluteTiming // First solGMG = S[b, "Tolerance" -> 1. 10^-4, "StartingVectorSmoothingCounts" -> 6, "PreSmoothingCounts" -> 4, "PostSmoothingCounts" -> 4 ]; // AbsoluteTiming // First xGMG = solGMG["Solution"]; > 0.405304 > > 0.242293 You can inspect `Dataset@solGMG` and see for yourself that only two(!) V-cycles were needed. So, `S` can solve the same equation with hundreds(!) of right hand sides before Pardiso has finished factorization and start the first actual solve. So in practice, even the `LinearSolveFunction` objects generated by `LinearSolve` will hardly make up for this difference. ###Errors Max[Abs[xUMFPACK - xPardiso]] Max[Abs[xUMFPACK - xCG]] Max[Abs[xUMFPACK - xGMG]] > 1.42109*10^-14 > > 6.63873*10^-6 > > 3.34638*10^-6 At first glance, this does not look that good for the iterative solvers, _but_ when taking also the discretization error into accout, these errors are negligible: xTrue = Map[v, RList[[1]]["Coordinates"]]; Max[Abs[xTrue - xPardiso]]/Max[Abs[xTrue]] Max[Abs[xTrue - xCG]]/Max[Abs[xTrue]] Max[Abs[xTrue - xGMG]]/Max[Abs[xTrue]] > 0.00298862 > > 0.00299525 > > 0.00298605 [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=a.png&userId=1338740 Henrik Schumacher 2018-06-04T18:47:18Z https://community.wolfram.com/groups/-/m/t/792601 ![Cross sections of the rhombic icosahedron][1] **Transitions** I have [long been fascinated][2] by the family of shapes you get when you look at the intersection of a polyhedron or polytope with a (hyper)plane. I think what's most interesting to me is the challenge of trying to use the cross sections to try to mentally reconstruct the entire original shape. Of course, you can check your answer with polyhedron slices, but this really gets interesting as a tool for visualizing higher-dimensional polytopes (or, for that matter, other shapes). In any case, after writing a bunch of *ad hoc* code for slicing particular shapes, I finally decided to write a general function which could produce slices of arbitrary convex polytopes of any dimension. As you can see, I'm basically just taking advantage of the `ConvexHullMesh` function: slices[edges_, vec_, plotrange_] := Module[{projector, pedges, n, times, positions, v}, projector = Orthogonalize[NullSpace[{vec}]]; pedges[t_] := (1 - t) #[[1]] + t #[[2]] & /@ edges; n = Length[pedges[.5]]; times = Table[NSolve[{pedges[t][[i]].vec == #, 0 <= t <= 1}, t], {i, 1, n}]; positions = Flatten[Position[times, a_ /; a != {}, 1]]; v = Table[ pedges[t][[positions[[i]]]] /. Flatten[times[[positions[[i]]]], 1], {i, 1, Length[positions]}]; ConvexHullMesh[projector.# & /@ v, PlotRange -> plotrange, PlotTheme -> "Polygons"] ] & And here's the code for generating the slices of the rhombic icosahedron in the above GIF (notice that I don't start at the bottom and cut things off before getting to the top; past the cutoff points, you just have a linearly growing or shrinking pentagon, which is kind of boring): DynamicModule[{polyhedron, sliceaxis, plotrange, cols, edges, θ}, polyhedron = "RhombicIcosahedron"; sliceaxis = {0, 0, 1}; plotrange = 2; cols = RGBColor /@ {"#04D976", "#0f2532"}; edges = PolyhedronData[polyhedron, "VertexCoordinates"][[#]] & /@ PolyhedronData[polyhedron, "Edges"][[2, 1]]; Manipulate[θ = 3/(2 Sqrt[5]) Cos[s]; Graphics[{FaceForm[None], EdgeForm[ Directive[JoinForm["Round"], cols[[1]], Thickness[.005]]], GraphicsComplex[MeshCoordinates[#], MeshCells[#, 2]] &[ slices[edges, sliceaxis, plotrange][θ]]}, PlotRange -> plotrange, ImageSize -> 540, Background -> cols[[2]]], {s, 0, π}] ] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=rhombicicosa5c.gif&userId=610054 [2]: http://shonkwiler.org/collections/#/slices/ Clayton Shonkwiler 2016-02-12T06:02:47Z https://community.wolfram.com/groups/-/m/t/366111 Wolfram Language(WL) provides several useful interfaces to link itself to libraries written in other language. **NETLink** and **JLink** are such very powerful tools that bridge WL to the strong objective-oriented languages. I am going to show briefly an example about how to call a NuGet library for C sharp from WL. http://www.mathdotnet.com/ is a project on NuGet that promotes the numerical computing power of C sharp. It does lots of things like what BLAS and LAPACK does for linear algebra and numeric solvers. Of course Mathematica and MATLAB(R) are much more mature products than this library. I use this library simply to show how you can call an external library. I am writing this example with Mathematica 10 + Windows 7 + Visual Studio 2012. 1. Follow this link http://numerics.mathdotnet.com/ to install the `MathNet` assembly into any open project or clone the git drive 1. You can locate the assembly on your machine by right-clicking the entry in Solution Explorer (VS 2012): **reference**->**MathNet.Numeric**->**Properties** ![enter image description here][1] Now you can open Mathematica and load the `.NETLink` package. Needs["NETLink`"] You can launch the runtime link connection with InstallNET[] Assume things are going well, here is what you see: ![enter image description here][2] If you have targeted the location of `MathNet.Numerics.dll` in your project, you can load the assembly with `LoadNETAssembly` LoadNETAssembly["MathNet.Numerics","C:\\Users\\shenghui\\...myCSharpProj1\\packages\\MathNet.Numerics.3.2.3\\lib\\net40\\"] Of course your absolute path may be different, here it is just my location to store the `dll` file. As in the VS2012, you have a xml tree about the build-in classes and objects in this `MathNet` package: ![enter image description here][3] The same view can be generated within Mathematica by `NETTypeInfo` function: ![enter image description here][4] http://numerics.mathdotnet.com/docs/ provides the following example code ( `Using`'s are omitted ): Matrix<double> A = DenseMatrix.OfArray(new double[,] { {1,1,1,1}, {1,2,3,4}, {4,3,2,1}}); Vector<double>[] nullspace = A.Kernel(); This is where Mathematica has to call a different method. The `Vector` generic type is valid and can be loaded into Mathematica without problem: In:= netType=LoadNETType["MathNet.Numerics.LinearAlgebra.Vector<int>"] Out:= NETType[MathNet.Numerics.LinearAlgebra.Vector`1[System.Int32],16] However `NETNew` cannot create a vector object: ![enter image description here][5] because there is no constructor with this type. The workaround is from taking a look at class list of the `NETTypeInfo` of the `MathNet` assembly: ![enter image description here][6] `NETInfo[assem, "Classes", "*Dense*"]` is a call of such funciton with pattern match. I use this function when I notice that the C Sharp code in the online example calls the `Dense.Build` method to create a dynamic (a fancy way of using `new`) vector or matrix object. The dense method stores every item of the array. Contrary, the sparse method only store the non-zero entries. The `....DenseVector` type contains public constructors: ![enter image description here][7] (Notice that `NETTypeInfo` can take the string name of the class/type/assembly as well) To create a vector in the runtime, you just put a regular Mathematica vector of real numbers into the place of arguments: In:= a = NETNew[ "MathNet.Numerics.LinearAlgebra.Double.DenseVector", {1, 2, 3, 4}] Out:= <<NETObject[MathNet.Numerics.LinearAlgebra.Double.DenseVector]>> In:= b = NETNew[ "MathNet.Numerics.LinearAlgebra.Double.DenseVector", 10] Out:= <<NETObject[MathNet.Numerics.LinearAlgebra.Double.DenseVector]>> (* b is {0,0,...,0} *) In:= c = NETNew["MathNet.Numerics.LinearAlgebra.Double.DenseMatrix", 2, 2, {1,2,3,4}] Out:= <<NETObject[MathNet.Numerics.LinearAlgebra.Double.DenseMatrix]>> (* c is a col-major matrix: {{1,3},{2,4}}*) To get the result back to Mathematica, use the method associated with these types: In:= a@ToArray[] Out= {1.,2.,3.,4.} In:= c@ToArray[] Out= {{1.,3.},{2.,4.}} I can do this because the return type of the `ToArray` is `double[]` or `double[,]`, which are basic `System` type in C sharp and Mathematica can convert these type to `Real` automatically. One more thing to say here is that Mathematica kernel is smart enough to avoid namespace/context clashing: In:= res=(c@Transpose[])@Inverse[] (*MathNet's Transpose and Inverse*) Out= « NETObject[MathNet.Numerics.LinearAlgebra.Double.DenseMatrix]» Check the result: In:= res@ToArray[] Out= {{-2.,1.},{1.5,-0.5}} which is the same as the familiar Mathematica implementation: In:= Inverse[Transpose[c@ToArray[]]] (*the Mathematica Inverse and Transpose*) Out= {{-2.,1.},{1.5,-0.5}} [1]: /c/portal/getImageAttachment?filename=cap2.PNG&userId=23928 [2]: /c/portal/getImageAttachment?filename=cap1.PNG&userId=23928 [3]: /c/portal/getImageAttachment?filename=cap4.PNG&userId=23928 [4]: /c/portal/getImageAttachment?filename=cap3.PNG&userId=23928 [5]: /c/portal/getImageAttachment?filename=cap5.PNG&userId=23928 [6]: /c/portal/getImageAttachment?filename=cap6.PNG&userId=23928 [7]: /c/portal/getImageAttachment?filename=cap7.PNG&userId=23928 Shenghui Yang 2014-10-09T01:50:09Z https://community.wolfram.com/groups/-/m/t/3569199 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/581e0b2c-c1c4-428b-b2d8-67501096ac1c Denis Ivanov 2025-11-02T07:36:59Z https://community.wolfram.com/groups/-/m/t/3359290 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/6e3750f7-a745-4c1e-ab2c-ce7ca0c9411e Housam Binous 2025-01-18T13:54:49Z https://community.wolfram.com/groups/-/m/t/3146544 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/cf46f393-5d67-4e65-9287-05f775b6294e Housam Binous 2024-03-24T08:09:38Z https://community.wolfram.com/groups/-/m/t/2925998 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/331f466f-9901-498d-9fc6-00610c892d78 Housam Binous 2023-05-26T19:45:33Z https://community.wolfram.com/groups/-/m/t/2823264 *MODERATOR NOTE: This is the notebook used in the livestream "PDE Modeling" on Wednesday, February 1 -- a part of Wolfram R&D livestream series announced and scheduled here: https://wolfr.am/RDlive For questions about this livestream, please leave a comment below.* &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/c7af8c67-f47b-4c08-9837-1a54ab80ba4b EDITORIAL BOARD 2023-02-03T19:05:42Z https://community.wolfram.com/groups/-/m/t/1926505 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/8c53b21b-204a-44ca-8f58-443bd91a05e3 Anton Antonov 2020-04-06T16:33:51Z https://community.wolfram.com/groups/-/m/t/1668032 The Binomial and Multinomial random number generators in Mathematica are fast if multiple draws are needed from the same distribution, i.e., when the distribution parameters do not change across the draws. This can be seen by generating, for example, 500,000 draws from the Binomial distribution. In[30]:= AbsoluteTiming[ RandomVariate[BinomialDistribution[100, 0.6], 500000];] Out[30]= {0.017365, Null} However, the speed is slower, relative to some other systems, when the parameters change across draws. Such a situation arises often when performing certain Monte Carlo simulations. For example, if we have a vector nvec that contains the number of binomial trials for each draw and a vector pvec that contains the corresponding probabilities of success. nvec = RandomInteger[{5, 125}, 500000]; pvec = RandomReal[{0, 1}, 500000]; Then we have In[28]:= AbsoluteTiming[ Mean[Table[ RandomVariate[BinomialDistribution[nvec[[i]], pvec[[i]]]], {i, 1, Length@nvec}]] // N ] Out[28]= {36.2144, 32.5283} This can be addressed via an implementation of fast random number generators for the Binomial as described in Kachitvichyanukul, V.; Schmeiser, B.W. "Binomial random variate generation." Comm. ACM 31 (1988), no .2, 216 - 222. A Mathematica implementation based on the above paper involves the following three functions. When the number of trials is small, the geometric method from Devroye. L. "Generating the maximum of independent identically distributed random variables." Computers and Mathematics with Applications 6, 1960, 305-315. can be use, as in the following function. ablRanBinGeom = Compile[{{n, _Integer}, {p, _Real}}, Module[ {y = 0, x = 0, comp = 0, er, v, scale = 0.0}, If[p >= 1.0, Return[n]]; If[p <= 0.5, comp = 0; scale = -1.0/Internal`Log1p[-p], comp = 1; scale = -1.0/Log[p] ]; While[True, er = -Log[RandomReal[]]; v = er*scale; If[v > n, Break[]]; y = y + Ceiling[v]; If[y > n, Break[]]; x = x + 1; ]; If[comp == 1, n - x, x] ], CompilationTarget -> "C", RuntimeAttributes -> {Listable} ]; For larger n, we can use another function from the Communications of ACM paper referred above. ablRanBinBtpe = Compile[{{n, _Integer}, {p, _Real}}, Module[ {comp = 0, r, q, nrq, fM, M, Mi, p1, xM, xL, xR, c, a, lamL, lamR, p2, p3, p4, y, u, v, x, k, S, F, t, A, x1, f1, z, w, rho}, If[p >= 1.0, Return[n]]; If[p <= 0.5, comp = 0; r = p; q = 1.0 - p, comp = 1; r = 1.0 - p; q = p ]; nrq = n*r*q; fM = (n + 1)*r; M = Floor[fM]; Mi = Floor[M]; p1 = Floor[2.195*Sqrt[nrq] - 4.6*q] + 0.5; xM = M + 0.5; xL = xM - p1; xR = xM + p1; c = 0.134 + 20.5/(15.3 + M); a = (fM - xL)/(fM - xL*r); lamL = a*(1.0 + 0.5*a); a = (xR - fM)/(xR*q); lamR = a*(1.0 + 0.5*a); p2 = p1*(1.0 + 2.0*c); p3 = p2 + c/lamL; p4 = p3 + c/lamR; y = 0; While[True, (* Step 1 *) u = p4*RandomReal[]; v = RandomReal[]; Which[ u <= p1, y = Floor[xM - p1*v + u]; Break[], u <= p2, (* Step 2 *) x = xL + (u - p1)/c; v = v*c + 1.0 - Abs[M - x + 0.5]/p1; If[v > 1, Continue[]]; y = Floor[x], u <= p3 ,(* Step 3 *) y = Floor[xL + Log[v]/lamL]; If[y < 0, Continue[]]; v = v*(u - p2)*lamL, True, (* Step 4 *) y = Floor[xR - Log[v]/lamR]; If[y > n, Continue[]]; v = v*(u - p3)*lamR ]; A = Log[v]; If[A > (LogGamma[Mi + 1] + LogGamma[n - Mi + 1] + LogGamma[y + 1] + LogGamma[n - y + 1] + (y - Mi)*Log[r/q]), Continue[] ]; Break[]; ]; If[comp == 1, n - y, y] ], CompilationTarget -> "C", CompilationOptions -> {"InlineExternalDefinitions" -> True}, RuntimeAttributes -> {Listable} ]; We can automatically choose the appropriate method for different values of the parameters using the function ablRanBinomial = Compile[{{n, _Integer}, {p, _Real}}, Module[ {q = 1.0 - p}, If[n*Min[p, q] > 20, ablRanBinBtpe[n, p], ablRanBinGeom[n, p]] ], CompilationTarget -> "C", CompilationOptions -> {"InlineExternalDefinitions" -> True}, RuntimeAttributes -> {Listable} ]; The above functions result in considerable improvement in speed of random number generation for the Binomial. In[32]:= AbsoluteTiming[ Mean@Table[ ablRanBinomial[nvec[[i]], pvec[[i]]], {i, 1, Length@nvec}]] // N Out[32]= {0.413019, 32.5307} This can be further improved by leveraging the listability property of the functions as follows. In[33]:= AbsoluteTiming[Mean@ablRanBinomial[nvec, pvec] // N] Out[33]= {0.156881, 32.5337} The above functions can then be used for generating multinomial draws. The multinomial distribution is specified via two parameters. n is the number of trials, and p is a vector of probabilities that sum to 1. Multinomial variates can be generated using the following function: ablRanMultinomial=Compile[{{n, _Integer},{p, _Real, 1}}, Module[ {k=Length[p], rp,i, km1,cn,pi,xi,x}, rp=1.0;cn=n; i=0; km1=k-1; x=Table[0, {k}]; While[i<km1 && cn >0, i+=1; pi=p[[i]]; If[pi < rp, xi=ablRanBinomial[cn, pi/rp]; x[[i]]=xi; cn-=xi; rp-=pi;, x[[i]]=cn; cn=0 ]; ]; If[i==km1, x[[k]]=cn, Do[x[[j]]=0,{j,i+1, k}] ]; x ], CompilationTarget->"C", CompilationOptions->{"InlineExternalDefinitions" -> True}, RuntimeAttributes->{Listable} ]; This can be used as follows: In[36]:= ablRanMultinomial[20, {0.5, 0.3, 0.2}] Out[36]= {12, 7, 1} Asim Ansari 2019-04-24T14:20:43Z