https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Physics sorted by most likes. https://community.wolfram.com/groups/-/m/t/2411604 A new study group devoted to Differential Equations begins next Monday! A list of daily topics can be found on our [Daily Study Groups][1] page. This group will be led by one of our outstanding Wolfram certified instructors, Luke Titus, and will meet daily, Monday to Friday, over the next three weeks. Luke will share the excellent lesson videos created by him for the upcoming Wolfram U course "[Introduction to Differential Equations][2]". Study group sessions include time for exercises, discussion and Q&A. This study group will help you achieve the "Course Completion" certificate for the "Introduction to Differential Equations" course after you complete the course quizzes. Sign up: [Study group registration page][3] [1]: https://www.wolfram.com/wolfram-u/special-event/study-groups/ [2]: https://www.wolfram.com/wolfram-u/introduction-to-differential-equations/ [3]: https://www.bigmarker.com/series/daily-study-group-intro-to-differential-equations/series_details?utm_bmcr_source=community Devendra Kapadia 2021-11-22T16:35:30Z https://community.wolfram.com/groups/-/m/t/863933 Many of you have seen the strandbeest (from Dutch, meaning beach-beast). These PVC tube animals created by Theo Jansen walk along the beach and are wind powered: ![enter image description here][1] Years ago (2009 to be more exact) I made a post on my blog about the movement of the legs, as evidenced by the still-nicely-working Mathematica notebook: ![enter image description here][2] At the time the proportions of the legs were not known publicly so I meticulously studied frames of (low quality) YouTube videos. I made the following diagram in Illustrator of what I thought I saw: ![enter image description here][3] ![enter image description here][4] On the left the length of the legs in red, and in blue the numbers of the joints. On the right the trajectory of the joints that I calculated at the time in Mathematica. It's funny that my blog does not exist any more (for years actually), but these images live on, as I found out when I looked for strandbeest on Google Images: ![enter image description here][5] My images! But not on my website! Nice to see people still use it. Now, in 2016, I saw these files on my laptop, and thought: is there finally more known about them? Well yes, there is! The exact proportions are now known and there is tons and tons of videos, lectures, 3D-printable strandbeest models, interviews with Theo Jansen and other stuff! So now we can find the exact dimensions readily on the internet: ![enter image description here][6] Notice that I (wrongly) assumed that the legs had 'feet'! oops! I was very happy to see that my lengths were not that wrong though! Let's recreate the strandbeest. We do so by first creating a function that quickly finds the intersection of two circles: Clear[FindPoint, FindLines] FindPoint[p1 : {x1_, y1_}, p2 : {x2_, y2_}, R_, r_, side_] := Module[{d, x, y, vc1, vc2, p, sol, sol1, sol2, s1, s2, sr}, d = N@Sqrt[(x2 - x1)^2 + (y2 - y1)^2]; x = (d^2 - r^2 + R^2)/(2 d); y = Sqrt[R^2 - x^2]; vc1 = Normalize[{x2 - x1, y2 - y1}]; vc2 = Cross[vc1]; p = {x1, y1} + x vc1; {sol1, sol2} = {p + y vc2, p - y vc2}; s1 = Sign[Last[Cross[Append[(p2 - p1), 0], Append[(sol1 - p1), 0]]]]; s2 = Sign[Last[Cross[Append[(p2 - p1), 0], Append[(sol2 - p1), 0]]]]; sr = If[side === Left, 1, -1]; Switch[sr, s1, sol1 , s2 , sol2 ] ] This finds on the side 'side' (Left/Right) the intersection point of two circles positioned at p1 and p2, with radii R and r, respectively. And now we can easily compute all the little vertices/joints of our beast: FindLines[\[Theta]_] := Module[{p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15}, {p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15} = FindPoints[\[Theta]]; {{p1, p2}, {p2, p3}, {p3, p4}, {p1, p4}, {p2, p6}, {p4, p6}, {p3, p5}, {p4, p5}, {p5, p8}, {p6, p8}, {p6, p7}, {p7, p8}, {p1, p11}, {p10, p11}, {p2, p10}, {p2, p13}, {p11, p13}, {p10, p12}, {p11, p12}, {p12, p14}, {p13, p14}, {p13, p15}, {p14, p15}} ] FindPoints[\[Theta]_] := Module[{p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16}, p1 = {0, 0}; p4 = {38, -7.8}; p11 = {-38, -7.8}; p2 = 15 {Cos[\[Theta]], Sin[\[Theta]]}; p3 = FindPoint[p2, p4, 50, 41.5, Left]; p6 = FindPoint[p2, p4, 61.9, 39.3, Right]; p5 = FindPoint[p3, p4, 55.8, 41.5, Left]; p8 = FindPoint[p5, p6, 39.4, 36.7, Left]; p7 = FindPoint[p6, p8, 49, 65.7, Right]; p10 = FindPoint[p2, p11, 50, 41.5, Right]; p13 = FindPoint[p2, p11, 61.9, 39.3, Left]; p12 = FindPoint[p10, p11, 55.8, 41.5, Right]; p14 = FindPoint[p12, p13, 39.4, 36.7, Right]; p15 = FindPoint[p13, p14, 49, 65.7, Left]; {p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15} ] Now we can plot it easily: trajectoriesdata = (FindPoints /@ Subdivide[0, 2 Pi, 100])\[Transpose]; Manipulate[ Graphics[{Arrowheads[Large], Arrow /@ trajectoriesdata, Thick, Red, Line[FindLines[\[Theta]]]}, PlotRange -> {{-150, 150}, {-120, 70}}, ImageSize -> 800 ] , {\[Theta], 0, 2 \[Pi]} ] ![enter image description here][7] We can also make an entire bunch of legs at the same time and make a 3D beast! Manipulate[ mp = 60; n = 12; \[CurlyPhi] = Table[Mod[5 \[Iota], n, 1], {\[Iota], 1, n}]; Graphics3D[{Darker@Yellow, Table[ Line[ Map[Prepend[mp \[Iota]], FindLines[\[Theta] + \[CurlyPhi][[\[Iota]]] (2 Pi/n)], {2}]], {\[Iota], n} ] , Black, Line[{{mp 1, 0, 0}, {mp n, 0, 0}}] } , Lighting -> "Neutral", PlotRangePadding -> Scaled[.1], PlotRange -> {{-mp, (n + 1) mp}, {-150, 150}, {-150, 150}}, Boxed -> False, ImageSize -> 700 ] , {\[Theta], 0, 2 \[Pi]} ] ![enter image description here][8] From the side we can look at how the legs of 4-pair-legged and 6-pair-legged versions of the beasts work: ![enter image description here][9] ![enter image description here][10] Hope you enjoyed this! Perhaps someone else can make this thing actually walk over a (bumpy) surface? [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=LVDKumerus2.jpg&userId=73716 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-05-29at00.51.53.png&userId=73716 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=strandbeest_sketch.png&userId=73716 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=strandbeest_trajectories.png&userId=73716 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-05-29at00.16.23.png&userId=73716 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Strandbeest_Leg_Proportions-01.png&userId=73716 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3493strandwalk.gif&userId=73716 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3587strandwalk3D.gif&userId=73716 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4legged.gif&userId=73716 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6legged.gif&userId=73716 Sander Huisman 2016-05-28T23:02:16Z https://community.wolfram.com/groups/-/m/t/235291 [img]/c/portal/getImageAttachment?filename=fig0.gif&userId=93201[/img] Some time ago one of my friends asked me whether it is possible to design a cellular automaton which can generate realistic snowflakes. I recall my crystallography and thermodynamics knowledge and came up a very simple yet impressive model. [size=5][b]The Regular Triangular Lattice[/b][/size] First of all, we are trying to simulate snowflake, which is a kind of hexagonal crystal. So it should be best to construct our CA on a regular hexagonal grid, i.e. regular triangular lattice. We all know [b]CellularAutomaton[/b] inherently works on rectangle lattices ("4-lattice" for short), so how can we deduce a triangular lattice ("3-lattice" for short) on it? Well, the differences between rect-lattice and triangular one is just a geometric transformation. To demonstrate that, have a look at the following 4-lattice, with a blue square highlighting the range-1 [url=http://mathworld.wolfram.com/MooreNeighborhood.html]Moore neighborhood[/url]: [img=width: 388px; height: 396px;]/c/portal/getImageAttachment?filename=fig1.gif&userId=93201[/img] Clearly there is always a hexagon (the green area) in this kind of neighborhood. So forming a regular 3-lattice is as straightforward as doing a simple affine transformation (basically a shearing and a scaling): [img=width: 484px; height: 304px;]/c/portal/getImageAttachment?filename=fig2.gif&userId=93201[/img] So to take advantage of all the power of [b]CellularAutomaton[/b], all we have to do, is to use a following special 6-neighborhood stencil on rectangle lattices, meanwhile our model can be discussed and constructed on regular triangular lattice convieniently: [img=width: 118px; height: 57px;]/c/portal/getImageAttachment?filename=fig3.png&userId=93201[/img] And after the calculation, we can perform the affine transformation with following functions to get a nice hexagonal grid picture. [mcode]Clear[vertexFunc] vertexFunc = Compile[{{para, _Real, 1}}, Module[{center, ratio}, center = para[[1 ;; 2]]; ratio = para[[3]]; {Re[#], Im[#]} + {{1, -(1/2)}, {0, Sqrt[3]/2}}.Reverse[{-1, 1} center + {3, 0}] & /@ (ratio 1/ Sqrt[3] E^(I ?/6) E^(I Range[6] ?/3))], RuntimeAttributes -> {Listable}, Parallelization -> True, RuntimeOptions -> "Speed" (*,CompilationTarget?"C"*)]; Clear[displayfunc] displayfunc[array_, ratio_] := Graphics[{FaceForm[{ColorData["DeepSeaColors"][3]}], EdgeForm[{ColorData["DeepSeaColors"][4]}], Polygon[vertexFunc[Append[#, ratio]] & /@ Position[array, 1]]}, Background -> ColorData["DeepSeaColors"][0]][/mcode] [size=5][b]The Model[/b][/size] To construct the crystallization model, let's consider one of the 6-neighborhood stencil, where each cell represents a minimal crystal unit: [img=width: 261px; height: 236px;]/c/portal/getImageAttachment?filename=fig4.png&userId=93201[/img] A simple model will need only 2 states: [b]0[/b] for "[i]It's empty[/i]", [b]1[/b] for "[i]There is a crystal unit[/i]". So by considering all (except the [b]000000[/b] one, because we are generating ONE snowflake thus don't want a crystall randomly arises from void) [b]6-bit[/b] non-negative numbers, we can have a finite set of possible arrangements of the neighborhood: [mcode]stateSet = Tuples[{0, 1}, 6] // Rest[/mcode] However, from the viewpoint of physics, any two arrangements which can be transformed into each other with only rotation and reflection should be considered as the same arrangement in the sense of their physical effects on the central cell (i.e. cell[size=1]2,2[/size]) are the same: [img=width: 363px; height: 117px;]/c/portal/getImageAttachment?filename=fig5.png&userId=93201[/img] So we should gather [b]stateSet[/b] with above equivalence class: [mcode]gatherTestFunc = Function[lst, Union[Join[ RotateLeft[lst, # - 1] & /@ Flatten[Position[lst, 1]], RotateLeft[Reverse[lst], # - 1] & /@ Flatten[Position[Reverse[lst], 1]] ]]]; stateClsSet = Sort /@ Gather[stateSet, gatherTestFunc[#1] == gatherTestFunc[#2] &]; stateClsSetHomogeneous = ArrayPad[#, {{0, 12 - Length@#}, {0, 0}}] & /@ stateClsSet;[/mcode] Which turned out to be [b]12[/b] classes in total: [img=width: 710px; height: 127px;]/c/portal/getImageAttachment?filename=fig6.png&userId=93201[/img] Now from the viewpoint of cellular automaton, we need to establish a set of rules on how should any 6-neighborhood arrangement, i.e. those 12 kinds of equivalence classes, determine the state of the central cell. There are 4 kinds of possible transformations on cell[size=1]2,2[/size]: [b]0 --> 1[/b] is called [b]frozen[/b], [b]0 --> 0[/b] is [b]remaining empty[/b], [b]1 --> 1[/b] is [b]remaining frozen[/b], and [b]1 --> 0[/b] is called [b]melten[/b]. To make things more interesting and to explore more possibilities, we can introduce probability here, so certain arrangement will give certain probabilities corresponding to the 4 kinds of transformations. But notice that because of the unitarity of probability, we have Prob(frozen) + Prob(0->0) = 1 and Prob(melten) + Prob(1->1) = 1, so only 2 of the 4 probabilities are independent. In the following, we'll choose Prob(frozen) and Prob(melten), and denote them as [b]pFrozen[/b] and [b]pMelten[/b]. [img=width: 800px; height: 367px;]/c/portal/getImageAttachment?filename=fig7.png&userId=93201[/img] Back to physics / thermodynamics, those 24 probabilities, [b]pFrozen[/b] and [b]pMelten[/b], can of corse be determined by serious physical models, or they can be chosen randomly just for fun. For example, an intuitive (and naive) idea would be to believe an empty cell nearby a sharp pointed end or with abundant moisture source will have a high [b]pFrozen[/b]. (People who are interested in the serious physical models should not miss [url=http://psoup.math.wisc.edu/Snowfakes.htm]the Gravner-Griffeath Snowfakes model[/url].) Now we have the grid, the stencil, the neighborhood arrangement set and the transfer probabilities, we're offically ready to construct our cellular automaton rules. Following the above discussion, the construction is straightforward. There are only two points which need to pay attention to. One is to keep in mind that the rule function is applied on the 3x3 stencil, so even cell[size=1]1,1[/size] and cell[size=1]3,3[/size] has nothing to do with our model, don't forget handling them. The second is to use a [b]SeedRandom[/b] function to make sure same arrangement gives same result in same time step, otherwise the 6-fold rotational symmetry and 3 axes of reflection symmetry will both break! [mcode]Clear[ruleFunc] ruleFunc = With[{ stateClsSetHomogeneous = stateClsSetHomogeneous, seedStore = RandomInteger[{0, 1000}, 1000], pFreeze = {1, 0, 0.6, 0, 0.3, 0.15, 0, 0.2, 0, 0.2, 0, 0.8}, pMelt = {0, 0.7, 0.5, 0.7, 0.7, 0.5, 0.3, 0.5, 0.3, 0.2, 0.1, 0 } }, Compile[{{neighborarry, _Integer, 2}, {step, _Integer}}, Module[{cv, neighborlst, cls, rand}, cv = neighborarry[[2, 2]]; neighborlst = {#[[1, 2]], #[[1, 3]], #[[2, 3]], #[[3, 2]], #[[3, 1]], #[[2, 1]]} &[neighborarry]; If[Total[neighborlst] == 0, cv, cls = Position[stateClsSetHomogeneous, neighborlst][[1, 1]]; SeedRandom[seedStore[[step + 1]]]; rand = RandomReal[]; Boole@If[cv == 0, rand < pFreeze[[cls]], rand > pMelt[[cls]]] ]], (*CompilationTarget -> "C",*) RuntimeAttributes -> {Listable}, Parallelization -> True, RuntimeOptions -> "Speed" ] ];[/mcode] (Note: re-compile the rule function [b]ruleFunc[/b] will give a different set of [b]seedStore[/b] thus a different growth path.) Now everything is ready, let's grow a snowflake from the beginning! :D [mcode]dataSet = Module[{ rule, initM = {{ {0, 0, 0}, {0, 1, 0}, {0, 0, 0} }, 0}, rspec = {1, 1}, tmin = 0, tmax = 100, dt = 1}, rule = {ruleFunc, {}, rspec}; CellularAutomaton[rule, initM, {{tmin, tmax, dt}}] ]; // AbsoluteTiming Animate[ Rotate[displayfunc[dataSet[[k]], .8], 90 °], {k, 1, Length[dataSet], 1}, AnimationDirection -> ForwardBackward, AnimationRunning -> False, DisplayAllSteps -> True ][/mcode] [img]/c/portal/getImageAttachment?filename=fig0.gif&userId=93201[/img] [size=5][b]Possible Improvements[/b][/size] We used a [b]SeedRandom[/b] function in our CA rule function to force the 6-fold rotational symmetry and 3 axes of reflection symmetry, and performed the CA calculation on all cells. However, this so called [url=http://demonstrations.wolfram.com/DihedralGroupNOfOrder2n/][i]D[/i][size=1]6[/size] symmetry[/url] can (and should) be integrated into our model, which will saving [b]11/12[/b] of the calculation. Also, the randomness of the growth path comes from [b]seedStore[/b], so to generate a new growth path, we have to re-compile the rule function. But with a improved model as described above, this constraint will no longer exist. [img=width: 800px; height: 177px;]/c/portal/getImageAttachment?filename=fig8.png&userId=93201[/img] [b][size=4] [size=5]Open question [/size] [/size][/b] Can we construct a well-organized structure (like the crystals) from a cellular automaton defined on an [b]irregular[/b] grid? While I believe the answer is [i]yes[/i], the next question would be [i]how?[/i] Silvia Hao 2014-04-11T16:03:33Z https://community.wolfram.com/groups/-/m/t/463721 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4902Hero.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/5838919a-e64d-49fe-9193-c6ce123184f2 Marco Thiel 2015-03-21T01:18:08Z https://community.wolfram.com/groups/-/m/t/2051264 Probably most of you heard the sad news that there was a giant explosion in the port of Beirut today August 3rd 2020. Several videos were released on which we can do analysis. Note that the method I will use was also famously used by G.I. Taylor to find the energy of the Trinity nuclear bomb test, and he found the right amount to within 10%! We will not be so lucky as the video quality was relatively poor as compared to the high-speed imaging done back then. I extracted several frames from one of the videos: ![enter image description here][1] SetDirectory[NotebookDirectory[]]; v1 = Import["1.mp4"]; fra = VideoExtractFrames[v1, Interval[{11, 12}]] fra = ImageRotate[#, Right] & /@ fra; For each of the frames I identified the explosion by clicking 3 point on the circle: data={ {7,{{157.15625,365.20703125000006`},{233.83984375,379.76562500000006`},{272.015625,312.91015625000006`}}}, {8,{{318.16796874999994`,322.81640625000006`},{228.7890625,462.8515625},{103.61328125,393.38281250000006`}}}, {9,{{341.03515625000006`,311.34765625},{308.27734375,478.125},{93.86328125,420.34375}}}, {10,{{359.08984375,315.546875},{351.48828125,478.63671875000006`},{86.55078125,454.5078125}}}, {11,{{375.62109375,325.64453125},{330.05859375,535.3984375},{62.0390625,434.51171875}}}, {12,{{376.0390625,326.765625},{337.94140625,539.9257812499999},{46.4140625,462.55859375}}} }; The first is the index of the frames, the last elements are points of the circle: circs = CircleThrough /@ data[[;; 6, 2]]; r = circs[[All, 2]]; Here is the visualization: Table[HighlightImage[fra[[data[[i, 1]]]], circs[[i]], "Boundary"], {i, Length[data]}] ![enter image description here][2] Notice that I tracked the orange 'glow', not the shockwave or the smoke that was there partially before the main explosion (so on the conservative side and underestimating the energy release). From Google earth I estimated the size of the face of the building on the left (a grain elevator) and found that every pixel corresponds to 0.59 m roughly (~22 meters corresponding to ~37 pixels). cali = 0.5888486673789164`; realr = r cali The timestamps can be found from the video framerate. Information[Import["video.mp4"]]. And so the timestamps are created and the dataset is created: t = (Range[0, Length[realr] - 1]) 1/29.97; tr = Transpose[{t, realr}] Since the explosion started between two frames we include that in the fit (the t0): fit = FindFit[ tr, { a (x + t0)^0.4, 0 < t0 < 1/30}, {{a, 200}, {t0, 1/60}}, x] realfit = a (x + t0)^0.4 /. fit tzero = t0 /. fit realfitshifted = a (x)^0.4 /. fit prefactor = a /. fit The fit can be found [here][3] and is based on dimensional analysis with the variable E (energy), r (radius of the explosion), t (time), and ρ (density). This also explains the exponent 0.4 used for fitting. We plot the data and the fit: Show[{ListPlot[Transpose[{t + tzero, realr}]], Plot[realfitshifted, {x, 0, 0.2}]}, PlotRange -> {{0, 0.2}, {0, 120}}, Frame -> True, FrameLabel -> {"t", "r [m]"}] ![enter image description here][4] Which is a pretty good fit. We can now calculate the energy back from the explosion: ClearAll[r, e, t, \[Rho]] r == (e t^2/\[Rho])^(1/5) Refine[DivideSides[%, t^(2/5)], t > 0] %[[2]] == Quantity[prefactor, "Meters"/"Seconds"^(2/5)] % /. \[Rho] -> Quantity[1, "Kilograms"/"Meters"^3] energy = e /. Solve[%, e][[1]] Yielding: Quantity[4.2808721214488837`*^11, "Joules"] and we can convert it to kiloton of TNT: UnitConvert[energy, "KilotonsOfTNT"] yielding: Quantity[0.102315, "KilotonsOfTNT"] This number is comparable to the 2015 Tianjin explosion (0.3 kilo tonnes of TNT). [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2020-08-04at21.44.20.png&userId=73716 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2020-08-05at12.00.12.png&userId=73716 [3]: https://en.wikipedia.org/wiki/Nuclear_weapon_yield#Calculating_yields_and_controversy [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2020-08-04at21.53.18.png&userId=73716 Sander Huisman 2020-08-04T19:57:48Z https://community.wolfram.com/groups/-/m/t/413906 In discussions with several university physics professors,,,theoreticians...they profess a strong dislike for Mathematica and caution their students about using it. I can fully understand cautioning a user to make sure they have used the correct syntax or correctly formulated a problem or model, but their caution was stronger than that. They, in effect, prefer to roll their own algorithms. They also claim Mathematica gives bad results, though it was unclear whether the fault lay in the execution or the formulation of a problem. I am troubled by this attitude, since users in all technical disciplines use Mathematica and rely on it to supply solutions to various designs, models, and analyses, some that are mission critical. I performed a literature search on evaluation of Mathematica and the most recent published critique and evaluation I found was for Mathematica 5. Other than this, there does not appear to be an undercurrent of suspicion except from these specific profs. What is going on? I can defend my mathematical models but I cannot defend the outcomes of executions of these models if there is skepticism over the validity of solutions obtained by Mathematica. I can also understand that anyone who has not come up on the learning curve might simply be covering their own inadequacies, hence the attitude of rolling their own. However, everyone should be skeptical of published results from the use of personal algorithms, for which no validation or user community exists. How can the quality of the results from the use of Mathmatica be supported? Are there published evaluations? What might some organizations such as DARPA do to validate some work for which Mathematica has been a cornerstone of the analyses? Or am I the only person to have run into this level of skepticism...which is ironic since I am more skeptical of analytical results than most. Luther Nayhm 2014-12-30T15:36:06Z https://community.wolfram.com/groups/-/m/t/595870 ![Ocean currents: from Fukushima and rubbish, to Malaysian airplane MH370][1] In this post I will use data from NASA's ECCO2 project (http://ecco2.jpl.nasa.gov/) to simulate various scenarios: the movement of radioactive particles from the Fukushima nuclear power plant and the accumulation of rubbish in the oceans. I download about 20 years worth of oceanographic data and study how the flow of water might transport particles. A slight modification of the program might be useful to determine the crash site of Malaysian airplane MH370. The work was done with [Bjoern Schelter][2], who is member of this community. We will first download the vector fields for u and v direction. We obtain data for different depth, but I will only use surface currents. We first generate a list of filenames. filenamesU = ("http://ecco2.jpl.nasa.gov/opendap/data1/cube/cube92/lat_lon/quart_90S_90N/UVEL.nc/UVEL.1440x720x50." <> # <> ".nc.ascii?UVEL[0:1:0][0:1:0][0:1:719][0:1:1439]" & /@ (StringJoin[{ToString[#[[1]]], StringTake[StringJoin[ToString /@ PadLeft[{#[[2]]}, 2]], -2], StringTake[StringJoin[ToString /@ PadLeft[{#[[3]]}, 2]], -2]}] & /@ Table[Normal[DatePlus[DateObject[{1992, 1, 2}], 3*n]], {n, 0, 2556}])); filenamesV = ("http://ecco2.jpl.nasa.gov/opendap/data1/cube/cube92/lat_lon/quart_90S_90N/VVEL.nc/VVEL.1440x720x50." <> # <> ".nc.ascii?VVEL[0:1:0][0:1:0][0:1:719][0:1:1439]" & /@ (StringJoin[{ToString[#[[1]]], StringTake[StringJoin[ToString /@ PadLeft[{#[[2]]}, 2]], -2],StringTake[StringJoin[ToString /@ PadLeft[{#[[3]]}, 2]], -2]}] & /@ Table[Normal[DatePlus[DateObject[{1992, 1, 2}], 3*n]], {n, 0, 2556}])); These filenames cover a time interval from the beginning of 1992 to 2012. We then download the actual data (which can take really long): Monitor[For[k = 1, k <= Length[filenamesV], k++, Export["~/Desktop/OceanVelocities/velV" <> ToString[k] <> ".csv", ToExpression[StringSplit[StringSplit[#, "],"][[2]], ","]] & /@ StringSplit[Import[filenamesV[[k]]], "VVEL.VVEL[VVEL.TIME="][[ 2 ;;]] ]], ProgressIndicator[Dynamic[k], {0, Length[filenamesV]}]] and Monitor[For[k = 1, k <= Length[filenamesU], k++, Export["~/Desktop/OceanVelocities/velU" <> ToString[k] <> ".csv", ToExpression[StringSplit[StringSplit[#, "],"][[2]], ","]] & /@ StringSplit[Import[filenamesU[[k]]], "UVEL.UVEL[UVEL.TIME="][[ 2 ;;]] ]], ProgressIndicator[Dynamic[k], {0, Length[filenamesU]}]] This will download about 16GB worth of data. You will, however, get reasonable results if you only use 30 frames, i.e. if you substitute Length[filenamesU] and Length[filenamesV] by 30. We will now create a figure for the first frame. velV1 = Import["~/Desktop/OceanVelocities/velV1.csv"]; velU1 = Import["~/Desktop/OceanVelocities/velU1.csv"]; We can now generate the velocity vectors for each point on the surface of the earth veltot = Table[{velU1[[i, j]], velV1[[i, j]]}, {i, 1, 720}, {j, 1, 1440}]; and then clean the data veltot2 = Table[If[((StringQ[#[[1]]] || StringQ[#[[2]]]) & /@ {veltot[[i, j]] })[[1]], {0., 0.}, {velU1[[i, j]], velV1[[i, j]]}], {i, 1, 720}, {j, 1, 1440}]; We can also calculate the speed at each point. veltottot = Table[If[((StringQ[#[[1]]] || StringQ[#[[2]]]) & /@ {veltot[[i, j]] })[[1]], 0., Norm[{velU1[[i, j]], velV1[[i, j]]}]], {i, 1, 720}, {j, 1, 1440}]; This next function will produce a visualisation of the speed profile for the first frame. Show[ArrayPlot[Reverse[veltottot], PlotLegends -> Automatic, ImageSize -> Full, ColorFunction -> "TemperatureMap"], ListVectorPlot[Transpose[veltot2], VectorPoints -> 50]] ![enter image description here][3] Note the incredible fine-structure in that image. We could now produce an animation for all frames. This will, however, be too large for the memory of most computers, so I would not execute it. If you only use the first 30 frames you get a reasonable idea of its working. framesflow = {}; Monitor[ For[k = 1, k <= Length[filenamesU], k++, velU1 = Import["~/Desktop/velU" <> ToString[k] <> ".csv"]; velV1 = Import["~/Desktop/velV" <> ToString[k] <> ".csv"]; veltot = Table[{velU1[[i, j]], velV1[[i, j]]}, {i, 1, 720}, {j, 1, 1440}]; AppendTo[framesflow, ArrayPlot[Reverse[Table[If[((StringQ[#[[1]]] || StringQ[#[[2]]]) & /@ {veltot[[i,j]] })[[1]], 0., Norm[{velU1[[i, j]], velV1[[i, j]]}]], {i, 1, 720}, {j, 1, 1440}]], PlotLegends -> Automatic, ImageSize -> Full, ColorFunction -> "TemperatureMap"]]], k]; This following command exports all the frames as individual gif files, which can later be combined into a gif animation. Monitor[For[k = 1, k <= Length[filenamesU], k++, velU1 = Import[ "~/Desktop/OceanVelocities/velU" <> ToString[k] <> ".csv"]; velV1 = Import[ "~/Desktop/OceanVelocities/velV" <> ToString[k] <> ".csv"]; veltot = Table[{velU1[[i, j]], velV1[[i, j]]}, {i, 1, 720}, {j, 1, 1440}]; Export["~/Desktop/MovieOut/frame" <> ToString[1000 + k] <> ".gif", ArrayPlot[Reverse[Table[If[((StringQ[#[[1]]] || StringQ[#[[2]]]) & /@ {veltot[[i,j]] })[[1]], 0., Norm[{velU1[[i, j]], velV1[[i, j]]}]], {i, 1, 720}, {j, 1, 1440}]], PlotLegends -> None, ImageSize -> {1440, 730}, ColorFunction -> "TemperatureMap"]]], k]; Another advantage of saving the frames is that we can use them as background for various scenarios and thereby decrease our computation time substantially. Here is a short animation of the first couple of frames. ![enter image description here][4] Now we get the trajectories of radioactive particles that are released into the ocean at the approximate site of the Fukushima power plant. We make the assumption that the particles simply follow the flow. Also, we use the vectorfield starting on 2nd January 1992. The overall patterns of the ocean currents seem to be reasonably stable over the years so that for this conceptual study this assumption will have to suffice. It is of course easy to adapt to the actual date. We first need to introduce a formula to convert the data grid to the surface of the earth. ClearAll["Global`*"]; f[teta_, r_, vx_, vy_] := {vx/(r*Sin[2*Pi*teta/4./360.]*2*Pi/360/4)*24*3600, vy/(N[r*2*Pi/360/4])*24*3600}; teta = 1; r = 6360000; We now place 20000 particle into the see close to the location of Fukushima. We add a small random number to the position to model a "cloud" of particles. teilreinpos = Table[{3, 511 + RandomVariate[NormalDistribution[0., 1.]], 568 + RandomVariate[NormalDistribution[0., 1.]]}, {m, 1, 20000}]; This is the main part of the program. We use the velocity to update the position of the particles. We then use the back-ground frames generated above and overlay the particle positions. trajectories = {teilreinpos}; Monitor[Do[ velVt = Table[ If[StringQ[#], 0.1*(ToExpression[#[[ 3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velV" <> ToString[k] <> ".csv", "CSV"], {k, i - 2, i + 2}]; velUt = Table[If[StringQ[#], 0.1*(ToExpression[#[[ 3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velU" <> ToString[k] <> ".csv", "CSV"], {k, i - 2, i + 2}]; xfunc = ListInterpolation[velUt, {{1, 5}, {0, 720}, {0, 1440}}]; yfunc = ListInterpolation[velVt, {{1, 5}, {0, 720}, {0, 1440}}]; AppendTo[trajectories, Nest[({#[[1]], Mod[#[[2]], 720], Mod[#[[3]], 1440]}) & /@ (# + {0.1, 0.1*f[#[[2]], r, xfunc[#[[1]] - i + 3., #[[2]], #[[3]]], yfunc[#[[1]] - i + 3., #[[2]], #[[3]]]][[2]] , 0.1*f[#[[2]], r, xfunc[#[[1]] - i + 3., #[[2]], #[[3]]], yfunc[#[[1]] - i + 3., #[[2]], #[[3]]]][[1]] } &) , # , 10] & /@ trajectories[[-1]]]; Export["~/Desktop/OilSpillFrames/frame" <> ToString[1000 + i] <> ".gif", Show[ Import["~/Desktop/MovieOut/frame" <> ToString[1000 + i] <> ".gif"], Graphics[{Red, Disk[#, 1]} & /@ (0.9361111 # + {44., 28.} & /@ trajectories[[i - 2, All, {3, 2}]]), PlotRange -> {{0, 1440}, {0, 720}}]]]; , {i, 3, 1238}], i]; Here are a couple of frames: ![enter image description here][5] All frames yield the following animation. ![enter image description here][6] Also see the higher quality animation on Youtube. [https://youtu.be/8icgMg6lt0Y][7] Similarly we can study where rubbish, such as plastic bags would accumulate in the oceans due to the currents; these are also called [gyres of marine debris particles][8]. See also [this link][9]. We start out just like for the Fukushima simulation: ClearAll["Global`*"]; f[teta_, r_, vx_, vy_] := {vx/(r*Sin[2*Pi*teta/4./360.]*2*Pi/360/4)*24*3600, vy/(N[r*2*Pi/360/4])*24*3600}; teta = 1; r = 6360000; In this case we have to distribute the particles randomly in all oceans. So I will basically distribute them everywhere and then ingore the ones over land mass, by checking whether the background flow speed is zero. So we first calculate the speed. velVt = Table[ If[StringQ[#], 0.1*(ToExpression[#[[3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velV" <> ToString[k] <> ".csv", "CSV"], {k, 3 - 2, 3 + 2}]; velUt = Table[ If[StringQ[#], 0.1*(ToExpression[#[[3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velU" <> ToString[k] <> ".csv", "CSV"], {k, 3 - 2, 3 + 2}]; xfunc = ListInterpolation[velUt, {{1, 5}, {0, 720}, {0, 1440}}]; yfunc = ListInterpolation[velVt, {{1, 5}, {0, 720}, {0, 1440}}]; We then distribute the particles everywhere teilreinpospre = Table[{3, RandomReal[{0, 720}], RandomReal[{0, 1440}]}, {k, 1, 30000}]; and delete the particles with zero-speed-background. teilreinpos = Select[teilreinpospre, xfunc[3, #[[2]], #[[3]]] != 0. && yfunc[3, #[[2]], #[[3]]] != 0. &]; Now we iterate as before. trajectories = {teilreinpos}; Monitor[Do[ velVt = Table[ If[StringQ[#], 0.1*(ToExpression[#[[ 3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velV" <> ToString[k] <> ".csv", "CSV"], {k, i - 2, i + 2}]; velUt = Table[If[StringQ[#], 0.1*(ToExpression[#[[ 3]]]*10^(ToExpression[#[[1]]]) ) & /@ { StringSplit[#, {" ", "*"}]}, 1.*#] & /@ # & /@ Import["~/Desktop/OceanVelocities/velU" <> ToString[k] <> ".csv", "CSV"], {k, i - 2, i + 2}]; xfunc = ListInterpolation[velUt, {{1, 5}, {0, 720}, {0, 1440}}]; yfunc = ListInterpolation[velVt, {{1, 5}, {0, 720}, {0, 1440}}]; AppendTo[trajectories, Nest[({#[[1]], Mod[#[[2]], 720], Mod[#[[3]], 1440]}) & /@ (# + {0.1, RandomVariate[NormalDistribution[0., 0.05]] + 0.1*f[#[[2]], r, xfunc[#[[1]] - i + 3., #[[2]], #[[3]]], yfunc[#[[1]] - i + 3., #[[2]], #[[3]]]][[2]] , RandomVariate[NormalDistribution[0., 0.05]] + 0.1*f[#[[2]], r, xfunc[#[[1]] - i + 3., #[[2]], #[[3]]], yfunc[#[[1]] - i + 3., #[[2]], #[[3]]]][[ 1]] } &) , # , 10] & /@ trajectories[[-1]]]; Export["~/Desktop/Rubbish/frame" <> ToString[1000 + i] <> ".gif", Show[Import[ "~/Desktop/MovieOut/frame" <> ToString[1000 + i] <> ".gif"], Graphics[{Red, Disk[#, 1]} & /@ (0.9361111 # + {44., 28.} & /@ trajectories[[i - 2, All, {3, 2}]]), PlotRange -> {{0, 1440}, {0, 720}}]]]; , {i, 3, 1238}], i]; Here are some frames: ![enter image description here][10] This leads to the following animation (due to file size I only show a later part of the simulation). ![enter image description here][10] Please have a look at the [higher resolution and longer animation on Youtube][11]. It becomes clear that there are 5 large areas of rubbish in the oceans. This and their approximate positions are in accordance with their known positions and satellite data. This type of simulation is very much simplified. We are making many assumptions, but by using the "observed" velocity field, we get around the fluid mechanical problems usually involved in these problems. The main idea can be used for many other problems as well. For example, we could iterate backwards to see where particles came from. So I challenge you to simulate the following. Several fragments of the crashed Malaysian airplane have been found. Can you use the flow, invert the time direction and simulate where the parts must have come from? I wonder whether you can make better assmumptions than me (the larger fragments drift differently in the currents), and whether your point of origin correponds to mine. I would love to hear back from you, and get ideas of how to apply this. I had a previous discussion with Vitaliy Kaurov about this, and there are certainly much nicer ways of representing the results. Any ideas are welcome. Cheers, Marco [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Rubbish-final-optimize.gif&userId=20103 [2]: http://community.wolfram.com/web/bschelter [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2015-10-24at01.21.46.png&userId=48754 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=VelocityField.gif&userId=48754 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2015-10-24at01.28.35.png&userId=48754 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Fukushima-ok.gif&userId=48754 [7]: https://youtu.be/8icgMg6lt0Y [8]: https://en.wikipedia.org/wiki/Great_Pacific_garbage_patch [9]: https://en.wikipedia.org/wiki/File:Garbage_Patch_Visualization_Experiment.webm [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2015-10-24at01.36.47.png&userId=48754 [11]: https://youtu.be/ttJPAIBch8U Marco Thiel 2015-10-24T00:43:19Z https://community.wolfram.com/groups/-/m/t/2448552 ![enter image description here][1] ![enter image description here][2] A new study group devoted to [Quantum Computation Framework][3] begins Monday Jan 24th! A list of daily topics can be found on our Daily Study Groups page. This group will be led by me and few other developers from Wolfram Quantum Team. We will meet daily, Monday to Friday. Study group sessions include time for exercises, discussion and Q&A. This study group will help you acquire an intro knowledge of quantum computing and learn how to implement quantum algorithms in the [Wolfram Quantum Computation Framework][4]. Feel free to explore [our framework][5]. Sign up: [Study group registration page][6] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2022-01-17at3.53.39PM.png&userId=1539902 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=FrontImage.jpeg&userId=1539902 [3]: https://www.bigmarker.com/series/daily-study-group-quantum-computation-framework/series_details?utm_bmcr_source=wolfram-u [4]: https://www.wolframcloud.com/obj/wolframquantumframework/DeployedResources/Paclet/Wolfram/QuantumFramework/ [5]: https://www.wolframcloud.com/obj/wolframquantumframework/DeployedResources/Paclet/Wolfram/QuantumFramework/ [6]: https://www.bigmarker.com/series/daily-study-group-quantum-computation-framework/series_details?utm_bmcr_source=community Mohammad Bahrami 2022-01-17T18:20:25Z https://community.wolfram.com/groups/-/m/t/121507 [b]With 5 point-source lights in a square room, what is the optimal configuration for even lighting?[/b] To make this question concrete, say that each wall has length 1, the room has no height (i.e., two dimensional) and we have five identical lights that are pointsized and want to know the optimal placement that maximizes even lighting.  That could mean [mcode]f = 1/((x - x1)^2 + (y - y1)^2) + 1/((x - x2)^2 + (y - y2)^2) + 1/((x - x3)^2 + (y - y3)^2) + 1/((x - x4)^2 + (y - y4)^2) + 1/((x - x5)^2 + (y - y5)^2);[/mcode] a) maximizing the value of the minimal illumination [mcode]Minimize[f, {x,0,1},{y,0,1}][/mcode]or an integral measure like b) maximizing the total illumination where the brightest areas are considered as being some default value, e.g., the value of [mcode]Integrate[Min[f, f0], {x,0,1},{y,0,1}][/mcode] For an example configuration of light sources with [mcode]f = With[{n = 5}, Sum[1/((x - (.5 + .45 Cos[2 Pi i/n]))^2 + (y - (.5 + .45 Sin[2 Pi i/n]))^2), {i, 0, n - 1}]] [/mcode]and then here is the minimum illumination [mcode]NMinimize[{f, 0 <= x <= 1 && 0 <= y <= 1}, {x, y}] (*{14.349, {x -> 1., y -> 1.}}*) [/mcode]and here that point is shown on a contour plot [img=width: 360px; height: 359px;]/c/portal/getImageAttachment?filename=lights5.jpg&userId=23275[/img] For that configuration here is the integral (which I had to approximate with a Sum) [mcode]Sum[Min[1.2 (14.349), f], {x, 0.0001, 1, .01}, {y, 0.0001, 1, .01}]/10^4 (*17.2146*) [/mcode]I'd be interested in optimization approaches, but also aesthetic approaches, e.g., symmetries, angles, shadows, or patterns made by contour lines. To generalize, not only other numbers of lights, but try tacking on albedo of 50% so the wall reflect half of the light they receive. Todd Rowland 2013-09-10T16:45:23Z https://community.wolfram.com/groups/-/m/t/1433064 ![fig7][331] I started the discussion [here][1] but I also want to repeat on this forum. There are many commercial and open code for solving the problems of unsteady flows. We are interested in the possibility of solving these problems using Mathematica FEM. Previously proposed solvers for stationary incompressible isothermal flows: Solving 2D Incompressible Flows using Finite Elements: http://community.wolfram.com/groups/-/m/t/610335 FEM Solver for Navier-Stokes equations in 2D: http://community.wolfram.com/groups/-/m/t/611304 Nonlinear FEM Solver for Navier-Stokes equations in 2D: https://mathematica.stackexchange.com/questions/94914/nonlinear-fem-solver-for-navier-stokes-equations-in-2d/96579#96579 We give several examples of the successful application of the finite element method for solving unsteady problem including nonisothermal and compressible flows. We will begin with two standard tests that were proposed to solve this class of problems by M. Schäfer and S. Turek, Benchmark computations of laminar ?ow around a cylinder (With support by F. Durst, E. Krause and R. Rannacher). In E. Hirschel, editor, Flow Simulation with High-Performance Computers II. DFG priority research program results 1993-1995, number 52 in Notes Numer. Fluid Mech., pp.547–566. Vieweg, Weisbaden, 1996. https://www.uio.no/studier/emner/matnat/math/MEK4300/v14/undervisningsmateriale/schaeferturek1996.pdf ![fig8][332] Let us consider the flow in a flat channel around a cylinder at Reynolds number = 100, when self-oscillations occur leading to the detachment of vortices in the aft part of cylinder. In this problem it is necessary to calculate drag coe?cient, lift coe?cient and pressure di?erence in the frontal and aft part of the cylinder as functions of time, maximum drag coe?cient, maximum lift coe?cient , Strouhal number and pressure di?erence $\Delta P(t)$ at $t = t0 +1/2f$. The frequency f is determined by the period of oscillations of lift coe?cient f=f(c_L). The data for this test, the code and the results are shown below. H = .41; L = 2.2; {x0, y0, r0} = {1/5, 1/5, 1/20}; ? = RegionDifference[Rectangle[{0, 0}, {L, H}], Disk[{x0, y0}, r0]]; RegionPlot[?, AspectRatio -> Automatic] K = 2000; Um = 1.5; ? = 10^-3; t0 = .004; U0[y_, t_] := 4*Um*y/H*(1 - y/H) UX[0][x_, y_] := 0; VY[0][x_, y_] := 0; P0[0][x_, y_] := 0; Do[ {UX[i], VY[i], P0[i]} = NDSolveValue[{{Inactive[ Div][({{-?, 0}, {0, -?}}.Inactive[Grad][ u[x, y], {x, y}]), {x, y}] + \!\(\*SuperscriptBox[\(p\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x, y] + (u[x, y] - UX[i - 1][x, y])/t0 + UX[i - 1][x, y]*D[u[x, y], x] + VY[i - 1][x, y]*D[u[x, y], y], Inactive[ Div][({{-?, 0}, {0, -?}}.Inactive[Grad][ v[x, y], {x, y}]), {x, y}] + \!\(\*SuperscriptBox[\(p\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x, y] + (v[x, y] - VY[i - 1][x, y])/t0 + UX[i - 1][x, y]*D[v[x, y], x] + VY[i - 1][x, y]*D[v[x, y], y], \!\(\*SuperscriptBox[\(u\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x, y] + \!\(\*SuperscriptBox[\(v\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x, y]} == {0, 0, 0} /. ? -> ?, { DirichletCondition[{u[x, y] == U0[y, i*t0], v[x, y] == 0}, x == 0.], DirichletCondition[{u[x, y] == 0., v[x, y] == 0.}, 0 <= x <= L && y == 0 || y == H], DirichletCondition[{u[x, y] == 0, v[x, y] == 0}, (x - x0)^2 + (y - y0)^2 == r0^2], DirichletCondition[p[x, y] == P0[i - 1][x, y], x == L]}}, {u, v, p}, {x, y} ? ?, Method -> {"FiniteElement", "InterpolationOrder" -> {u -> 2, v -> 2, p -> 1}, "MeshOptions" -> {"MaxCellMeasure" -> 0.001}}], {i, 1, K}]; {ContourPlot[UX[K/2][x, y], {x, y} ? ?, AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow", FrameLabel -> {x, y}, PlotLegends -> Automatic, Contours -> 20, PlotPoints -> 25, PlotLabel -> u, MaxRecursion -> 2], ContourPlot[VY[K/2][x, y], {x, y} ? ?, AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow", FrameLabel -> {x, y}, PlotLegends -> Automatic, Contours -> 20, PlotPoints -> 25, PlotLabel -> v, MaxRecursion -> 2, PlotRange -> All]} // Quiet {DensityPlot[UX[K][x, y], {x, y} ? ?, AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow", FrameLabel -> {x, y}, PlotLegends -> Automatic, PlotPoints -> 25, PlotLabel -> u, MaxRecursion -> 2], DensityPlot[VY[K][x, y], {x, y} ? ?, AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow", FrameLabel -> {x, y}, PlotLegends -> Automatic, PlotPoints -> 25, PlotLabel -> v, MaxRecursion -> 2, PlotRange -> All]} // Quiet dPl = Interpolation[ Table[{i*t0, (P0[i][.15, .2] - P0[i][.25, .2])}, {i, 0, K, 1}]]; cD = Table[{t0*i, NIntegrate[(-?*(-Sin[?] (Sin[?] \!\(\*SuperscriptBox[\(UX[i]\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]] + Cos[?] \!\(\*SuperscriptBox[\(UX[i]\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]]) + Cos[?] (Sin[?] \!\(\*SuperscriptBox[\(VY[i]\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]] + Cos[?] \!\(\*SuperscriptBox[\(VY[i]\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]]))*Sin[?] - P0[i][x0 + r Cos[?], y0 + r Sin[?]]* Cos[?]) /. {r -> r0}, {?, 0, 2*Pi}]}, {i, 1000, 2000}]; // Quiet cL = Table[{t0*i, -NIntegrate[(-?*(-Sin[?] (Sin[?] \!\(\*SuperscriptBox[\(UX[i]\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]] + Cos[?] \!\(\*SuperscriptBox[\(UX[i]\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]]) + Cos[?] (Sin[?] \!\(\*SuperscriptBox[\(VY[i]\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]] + Cos[?] \!\(\*SuperscriptBox[\(VY[i]\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]]))*Cos[?] + P0[i][x0 + r Cos[?], y0 + r Sin[?]]* Sin[?]) /. {r -> r0}, {?, 0, 2*Pi}]}, {i, 1000, 2000}]; // Quiet {ListLinePlot[cD, AxesLabel -> {"t", "\!\(\*SubscriptBox[\(c\), \(D\)]\)"}], ListLinePlot[cL, AxesLabel -> {"t", "\!\(\*SubscriptBox[\(c\), \(L\)]\)"}], Plot[dPl[x], {x, 0, 8}, AxesLabel -> {"t", "?P"}]} f002 = FindFit[cL, a*.5 + b*.8*Sin[k*16*t + c*1.], {a, b, k, c}, t] Plot[Evaluate[a*.5 + b*.8*Sin[k*16*t + c*1.] /. f002], {t, 4, 8}, Epilog -> Map[Point, cL]] k0=k/.f002; Struhalnumber = .1*16*k0/2/Pi cLm = MaximalBy[cL, Last] sol = {Max[cD[[All, 2]]], Max[cL[[All, 2]]], Struhalnumber, dPl[cLm[[1, 1]] + Pi/(16*k0)]} In Fig. 1 shows the components of the flow velocity and the required coefficients. Our solution of the problem and what is required in the test {3.17805, 1.03297, 0.266606, 2.60427} lowerbound= { 3.2200, 0.9900, 0.2950, 2.4600}; upperbound = {3.2400, 1.0100, 0.3050, 2.5000}; ![Fig1][2] Note that our results differ from allowable by several percent, but if you look at all the results of Table 4 from the cited article, then the agreement is quite acceptable.The worst prediction is for the Strouhal number. We note that we use the explicit Euler method, which gives an underestimate of the Strouhal number, as follows from the data in Table 4. The next test differs from the previous one in that the input speed varies according to the `U0[y_, t_] := 4*Um*y/H*(1 - y/H)*Sin[Pi*t/8]`. It is necessary to determine the time dependence of the drag and lift parameters for a half-period of oscillation, as well as the pressure drop at the last moment of time. In Fig. 2 shows the components of the flow velocity and the required coefficients. Our solution of the problem and what is required in the test sol = {3.0438934441256595`, 0.5073345082785012`, -0.11152933279750943`}; lowerbound = {2.9300, 0.4700, -0.1150}; upperbound = {2.9700, 0.4900, -0.1050}; ![Fig2][3] For this test, the agreement with the data in Table 5 is good. Consequently, the two tests are almost completely passed. I wrote and debugged this code using Mathematics 11.01. But when I ran this code using Mathematics 11.3, I got strange pictures, for example, the disk is represented as a hexagon, the size of the area is changed. ![Fig3][4] In addition, the numerical solution of the problem has changed, for example, test 2D2 {3.17805, 1.03297, 0.266606, 2.60427} v11.01 {3.15711, 1.11377, 0.266043, 2.54356} v11.03 The attached file contains the working code for test 2D3 describing the flow around the cylinder in a flat channel with a change in the flow velocity. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=test2D2.png&userId=1218692 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=test2D2.png&userId=1218692 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=test2D3.png&userId=1218692 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Math11.3.png&userId=1218692 [331]: http://community.wolfram.com//c/portal/getImageAttachment?filename=CylinderRe100test2D2.gif&userId=1218692 [332]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2D2test.png&userId=1218692 Alexander Trounev 2018-08-31T11:44:04Z https://community.wolfram.com/groups/-/m/t/2399430 *SUPPLEMENTARY WOLFRAM MATERIALS for the ARTICLE:* > Sergio Manzetti, Alexander Trounev (2021). > A Navier-Stokes model for Rogue wave simulation. > ResearchGate, Technical Report. https://www.researchgate.net/publication/354527324 ------ ![enter image description here][1] ABSTRACT -------------------------------------- Rogue waves are anomalous phenomena occurring over large sea bodies, where they are said appear out of nowhere and disappear without a trace. Simulations of rogue waves have been carried over the last 40 years, with several models published. In this paper we investigate the formation of rogue waves by two models: I. the Navier-Stokes equation where we take into account density and viscosity gradient on the air-water interface due to diffusion and II. a Korteveg de Vries-type model for quantum jumps which we developed earlier. We derive also a stable fluids algorithm which we use to compute nonlinear waves interaction produced by the wind. The results are discussed and compared. This code solves problem of viscous incompressible flow with gravitational force in a rectangle with periodic boundary condition on the left and right side and with Dirichlet condition on the top and bottom side. In the initial condition fluid velocity is periodic wave, and density has unit step like distribution on the air/water interface. Some other application of this code has been discussed on https://mathematica.stackexchange.com/questions/246091/stable-fluids-code-for-electromagnetic-mixture-application This model has been discussed in our report [A Navier-Stokes model for Rogue wave simulation][2] Two phase model of air-water interface -------------------------------------- Let us consider the system of equations describing nonlinear waves on the air-water interface. As it well known the air and the water can be considered as viscous incompressible fluids with density $\rho_a, \rho_w$, and dynamical viscosity $\mu_a, \mu_w$ consequently. Taking into account the gravity force and diffusion on the air-water interface, we have $$\nabla.\bf{u}=0\\ \frac{\partial \mathbf{u}}{\partial t}+(\mathbf{u}.\nabla)\mathbf{u}+\frac{\nabla P}{\rho_i}=\nu_i\nabla ^2\mathbf{u}+\mathbf{f}\\\ \frac{\partial \phi}{\partial t} +(\mathbf{u}.\nabla)\phi=\frac{\nu_i}{Sc_i}\nabla ^2\phi\\ $$ Here it is indicated $\rho_i, i=a,w $ - air and water density, $\mathbf{u}=(u_x,u_y)$ - flow velocity, $P$ - pressure; $\bf{f}$ - force acting on the volume of the air-water mixture; $\phi$ - the interface function describing the averaged density of the air-water mixture; $Sc_i$ - analog of the Schmidt number characterized water diffusion in the air and air diffusion in the water. Note that we considered averaged effect of mass transfer on the air-water interface including drops and bubbles. Let us define the Cartesian coordinate system so that the $y$ axis is directed against the direction of the gravitational acceleration vector and the $x$ axis is parallel to horizon. Let suppose that the water surface relief is described by the equation $y=r(t,x,y)$ - Figure 1. ![Figure 1. Flow geometry on the air-water interface with waves of small (left) and large (right) amplitude][3] We set the boundary conditions for the flow parameters on the top and bottom part of the boundary layer and periodic boundary conditions by coordinate $x$ as follows: $$ y=0: \mathbf{u}=0,\phi=\rho_w\\ y=H: \mathbf{u}=(U_0,0), \phi=\rho_a\\ \mathbf{u}(t,0,y)=\mathbf{u}(t,L,y)\\ \phi(t,0,y)=\phi(t,L,y). $$ Here $H$ is the height of the boundary layer,$U_0$ is the wind velocity, $L$ is the period of the wave tray. We assume that at the initial time the flow velocity and interface function are given by $$ t=0, y<H/2:u_x = 0, u_y=V_0 \sin(2 \pi n x/L), \phi =\rho_w\\ t=0, y\ge H/2: u_x=U_0, u_y=V_0\sin (2 \pi n x/L), \phi =\rho_a\\ $$ This problem can be solved with using numerical methods and an appropriate turbulence model. We have used stable fluids algorithm (Stam1999, Stam 2000) to solve 2D Navier-Stokes equations and to simulate nonlinear waves interaction on the air-water interface with a given wind velocity on the top of the boundary layer. While in the standard gravity wave theory the air-water interface is considered mainly as a potential flow, in our approach we take into account velocity, viscosity and density gradients on the interface. Since air/water density ratio is about $10^{-3}$ we have some challenging numerical problem. To solve this problem we made some simplifications in the basic Navier-Stokes equations. First, we suppose that velocity is a continues field at $t>0$ so that flow in the water and flow in the air is an united flow continuously distributed from the bottom to the top and the periodic one in the $x$ direction. We neglect by the surface tension due to large scale of the waves. Therefore we don't need any boundary condition on the air-water interface. Second, at $t>0$ we introduce continues density as $\rho=\phi$ to compute velocity field on every step. Third, we use stable fluid algorithm in time in the very specific order described below. Stable fluids algorithm ----------------------- 1) Solve advection equation with using boundary conditions, initial data from the previous step, and an implicit algorithm $$ \frac{\partial \mathbf{u}_1}{\partial t}+(\mathbf{u}_1.\nabla) \bf{u}_1=0 $$ 2) Solve diffusion equation with $\nu_i=\nu_i(\phi)$, initial data $\mathbf{u}_1$, boundary conditions and with using, for example, Gauss-Seidel relaxation algorithm $$ \frac{\partial \mathbf {u}_2}{\partial t}-\nu_i \nabla^2 \mathbf{u}_2=0$$ here $$\nu_i(\phi)=\nu_w \phi ^k, k=-0.4029$$ for the air temperature of 20C. 3) Add force to the velocity field from the previous step as follows $$ \mathbf{u}_3=\mathbf{u}_2+\mathbf{f} dt\\ $$ To simulate force acting on the volume of air-water mixture we used approximation $$ f_y=-\frac{(\rho_w-\phi)(\phi-\rho_w/2)(\phi-\rho_a)}{\rho_w^2(\rho_w-\rho_a)Fr^2} $$ 4) Make projection step. Here we can use two models. First model is standard projection (Stam 1999) by solving Poison equation $$ t>0, \nabla^2 q=\nabla . \bf{u}_3\\ \bf{u}_4=\bf{u}_3-\nabla q $$ Note, that this step allows us to define divergent free velocity field. 5) Update velocity field $\bf{u}_4\longrightarrow \bf{u}_5$ with using boundary conditions. 6) Make diffusion step with interface function by solving diffusion equation with initial condition from the previous step, with boundary conditions, and with $\nu=\nu_i(\phi)/Sc$ as follows $$ \frac{\partial \phi_1}{\partial t}-\nu \nabla^2 \phi_1=0 $$ 7) Make advection step by solving advection equation with initial data from step 6 with boundary conditions using an implicit algorithm (from step 1, for example), $$ \frac{\partial \phi_2}{\partial t}+(\bf{u}_5.\nabla) \phi_2=0 $$ 8) Update interface function with boundary conditions. 9) Return to step 1 with updated velocity and interface function. This algorithm can be also used in some different order, for example, in the beginning we can compute step 3 (Stam1999). Also we can make steps 6-8 first, and then compute velocity field with steps 1-5. The question about stability of the stable fluids algorithm not really solved yet. From our experience, we can't do arbitrary time step, but $dt$ is limiting by the grid size as usual for more precise computation. In our computations we have used $dt=2/N$ for $N\times N$ grid. In general case the numerical solution depends on the Froude number $Fr=\frac{U_0}{\sqrt{g L}}$, Reynolds number $Re=\frac{U_0 L}{\nu_w}$, Schmidt number and number of waves in the initial data. In our computations we fixed the Froude number, so that we can put $H=L=1$. We also fixed the Reynolds number, therefore we can put $U_0=1.5, V_0=0.5$. The algorithm 1-9 has been implemented with FDM and compiled to C with using Mathematica 12.3. Code to simulate air/water interface with $Re=10^4, Fr=1$ ---- rhoWater20C = 1.027; nuW20C = 0.01007; rhoAir20C = 0.001204; nuA20C = 0.151;dif = 1/10000; pec = .1; U0 = 1.5; V0 = .5; dn0 = 0.997658; dn1 = 0.514102; kap = 1; n = 81; Fr = 1; F0 = 1; n1 = n + 1; sm = 600; r = 20; den = ConstantArray[dn1 (1 + dn0 Tanh[-kap Range[-n1/2, n1/2]]), n1];u0 = ConstantArray[0, {n1, n1}]; Do[ u0[[i, j]] = U0 (1 + Tanh[kap (j - n1/2)])/2;, {i, n1}, {j, n1}]; v0 = ConstantArray[0., {n1, n1}]; Do[ v0[[i, j]] = V0 Sin[10 Pi (i - 1)/n];, {i, n1}, {j, n1}];periodic[n_, up_, ud_, ub_] := Module[{bd = ub}, Do[bd[[1, i]] = .5 (bd[[n, i]] + bd[[2, i]]); bd[[n + 1, i]] = bd[[1, i]]; bd[[i, 1]] = ud; bd[[i, n + 1]] = up;, {i, 2, n}]; bd[[1, 1]] = .5 (bd[[2, 1]] + bd[[1, 2]]); bd[[n + 1, n + 1]] = .5 (bd[[n, n + 1]] + bd[[n + 1, n]]); bd[[n + 1, 1]] = .5 (bd[[n, 1]] + bd[[n + 1, 2]]); bd[[1, n + 1]] = .5 (bd[[1, n]] + bd[[2, n + 1]]); bd]; diffuse[n_, r_, a_, c_, c0_] := Module[{c1 = c}, Do[Do[Do[ c1[[i, j]] = (c0[[i, j]] + (a/den[[i, j]]^.4029) (c1[[i - 1, j]] + c1[[i + 1, j]] + c1[[i, j - 1]] + c1[[i, j + 1]]))/(1 + 4 a/den[[i, j]]^.4029);, {j, 2, n}];, {i, 2, n}]; Do[c1[[1, i]] = c1[[n, i]]; c1[[n + 1, i]] = c1[[2, i]]; c1[[i, 1]] = c0[[i, 1]]; c1[[i, n + 1]] = c0[[i, n + 1]];, {i, 2, n}]; c1[[1, 1]] = .5 (c1[[2, 1]] + c1[[1, 2]]); c1[[n + 1, n + 1]] = .5 (c1[[n, n + 1]] + c1[[n + 1, n]]); c1[[n + 1, 1]] = .5 (c1[[n, 1]] + c1[[n + 1, 2]]); c1[[1, n + 1]] = .5 (c1[[1, n]] + c1[[2, n + 1]]);, {k, 0, r}]; c1]; advect[n_, d0_, u_, v_, dt_] := Module[{x, y, d1, dt0, i0, i1, j0, j1, s0, s1, t0, t1}, d1 = ConstantArray[0, {n + 1, n + 1}]; dt0 = dt n; Do[Do[x = i - dt0 u[[i, j]]; y = j - dt0 v[[i, j]]; i0 = Which[x <= 1, 1, 1 < x < n, Floor[x], True, n]; i1 = i0 + 1; j0 = Which[y <= 1, 1, 1 < y < n, Floor[y], True, n]; j1 = j0 + 1; s1 = x - i0; s0 = 1 - s1; t1 = y - j0; t0 = 1 - t1; d1[[i, j]] = s0 (t0 d0[[i0, j0]] + t1 d0[[i0, j1]]) + s1 (t0 d0[[i1, j0]] + t1 d0[[i1, j1]]);, {j, 1, n + 1}];, {i, 1, n + 1}]; d1]; project[n_, r_, u0_, v0_, u_, v_] := Module[{ux = u, vy = v, div, p}, p = ConstantArray[0, {n + 1, n + 1}]; div = ConstantArray[0, {n + 1, n + 1}]; ux = ConstantArray[0, {n + 1, n + 1}]; vy = ConstantArray[0, {n + 1, n + 1}]; Do[div[[i, j]] = -.5/ n (u0[[i + 1, j]] - u0[[i - 1, j]] + v0[[i, 1 + j]] - v0[[i, j - 1]]);, {i, 2, n}, {j, 2, n}]; Do[Do[Do[ p[[i, j]] = (div[[i, j]] + (p[[i - 1, j]] + p[[i + 1, j]] + p[[i, j - 1]] + p[[i, j + 1]]))/4;, {j, 2, n}], {i, 2, n}];, {k, 0, r}]; Do[ux[[i, j]] = u0[[i, j]] - .5 n (p[[i + 1, j]] - p[[i - 1, j]]); vy[[i, j]] = v0[[i, j]] - .5 n (p[[i, j + 1]] - p[[i, j - 1]]);, {i, 2, n}, {j, 2, n}]; {ux, vy}]; Fx[t_, x_, y_] := 0; Fy[t_, x_, y_] := -1/Fr^2; onestep[n_, step_, r_, a_, uin_, vin_, dt_, c_] := Module[{u1, v1, f1, f2, u, v, u0, v0}, f1 = ConstantArray[0, {n + 1, n + 1}]; f2 = ConstantArray[0., {n + 1, n + 1}]; u0 = ConstantArray[0., {n + 1, n + 1}]; v0 = ConstantArray[0., {n + 1, n + 1}]; u = ConstantArray[0., {n + 1, n + 1}]; v = ConstantArray[0., {n + 1, n + 1}]; u1 = ConstantArray[0., {n + 1, n + 1}]; v1 = ConstantArray[0., {n + 1, n + 1}]; u0 = uin; v0 = vin; Do[ f2[[i, j]] = 1/Fr^2 (den[[i, j]] - rhoWater20C/2) (rhoWater20C - den[[i, j]]) (den[[i, j]] - rhoAir20C)/(rhoWater20C - rhoAir20C)/rhoWater20C^2;, {i, 2, n}, {j, 2, n}]; v0 += f2 dt; u0 = advect[n, u0, u0, v0, dt]; v0 = advect[n, v0, u0, v0, dt]; mnV = 0; u0 = periodic[n, U0, 0, u0]; v0 = periodic[n, mnV, mnV, v0]; u0 = diffuse[n, r, a, c, u0]; v0 = diffuse[n, r, a, c, v0]; u0 = periodic[n, U0, 0, u0]; v0 = periodic[n, mnV, mnV, v0]; {u1, v1} = project[n, r, u0, v0, u, v]; u0 = periodic[n, U0, 0, u1]; v0 = periodic[n, mnV, mnV, v1]; {u0, v0}] cf = With[{cg = Compile`GetElement, hp = HoldPattern, dv = DownValues}, Hold@Compile[{{u0argu, _Real, 2}, {v0argu, _Real, 2}, {denargu, _Real, 2}, {sm, _Integer}, {n, _Integer}, {r, _Integer}, dif, pec, F0}, Module[{u0 = u0argu, v0 = v0argu, uu, vv, dd, den = denargu, c = Table[0., {n + 1}, {n + 1}], dt = 40./n^2, a, dnup = den[[1, n + 1]], dnd = den[[1, 1]]}, a = dt dif n n; uu = vv = dd = Table[0., {sm + 1}, {n + 1}, {n + 1}]; Do[ den = advect[n, den, u0, v0, dt]; den = periodic[n, dnup, dnd, den]; den = diffuse[n, r, a/pec, c, den]; den = periodic[n, dnup, dnd, den]; dd[[step + 1]] = den; {u0, v0} = onestep[n, step, r, a, u0, v0, dt, c]; uu[[step + 1]] = u0; vv[[step + 1]] = v0;, {step, 0, sm}]; {uu, vv, dd}], CompilationTarget -> C, RuntimeOptions -> "Speed"] /. dv@onestep /. Flatten[dv /@ {Fx, Fy, advect, diffuse, periodic, project}] /. hp@ConstantArray[c_, {i_, j_}] :> Table[0., {i}, {j}] /. hp@Part[a__] :> cg[a] /. hp[cg[a__] = rhs_] :> (Part[a] = rhs) // ReleaseHold]; Visualization ------------- rst = cf[u0, v0, den, sm, n, r, dif, pec, F0];Do[lstu[k] = Flatten[Table[{{(i - 1)/n, (j - 1)/n}, rst[[1, k, i, j]]}, {i, n1}, {j, n1}], 1]; lstv[k] = Flatten[Table[{{(i - 1)/n, (j - 1)/n}, rst[[2, k, i, j]]}, {i, n1}, {j, n1}], 1];, {k, sm}]; Do[Uvel[i] = Interpolation[lstu[i], InterpolationOrder -> 3];, {i, 1, sm}]; Do[Vvel[i] = Interpolation[lstv[i], InterpolationOrder -> 3];, {i, 1, sm}]; Do[lst4[k] = Flatten[Table[{{(i - 1)/n, (j - 1)/n}, rst[[3, k, i, j]]}, {i, n1}, {j, n1}], 1];, {k, sm}]; Do[rh[k] = Interpolation[lst4[k], InterpolationOrder -> 3];, {k, sm}];{ContourPlot[Uvel[10][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 15, ContourStyle -> Yellow, PlotLegends -> Automatic], ContourPlot[Vvel[10][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 15, ContourStyle -> Yellow, PlotLegends -> Automatic], ContourPlot[1 - rh[10][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 15, ContourStyle -> Yellow, PlotLegends -> Automatic], ContourPlot[Uvel[sm][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 15, ContourStyle -> Yellow, PlotLegends -> Automatic], ContourPlot[Vvel[sm][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 15, ContourStyle -> Yellow, PlotLegends -> Automatic], ContourPlot[1 - rh[sm][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 8, ContourStyle -> Yellow, PlotLegends -> Automatic]} In this Figure are shown velocity components $u_x$ (left), $u_y$ (middle) and 1- density (right) on step 10 (upper line) and on final step $sm=600$ ![Figure 2][4] UPDATE ---------- Next step is to animate wave transformation using interface function. We can show velocity field over density as follows Show[ContourPlot[1 - rh[sm][x, y]/rhoWater20C, {x, 0, 1}, {y, 0, 1}, PlotRange -> All, ColorFunction -> "BlueGreenYellow", Contours -> 8, ContourStyle -> Yellow, Frame -> False, PlotLegends -> Automatic], StreamPlot[{Uvel[sm][x, y], Vvel[sm][x, y]}, {x, 0, 1}, {y, 0, 1}, PlotRange -> All, StreamColorFunction -> None, VectorPoints -> Fine, VectorColorFunction -> Hue, PlotLegends -> Automatic, StreamColorFunctionScaling -> True, StreamStyle -> LightGray]] ![Figure 3][5] We can also compute frames for animation with using interface function frames=Table[ContourPlot[1 - rh[i][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 8, ContourStyle -> Yellow, PlotLabel -> i], {i, 20, sm, 20}]; Animate[frames] ![Figure 4][6] References ---------- Jos Stam. Stable fluids. In Computer Graphics Proceedings Annual Conference Series, Los Angeles, Aug. 3–8, 199. Jos Stam. Interacting with smoke and fire in real time. Communications of the ACM, 43(7):77–83, July 2000. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=RogueWave.gif&userId=11733 [2]: https://www.researchgate.net/publication/354527324_A_Navier-Stokes_model_for_Rogue_wave_simulation [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Figure1.jpg&userId=1218692 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Figure2.jpg&userId=1218692 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Figure3.jpg&userId=1218692 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Fr3v3.AW1300Q5.gif&userId=1218692 Alexander Trounev 2021-11-03T06:49:53Z https://community.wolfram.com/groups/-/m/t/294122 ![enter image description here][5] When playing with Mathematica 10 I constructed this very simple example of an application of the NDSolve command, which I wanted to share. The objective is to model the growth of a special kind of brain tumour which affects mainly glial cells in a highly simplified way. I follow modelling ideas discussed in the excellent book ["Mathematical Biology" (Vol 2) by J.D. Murray][1]. It turns out that Gliomas, which are neoplasms of glial cells, i.e. neural calls capable of division, can be be modelled by a rather simple diffusion-growth model. $$\frac{d c}{dt}=\nabla\left(D(x) \nabla c \right)+ \rho c$$ where c is the concentration of cancer cells and $D(x)$ is the diffusion coefficient, which depends on the coordinates; $\rho$ models the growth rate of the cells. The following boundary condition has to be observe (even though will be ignored in the model I use later on): $${\bf n} \cdot D(x) \nabla c = 0 \qquad \text{for}\; x\; \text{on}\; \partial B.$$ In reality the diffusion coefficient will depend on the tissue type, i.e. gray matter vs white matter. I will use an image from a CT can to describe the different densities of the tissue instead. ![enter image description here][2] In the book by Murray great care is taken to estimate the diffusion coefficient but I just want to show the principle here. I use the attached file "brain-crop.jpg" and import it: img2=Import["~/Desktop/brain-crop.jpg"] Then I sharpen it and convert it to gray-scale. img3 = Sharpen[ColorConvert[img2, "Grayscale"]] Then I use that image to determine the diffusion coefficient, locally: diffcoeff = ListInterpolation[ImageData[img3], InterpolationOrder -> 3] I should now determine the boundaries using something like EdgeDetect. As the background is black and allows no diffusion at all, we can simplify this by just setting a larger (rectangular) boundary box like so: boundaries = {-y, y - 1, -x, x - 1}; \[CapitalOmega] = ImplicitRegion[And @@ (# <= 0 & /@ boundaries), {x, y}]; Next we can solve the ODE on the domain: sols = NDSolveValue[{{Div[1./500.*(diffcoeff[798.*x, 654*y])^4*Grad[u[t, x, y], {x, y}], {x, y}] - D[u[t, x, y], t] + 0.025*u[t, x, y] == NeumannValue[0., x >= 1. || x <= 0. || y <= 0. || y >= 1.]}, {u[0, x, y] == Exp[-1000. ((x - 0.6)^2 + (y - 0.6)^2)]}}, u, {x, y} \[Element] \[CapitalOmega], {t, 0, 20}, Method -> {"FiniteElement", "MeshOptions" -> {"BoundaryMeshGenerator" -> "Continuation", MaxCellMeasure -> 0.002}}] Note that we start with an initially Gaussian distributed tumour and describe its growth from there. Also I took the fourth power of the diffcoeff function, which changes the relation between grayscale and diffusion rate. You can change the coefficient to get different patterns for the growth. Interestingly, this integration gives a warning about intersecting boundaries in MMA10, which it did not say in the Prerelease version; if someone can fix that, that would be great. For any time we can now overlay the resulting distribution onto the CT image: ImageCompose[img3, {ContourPlot[ Max[sols[t, x, y], 0] /. t -> 2, {y, 0, 1}, {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}, {0.01, All}}, PlotPoints -> 100, Contours -> 200, ContourLines -> False, AspectRatio -> 798./654., ColorFunction -> "Temperature"], 0.6}] This should give something like this: ![enter image description here][3] Using frames = Table[ ImageCompose[ img3, {ContourPlot[ Max[sols[d, x, y], 0] /. d -> t, {y, 0, 1}, {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}, {0.01, All}}, PlotPoints -> 100, Contours -> 200, ContourLines -> False, AspectRatio -> 798./654., ColorFunction -> "Temperature"], 0.6}], {t, 0, 10, 0.5}]; we get a list of images, ![enter image description here][4] which can be animated ListAnimate[frames, DefaultDuration -> 20] to give ![enter image description here][5] This is only a very elementary demonstration, and certainly still far away from a "real" medical application, but it demonstrates the power of NDSolve and might, in a modified form, be useful as a case study for some introductory courses. Cheers, Marco [1]: http://www.springer.com/new+&+forthcoming+titles+%28default%29/book/978-0-387-95228-4 [2]: /c/portal/getImageAttachment?filename=brain-crop.jpg&userId=48754 [3]: /c/portal/getImageAttachment?filename=BrainTumor-still.jpg&userId=48754 [4]: /c/portal/getImageAttachment?filename=1473BrainTumor-frames.jpg&userId=48754 [5]: /c/portal/getImageAttachment?filename=BrainTumor.gif&userId=48754 Marco Thiel 2014-07-14T13:54:54Z https://community.wolfram.com/groups/-/m/t/3022104 An axes aligned bounding box (AABB) tree, a type of [bounding volume hierarchy](https://en.wikipedia.org/wiki/Bounding_volume_hierarchy), is a spatial data structure designed to efficiently find overlapping bounding boxes. It is often used to find broad-level collisions in applications such as collision detection and ray tracing. ## Question I have an implementation in WL that uses some [`Compile`](https://reference.wolfram.com/language/ref/Compile) and [`DataStructure`](https://reference.wolfram.com/language/ref/DataStructure), but is mostly top-level WL code. I'm looking to increase performance, while staying in the WL ecosystem. Are there any tips to speed up my code? In particular any tips to port this over to compiled code using [`FunctionCompile`](https://reference.wolfram.com/language/ref/FunctionCompile.html) & friends? Side note, would be nice if this was a builtin `DataStructure` :) I've posted the code below. Feel free to ask any questions about how it works, etc. ## Examples ### Basic example Bounding boxes are of the form $\{\{x_{min}, x_{max}\}, \{y_{min}, y_{max}\}, \{z_{min}, z_{max}\}\}$. Let's create the AABB tree over 3 bounding boxes and make 1 query bounding box: bboxes = { {{0, 1}, {0, 1}, {0, 1}}, {{0.5, 1.5}, {0.25, 1.5}, {0.3, 0.7}}, {{0.7, 0.8}, {0.8, 2}, {0.2, 0.8}} }; testbbox = {{0.6, 0.9}, {1.1, 1.4}, {0.6, 0.9}}; Create the data structure: aabbtree = AABBTree[bboxes]; Find the indices of the bounding boxes that overlap `testbbox`: overlaps = OverlappingBBoxes[aabbtree, testbbox] (* {2, 3} *) Visualize (query box in blue, overlapping in red, disjoint in green): Graphics3D[{ {FaceForm[Green], Cuboid @@@ Transpose[Delete[bboxes, Partition[overlaps, 1]], {1, 3, 2}]}, {FaceForm[Red], Cuboid @@@ Transpose[bboxes[[overlaps]], {1, 3, 2}]}, {Blue, Cuboid @@ Transpose[testbbox]} }] <img src="https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2023-09-26at10.48.42AM.png&userId=46025" width="360"> ### 4000 bounding boxes, 1 query randomBBox[n_] := With[{llcorners = RandomReal[{-10, 10}, {n, 3}]}, Transpose[{llcorners, llcorners + RandomReal[{1, 1}, {n, 3}]}, {3, 1, 2}] ] SeedRandom[1]; bboxes = randomBBox[4000]; testbbox = randomBBox[1][[1]]; aabbtree = AABBTree[bboxes]; // AbsoluteTiming (* {0.018875, Null} *) (overlaps = OverlappingBBoxes[aabbtree, testbbox]) // AbsoluteTiming (* {0.000692, {1817, 3935, 878, 87}} *) Graphics3D[Cuboid @@@ Transpose[bboxes, {1, 3, 2}]] <img src="https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2023-09-26at10.52.43AM.png&userId=46025" width="360"> Graphics3D[{ {FaceForm[Green], Cuboid @@@ Transpose[Delete[bboxes, Partition[overlaps, 1]], {1, 3, 2}]}, {FaceForm[Red], Cuboid @@@ Transpose[bboxes[[overlaps]], {1, 3, 2}]}, {Blue, Cuboid @@ Transpose[testbbox]}}, PlotRange -> testbbox, PlotRangePadding -> Scaled[0.25] ] <img src="https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2023-09-26at10.52.58AM.png&userId=46025" width="360"> ### 100000 bounding boxes, 100000 queries SeedRandom[1]; bboxes = randomBBox[100000]; testbboxes = randomBBox[100000]; aabbtree = AABBTree[bboxes]; // AbsoluteTiming (* {0.235465, Null} *) OverlappingBBoxes[aabbtree, testbboxes[[1]]]; // AbsoluteTiming (* {0.001988, Null} *) I suspect this can be sped up substantially: Scan[OverlappingBBoxes[aabbtree, #]&, testbboxes]; // AbsoluteTiming (* {44.8445, Null} *) ## Code AABBTree[bboxes_] := Block[{$RecursionLimit = ∞}, iAABBTree[1, MapIndexed[Join, Flatten /@ bboxes][[Ordering[bboxes[[All, 1, 1]]]]]] ] iAABBTree[d_, bboxestagged_] := Block[{len, n, x, Sleft, Scent, Sright, node}, len = Length[bboxestagged]; If[len <= 16, Return[centerNode3D[d, Null, bboxestagged]]]; n = Ordering[bboxestagged[[All, 2d-1]], {Quotient[len+1, 2]}][[1]]; x = Mean[bboxestagged[[n, 2d-1 ;; 2d]]]; {Sleft, Scent, Sright} = partitionIntervals3D[d, bboxestagged, x]; node = centerNode3D[d, x, Scent]; If[Length[Sleft] > 0, node["SetLeft", iAABBTree[Mod[d+1, 3, 1], Sleft]];]; If[Length[Sright] > 0, node["SetRight", iAABBTree[Mod[d+1, 3, 1], Sright]];]; node ] centerNode3D[d_, x_, {}] := CreateDataStructure["BinaryTree", {x, {}, {}, {}, {}, {}, {}, {}, -$MaxMachineNumber, $MaxMachineNumber, d}] (* {center ordinate, xmins, ymins, zmins, xmaxs, ymaxs, zmaxs, inds, dmin, dmax, d} *) (* xmins are the xmin values of all bboxes in this node, ymins, etc follow suit *) (* inds are the respective indices of the bboxes in this node *) (* dmin & dmax are the bounds of all bounding boxes in dimension d (the splitting dimension) *) centerNode3D[d_, x_, intstagged_] := CreateDataStructure["BinaryTree", { x, #1, #2, #3, #4, #5, #6, Developer`ToPackedArray[#7, Integer], Switch[d, 1, #1[[1]], 2, Min[#3], 3, Min[#5]], Max[Switch[d, 1, #2, 2, #4, 3, #6]], d }& @@ Transpose[intstagged] ] partitionIntervals3D[d_, intstagged_, x_] := Block[{data, spec}, data = Partition[partitionIntervals3DC[d, intstagged, x], 7]; spec = Round[data[[-1]]]; {data[[1 ;; spec[[1]]]], data[[spec[[1]]+1 ;; spec[[2]]]], data[[spec[[2]]+1 ;; -2]]} ] partitionIntervals3DC = Compile[{{d, _Integer}, {intstagged, _Real, 2}, {x, _Real}}, Block[{mnp, mxp, cright = 0., ccenter = 0., bagright = Internal`Bag[Most[{0.}]], bagcenter = Internal`Bag[Most[{0.}]], bagleft = Internal`Bag[Most[{0.}]]}, mnp = 2d-1; mxp = mnp+1; Do[ If[Compile`GetElement[i, mxp] < x, Internal`StuffBag[bagright, i, 1]; cright++, If[Compile`GetElement[i, mnp] > x, Internal`StuffBag[bagleft, i, 1], Internal`StuffBag[bagcenter, i, 1]; ccenter++ ] ], {i, intstagged} ]; Join[Internal`BagPart[bagright, All], Internal`BagPart[bagcenter, All], Internal`BagPart[bagleft, All], {cright, cright + ccenter, 0., 0., 0., 0., 0.}] ], CompilationTarget -> "C", RuntimeOptions -> "Speed" ]; OverlappingBBoxes[tree_?DataStructureQ, bbox:{{x1_, x2_}, {y1_, y2_}, {z1_, z2_}}] := Block[{bag, stack, node, a, b, d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11}, bag = Internal`Bag[]; stack = CreateDataStructure["Stack"]; stack["Push", tree]; While[!stack["EmptyQ"], node = stack["Pop"]; {d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11} = node["Data"]; {a, b} = bbox[[d11]]; If[Length[d2] > 0 && (d9 <= a <= d10 || d9 <= b <= d10 || a <= d9 <= d10 <= b), Internal`StuffBag[bag, Pick[d8, bboxOverlaps[d2, d3, d4, d5, d6, d7, x1, x2, y1, y2, z1, z2], 1], 1]; ]; If[d1 =!= Null, If[a < d1 && !node["LeftNullQ"], stack["Push", node["Left"]]]; If[d1 < b && !node["RightNullQ"], stack["Push", node["Right"]]]; ]; ]; Internal`BagPart[bag, All] ] bboxOverlaps = Compile[{{epx1, _Real}, {epx2, _Real}, {epy1, _Real}, {epy2, _Real}, {epz1, _Real}, {epz2, _Real}, {x1, _Real}, {x2, _Real}, {y1, _Real}, {y2, _Real}, {z1, _Real}, {z2, _Real}}, Boole @ And[ epx1 <= x1 <= epx2 || epx1 <= x2 <= epx2 || (x1 <= epx1 <= epx2 <= x2), epy1 <= y1 <= epy2 || epy1 <= y2 <= epy2 || (y1 <= epy1 <= epy2 <= y2), epz1 <= z1 <= epz2 || epz1 <= z2 <= epz2 || (z1 <= epz1 <= epz2 <= z2) ], CompilationTarget -> "C", Parallelization -> True, RuntimeOptions -> "Speed", RuntimeAttributes -> {Listable} ]; Greg Hurst 2023-09-26T15:12:15Z https://community.wolfram.com/groups/-/m/t/131302 I am reposting this here from the [url=http://mathematica.blogoverflow.com/]Stackexchange Mathematica blog[/url] so that more people might see it.  I'd be very happy to get some feedback on this plotting function.  If anyone can use the function, let me know how it works out for you, and if you'd recommend any changes.  If so, I can edit this post to have to most up-to-date version. As a chemist it is often useful to plot electronic orbitals. These are used to describe the wave function of electrons in atoms or molecules. Typically, these are output from electronic structure software in the form of a cube file, first developed by Gaussian. These files contain volumetric data for a given orbital on a three-dimensional grid. There exist many applications to visualize cube files, such as [url=http://www.ks.uiuc.edu/Research/vmd/plugins/molfile/cubeplugin.html]VMD [/url]or [url=http://www.gaussian.com/g_tech/gv5ref/results.htm]GaussView[/url], but I wanted to take advantage of Mathematica‘s capability to easily combine graphics, as well as the ability to automate the process in order to efficiently create frames for a [url=http://www.pnas.org/content/suppl/2013/09/05/1308604110.DCSupplemental/sm01.mp4]movie[/url]. First off, we need a function to extract the data from the cube file. In the process, we will create the text for an XYZ file, a format also developed by Gaussian. The function [b]OutForm[/b] is used here to mimic the printf function found in other programming languages. [mcode]OutForm[num_?NumericQ, width_Integer, ndig_Integer, OptionsPattern[]] := Module[{mant, exp, val}, {mant, exp} = MantissaExponent[num]; mant = ToString[NumberForm[mant, {ndig, ndig}]]; exp = If[Sign[exp] == -1, "-", "+"] <> IntegerString[exp, 10, 2]; val = mant <> "E" <> exp; StringJoin@PadLeft[Characters[val], width, " "] ]; ReadCube[cubeFileName_?StringQ] := Module[ {moltxt, nAtoms, lowerCorner, nx, ny, nz, xstep, ystep, zstep, atoms, desc1, desc2, xyzText, cubeDat, xgrid, ygrid, zgrid, dummy1, dummy2, atomicNumber, atomx, atomy, atomz, tmpString, headerTxt,bohr2angstrom}, bohr2angstrom = 0.529177249; moltxt = OpenRead[cubeFileName]; desc1 = Read[moltxt, String]; desc2 = Read[moltxt, String]; lowerCorner = {0, 0, 0}; {nAtoms, lowerCorner[[1]], lowerCorner[[2]], lowerCorner[[3]]} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; xyzText = ToString[nAtoms] <> "\n"; xyzText = xyzText <> desc1 <> desc2 <> "\n"; {nx, xstep, dummy1, dummy2} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; {ny, dummy1, ystep, dummy2} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; {nz, dummy1, dummy2, zstep} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; Do[ {atomicNumber, dummy1, atomx, atomy, atomz} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; xyzText = If[Sign[lowerCorner[[1]]] == 1, xyzText <> ElementData[atomicNumber, "Abbreviation"] <> OutForm[atomx, 17, 7] <> OutForm[atomy, 17, 7] <> OutForm[atomz, 17, 7] <> "\n", xyzText <> ElementData[atomicNumber, "Abbreviation"] <> OutForm[bohr2angstrom atomx, 17, 7] <> OutForm[bohr2angstrom atomy, 17, 7] <> OutForm[bohr2angstrom atomz, 17, 7] <> "\n"]; , {nAtoms}]; cubeDat = Partition[Partition[ReadList[moltxt, Number, nx ny nz], nz], ny]; Close[moltxt]; moltxt = OpenRead[cubeFileName]; headerTxt = Read[moltxt, Table[String, {2 + 4 + nAtoms}]]; Close[moltxt]; headerTxt = StringJoin@Riffle[headerTxt, "\n"]; xgrid = Range[lowerCorner[[1]], lowerCorner[[1]] + xstep (nx - 1), xstep]; ygrid = Range[lowerCorner[[2]], lowerCorner[[2]] + ystep (ny - 1), ystep]; zgrid = Range[lowerCorner[[3]], lowerCorner[[3]] + zstep (nz - 1), zstep]; {cubeDat, xgrid, ygrid, zgrid, xyzText, headerTxt} ];[/mcode] If you need to create a cube file, then the following function can be used: [mcode]WriteCube[cubeFileName_?StringQ, headerTxt_?StringQ, cubeData_] := Module[{stream}, stream = OpenWrite[cubeFileName, FormatType -> FortranForm]; WriteString[stream, headerTxt, "\n"]; Map[WriteString[stream, ##, "\n"] & @@ Riffle[ScientificForm[#, {3, 4}, NumberFormat -> (Row[{#1, "E", If[#3 == "", "+00", #3], "\t"}] &), NumberPadding -> {"", "0"}, NumberSigns -> {"-", " "}] & /@ #, "\n", {7, -1, 7}] &, cubeData, {2}]; Close[stream];][/mcode]Next we need the function to plot the orbital, [mcode]CubePlot[{cub_, xg_, yg_, zg_, xyz_}, plotopts : OptionsPattern[]] := Module[{xyzplot, bohr2picometer, datarange3D, pr}, bohr2picometer = 52.9177249; datarange3D = bohr2picometer {{xg[[1]], xg[[-1]]}, {yg[[1]], yg[[-1]]}, {zg[[1]], zg[[-1]]}}; xyzplot = ImportString[xyz, "XYZ"]; Show[xyzplot, ListContourPlot3D[Transpose[cub, {3, 2, 1}], Evaluate[FilterRules[{plotopts}, Options[ListContourPlot3D]]], Contours -> {-.02, .02}, ContourStyle -> {Blue, Red}, DataRange -> datarange3D, MeshStyle -> Gray, Lighting -> {{"Ambient", White}}], Evaluate[ FilterRules[{plotopts}, {ViewPoint, ViewVertical, ImageSize}]]] ]; [/mcode]Let’s look at an example. First we need to read in a cube file, download this cube file and place it in your base directory:  [url=https://dl.dropboxusercontent.com/s/rdsxcnqudn1s76n/cys-MO35.cube]cys-MO35cube[/url] [mcode]{cubedata,xg,yg,zg,xyz,header}= ReadCube["cys-MO35.cube"];[/mcode]Then plot it via[mcode]CubePlot[{cubedata, xg, yg, zg, xyz}][/mcode][img=width: 300px; height: 291px;]http://mathematica.blogoverflow.com/files/2013/09/pizCq-300x291.jpg[/img] When I want to create a movie file, I want all the images to have exactly the same [b]ViewAngle[/b], [b]ViewPoint[/b], and [b]ViewCenter[/b]. When you give these options to [b]CubePlot[/b], it feeds them directly to the [b]Show[/b] function [mcode]vp = {ViewCenter -> {0.5, 0.5, 0.5}, ViewPoint -> {1.072, 0.665, -3.13}, ViewVertical -> {0.443, 0.2477, 1.527}}; CubePlot[{cubedata, xg, yg, zg, xyz}, vp][/mcode][img=width: 280px; height: 300px;]http://mathematica.blogoverflow.com/files/2013/09/Q1mjs-280x300.jpg[/img] Finally, you can also give any options that normally go to [b]ListContourPlot3D[/b][mcode]CubePlot[{cubedata, xg, yg, zg, xyz}, vp, ContourStyle -> {Texture[ExampleData[{"ColorTexture", "Vavona"}]], Texture[ExampleData[{"ColorTexture", "Amboyna"}]]}, Contours -> {-.015, .015}][/mcode][img=width: 288px; height: 300px;]http://mathematica.blogoverflow.com/files/2013/09/fLyJ7-288x300.jpg[/img] Many thanks to Daniel Healion for the [b]ReadCube[/b] and [b]WriteCube[/b] functions. Jason Biggs 2013-09-27T18:35:45Z 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/3458262 ![The uncontrolled re-entry of a large Soviet-era Venus probe KOSMOS-482 on May 10, 2025][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Video-2025-05-09T12-02-59-ezgif.com-optimize.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/1c63983c-ad3c-4244-b174-bfa84310904f Gosia Konwerska 2025-05-09T18:37:28Z https://community.wolfram.com/groups/-/m/t/418720 ## This is it. The perfectly centered billiards break. Behold: ![enter image description here][2] <h2>Setup</h2> This break was computed in *Mathematica* using a numerical differential equations model. Here are a few details of the model: * All balls are assumed to be perfectly [elastic][3] and almost perfectly rigid. * Each ball has a mass of 1 unit and a radius of 1 unit. * The cue ball has a initial speed of 10 units/sec. * The force between two balls is given by the formula $$F \;=\; \begin{cases}0 & \text{if }d \geq 2, \\ 10^{11}(2-d)^{3/2} & \text{if }d < 2, \end{cases}$$ where $d$ is the distance between the centers of the balls. Note that the balls overlap if and only if $d < 2$. The power of $3/2$ was [suggested by Yoav Kallus][4] on Math Overflow, because it follows [Hertz's theory of non-adhesive elastic contact](https://en.wikipedia.org/wiki/Contact_mechanics#Hertzian_theory_of_non-adhesive_elastic_contact). The initial speed of the cue ball is immaterial -- slowing down the cue ball is the same as slowing down time. The force constant $10^{11}$ has no real effect as long as it's large enough, although it does change the speed at which the initial collision takes place. <h2>The Collision</h2> For this model, the entire collision takes place in the first 0.2 milliseconds, and none of the balls overlap by more than 0.025% of their radius during the collision. (These figures are model dependent -- real billiard balls may collide faster or slower than this.) The following animation shows the forces between the balls during the collision, with the force proportional to the area of each yellow circle. Note that the balls themselves hardly move at all *during* the collision, although they do accelerate quite a bit. ![enter image description here][5] <h2>The Trajectories</h2> The following picture shows the trajectories of the billiard balls after the collision. ![enter image description here][6] After the collision, some of the balls are travelling considerably faster than others. The following table shows the magnitude and direction of the velocity of each ball, where $0^\circ$ indicates straight up. $\begin{array}{|c|c|c|c|c|c|c|c|c|c|c|} \hline \text{ball} & \text{cue} & 1 & 2,3 & 4,6 & 5 & 7,10 & 8,9 & 11,15 & 12,14 & 13 \\ \hline \text{angle} & 0^\circ & 0^\circ & 40.1^\circ & 43.9^\circ & 0^\circ & 82.1^\circ & 161.8^\circ & 150^\circ & 178.2^\circ & 180^\circ \\ \hline \text{speed} & 1.79 & 1.20 & 1.57 & 1.42 & 0.12 & 1.31 & 0.25 & 5.60 & 2.57 & 2.63 \\ \hline \end{array} $ For comparison, remember that the initial speed of the cue ball was 10 units/sec. Thus, balls 11 and 15 (the back corner balls) shoot out at more than half the speed of the original cue ball, whereas ball 5 slowly rolls upwards at less than 2% of the speed of the original cue ball. By the way, if you add up the sum of the squares of the speeds of the balls, you get 100, since kinetic energy is conserved. <h2>Linear and Quadratic Responses</h2> The results of this model are dependent on the power of $3/2$ in the force law -- other force laws give other breaks. For example, we could try making the force a linear function of the overlap distance (in analogy with springs and [Hooke's law][7]), or we could try making the force proportional to the *square* of the overlap distance. The results are noticeably different ![enter image description here][8] ![enter image description here][9] <h2>Stiff Response</h2> Glenn the Udderboat points out that "stiff" balls might be best approximated by a force response involving a higher power of the distance (although this isn't the [usual definition][10] of "stiffness"). Unfortunately, the calculation time in *Mathematica* becomes longer when the power is increased, presumably because it needs to use a smaller time step to be sufficiently accurate. Here is a simulation involving a reasonably "stiff" force law $$F \;=\; \begin{cases}0 & \text{if }d \geq 2, \\ 10^{54}(2-d)^{10} & \text{if }d<2. \end{cases}$$ ![enter image description here][11] As you can see, the result is very similar to my first thought: > The two balls in the back corners shoot away along rays parallel to the two sides of the triangle. Here is a picture showing the forces, with each force vector emanating from the point of contact. > ![enter image description here][12] This seems like good evidence that above 1st-thought behavior is indeed the limiting behavior in the case where the stiffness goes to infinity. As you might expect, most of the energy in this case is transferred very quickly at the beginning of the collision. Almost all of the energy has moves to the back corner balls in the first 0.02 milliseconds. Here is an animation of the forces: ![enter image description here][13] After that, the corner balls and the cue ball shoot out, and the remaining balls continue to collide gently for the next millisecond or so. While the simplicity of this behavior is appealing, I would guess that "real" billard balls do not have such a stiff force response. Of the models listed here, the intial Hertz-based model is probably the most accurate. Qualitatively, it certainly seems the closest to an "actual" break. <h2> Full Code </h2> &[Wolfram Notebook][14] ---------- I wrote this post originally for [Math Stack Exchange][15]. [1]: http://math.bard.edu/belk/code.htm [2]: http://i.stack.imgur.com/Y9ixR.gif [3]: https://en.wikipedia.org/wiki/Elasticity_%28physics%29 [4]: http://mathoverflow.net/questions/156263/perfectly-centered-break-of-a-perfectly-aligned-pool-ball-rack/156407?noredirect=1#comment400402_156407 [5]: http://i.stack.imgur.com/WY37i.gif [6]: http://i.stack.imgur.com/wHVJA.png [7]: https://en.wikipedia.org/wiki/Hooke%27s_law [8]: http://i.stack.imgur.com/a1l3b.gif [9]: http://i.stack.imgur.com/xM76n.gif [10]: https://en.wikipedia.org/wiki/Stiffness [11]: http://i.stack.imgur.com/nMJyT.gif [12]: http://i.stack.imgur.com/GKGT9.png [13]: http://i.stack.imgur.com/VuUWT.gif [14]: https://www.wolframcloud.com/obj/8c6b7e81-4a5c-4e3a-bb13-a3d47e728e64 [15]: http://math.stackexchange.com/a/659318/28293 Jim Belk 2015-01-08T18:02:10Z https://community.wolfram.com/groups/-/m/t/787142 ## General information and download links ## If you're interested in crystal structures, you can now download the Crystallica application from the Wolfram Library Archive, and then you can do things like this: Needs["Crystallica`"]; CrystalPlot[ {{5.4,0,0},{0,5.4,0},{0,0,5.4}}, {{0,0,0},{0,0,.5},{0,.5,0},{.5,0,0},{.24,.24,.24},{.24,.76,.76},{.76,.24,.76},{.76,.76,.24}}, {1,2,2,2,3,3,3,3}, AtomCol->{"Firebrick","YellowGreen",White},AtomRad->.4, BondStyle->2,BondDist->3, CellLineStyle->False,AddQ->True,Lighting->{{"Directional",White,ImageScaled[{0,0,1}]}},Background->Black] ![enter image description here][1] Here are the download links for Crystallica and two other packages you may need: [Crystallica][2] - contains the functions `CrystalPlot` and `CrystalChange` [CifImport][3] - contains an import function for CIF files [VaspImport][4] - contains an import function for files related to [VASP][5] Once you've installed Crystallica (by saving the entire Crystallica folder - not the zip archive - to `$USerBaseDirectory/Applications` and re-starting the Kernel), you can enter Crystallica into the Documentation Center and you'll find lots of useful examples. Most of the examples in this post are taken from the Documentation. For the other two packages, just install them and evaluate this: ?CifImport ?VaspImport I'll first show you a few things the `CrystalPlot` function can do when you already have crystal structure data inside Mathematica, wherever it may have come from. Then we'll take a look at how to get the data into Mathematica in the first place, which is where `CifImport` and `VaspImport` will come into play - but we'll get data from other sources as well. I'll cover the different import solutions in separate replies to this thread, because I have a feeling that I'll be rambling on and on and on... ## Simple plot ## Traditional ball-and-stick plots are usually just fine, so the simplest thing you can do is this: CrystalPlot[ {{4.5,0,0},{0,4.5,0},{0,0,3}}, {{0,0,0},{.5,.5,.5},{.2,.8,.5},{.3,.3,0},{.7,.7,0},{.8,.2,.5}}, {1,1,2,2,2,2}] ![enter image description here][6] As you can see, `CrystalPlot` expects three arguments. The first one contains the lattice vectors, which are simply the three vectors that create the parallelepiped that constitutes the cell. The second argument contains the atomic coordinates, but they're given in the basis of the lattice vectors (which is quite useful in crystallography). The third argument is a list of integers that gives the atom types, with one entry for each atom. If you want to plot a molecule instead, you can call `CrystalPlot` with just two arguments: A list of atom coordinates in cartesian space, and a list of atom types. Everything else you see in the plot - the atoms, bonds, colours, arrows etc. - represents the default settings of various layout options. ## Advanced atoms and bonds ## Let's take a look at some more advanced options just for fun. For instance, atoms and bonds can look any way you need them to, because you can specify your own functions for them. You can also fine-tune where to put bonds and what to do with their thickness and colour in a physically (or chemically) meaningful way, but I won't show that here. So here are some customized atoms and bonds: Row[Table[ CrystalPlot[{{4,0,0},{0,4,0},{0,0,4}},{{0,0,0},{.4,.4,.4},{.8,.8,.8}},{1,2,3}, AtomRad->{.4,1.2,.7},AtomFunction->style,ImageSize->400], {style,{ (Ball[#1,#2]&), (Scale[Sphere[#1,#2],{1,1,.5}]&), ({EdgeForm[Thick],Opacity[.7],Cuboid[#1-.5*#2,#1+.5*#2]}&) }}]] ![enter image description here][7] Row[Table[ CrystalPlot[{{0,0,0},{5,0,0},{2.5,4,0}},{1,2,3},BondDist->6,BondStyle->style,ImageSize->400], {style,{ 1, Function[{bonds,partcol},Table[{If[ii<.5,partcol[#,1],partcol[#,2]],Sphere[bonds[[#,1]]+ii*(bonds[[#,2]]-bonds[[#,1]]),.15]},{ii,0,1,1/9}]&/@Range[Length[bonds]]], Function[{bonds,partcol},Module[{spiral,points,rad=.05}, spiral[atoms_]:=Module[{scale=.5,dist=atoms[[2]]-atoms[[1]],curls=60,normal,rot,scaled}, normal=Table[{scale*Cos[ii],scale*Sin[ii],.1*ii},{ii,0,curls,\[Pi]/10}]; scaled={#[[1]],#[[2]],10*Norm[dist]/curls*#[[3]]}&/@normal; rot=scaled.Quiet[RotationMatrix[{dist,{0,0,1}}]]; Join[{atoms[[1]]},#+atoms[[1]]&/@(rot[[25;;-25]]),{atoms[[2]]}]]; points=spiral/@bonds; {partcol[#,1],Tube[BSplineCurve[points[[#,;;Round[Length[points[[#]]]/2]]],rad]],partcol[#,2],Tube[BSplineCurve[points[[#,Round[Length[points[[#]]]/2];;]],rad]]}&/@Range[Length[bonds]] ]] }}]] ![enter image description here][8] ## Lattice planes ## Crystallica can also add lattice planes to the plot. You can specify them using [h,k,l] Miller indices and distance to the origin. CrystalPlot[{{3,0,0},{0,3,0},{0,0,3}},{{0,0,0}},{1}, AddQ->True,AtomRad->.3,AtomCol->"CadmiumYellow",Sysdim->2,CellLineStyle->2, LatticePlanes->Table[{{1,1,1},dist},{dist,1,5}],ContourStyle->{"TerreVerte",Opacity[.7]},BoundaryStyle->Thick] ![enter image description here][9] ## Coordination polyhedra ## You can automatically search for and plot coordination polyhedra. This is not limited to the commonly occurring tetrahedra and octahedra - you can actually look for polyhedra with arbitrary numbers of corners. There are also options to fine-tune both the searching and the rendering. plot[corners_,mixed_]:=CrystalPlot[{{0,0,0},{0,0,1.8},{-.9,-1.5,-.6},{-.9,1.5,-.6},{1.7,0,-.6},{.8,.8,.8}},{1,2,2,2,2,3}, BondStyle->False,ImageSize->250, PolyMode[corners]->{"Show"->All,"AllowMixed"->mixed},PolyStyle[corners]->Directive[Opacity[.5],EdgeForm[Thick]]]; Grid[{{ "", "Search for polyhedra with \n4 corners", "Search for polyhedra with \n5 corners" },{ "Allow \nmixed corners", plot[4,True], plot[5,True] },{ "Don't allow \nmixed corners", plot[4,False], plot[5,False] }},Dividers->All] ![enter image description here][10] CrystalPlot[{{2.5,-4.3,0},{2.5,4.3,0},{0,0,5.5}}, {{.5,0,0},{0,.5,.7},{.5,.5,.3},{.2,.4,.5},{.6,.8,.2},{.2,.8,.8},{.8,.6,.5},{.4,.2,.2},{.8,.2,.8}},{1,1,1,2,2,2,2,2,2}, PolyMode[4]->True,PolyStyle[4]->EdgeForm[None],AddQ->True, Sysdim->2,AtomRad->0,CellLineStyle->False,AtomCol->{"SlateGray","Firebrick"}, ViewAngle->.4,ViewPoint->{3.2,0,1.1},ViewVertical->{.5,0,1.2}] ![enter image description here][11] ## Other things ## Visualization aside, you can also build supercells, change cell shapes, or add, remove and sort atoms... but that's a bit boring to read, so I'll refer you to the Documentation page of the `CrystalChange` function instead. If you're interested, we can use this thread to talk about any questions you may have, or you can share your use of the package (if you decide to use it). I'm not offering full support here, but I'll be floating around, and I'd like to hear your feedback. We don't have any intentions to be involved in further development. But if you have a good idea and some time, then by all means, work on it for yourself, or host it on your favourite code collaboration site. Bianca Eifert and Christian Heiliger [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=teaser.png&userId=69107 [2]: http://library.wolfram.com/infocenter/MathSource/9372/ [3]: http://library.wolfram.com/infocenter/MathSource/9373/ [4]: http://library.wolfram.com/infocenter/MathSource/9375/ [5]: http://vasp.at/ [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9692simple.png&userId=69107 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=atoms.png&userId=69107 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=bonds.png&userId=69107 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=planes.png&userId=69107 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=polys.png&userId=69107 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=polys2.png&userId=69107 [12]: http://rruff.geo.arizona.edu/AMS/CIF_text_files/13532_cif.txt [13]: http://cms.mpi.univie.ac.at/vasp/vasp/POSCAR_file.html [14]: http://wiki.jmol.org/index.php/File:Caffeine.mol Bianca Eifert 2016-02-05T18:43:18Z https://community.wolfram.com/groups/-/m/t/2085563 ![enter image description here][1] In a previous Wolfram Demonstration [Pendulum with Varying Length or How to Improve Your Next Swing Ride][2], I modelled a swing and rider system as a pendulum with varying length. Inspired by the article "[Pumping a Playground Swing][3]" by Post et al. I looked at an alternative strategy to "optimize my swing ride". The swing-rider system can be modeled as a double pendulum. The regular, *unforced double pendulum* maintains a constant level of energy. Kinetic-and potential energy are merely converted into one another and their sum remains constant. In the case of a swing however, we have a *forced double pendulum* as the rider wants to go higher and "pump" his way up. This can only be achieved by increasing the total energy in the (swing and rider) system. "Energy insertion" can be done by someone pushing the rider or by a properly synchronized change in the position of the center of mass (CM) of the rider. In the mentioned demonstration, the CM change was limited to an up and down crouching of the rider. Here, I will analyse a more general, circular or elliptic position change of the rider's CM. **Geometry** Let us first look at the geometry of the swing-rider system: The swinging kid at P can introduce energy into the double pendulum by forcibly moving his center of gravity in an elliptic movement around a point Z on the rigid swing rods OS. \[Theta] is the angle of the swing movement and \[Phi] is the angle of the crouching movement (rotation). We need a "crouching function" linking the angles \[Phi] and \[Theta]: \[Phi] = \[Omega] \[Theta]+\[Phi]0. \[Omega] is the crouching frequency and \[Phi]0 is the crouching's initial angular offset. Animate[ With[{L = 10, r = 2., \[Omega] = 3., \[Phi]0 = 0, a = .62, b = 2}, Module[{pivot, \[Phi], trace, seatCenter, hipPivot, hip}, pivot = {0, 0}; \[Phi] = \[Omega] \[Theta] + \[Phi]0; seatCenter = {L Sin[\[Theta]], -L Cos[\[Theta]]}; hipPivot = (L - r) {Sin[\[Theta]], -Cos[\[Theta]]}; hip = {(L - r - a Cos[\[Phi]]) Sin[\[Theta]] + b Cos[\[Theta]] Sin[\[Phi]], Cos[\[Theta]] (-L + r + a Cos[\[Phi]]) + b Sin[\[Theta]] Sin[\[Phi]]}; trace = Rotate[Circle[hipPivot, {b, a}], \[Theta]]; Graphics[{Line[{pivot, seatCenter}], Blue, Line[{hipPivot, hip}], PointSize[.015], Point[{pivot, hip, hipPivot, seatCenter}], {Red, trace}, {Dashed, Line[{hip, pivot}]}, {Black, Text[Style["O", 12], pivot, {-1, -1}], Text[Style["Z", 12], hipPivot, {1, 1}], Text[Style["P", 12], hip, {-1, -1}], Text[Style["S", 12], seatCenter, {-1, 1}]}}]]], {\[Theta], 0, 2 Pi}] ![enter image description here][4] **Dynamic Model** We add the driver's mass mk at P and consider the crouching as a periodic driving force. We use Newton's laws to derive the equation of motion: (*hip (CM) coordinate*) xh[t_] := b Cos[\[Theta][t]] Sin[\[Phi]0 + t \[Omega]] + (L - r - a Cos[\[Phi]0 + t \[Omega]]) Sin[\[Theta][t]]; yh[t_] := (-L + r + a Cos[\[Phi]0 + t \[Omega]]) Cos[\[Theta][t]] + b Sin[\[Phi]0 + t \[Omega]] Sin[\[Theta][t]]; (*effective swing length*)l = Sqrt[xh[t]^2 + yh[t]^2]; (*equilibrium of forces*) deqns = {mk xh''[t] == s[t] xh[t]/l, mk yh''[t] == s[t] yh[t]/l - mk g}; deqn = Eliminate[deqns, s[t]] // FullSimplify ![enter image description here][5] This is an animation showing a solution of the differential equation. The evolution of the energy levels shows how the forced position changes in the rider's CM is increasing the total energy in the system. Trying to reach a large energy increase in a short time is the goal of every swing rider. Here, a maximum energy level with a high swing is reached after a mere 1.5 full swings. Animate[Module[{a = 1.75, b = 1.5, \[Omega] = 1.9, \[Phi]0 = 0, \[Theta]0 = \[Pi]/4, \[Theta]00 = 0, V, T, mk = 50, g = 9.81, L = 10, l, xh, yh, \[Theta]sol, seat, hip, hipPivot, trace, tMax = 16, r = .75}, pivot = {0, 0}; (*crouch function*)\[Phi][t_] := \[Omega] t + \[Phi]0; xh[t_] := b Cos[\[Theta][t]] Sin[\[Phi]0 + t \[Omega]] + (L - r - a Cos[\[Phi]0 + t \[Omega]]) Sin[\[Theta][t]]; yh[t_] := (-L + r + a Cos[\[Phi]0 + t \[Omega]]) Cos[\[Theta][t]] + b Sin[\[Phi]0 + t \[Omega]] Sin[\[Theta][t]]; sol = First@ NDSolve[{deqn, \[Theta][0] == \[Theta]0, \[Theta]'[ 0] == \[Theta]00}, \[Theta], {t, 0, tMax}]; hip = {xh[t], yh[t]} /. sol /. t -> time; seat = L {Sin[\[Theta][time]], -Cos[\[Theta][time]]} /. sol; hipPivot = (L - r) {Sin[\[Theta][time]], -Cos[\[Theta][time]]} /. sol; trace = Rotate[Circle[hipPivot, {b, a}], \[Theta][time]] /. sol; (*kinetic energy*) T[t_] := Evaluate[.5 mk (xh'[t]^2 + yh'[t]^2)] /. sol;(*potential energy*)V[t_] := mk g yh[t] /. sol; Column[{ Plot[Evaluate[{V[t], T[t] + V[t]}], {t, 0, tMax}, Filling -> {2 -> {1}, 1 -> Bottom}, PlotLabel -> "Energy", PlotLegends -> Placed[{"Potential", "Total"}, Bottom], AxesLabel -> {"t", ""}, Epilog -> {AbsoluteThickness[.75], Line[{{time, -10000}, {time, 10000}}]}], Graphics[{(*support*){FaceForm[Yellow], EdgeForm[Black], Triangle[{pivot, 10 {-.035, .045}, 10 {.035, .045}}], Red, Disk[pivot, .01]}, (*floor*), {Brown, AbsoluteThickness[4], Line[{{-10, -L - a}, {10, -L - a}}]}, Point[{pivot, seat, hipPivot}], Line[{pivot, hip}], {Directive[Blue, AbsoluteThickness[.5]], trace}, {DotDashed, Line[{pivot, seat}]}, {Blue, Line[{hipPivot, hip}]}, {Red, AbsolutePointSize[7], Point@hip, White, Disk[hip, .025]}, ParametricPlot[ Evaluate[{xh[t], yh[t]} /. sol], {t, 0, time + .001}, PlotStyle -> Directive[Red, AbsoluteThickness[.75]]][[1]]}, PlotRange -> 12, Axes -> True]}]], {time, 0, 15.5, .25}] ![enter image description here][6] **Adding a rider** I designed a simplified rider figure with the hip position at the center of gravity and fixed points where the foot is on the seat and the grip of the hand is on the front rod. This figure can then simply be fitted into the previous code to make a working and more realistic model. kidNSwing[hip : {hx_, hy_}] := With[{pivot = {0, 0}, L = 10, seat = .75, head = .45, grip = 2.5, leg = 1.55, thigh = 1.4, trunk = 1.5, arm1 = 1.25, arm2 = 1.2}, Module[{(*joints*)ptF, ptB, ptT, ptS, ptK, ptP, ptN, ptE, ptH, ptD}, ptT = {-.2, -L}; ptS = {0, -L + .085}; ptF = {-seat, -L}; ptB = {seat, -L}; ptK = findTop[ptS, hip, leg, thigh]; ptH = AngleVector[{(L - grip), -1.6458}]; ptN = First@ Nearest[{x, y} /. Solve[{x, y} \[Element] Line[{ptS, pivot}] && EuclideanDistance[{x, y}, hip] == trunk + .1, {x, y}], pivot]; ptE = findTop[ptN, ptH, arm2, arm2]; ptD = First@ Nearest[{x, y} /. Solve[{x, y} \[Element] Line[{ptN, pivot}] && EuclideanDistance[{x, y}, hip] == trunk + head + .175, {x, y}], pivot]; {(*seat*){AbsoluteThickness[6], Gray, Line[{ptF, ptB}]}, (*rods*){AbsoluteThickness[.9], Line[{ptF, {0, 0}, ptB}]}, {PointSize[.01], Point[hip]}, (*trunk & limbs*) {FaceForm[Lighter[Red, .8]], EdgeForm[AbsoluteThickness[1]], StadiumShape[#, .125] & /@ Partition[{ptT, ptS, ptK, hip, ptN, ptE, ptH}, 2, 1] }, (*joints*){Disk[#, .12] & /@ {ptT, ptS, ptK,(*hip,*)ptN, ptE, ptH}, White, Disk[#, .065] & /@ {hip, ptT, ptS, ptK,(*hip,*)ptN, ptE, ptH}}, (*head*){Darker[Gray, .35], Disk[ptD, head, {176 \[Degree], -154 \[Degree]}],(*eye*)White, Disk[ptD, .075]}}]] ![enter image description here][7] **Full model to Optimize your Swing ride** The equation of motion is then introduced in a Manipulate. This lets the user experiment with a simple model of the swing and rider system to explore the conditions for an optimized swing ride . The parameters of the hip (CM) displacement and the initial conditions (angular position and speed) can be adjusted. The energy level graph on top lets the user see where the maximum energy level occurs and try do move this as much as possible to the start of the ride. Manipulate[With[{mk = 50, g = 9.81, pivot = {0, 0}, L = 10}, Module[{deqn, crouch, xh, yh, sol, \[Phi], V, T, hipPivot, hip, trace}, time = Min[tMax, time]; \[Phi][t_] := \[Omega] t + \[Phi]0; crouch[t_] := {b Sin[\[Phi][t]], -L + r + a Cos[\[Phi][t]]}; xh[t_] := b Cos[\[Theta][t]] Sin[\[Phi]0 + t \[Omega]] + (L - r - a Cos[\[Phi]0 + t \[Omega]]) Sin[\[Theta][t]]; yh[t_] := (-L + r + a Cos[\[Phi]0 + t \[Omega]]) Cos[\[Theta][t]] + b Sin[\[Phi]0 + t \[Omega]] Sin[\[Theta][t]]; deqn = 2 b ((-L + r) \[Omega]^2 + g Cos[\[Theta][t]]) Sin[\[Phi]0 + t \[Omega]] + 4 \[Omega] (a (L - r) + (-a^2 + b^2) Cos[\[Phi]0 + t \[Omega]]) Sin[\[Phi]0 + t \[Omega]] Derivative[ 1][\[Theta]][ t] + (a^2 + b^2 + 2 (L - r)^2 + 4 a (-L + r) Cos[\[Phi]0 + t \[Omega]] + (a - b) (a + b) Cos[ 2 (\[Phi]0 + t \[Omega])]) (\[Theta]^\[Prime]\[Prime])[ t] == 2 g (-L + r + a Cos[\[Phi]0 + t \[Omega]]) Sin[\[Theta][ t]]; sol = First@ NDSolve[{deqn, \[Theta][0] == \[Theta]0, \[Theta]'[ 0] == \[Theta]00}, \[Theta], {t, 0, tMax}]; hip[t_] := {xh[t], yh[t]} /. sol; hipPivot = (L - r) {Sin[\[Theta][time]], -Cos[\[Theta][time]]} /. sol; trace[t_] := Rotate[Circle[hipPivot, {b, a}], \[Theta][t]]; T[t_] := Evaluate[.5 mk (xh'[t]^2 + yh'[t]^2)] /. sol; V[t_] := mk g yh[t] /. sol; Column[{ Plot[Evaluate[{V[t], T[t] + V[t]}], {t, 0, tMax}, Filling -> {2 -> {1}, 1 -> Bottom}, PlotLabel -> "Energy", PlotLegends -> Placed[{"Potential", "Total"}, Bottom], AxesLabel -> {"t", ""}, AxesStyle -> 7, Epilog -> {AbsoluteThickness[.75], Line[{{time, -1*^6}, {time, 1*^6}}]}, ImageSize -> 400, AspectRatio -> .3], Graphics[{ {FaceForm[Yellow], EdgeForm[Black], Triangle[{pivot, {-.35, .45}, {.35, .45}}], Red, Disk[pivot, .15]}, (*floor*), {Brown, AbsoluteThickness[4], Line[{{-20, -L - 1}, {20, -L - 1}}]}, ParametricPlot[ hip[t] /. sol, {t, 0, If[sdt, tMax, time + .01]}, PerformanceGoal -> "Quality", PlotStyle -> Directive[AbsoluteThickness[.45], Red], PlotPoints -> 10][[1]], Rotate[kidNSwing[crouch[time]], \[Theta][time], pivot] /. sol, If[ sht, {Directive[Dashed, Blue, AbsoluteThickness[1.5]], trace[time] /. sol}, Nothing]}, Background -> Lighter[Gray, 0.8], Axes -> True, Frame -> True, FrameTicks -> None, PlotRange -> 1.1 {{-L, L}, {-L - .1, L}}, ImageSize -> 400]}]]], Style["animation", Bold, 10], {{time, 0.}, 0., tMax, .001, ImageSize -> Tiny, Appearance -> "Labeled"}, Delimiter, Style["swinging", Bold, 10], "initial angular position kid", {{\[Theta]0, 1.31}, -1.57, 1.57, .001, ImageSize -> Tiny, Appearance -> "Labeled"}, "initial angular speed", {{\[Theta]00, 0}, -6, 6, .0001, ImageSize -> Tiny, Appearance -> "Labeled"}, Delimiter, Style["crouching", Bold, 10], "major axis a (in line with swing rods)", {{a, .75}, 0., 2, .001, ImageSize -> Tiny, Appearance -> "Labeled"}, "minor axis b (perpendicular to swing rods)", {{b, .274}, 0., 2, .001, ImageSize -> Tiny, Appearance -> "Labeled"}, "frequency", {{\[Omega], 1.904}, -5, 5, .001, ImageSize -> Tiny, Appearance -> "Labeled"}, "angular offset", {{\[Phi]0, 0}, -1.57, 1.57, .0001, ImageSize -> Tiny, Appearance -> "Labeled"}, Delimiter, "hip vertical offset", {{r, 1.6722}, 0, 2.5, .0001, ImageSize -> Tiny, Appearance -> "Labeled"}, Delimiter, Row[{"show full dynamic trace", Control[{{sdt, False, ""}, {True, False}}]}], Row[{"show static trace", Control[{{sht, False, ""}, {True, False}}]}], {{tMax, 30, "total time"}, None}, TrackedSymbols :> True, ControlPlacement -> Left] ![enter image description here][8] After some experimenting, one can easily derive some conclusions: 1. the most important effect is to synchronize the crouching (\[Phi]) with the swinging (\[Theta]). Best results are achieved if the crouching frequency (\[Omega]) is double the swing frequency. 2. up and down crouching (a is the crouching path's semimajor axis in line with swing rods) has more effect than forward- backward leaning (b is the crouching path's semi-minor axis perpendicular to swing rods) **Some Favorite Rides** 1. A start from absolute standstill and zero position. Only the hip movement is in action here and is enough to add energy to the system. "zero start-1" :> {a = 0.75, b = 0.75, r = 1.6722, \[Theta]00 = 0, \[Theta]0 = 0, \[Phi]0 = 0.253, \[Omega] = 1} ![enter image description here][9] 2. This example also has zero initial speed and position but the crouching is synchronized in a nearly optimal way (\[Omega]= approximately 2), resulting in a spectacular swing over the top (we have rigid rods, no ropes or chains!). "zero start-2" :> {a = 1.2, b = 0, r = 1.6722, \[Theta]00 = 0, \[Theta]0 = 0.785, \[Phi]0 = 0.4664, \[Omega] = 1.994} ![enter image description here][10] 3. Other relations of crouching to swinging can result in some nice periodic rides. "oval track" :> {a = 0.75, b = 0, r = 0.8, \[Theta]00 = 0.0714, \[Theta]0 = 1.265, \[Phi]0 = -0.2527, \[Omega] = 3.74} ![enter image description here][11] Experiment freely with the previous Manipulate and get as much fun as I did with this simple model of something we are all familiar with. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=zerostart-6.gif&userId=68637 [2]: https://demonstrations.wolfram.com/PendulumWithVaryingLengthOrHowToImproveYourNextSwingRide/ [3]: https://pdfs.semanticscholar.org/9b19/8d284aee700cc35c2faae5683ff5e6fba66d.pdf [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5490dynamicgeometry.gif&userId=68637 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1981eqnofmotion.png&userId=68637 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2550modelwokid.gif&userId=68637 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8117kidNswingcombi.gif&userId=68637 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif.com-resize.png&userId=68637 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8451zerostart-1.gif&userId=68637 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=zerostart-4.gif&userId=68637 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=zerostart-5.gif&userId=68637 Erik Mahieu 2020-09-29T12:38:26Z https://community.wolfram.com/groups/-/m/t/790989 ![enter image description here][1] With all of the rumors and excitement about the gravity wave press release tomorrow, I was reminded of this code I've had lying around for years for creating a gravity wave visualization (seen above) for illustrative purposes. You can find also a [video here][2]. It was inspired by an interaction I had years ago (unfortunately I can't find the interaction in my email) with someone on the [LISA][3] project wanting to use Mathematica to re-create a visualization they had. This code was the result of that interaction. First, the primary goal was to generate a "space-time" surface and mesh that had a double-armed spiral wave on it. The following code generates that. Its dependent on a rotation angle Theta which is not specified here: Plot3D[(60 Cos[ 2 ArcTan[y/(x + 0.00001)] - \[Theta] + 0.544331 Sqrt[x^2 + y^2]])/( 20 + Sqrt[x^2 + y^2]), {x, -45, 45}, {y, -45, 45}, PlotPoints -> 100, Mesh -> 20, MeshStyle -> {RGBColor[.5, .5, .5, .5]}, Boxed -> False, BoxRatios -> Automatic, Axes -> False, PlotStyle -> {RGBColor[.3, .3, .8]}, ImageSize -> {1024, 768}, Lighting -> {{"Directional", White, ImageScaled[{0, 0, 2.}]}}, ViewPoint -> {-0.011, -3.043, 1.479}, Background -> Black, BoundaryStyle -> RGBColor[.5, .5, .5, .5]] I wanted to overlay 2 stars or black holes on top of the surface. Combining the above with this overlay and giving a value to the angle Theta we get: With[{\[Theta] = 0}, Show[Plot3D[( 60 Cos[2 ArcTan[y/(x + 0.00001)] - \[Theta] + 0.544331 Sqrt[x^2 + y^2]])/( 20 + Sqrt[x^2 + y^2]), {x, -45, 45}, {y, -45, 45}, PlotPoints -> 100, Mesh -> 20, MeshStyle -> {RGBColor[.5, .5, .5, .5]}, Boxed -> False, BoxRatios -> Automatic, Axes -> False, PlotStyle -> {RGBColor[.3, .3, .8]}, ImageSize -> {1024, 768}, Lighting -> {{"Directional", White, ImageScaled[{0, 0, 2.}]}}, ViewPoint -> {-0.011, -3.043, 1.479}, Background -> Black, BoundaryStyle -> RGBColor[.5, .5, .5, .5]], Graphics3D[{Directive[Hue[.58, 0, 1], Lighting -> Join[{{"Ambient", Black}}, Table[{"Directional", Hue[.58, .5, 1], ImageScaled[{Sin[x], Cos[x], -.5}]}, {x, 0, 2 Pi - 2 Pi/8, 2 Pi/8}]]], Sphere[{2 Cos[\[Theta] - \[Pi]/2], 2 Sin[\[Theta] - \[Pi]/2], 3}, 1], Sphere[{Cos[\[Theta] + \[Pi]/2], Sin[\[Theta] + \[Pi]/2], 3}, 1]}], PlotRange -> All]] ![enter image description here][4] Next, I wanted to animate this to give the effect that the spiral arms are rotating outwards. That's done by incrementing the angle Theta and generating a list of frames that can then be exported. anim = Table[ Rasterize[ Show[Plot3D[( 60 Cos[2 ArcTan[y/(x + 0.00001)] - \[Theta] + 0.544331 Sqrt[x^2 + y^2]])/( 20 + Sqrt[x^2 + y^2]), {x, -45, 45}, {y, -45, 45}, PlotPoints -> 100, Mesh -> 20, MeshStyle -> {RGBColor[.5, .5, .5, .5]}, Boxed -> False, BoxRatios -> Automatic, Axes -> False, PlotStyle -> {RGBColor[.3, .3, .8]}, ImageSize -> {800, 450}, Lighting -> {{White, ImageScaled[{0, 0, 2.}]}}, ViewPoint -> {-0.011, -3.043, 1.479}, Background -> RGBColor[0, 0, 0], BoundaryStyle -> Gray], Graphics3D[{Directive[Hue[.58, 0, 1], Lighting -> Join[{{"Ambient", Black}}, Table[{"Directional", Hue[.58, .5, 1], ImageScaled[{Sin[x], Cos[x], -.5}]}, {x, 0, 2 Pi - 2 Pi/8, 2 Pi/8}]]], Sphere[{2 Cos[\[Theta] - \[Pi]/2], 2 Sin[\[Theta] - \[Pi]/2], 3}, 1], Sphere[{Cos[\[Theta] + \[Pi]/2], Sin[\[Theta] + \[Pi]/2], 3}, 1]}], PlotRange -> All]], {\[Theta], 0, 2 \[Pi], .1}]; And then to export it to an animated GIF: Export["GravityWave.gif", anim] The result is the animation at the top of this post. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif.com-optimize%283%29.gif&userId=20103 [2]: https://www.youtube.com/watch?v=WiNKulqt0SE [3]: http://lisa.nasa.gov/ [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gravitywave60.png&userId=25355 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=GravityWave.gif&userId=25355 Jeffrey Bryant 2016-02-10T19:35:05Z