(************** Content-type: application/mathematica ************** CreatedBy='Mathematica 5.0' Mathematica-Compatible Notebook This notebook can be used with any Mathematica-compatible application, such as Mathematica, MathReader or Publicon. The data for the notebook starts with the line containing stars above. To get the notebook into a Mathematica-compatible application, do one of the following: * Save the data starting with the line of stars above into a file with a name ending in .nb, then open the file inside the application; * Copy the data starting with the line of stars above to the clipboard, then use the Paste menu command inside the application. Data for notebooks contains only printable 7-bit ASCII and can be sent directly in email or through ftp in text mode. Newlines can be CR, LF or CRLF (Unix, Macintosh or MS-DOS style). NOTE: If you modify the data for this notebook not in a Mathematica- compatible application, you must delete the line below containing the word CacheID, otherwise Mathematica-compatible applications may try to use invalid cache data. For more information on notebooks and Mathematica-compatible applications, contact Wolfram Research: web: http://www.wolfram.com email: info@wolfram.com phone: +1-217-398-0700 (U.S.) Notebook reader applications are available free of charge from Wolfram Research. *******************************************************************) (*CacheID: 232*) (*NotebookFileLineBreakTest NotebookFileLineBreakTest*) (*NotebookOptionsPosition[ 70268, 1767]*) (*NotebookOutlinePosition[ 71250, 1798]*) (* CellTagsIndexPosition[ 71206, 1794]*) (*WindowFrame->Normal*) Notebook[{ Cell[CellGroupData[{ Cell[" Saari's Conjecture for the Three-Body Problem", "Title"], Cell["\<\ This notebook contains computations supporting the paper, \"A proof \ of Saari's conjecture for the three-body problem in R^d\", by R. Moeckel. \ The notebook is divided into sections similar to the ones in the paper. You \ should be able to follow along, executing the commands to reproduce and check \ all the computations.\ \>", "Text"], Cell[CellGroupData[{ Cell["Lagrange's Equations of Motion", "Section"], Cell["\<\ In this section, the equations of motion for mutual distances first \ derived by Lagrange are calculated. In addition, the moment of intertia and \ constants of motion are calculated. The form of the equations and the \ derivation of the angular momentum follows the works of Albouy-Chenciner and \ Albouy referenced in section 2 of the paper.\ \>", "Text"], Cell[CellGroupData[{ Cell["Differential Equations", "Subsection"], Cell["\<\ Define subscript cyclic permutation functions and missing index \ function.\ \>", "Text"], Cell[BoxData[{ \(j[i_]\ := \ 1 + Mod[i, 3]\), "\[IndentingNewLine]", \(k[i_]\ := \ 1 + Mod[i + 1, 3]\), "\[IndentingNewLine]", \(c[a_, b_]\ := \ \(Complement[{1, 2, 3}, {a, b}]\)[\([1]\)]\), "\[IndentingNewLine]", \(Table[{i, j[i], k[i]}, {i, 1, 3}] // TableForm\), "\[IndentingNewLine]", \(Table[{i, j, c[i, j]}, {i, 1, 2}, {j, i + 1, 3}]\)}], "Input"], Cell["\<\ Force the variables rij, vij, etc. to be symmetric. In this \ notebook, the variable r[1,3] is used instead of r[3,1] as in the paper. \ sp[i,j] and sdp[i,j] stand for s' and s'' in the paper.\ \>", "Text"], Cell[BoxData[{ \(r[i_, i_] := 0\), "\[IndentingNewLine]", \(r[i_, j_] := r[j, i] /; j < i\), "\[IndentingNewLine]", \(v[i_, i_] := 0\), "\[IndentingNewLine]", \(v[i_, j_] := v[j, i] /; j < i\), "\[IndentingNewLine]", \(s[i_, i_] := 0\), "\[IndentingNewLine]", \(s[i_, j_] := s[j, i] /; j < i\), "\[IndentingNewLine]", \(sp[i_, i_] := 0\), "\[IndentingNewLine]", \(sp[i_, j_] := sp[j, i] /; j < i\), "\[IndentingNewLine]", \(sdp[i_, i_] := 0\), "\[IndentingNewLine]", \(sdp[i_, j_] := sdp[j, i] /; j < i\)}], "Input"], Cell[TextData[{ "The function ", StyleBox["S", FontFamily->"Symbol"], "[i,j] used to define the equations of motion" }], "Text"], Cell[BoxData[ \(Sigma[a_, b_]\ := \ \((m[a] + m[b])\)/r[a, b]^3\ + 1/2\ m[c[a, b]]*\((1/r[j[a], j[b]]^3 + 1/r[k[a], k[b]]^3)\)\)], "Input"], Cell["\<\ Differential equations of Lagrange for s[i,j], sp[i,j],sdp[i,j], \ rho\ \>", "Text"], Cell[BoxData[{ \(\(\(Off[General::spell, General::spell1]\)\(\ \)\( (*turn\ off\ annoying\ spelling\ checker\ \ *) \)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(sdot[a_, b_]\ := \ 2*sp[a, b]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(spdot[a_, b_]\ := \ sdp[a, b] - s[a, b]*Sigma[a, b] - m[c[a, b]]*\((s[k[a], k[b]] - s[j[a], j[b]])\)*\((r[k[a], k[b]]^\((\(-3\))\) - r[j[a], j[b]]^\((\(-3\))\))\)/2\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(sdpdot1[a_, b_]\ := \(-2\)*sp[a, b]*Sigma[a, b] - m[c[a, b]]*\((sp[k[a], k[b]] - sp[j[a], j[b]] - rho)\)*\((r[k[a], k[b]]^\((\(-3\))\) - r[j[a], j[b]]^\((\(-3\))\))\)\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(rhodot = \ 1/2 Det[{{1, 1, 1}, \[IndentingNewLine]{m[ 1] \((r[2, 3]^2 - r[1, 2]^2 - r[1, 3]^2)\), m[2] \((r[1, 3]^2 - r[1, 2]^2 - r[2, 3]^2)\), m[3] \((r[1, 2]^2 - r[2, 3]^2 - r[1, 3]^2)\)}, \[IndentingNewLine]{1/r[2, 3]^3, 1/r[1, 3]^3, 1/r[1, 2]^3}}] // Factor;\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(lagrangeodes\ = \ {2*sp[1, 2], 2*sp[1, 3], 2*sp[2, 3], spdot[1, 2], spdot[1, 3], spdot[2, 3], sdpdot1[1, 2], sdpdot1[1, 3], sdpdot1[2, 3], rhodot}\)}], "Input"], Cell["\<\ Differential equation for the 10 variables r[i,j], v[i,j], \ spdot[i,j] , rho. Introduce a substitution for s[i,j] and sp[i,j] in favor \ of r[i,j], v[i,j].\ \>", "Text"], Cell[BoxData[{ \(\(rvsub\ = \ {s[i_, j_] \[Rule] r[i, j]^2, sp[i_, j_] \[Rule] r[i, j]*v[i, j]};\)\), "\[IndentingNewLine]", \(rdot[a_, b_]\ := \ v[a, b]\), "\[IndentingNewLine]", \(vdot[a_, b_]\ := \ \((spdot[a, b] - v[a, b]^2)\)/\((r[a, b])\) /. rvsub\), "\[IndentingNewLine]", \(\(\(sdpdot[a_, b_] := sdpdot1[a, b] /. rvsub\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(vdot[1, 2] // Factor\), "\[IndentingNewLine]", \(vdot[1, 3] // Factor\), "\[IndentingNewLine]", \(vdot[2, 3] // Factor\), "\[IndentingNewLine]", \(sdpdot[1, 2] // Factor\), "\[IndentingNewLine]", \(sdpdot[1, 3] // Factor\), "\[IndentingNewLine]", \(sdpdot[2, 3] // Factor\), "\[IndentingNewLine]", \(rhodot // Factor\)}], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Examples -- Relative Equilibria", "Subsection"], Cell["\<\ This section is not really part of the paper but it checks the \ Lagrange ODE's for the equilateral triangle relative equilibrium and for the \ equal mass isosceles relative equilibria in R^4 of Albouy and \ Chenciner.\ \>", "Text"], Cell["\<\ Use the differential equations to check the relative equilibria. \ Starting from vectors xi and yi representing the Cartesian positions and \ velocities, we calculate Lagrange's variables and put them into the \ differential equations. Here is the equilateral triangle.\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[{ \(\(\(x\ = \ {{0, 0, 0, 0}, {1, 0, 0, 0}, {1/2, Sqrt[3]/2, 0, 0}} // Transpose;\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(angvel\ = \ {{0, \(-a\), 0, 0}, {a, 0, 0, 0}, {0, 0, 0, \(-b\)}, {0, 0, b, 0}};\)\), "\[IndentingNewLine]", \(\(\(y\ = angvel . x;\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(beta\ = \ Transpose[x] . x;\)\), "\[IndentingNewLine]", \(\(delta\ = \ Transpose[y] . y;\)\), "\[IndentingNewLine]", \(\(gamma\ = \ \ \((Transpose[x] . y + \ Transpose[y] . x)\)/ 2;\)\), "\[IndentingNewLine]", \(\(rhoo\ = \ \((Transpose[x] . y - \ Transpose[y] . x)\)/ 2;\)\), "\[IndentingNewLine]", \(\(\(mu\ = {{m[1] \((m[2] + m[3])\), \(-m[1]\) m[2], \(-m[1]\) m[3]}, {\(-m[1]\) m[2], m[2] \((m[1] + m[3])\), \(-m[2]\) m[3]}, {\(-m[1]\) m[3], \(-m[2]\) m[3], m[3] \((m[1] + m[2])\)}}/\((m[1] + m[2] + m[3])\) /. m[i_] \[Rule] 1;\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(xx[i_, j_] := \ \(Transpose[x]\)[\([i]\)] - \ \(Transpose[ x]\)[\([j]\)];\)\), "\[IndentingNewLine]", \(\(yy[i_, j_] := \ \(Transpose[y]\)[\([i]\)] - \ \(Transpose[ y]\)[\([j]\)];\)\), "\[IndentingNewLine]", \(\(s0[i_, j_]\ := \ xx[i, j] . xx[i, j];\)\), "\[IndentingNewLine]", \(\(sp0[i_, j_]\ := \ xx[i, j] . yy[i, j];\)\), "\[IndentingNewLine]", \(sdp0[i_, j_]\ := \ yy[i, j] . yy[i, j]\), "\[IndentingNewLine]", \(\(\(lagrangesub\ = \ {s[1, 2] \[Rule] s0[1, 2], s[1, 3] \[Rule] s0[1, 3], s[2, 3] \[Rule] s0[2, 3], r[1, 2]^2 \[Rule] s0[1, 2], r[1, 3]^2 \[Rule] s0[1, 3], r[2, 3]^2 \[Rule] s0[2, 3], \[IndentingNewLine]r[1, 2] \[Rule] Sqrt[s0[1, 2]], r[1, 3] \[Rule] Sqrt[s0[1, 3]], r[2, 3] \[Rule] Sqrt[s0[2, 3]], sp[1, 2] \[Rule] sp0[1, 2], sp[1, 3] \[Rule] sp0[1, 3], sp[2, 3] \[Rule] sp0[2, 3], sdp[1, 2] \[Rule] sdp0[1, 2], sdp[1, 3] \[Rule] sdp0[1, 3], sdp[2, 3] \[Rule] sdp0[2, 3], rho \[Rule] 2*\((rhoo[\([1, 2]\)] - rhoo[\([1, 3]\)] + rhoo[\([2, 3]\)])\)};\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(lagrangeodes /. lagrangesub // Factor\)}], "Input"], Cell[BoxData[ \({0, 0, 0, a\^2 - m[1] - m[2] - m[3], a\^2 - m[1] - m[2] - m[3], a\^2 - m[1] - m[2] - m[3], 0, 0, 0, 0}\)], "Output"] }, Open ]], Cell["\<\ Thus if we choose the angular velocity a appropriately, we get a \ solution.\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[{ \(\(x\ = \ {{2, 0, 0, 0}, {\(-1\), 0, q, 0}, {\(-1\), 0, \(-q\), 0}} // Transpose;\)\[IndentingNewLine]\), "\[IndentingNewLine]", \(\(angvel\ = \ {{0, \(-a\), 0, 0}, {a, 0, 0, 0}, {0, 0, 0, \(-b\)}, {0, 0, b, 0}};\)\), "\[IndentingNewLine]", \(\(y\ = angvel . x;\)\[IndentingNewLine]\), "\[IndentingNewLine]", \(\(beta\ = \ Transpose[x] . x;\)\), "\[IndentingNewLine]", \(\(delta\ = \ Transpose[y] . y;\)\), "\[IndentingNewLine]", \(\(gamma\ = \ \ \((Transpose[x] . y + \ Transpose[y] . x)\)/ 2;\)\), "\[IndentingNewLine]", \(\(rhoo\ = \ \((Transpose[x] . y - \ Transpose[y] . x)\)/ 2;\)\), "\[IndentingNewLine]", \(\(mu\ = {{m[1] \((m[2] + m[3])\), \(-m[1]\) m[2], \(-m[1]\) m[3]}, {\(-m[1]\) m[2], m[2] \((m[1] + m[3])\), \(-m[2]\) m[3]}, {\(-m[1]\) m[3], \(-m[2]\) m[3], m[3] \((m[1] + m[2])\)}}/\((m[1] + m[2] + m[3])\) /. m[i_] \[Rule] 1;\)\[IndentingNewLine]\), "\[IndentingNewLine]", \(\(xx[i_, j_] := \ \(Transpose[x]\)[\([i]\)] - \ \(Transpose[ x]\)[\([j]\)];\)\), "\[IndentingNewLine]", \(\(yy[i_, j_] := \ \(Transpose[y]\)[\([i]\)] - \ \(Transpose[ y]\)[\([j]\)];\)\), "\[IndentingNewLine]", \(\(s0[i_, j_]\ := \ xx[i, j] . xx[i, j];\)\), "\[IndentingNewLine]", \(\(sp0[i_, j_]\ := \ xx[i, j] . yy[i, j];\)\), "\[IndentingNewLine]", \(sdp0[i_, j_]\ := \ yy[i, j] . yy[i, j]\), "\[IndentingNewLine]", \(\(lagrangesub\ = \ {s[1, 2] \[Rule] s0[1, 2], s[1, 3] \[Rule] s0[1, 3], s[2, 3] \[Rule] s0[2, 3], r[1, 2]^k_ :> s0[1, 2]^k /; EvenQ[k], r[1, 3]^k_ :> s0[1, 3]^k /; EvenQ[k], r[2, 3]^k_ :> s0[2, 3]^k /; EvenQ[k], r[1, 2]^k_ :> r[1, 2] s0[1, 2]^k /; OddQ[k], r[1, 3]^k_ :> r[1, 3] s0[1, 3]^k /; OddQ[k], r[2, 3]^k_ :> r[2, 3] s0[2, 3]^k /; OddQ[k], \[IndentingNewLine]sp[1, 2] \[Rule] sp0[1, 2], sp[1, 3] \[Rule] sp0[1, 3], sp[2, 3] \[Rule] sp0[2, 3], sdp[1, 2] \[Rule] sdp0[1, 2], sdp[1, 3] \[Rule] sdp0[1, 3], sdp[2, 3] \[Rule] sdp0[2, 3], rho \[Rule] 2*\((rhoo[\([1, 2]\)] - rhoo[\([1, 3]\)] + rhoo[\([2, 3]\)])\)};\)\[IndentingNewLine]\), \ "\[IndentingNewLine]", \({r[1, 2]^2, r[1, 3]^2} /. lagrangesub // Factor\), "\[IndentingNewLine]", \(isosodes\ = \ \(\(lagrangeodes /. lagrangesub\) /. {r[1, 2] \[Rule] r[1, 3], m[i_] \[Rule] 1, r[2, 3] \[Rule] 2*q} // Factor\) // Numerator\[IndentingNewLine]\), "\[IndentingNewLine]", \(\)}], "Input"], Cell[BoxData[ \({\((9 + q\^2)\)\^2, \((9 + q\^2)\)\^2}\)], "Output"], Cell[BoxData[ \({0, 0, 0, \(-729\) - 243\ q\^2 + 104976\ a\^2\ q\^3 - 27\ q\^4 + 34992\ a\^2\ q\^5 + 11664\ b\^2\ q\^5 - q\^6 + 3888\ a\^2\ q\^7 + 3888\ b\^2\ q\^7 + 144\ a\^2\ q\^9 + 432\ b\^2\ q\^9 + 16\ b\^2\ q\^11 - 432\ q\^3\ r[1, 3] - 16\ q\^5\ r[1, 3], \(-729\) - 243\ q\^2 + 104976\ a\^2\ q\^3 - 27\ q\^4 + 34992\ a\^2\ q\^5 + 11664\ b\^2\ q\^5 - q\^6 + 3888\ a\^2\ q\^7 + 3888\ b\^2\ q\^7 + 144\ a\^2\ q\^9 + 432\ b\^2\ q\^9 + 16\ b\^2\ q\^11 - 432\ q\^3\ r[1, 3] - 16\ q\^5\ r[1, 3], \(-729\) - 243\ q\^2 - 27\ q\^4 + 11664\ b\^2\ q\^5 - q\^6 + 3888\ b\^2\ q\^7 + 432\ b\^2\ q\^9 + 16\ b\^2\ q\^11 - 16\ q\^5\ r[1, 3], 0, 0, 0, 0}\)], "Output"] }, Open ]], Cell["\<\ These equations can be solved for the angular velocities a and b to \ get a solution.\ \>", "Text"], Cell[BoxData[{ \(isosodes[\([6]\)] /. b^2 \[Rule] bsq\), "\[IndentingNewLine]", \(bsqsol\ = \ \(Solve[% \[Equal] 0, bsq]\)[\([1]\)]\), "\[IndentingNewLine]", \(\(\(\(isosodes[\([4]\)] /. b^2 \[Rule] bsq\) /. bsqsol\) /. a^2 \[Rule] asq // Factor\) // Numerator\), "\[IndentingNewLine]", \(\(Solve[% \[Equal] 0, asq]\)[\([1]\)]\)}], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Integrals of Motion", "Subsection"], Cell["\<\ The potential, moment of inertia and twice the kinetic energy\ \>", \ "Text"], Cell[BoxData[{ \(\(\(U\ = \ m[1]*m[2]/r[1, 2]\ + \ m[1]*m[3]/r[1, 3]\ + \ m[2]*m[3]/r[2, 3]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(Iner\ = \ \((m[1]*m[2]*r[1, 2]^2\ + \ m[1]*m[3]*r[1, 3]^2\ + \ m[2]*m[3]*r[2, 3]^2)\)/\((m[1] + m[2] + m[3])\)\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(K\ = \ \((m[1]*m[2]*sdp[1, 2]\ + \ m[1]*m[3]*sdp[1, 3]\ + \ m[2]*m[3]*sdp[2, 3])\)/\((m[1] + m[2] + m[3])\)\)}], "Input"], Cell["\<\ Next calculate the integrals of angular momentum, following the \ method of in Albouy-Chenciner. Begin with the 6 x 6 matrix called E in the \ paper. Here the variable rho[1,3] corresponds to -rho[3,1] in the \ paper.\ \>", "Text"], Cell[BoxData[{ \(\(\(Emat\ = \ {{0, \(-s[1, 2]\)/2, \(-s[1, 3]\)/2, 0, \(-sp[1, 2]\)/2 + rho[1, 2], \(-sp[1, 3]\)/2 + rho[1, 3]}, \[IndentingNewLine]{\(-s[1, 2]\)/2, 0, \(-s[2, 3]\)/2, \(-sp[1, 2]\)/2 - rho[1, 2], 0, \(-sp[2, 3]\)/2 + rho[2, 3]}, \[IndentingNewLine]{\(-s[1, 3]\)/ 2, \(-s[2, 3]\)/2, 0, \(-sp[1, 3]\)/2 - rho[1, 3], \(-sp[2, 3]\)/2 - rho[2, 3], 0}, \[IndentingNewLine]{0, \(-sp[1, 2]\)/2 - rho[1, 2], \(-sp[1, 3]\)/2 - rho[1, 3], 0, \(-sdp[1, 2]\)/2, \(-sdp[1, 3]\)/ 2}, \[IndentingNewLine]{\(-sp[1, 2]\)/2 + rho[1, 2], 0, \(-sp[2, 3]\)/2 - rho[2, 3], \(-sdp[1, 2]\)/2, 0, \(-sdp[2, 3]\)/2}, \[IndentingNewLine]{\(-sp[1, 3]\)/2 + rho[1, 3], \(-sp[2, 3]\)/2 + rho[2, 3], 0, \(-sdp[1, 3]\)/2, \(-sdp[2, 3]\)/2, 0}};\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(Emat2\ = \ {{0, \(-s[1, 2]\)/2, \(-s[1, 3]\)/2, 0, \(-sp[1, 2]\) + rho[1, 2], \(-sp[1, 3]\) + rho[1, 3]}, \[IndentingNewLine]{\(-s[1, 2]\)/2, 0, \(-s[2, 3]\)/2, \(-sp[1, 2]\) - rho[1, 2], 0, \(-sp[2, 3]\) + rho[2, 3]}, \[IndentingNewLine]{\(-s[1, 3]\)/ 2, \(-s[2, 3]\)/2, 0, \(-sp[1, 3]\) - rho[1, 3], \(-sp[2, 3]\) - rho[2, 3], 0}, \[IndentingNewLine]{0, \(-sp[1, 2]\) - rho[1, 2], \(-sp[1, 3]\) - rho[1, 3], 0, \(-sdp[1, 2]\)/2, \(-sdp[1, 3]\)/ 2}, \[IndentingNewLine]{\(-sp[1, 2]\) + rho[1, 2], 0, \(-sp[2, 3]\) - rho[2, 3], \(-sdp[1, 2]\)/2, 0, \(-sdp[2, 3]\)/2}, \[IndentingNewLine]{\(-sp[1, 3]\) + rho[1, 3], \(-sp[2, 3]\) + rho[2, 3], 0, \(-sdp[1, 3]\)/2, \(-sdp[2, 3]\)/2, 0}};\)\[IndentingNewLine]\[IndentingNewLine]\), "\ \[IndentingNewLine]", \(MatrixForm[Emat]\)}], "Input"], Cell["The 6 x 6 matrix omega_mu", "Text"], Cell[BoxData[{ \(\(omegamumat\ = \ {{0, 0, 0, \(-m[1]\) \((m[2] + m[3])\), m[1] m[2], m[1] m[3]}, {0, 0, 0, m[1] m[2], \(-m[2]\) \((m[1] + m[3])\), m[2] m[3]}, {0, 0, 0, m[1] m[3], m[2] m[3], \(-m[3]\) \((m[1] + m[2])\)}, {m[ 1] \((m[2] + m[3])\), \(-m[1]\) m[2], \(-m[1]\) m[3], 0, 0, 0}, {\(-m[1]\) m[2], m[2] \((m[1] + m[3])\), \(-m[2]\) m[3], 0, 0, 0}, {\(-m[1]\) m[3], \(-m[2]\) m[3], m[3] \((m[1] + m[2])\), 0, 0, 0}}/\((m[1] + m[2] + m[3])\);\)\), "\[IndentingNewLine]", \(omegamumat // MatrixForm\)}], "Input"], Cell["\<\ Calculate the product omega_mu * E and restrict it to the subspace \ P x P as described in section 2 of my paper. The vectors e1 -- e4 give an \ orthogonal basis for this subspace. So one can calculate the matrix of the \ restriction of omega_mu * E in a simple way.\ \>", "Text"], Cell[BoxData[ \(\(\(\[IndentingNewLine]\)\(\(e1 = \ {1, \(-1\), 0, 0, 0, 0};\)\[IndentingNewLine] \(e2\ = \ {1, 1, \(-2\), 0, 0, 0};\)\[IndentingNewLine] \(e3 = \ {0, 0, 0, 1, \(-1\), 0};\)\[IndentingNewLine] \(e4 = \ {0, 0, 0, 1, 1, \(-2\)};\)\[IndentingNewLine]\[IndentingNewLine] \(muEmat4\ = \ {e1/\((e1 . e1)\), e2/\((e2 . e2)\), e3/\((e3 . e3)\), e4/\((e4 . e4)\)} . omegamumat . Emat . Transpose[{e1, e2, e3, e4}];\)\[IndentingNewLine]\[IndentingNewLine] \(muEmat4 // Factor\) // MatrixForm\)\)\)], "Input"], Cell["\<\ Now find the characteristic polynomial and read off the two angular \ momentum integrals.\ \>", "Text"], Cell[BoxData[{ \(\(cp\ = \ CharacteristicPolynomial[muEmat4, z];\)\), "\[IndentingNewLine]", \(\(c0 = \ cp /. z \[Rule] 0 // Factor;\)\), "\[IndentingNewLine]", \(\(c1 = \ Coefficient[cp, z^2] // Factor;\)\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ It should be the case that the variables rho[i,j] only appear in \ the combination rho = (rho[1,2] - rho[1,3] + rho[2,3])/2. Making the \ following substution verifies this and provides the simplified formulas for \ c0 and c1.\ \>", "Text"], Cell[BoxData[{ \(c0\ = \ c0 /. rho[1, 2] \[Rule] rho/2 + rho[1, 3] - rho[2, 3] // Factor\), "\[IndentingNewLine]", \(c1\ = \ c1 /. rho[1, 2] \[Rule] rho/2 + rho[1, 3] - rho[2, 3] // Factor\)}], "Input"], Cell["\<\ Try to find simpler expressions for these, to put in the Appendix \ of the paper. Begin with c1. This is essentially the total angular momentum \ from Albouy's paper. Introduce the quantities phi and psi from that \ paper\ \>", "Text"], Cell[BoxData[{ \(psi\ = \ \(-\((s[1, 2]\ \((sdp[1, 2] - sdp[1, 3] - sdp[2, 3])\) - s[2, 3]\ \((sdp[1, 2] + sdp[1, 3] - sdp[2, 3])\) - s[1, 3]\ \((sdp[1, 2] - sdp[1, 3] + sdp[2, 3])\))\)\) // Expand\), "\[IndentingNewLine]", \(phi\ = \ \(-\((sp[1, 2] - sp[1, 3])\)\^2\) + 2\ \((sp[1, 2] + sp[1, 3])\)\ sp[2, 3] - sp[2, 3]\^2 // Expand\)}], "Input"], Cell["\<\ Here are the moment of intertia, half its time derivative and half \ the kinetic energy. Then there is a nice formula for c1\ \>", "Text"], Cell[BoxData[{ \(\(I1 = \((m[1] m[2]*s[1, 2] + m[1] m[3]*s[1, 3] + m[2] m[3]*s[2, 3])\)/\((m[1] + m[2] + m[3])\);\)\), "\[IndentingNewLine]", \(\(J1 = \((m[1] m[2]*sp[1, 2] + m[1] m[3]*sp[1, 3] + m[2] m[3]*sp[2, 3])\)/\((m[1] + m[2] + m[3])\);\)\), "\[IndentingNewLine]", \(\(K1 = \((m[1] m[2]*sdp[1, 2] + m[1] m[3]*sdp[1, 3] + m[2] m[3]*sdp[2, 3])\)/\((m[1] + m[2] + m[3])\);\)\), "\[IndentingNewLine]", \(\(\(IJKdet\ = \ I1*K1 - J1^2;\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(c1simp\ = \ m[1] m[2] m[3]/\((2 \((m[1] + m[2] + m[3])\))\) \((phi - psi + rho^2)\)\ + IJKdet\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["Verify that this is the same as c1.", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(c1 - c1simp // Factor\)], "Input"], Cell[BoxData[ \(0\)], "Output"] }, Open ]], Cell["\<\ Note that for constant moment of inertia solutions we will have \ IJKdet = c so there will be an even simpler formula\ \>", "Text"], Cell[BoxData[ \(\(\(c1extrasimp\ \ = \ m[1] m[2] m[3]/\((2 \((m[1] + m[2] + m[3])\))\) \((phi - psi + rho^2)\)\ + \ c\)\(\[IndentingNewLine]\) \)\)], "Input"], Cell["\<\ It turns out that most of the rho-dependence of C0 can be expressed \ by the same term (phi-psi+rho^2) which occurs in C1\ \>", "Text"], Cell[BoxData[{ \(Coefficient[4*c0, rho^4] // FullSimplify\), "\[IndentingNewLine]", \(Coefficient[4*c0, rho^2] // FullSimplify\), "\[IndentingNewLine]", \(Coefficient[\((c1extrasimp - c)\)^2, rho^4] // FullSimplify\), "\[IndentingNewLine]", \(\(\(Coefficient[\((c1extrasimp - c)\)^2, rho^2] // FullSimplify\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ So here is an alternative angular momentum integral valid for \ constant moment of intertia solutions\ \>", "Text"], Cell[BoxData[ \(d0\ = \ 4 c0 - \((c1extrasimp - c)\)^2 // Factor\)], "Input"], Cell["\<\ The new invariant is linear in rho. The coefficient of rho is a \ multiple of a simple determinant in the variables s, sp and sdp\ \>", "Text"], Cell[BoxData[{ \(d01\ = \ Coefficient[d0, rho] // FullSimplify\), "\[IndentingNewLine]", \(sdeterminant\ = \ Det[{{s[1, 2], s[1, 3], s[2, 3]}, {sp[1, 2], sp[1, 3], sp[2, 3]}, {sdp[1, 2], sdp[1, 3], sdp[2, 3]}}] // FullSimplify\), "\[IndentingNewLine]", \(d01\ - \ 2*m[1]^2 m[2]^2 m[3]^2/\((m[1] + m[2] + m[3])\)^2*sdeterminant // Factor\)}], "Input"], Cell["\<\ The last term in the formula for C0 in the paper involves a \ polynomial P\ \>", "Text"], Cell[BoxData[ \(P\ = \ 2 \((s[2, 3] sdp[1, 3] + s[1, 3] sdp[2, 3])\) sp[1, 2]^2 + \[IndentingNewLine]2 \((s[2, 3] sdp[1, 2] + s[1, 2] sdp[2, 3])\) sp[1, 3]^2 + \[IndentingNewLine]2 \((s[1, 2] sdp[1, 3] + s[1, 3] sdp[1, 2])\) sp[2, 3]^2 - \[IndentingNewLine]2 \((s[2, 3] \((sdp[1, 2] + sdp[1, 3] - sdp[2, 3])\) + sdp[2, 3] \((s[1, 2] + s[1, 3] - s[2, 3])\))\) sp[1, 2] sp[1, 3] - \[IndentingNewLine]2 \((s[1, 3] \((sdp[1, 2] - sdp[1, 3] + sdp[2, 3])\) + sdp[1, 3] \((s[1, 2] - s[1, 3] + s[2, 3])\))\) sp[1, 2] sp[2, 3] - \[IndentingNewLine]2 \((s[1, 2] \((\(-sdp[1, 2]\) + sdp[1, 3] + sdp[2, 3])\) + sdp[1, 2] \((\(-s[1, 2]\) + s[1, 3] + s[2, 3])\))\) sp[2, 3] sp[1, 3] + \ sdp[1, 3] sdp[2, 3] s[1, 2]^2\ - \ \((sdp[1, 2] + sdp[1, 3] - sdp[2, 3])\) sdp[2, 3] s[1, 2] s[1, 3] + \ sdp[1, 2] sdp[2, 3] s[1, 3]^2\ - \ \((sdp[1, 2] - sdp[1, 3] + sdp[2, 3])\) sdp[1, 3] s[1, 2] s[2, 3] + \ sdp[1, 3] sdp[1, 2] s[2, 3]^2\ - \ \((\(-sdp[1, 2]\) + sdp[1, 3] + sdp[2, 3])\) sdp[1, 2] s[2, 3] s[1, 3]\)], "Input"], Cell["Verify the formula for C0 in the paper.", "Text"], Cell[BoxData[ \(c0\ - \ \((m[1]^2 m[2]^2 m[3]^2/\((16 \((m[1] + m[2] + m[3])\)^2)\) \((phi - psi + rho^2)\)^2 + rho*m[1]^2 m[2]^2 m[3]^2/\((2 \((m[1] + m[2] + m[3])\)^2)\)* sdeterminant - \ m[1]^2 m[2]^2 m[3]^2/\((4*\((m[1] + m[2] + m[3])\)^2)\)*P)\) // Factor\)], "Input"], Cell["\<\ Finally, make the substitutions for s[i,j] and sp[i,j] in favor of \ r[i,j], v[i,j] to obtain the final formulas. It does no harm to drop the \ denominators which are nonzero constants and to divide c0 by \ m1^2m2^2m3^2\ \>", "Text"], Cell[BoxData[{ \(d0 = \(d0 /. {s[i_, j_] \[Rule] r[i, j]^2, sp[i_, j_] \[Rule] r[i, j] v[i, j]} // Factor\) // Numerator\), "\[IndentingNewLine]", \(d0 = d0[\([5]\)]\), "\[IndentingNewLine]", \(c1extrasimp = c1extrasimp /. {s[i_, j_] \[Rule] r[i, j]^2, sp[i_, j_] \[Rule] r[i, j] v[i, j]} // Factor\)}], "Input"], Cell["\<\ An example showing the angular momentum integrals in Cartesian \ coordinates. We calculate the angular momentum in two different ways. One \ involves a 4 x 4 Cartesian matrix (called Cmat here) as in Albouy-Chenciner. \ The other way is to convert to Lagrange coordinates and then substitute into \ the formulas above.\ \>", "Text"], Cell[BoxData[{ \(\(x\ = \ {{0, 0, 0, 0}, {1, 0, 0, 0}, {q3[1], q3[2], 0, 0}} // Transpose;\)\), "\[IndentingNewLine]", \(\(y\ = \ {{v1[1], v1[2], v1[3], v1[4]}, {v2[1], v2[2], v2[3], v2[4]}, {v3[1], v3[2], v3[3], v3[4]}} // Transpose;\)\[IndentingNewLine]\[IndentingNewLine]\), "\ \[IndentingNewLine]", \(\(beta\ = \ Transpose[x] . x;\)\), "\[IndentingNewLine]", \(\(delta\ = \ Transpose[y] . y;\)\), "\[IndentingNewLine]", \(\(gamma\ = \ \ \((Transpose[x] . y + \ Transpose[y] . x)\)/ 2;\)\), "\[IndentingNewLine]", \(\(rhoo\ = \ \((Transpose[x] . y - \ Transpose[y] . x)\)/ 2;\)\), "\[IndentingNewLine]", \(\(mu\ = {{m[1] \((m[2] + m[3])\), \(-m[1]\) m[2], \(-m[1]\) m[3]}, {\(-m[1]\) m[2], m[2] \((m[1] + m[3])\), \(-m[2]\) m[3]}, {\(-m[1]\) m[3], \(-m[2]\) m[3], m[3] \((m[1] + m[2])\)}}/\((m[1] + m[2] + m[3])\) /. m[i_] \[Rule] 1;\)\), "\[IndentingNewLine]", \(\(Cmat\ = \ y . mu . Transpose[x] - x . mu . Transpose[y];\)\), "\[IndentingNewLine]", \(Cmat // MatrixForm\[IndentingNewLine]\), "\[IndentingNewLine]", \(c0alt\ = \ \ Det[Cmat] // Factor\), "\[IndentingNewLine]", \(c1alt\ = \ \ Coefficient[CharacteristicPolynomial[Cmat, z], z^2] // Factor\[IndentingNewLine]\), "\[IndentingNewLine]", \(\(xx[i_, j_] := \ \(Transpose[x]\)[\([i]\)] - \ \(Transpose[ x]\)[\([j]\)];\)\), "\[IndentingNewLine]", \(\(yy[i_, j_] := \ \(Transpose[y]\)[\([i]\)] - \ \(Transpose[ y]\)[\([j]\)];\)\), "\[IndentingNewLine]", \(\(s0[i_, j_]\ := \ xx[i, j] . xx[i, j];\)\), "\[IndentingNewLine]", \(\(sp0[i_, j_]\ := \ xx[i, j] . yy[i, j];\)\), "\[IndentingNewLine]", \(sdp0[i_, j_]\ := \ yy[i, j] . yy[i, j]\), "\[IndentingNewLine]", \(\(angsub\ = \ {s[1, 2] \[Rule] s0[1, 2], s[1, 3] \[Rule] s0[1, 3], s[2, 3] \[Rule] s0[2, 3], sp[1, 2] \[Rule] sp0[1, 2], sp[1, 3] \[Rule] sp0[1, 3], sp[2, 3] \[Rule] sp0[2, 3], sdp[1, 2] \[Rule] sdp0[1, 2], sdp[1, 3] \[Rule] sdp0[1, 3], sdp[2, 3] \[Rule] sdp0[2, 3], rho[1, 2] \[Rule] rhoo[\([1, 2]\)], rho[1, 3] \[Rule] rhoo[\([1, 3]\)], rho[2, 3] \[Rule] rhoo[\([2, 3]\)], \[IndentingNewLine]rho \[Rule] 2*\((rhoo[\([1, 2]\)] - rhoo[\([1, 3]\)] + rhoo[\([2, 3]\)])\), m[i_] \[Rule] 1};\)\[IndentingNewLine]\), "\[IndentingNewLine]", \(c0 /. angsub // Factor\), "\[IndentingNewLine]", \(c1 /. angsub // Factor\[IndentingNewLine]\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ Note that the formula for c0 becomes a perfect square in Cartesian \ coordinates. This is because the matrix Cmat is antisymmetric and so its \ determinant is the square of the Pfaffian.\ \>", "Text"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["Equations for Constant Moment of Inertia Solutions", "Section"], Cell["\<\ In this section, the 10 equations satisfied by solution with \ constant moment of inertia will be computed. Then the variables v[i, j] and \ sdp[i, j] will be eliminated to get 5 equations in 5 unknowns. Begin by \ defining a function to calculate the time derivative of a function of these \ Lagrange variables using the chain rule.\ \>", "Text"], Cell[BoxData[ \(TimeDeriv[f_]\ := \ D[f, r[1, 2]]*v[1, 2]\ + \ \ D[f, r[1, 3]]*v[1, 3]\ + \ D[f, r[2, 3]]*v[2, 3]\ + \[IndentingNewLine]\ D[f, v[1, 2]]*vdot[1, 2]\ + \ \ D[f, v[1, 3]]*vdot[1, 3]\ + \ D[f, v[2, 3]]*vdot[2, 3]\ + \ D[f, sdp[1, 2]]*sdpdot[1, 2]\ + \ \ D[f, sdp[1, 3]]* sdpdot[1, 3]\ + \ D[f, sdp[2, 3]]*sdpdot[2, 3]\ + \[IndentingNewLine]D[f, rho]* rhodot\)], "Input"], Cell["\<\ Use the TimeDeriv function to find the time derivatives of the \ potential, moment of inertia.\ \>", "Text"], Cell[BoxData[{ \(ud\ = \ TimeDeriv[U] // Factor\), "\[IndentingNewLine]", \(id\ = \ TimeDeriv[Iner] // Factor\)}], "Input"], Cell["Here are their second time derivatives.", "Text"], Cell[BoxData[{ \(uddot\ = \ TimeDeriv[ud] // Factor\), "\[IndentingNewLine]", \(iddot\ = \ \ TimeDeriv[id] // Factor\)}], "Input"], Cell["\<\ The second time derivative iddot can be expressed in terms of K and \ U and so is not helpful.\ \>", "Text"], Cell[BoxData[ \(\((iddot/2\ - \((K - U)\))\) // Factor\)], "Input"], Cell["\<\ So the third and fourth derivatives of the potential will be \ used.\ \>", "Text"], Cell[BoxData[{ \(utdot\ = \ TimeDeriv[uddot] // Factor\), "\[IndentingNewLine]", \(uqdot\ = \ TimeDeriv[utdot] // Factor\)}], "Input"], Cell["\<\ Clear the denominators, since they are harmless and the derivatives \ will be set to zero.\ \>", "Text"], Cell[BoxData[{ \(\(uddot\ = \ Numerator[uddot];\)\), "\[IndentingNewLine]", \(\(utdot\ = \ Numerator[utdot];\)\), "\[IndentingNewLine]", \(\(uqdot\ = \ Numerator[uqdot];\)\)}], "Input"], Cell["\<\ Here are the 10 equations for constant moment of inertia solutions \ using the notation from section 3 of the paper. The two angular momentum \ constants are here called w0 and w1 (w0 is called delta_0 in the \ paper).\ \>", "Text"], Cell[BoxData[{ \(g1 = \ \(Iner\ - c // Factor\) // Numerator\), "\[IndentingNewLine]", \(g2 = \ \(U - 1 // Factor\) // Numerator\), "\[IndentingNewLine]", \(g3 = \ \(K - 1 // Factor\) // Numerator\), "\[IndentingNewLine]", \(g4\ = \ \(d0 - w0 // Factor\) // Numerator\), "\[IndentingNewLine]", \(g5\ = \(c1extrasimp\ - \ w1 // Factor\) // Numerator\), "\[IndentingNewLine]", \(g6 = \ \(id/2 // Factor\) // Numerator\), "\[IndentingNewLine]", \(g7 = \ \(ud // Factor\) // Numerator\), "\[IndentingNewLine]", \(g8 = \ uddot\), "\[IndentingNewLine]", \(g9 = \ utdot\), "\[IndentingNewLine]", \(g10 = uqdot\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ Determine which of the equations are linear in some \ variables,\ \>", "Text"], Cell[BoxData[{ \(Exponent[{g1, g2, g3, g4, g5, g6, g7, g8, g9, g10}, rho]\), "\[IndentingNewLine]", \(Exponent[{g1, g2, g3, g4, g5, g6, g7, g8, g9, g10}, sdp[1, 2]]\)}], "Input"], Cell["\<\ Try to eliminate the v[i,j]. Find the gradients of U and I and \ take a nonzero multiple of their cross product as the direction of the vector \ v.\ \>", "Text"], Cell[BoxData[{ \(udvec\ = \ Coefficient[g6, {v[1, 2], v[1, 3], v[2, 3]}]\), "\[IndentingNewLine]", \(idvec\ = \ Coefficient[g7, {v[1, 2], v[1, 3], v[2, 3]}]\), "\[IndentingNewLine]", \(vdirec\ = \ {udvec[\([2]\)]*idvec[\([3]\)] - udvec[\([3]\)]*idvec[\([2]\)], \[IndentingNewLine]udvec[\([3]\)]* idvec[\([1]\)] - udvec[\([1]\)]*idvec[\([3]\)], \[IndentingNewLine]udvec[\([1]\)]* idvec[\([2]\)] - udvec[\([2]\)]*idvec[\([1]\)]} // Factor\), "\[IndentingNewLine]", \(vdirec\ = \ vdirec/\((m[1]*m[2]*m[3])\) // Factor\)}], "Input"], Cell["Replace the v[i, j] by a new variable d.", "Text"], Cell[BoxData[{ \(\(\(vsub\ = \ {v[1, 2] \[Rule] d*vdirec[\([1]\)], v[1, 3] \[Rule] d*vdirec[\([2]\)], v[2, 3] \[Rule] d*vdirec[\([3]\)]};\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(g1\ = \ g1 /. vsub // Factor\), "\[IndentingNewLine]", \(g2\ = \ g2 /. vsub // Factor\), "\[IndentingNewLine]", \(g3\ = \ g3 /. vsub // Factor\), "\[IndentingNewLine]", \(g4\ = \ g4 /. vsub // Factor\), "\[IndentingNewLine]", \(g5\ = \ g5 /. vsub // Factor\), "\[IndentingNewLine]", \(g6\ = \ g6 /. vsub // Factor\), "\[IndentingNewLine]", \(g7\ = \ g7 /. vsub // Factor\), "\[IndentingNewLine]", \(g8\ = \ g8 /. vsub // Factor\), "\[IndentingNewLine]", \(g9\ = \ g9 /. vsub // Factor\), "\[IndentingNewLine]", \(g10\ = \ g10 /. vsub // Factor\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ Cancel out some harmless factors from g9. Recall that d is assumed \ to be nonzero.\ \>", "Text"], Cell[BoxData[ \(g9 = g9/\((3\ d\ \ m[1]\ m[2]\ m[ 3]\ r[1, 2]\^2\ r[1, 3]\^2\ r[2, 3]\^2)\)\)], "Input"], Cell["\<\ Next we eliminate the variables sdp[i, j] which appear linearly in \ g3, g8, g9. First check the Jacobian determinant.\ \>", "Text"], Cell[BoxData[ \(jacobian389\ = \ \({Coefficient[ g3, {sdp[1, 2], sdp[1, 3], sdp[2, 3]}], \[IndentingNewLine]Coefficient[ g8, {sdp[1, 2], sdp[1, 3], sdp[2, 3]}], \[IndentingNewLine]Coefficient[ g9, {sdp[1, 2], sdp[1, 3], sdp[2, 3]}]} // Det\) // FullSimplify\)], "Input"], Cell["\<\ The jacobian only vanishes when the distances are equal. This case \ may be excluded a priori, as explained in the paper. Now sovle these \ equations for the variables sdp[i, j].\ \>", "Text"], Cell[BoxData[{ \(\(sdpsol\ = \ \(Solve[{g3 \[Equal] 0, g8 \[Equal] 0, g9 \[Equal] 0}, {sdp[1, 2], sdp[1, 3], sdp[2, 3]}]\)[\([1]\)] // Factor;\)\), "\[IndentingNewLine]", \(\(\(sdp[1, 2] /. sdpsol // Factor\) // Numerator\) // FullSimplify\), "\[IndentingNewLine]", \(\(\(sdp[1, 2] /. sdpsol // Factor\) // Denominator\) // FullSimplify\)}], "Input"], Cell["\<\ Now substitute into the remaining nonzero equations. The \ denominators will be products of the nonzero denominators of the sdp[i,j] \ themselves, so can be discarded. This computation takes a few minutes.\ \>", \ "Text"], Cell[BoxData[{ \(g1 = \(g1 /. sdpsol // Factor\) // Numerator\), "\[IndentingNewLine]", \(g2 = \(g2 /. sdpsol // Factor\) // Numerator\), "\[IndentingNewLine]", \(\(g4 = \(g4 /. sdpsol // Factor\) // Numerator;\)\), "\[IndentingNewLine]", \(\(g5 = \(g5 /. sdpsol // Factor\) // Numerator;\)\), "\[IndentingNewLine]", \(\(g10 = \(g10 /. sdpsol // Factor\) // Numerator;\)\)}], "Input"], Cell[BoxData[ \(\(g10 = \(g10 /. sdpsol // Factor\) // Numerator;\)\)], "Input"], Cell["g10 has several factors. All but the last can be dropped.", "Text"], Cell[BoxData[{ \(Length[g4]\), "\[IndentingNewLine]", \(Length[g5]\), "\[IndentingNewLine]", \(Length[g10]\), "\[IndentingNewLine]", \(\)}], "Input"], Cell[BoxData[{ \(Take[g10, 4]\), "\[IndentingNewLine]", \(\(g10 = g10[\([5]\)];\)\), "\[IndentingNewLine]", \(Length[g10]\)}], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Puiseux Expansions for the Distances", "Section"], Cell["\<\ In this section the equations g1 = g2 = 0 will be analyzed to \ determine possible Puiseux expanions for the three mutual distances r[i, \ j].\ \>", "Text"], Cell[BoxData[{ \(g1\), "\[IndentingNewLine]", \(g2\)}], "Input"], Cell["Some functions to determine exponent vectors.", "Text"], Cell[BoxData[{ \(\(\(GetExponents[mon_, vars_]\ := \ Map[Exponent[mon, #] &, vars]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(GetAllExponents[poly_, vars_] := \[IndentingNewLine]Table[ GetExponents[poly[\([i]\)], vars], {i, 1, Length[poly]}] // Union\)}], "Input"], Cell["\<\ Here are the vertices of the Newton polytopes P1, P2. They are \ tetrahedra.\ \>", "Text"], Cell[BoxData[{ \(\(\(vars\ = \ {r[1, 2], r[1, 3], r[2, 3]};\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(explist = \ Map[GetAllExponents[#, vars] &, {g1, g2}]\)}], "Input"], Cell["Add vertices to get the Minkowski sum.", "Text"], Cell[BoxData[{ \(AddToAll[vect_, vlist_]\ := Map[\((\ vect + #)\) &, vlist]\), "\[IndentingNewLine]", \(\(\(MinkSum[vlist_, wlist_]\ := \ \(Map[AddToAll[#, wlist] &, vlist] // Flatten[#, 1] &\) // Union\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(mink\ = \ MinkSum[explist[\([1]\)], explist[\([2]\)]]\)}], "Input"], Cell["\<\ Porta was used to get a minimal list vertices and to find \ inequalities for the facets. Here we just quote the results.\ \>", "Text"], Cell[BoxData[ \(\(\( (*ineqlist\ = \ \(ReadList["\", Expression]\[IndentingNewLine]Length[%]\[IndentingNewLine]\ convlist\ = \ ReadList["\", {Number, Number, Number}]\[IndentingNewLine]Length[%]\)*) \)\(\ \[IndentingNewLine]\)\(\[IndentingNewLine]\)\(\(ineqlist\ = {x1 \[LessEqual] 3, \(-x1\) - x2 \[LessEqual] \(-1\), \(-x1\) - x3 \[LessEqual] \(-1\), \(-x1\) - x2 - x3 \[LessEqual] \(-2\), \(-x2\) \[LessEqual] 0, \(-x2\) - x3 \[LessEqual] \(-1\), \(-x1\) \[LessEqual] 0, \(-x3\) \[LessEqual] 0, x3 \[LessEqual] 3, x2 \[LessEqual] 3, x2 + x3 \[LessEqual] 4, x1 + x3 \[LessEqual] 4, x1 + x2 \[LessEqual] 4, x1 + x2 + x3 \[LessEqual] 5};\)\[IndentingNewLine]\[IndentingNewLine] \(convlist\ = {{1, 0, 1}, {1, 1, 0}, {3, 1, 1}, {0, 1, 3}, {0, 3, 1}, {1, 0, 3}, {1, 3, 0}, {3, 0, 1}, {3, 1, 0}, {0, 1, 1}, {1, 1, 3}, {1, 3, 1}};\)\)\)\)], "Input"], Cell["\<\ Next we determine which of the facets is nontrivial, that is, which \ of the reduced systems will not contain a polynomial which reduces to a \ single term.\ \>", "Text"], Cell[BoxData[{ \(\(Subst[v_]\ := \ {x1 \[Rule] v[\([1]\)], \ x2 \[Rule] v[\([2]\)], \ x3 \[Rule] v[\([3]\)]};\)\), "\[IndentingNewLine]", \(lhs[LessEqual[a_, b_]]\ := \ a\), "\[IndentingNewLine]", \(\(\(rhs[LessEqual[a_, b_]]\ := \ b\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(FindMax[linform_, vertlist_]\ := \ Max[\ Map[linform /. Subst[#] &, vertlist]]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(GetMaximalExponents[ineq_, vertlist_] := \[IndentingNewLine]With[{linform = lhs[ineq], maxval\ = \ FindMax[lhs[ineq], vertlist]}, \ Select[vertlist, \((\((linform /. Subst[#])\)\ \[Equal] maxval)\) &]]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(AddLEInequalities[indlist_, ineqlist_] := Module[{ins, rights, \ lefts}, \[IndentingNewLine]ins\ = \ Part[ineqlist, indlist]; \[IndentingNewLine]rights\ = \ Map[rhs, ins]; \[IndentingNewLine]lefts\ = \ Map[lhs, ins]; \[IndentingNewLine]LessEqual[Plus @@ lefts, Plus @@ rights]]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(NontrivialFace[indlist_, ineqlist_, explist_]\ := \ With[{in = AddLEInequalities[indlist, ineqlist]}, \[IndentingNewLine]AllNontrivial[in, explist]]\)\(\[IndentingNewLine]\)\(\[IndentingNewLine]\)\(\ \[IndentingNewLine]\) \)\ (*returns\ 1\ if\ the\ inequality\ determines\ a\ reduced\ \ polynomial\ with\ more\ than\ one\ term\ *) \), "\[IndentingNewLine]", \(\(\(Nontrivial[ineq_, vertlist_] := \ If[Length[GetMaximalExponents[ineq, vertlist]] > 1, 1, 0]\)\(\[IndentingNewLine]\)\(\[IndentingNewLine]\) \) (*\ returns\ 1\ if\ ineq\ is\ nontrivial\ all\ of\ the\ reduced\ \ polynomials\ whose\ exponents\ are\ in\ vllist\ \((list\ of\ exponent\ lists)\ \)\ *) \), "\[IndentingNewLine]", \(\(\(AllNontrivial[ineq_, vllist_]\ := \[IndentingNewLine]If[ Min[Map[Nontrivial[ineq, #] &, vllist]] > 0, True, False]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\)}], "Input"], Cell[BoxData[{ \(nontrivialfacets\ = \ Select[ineqlist, AllNontrivial[#, explist] &]\), "\[IndentingNewLine]", \(\(trivialfacets\ = \ Complement[ineqlist, nontrivialfacets];\)\), "\[IndentingNewLine]", \(Length[nontrivialfacets]\)}], "Input"], Cell["\<\ Sort them in a nice way and make a table. Note: in the paper all \ the inequalities are reversed to that the inward normals will be the \ coefficients.\ \>", "Text"], Cell[BoxData[{ \(GetAlpha[ LessEqual[a_, b_]] := \ \(-Coefficient[ a, {x1, x2, x3}]\)\), "\[IndentingNewLine]", \(\(nontrivialfacets\ = \ Sort[nontrivialfacets, \(({1, 1, 1} . GetAlpha[#1] > {1, 1, 1} . GetAlpha[#2])\) &];\)\), "\[IndentingNewLine]", \(\(trivialfacets\ = \ Sort[trivialfacets, \(({1, 1, 1} . GetAlpha[#1] > {1, 1, 1} . GetAlpha[#2])\) &];\)\), "\[IndentingNewLine]", \(\({Table[i, {i, 1, 6}], nontrivialfacets} // Transpose\) // MatrixForm\), "\[IndentingNewLine]", \(\({Table[i, {i, 1, 8}], trivialfacets} // Transpose\) // MatrixForm\)}], "Input"], Cell["\<\ We also need to test the edges for nontriviality. First a funtion \ to test if two facets are adjacent.\ \>", "Text"], Cell[BoxData[{ \(FindFacet[ineq_, vlist_] := Select[vlist, \((\((lhs[ineq] /. Subst[#])\) === rhs[ineq])\) &]\), "\[IndentingNewLine]", \(FacetsIncident[indlist_, ineqlist_, vlist_]\ := \ With[{f = Map[FindFacet[#, vlist] &, Part[ineqlist, indlist]]}, \[IndentingNewLine]If[ Length[Intersection @@ f] > 0, True, False]]\)}], "Input"], Cell["\<\ Now make a list of all possible pairs of indices of nontrivial \ facets and test them for incidence and for whether the resulting reduced \ system is nontrivial\ \>", "Text"], Cell[BoxData[{ \(pairs = \ Flatten[Table[{i, j}, {i, 1, 5}, {j, i + 1, 6}], 1]\), "\[IndentingNewLine]", \(nontrivialedges = \ Select[pairs, \((NontrivialFace[#, nontrivialfacets, explist]\ && FacetsIncident[#, nontrivialfacets, convlist])\) &]\)}], "Input"], Cell["This shows that all of the edges are trivial.", "Text"], Cell["\<\ Next, some functions to calculate reduced systems for a given \ inequality.\ \>", "Text"], Cell[BoxData[{ \(\(\(ReducePoly[p_, ineq_]\ := Module[{q, linform, maxval, explist, vars}, \[IndentingNewLine]vars\ = \ {d, rho, t}; \[IndentingNewLine]q = Expand[p]; \[IndentingNewLine]linform\ = \ lhs[ineq]; \[IndentingNewLine]explist\ = \ GetAllExponents[q, vars]; \[IndentingNewLine]maxval\ = \ FindMax[linform, explist]; \[IndentingNewLine]Select[ q, \((\((linform /. Subst[GetExponents[#, vars]])\) \[Equal] maxval)\) &]\[IndentingNewLine]]\)\(\[IndentingNewLine]\) \)\), "\n", \(\(\(ReducedSystem[LessEqual[lhs_, rhs_], eqlist_]\ := \ Map[ReducePoly[#, LessEqual[lhs, rhs]] &, eqlist]\)\(\n\) \)\), "\[IndentingNewLine]", \(ReducedSystem[indlist_, ineqlist_, eqlist_]\ := \ ReducedSystem[AddLEInequalities[indlist, ineqlist], eqlist]\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ Since the pairs are all trivial we only need to consider, e.g., \ inequality 1. In other words, rule out Puiseux series with r12 =t and r13 \ of order 1 and r23 of order 0. To investigate such series, make a \ substitution as is section 4.2 of the paper.\ \>", "Text"], Cell[BoxData[{ \(sub0\ = \ {r[1, 2] \[Rule] t, r[1, 3] \[Rule] t*u[1, 3], r[2, 3] \[Rule] u[2, 3]}\), "\[IndentingNewLine]", \(eqs = \({g1, g2} /. sub0 // Factor\) // Numerator\)}], "Input"], Cell["Drop the factor of t from the second equation.", "Text"], Cell[BoxData[ \(eqs[\([2]\)] = eqs[\([2]\)]/t\)], "Input"], Cell["\<\ The reduced systems for this type of series is obtained by setting \ t=0.\ \>", "Text"], Cell[BoxData[ \(F0\ = \ eqs /. t \[Rule] 0 // Factor\)], "Input"], Cell["\<\ This system determines the leading coefficients u[2,3]^2 and u[1,3] \ uniquely. Next we show that the Puiseux series must be a power series\ \>", \ "Text"], Cell[BoxData[{ \(grad[f_]\ := \ {D[f, u[1, 3]], D[f, u[2, 3]]}\), "\[IndentingNewLine]", \(\(dF0\ = \ Map[grad, F0] /. sub0 // Factor;\)\), "\[IndentingNewLine]", \(dF0 // MatrixForm\), "\[IndentingNewLine]", \(Det[dF0]\)}], "Input"], Cell["\<\ Since the determinant is nonzero, the solutions of the reduced eqs. \ are nondegerate, as required. The substitution sub0 represents the leading \ terms of the series. Sub1 will allow us to look at the higher-order terms. \ Rename the leading terms a[i,j] as in the paper. The next terms will be \ called b[i,j].\ \>", "Text"], Cell[BoxData[{ \(\(sub0\ = \ {a[1, 3] \[Rule] \(-m[3]\)/m[2], a[2, 3]^k_ \[RuleDelayed] \((c*\((m[1] + m[2] + m[3])\)/\((m[3]* m[2])\))\)^\((k/2)\) /; EvenQ[k], a[2, 3]^k_ \[RuleDelayed] \((a[2, 3])\) \((c*\((m[1] + m[2] + m[3])\)/\((m[3]* m[2])\))\)^\((\((k - 1)\)/2)\) /; OddQ[k]};\)\), "\[IndentingNewLine]", \(\(sub1\ = \ {u[1, 3] \[Rule] a[1, 3] + t*b[1, 3], u[2, 3] \[Rule] a[2, 3] + t*b[2, 3]};\)\), "\[IndentingNewLine]", \(eqs1 = \ \(\((eqs /. sub1 // Factor)\) /. sub0 // Factor\) // Numerator\)}], "Input"], Cell["\<\ Drop the factors of t. Then set t=0 to determine the next lowest \ terms.\ \>", "Text"], Cell[BoxData[{ \(\(eqs1 = eqs1/t;\)\), "\[IndentingNewLine]", \(eqs10 = \ \(eqs1 /. t \[Rule] 0\) /. sub0 // Factor\)}], "Input"], Cell["This determines b[2,3]=0 and b[1,3] uniquely", "Text"], Cell[BoxData[ \(b13sol\ = \ \(Solve[eqs10[\([2]\)] \[Equal] 0, b[1, 3]]\)[\([1]\)] // Factor\)], "Input"], Cell["\<\ For case I we assume that b[1,3] is not zero. The next term of r23 \ would be at second order so redefine sub1 to take this into account.\ \>", \ "Text"], Cell[BoxData[{ \(\(sub1\ = \ {u[1, 3] \[Rule] a[1, 3] + t*b[1, 3], u[2, 3] \[Rule] a[2, 3] + t^2*b[2, 3]};\)\), "\[IndentingNewLine]", \(eqs1 = \ \(\((eqs /. sub1 // Factor)\) /. sub0 // Factor\) // Numerator\)}], "Input"], Cell["After dropping powers of t, the leading terms can be found.", "Text"], Cell[BoxData[{ \(\(eqs1[\([1]\)] = eqs1[\([1]\)]/t^2;\)\), "\[IndentingNewLine]", \(\(eqs1[\([2]\)]\ = \ eqs1[\([2]\)]/t;\)\), "\[IndentingNewLine]", \(eqs10\ = \ \(eqs1 /. t \[Rule] 0\) /. sub0 // Factor\), "\[IndentingNewLine]", \(b13sol\ = \ \(Solve[eqs10[\([2]\)] \[Equal] 0, b[1, 3]]\)[\([1]\)] // Factor\), "\[IndentingNewLine]", \(b23sol\ = \ \(Solve[eqs10[\([1]\)] \[Equal] 0, b[2, 3]]\)[\([1]\)] // Factor\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ Next consider case II where b[1,3] = 0. This gives a[2,3] \ =m[2]m[3] which uniquely deterines c.\ \>", "Text"], Cell[BoxData[{ \(ceq\ = \ \(a[2, 3]^2 - m[2]^2 m[3]^2 /. sub0 // Factor\) // Numerator\), "\[IndentingNewLine]", \(csol\ = \ \(Solve[ceq \[Equal] 0, c]\)[\([1]\)]\), "\[IndentingNewLine]", \(caseIIsub\ = \ csol~Join~{a[2, 3] \[Rule] m[2] m[3], a[1, 3] \[Rule] \(-m[3]\)/m[2]}\)}], "Input"], Cell["\<\ We already know that r23 continues at second order and now we \ assume the same for r13 and also assume that csol holds\ \>", "Text"], Cell[BoxData[{ \(\(sub1alt\ = \ {u[1, 3] \[Rule] a[1, 3] + t^2*b[1, 3], u[2, 3] \[Rule] a[2, 3] + t^2*b[2, 3]};\)\), "\[IndentingNewLine]", \(eqs1alt = \ \(\(\((eqs /. sub1alt // Factor)\) /. caseIIsub\) /. sub0 // Factor\) // Numerator\)}], "Input"], Cell["It turns out that b[1,3]=0 :", "Text"], Cell[BoxData[{ \(\(eqs1alt = eqs1alt/t^2;\)\), "\[IndentingNewLine]", \(\(\(eqs1alt /. t \[Rule] 0\) /. csol\) /. sub0 // Factor\)}], "Input"], Cell["Thus u13 would have to be at least third order", "Text"], Cell[BoxData[{ \(\(sub1alt\ = \ {u[1, 3] \[Rule] a[1, 3] + t^3*b[1, 3], u[2, 3] \[Rule] a[2, 3] + t^2*b[2, 3]};\)\), "\[IndentingNewLine]", \(eqs1alt = \ \(\(\((eqs /. sub1alt // Factor)\) /. caseIIsub\) /. sub0 // Factor\) // Numerator\)}], "Input"], Cell[BoxData[{ \(\(eqs1alt[\([1]\)] = eqs1alt[\([1]\)]/t^2;\)\), "\[IndentingNewLine]", \(\(eqs1alt[\([2]\)] = eqs1alt[\([2]\)]/t^3;\)\), "\[IndentingNewLine]", \(\(\(eqs1alt /. t \[Rule] 0\) /. csol\) /. sub0 // Factor\)}], "Input"], Cell["Here are the next-to-highest terms for case II.", "Text"], Cell[BoxData[{ \(\(b23solalt\ = \ \ \(Solve[\((eqs1alt[\([1]\)] /. t \[Rule] 0)\) \[Equal] 0, b[2, 3]]\)[\([1]\)] // Factor;\)\), "\[IndentingNewLine]", \(\(b13solalt\ = \ \ \(Solve[\((eqs1alt[\([2]\)] /. t \[Rule] 0)\) \[Equal] 0, b[1, 3]]\)[\([1]\)] /. b23solalt // Factor;\)\), "\[IndentingNewLine]", \(bsolalt\ = \ b13solalt~Join~b23solalt\)}], "Input"], Cell["\<\ Both coefficients are nonzero at this point. Tnus we have two \ cases to consider. First the case where r13 continues at first order and r23 \ at second (both b[1,3] and b[2,3] nonzero below). Here are the appropriate \ substitutions for the r[i, j] variables.\ \>", "Text"], Cell[BoxData[{ \(\(caseIsub\ = \ {a[1, 3] \[Rule] \(-m[3]\)/m[2], a[2, 3]^k_ \[RuleDelayed] \((c*\((m[1] + m[2] + m[3])\)/\((m[3]* m[2])\))\)^\((k/2)\) /; EvenQ[k], a[2, 3]^k_ \[RuleDelayed] \((a[2, 3])\) \((c*\((m[1] + m[2] + m[3])\)/\((m[3]* m[2])\))\)^\((\((k - 1)\)/2)\) /; OddQ[k]};\)\), "\[IndentingNewLine]", \(\(\(sub2\ = \ {r[1, 2] \[Rule] t, r[1, 3] \[Rule] t*a[1, 3] + t^2*b[1, 3], r[2, 3] \[Rule] a[2, 3] + t^2*b[2, 3]};\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(({g1, g2} /. sub2 // Factor)\) /. caseIsub // Factor\) // Numerator\)}], "Input"], Cell["And for case II :", "Text"], Cell[BoxData[{ \(caseIIsub\), "\[IndentingNewLine]", \(\(\(sub2alt\ = \ {r[1, 2] \[Rule] t, r[1, 3] \[Rule] t*a[1, 3] + t^4*b[1, 3], r[2, 3] \[Rule] a[2, 3] + t^2*b[2, 3]};\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\(\(({g1, g2} /. sub2 // Factor)\) /. caseIIsub // Factor\) // Numerator\)}], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Nonexistence of Expansions for d and rho", "Section"], Cell["\<\ In this section we try to extend the two possible Puiseux \ expansions for the r[i,j] to Puiseux solutions for all five equations. It \ will prove to be impossible to do this. Begin by selecting our three \ equations.\ \>", "Text"], Cell[BoxData[ \(\(f3\ = \ {g4, g5, g10};\)\)], "Input"], Cell["\<\ Identify all the possible monomials in d and rho which occur.\ \>", \ "Text"], Cell[BoxData[ \(Map[GetAllExponents[#, {d, rho}] &, f3]\)], "Input"], Cell["\<\ Next read off all of the relevant coefficients. These are large \ polynomials in the r[i, j] and the parameters.\ \>", "Text"], Cell[BoxData[{ \(\(C00\ = \ g4 /. {d \[Rule] 0, rho \[Rule] 0};\)\), "\[IndentingNewLine]", \(\(D00\ = \ g5 /. {d \[Rule] 0, rho \[Rule] 0};\)\), "\[IndentingNewLine]", \(\(E00\ = \ g10 /. {d \[Rule] 0, rho \[Rule] 0};\)\), "\[IndentingNewLine]", \(\(C11 = \ Coefficient[g4, d*rho];\)\), "\[IndentingNewLine]", \(\(C20 = \ Coefficient[g4, d^2];\)\), "\[IndentingNewLine]", \(\(C31 = \ Coefficient[g4, d^3*rho];\)\), "\[IndentingNewLine]", \(\(C40 = \ Coefficient[g4, d^4];\)\), "\[IndentingNewLine]", \(\(D20 = \ Coefficient[g5, d^2];\)\), "\[IndentingNewLine]", \(\(D02 = \ Coefficient[g5, rho^2];\)\), "\[IndentingNewLine]", \(\(E11 = \ Coefficient[g10, d*rho];\)\), "\[IndentingNewLine]", \(\(E20 = \ Coefficient[g10, d^2];\)\), "\[IndentingNewLine]", \(\(E40 = \ Coefficient[g10, d^4];\)\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["Compute a few terms to put in the paper.", "Text"], Cell[BoxData[{ \(g4sample\ = \ C00[\([1]\)] + C11[\([1]\)]*d*rho + C20[\([1]\)]*d^2 + C31[\([1]\)]*d^3*rho + C40[\([1]\)]*d^4\), "\[IndentingNewLine]", \(g5sample\ = \ D00[\([1]\)] + D20[\([1]\)]*d^2 + D02[\([1]\)]*rho^2\), "\[IndentingNewLine]", \(g10sample\ = \ E00[\([1]\)] + E11[\([1]\)]*d*rho + E20[\([1]\)]*d^2 + E40[\([1]\)]*d^4\)}], "Input"], Cell[CellGroupData[{ Cell["Case I", "Subsection"], Cell["\<\ To study case I we will make the appropriate substitutions for the \ variables r[i j] and then read off the lowest order terms in t from each of \ the coefficients of the monomials in d and rho above. Here is a function to \ find the lowest-order terms in t, taking into account the values of the \ leading coefficient for case I.\ \>", "Text"], Cell[BoxData[ \(\(\(FindLowestPowerI[p_, var_] := Module[{c, pow = 0}, \[IndentingNewLine]c = \(p /. var \[Rule] 0\) /. sub0 // Factor; \[IndentingNewLine]If[\(! \((c === 0)\)\), Print[pow]; Return[c]]; \[IndentingNewLine]\(pow++\); \[IndentingNewLine]While[ pow < 30, \[IndentingNewLine]c = \ Coefficient[p, var^pow] /. caseIsub // Factor; \[IndentingNewLine]If[\(! \((c === 0)\)\), Print[pow]; Return[c]]; \[IndentingNewLine]\(pow++\);]; \ \[IndentingNewLine]Print["\"];]\)\(\[IndentingNewLine]\) \)\)], "Input"], Cell[BoxData[{ \(\(C00I\ = \ C00 /. sub2;\)\), "\[IndentingNewLine]", \(c00\ = \ FindLowestPowerI[C00I, t] // Factor\), "\[IndentingNewLine]", \(\(C20I\ = \ C20 /. sub2;\)\), "\[IndentingNewLine]", \(c20\ = \ FindLowestPowerI[C20I, t] // Factor\), "\[IndentingNewLine]", \(\(C11I\ = \ C11 /. sub2;\)\), "\[IndentingNewLine]", \(c11\ = \ FindLowestPowerI[C11I, t] // Factor\), "\[IndentingNewLine]", \(\(C31I\ = \ C31 /. sub2;\)\), "\[IndentingNewLine]", \(c31\ = \ FindLowestPowerI[C31I, t] // Factor\), "\[IndentingNewLine]", \(\(C40I\ = \ C40 /. sub2;\)\), "\[IndentingNewLine]", \(c40\ = \ FindLowestPowerI[C40I, t] // Factor\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ Now put together a simplified version of g3 using only these \ lowest-order terms. One can divide out a common factor of t^4.\ \>", "Text"], Cell[BoxData[ \(G4\ = \ c00\ + \ c20*d^2*t^8 + \ c11*d*rho*t^8 + c31*d^3*rho*t^16 + c40*d^4*t^16\)], "Input"], Cell["Repeat these steps for g5, g10", "Text"], Cell[BoxData[{ \(\(D00I\ = \ D00 /. sub2;\)\), "\[IndentingNewLine]", \(d00\ = \ FindLowestPowerI[D00I, t] // Factor\), "\[IndentingNewLine]", \(\(D20I\ = \ D20 /. sub2;\)\), "\[IndentingNewLine]", \(d20\ = \ FindLowestPowerI[D20I, t] // Factor\), "\[IndentingNewLine]", \(\(D02I\ = \ D02 /. sub2;\)\), "\[IndentingNewLine]", \(d02\ = \ FindLowestPowerI[D02I, t] // Factor\)}], "Input"], Cell[BoxData[ \(G5 = \ d00 + \ d20*d^2*t^8\ + \ d02*rho^2*t^4\)], "Input"], Cell[BoxData[{ \(\(E00I\ = \ E00 /. sub2;\)\), "\[IndentingNewLine]", \(e00\ = \ FindLowestPowerI[E00I, t] // Factor\), "\[IndentingNewLine]", \(\(E20I\ = \ E20 /. sub2;\)\), "\[IndentingNewLine]", \(e20\ = \ FindLowestPowerI[E20I, t] // Factor\), "\[IndentingNewLine]", \(\(E11I\ = \ E11 /. sub2;\)\), "\[IndentingNewLine]", \(e11\ = \ FindLowestPowerI[E11I, t] // Factor\), "\[IndentingNewLine]", \(\(E40I\ = \ E40 /. sub2;\)\), "\[IndentingNewLine]", \(e40\ = \ FindLowestPowerI[E40I, t] // Factor\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ The coefficient e00 is more complicated than the others and it is \ not clear whether or not it is zero. Making the substitutions for the b[i,j] \ shows that, in fact, it vanishes.\ \>", "Text"], Cell[BoxData[ \(\(e00 /. b13sol\) /. caseIsub // Factor\)], "Input"], Cell["\<\ To find the real lowest-order term, we have to modify the function \ which looks for lowest-order terms.\ \>", "Text"], Cell[BoxData[{ \(\(\(FindLowestPowerIb[p_, var_] := Module[{c, pow = 0}, \[IndentingNewLine]c = \(p /. var \[Rule] 0\) /. sub0 // Factor; \[IndentingNewLine]If[\(! \((c === 0)\)\), Print[pow]; Return[c]]; \[IndentingNewLine]\(pow++\); \[IndentingNewLine]While[ pow < 30, \[IndentingNewLine]c = \ \((\(Coefficient[p, var^pow] /. b13sol\) /. caseIsub // Factor)\); \[IndentingNewLine]If[\(! \((c === 0)\)\), Print[pow]; Return[c]]; \[IndentingNewLine]\(pow++\);]; \ \[IndentingNewLine]Print["\"];]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(e005\ = \ FindLowestPowerIb[E00I, t] /. caseIsub // Factor\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ It still looks suspicious -- try to see if it can really be \ 0.\ \>", "Text"], Cell[BoxData[{ \(a23eq\ = \ m[2] m[3]*a[2, 3]^2 - c*\((m[1] + m[2] + m[3])\)\), "\[IndentingNewLine]", \(Resultant[e005[\([6]\)], a23eq, a[2, 3]] // Factor\)}], "Input"], Cell["\<\ There are two conditions on c which will make this vanish. But the \ first is case II. The other one gives.\ \>", "Text"], Cell[BoxData[ \(csol3 = \ c \[Rule] m[2]^3 m[3]^3/\((16*\((m[1] + m[2] + m[3])\))\)\)], "Input"], Cell["\<\ Assuming this, then look for the next coefficient of t which is \ nonzero. It will be either t^6 or t^7.\ \>", "Text"], Cell[BoxData[ \(\(\(\ \)\(e006\ = \ \((\(\(Coefficient[E00I, t^6] /. b13sol\) /. b23sol\) /. caseIsub // Factor)\) /. caseIsub // Factor\[IndentingNewLine] e007\ = \ \((\(\(Coefficient[E00I, t^7] /. b13sol\) /. b23sol\) /. caseIsub // Factor)\) /. caseIsub // Factor\)\)\)], "Input"], Cell[BoxData[{ \(e006\ = \ e006 /. csol3 // Factor\), "\[IndentingNewLine]", \(e007\ = \ e007 /. csol3 // Factor\)}], "Input"], Cell["Try to show that these cannot both vanish.", "Text"], Cell[BoxData[{ \(res6\ = \ Resultant[\(Numerator[e006]\)[\([4]\)], a23eq, a[2, 3]] /. csol3 // Factor\), "\[IndentingNewLine]", \(res7\ = Resultant[\(Numerator[e007]\)[\([7]\)], a23eq, a[2, 3]] /. csol3 // Factor\)}], "Input"], Cell["\<\ Thus, for special masses, c005 and c006 could both vanish. But \ c005 and c007 cannot both vanish. So we must have one of them nonzero. Thus \ e00 have order 5, 6 or 7 depending on the masses. To handle this we will \ work with three different version of G10\ \>", "Text"], Cell[BoxData[{ \(G105\ = \ e05\ + \ e20*d^2*t\ + \ e11*d*rho*t\ + \ e40*d^4*t^9\), "\[IndentingNewLine]", \(G106\ = \ e06*t\ + \ e20*d^2*t\ + \ e11*d*rho*t\ + \ e40*d^4*t^9\), "\[IndentingNewLine]", \(G107\ = \ e07*t^2\ + \ e20*d^2*t\ + \ e11*d*rho*t\ + \ e40*d^4*t^9\)}], "Input"], Cell["\<\ In what follows, the only thing that matters is that the indicated \ coefficients are nonzero. For simplicity, we replace them by symbols. We \ handle the three possibilities for G10 seperately.\ \>", "Text"], Cell[BoxData[{ \(G4\ = \ cc00\ + \ cc20*d^2*t^8 + \ cc11*d*rho*t^8 + cc31*d^3*rho*t^16 + cc40*d^4*t^16\), "\[IndentingNewLine]", \(G5 = \ dd00 + \ dd20*d^2*t^8\ + \ dd02*rho^2*t^4\), "\[IndentingNewLine]", \(G105\ = \ ee00\ + \ ee20*d^2*t\ + \ ee11*d*rho*t\ + \ ee40*d^4*t^9\), "\[IndentingNewLine]", \(G106\ = \ ee00*t\ + \ ee20*d^2*t\ + \ ee11*d*rho*t\ + \ ee40*d^4*t^9\), "\[IndentingNewLine]", \(G107\ = \ ee00*t^2 + \ ee20*d^2*t\ + \ ee11*d*rho*t\ + \ ee40*d^4*t^9\)}], "Input"], Cell["\<\ Here is a substitution to replace the symbols by their values, \ leaving ee00 undetermined.\ \>", "Text"], Cell[BoxData[ \(coeffsub\ = \ {cc00 \[Rule] c00, cc20 \[Rule] c20, cc11 \[Rule] c11, cc31 \[Rule] c31, cc40 \[Rule] c40, dd00 \[Rule] d00, dd20 \[Rule] d20, dd02 \[Rule] d02, ee20 \[Rule] e20, ee11 \[Rule] e11, ee40 \[Rule] e40}\)], "Input"], Cell["\<\ Solve the equation G10=0 for rho and substitute into the other \ equations. Doing this for all three cases reveals the similarities.\ \>", \ "Text"], Cell[BoxData[{ \(rhosol\ = \ \(Solve[G105 \[Equal] 0, rho]\)[\([1]\)]\), "\[IndentingNewLine]", \(K45\ = \ \(G4 /. rhosol // Factor\) // Numerator\), "\[IndentingNewLine]", \(K55\ = \ \(G5 /. rhosol // Factor\) // Numerator\), "\[IndentingNewLine]", \(GetAllExponents[K45, {d, t}]\), "\[IndentingNewLine]", \(\(\(GetAllExponents[K55, {d, t}]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(rhosol\ = \ \(Solve[G106 \[Equal] 0, rho]\)[\([1]\)]\), "\[IndentingNewLine]", \(K46 = \ \(G4 /. rhosol // Factor\) // Numerator\), "\[IndentingNewLine]", \(K56\ = \ \(G5 /. rhosol // Factor\) // Numerator\), "\[IndentingNewLine]", \(GetAllExponents[K46, {d, t}]\), "\[IndentingNewLine]", \(\(\(GetAllExponents[K56, {d, t}]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(rhosol\ = \ \(Solve[G107 \[Equal] 0, rho]\)[\([1]\)]\), "\[IndentingNewLine]", \(K47\ = \ \(G4 /. rhosol // Factor\) // Numerator\), "\[IndentingNewLine]", \(K57\ = \ \(G5 /. rhosol // Factor\) // Numerator\), "\[IndentingNewLine]", \(GetAllExponents[K47, {d, t}]\), "\[IndentingNewLine]", \(\(\(GetAllExponents[K57, {d, t}]\)\(\[IndentingNewLine]\) \)\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["All three case lead to the same condition on the masses.", "Text"], Cell[BoxData[{ \(red5 = \ \((\({K45, K55} /. d \[Rule] a*t^\((\(-4\))\) // Factor\) // Numerator)\) /. t \[Rule] 0\), "\[IndentingNewLine]", \(red6 = \ \((\({K46, K56} /. d \[Rule] a*t^\((\(-4\))\) // Factor\) // Numerator)\) /. t \[Rule] 0\), "\[IndentingNewLine]", \(red7 = \ \((\({K47, K57} /. d \[Rule] a*t^\((\(-4\))\) // Factor\) // Numerator)\) /. t \[Rule] 0\)}], "Input"], Cell[BoxData[ \(Resultant[red5[\([1]\)], red5[\([2]\)], a] /. coeffsub // Factor\)], "Input"], Cell[BoxData[ \(FactorInteger[13493281232954916864]\)], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Case II", "Subsection"], Cell["\<\ To study case II we will make the appropriate substitutions for the \ variables r[i j] and then read off the lowest order terms in t from each of \ the coefficients of the monomials in d and rho above. Here is a function to \ find the lowest-order terms in t, taking into account the values of the \ leading coefficient for case II.\ \>", "Text"], Cell[BoxData[ \(\(\(FindLowestPowerII[p_, var_] := Module[{c, pow = 0}, \[IndentingNewLine]c = \(p /. var \[Rule] 0\) /. sub0 // Factor; \[IndentingNewLine]If[\(! \((c === 0)\)\), Print[pow]; Return[c]]; \[IndentingNewLine]\(pow++\); \[IndentingNewLine]While[ pow < 30, \[IndentingNewLine]c = \ \(Coefficient[p, var^pow] /. bsolalt\) /. caseIIsub // Factor; \[IndentingNewLine]If[\(! \((c === 0)\)\), Print[pow]; Return[c]]; \[IndentingNewLine]\(pow++\);]; \ \[IndentingNewLine]Print["\"];]\)\(\[IndentingNewLine]\) \)\)], "Input"], Cell[BoxData[{ \(\(C00II\ = \ C00 /. sub2alt;\)\), "\[IndentingNewLine]", \(c00\ = \ FindLowestPowerII[C00II, t] // Factor\), "\[IndentingNewLine]", \(\(C20II\ = \ C20 /. sub2alt;\)\), "\[IndentingNewLine]", \(c20\ = \ FindLowestPowerII[C20II, t] // Factor\), "\[IndentingNewLine]", \(\(C11II\ = \ C11 /. sub2alt;\)\), "\[IndentingNewLine]", \(c11\ = \ FindLowestPowerII[C11II, t] // Factor\), "\[IndentingNewLine]", \(\(C31II\ = \ C31 /. sub2alt;\)\), "\[IndentingNewLine]", \(c31\ = \ FindLowestPowerII[C31II, t] // Factor\), "\[IndentingNewLine]", \(\(C40II\ = \ C40 /. sub2alt;\)\), "\[IndentingNewLine]", \(c40\ = \ FindLowestPowerII[C40II, t] // Factor\), "\[IndentingNewLine]", \(\)}], "Input"], Cell["\<\ Now put together a simplified version of g3 using only these \ lowest-order terms. One can divide out a common factor of t^4.\ \>", "Text"], Cell[BoxData[ \(G4\ = \ c00\ + \ c20*d^2*t^10 + \ c11*d*rho*t^12 + c31*d^3*rho*t^22 + c40*d^4*t^20\)], "Input"], Cell["Repeat these steps for g5, g10", "Text"], Cell[BoxData[{ \(\(D00II = \ D00 /. sub2alt;\)\), "\[IndentingNewLine]", \(d00\ = \ FindLowestPowerII[D00II, t] // Factor\), "\[IndentingNewLine]", \(\(D20II\ = \ D20 /. sub2alt;\)\), "\[IndentingNewLine]", \(d20\ = \ FindLowestPowerII[D20II, t] // Factor\), "\[IndentingNewLine]", \(\(D02II\ = \ D02 /. sub2alt;\)\), "\[IndentingNewLine]", \(d02\ = \ FindLowestPowerII[D02II, t] // Factor\)}], "Input"], Cell[BoxData[ \(G5 = \ d00 + \ d20*d^2*t^10\ + \ d02*rho^2*t^6\)], "Input"], Cell[BoxData[{ \(\(E00II\ = \ E00 /. sub2alt;\)\), "\[IndentingNewLine]", \(e00\ = \ FindLowestPowerII[E00II, t] // Factor\), "\[IndentingNewLine]", \(\(E20II = \ E20 /. sub2alt;\)\), "\[IndentingNewLine]", \(e20\ = \ FindLowestPowerII[E20II, t] // Factor\), "\[IndentingNewLine]", \(\(E11II = \ E11 /. sub2alt;\)\), "\[IndentingNewLine]", \(e11\ = \ FindLowestPowerII[E11II, t] // Factor\), "\[IndentingNewLine]", \(\(E40II = \ E40 /. sub2alt;\)\), "\[IndentingNewLine]", \(e40\ = \ FindLowestPowerII[E40II, t] // Factor\), "\[IndentingNewLine]", \(\)}], "Input"], Cell[BoxData[ \(G10\ = \ e05\ + \ e20*d^2\ + \ e11*d*rho*t^2\ + \ e40*d^4*t^10\)], "Input"], Cell["\<\ In what follows, the only thing that matters is that the indicated \ coefficients are nonzero. For simplicity, we replace them by symbols\ \>", \ "Text"], Cell[BoxData[{ \(G4\ = \ cc00\ + \ cc20*d^2*t^10 + \ cc11*d*rho*t^12 + cc31*d^3*rho*t^22 + cc40*d^4*t^20\), "\[IndentingNewLine]", \(G5 = \ dd00 + \ dd20*d^2*t^10\ + \ dd02*rho^2*t^6\), "\[IndentingNewLine]", \(G10 = \ ee00\ + \ ee20*d^2\ + \ ee11*d*rho*t^2\ + \ ee40*d^4*t^10\)}], "Input"], Cell[BoxData[ \(coeffsub\ = \ {cc00 \[Rule] c00, cc20 \[Rule] c20, cc11 \[Rule] c11, cc31 \[Rule] c31, cc40 \[Rule] c40, dd00 \[Rule] d00, dd20 \[Rule] d20, dd02 \[Rule] d02, ee00 \[Rule] e005, ee20 \[Rule] e20, ee11 \[Rule] e11, ee40 \[Rule] e40}\)], "Input"], Cell[BoxData[ \(explist5II = \ Map[GetAllExponents[#, {d, rho, t}] &, {G4, \ G5, \ G10}]\)], "Input"], Cell[BoxData[{ \(rhosol\ = \ \(Solve[G10 \[Equal] 0, rho]\)[\([1]\)]\), "\[IndentingNewLine]", \(K4\ = \ \(G4 /. rhosol // Factor\) // Numerator\), "\[IndentingNewLine]", \(K5 = \ \(G5 /. rhosol // Factor\) // Numerator\), "\[IndentingNewLine]", \(GetAllExponents[K4, {d, t}]\), "\[IndentingNewLine]", \(GetAllExponents[K5, {d, t}]\)}], "Input"], Cell["\<\ This time, the Newton polygons show that the expansion of d must \ start with t^(-5). Computing the resultant shows that there are no solutions \ for the coefficient, a.\ \>", "Text"], Cell[BoxData[{ \(red = \ \((\({K4, K5} /. d \[Rule] a*t^\((\(-5\))\) // Factor\) // Numerator)\) /. t \[Rule] 0\), "\[IndentingNewLine]", \(res\ = \ Resultant[red[\([1]\)], red[\([2]\)], a] // Factor\), "\[IndentingNewLine]", \(res /. coeffsub // Factor\)}], "Input"], Cell[BoxData[{ \(FactorInteger[ 29258889653455213419874780811369419097900390625]\), \ "\[IndentingNewLine]", \(FactorInteger[262144]\)}], "Input"] }, Closed]] }, Closed]] }, Open ]] }, FrontEndVersion->"5.0 for Macintosh", ScreenRectangle->{{0, 978}, {0, 746}}, WindowToolbars->{}, WindowSize->{884, 533}, WindowMargins->{{17, Automatic}, {Automatic, 20}}, PrintingCopies->1, PrintingPageRange->{1, Automatic}, PageHeaders->{{Inherited, Inherited, Inherited}, {None, Inherited, None}}, PageHeaderLines->{Inherited, False}, PrintingOptions->{"PrintingMargins"->{{54, 54}, {72, 72}}, "PrintCellBrackets"->False, "PrintRegistrationMarks"->False, "PrintMultipleHorizontalPages"->False} ] (******************************************************************* Cached data follows. If you edit this Notebook file directly, not using Mathematica, you must remove the line containing CacheID at the top of the file. The cache data will then be recreated when you save this file from within Mathematica. *******************************************************************) (*CellTagsOutline CellTagsIndex->{} *) (*CellTagsIndex CellTagsIndex->{} *) (*NotebookFileOutline Notebook[{ Cell[CellGroupData[{ Cell[1776, 53, 63, 0, 88, "Title"], Cell[1842, 55, 351, 6, 50, "Text"], Cell[CellGroupData[{ Cell[2218, 65, 49, 0, 69, "Section"], Cell[2270, 67, 369, 6, 68, "Text"], Cell[CellGroupData[{ Cell[2664, 77, 44, 0, 38, "Subsection"], Cell[2711, 79, 99, 3, 32, "Text"], Cell[2813, 84, 409, 8, 91, "Input"], Cell[3225, 94, 217, 4, 50, "Text"], Cell[3445, 100, 565, 10, 171, "Input"], Cell[4013, 112, 138, 5, 33, "Text"], Cell[4154, 119, 169, 3, 59, "Input"], Cell[4326, 124, 94, 3, 32, "Text"], Cell[4423, 129, 1506, 30, 347, "Input"], Cell[5932, 161, 182, 4, 50, "Text"], Cell[6117, 167, 794, 14, 203, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[6948, 186, 53, 0, 30, "Subsection"], Cell[7004, 188, 242, 5, 50, "Text"], Cell[7249, 195, 295, 5, 68, "Text"], Cell[CellGroupData[{ Cell[7569, 204, 2408, 42, 443, "Input"], Cell[9980, 248, 143, 2, 29, "Output"] }, Open ]], Cell[10138, 253, 100, 3, 32, "Text"], Cell[CellGroupData[{ Cell[10263, 260, 2786, 50, 571, "Input"], Cell[13052, 312, 72, 1, 32, "Output"], Cell[13127, 315, 753, 12, 101, "Output"] }, Open ]], Cell[13895, 330, 109, 3, 32, "Text"], Cell[14007, 335, 382, 6, 75, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[14426, 346, 41, 0, 30, "Subsection"], Cell[14470, 348, 87, 3, 32, "Text"], Cell[14560, 353, 526, 10, 123, "Input"], Cell[15089, 365, 243, 5, 50, "Text"], Cell[15335, 372, 2000, 35, 427, "Input"], Cell[17338, 409, 41, 0, 32, "Text"], Cell[17382, 411, 651, 10, 139, "Input"], Cell[18036, 423, 292, 5, 68, "Text"], Cell[18331, 430, 590, 10, 171, "Input"], Cell[18924, 442, 113, 3, 32, "Text"], Cell[19040, 447, 277, 5, 75, "Input"], Cell[19320, 454, 251, 5, 50, "Text"], Cell[19574, 461, 245, 6, 43, "Input"], Cell[19822, 469, 248, 5, 50, "Text"], Cell[20073, 476, 417, 7, 93, "Input"], Cell[20493, 485, 151, 3, 32, "Text"], Cell[20647, 490, 782, 16, 171, "Input"], Cell[21432, 508, 51, 0, 32, "Text"], Cell[CellGroupData[{ Cell[21508, 512, 54, 1, 27, "Input"], Cell[21565, 515, 35, 1, 27, "Output"] }, Open ]], Cell[21615, 519, 141, 3, 32, "Text"], Cell[21759, 524, 195, 5, 43, "Input"], Cell[21957, 531, 145, 3, 32, "Text"], Cell[22105, 536, 419, 8, 107, "Input"], Cell[22527, 546, 125, 3, 32, "Text"], Cell[22655, 551, 83, 1, 27, "Input"], Cell[22741, 554, 154, 3, 32, "Text"], Cell[22898, 559, 423, 9, 107, "Input"], Cell[23324, 570, 98, 3, 32, "Text"], Cell[23425, 575, 1307, 25, 251, "Input"], Cell[24735, 602, 55, 0, 32, "Text"], Cell[24793, 604, 367, 7, 59, "Input"], Cell[25163, 613, 244, 5, 50, "Text"], Cell[25410, 620, 370, 7, 91, "Input"], Cell[25783, 629, 345, 6, 68, "Text"], Cell[26131, 637, 2719, 46, 555, "Input"], Cell[28853, 685, 211, 4, 50, "Text"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[29113, 695, 69, 0, 39, "Section"], Cell[29185, 697, 360, 6, 68, "Text"], Cell[29548, 705, 468, 9, 107, "Input"], Cell[30019, 716, 118, 3, 32, "Text"], Cell[30140, 721, 134, 2, 43, "Input"], Cell[30277, 725, 55, 0, 32, "Text"], Cell[30335, 727, 141, 2, 43, "Input"], Cell[30479, 731, 118, 3, 32, "Text"], Cell[30600, 736, 72, 1, 27, "Input"], Cell[30675, 739, 92, 3, 32, "Text"], Cell[30770, 744, 145, 2, 43, "Input"], Cell[30918, 748, 114, 3, 32, "Text"], Cell[31035, 753, 202, 3, 59, "Input"], Cell[31240, 758, 243, 5, 50, "Text"], Cell[31486, 765, 712, 12, 187, "Input"], Cell[32201, 779, 88, 3, 32, "Text"], Cell[32292, 784, 201, 4, 43, "Input"], Cell[32496, 790, 172, 4, 50, "Text"], Cell[32671, 796, 628, 11, 107, "Input"], Cell[33302, 809, 56, 0, 32, "Text"], Cell[33361, 811, 876, 15, 235, "Input"], Cell[34240, 828, 108, 3, 32, "Text"], Cell[34351, 833, 129, 3, 31, "Input"], Cell[34483, 838, 143, 3, 32, "Text"], Cell[34629, 843, 360, 7, 59, "Input"], Cell[34992, 852, 204, 4, 50, "Text"], Cell[35199, 858, 424, 8, 75, "Input"], Cell[35626, 868, 233, 5, 50, "Text"], Cell[35862, 875, 430, 7, 91, "Input"], Cell[36295, 884, 84, 1, 27, "Input"], Cell[36382, 887, 74, 0, 32, "Text"], Cell[36459, 889, 168, 4, 75, "Input"], Cell[36630, 895, 149, 3, 59, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[36816, 903, 55, 0, 39, "Section"], Cell[36874, 905, 166, 4, 50, "Text"], Cell[37043, 911, 73, 2, 43, "Input"], Cell[37119, 915, 61, 0, 32, "Text"], Cell[37183, 917, 326, 7, 75, "Input"], Cell[37512, 926, 101, 3, 32, "Text"], Cell[37616, 931, 197, 3, 59, "Input"], Cell[37816, 936, 54, 0, 32, "Text"], Cell[37873, 938, 374, 7, 91, "Input"], Cell[38250, 947, 145, 3, 32, "Text"], Cell[38398, 952, 1070, 18, 187, "Input"], Cell[39471, 972, 180, 4, 50, "Text"], Cell[39654, 978, 2201, 41, 539, "Input"], Cell[41858, 1021, 283, 6, 59, "Input"], Cell[42144, 1029, 176, 4, 50, "Text"], Cell[42323, 1035, 680, 13, 123, "Input"], Cell[43006, 1050, 128, 3, 32, "Text"], Cell[43137, 1055, 410, 8, 91, "Input"], Cell[43550, 1065, 184, 4, 50, "Text"], Cell[43737, 1071, 306, 6, 91, "Input"], Cell[44046, 1079, 61, 0, 32, "Text"], Cell[44110, 1081, 99, 3, 32, "Text"], Cell[44212, 1086, 942, 18, 267, "Input"], Cell[45157, 1106, 281, 5, 50, "Text"], Cell[45441, 1113, 209, 3, 43, "Input"], Cell[45653, 1118, 62, 0, 32, "Text"], Cell[45718, 1120, 62, 1, 27, "Input"], Cell[45783, 1123, 97, 3, 32, "Text"], Cell[45883, 1128, 70, 1, 27, "Input"], Cell[45956, 1131, 166, 4, 50, "Text"], Cell[46125, 1137, 272, 6, 75, "Input"], Cell[46400, 1145, 340, 6, 68, "Text"], Cell[46743, 1153, 665, 11, 107, "Input"], Cell[47411, 1166, 98, 3, 32, "Text"], Cell[47512, 1171, 138, 2, 43, "Input"], Cell[47653, 1175, 60, 0, 32, "Text"], Cell[47716, 1177, 119, 2, 27, "Input"], Cell[47838, 1181, 164, 4, 50, "Text"], Cell[48005, 1187, 265, 5, 43, "Input"], Cell[48273, 1194, 75, 0, 32, "Text"], Cell[48351, 1196, 517, 9, 107, "Input"], Cell[48871, 1207, 122, 3, 32, "Text"], Cell[48996, 1212, 345, 7, 59, "Input"], Cell[49344, 1221, 143, 3, 32, "Text"], Cell[49490, 1226, 295, 5, 43, "Input"], Cell[49788, 1233, 44, 0, 32, "Text"], Cell[49835, 1235, 151, 2, 43, "Input"], Cell[49989, 1239, 62, 0, 32, "Text"], Cell[50054, 1241, 295, 5, 43, "Input"], Cell[50352, 1248, 247, 3, 59, "Input"], Cell[50602, 1253, 63, 0, 32, "Text"], Cell[50668, 1255, 442, 7, 75, "Input"], Cell[51113, 1264, 287, 5, 50, "Text"], Cell[51403, 1271, 735, 13, 139, "Input"], Cell[52141, 1286, 33, 0, 32, "Text"], Cell[52177, 1288, 363, 7, 91, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[52577, 1300, 59, 0, 39, "Section"], Cell[52639, 1302, 243, 5, 50, "Text"], Cell[52885, 1309, 60, 1, 27, "Input"], Cell[52948, 1312, 87, 3, 32, "Text"], Cell[53038, 1317, 72, 1, 27, "Input"], Cell[53113, 1320, 137, 3, 32, "Text"], Cell[53253, 1325, 928, 16, 219, "Input"], Cell[54184, 1343, 56, 0, 32, "Text"], Cell[54243, 1345, 414, 9, 75, "Input"], Cell[CellGroupData[{ Cell[54682, 1358, 28, 0, 38, "Subsection"], Cell[54713, 1360, 355, 6, 68, "Text"], Cell[55071, 1368, 622, 11, 171, "Input"], Cell[55696, 1381, 770, 16, 187, "Input"], Cell[56469, 1399, 149, 3, 32, "Text"], Cell[56621, 1404, 131, 3, 43, "Input"], Cell[56755, 1409, 46, 0, 32, "Text"], Cell[56804, 1411, 435, 8, 107, "Input"], Cell[57242, 1421, 79, 1, 27, "Input"], Cell[57324, 1424, 623, 13, 155, "Input"], Cell[57950, 1439, 205, 4, 50, "Text"], Cell[58158, 1445, 72, 1, 27, "Input"], Cell[58233, 1448, 128, 3, 32, "Text"], Cell[58364, 1453, 811, 16, 203, "Input"], Cell[59178, 1471, 88, 3, 32, "Text"], Cell[59269, 1476, 195, 4, 43, "Input"], Cell[59467, 1482, 133, 3, 32, "Text"], Cell[59603, 1487, 108, 2, 27, "Input"], Cell[59714, 1491, 128, 3, 32, "Text"], Cell[59845, 1496, 338, 5, 91, "Input"], Cell[60186, 1503, 137, 2, 43, "Input"], Cell[60326, 1507, 58, 0, 32, "Text"], Cell[60387, 1509, 269, 6, 43, "Input"], Cell[60659, 1517, 285, 5, 68, "Text"], Cell[60947, 1524, 346, 8, 59, "Input"], Cell[61296, 1534, 219, 4, 50, "Text"], Cell[61518, 1540, 592, 14, 107, "Input"], Cell[62113, 1556, 115, 3, 32, "Text"], Cell[62231, 1561, 273, 4, 43, "Input"], Cell[62507, 1567, 159, 4, 32, "Text"], Cell[62669, 1573, 1359, 28, 315, "Input"], Cell[64031, 1603, 72, 0, 32, "Text"], Cell[64106, 1605, 433, 6, 59, "Input"], Cell[64542, 1613, 104, 2, 27, "Input"], Cell[64649, 1617, 68, 1, 27, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[64754, 1623, 29, 0, 30, "Subsection"], Cell[64786, 1625, 357, 6, 68, "Text"], Cell[65146, 1633, 645, 11, 171, "Input"], Cell[65794, 1646, 800, 16, 187, "Input"], Cell[66597, 1664, 149, 3, 32, "Text"], Cell[66749, 1669, 133, 3, 43, "Input"], Cell[66885, 1674, 46, 0, 32, "Text"], Cell[66934, 1676, 451, 8, 107, "Input"], Cell[67388, 1686, 80, 1, 27, "Input"], Cell[67471, 1689, 641, 13, 155, "Input"], Cell[68115, 1704, 106, 2, 27, "Input"], Cell[68224, 1708, 164, 4, 50, "Text"], Cell[68391, 1714, 349, 8, 75, "Input"], Cell[68743, 1724, 292, 4, 59, "Input"], Cell[69038, 1730, 112, 2, 27, "Input"], Cell[69153, 1734, 400, 8, 91, "Input"], Cell[69556, 1744, 194, 4, 50, "Text"], Cell[69753, 1750, 311, 6, 59, "Input"], Cell[70067, 1758, 161, 4, 43, "Input"] }, Closed]] }, Closed]] }, Open ]] } ] *) (******************************************************************* End of Mathematica Notebook file. *******************************************************************)