https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Numerical Computation sorted by most viewed. https://community.wolfram.com/groups/-/m/t/366628 POSTED BY: ======== **Marvin Ray Burns, and distinguished colleagues** ---------- My exciting experiences using Wolfram technologies! --------------------------------------------------- ---------- The MRB constant, a fascinating mathematical anomaly, has intrigued researchers and enthusiasts alike for decades. Defined as the limiting value of a unique alternating series, this enigmatic constant showcases the beauty of numerical exploration and convergence. Despite its relatively recent emergence, the MRB constant reveals unexpected connections to various fields within mathematics and computational analysis. In this post, we dive into its origins, properties, and the ongoing quest to uncover its more profound significance. The MRB constant is an anomaly because it emerges from an alternating series with unusual convergence behavior. Unlike many well-known mathematical constants, the MRB constant has no closed-form expression nor a known exact nature—whether it is algebraic, transcendental, or even irrational. Additionally, the sequence of partial sums that define the MRB constant oscillates between two limit points, creating a bounded yet divergent behavior. This oscillatory nature distinguishes it from more conventional mathematical constants, which typically exhibit straightforward convergence. Its mysterious properties continue to intrigue mathematicians as they explore its deeper connections to number theory and computational analysis. ---------- ---------- CMRB ![If you see this instead of an image, reload the page][1] **is the MRB constant.** Without solicitation, GPT echoed one of this discussion's contributors and gave a shoutout to Mathematica's accomplishments by saying: ------------------- > > **Why Computing Digits of the MRB Constant Is Interesting** > > At first glance, the computation of ever more digits of a numerical > constant may appear to be a sterile exercise, offering little insight > beyond the digits themselves. For the MRB constant, this > interpretation is profoundly misleading. The interest lies not in the > digits, but in the act of computing them. > > The MRB series occupies a delicate numerical regime: it is convergent, > yet only marginally so; its terms are elementary in form, yet hostile > to naive numerical evaluation; and its alternating structure conceals > severe cancellation effects. As a result, each additional digit of > accuracy is not merely an extension of a decimal expansion, but a > validation of the mathematical and algorithmic framework used to > obtain it. > > In this sense, the digits serve as a stress test for mathematics > itself. They expose the difference between formal convergence and > effective convergence, between theoretical existence and computational > feasibility. Techniques that are elegant on paper often fail > catastrophically in practice, while successful methods must balance > asymptotics, numerical stability, precision control, and computational > cost. > > Moreover, the computation of the MRB constant forces the > reconciliation of disparate mathematical ideas. Alternating series, > logarithmic asymptotics, convergence acceleration, special functions, > and analytic continuation must all agree numerically. Any hidden > inconsistency—whether conceptual or computational—reveals itself > immediately in the failure of the digits to stabilize. > > Thus, computing digits of the MRB constant transforms mathematics from > a static collection of statements into a living experiment. The > resulting digits are not trophies; they are evidence. They measure the > effectiveness of our methods, the soundness of our assumptions, and > the practical reach of our theory. > > In short, the digits themselves do not matter. What matters is that > they *can* be computed at all—and how difficult it is to do so. > That difficulty is precisely what makes the MRB constant > mathematically interesting. **In general, we will see:** ![enter image description here][7] ---------- ---------- ---------- [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2024-11-25023042.png&userId=366611 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2026-01-01235656.png&userId=366611 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2026-01-01235710.png&userId=366611 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2026-02-18190718.png&userId=366611 Marvin Ray Burns A.G.S. (cum laude) 2014-10-09T18:08:49Z https://community.wolfram.com/groups/-/m/t/1323951 This has been one of my favorite Mathematica projects! Here are a couple of Ai generated outlines of my progress of computing the MKB constant digits: ![enter image description here][1] ![enter image description here][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4506unnamed.png&userId=366611 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=unnamed%281%29.png&userId=366611 Marvin Ray Burns A.G.S. (cum laude) 2018-04-20T12:06:18Z https://community.wolfram.com/groups/-/m/t/2286246 $\int_0^\infty e^{i \pi x} \left(1-(x+1)^{\frac{1}{x+1}}\right) dx$ ![enter image description here][1] ![enter image description here][2] ![enter image description here][3] f[x_] = E^(I*Pi*x)*(1 - (x + 1)^(1/(x + 1))); g[x_] = x^(1/x); u := t/(1 - t); sub = Im[NIntegrate[(f[(-I t)] - f[( I t)])/(Exp[2 Pi t] - 1), {t, 0, Infinity}, WorkingPrecision -> 100]] 0.1170836031505383167089899122239912286901483986967757585888318959258587743002\ 7817712246477316693025869 m = NSum[f[( t)] , {t, 0, Infinity}, WorkingPrecision -> 100, Method -> "AlternatingSigns"] 0.1878596424620671202485179340542732300559030949001387861720046840894772315646\ 6021370329665443217278 m - sub 0.0707760393115288035395280218302820013657546962033630275831727881636184572643\ 8203658083188126524252 Is the same as {Re[NIntegrate[f[t], {t, 0, Infinity}]], and, Re[NIntegrate[f[t], {t, 0, Infinity I}, WorkingPrecision -> 100]]} NIntegrate::deodiv: DoubleExponentialOscillatory returns a finite integral estimate, but the integral might be divergent. NIntegrate::deodiv: DoubleExponentialOscillatory returns a finite integral estimate, but the integral might be divergent. {0.070776, and, \ 0.0707760393115288035395280218302820013657546962033630275831727881636184572643\ 8203658083188126617723821} To be continued. ---------------- [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=01.jpg&userId=366611 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=02.jpg&userId=366611 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=03.jpg&userId=366611 Marvin Ray Burns A.G.S. (cum laude) 2021-06-09T05:56:08Z https://community.wolfram.com/groups/-/m/t/403693 Hey there, community! I have recently been working with the new FEM-package included in Mathematica 10. I have a 2D mesh and two interpolating functions (call them uif and vif) obtained by solving a differential equation in the mesh using NDSolve. The mesh is similar to the one shown below, only denser. My problem now is that, given values u0 and v0, I need to find the point where uif[x,y] = u0 and vif[x,y] = v0. ![Example of the mesh][1] Now, since uif and vif are defined on the mesh, I would naturally want to do something like this: NMinimize[{Norm[{u0 - uif[x, y], v0 - vif[x, y]}], {x, y} \[Element] mesh}, {x, y}]]; Here "{x,y} \[Element] mesh" indicates that the point (x,y) lies inside the mesh. Unfortunately, the above code results in the following error: NMinimize::elemc: "Unable to resolve the domain or region membership condition {x,y} \[Element] <<1>>. **So, is there a way to convert the mesh into a region that I can pass on to NMinimize?** Previously I tried defining the region explicitly using unions and differences of disks and rectangles, or implicitly using equations for $x$ and $y$, but due to a number of bugs (or restrictions) with the regions and with the FEM package, this is unfortunately not an option. The mesh is simply-connected and I do have direct access to the boundary mesh if necessary. -Jonatan [1]: /c/portal/getImageAttachment?filename=Samplemesh.jpeg&userId=338953 Jonatan Lehtonen 2014-12-08T16:43:02Z https://community.wolfram.com/groups/-/m/t/122095 The latest way I have found to use my expensive math software for frivolous entertainment is this. Here's is a way to describe it. [list] [*]1000 dancers assume random positions on the dance-floor. [*]Each randomly chooses one "friend" and one "enemy". [*]At each step every dancer [list] [*]moves 0.5% closer to the centre of the floor [*]then takes a large step towards their friend [*]and a small step away from their enemy. [/list] [*]At random intervals one dancer re-chooses their friend and enemy [/list] Randomness is deliberately injected. Here is the dance... [mcode]n = 1000; r := RandomInteger[{1, n}]; f := (#/(.01 + Sqrt[#.#])) & /@ (x[[#]] - x) &; s := With[{r1 = r}, p[[r1]] = r; q[[r1]] = r]; x = RandomReal[{-1, 1}, {n, 2}]; {p, q} = RandomInteger[{1, n}, {2, n}]; Graphics[{PointSize[0.007], Dynamic[If[r < 100, s]; Point[x = 0.995 x + 0.02 f[p] - 0.01 f[q]]]}, PlotRange -> 2][/mcode] [img]/c/portal/getImageAttachment?filename=OPTfnlfrnds.gif&userId=11733[/img] Thanks to Vitaliy for posting this on my behalf, complete with animations :-) Background: I had read somewhere that macro-scale behaviour of animal swarms (think of flocks of starlings or shoals of herring) is explained by each individual following very simple rules local to their vicinity, essentially 1) try to keep up and 2) try not to collide. I started trying to play with this idea in Mathematica, but it was rather slow to identify the nearest neighbours of each particle. So I wondered what would happen if each particle acted according to the locations of two other particles, regardless of their proximity. The rule was simply to move away from one and towards the other. The contraction (x = 0.995 x) was added to prevent the particle cloud from dispersing towards infinity or drifting away from the origin. I tweaked the "towards" and "away" step sizes to strike a balance between the tendency to clump together and to spread apart (if you make the step sizes equal you get something more like a swarm of flies). With each particle's attractor and repeller fixed, the system finds a sort of dynamic equilibrium, so to keep things changing I added a rule to periodically change the attractor and repeller for one of the particles. The final adjustment was to make the "force" drop towards zero for particles at very close range. This helps to stop the formation of very tight clumps, and also prevents a division-by-zero error when a particle chooses itself as its attractor or repeller. The description of the system as a dance was an attempt to explain the swirling pattern on the screen without using mathematical language. I'd love to see what other "dances" can be created with other simple rules. Simon Woods 2013-09-11T18:31:12Z https://community.wolfram.com/groups/-/m/t/290059 Hi everyone, the Wolfram Language both in the cloud and in Mathematica 10 offers the possibility to solve PDEs on quite general surfaces. In the documentation it is shown that the Laplace equation can be solved on a 3D model of the space shuttle like this: mr = DiscretizeGraphics[ExampleData[{"Geometry3D", "SpaceShuttle"}]]; uif = NDSolveValue[{Inactive[Laplacian][u[x, y, z], {x, y, z}] == 0, DirichletCondition[u[x, y, z] == 1, z <= -1.3]}, u, {x, y, z} \[Element] mr]; Needs["NDSolve`FEM`"] ElementMeshSurfacePlot3D[uif, Boxed -> False, ViewPoint -> {0, -4, 2}] This is really nice and gives ![enter image description here][1] The problem shows up when we take more irregular objects like mr = DiscretizeGraphics[ExampleData[{"Geometry3D", "Cow"}]] ![enter image description here][2] or mr = DiscretizeGraphics[ExampleData[{"Geometry3D", "Horse"}]] When you execute the integration you get: NDSolveValue::fememib: The input has or generated an intersecting boundary and cannot be processed. >> Similarly, BoundaryDiscretizeGraphics[ExampleData[{"Geometry3D", "Cow"}]] gives BoundaryMeshRegion::binsect: "The boundary curves self-intersect or cross each other in BoundaryMeshRegion[{{0.10799399763345718`,0.08466669917106628`,-0.21893799304962158`},{0.1157900020480156`,0.08869930356740952`,-0.22847199440002441`},{0.10719799995422363`,0.09556479752063751`,-0.23278899490833282`},<<46>>,{-0.30769699811935425`,0.093573197722435`,-0.22068199515342712`},<<2853>>},{{},{},{Polygon[{<<1>>}]}}]. \!\(\*ButtonBox[\">>\", Appearance->{Automatic, None}, BaseStyle->\"Link\", ButtonData:>\"paclet:ref/BoundaryMeshRegion\", ButtonNote->\"BoundaryMeshRegion::binsect\"]\)" So the problem is that there are self-intersections of the surface. Is there any elegant approach to fixing that? Cheers, Marco [1]: /c/portal/getImageAttachment?filename=Shuttle.jpg&userId=48754 [2]: /c/portal/getImageAttachment?filename=cow.jpg&userId=48754 Marco Thiel 2014-07-09T23:02:47Z https://community.wolfram.com/groups/-/m/t/745870 While going through the Wolfram Demonstration Project site, I came across an simulation of a Trebuchet: [Optimizing the Counterweight Trebuchet][1] I was wondering if it is possible to animate the Trebuchet in such a way that the projectile of the trebuchet actually leaves the sling and makes impact against a wall at a certain distance say x='some constant'. [![enter image description here][2]][1] [1]: http://demonstrations.wolfram.com/OptimizingTheCounterweightTrebuchet [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6648popup_3.jpg&userId=11733 Varun Kulkarni 2015-11-26T22:26:41Z https://community.wolfram.com/groups/-/m/t/515162 **See attached notebook for details**. A [shuttlecock][1] (previously called Shuttlecork) (also called a bird or birdie) is a high-drag projectile used in the sport of badminton. It has an open conical shape: the cone is formed from 16 or so overlapping feathers, usually goose or duck, embedded into a rounded cork base. The cork is covered with thin leather. The shuttlecock's shape makes it extremely aerodynamically stable. Regardless of initial orientation, it will turn to fly cork first, and remain in the cork-first orientation. ![enter image description here][2] *Image courtesy of IOP Science* The name shuttlecock is frequently shortened to shuttle. The "shuttle" part of the name was probably derived from its back-and-forth motion during the game, resembling the shuttle of a loom; the "cock" part of the name was probably derived from the resemblance of the feathers to those on a cockerel. ![enter image description here][3] **The code with NDSolveValue is attached**. Here is the resulting simulation of the flight of badminton shuttlecocks: ![enter image description here][4] ![enter image description here][5] &[Wolfram Notebook][6] > [References][7] [1]: https://en.wikipedia.org/?title=Shuttlecock [2]: /c/portal/getImageAttachment?filename=sdf54wyehfgsd54qt.png&userId=11733 [3]: /c/portal/getImageAttachment?filename=sz.png&userId=476423 [4]: /c/portal/getImageAttachment?filename=ssdf3544ytjkjghd.gif&userId=11733 [5]: /c/portal/getImageAttachment?filename=1523Anim.gif&userId=476423 [6]: https://www.wolframcloud.com/obj/ff04670b-b2e3-4281-86a5-0cbb60e61592 [7]: http://iopscience.iop.org/1367-2630/17/6/063001/article Mariusz Iwaniuk 2015-06-18T14:56:37Z https://community.wolfram.com/groups/-/m/t/1569707 ![a very prime pencil][1] I just got a set of these pencils, from [Mathsgear][2]. The number printed on it is prime, and will remain so as you sharpen the pencil from the left, all the way down to the last digit, 7. Here is a recursive construction of all such *truncatable primes*. TruncatablePrimes[p_Integer?PrimeQ] := With[{digits = IntegerDigits[p]}, {p, TruncatablePrimes /@ (FromDigits /@ (Prepend[digits, #] & /@ Range[9]))} ]; TruncatablePrimes[p_Integer] := {} The one on the pencil is the largest one, In[7]:= Take[Sort[Flatten[TruncatablePrimes /@ Range[9]]], -5] Out[7]= { 9918918997653319693967, 57686312646216567629137, 95918918997653319693967, 96686312646216567629137, 357686312646216567629137} [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_20181212_120939.jpg&userId=143131 [2]: https://mathsgear.co.uk/products/truncatable-prime-pencil Roman Maeder 2018-12-12T12:01:36Z https://community.wolfram.com/groups/-/m/t/1286708 In 1356, Narayana posed a question in his book *Ga?ita Kaumudi*: "A cow gives birth to a calf every year. In turn, the calf gives birth to another calf when it is three years old. What is the number of progeny produced during twenty years by one cow?" This is now known as Narayana's cows sequence. The Narayana's cows sequence constant, **cow**=1.4655712318767680266567312252199391080255775684723, is the limit ratio between neighboring terms. LinearRecurrence[{1, 0, 1}, {2, 3, 4}, 21] NestList[Round[# Root[-1 - #1^2 + #1^3 &, 1]] &, 2, 20] Either gives {2, 3, 4, 6, 9, 13, 19, 28, 41, 60, 88, 129, 189, 277, 406, 595, 872, 1278, 1873, 2745, 4023}. This turns out to be a good constant to use for a Rauzy fractal. The outer fractal triangle can be divided into copies of itself r = Root[-1 - #1^2 + #1^3 &, 3]; iterations = 6; cowed[comp_] := First /@ Split[Flatten[RootReduce[#[[1]] + (#[[2]] - #[[1]]) {0, -r^5, r^5 + 1, 1}] & /@ Partition[comp, 2, 1, 1], 1]]; poly = ReIm[Nest[cowed[#] &, #, iterations]] & /@ Table[N[RootReduce[r^({4, 1, 3, 5} + n) {1, 1, -1, 1}], 50], {n, 1,14}]; Graphics[{EdgeForm[{Black}], Gray, Disk[{0, 0}, .1], MapIndexed[{Hue[#2[[1]]/12], Polygon[#1]} &, poly]}] ![fractal Narayana Cow spiral ][1] The ratio of areas for the triangles turns out to be **cow**. Try Area[Polygon[poly[[1]]]]/Area[Polygon[poly[[2]]]] and you'll see. If you want to laser cut that, it's handy to get a single path. cowpath[comp_] := First /@ Split[Flatten[RootReduce[#[[1]] + (#[[2]] - #[[1]]) {0, -r^5, r^5 + 1, 1}] & /@ Partition[comp, 2, 1], 1]]; path = ReIm[Nest[cowpath[#] &, N[Drop[Flatten[Table[r^({4, 1, 3} + n) {1, 1, -1}, {n, 1, 16}]], -1], 50], iterations]]; Graphics[{Line[path]}] What else can be done with **cow**? With some trickier code I put together the pieces this way. Notice how order 5 spokes appear. ![Narayana cow fractal egg][2] The opening gave an order 3 infinite spiral. Is there an order 5 infinite spiral? It turns out there is. Behold the **cow-nautilus**! ![cow-nautilus][3] It can be made with the following code: r=Root[-1-#1^2+#1^3&,3]; iterate=3; cowed[comp_]:= First/@Split[Flatten[RootReduce[#[[1]]+(#[[2]]-#[[1]]){0,-r^5,r^5+1,1}]&/@Partition[comp,2,1,1],1]]; base={{r^10,r^7,-r^9,r^11},{-r^12,-r^9,r^11,-r^13},{r^8,r^5,-r^7,r^9},{-r^7,-r^4,r^6,-r^8}}+{-r^10,r^11,-r^6,r^4+r^8}; naut=RootReduce[Join[Table[base[[1]] (-r)^n,{n,0,-4,-1}],Flatten[Table[Drop[base,1](-r)^n,{n,-8,0}],1]]]; poly=ReIm[Nest[cowed[#]&,#,iterate]]&/@N[naut,50]; Graphics[{EdgeForm[{Black}],MapIndexed[{ColorData["BrightBands"][N[Norm[Mean[#1]]/2]],Polygon[#1]}&,poly]},ImageSize-> 800] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=fractalcowspiral.jpg&userId=21530 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=cowegg.jpg&userId=21530 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=cownautilus.jpg&userId=21530 Ed Pegg 2018-02-16T22:52:01Z https://community.wolfram.com/groups/-/m/t/2017849 #Introduction One of the most thrilling parts in Nolan's movie "Interstellar" is the black hole Gargantua and its accretion disk. Its weird shape has surely attracted lots of attention. But do black holes and their accretion disks actually look like that? Not exactly. ![BH and accretion disk in Interstellar][1] In the paper "Gravitational lensing by spinning black holes in astrophysics, and in the movie Interstellar", the authors say that in the movie, redshift and blueshift, as well as the intensity difference is ignored to prevent confusion to the audience. So, although the outline of the accretion disk in "Interstellar" is accurate, the color and the intensity are not. Furthermore, even in the paper, effects brought by the time delay in the propagation of light are ignored, and the influence of gravity lensing on light intensity is simplified. Though I cannot easily render a spinning black hole (Kerr black hole), what I can do is try to render an accretion disk around a Schwarzschild black hole, and as physically correct as possible. The result would be something like this (observer static at 6 times the Schwarzschild radius): ![my rendering result, static observer][2] I strongly recommend you to see the videos at [Bilibili](https://www.bilibili.com/video/BV1Fp4y1S7EF) or [Youtube](https://www.youtube.com/watch?v=Dux1NkTaqwo) (Both have English subtitles) first to have a first impression, and it would be the best if you can click the vote up button XD. After that, If you would like to know more about the Mathematica realization and physical principles behind the scene, please continue. **A disclaimer first:** I know nothing about accretion disk physics, so the property of accretion disks are set arbitrarily. Furthermore, actual accretion disks are actually blazingly bright, and you would be blind instantly if you are looking at it from a short distance, so I have to make some modifications. #Analytics ###Physics Perspective First, we need to analyze this problem from the physics perspective, get to know about the problems we should consider. **For observers**, the intensity of light is determined by how much photons reached their eye in a certain angle range, and the color is determined by the spectrum of the light. However, the orientation, spectrum, and intensity of light beams can be influenced by the observer's movement, so we have to consider that. Naturally, the next question should be, where the light comes? Well, all the light must have come from some **light-emitting materials**, so we have to consider the light-emitting materials' property and movement. But the **light should travel** for some time and distance before reaching the observer's eye. This process involves tracing the light from the emitter to the observer to determine the direction of light the observer perceived, as well as how much portion of light can reach the observer's eyes. Till now, we have already listed out all effects, from the emission to the perception, which could influence our view, so I believe this rendering is "physically accurate". ### Programming Perspective But view from the programming perspective, the zeroth problem should be how lights travel around a black hole: we need the light path to calculate all other effects. Then, based on the light path, we can directly compute the equivalent of "brighter when closer" rule, as well as the time delay between light emission and observation. If combined with the movement of the light-emitting materials and the observer, we can compute the redshift and the blueshift. #Details, Theory, Coding and Results Now let's assume that we are stationary observers viewing from 6 times the Schwarzchild radius. ##Ray Tracing The first problem to solve is tracing the light beam. Light bends around black holes following the geodesics, and the most apparent consequence of this would be that the accretion disk we see would not be on a plane, but rather curved and bent. Fortunately for us, because Schwartzchild black holes are spherically symmetric, we can reduce the problem to 2D. The parametric equation of geodesics around a Schwarzschild black hole can be derived as follows: $$ \left\{ \begin{aligned} t''(\lambda)&=\frac{R_s r' t'}{R_s r-r^2}\\ r''(\lambda)&=\frac{-R_s r^2 r'^2-2r^3\theta'^2(R_s-r)^2+R_s(R_s-r)^2t'^2}{2r^3(R_s-r)}\\ \theta''(\lambda)&=-\frac{2r'\theta'}{r} \end{aligned} \right. $$ Where $\lambda$ is the ray parameter. Now we construct a set of light which originates from the observer, and trace them backward: ![Possible light paths][3] ![Definition of variables][4] ![How interpolation works][5] On each ray, we take some sample points and record the corresponding angle $\theta_0$, $\theta_1$, and time $\Delta T$. By interpolating them, we know about how a random object will look like in our eyes. (*Initial definitions*) Rs = 1; R0 = 6 Rs; Rmax = 6 Rs + 1.*^-6; (*Tracking the light*) parfunc = ParametricNDSolveValue[{{tt''[\[Tau]], rr''[\[Tau]], \[Theta]\[Theta]''[\[Tau]]} == {( Derivative[1][rr][\[Tau]] Derivative[1][tt][\[Tau]])/( rr[\[Tau]] - rr[\[Tau]]^2), ( rr[\[Tau]]^2 Derivative[1][ rr][\[Tau]]^2 - (-1 + rr[\[Tau]])^2 Derivative[1][ tt][\[Tau]]^2)/( 2 (-1 + rr[\[Tau]]) rr[\[Tau]]^3) + (-1 + rr[\[Tau]]) Derivative[1][\[Theta]\[Theta]][\[Tau]]^2, -(( 2 Derivative[1][rr][\[Tau]] Derivative[ 1][\[Theta]\[Theta]][\[Tau]])/rr[\[Tau]])}, {tt'[0], rr'[0], \[Theta]\[Theta]'[ 0]} == {1/(1 - Rs/R0), -Cos[\[Theta]0], Sqrt[1/(1 - Rs/R0)]/R0 Sin[\[Theta]0]}, {tt[0], rr[0], \[Theta]\[Theta][0]} == {0, R0, 0}, WhenEvent[ 1.01 Rs >= rr[\[Tau]] || rr[\[Tau]] >= Rmax || \[Theta]\[Theta][\[Tau]] >= 3.1 Pi, "StopIntegration"]}, {tt[\[Tau]], rr[\[Tau]], \[Theta]\[Theta][\[Tau]]}, {\[Tau], 0, 1000}, {\[Theta]0}]; (*data used in interpolation*) datp = Catenate@ Table[With[{pf = parfunc[\[Theta]]}, With[{\[Tau]max = pf[[1, 0, 1, 1, 2]], df = D[Rest@pf, \[Tau]], f = Rest@pf}, Block[{\[Tau] = Range[RandomReal[{0, \[Tau]max/500}], \[Tau]max, \[Tau]max/ 500]}, Select[ Thread[(Thread@f -> Thread@{\[Theta], ArcTan[-df[[1]], df[[2]] f[[1]] Sqrt[1 - Rs/f[[1]]]], pf[[1]]})], 2.4 Rs < #[[1, 1]] < 5.6 Rs && -0.05 Pi < #[[1, 1]] < 3.08 Pi &]]]], {\[Theta], Range[-2.5 Degree, 80 Degree, 1 Degree]~Join~ Range[20.2 Degree, 28.2 Degree, 0.5 Degree]~Join~ Range[23.025 Degree, 24.05 Degree, 0.05 Degree]~Join~ Range[23.2825 Degree, 23.4 Degree, 0.005 Degree]~Join~ Range[23.28525 Degree, 23.30025 Degree, 0.001 Degree]}]; datp = First /@ GatherBy[datp, Floor[#[[1]]/{0.01 Rs, 1 Degree}] &]; (*Construct InterpolatingFunctions*) ReceiveAngleFunction = Interpolation[Thread[{datp[[;; , 1]], datp[[;; , 2, 1]]}], InterpolationOrder -> 1]; EmitAngleFunction = Interpolation[Thread[{datp[[;; , 1]], datp[[;; , 2, 2]]}], InterpolationOrder -> 1]; DelayFunction = Interpolation[Thread[{datp[[;; , 1]], datp[[;; , 2, 3]]}], InterpolationOrder -> 1]; (*Angle vs time of observation*) GenerateAngleFunctions[R1_, \[Theta]1_] := Block[{\[Phi]1}, With[{interpol = Interpolation@ Table[{DelayFunction[R1, #] + Sqrt[2 R1^3] \[Phi]1, \[Phi]1}, {\[Phi]1, 0., 2 Pi, 10. Degree}]}, With[{ts = interpol[[1, 1, 1]], tperiod = 2. Pi Sqrt[2 R1^3]}, Function[t, interpol[t - Floor[t - ts, tperiod]]]]] & /@ ({#, 2 Pi - #, 2 Pi + #} &@ArcCos[Sin[\[Phi]1] Sin[\[Theta]1]])] If we only consider this effect, then we will have something like this: ![Light bending included][6] The inner two rings correspond to the light that rotates around the black hole for more than half a round. And if we consider the propagation time of light, the right side will be a bit brighter. ![Time correction included][7] This is because on the right, objects are moving away from you. So from your point of view, these particles will stay for a longer time on the right. (The reason is explained in the figure) ![Illustration of how velocity influence timing][8] ##"Brighter when Closer" The next question is about the "brighter when closer" rule. We all know that the further a bulb is, the dimmer it would appear to be. This is because the light from the bulb is approximately evenly distributed across solid angles, but as we move further, the solid angle corresponding to our eyes will be smaller. Mathematically, this is saying $I\propto S_0 \frac{d\Omega}{dS}$ where $S_0$ is the surface area of our eyes, $S$ is area, and $\Omega$ is the solid angle. !["Brighter when closer" rule in flat space][9] The same rules apply here in curved spacetime, except the light beams are weirder. !["Brighter when closer" rule in curved space][10] We know that $\frac{d\Omega}{dS}=(\frac{dx}{d\theta_x}\frac{dy}{d\theta_y})^{-1}$. While $\frac{dy}{d\theta_y}=\frac{R_0 \sin \alpha}{\sin \theta_1}$ can be derived using basic solid geometry, $\frac{dx}{d\theta_x}$ must be calculated numerically by tracing the light from the object to the observer. Similarly, we use interpolating function to generalize the result from a set of sample points to the whole space. (*Reverse ray tracing*) parfuncrev = ParametricNDSolveValue[{{tt''[\[Tau]], rr''[\[Tau]], \[Theta]\[Theta]''[\[Tau]]} == {( Derivative[1][rr][\[Tau]] Derivative[1][tt][\[Tau]])/( rr[\[Tau]] - rr[\[Tau]]^2), ( rr[\[Tau]]^2 Derivative[1][ rr][\[Tau]]^2 - (-1 + rr[\[Tau]])^2 Derivative[1][ tt][\[Tau]]^2)/( 2 (-1 + rr[\[Tau]]) rr[\[Tau]]^3) + (-1 + rr[\[Tau]]) Derivative[1][\[Theta]\[Theta]][\[Tau]]^2, -(( 2 Derivative[1][rr][\[Tau]] Derivative[ 1][\[Theta]\[Theta]][\[Tau]])/rr[\[Tau]])}, {tt'[0], rr'[0], \[Theta]\[Theta]'[0]} == {1/(1 - Rs/R1), Cos[\[Theta]0], -Sqrt[1/(1 - Rs/R1)]/R1 Sin[\[Theta]0]}, {tt[0], rr[0], \[Theta]\[Theta][0]} == {0, R1, \[Theta]1}, WhenEvent[\[Theta]\[Theta][\[Tau]] == 0, "StopIntegration"]}, {tt[\[Tau]], rr[\[Tau]], \[Theta]\[Theta][\[Tau]]}, {\[Tau], 0, 100}, {\[Theta]0, R1, \[Theta]1}]; (*data used in interpolation*) \[CapitalDelta]\[Phi] = 1.*^-5; intensity = Catenate@Table[{{R, \[Theta]}, R0^2 With[{\[Theta] = Abs[\[Theta]]}, Abs[Sin[EmitAngleFunction[ R, \[Theta]]]/(R0 \ Sin[\[Theta]])]*(\[CapitalDelta]\[Phi]/(Sin[ ReceiveAngleFunction[R, \[Theta]]]* Subtract @@ (With[{f = parfuncrev[ EmitAngleFunction[ R, \[Theta]] + # \[CapitalDelta]\[Phi], R, \[Theta]][[2, 0]]}, f@f[[1, 1, -1]]] & /@ {-1, 1})))]}, {R, 2.45 Rs, 5.55 Rs, 0.02 Rs}, {\[Theta], -3 Degree, 543 Degree, 2 Degree}]; (*Construct InterpolatingFunction*) IntensityFunction1 = Interpolation[intensity]; ![With intensity correction 1][11] The figure will be much more realistic in the aspect of intensity after we added this effect. The inner two rings are much dimmer because light bent dramatically is rare after all. ##Doppler Effect and Headlight Effect Now its time for Doppler effect and headlight effect. These two effects are related to the movement of light-emitting objects and observers. Though the names of these effects can be forbidding, these effects are quite common in everyday life. Blueshift refers to the phenomenon that when a car is approaching you, the noise made by the car would be more acute and loud, and redshift means when the car is leaving you, the noise would quieter and be of lower frequency. ![Doppler effect][12] The equation for the relativistic Doppler effect is: $$ f'=f\frac{\sqrt{1-\beta^2}}{1-\beta \cos \theta} $$ where $\beta=\frac{v}{c}$ and $\theta$ is the angle between the velocity direction of the light-emitting object and the light emitted, as observed by an external observer. In this case, we should further add a coefficient of $$ f''=f'\sqrt{\frac{1 - R_s/R_1}{1 - R_s/R_0}} $$ due to general relativistic effects. Headlight effect means when you are driving a car on rainy days, no matter how the wind blows, the raindrops will always run towards the windshield. But if you stop your vehicle, you can see how the wind influences the dropping direction of rain. ![Headlight effect][13] The equation for angle transformation is: $$ \cos \theta'= \frac{\cos \theta +\beta}{1+\beta \cos \theta} $$ and such, the intensity difference introduced by this can be written as: $$ \frac{dP'}{d\Omega}= \frac{dP}{d\Omega}\frac{\sin \theta}{\sin \theta'}\frac{d \theta}{d \theta'}=\frac{dP}{d\Omega}\frac{1 - \beta^2}{(1 -\beta \cos \theta)^2} $$ Except for the difference in timing brought by the curved spacetime, these two effects are purely in the special relativity regime. The only thing involved in coding is tedious coordinate transformation. (*Calculate moving speed*) Calc\[Beta][{R1_, \[Theta]_, \[Phi]_}, {vr_, v\[Theta]_, v\[Phi]_}] := Sqrt[vr^2/(1 - Rs/R1) + (R1 v\[Theta])^2 + (R1 Sin[\[Theta]] v\[Phi])^2]/ Sqrt[1 - Rs/R1] (*Calculate inner product between moving direction and light direction*) CalcCosAngle[{R1_, \[Theta]_, \[Phi]_}, {vr_, v\[Theta]_, v\[Phi]_}] := With[{v = {vr/Sqrt[1 - Rs/R1], R1 v\[Theta], R1 Sin[\[Theta]] v\[Phi]}}, MapThread[With[{\[Theta]0 = EmitAngleFunction[R1, #1]}, With[{vnormed = MapThread[Normalize@*List, v]}, MapThread[ Dot, {vnormed, Thread@{Cos[\[Theta]0], #2 Sin[\[Theta]0], 0}}, 1]]] &, {{\[Theta], 2 Pi - \[Theta], 2 Pi + \[Theta]}, {-1, 1, -1}}]] (*Frequency shift, Doppler effect + GR timing effects*) FrequencyMult[R1_, \[Beta]_, cos_] := Sqrt[(1 - Rs/R1)/(1 - Rs/R0)]*Sqrt[1 - \[Beta]^2]/(1 - \[Beta] cos) (*Intensity shift due to headlight effect only*) IntensityMult2[\[Beta]_, cos_] := (Sqrt[1 - \[Beta]^2]/(1 - \[Beta] cos))^2 Then we can put all these effects together and see how things works out! << PhysicalColor` IntensityFunctionScaling::usage = "Scale Intensity."; Protect@IntensityFunctionScaling; Options[RenderFunc] = {ColorFunction -> TemperatureColor, ColorFunctionScaling -> (# &), IntensityFunctionScaling -> (# &), "StaticObserver" -> True}; RenderFunc[R1_, {\[Theta]1_, t1_, \[Gamma]1_}, {T0_, I0_}, OptionsPattern[]] := Function[t, Through[#[t]]] &@Module[{ (*Velocity of observer*) vobs = N@Sqrt[(1 - Rs/R0) Rs/(2 R0)], (*list of \[Phi]1 parameters*) \[Phi]1l = Range[0., 2 Pi, 1 Degree], (*Polar coordinates \[Theta] and \[Phi]*) \[Theta]l0, \[Phi]l0, (*velocity of object and its norm*) vrl, v\[Theta]l, v\[Phi]l, vnorml }, (*Polar coordinate \[Theta]*) \[Theta]l0 = ArcCos[Sin[\[Phi]1l] Sin[\[Theta]1]]; (*Original \[Phi]*) \[Phi]l0 = ArcTan[Cos[\[Phi]1l], Sin[\[Phi]1l] Cos[\[Theta]1]] + \[Gamma]1; (*velocity of object*) vrl = ConstantArray[0, Length@\[Phi]1l]; v\[Theta]l = -(Cos[\[Phi]1l] Sin[\[Theta]1])/ Sqrt[1 - Sin[\[Theta]1]^2 Sin[\[Phi]1l]^2]*Sqrt[Rs/(2 R1^3)]; v\[Phi]l = 1/(Cos[\[Phi]1l]^2/Cos[\[Theta]1] + Cos[\[Theta]1] Sin[\[Phi]1l]^2)*Sqrt[Rs/(2 R1^3)]; (*velocity norm*) vnorml = Calc\[Beta][{R1, \[Theta]l0, 0}, {vrl, v\[Theta]l, v\[Phi]l}]; MapThread[Module[{ (*Observed \[Phi]1 parameter - t*) \[Phi]1t = #3, (*actual \[Theta] of object*) \[Theta]l = #1, (*angle between velocy and ray*) cosl = #4, (*Observed values - \[Phi]1*) (*Geometry*) \[Theta]obsl, \[Phi]obsl = \[Phi]l0 + #2, (*Frequency and intensity shift*) freqobsl, intobsl, (*helper function*) helpf }, \[Theta]obsl = ReceiveAngleFunction[R1, \[Theta]l]; (*Frequency*) freqobsl = FrequencyMult[R1, vnorml, cosl]; (*Process with the non-static observer*) If[OptionValue["StaticObserver"] =!= True, Module[{\[Theta]transl, \[Phi]transl, \[Delta] = ArcSin[vobs]}, (*Geometrics, static frame*) \[Theta]transl = ArcCos[Sin[\[Theta]obsl] Cos[\[Phi]obsl]]; \[Phi]transl = ArcTan[Sin[\[Theta]obsl] Sin[\[Phi]obsl], Cos[\[Theta]obsl]]; (*Frequency shift due to movement of observer, intensity shift is calculated together later*) freqobsl *= (1 + vobs Cos[\[Theta]transl])/Sqrt[1 - vobs^2]; (*Angle shift due to movement of observer*) \[Theta]transl = ArcCos[(vobs + Cos[\[Theta]transl])/(1 + vobs Cos[\[Theta]transl])]; (*Transform back*) (*Here we change the center of viewing angle so that the \ black hole's center is at {0,0}*) \[Theta]obsl = ArcCos[Sin[\[Delta]] Cos[\[Theta]transl] + Cos[\[Delta]] Sin[\[Theta]transl] Sin[\[Phi]transl]]; \[Phi]obsl = ArcTan[Cos[\[Delta]] Cos[\[Theta]transl] - Sin[\[Delta]] Sin[\[Theta]transl] Sin[\[Phi]transl], Sin[\[Theta]transl] Cos[\[Phi]transl]] ] ]; \[Phi]obsl = Catenate[ MapIndexed[#1 + 2 Pi #2[[1]] &, Split[\[Phi]obsl, Less]]]; (*Intensity*) intobsl = freqobsl^2*IntensityFunction1[R1, \[Theta]l]* IntensityMult2[vnorml, cosl]* TemperatureIntensity[freqobsl T0]/TemperatureIntensity[T0]/ freqobsl^4; (*Helper function to construct interpolating functions*) helpf[l_] := Interpolation[Thread[{\[Phi]1l, l}]]; With[{ cf = OptionValue[ColorFunction], (*Interpolating functions*) t11 = t1, \[Phi]1f = #3, \[Theta]func = helpf[\[Theta]obsl], \[Phi]func = helpf[\[Phi]obsl], freqfunc = helpf[OptionValue[ColorFunctionScaling][T0 freqobsl]], intfunc = helpf[OptionValue[IntensityFunctionScaling][I0 intobsl]] }, (*Final function*) Function[t, With[{\[Phi]11 = \[Phi]1f[t + t11]}, {Append[cf[freqfunc[\[Phi]11]], intfunc[\[Phi]11]], With[{\[Theta] = \[Theta]func[\[Phi]11], \[Phi] = \ \[Phi]func[\[Phi]11]}, (*Point[{Sin[\[Theta]]Cos[\[Phi]],Sin[\[Theta]]Sin[\[Phi]], Cos[\[Theta]]}]*) Point[Tan[\[Theta]] {Cos[\[Phi]], Sin[\[Phi]]}]]} ]] ] ] &, {{\[Theta]l0, 2 Pi - \[Theta]l0, 2 Pi + \[Theta]l0}, {0, Pi, 0}, GenerateAngleFunctions[R1, \[Theta]1], CalcCosAngle[{R1, \[Theta]l0, 0}, {vrl, v\[Theta]l, v\[Phi]l}]}]] (*My version of rasterize, which increase color precision in dimmer areas*) HDRRasterize[gr_Graphics, convertfunc_, opts : OptionsPattern[Rasterize]] := Module[{rasterl = Join[ColorSeparate[ColorConvert[Rasterize[gr, opts], "HSB"]], ColorSeparate[ ColorConvert[ Rasterize[ gr /. RGBColor[r_, g_, b_, op_] :> RGBColor[r, g, b, 16 op], opts], "HSB"]]], mask, invmask}, mask = Binarize[rasterl[[3]], 1/16]; invmask = 1 - mask; ColorCombine[{ mask*rasterl[[1]] + invmask*rasterl[[4]], mask*rasterl[[2]] + invmask*rasterl[[5]], mask*convertfunc[rasterl[[3]]] + invmask*convertfunc[rasterl[[6]]/16.]}, "HSB"] ] (*Preliminary computation*) npts = 5000; rflist = MapThread[ Function[{R1, \[Theta]1, t1, \[Gamma]1, T0, I0}, RenderFunc[R1, {\[Theta]1, t1, \[Gamma]1}, {T0, I0}, "StaticObserver" -> False(*, IntensityFunctionScaling\[Rule](.7(#/.5)^0.5&)*)]], {RandomReal[{3, 4.5}, npts], RandomReal[-{83, 86} Degree, npts], RandomReal[{0, 10000}, npts], RandomReal[15 Degree + {-2, 2} Degree, npts], RandomReal[{4000, 10000}, npts], RandomReal[{.03, .1}, npts] } ]; (*rendering!!!*) g = Graphics[{(*AbsolutePointSize@.1,White,Point[{Sin[20Degree]Cos[#], Sin[20Degree]Sin[#],Cos[20Degree]}&/@Range[0.,360.Degree, 60.Degree]],*)AbsoluteThickness@2, Map[Line[#[[;; , 2, 1]], VertexColors -> MapThread[ Function[{col, len, mult}, MapAt[mult^2*#*0.006/len &, col, 4]], {#[[;; , 1]], Prepend[#, #[[1]]] &@ BlockMap[Norm[#[[2]] - #[[1]]] &, #[[;; , 2, 1]], 2, 1], Subdivide[Length[#] - 1]}]] &, Reverse@Transpose[ Through[rflist[#]] & /@ (Range[0, 3, .1]), {3, 2, 1}], {2}]}, Background -> Black, ImageSize -> {500, Automatic}, PlotRange -> {{-1.28, 1.28}, {-0.72, 0.72}}]; HDRRasterize[g, #^(1/2.2) &, ImageSize -> {1920, 1080}] ![With all effects, static observer][14] Well, because objects at left are moving towards you, they will appear much brighter and blue-ish, while objects at right are much dimmer and red-ish. We can also consider the movement of the observer, which will make the image something like this: ![With all effects, observer moving][15] Hooray! The notebook can be found in the attachment or at [my github repo](https://github.com/wjxway/Realistic_Blackhole_Accretion_Disk). [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bh10.png&userId=1340903 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=T_001.png&userId=1340903 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Path_4.png&userId=1340903 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus2.png&userId=1340903 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus1.png&userId=1340903 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=LightBending.png&userId=1340903 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithTimeCorrection.png&userId=1340903 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus3.png&userId=1340903 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IntensityIllus.png&userId=1340903 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus4.png&userId=1340903 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithIntensity1.png&userId=1340903 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Doppler.jpg&userId=1340903 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=FrontLight.jpg&userId=1340903 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithAllEffects.png&userId=1340903 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithObserverMoving.png&userId=1340903 Jingxian Wang 2020-07-02T11:26:03Z https://community.wolfram.com/groups/-/m/t/441498 Hello guys, I'm stuck with this question for some time. For my equation, I need to use WolframAlpha for my data. Firstly, I fix my initial water temperature as 500 Kelvin. Eg: Twater = 300 Cwater = QuantityMagnitude[ ThermodynamicData["Water", "ThermalConductivity", {"Temperature" -> Quantity[Twater, "Kelvins"]}]] With Cwater determined, I can implement the next 2 functions Dwater = (5 Cwater)/\[Pi] Ewater = Dwater^3 + 2 Cwater Then by using ParametricNDSolveValue, I can determine the value of Z ClassicalRungeKuttaCoefficients[4, prec_] := With[{amat = {{1/2}, {0, 1/2}, {0, 0, 1}}, bvec = {1/6, 1/3, 1/3, 1/6}, cvec = {1/2, 1/2, 1}}, N[{amat, bvec, cvec}, prec]]; f = ParametricNDSolveValue[{Derivative[1][y][x] == Piecewise[{{(y[x] + x^3 + 3 z - 120*Ewater), 0 <= x <= 1}, {(y[x] + x^2 + 2 z), 1 <= x <= 2}, {(y[x] + x + z), 2 <= x <= 3}}], y[0] == 0}, y[3.], {x, 0., 3.}, z, Method -> {"ExplicitRungeKutta", "DifferenceOrder" -> 4, "Coefficients" -> ClassicalRungeKuttaCoefficients}, StartingStepSize -> 1/10]; point = {z /. FindRoot[f[z] == 100., {z, 1}, Evaluated -> False], 100.}; FindRoot[f[z] == 100., {z, 1}, Evaluated -> False] Lastly, to find the new temperature of water Tnew = 170 + 1.89*z /. FindRoot[f[z] == 100., {z, 1}, Evaluated -> False] I wanted to repeat Twater with Tnew until Twater=Tnew->True and the loop stop. I need to start Twater with a value, (only to replace Twater=Tnew after the first equation and keep press shift+enter repeatedly) I've tried some Do Loop or For Loop and even FixedPoint but still don't know how to combine multiple functions/equations into 1 loop.... I apologize because I've been asking this question a few times, or maybe some of you have answered me in some way, but I still did not understand how to do this. Thank you very much for your time. Thai Kee Gan 2015-02-13T05:57:04Z https://community.wolfram.com/groups/-/m/t/273260 Dear All, I want to ask your advise. I have a variable q as a function of time but I already have the values of q for each time step. So do you know any command in Mathematica for getting the derivative values of q? There are some commands such as: dq/dt = D[q[t],t] or dq/dt = q'[t] but I think I can use that command if I have q as an equation but I have q as values. So I used the below method to calculate the derivative: dqdt = Table[(q[t + 1] - q[t - 1])/2, {t, 1, 99}] Please refer to attach. titled "Derivative.nb" for the script. So may I know if the above method is correct? And may I know the alternative ways for calculating derivative like in this case? Thanks a lot for your kind attention. Best Regards, Intan INTAN SUPRABA 2014-06-10T01:43:43Z https://community.wolfram.com/groups/-/m/t/1132423 The function `FindRoot` can only find one root; there is no way of finding multiple roots. User J. M. extended the FindRoot by the function [FindAllCrossings][1] by changing Stan Wagon's book Mathematica in Action slightly. The implementation is pretty slick. You plot the function on a certain range and tell the `Plot` function to mesh the zeros, then you extract the zeros and use `FindRoot` with them as an initial condition. But this implementation has a major drawback; it fails in cases where the function doesn't cross zero, as `x^2` for example. To extend J. M. implementation I added some more lines of code, and I've made the code more verbose. The new lines of code calculate the zeros of the derivative of the function and then test it is close to zero and later refine it with `FindRoot`, this works even with functions as `Abs[x]`, which has discontinuous derivative and never crosses zero, but thanks to the interpolated result, it takes care of that. Options@FindRoots = Sort@Join[Options@FindRoot, {MaxRecursion -> Automatic, PerformanceGoal :> $PerformanceGoal, PlotPoints -> Automatic, Debug -> False, ZeroTolerance -> 10^-2}]; FindRoots[fun_, {var_, min_, max_}, opts:OptionsPattern[]] := Module[{PlotRules, RootRules, g, g2, pts, pts2, lpts, F, sol}, (* Extract the Options *) PlotRules = Sequence @@ FilterRules[Join[{opts}, Options@FindRoots], Options@Plot]; RootRules = Sequence @@ FilterRules[Join[{opts}, Options@FindRoots], Options@FindRoot]; (* Plot the function and "mesh" the point with y-coordinate 0 *) g = Normal@Plot[fun, {var, min, max}, MeshFunctions -> (#2 &), Mesh -> {{0}}, Method -> Automatic, Evaluate@PlotRules]; (* Get the meshes zeros *) pts = Cases[g, Point[p_] :> SetPrecision[p[[1]], OptionValue@WorkingPrecision], Infinity]; (* Get all plot points *) lpts = Join@@Cases[g, Line[p_] :> SetPrecision[p, OptionValue@WorkingPrecision], Infinity]; (* Derive the interpolated data to find other zeros *) F = Interpolation[lpts, InterpolationOrder->2]; g2 = Normal@Plot[Evaluate@D[F@var, var], {var, min, max}, MeshFunctions -> (#2 &), Mesh -> {{0}}, Method -> Automatic, Evaluate@PlotRules]; (* Get the meshes zeros and retain only small ones *) pts2 = Cases[g2, Point[p_] :> SetPrecision[p[[1]], OptionValue@WorkingPrecision], Infinity]; pts2 = Select[pts2, Abs[F@#] < OptionValue@ZeroTolerance &]; pts = Join[pts, pts2]; (* Join all zeros *) (* Refine zeros by passing each point through FindRoot *) If[Length@pts > 0, pts = Map[FindRoot[fun, {var, #}, Evaluate@RootRules]&, pts]; sol = Union@Select[pts, min <= Last@Last@# <= max &]; (* For debug purposes *) If[OptionValue@Debug, Print@Show[g, Graphics@{PointSize@0.02, Red, Point[{var, fun} /. sol]}]]; sol , If[OptionValue@Debug, Print@g]; {} ] ] Example: ![enter image description here][2] My primary use of this function is to find the eigenvalues of dielectric waveguides. They are found as the zeros of the boundary conditions. [1]: https://mathematica.stackexchange.com/questions/5663/about-multi-root-search-in-mathematica-for-transcendental-equations#answer-5666 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2017-07-01_153306.png&userId=845022 Thales Fernandes 2017-07-01T18:39:46Z https://community.wolfram.com/groups/-/m/t/1670775 ##Introduction## You may have noticed that the factorial function for integers generates a lot of trailing zeros at the end e.g. 100! evaluates to 9332621544394415268169923885626670049071596826438162146859296389521759\ 9993229915608941463976156518286253697920827223758251185210916864000000\ 000000000000000000 That's 24 zeros right there. Maybe you would like to figure out how to calculate the exact number for arbitrary input integers? And then maybe for any chosen radix as well i.e. not using the decimal representation? I don't want to spoil the fun for you, so please go chew away at this nice little mathematical diversion. The asymptotic "TZF" function for large integers is really compute-friendly, so for "easy" large integers you will be able to do the algebra just using a simple rule. Well and then it is always possible I have made a mistake, so I include my notebook on this problem for you to compare. Have fun! ![enter image description here][1] In the seventies when I got my first TI pocket calculator in school I developed a certain fascination for the factorial function. It was basically the most dangerous function around because if you entered any integer larger than 69 it would blow up with an error because it could not calculate numbers with more than two digits in the base-10 exponent and for most of them it could of course only show the first few most significant digits. So it took me almost 40 years and the mind-boggling capacity of WL to handle arbitrary-sized integers (well almost) to ask the following question: What is the number of trailing zeros in $n$ factorial? As a short reminder n! is the mathematical notation for the product of all positive integers less or equal to n. As you can easily see from an example there are plenty of trailing zeros in the factorial of reasonably-sized integers: 100! > `9332621544394415268169923885626670049071596826438162146859296389521759\ 9993229915608941463976156518286253697920827223758251185210916864000000\ 000000000000000000` Well to answer the question above we reformulate it as the number of sought zeros is equal to how many times n factorial can be divided (meaning integer division) by ten without getting a remainder. But for getting a factor of 10 there needs to be a corresponding factor of 5 and one factor of 2 in the prime factorization of $n$ factorial. Since every other number contains at least a factor of 2 in its prime factorization we can safely count only the factors of 5 in the factorization of the first n integers so we get a first (very functional and "pattern matchy" way to calculate the trailing zero function TZF: TZF1[n_] := Flatten[FactorInteger[Range[n]] , 1] // Cases[{5, a_} -> a] // Total ListPlot[Table[TZF1[n], {n, 100}], Joined -> True, ImageSize -> Large, PlotRange -> All] ![enter image description here][2] Well it looks pretty step-like with regular intervals so let's plot the differences: ListPlot[Differences[Table[TZF1[n], {n, 100}]], Joined -> True, ImageSize -> Large, PlotRange -> All] ![enter image description here][3] Aha! For each $5^i$ we get i new trailing zeros, but that is then equal to just summing the integer quotients of dividing n by increasing powers of $5^i$. So we have another candidate for the trailing zeros which definitely looks much more procedural: TZF2[n_] := Module[{i = 1, result = 0}, While[5^i <= n, result += Quotient[n, 5^i]; i++]; result] And finally we might always have done a mistake so let's just see how long the last group of digits is for any n larger than 4, which is the brute force way to get the answer: TZF3[n_] := If[n < 5, 0, IntegerDigits[Factorial[n]] // SplitBy[#, 1] & // Part[#, -1] & // Length] m = 150; ListPlot[{Table[TZF1[n], {n, m}], Table[TZF2[n], {n, m}], Table[TZF3[n], {n, m}]}, Joined -> True, ImageSize -> Large, PlotRange -> All] ![enter image description here][4] All well it seems, of course not everything worked out right at first trial, but now that all three seem to coincide, it seems pretty watertight right? So then let's see which form might be most efficient to calculate the TZF function: n = 10000; Timing[TZF1[n]] Timing[TZF2[n]] Timing[TZF3[n]] {0.041059, 2499} {0.000055, 2499} {0.043205, 2499} So you see functional is not always faster unfortunately, but it is also surprising to see that taking the long detour to calculate the whole factorial does equally well roughly as the first variant which only factorizes rather small numbers. But back to the original question we can see that we answer the original question pretty accurately by calculating the TZF function divided by n as a geometric sum: n =.; Sum[1/5^i, {i, 1, \[Infinity]}] > 1/4 So the trailing number of zeros of n factorial is approximately $n/4$ for large n (to be more accurate take one less). So if you get the question at the next party "how many trailing zeros are there in 10000 factorial?" just say "2499 of course"! So what about other radices (plural for radix or base of the integer digit representation)? To find an the answer we have to consider the prime factorization of the radix which then of course can have more (or less) than two prime factors and each with a separate multiplicity to form the radix as a product. So for each of these prime factors of the radix $p^k$ we then have to calculate how many times p appears in the positive integer numbers smaller or equal to n and find the integer quotient when dividing by k. The smallest of these is then our trailing zeros count. TZF4[n_, r_] := Quotient[Total[ Cases[Flatten[FactorInteger[Range[n]] , 1] , {#[[1]], a_} -> a]], #[[2]]] & /@ FactorInteger[r] // Min TZF5[n_, r_] := Module[{f = FactorInteger[r], q = Table[0, Length[FactorInteger[r]]], i, p, q0}, Do[i = 1; p = f[[j, 1]]; q0 = 0; While[p^i <= n, q0 += Quotient[n, p^i]; i++]; q[[j]] = q0 , {j, Length[f]}]; If[Min[q] > 0, Min[Quotient[q, f[[;; , 2]]]], 0] ] TZF6[n_, r_] := IntegerDigits[Factorial[n], r] // SplitBy[#, 1] & // If[Part[#, -1][[1]] == 0, Length[Part[#, -1]], 0] & Let's see if these agree to iron out obvious mistakes by feeding random samples. But beware, the factorial is still dangerous and will exhaust your physical memory if you throw in too big numbers or too small radices. Table[{n = RandomInteger[10000], r = RandomInteger[{5, 30}], TZF4[n, r], TZF5[n, r], TZF6[n, r]}, 10] // TableForm ![enter image description here][5] Table[{n = RandomInteger[10000], TZF1[n], TZF2[n], TZF3[n], TZF4[n, 10], TZF5[n, 10], TZF6[n, 10]}, 10] // TableForm ![enter image description here][6] In order to get asymptotic values of the trailing zeros you now need to divide n by $(p-1) k$. You have to do this only with the prime factor that results in the largest value of $(p-1) k$ of course. Then you round down again and you will be mostly very accurate. So let's do an example: TZF5[10000, 72] > 2498 For radix 72 the prime decomposition is $2^3 3^2$, so again it's a division by four (from the first factor) but now we'd actually would have to subtract 2 to get the right number. If you end up with a tricky radix decomposition for the party trick you might actually have to consult the pocket calculator on your smartphone for the division. To close out I have to confess that I still own a working HP-15C, an icon of computation devices and a testament to solid engineering: Well I am looking forward to the day when we are going to have hardware that durable again and being able to run WL from it. If you liked this piece and want to explore further, why not generalizing the TZF functions above to mixed radix representations or make your own variant of them to optimize code, memory or performance. ![enter image description here][7] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=42551.png&userId=20103 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=65422.png&userId=20103 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=64973.png&userId=20103 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=78994.png&userId=20103 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=54855.png&userId=20103 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=44026.png&userId=20103 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=44607.png&userId=20103 Fabian Wenger 2019-04-27T18:17:05Z https://community.wolfram.com/groups/-/m/t/610335 Introduction ------------ I was inspired by the Wolfram blog by [Mokashi][1] showing how to use *Mathematica* to solve a 2D stationary Navier-Stokes flow using a finite difference scheme to write this blog. I thought it should be possible to solve the 2D cavity box flow problem using *Mathematica's* Finite Element capabilities. In the following I show how the problem can be discretized and solved by the Finite Element method using an iterative scheme. Solving the 2D cavity flow using FE ----------------------------------- In order to solve the cavity flow problem using the finite element method, we first need to define the geometry of the box containing the fluid (the region) we want to discretize. The region is a rectangular box with width *a* and height *b*: \[CapitalOmega] = Rectangle[{0, 0}, {a, b}] /. {a -> 1, b -> 1}; RegionPlot[\[CapitalOmega], AspectRatio -> Automatic] ![The region][2] ---------- In order to use the FE capabilities in *Mathematica*, we first have to load the FE package: Needs["NDSolve`FEM`"] The mesh is created using the `ToElementMesh` command. In our case, we only input the region to be meshed and the maximum element size. The maximum element size is specified as 1/1000 of the characteristic length. The mesh will be used to discretize the PDEs. mesh = ToElementMesh[\[CapitalOmega], "MaxCellMeasure" -> 1/1000, "MeshElementType" -> QuadElement] `ToElementMesh` returns a mesh object showing the bounds of the discretized region, the element type and the number of elements. The actual mesh can be displayed in wireframe using the `Wireframe` option: mesh["Wireframe"] ![The mesh][3] ---------- The operator form of the 2D stationary Navier-Stokes flow --------------------------------------------------------- Now that we have defined the region and the mesh, we will need to input the PDEs describing our problem. Refer to the post by [Mokashi][4] to see the form of the equations. The unknowns are described by the velocity vector ***u*** and the scalar pressure field *p* uv = {u[x, y], v[x, y]}; pxy = p[x, y]; The stress tensor is defined by: \[Sigma] = -pxy IdentityMatrix[2] + 2/re Outer[ D, uv, {x, y}]*1/2 where `re` is the Reynolds number. The stationary N-S equations are defined by: NS = \!\( \*SubscriptBox[\(\[Del]\), \({x, y}\)]uv\). uv - \!\( \*SubscriptBox[\(\[Del]\), \({x, y}\)] . \[Sigma]\); MatrixForm[NS] - ![The Navier-Stokes equations][5] Adding the continuity condition gives the complete operator for the 2D N-S equations: NSOperator = {NS, \!\( \*SubscriptBox[\(\[Del]\), \({x, y}\)] . uv\)} // Flatten - ![Complete Navier-Stokes equations][6] ---------- It is only possible to solve a linear set of PDEs using the FE method. The operator form of the N-S equations derived above are nonlinear due to the convective terms which are products of the solution and it's derivatives. However, it is possible to linearise these terms and use an iterative scheme to calculate the nonlinear terms.Through a Newton linearization it is possible to show that: - ![enter image description here][7] Now, we only need to specify a reasonable starting value of u0 in order to calculate an approximation to the nonlinear term.We can now perform the next iteration by simply assigning the velocity field obtained from the last solution as an estimate to the next solution. However, we will need a criterion to terminate the iterations. A typical termination criterion would be when the flow field does not change much from one iteration to the next. This can be expressed as ![Termination criterion][8] where ![\[Epsilon\]][9] is a given tolerance and ![k'th veleocity field norm][10] is the Norm of the velocity vector and ![Initial velocity field norm][11] is the norm of the initial velocity field from the solution of the Stokes flow. Boundary conditions ------------------- The boundary conditions for the 2D cavity flow in a box are given by: bcs = { DirichletCondition[{u[x, y] == 1, v[x, y] == 0.}, y == 1], DirichletCondition[{u[x, y] == 0., v[x, y] == 0.}, x == 1], DirichletCondition[{u[x, y] == 0., v[x, y] == 0.}, y == 0], DirichletCondition[{u[x, y] == 0., v[x, y] == 0.}, x == 0], DirichletCondition[p[x, y] == 0., y == 1 && x == 1]}; We have prescribed no-slip conditions (*u*=0, *v*=0) at the left, right and lower side of the box. At the lid the *u* velocity is given by a characteristic velocity *U* = 1 while the *v* velocity is set to zero at this boundary. Since we now have specified the velocity on the complete boundary (all sides), the velocities are unique while the pressure is fixed up to one additive constant. Hence, we only need to define one additional boundary condition for the pressure. In our case we have set the pressure *p*=0 at the upper left corner of the box. Solving the cavity flow problem for Re=100 ----------------------------------- Wrapping everything together, we will solve the 2D cavity flow for Reynold's number 100 in an iterative scheme. We will use the solution of the Stoke's flow as our initial velocity field. The Stokes flow is simply derived from the N-S operator neglecting the convective terms: StokesOperator = NSOperator /. {u[x, y] -> 0, v[x, y] -> 0}; - ![List item][12] The PDEs for a Stokes flow with Reynolds number of 100: pde = StokesOperator == {0, 0, 0} /. re -> 100; A stable solution can be found if the velocities are interpolated with a higher order than the pressure. `NDSolve` allows an interpolation order for each dependent variable to be specified. {u0, v0, p0} = NDSolveValue[{pde, bcs}, {u, v, p}, {x, y} \[Element] mesh, Method -> {"FiniteElement", "InterpolationOrder" -> {u -> 2, v -> 2, p -> 1}, "IntegrationOrder" -> 5}]; The velocity field is easily visualized using the `StreamPlot` function: stokes = StreamPlot[{u0[x, y], v0[x, y]}, {x, 0, 1}, {y, 0, 1}, StreamPoints -> Fine, StreamColorFunction -> Hue, StreamColorFunctionScaling -> False, PlotLabel -> Style["Stokes flow for \!\(\*SubscriptBox[\(R\), \(e\)]\)=100", Black, FontFamily -> "Times", Bold]] ![Flow field of Stokes solution][13] Preparing for the iterations ---------------------------- To calculate the norm of the solution, wee need to access the raw solution vectors directly instead of the `InterPolatingFunction` returned by `NDSolveValue` above. We can access the raw solution vectors through the `NDSolve'ProcessEquations`. This will lead to a slightly more complicated work flow, but gives us access to the `StateData` object and it's data structure: pde = StokesOperator == {0, 0, 0} /. re -> 100; {state} = NDSolve`ProcessEquations[{pde, bcs}, {u, v, p}, {x, y} \[Element] mesh, Method -> {"FiniteElement", "InterpolationOrder" -> {u -> 2, v -> 2, p -> 1}, "IntegrationOrder" -> 5}] {NDSolve`StateData["<" "SteadyState" ">"]} From the `StateData` object we get access to the `FiniteElementData` state["FiniteElementData"]["FEMMethodData"]["Properties"] {"DegreesOfFreedom", "ElementMesh", "IncidentOffsets", "Incidents", \ "IntegrationOrder", "InterpolationOrder", "Precision", "Properties", \ "SolutionData", "TotalDegreesOfFreedom", "VariableData"} The `IncidentOffset` dataset gives us the offsets of the dependent variables in the set of the discretised PDEs: offset = state["FiniteElementData"]["FEMMethodData"]["IncidentOffsets"] {0, 1089, 4290, 7491} The `VariableData` gives us the sequence of the dependent variables: The incidents of the first dependent variable which is the pressure *p* range from the first offset plus one to the second offset: split = MapThread[#1 -> {#2} &, {vd[[3]], Span @@@ Transpose[{Most[# + 1], Rest[#]} &[offset]]}] {p -> {1 ;; 1089}, u -> {1090 ;; 4290}, v -> {4291 ;; 7491}} Now we have the necessary information to extract the raw solution for the velocity field and compute our norm for each iteration. For a steady state problem, invoking `NDSolve'Iterate` finds the solution of a system of equations with `LinearSolve`: NDSolve`Iterate[state]; The raw solution vector is now available from the `StateData` object: sol = state["FiniteElementData"]["Solution"]; The raw velocity vector can be extracted dropping the pressure terms from the solution vector: uv0 = Drop[sol, First[p /. split]]; We store the vector for using it to compute the norm in the next iteration. {u0, v0, p0} = {u, v, p} /. NDSolve`ProcessSolutions[state] This returns three interpolating functions which are assigned to `u0`, `v0` and `p0`. The velocity field can be visualized using the `StreamPlot` function as showed previously. We will now use the velocity field from the Stokes flow solution as a first guess to solve the N-S equations. We use u0 v0 from the solution of the Stokes flow as an approximation to the solution of the N-S equations: pde = NSOperator == {0, 0, 0} /. {u[x, y] -> u0[x, y], v[x, y] -> v0[x, y], re -> 100}; Solving the discretized PDEs: {un, vn, pn} = NDSolveValue[{pde, bcs}, {u, v, p}, {x, y} \[Element] mesh, Method -> {"FiniteElement", "InterpolationOrder" -> {u -> 2, v -> 2, p -> 1}, "IntegrationOrder" -> 5}]; We can now display the solution of the N-S equations and compare with the Stokes solution: GraphicsRow[{stokes, StreamPlot[{un[x, y], vn[x, y]}, {x, 0, 1}, {y, 0, 1}, StreamPoints -> Fine, StreamColorFunction -> Hue, StreamColorFunctionScaling -> False, PlotLabel -> "Navier-Stokes flow for \!\(\*SubscriptBox[\(R\), \(e\)]\)=100"]}, ImageSize -> Large] ![enter image description here][14] This is the first iteration, and we see that the Navier-Stokes flow field is slightly changed compared to the Stokes flow. The flow is not symmetric any more and we can see a new vortex appearing at the lower right corner. Iterating to a converged solution --------------------------------- Let's progress the iteration one more step by assigning the velocity field from the last iteration as an estimate to the solution of the next iteration: pde = NSOperator == {0, 0, 0} /. {u[x, y] -> un[x, y], v[x, y] -> vn[x, y], re -> 100}; {state} = NDSolve`ProcessEquations[{pde, bcs}, {u, v, p}, {x, y} \[Element] mesh, Method -> {"FiniteElement", "InterpolationOrder" -> {u -> 2, v -> 2, p -> 1}, "IntegrationOrder" -> 5}]; NDSolve`Iterate[state] Extract the velocity field from the last solution and compute the norm: sol = state["FiniteElementData"]["Solution"]; uvn = Drop[sol, First[p /. split]]; norm = Norm[uvn - uv0]/Norm[uv0] 0.0257194 In order to visualize the solution of this iteration, we have to process the solution: {un, vn, pn} = {u, v, p} /. NDSolve`ProcessSolutions[state]; StreamPlot[{un[x, y], vn[x, y]}, {x, 0, 1}, {y, 0, 1}, StreamPoints -> Fine, StreamColorFunction -> Hue, StreamColorFunctionScaling -> False, PlotLabel -> "Navier-Stokes flow for \!\(\*SubscriptBox[\(R\), \(e\)]\)=100, \ Iteration 2. Norm = " <> ToString[norm]] ![enter image description here][15] A norm of more than 2% is not small enough to accept the solution as converged, so we have to proceed with the next iteration: uvnMinusOne = uvn; pde = NSOperator == {0, 0, 0} /. {u[x, y] -> un[x, y], v[x, y] -> vn[x, y], re -> 100}; {state} = NDSolve`ProcessEquations[{pde, bcs}, {u, v, p}, {x, y} \[Element] mesh, Method -> {"FiniteElement", "InterpolationOrder" -> {u -> 2, v -> 2, p -> 1}, "IntegrationOrder" -> 5}]; NDSolve`Iterate[state]; sol = state["FiniteElementData"]["Solution"]; uvn = Drop[sol, First[p /. split]]; norm = Norm[uvn - uvnMinusOne]/Norm[uv0] {un, vn, pn} = {u, v, p} /. NDSolve`ProcessSolutions[state]; StreamPlot[{un[x, y], vn[x, y]}, {x, 0, 1}, {y, 0, 1}, StreamPoints -> Fine, StreamColorFunction -> Hue, StreamColorFunctionScaling -> False, PlotLabel -> "\!\(\*SubscriptBox[\(R\), \(e\)]\)=100, Iteration 3. Norm = " <> ToString[norm]] ![enter image description here][16] We see that the norm is less than 10^-3, and we may accept the last iteration as a converged solution. We have now solved the fully non-linear Navier-Stokes equations for a 2D cavity flow. I hope this small demonstration can be of inspiration to others. The big advantage of using the FE method is the flexibility of the method to discretize non-regular region geometries. This will allow us to solve 2D Navier-Stokes flows for much more complex geometries. I might return with some examples in a future post. Ole Christian [1]: http://blog.wolfram.com/2013/07/09/using-mathematica-to-simulate-and-visualize-fluid-flow-in-a-box/ [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2DNavier-StokesFlow.jpg&userId=382919 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=mesh.png&userId=382919 [4]: http://.//blog.wolfram.com/category/high-performance-computing/ [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=NS.png&userId=382919 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=NS2.png&userId=382919 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Linearisation.png&userId=382919 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Tolerance.png&userId=382919 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=eps.png&userId=382919 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=uk.png&userId=382919 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=u0.png&userId=382919 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=StokesFlow.png&userId=382919 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=StokesSolution.png&userId=382919 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=NS1andStokes.png&userId=382919 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=NS2Sol.png&userId=382919 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=NS3Sol.png&userId=382919 Ole Christian Astrup 2015-11-11T15:12:37Z https://community.wolfram.com/groups/-/m/t/611304 I'll show how to use the low level FEM functionality to code up a non-linear Navier-Stokes solver. The documentation explains the details about the low level [FEM programming](http://reference.wolfram.com/language/FEMDocumentation/tutorial/FiniteElementProgramming.html) functionality which I use here. Here is the basic idea: After every non-linear iteration we re-create an interpolation function from the now current solution vector and re-insert those into the PDE coefficients and iterate until converged. This will not be insanely efficient but it works on a PDE level. Now, to tackle non-linear problems it's a good idea to get the linear version to work first. In this case this is a Stokes solver. Here is a utility function to convert a PDE into it's discretized version: Needs["NDSolve`FEM`"] PDEtoMatrix[{pde_, ?___}, u_, r__] := Module[{ndstate, feData, sd, bcData, methodData, pdeData}, {ndstate} = NDSolve`ProcessEquations[Flatten[{pde, ?}], u, Sequence @@ {r}]; sd = ndstate["SolutionData"][[1]]; feData = ndstate["FiniteElementData"]; pdeData = feData["PDECoefficientData"]; bcData = feData["BoundaryConditionData"]; methodData = feData["FEMMethodData"]; {DiscretizePDE[pdeData, methodData, sd], DiscretizeBoundaryConditions[bcData, methodData, sd], sd, methodData} ] Next is the problem setup: ? = 10^-3; ? = 1; l = 2.2; h = 0.41; ? = RegionDifference[Rectangle[{0, 0}, {l, h}], ImplicitRegion[(x - 1/5)^2 + (y - 1/5)^2 < (1/20)^2, {x, y}]]; RegionPlot[?, AspectRatio -> Automatic] [![enter image description here][1]][2] ? = { DirichletCondition[p[x, y] == 0., x == l], DirichletCondition[{u[x, y] == 4*0.3*y*(h - y)/h^2, v[x, y] == 0}, x == 0], DirichletCondition[{u[x, y] == 0., v[x, y] == 0.}, y == 0 || y == h || (x - 1/5)^2 + (y - 1/5)^2 <= (1/20)^2]}; stokes = { D[u[x, y], x] + D[v[x, y], y], Div[{{-?, 0}, {0, -?}}.Grad[u[x, y], {x, y}], {x, y}] + D[p[x, y], x], Div[{{-?, 0}, {0, -?}}.Grad[v[x, y], {x, y}], {x, y}] + D[p[x, y], y] }; First we generate the system matrices for the Stokes equation: {dPDE, dBC, sd, md} = PDEtoMatrix[{stokes == {0, 0, 0}, ?}, {p, u, v}, {x, y} ? ?, Method -> {"FiniteElement", "InterpolationOrder" -> {p -> 1, u -> 2, v -> 2}, "MeshOptions" -> {"ImproveBoundaryPosition" -> False}}]; linearLoad = dPDE["LoadVector"]; linearStiffness = dPDE["StiffnessMatrix"]; vd = md["VariableData"]; offsets = md["IncidentOffsets"]; You could solve this stationary case, but we move on: The tricky part for non-linear equations is the linearization. For that I am referring you to [Chapter 5](https://www.freidok.uni-freiburg.de/fedora/objects/freidok:6440/datastreams/FILE1/content). uOld = ConstantArray[{0.}, md["DegreesOfFreedom"]]; mesh2 = md["ElementMesh"]; mesh1 = MeshOrderAlteration[mesh2, 1]; ClearAll[rhs] rhs[t_?NumericQ, ut_] := Module[{uOld}, uOld = ut; Do[ ClearAll[u0, v0, p0]; (* create pressure and velocity interpolations *) p0 = ElementMeshInterpolation[{mesh1}, uOld[[offsets[[1]] + 1 ;; offsets[[2]]]]]; u0 = ElementMeshInterpolation[{mesh2}, uOld[[offsets[[2]] + 1 ;; offsets[[3]]]]]; v0 = ElementMeshInterpolation[{mesh2}, uOld[[offsets[[3]] + 1 ;; offsets[[4]]]]]; (* these are the linearized coefficients *) nlPdeCoeff = InitializePDECoefficients[vd, sd, "LoadCoefficients" -> {(* F *) {-(D[u0[x, y], x] + D[v0[x, y], y])}, {-? (u0[x, y]*D[u0[x, y], x] + v0[x, y]*D[u0[x, y], y]) - D[p0[x, y], x]}, {-? (u0[x, y]*D[v0[x, y], x] + v0[x, y]*D[v0[x, y], y]) - D[p0[x, y], y]} }, "LoadDerivativeCoefficients" -> -{(* gamma *) {{0, 0}}, {{? D[u0[x, y], x], ? D[u0[x, y], y]}}, {{? D[v0[x, y], x], ? D[v0[x, y], y]}} }, "ConvectionCoefficients" -> {(*beta*) {{{0, 0}}, {{0, 0}}, {{0, 0}}}, {{{0, 0}}, {{? u0[x, y], ? v0[x, y]}}, {{0, 0}}}, {{{0, 0}}, {{0, 0}}, {{? u0[x, y], ? v0[x, y]}}} }, "ReactionCoefficients" -> {(* a *) {0, 0, 0}, {0, ? D[u0[x, y], x], ? D[u0[x, y], y]}, {0, ? D[v0[x, y], x], ? D[v0[x, y], y]} } ]; nlsys = DiscretizePDE[nlPdeCoeff, md, sd]; nlLoad = nlsys["LoadVector"]; nlStiffness = nlsys["StiffnessMatrix"]; ns = nlStiffness + linearStiffness; nl = nlLoad + linearLoad; DeployBoundaryConditions[{nl, ns}, dBC]; diriPos = dBC["DirichletRows"]; nl[[ diriPos ]] = nl[[ diriPos ]] - uOld[[diriPos]]; dU = LinearSolve[ns, nl]; Print[ i, " Residual: ", Norm[nl, Infinity], " Correction: ", Norm[ dU, Infinity ]]; uOld = uOld + dU; (*If[Norm[ dU, Infinity ]<10^-6,Break[]];*) , {i, 8} ]; uOld ] You'd then run this: uNew = rhs[0, uOld]; 1 Residual: 0.3 Correction: 0.387424 2 Residual: 0.000752321 Correction: 0.184443 3 Residual: 0.00023243 Correction: 0.0368286 4 Residual: 0.0000100488 Correction: 0.00264305 5 Residual: 3.6416*10^-8 Correction: 0.0000115344 6 Residual: 8.88314*10^-13 Correction: 1.22413*10^-10 7 Residual: 1.50704*10^-17 Correction: 1.08287*10^-15 8 Residual: 1.24246*10^-17 Correction: 6.93036*10^-16 See that the residual and correction converge. And do some post processing: p0 = ElementMeshInterpolation[{mesh1}, uNew[[offsets[[1]] + 1 ;; offsets[[2]]]]]; u0 = ElementMeshInterpolation[{mesh2}, uNew[[offsets[[2]] + 1 ;; offsets[[3]]]]]; v0 = ElementMeshInterpolation[{mesh2}, uNew[[offsets[[3]] + 1 ;; offsets[[4]]]]]; ContourPlot[u0[x, y], {x, y} ? mesh2, AspectRatio -> Automatic, PlotRange -> All, ColorFunction -> ColorData["TemperatureMap"], Contours -> 10, ImageSize -> Large] ContourPlot[v0[x, y], {x, y} ? mesh2, AspectRatio -> Automatic, PlotRange -> All, ColorFunction -> ColorData["TemperatureMap"], Contours -> 10, ImageSize -> Large] ContourPlot[p0[x, y], {x, y} ? mesh1, AspectRatio -> Automatic, PlotRange -> All, ColorFunction -> ColorData["TemperatureMap"], Contours -> 10, ImageSize -> Large] [![enter image description here][3]][4] [![enter image description here][5]][6] [![enter image description here][7]][8] Which show the x-, y-velocity components and the pressure. ---------- *This is a re-post of the [original][9] made with authors permission.* [1]: http://i.stack.imgur.com/8yr5F.jpg [2]: http://i.stack.imgur.com/8yr5F.jpg [3]: http://i.stack.imgur.com/oTeq0.jpg [4]: http://i.stack.imgur.com/oTeq0.jpg [5]: http://i.stack.imgur.com/k6rjY.jpg [6]: http://i.stack.imgur.com/k6rjY.jpg [7]: http://i.stack.imgur.com/AcnxA.jpg [8]: http://i.stack.imgur.com/AcnxA.jpg [9]: http://mathematica.stackexchange.com/a/96579/13 EDITORIAL BOARD 2015-11-12T18:24:33Z https://community.wolfram.com/groups/-/m/t/136774 Hi, im currently trying to work on the following formulae for a 1-d transient Heat transfer problem. [img=width: 272px; height: 74px;]/c/portal/getImageAttachment?filename=ScreenShot2013-10-10at1.58.06AM.png&userId=136759[/img] Basically it is a bar with 2 ends where each end has a fixed temperature after t=0 meaning to say that one end is being heated while the other is cooled to a fixed temperature.[b] i want to get a sketch of temp vs time and the solution for dT/dt[/b] my boundary condtions are T(0,0)=301K=T(L,0) and when it reaches steady state at an unknown time,  T(0,t)=293 T(L,t)=473 so with L = 5 i tried solving the equation but i kept coming up with the same error. [b]heatsol = NDSolve[{3.25D[temp[x, t], t] == -0.0000447D[ temp[x, t], {x, 2}], temp[0, 0] == 301, temp[5, 0] == 301, temp[5, t] == 473}, temp, {x, 0, 5}, {t, 0, 100}][/b] NDSolve::deqn: Equation or list of equations expected instead of True in the first argument {3.24776 (temp^(0,1))[x,t]==-0.000044705 (temp^(2,0))[x,t],temp[0,0]==301,temp[5,0]==301,True,temp[0,t]==273}. >> but if i assigned a random number to the boundary condition where it reaches steady state, temp[5,100] i get the following error saying that my initial condition is redundant [b]heatsol = NDSolve[{3.247755102 D[temp[x, t], t] == -0.000044705030299999997 D[ temp[x, t], {x, 2}], temp[5, 0] == 301, temp[5, 100] == 473}, temp, {x, 0, 5}, {t, 0, 100}][/b] NDSolve::bcedge: Boundary condition temp[5,0]==301 is not specified on a single edge of the boundary of the computational domain. >> Jon T 2013-10-09T18:14:37Z https://community.wolfram.com/groups/-/m/t/1843550 *MODERATOR NOTE: a submission to computations art contest, see more:* https://wolfr.am/CompArt-22 ---------- Showing Abs and Arg fields of Mandelbrot set under 200 iterations ![Mandelbrot_wallpaper.png][1] --- Showing Abs field of Mandelbrot set under 9 iterations ![9_iteration_abs.png][2] --- Showing Re vs. Im complex mapping of Mandelbrot set under 200 iterations ![ReIm_Complex_map.png][3] --- Mandelbrot Set on Neural Network =========================================== [The MXNet-based neural network framework](http://reference.wolfram.com/language/guide/NeuralNetworks.html) has been introduced to Wolfram Language since version 11. It is mostly designed for deep learning. However if we think about it, neural network is merely another fancy way to implement a certain program. As more and more functions are supported, it is now possible for us to "compile" general numerical program to neural network, which essentially gives us an interface to GPGPU parallel ability without the hassle of low-level coding. Inspired by [Brian](https://community.wolfram.com/web/tl2854)'s [recent post on MathCompile](https://community.wolfram.com/groups/-/m/t/1830592), we demonstrate in this post how to implement a neural network to compute the Mandelbrot set. ## Utilities As usual here is the code dump of some helper functions. Readers can evaluate then safely skip this section. ### code dump of helper functions ``` ClearAll[pipe, branch] pipe = RightComposition; branch = Through@*{##} &; ``` ``` Needs["NeuralNetworks`"] ``` ``` Clear[netInputPortSort] netInputPortSort[inPortLst_List] := Function[origNet, netInputPortSort[origNet, inPortLst]] netInputPortSort[origNet_NetGraph, inPortLst_List] := Block[{NetGraph = Inactive[NetGraph], fullnet, net}, fullnet = origNet ; net = fullnet[[1]] ; net["Inputs"] = AssociationThread[Rule[inPortLst, inPortLst /. net["Inputs"]]] ; ReplacePart[fullnet, 1 -> net] ] // Activate ``` --- # Basic concept The center of the Mandelbrot set computation is a simple iteration: $$\left\{ \begin{align} z_n &= c+z_{n-1}^2 \\ z_0 &= 0 \end{align} \right.$$ Under simple iteration it leads to the Mandelbrot set. ``` Block[{region, c, faclets} , (* random-points as different c for iteration: *) region = Disk[{-.5, 0}, 2] // DiscretizeGraphics // DiscretizeRegion[#, MaxCellMeasure -> .0001] & ; faclets = MeshCells[region, 2][[;; , 1]] ; c = MeshCoordinates[region].{1, I} ;(* The iteration taking place simultaneously for all c, nested 21 steps: *) Nest[Function[z, z^2 + c], 0, 21] // (* Visualizing the result: *) pipe[ pipe[(* Regularizing the norm for a clear visualization: *) Abs, HistogramTransform, Rescale, (1 - #)^2 &] , Append[ReIm[c]\[Transpose], #]\[Transpose] & , Graphics3D[ GraphicsComplex[#, {EdgeForm[], Polygon@faclets}] , Boxed -> False, SphericalRegion -> True, RotationAction -> "Fit" , ViewPoint -> {1, -2.4, 2.4}, ViewVertical -> {0, 0, 1} ] & ] ] ``` ![3D mesh of Mandelbrot set][4] Using the built-in [`MandelbrotSetPlot`](http://reference.wolfram.com/language/ref/MandelbrotSetPlot.html) function, it's straightforward to plot the traditional Mandelbrot set visualization: ``` MandelbrotSetPlot[{-2.5 - 2 I, 1.5 + 2 I}] ``` ![MandelbrotSetPlot][5] With some test we can notice that, for fixed `MaxIterations`, the relationship between computing time of `MandelbrotSetPlot` and `ImageResolution` follows a power law. ``` builtInTimeTest = {#, AbsoluteTiming[MandelbrotSetPlot[{-2.5 - 2 I, 1.5 + 2 I}, MaxIterations -> 100, ImageResolution -> #];][[1]]} & /@ Range[101, 4001, 100] NonlinearModelFit[builtInTimeTest, a r^k, {a, k}, r][r] // LogLogPlot[#, {r, 400, 5000}, PlotStyle -> Directive[Red, AbsoluteThickness[2]], Frame -> True, FrameTicks -> All] & // Show[{# , ListLogLogPlot[builtInTimeTest, PlotMarkers -> "OpenMarkers", PlotRange -> All] }, FrameLabel -> {"ImageResolution", "AbsoluteTiming"}] & ``` ![time benchmark of MandelbrotSetPlot][6] This is a scenario where parallel computation might make a difference. --- # Mandelbrot set on neural network -- A naïve attempt ## The implementation ### Iteration core net Neural network (short for **_NN_**) doesn't support complex number (yet). Aside from that, the iteration formula is simple enough for [`ThreadingLayer`](http://reference.wolfram.com/language/ref/ThreadingLayer.html): ``` iterNet = Module[{c = cX + cY I, z = x + y I}, z^2 + c // pipe[ ReIm, ComplexExpand, Echo[#, "{Re[\!\(\*SuperscriptBox[\(z\), \(2\)]\)+c], Im[\!\(\*SuperscriptBox[\(z\), \(2\)]\)+c]}:"] & , Map@pipe[ Inactive[Function][{cX, cY, x, y}, #] & , Activate , ThreadingLayer ] , Inactive[NetGraph][# , { (NetPort /@ StringSplit["cX,cY,x,y", ","]) -> # & /@ {1, 2} , 1 -> NetPort["x"], 2 -> NetPort["y"] } ] & , Activate ] ] ``` ![iterNet][7] It's very easy to perform the iteration with the help of [`Nest`](http://reference.wolfram.com/language/ref/Nest.html) / [`NestList`](http://reference.wolfram.com/language/ref/NestList.html). ``` Block[{region, c, xyInit, result} , (* random-points as different c for iteration: *) region = Disk[{0, 0}, .5] // DiscretizeGraphics // DiscretizeRegion[#, MaxCellMeasure -> .01] & ; c = MeshCoordinates[region].{1, I} // ReIm ; c = AssociationThread[StringSplit["cX,cY", ","], c\[Transpose]] ; xyInit = AssociationThread[StringSplit["x,y", ","], 0*Values[c]] ; result = NestList[ pipe[ Map[Clip[#, {-2, 2}] &] , Join[c, #] & , iterNet ] , xyInit, 20 ] ; result // pipe[ Values, Rest, Map@Transpose , Transpose , MapThread[{#2, BSplineCurve@#1} &, {#, # // Length // Range // N // Rescale // Map[ColorData["Rainbow"]]}] & , Graphics[#, Frame -> True, FrameTicks -> All, PlotRange -> {GoldenRatio {-1, 1}, {-1, 1}}, PlotRangeClipping -> True] & ] ] ``` ![Nest on iterNet][8] ### Nest net Now we have the core net representing the iteration formula, we need to mimic the functionality of `Nest[f, expr, n]` fully on a neural network. The go-to function is of course [`NetNestOperator`](https://reference.wolfram.com/language/ref/NetNestOperator.html). However in our case, the same $c$ is used repeatedly for all iterations, so we'd like to pass it directly to each iteration. Thus, we do it with the following customized `NetNestPartialOperator` function: ``` ClearAll[NetNestPartialOperator] NetNestPartialOperator[net_, staticPorts_List, nestPort_, iterNum_Integer] := Module[{pIdx, netIdx, staticpath, nestpath}, netIdx = Range[iterNum] ; pIdx = AssociationThread[staticPorts, staticPorts // Length // Range // Map[ToString]] ; staticpath = Function[p, NetPort["static" <> pIdx[p]] -> (NetPort[#, p] & /@ netIdx)] /@ staticPorts ; nestpath = Thread[Flatten[{NetPort["nest"], netIdx // Most}] -> (NetPort[#, nestPort] & /@ netIdx)] ; Inactive[NetGraph][ConstantArray[net, iterNum], {staticpath, nestpath} // Flatten] // Activate // netInputPortSort[Flatten[{"nest", "static" <> # & /@ Values[pIdx]}]] ] ``` Basically our `NetNestPartialOperator` takes a [`net_NetGraph`](https://reference.wolfram.com/language/ref/NetGraph.html) as the 1st argument. One of `net`'s input ports, i.e. `nestPort`, is going to be nested across iterations; other input ports (i.e. `staticPorts`) will be feed in constant/non-nested values. Here is a simple example realizing a 5 steps nest iteration `Nest[Function[c,a+b+c],c0,5]`: ``` Module[{coreNet, nestNet} , coreNet = NetGraph[{ThreadingLayer[#1+#2+#3&]}, {{NetPort["a"],NetPort["b"],NetPort["c"]}->1},"a"->"Real","b"->"Real","c"->"Real"] ; nestNet = NetNestPartialOperator[coreNet, {"a", "b"}, "c", 5] ; { {"coreNet", "nestNet"} , Quiet[ NetInformation[#, "MXNetNodeGraph"] // Graph[#, VertexSize -> 0.2, VertexLabels -> "Name"] & ] & /@ {coreNet, nestNet} }\[Transpose] // Grid[#, Background -> {{GrayLevel[.9], None}, None}, Frame -> All, FrameStyle -> Black] & ] ``` ![NetNestPartialOperator example][9] ### The Mandelbrot net In order to construct a net suitable for `NetNestPartialOperator`, we merge the real and imaginary ports in `iterNet` into a single "complex" port. ``` zNet = NetGraph[{ReplicateLayer[1], ReplicateLayer[1], CatenateLayer[]}, {NetPort["1"] -> 1, NetPort["2"] -> 2, {1, 2} -> 3}]; nestcoreNet = NetGraph[ {PartLayer[1], PartLayer[2], iterNet, zNet} , { (NetPort[#] -> NetPort[3, #]) & /@ StringSplit["cX,cY", ","] , NetPort["z"] -> {1, 2} , {{1, 2}, StringSplit["x,y", ","]} // MapThread[(#1 -> NetPort[3, #2]) &] , {StringSplit["x,y", ","], StringSplit["1,2", ","]} // MapThread[(NetPort[3, #1] -> NetPort[4, #2]) &] } ] ``` ![nestcoreNet][10] Thus a full net computing the Mandelbrot set is constructed as follows: ``` ClearAll[mandelbrot] mandelbrot[iterNum_Integer?Positive] := NetGraph[{ zNet , ElementwiseLayer[0 # &] , NetNestPartialOperator[nestcoreNet, StringSplit["cX,cY", ","], "z", iterNum] }, { {NetPort["cX"], NetPort["cY"]} -> 1 -> 2 , {2, NetPort["cX"], NetPort["cY"]} -> 3 } ] ``` ## Results We showcase our `mandelbrot` net with 9 iteration steps over the complex region ${-2-1.2I,1+1.2I}$, with a image resolution $401 \times 501$. The network is executed on a GPU (NVIDIA GeForce GTX 1050 Ti) with [`"Real64"`](https://reference.wolfram.com/language/ref/NetGraph.html#1010560149) precision. ``` mandelbrotF = mandelbrot[9]; ``` ``` result = Module[{region = {-2 - 1.2 I, 1 + 1.2 I}, resol = 501, aspr}, region = region // ReIm // Transpose ; aspr = region.{-1, 1} // Reverse // Apply[Divide] ; resol = resol {1, aspr} // Round ; {resol, region} // pipe[ MapThread[Rescale[Range[#1] // N // Rescale, {0, 1}, #2] &] , Tuples , AssociationThread[{"cX", "cY"}, #\[Transpose]] & , AbsoluteTiming[mandelbrotF[#, WorkingPrecision -> "Real64", TargetDevice -> "GPU"]] & , pipe[ branch[pipe[First, Quantity[#, "Seconds"] &, Echo[#, "Computing time on NN:"] &], Last] , Last] , Developer`ToPackedArray , ArrayReshape[#, {2, Sequence @@ resol}] & , {1, I}.# & , Transpose, Reverse ] ]; (* Computing time on NN: 3.08505 s *) ``` ``` result // Dimensions (* {401, 501} *) ``` ``` result // pipe[ branch[ pipe[ Abs , pipe[ branch[Flatten /* HistogramTransform, Dimensions /* Last] , Apply@Partition ] , Rescale, (1 - #)^5 & ] , pipe[Arg, Sin, Rescale] ] , Map @ pipe[ Image[#, ImageSize -> Length[#]] & , Colorize[#, ColorFunction -> "DarkColorFractalGradient"] & ] ] ``` ![naive result][11] Note the highlighted [periodic bulbs and Mandelbrot dendritic islands](https://dhushara.com/DarkHeart/DarkHeart.htm) in the left image, and the pattern approximately following the [external rays](https://en.wikipedia.org/wiki/External_ray) of the set in the right image. As a comparison, here is the result from the same region, iteration steps and resolution using the built-in `MandelbrotSetPlot` function. ``` AbsoluteTiming[ MandelbrotSetPlot[{-2 - 1.2 I, 1 + 1.2 I}, MaxIterations -> 9, ImageResolution -> 501] ] // pipe[ branch[pipe[First, Quantity[#, "Seconds"] &, Echo[#, "Computing time:"] &], Last], Last , #[[1, 1]] &, Reverse, Image[#, ImageSize -> Dimensions[#][[1]]] & ] (* Computing time: 0.187943 s *) ``` ![MandelbrotSetPlotOver(-2-1.2I,1+1.2I)][12] Clearly at this resolution scale, `MandelbrotSetPlot` is much faster than our neural-net function. But at a much larger resolution our function will eventually win. ``` myMandelbrotSetPlotTiming[resolution_Integer] := Module[ {region = {-2 - 1.2 I, 1 + 1.2 I}, aspr, resol} , region = region // ReIm // Transpose ; aspr = region.{-1, 1} // Reverse // Apply[Divide] ; resol = resolution {1, aspr} // Round ; {resol, region} // pipe[ MapThread[Rescale[Range[#1] // N // Rescale, {0, 1}, #2] &] , Tuples , AssociationThread[{"cX", "cY"}, #\[Transpose]] & , AbsoluteTiming[mandelbrotF[#, WorkingPrecision -> "Real64", TargetDevice -> "GPU"];][[1]] & , {resolution, #} & ] ] myTimeTest = myMandelbrotSetPlotTiming /@ Range[101, 4001, 100]; NonlinearModelFit[myTimeTest, a r^k, {a, k}, r][r] // LogLogPlot[#, {r, 400, 5000}, PlotStyle -> Directive[Purple, AbsoluteThickness[2]], Frame -> True, FrameTicks -> All] & // Show[ { # , ListLogLogPlot[myTimeTest, PlotMarkers -> Graphics[{FaceForm[White], EdgeForm[{Orange, AbsoluteThickness[1]}], Polygon[CirclePoints[4]]}, ImageSize -> 7], PlotRange -> All] } , FrameLabel -> {"ImageResolution", "AbsoluteTiming"} ] & ``` ![time benchmark of NN based mandelbrot][13] Comparing with previous benchmark result of `MandelbrotSetPlot`, we can see our NN-based function has an advantage when the image resolution is large enough. ![time bench comparison][14] --- # Mandelbrot set on neural network -- Avoid overflow Careful readers will find that for larger iteration steps and/or a larger computing region, our naïvely implemented `mandelbrot` will lead to overflow. That is of course due to the $c$ values leading to divergency. One simple way to avoid this overflow is to constrain the nested $z$ to a bounded region at every iteration step. ## The implementation ### A constrained iteration core net The simplest way to constrain the nested $z$ is to clip it into a rectangle region. ``` iterNet = Module[{c = cX + cY I, z = x + y I}, z^2 + c // pipe[ ReIm, ComplexExpand, Echo[#, "{Re[\!\(\*SuperscriptBox[\(z\), \(2\)]\)+c], Im[\!\(\*SuperscriptBox[\(z\), \(2\)]\)+c]}:"] & , Map@pipe[ (* The constraint: -> *) Block[{escR = 3}, escR Clip[#/escR]] & , Inactive[Function][{cX, cY, x, y}, #] & , Activate , ThreadingLayer ] , Inactive[NetGraph][# , { (NetPort /@ StringSplit["cX,cY,x,y", ","]) -> # & /@ {1, 2} , 1 -> NetPort["x"], 2 -> NetPort["y"] } ] & , Activate ] ] ``` ### The Mandelbrot net Re-evaluating the rest of the code leads to our simply constrained `mandelbrotCons` function. ``` nestcoreNet = NetGraph[ {PartLayer[1], PartLayer[2], iterNet, zNet} , { (NetPort[#] -> NetPort[3, #]) & /@ StringSplit["cX,cY", ","] , NetPort["z"] -> {1, 2} , {{1, 2}, StringSplit["x,y", ","]} // MapThread[(#1 -> NetPort[3, #2]) &] , {StringSplit["x,y", ","], StringSplit["1,2", ","]} // MapThread[(NetPort[3, #1] -> NetPort[4, #2]) &] } ] ``` ``` ClearAll[mandelbrotCons] mandelbrotCons[iterNum_Integer?Positive] := NetGraph[{ zNet , ElementwiseLayer[0 # &] , NetNestPartialOperator[nestcoreNet, StringSplit["cX,cY", ","], "z", iterNum] }, { {NetPort["cX"], NetPort["cY"]} -> 1 -> 2 , {2, NetPort["cX"], NetPort["cY"]} -> 3 } ] ``` ## Results Now we can go for much larger iteration steps on a larger region. ``` mandelbrotConsF = mandelbrotCons[200]; ``` ``` result = Module[{region = {-3 - 2 I, 1 + 2 I}, resol = 1001, aspr}, region = region // ReIm // Transpose ; aspr = region.{-1, 1} // Reverse // Apply[Divide] ; resol = resol {1, aspr} // Round ; {resol, region} // pipe[ MapThread[Rescale[Range[#1] // N // Rescale, {0, 1}, #2] &] , Tuples , AssociationThread[{"cX", "cY"}, #\[Transpose]] & , AbsoluteTiming[mandelbrotConsF[#, WorkingPrecision -> "Real64", TargetDevice -> "GPU"]] & , pipe[ branch[pipe[First, Quantity[#, "Seconds"] &, Echo[#, "Computing time on NN:"] &], Last] , Last] , Developer`ToPackedArray , ArrayReshape[#, {2, Sequence @@ resol}] & , {1, I}.# & , Transpose, Reverse ] ]; (* Computing time on NN: 6.29684 s *) ``` ``` result // Dimensions (* {1001, 1001} *) ``` ``` result // pipe[ branch[ pipe[ Abs , pipe[ branch[Flatten /* HistogramTransform, Dimensions /* Last] , Apply@Partition ] , Rescale, (1 - #)^5 & ] , pipe[Arg, Sin, Rescale] ] , Map @ pipe[ Image[#, ImageSize -> Length[#]] & , Colorize[#, ColorFunction -> "DarkColorFractalGradient"] & ] ] ``` ![constrained result][15] Or thresholding at 2 to get the classical Mandelbrot set. ``` result // Abs // UnitStep[2 - #] & // Image ``` ![classical Mandelbrot 200][16] ### Zoom-in For zoomed-in regions, this clipped version gives interesting results. ``` result = Module[{region = {-0.65 + 0.47 I, -0.4 + 0.72 I}, resol = 1001, aspr}, region = region // ReIm // Transpose ; aspr = region.{-1, 1} // Reverse // Apply[Divide] ; resol = resol {1, aspr} // Round ; {resol, region} // pipe[ MapThread[Rescale[Range[#1] // N // Rescale, {0, 1}, #2] &] , Tuples , AssociationThread[{"cX", "cY"}, #\[Transpose]] & , AbsoluteTiming[mandelbrotConsF[#, WorkingPrecision -> "Real64", TargetDevice -> "GPU"]] & , pipe[ branch[pipe[First, Quantity[#, "Seconds"] &, Echo[#, "Computing time on NN:"] &], Last] , Last] , Developer`ToPackedArray , ArrayReshape[#, {2, Sequence @@ resol}] & , {1, I}.# & , Transpose, Reverse ] ]; (* Computing time on NN: 6.06289 s *) ``` ``` result // pipe[ branch[ pipe[ Abs , pipe[branch[Flatten /* HistogramTransform, Dimensions /* Last], Apply@Partition] , Rescale, (1 - #)^5 &, Sin[\[Pi]/2 #] &, Rescale ] , pipe[Arg, Sin[#/2] &, Rescale] ] , Map@pipe[ Image[#, ImageSize -> Round[Length[#]/2]] & , Colorize[#, ColorFunction -> "StarryNightColors"] & ] ] ``` ![zoom-inAt(-0.65+0.47I,-0.4+0.72I)][17] ### Complex map We can also stylize the result any way we want, say, showing the complex mapping like the [`ComplexPlot`](https://reference.wolfram.com/language/ref/ComplexPlot.html). Abs vs. Arg: ``` result // pipe[ branch[ pipe[ Arg , branch[ pipe[Sin[#/2] &, Rescale] , pipe[ Sin[50 #] &, ArcSin, Rescale, #^.5 & ] ] ] , pipe[ Abs , Rescale, Log[10^-3 + #] &, Rescale , branch[ pipe[Sin[200 #] &, ArcSin, Rescale, #^.5 &] , pipe[#^5 &, Rescale[#, {0, 1}, {1, .3}] &] ] ] ] , Apply@Function[{arg2, abs2}, {arg2[[1]], arg2[[2]] abs2[[1]], abs2[[2]]}] , Image[#, ColorSpace -> "HSB", Interleaving -> False] & ] ``` ![Complex map: Abs vs Arg][18] Or Re vs. Im: ``` result // pipe[ branch[ pipe[ ReIm, Transpose[#, {2, 3, 1}] & , Map@pipe[ Cos[100 2 \[Pi] #] &, Rescale, #^.2 & ] ] , pipe[ Abs , Rescale, Log[10^-3 + #] &, Rescale , branch[ pipe[Sin[\[Pi]/2 #] &, Rescale] , pipe[#^5 &, Rescale[#, {0, 1}, {1, .5}] &] ] ] ] , Apply@Function[{reim, abs2}, {abs2[[1]], Times @@ reim, abs2[[2]]}] , Image[#, ColorSpace -> "HSB", Interleaving -> False] & ] ``` ![Complex map: Re vs Im][19] ### A different region (The detailed code in this section is omitted in the post, but included in the attached notebook.) Computing over a different region (`-0.0452407411 + 0.9868162204352258 I + 2.7 10^-5 {-1 - I, 1 + I}`) and fiddling with color palettes from `ColorData["ThemeGradients"]` gives us this wallpaper-like result (the [`ColorFunction`](https://reference.wolfram.com/language/ref/Colorize.html#777264821) used here is `"M10DefaultDensityGradient"`). ![zoom-in 2][20] Also the corresponding complex map plots: ![complex maps: Abs vs Arg & Re vs Im][21] --- # References - [Exploding the Dark Heart of Chaos](https://dhushara.com/DarkHeart/DarkHeart.htm) - [Wikipedia: External ray](https://en.wikipedia.org/wiki/External_ray) - [MathWorld: Mandelbrot Set](http://mathworld.wolfram.com/MandelbrotSet.html) - [Wikipedia: Mandelbrot set](https://en.wikipedia.org/wiki/Mandelbrot_set) - [The Mandelbrot Set Browser](http://www.cuug.ab.ca/dewara/mandelbrot/Mandelbrowser.html) [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Mandelbrot_wallpaper.png&userId=93201 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9_iteration_abs.png&userId=93201 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ReIm_Complex_map.png&userId=93201 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3D_mesh.png&userId=93201 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=MandelbrotSetPlot.png&userId=93201 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=time_bench_MandelbrotSetPlot.png&userId=93201 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=iterNet.png&userId=93201 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=iterNet_Nest.png&userId=93201 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=NetNestPartialOperator_example.png&userId=93201 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=nestcoreNet.png&userId=93201 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=naive_result.png&userId=93201 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=MandelbrotSetPlot2.png&userId=93201 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=time_bench_NN.png&userId=93201 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=time_bench_comparison.png&userId=93201 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=constrained_result.png&userId=93201 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=classical_Mandelbrot_200.png&userId=93201 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=zoom_in_1.png&userId=93201 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=AbsArg_Complex_map.png&userId=93201 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ReIm_Complex_map.png&userId=93201 [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Mandelbrot_wallpaper.png&userId=93201 [21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=complex_maps_2.png&userId=93201 Silvia Hao 2019-12-19T07:59:59Z https://community.wolfram.com/groups/-/m/t/143526 I have difficulty programming to find x in a polynomial. I try NSolve to set the equation to zero and solve for x. If N = 85, x= 5, and y = 17 I have an equation:[mcode]y = sqrt((N * y – x^2)/x)[/mcode]as an approximation of the larger Prime product (or any possible product) My equation as it stands does not find x. I know there is a margin of error in the equation. This error can be subtracted to get a closer approximation. For example: In the following equations: y = 17.2941176471 = 16.8522995464 This is the answer when subtracting the 2 equations below to find x knowing only N. Look at the Yellow. So as the equations approach 0 (plus the margin of error). So since it is an approximation I need to find those values that are less than 1 and greater than 0. But 16.9082 is the value of the equation and not the value of x which should be found. I need help programming this. So if anyone can help it would be much appreciated. [mcode]y = sqrt[(((85/x) * 85 - x^2)/ x) ]= ((85^2/x) + x^2)/ 85 p = ((((85^2/x) + x^2)/ 85 ) ^2)- (((85/x) * 85 - x^2)/ x )^2 - 0.4418181007 ; sol = NSolve[p?0, x] {{x?-86.8953},{x?82.8717},{x?23.3122},{x?-7.50642+19.0312 ?},{x?-7.50642-19.0312 ?}, {x?-10.592+14.3276 ?},{x?-10.592-14.3276 ?},{x?16.9082}}[/mcode][mcode]y = sqrt[(N * y - x^2) / x] y = sqrt[(7872197 * 3191 - 2467^2) / 2467][/mcode] You can see this work at [url=http://www.3dbuzz.com/forum/threads/200441-New-One-Way-Function/page2]http://www.3dbuzz.com/forum/threads/200441-New-One-Way-Function/page2[/url] Look at the last page first. Also my website is [url=www.constructorscorner.net]www.constructorscorner.net[/url] Bobby Joe Snyder 2013-10-23T22:58:02Z