A276738
Irregular triangle read by rows: T(n,m) = coefficients in a power/Fourier series expansion of an arbitrary anharmonic oscillator's exact phase space trajectory.
Original entry on oeis.org
-1, -1, 5, -1, 12, -32, -1, 14, 7, -126, 231, -1, 16, 16, -160, -160, 1280, -1792, -1, 18, 18, -198, 9, -396, 1716, -66, 2574, -12870, 14586, -1, 20, 20, -240, 20, -480, 2240, -240, -240, 6720, -17920, 2240, -35840, 129024, -122880, -1, 22, 22, -286, 22, -572, 2860, 11, -572, -286, 8580, -24310, -286, 4290, 8580, -97240, 184756, 715
Offset: 1
n/m 1 2 3 4 5 6 7
--------------------------------------------
1 | -1
2 | -1 5
3 | -1 12 -32
4 | -1 14 7 -126 231
5 | -1 16 16 -160 -160 1280 -1792
--------------------------------------------
R[1,Q] = -2*v_3*Q^3
R[2,Q] = -2*v_4*Q^4 + 10*v_3^2*Q^6
R[Q] = b*(1+b*(-2*v_3*Q^3)+b^2*(-2*v_4*Q^4 + 10*v_3^2*Q^6 ))+O(b^4)
Construct basis for R[4,Q]; List partitions: {{4}, {3, 1}, {2, 2}, {2, 1, 1}, {1, 1, 1, 1}}; Transform Plus 2: {{v_6}, {v_5, v_3}, {v_4, v_4}, {v_4, v_3, v_3}, {v_3, v_3, v_3, v_3}}; Multiply: {v_6, v_5*v_3, v_4^2, v_4*v_3^2, v_3^4}; don't forget power of Q and factor of 2: {2*v_6*Q^6, 2*v_5*v_3*Q^8, 2*v_4^2*Q^8, 2*v_4*v_3^2*Q^10, 2*v_3^4*Q^12}.
Pendulum:
A273506,
A273507,
A274076,
A274078,
A274130,
A274131,
A038534,
A056982,
A000984,
A001790,
A038533,
A046161,
A273496.
-
R[n_] := b Plus[1, Total[b^# R[#, q] & /@ Range[n]]]
Vp[n_] := Total[2 v[# + 2] q^(# + 2) & /@ Range[n]]
H[n_] := Expand[1/2*r^2 + Vp[n]]
RRules[n_] := With[{H = Series[ReplaceAll[H[n], {q -> R[n] Q, r -> R[n]}], {b, 0, n + 2}]}, Function[{rules},
Nest[Rule[#[[1]], ReplaceAll[#[[2]], rules]] & /@ # &, rules, n]][
Flatten[R[#, q] -> Expand[-ReplaceAll[ Coefficient[H, b^(# + 2)], {R[#, q] -> 0}]] & /@ Range[n]]]]
basis[n_] := Times[Times @@ (v /@ #), Q^Total[#],2] & /@ (IntegerPartitions[n] /. x_Integer :> x + 2)
TriangleRow[n_, rules_] := With[{term = Expand[rules[[n, 2]]]},
Coefficient[term, #] & /@ basis[n]]
With[{rules = RRules[10]}, TriangleRow[#, rules] & /@ Range[10]]
A276816
Irregular triangle read by rows: T(n,m) = coefficients in power/Fourier series expansion of an arbitrary anharmonic oscillator's exact period.
Original entry on oeis.org
-24, 480, -120, 6720, 3360, -241920, 1774080, -560, 40320, 40320, -1774080, 20160, -3548160, 61501440, -591360, 92252160, -1845043200, 8364195840, -2520, 221760, 221760, -11531520, 221760, -23063040, 461260800, 110880, -23063040, -11531520, 1383782400, -15682867200, -11531520, 691891200, 1383782400, -62731468800, 476759162880
Offset: 1
n/m 1 2 3 4 5
------------------------------------------
1 | -24 480
2 | -120 6720 3360 -241920 1774080
------------------------------------------
For pendulum values, f'(1,*)={(-1/384), 0}, f'(2,*) = {1/46080, 0, 1/294912, 0, 0}. Then K/(2Pi) = 1+(-1/384)*(-24)*4*k+((1/46080)*(-120)+(1/294912)*3360)*16*k^2=1+(1/4)*k + (9/64)*k^2, the first few terms of EllipticK.
Pendulum:
A273506,
A273507,
A274076,
A274078,
A274130,
A274131,
A038534,
A056982,
A000984,
A001790,
A038533,
A046161,
A273496.
-
RExp[n_]:=Expand[b Plus[R[0], Total[b^# R[#] & /@ Range[n]]]]
RCalc[n_]:=With[{basis =Subtract[Tally[Join[Range[n + 2], #]][[All, 2]],Table[1, {n + 2}]] & /@ IntegerPartitions[n + 2][[3 ;; -1]]},
Total@ReplaceAll[Times[-2, Multinomial @@ #, v[Total[#]],Times @@ Power[RSet[# - 1] & /@ Range[n + 2], #]] & /@ basis, {Q^2 -> 1, v[2] -> 1/4}]]
dt[n_] := With[{exp = Normal[Series[-1/(1 + x)/.x -> Total[(2 # v[#] RExp[n - 1]^(# - 2) &/@Range[3, n + 2])], {b, 0, n}]]},
Expand@ReplaceAll[Coefficient[exp, b, #] & /@ Range[n], R -> RSet]]
RingGens[n_] :=Times @@ (v /@ #) & /@ (IntegerPartitions[n]/. x_Integer :> x + 2)
tri[m_] := MapThread[Function[{a, b},Times[-# /. v[n_] :> Q^n /. Q^n_ :> Binomial[n, n/2],(1/2) Coefficient[a, #]] & /@ b], {dt[2 m][[2 #]] & /@ Range[m], RingGens[2 #] & /@ Range[m]}]
RSet[0] = 1; Set[RSet[#], Expand@RCalc[#]] & /@ Range[2*7];
tri7 = tri[7]; tri7 // TableForm
PeriodExpansion[tri_, n_] := ReplaceAll[ 1 + Dot[MapThread[ Dot, {tri,
2 RingGens[2 #] & /@ Range[n]}], (2 h)^(Range[n])], {v[m_] :> (v[m]*(1/2)^m)}]
{#,SameQ[Normal@Series[(2/Pi)*EllipticK[k],{k,0,7}],#]}&@ReplaceAll[
PeriodExpansion[tri7,7],{v[n_/;OddQ[n]]:>0,v[n_]:> (-1)^(n/2-1)/2/(n!),h->2 k}]
A276814
Irregular triangle read by rows T(n,m), coefficients in power/Fourier series expansion of an arbitrary anharmonic oscillator's exact phase space angular velocity.
Original entry on oeis.org
-3, -4, 6, -5, 22, -30, -6, 36, 16, -168, 192, -7, 54, 46, -294, -266, 1428, -1386, -8, 76, 64, -480, 30, -832, 2560, -128, 3520, -12800, 10752, -9, 102, 86, -738, 78, -1260, 4356, -594, -558, 11484, -23166, 3564, -42900, 118404, -87516, -10, 132, 112, -1080, 100, -1840, 7040, 48, -1680, -800, 18240, -40320, -760, 8640
Offset: 1
n/m 1 2 3 4 5 6 7
---------------------------------------------
1 | -3
2 | -4, 6
3 | -5, 22, -30
4 | -6, 36, 16, -168 192
5 | -7, 54, 46, -294 -266 1428 -1386
---------------------------------------------
Arbitrary Oscillator:
A276738,
A276815,
A276816,
A276817. Pendulum:
A273506,
A273507,
A274076,
A274078,
A274130,
A274131,
A038534,
A056982,
A000984,
A001790,
A038533,
A046161,
A273496.
-
R[n_] := b Plus[1, Total[b^# R[#, q] & /@ Range[n]]]
Vp[n_] := Total[2 v[# + 2] q^(# + 2) & /@ Range[n]]
H[n_] := Expand[1/2*r^2 + Vp[n]]
RRules[n_] := With[{H = Series[ReplaceAll[H[n], {q -> R[n] Q, r -> R[n]}], {b, 0, n + 2}]}, Function[{rules},
Nest[Rule[#[[1]], ReplaceAll[#[[2]], rules]] & /@ # &, rules, n]][
Flatten[R[#, q] -> Expand[-ReplaceAll[ Coefficient[H, b^(# + 2)], {R[#, q] -> 0}]] & /@ Range[n]]]]
xDot[n_] := Expand[Normal@Series[ReplaceAll[ Q^2 D[D[q[t], t]/q[t], t], {D[q[t], t] -> R[n] P, q[t] -> R[n] Q, r -> R[n], D[q[t], {t, 2}]
-> ReplaceAll[D[-(q^2/2 + Vp[n]), q], q -> R[n] Q]} ], {b, 0, n}] /. RRules[n] /. {P^2 -> 1 - Q^2}]
basis[n_] := Times[Times @@ (v /@ #), Q^Total[#],2] & /@ (IntegerPartitions[n] /. x_Integer :> x + 2)
TriangleRow[n_, fun_] := Coefficient[fun, b^n #] & /@ basis[n]
With[{xd = xDot[10]},TriangleRow[#, xd] /. v[_] -> 0 & /@ Range[10]]
A276815
Irregular triangle read by rows T(n,m), coefficients in power/Fourier series expansion of an arbitrary anharmonic oscillator's exact differential time dependence.
Original entry on oeis.org
3, 4, -24, 5, -70, 210, 6, -96, -48, 960, -1920, 7, -126, -126, 1386, 1386, -12012, 18018, 8, -160, -160, 1920, -80, 3840, -17920, 640, -26880, 143360, -172032, 9, -198, -198, 2574, -198, 5148, -25740, 2574, 2574, -77220, 218790, -25740, 437580, -1662804, 1662804, 10, -240, -240, 3360, -240, 6720, -35840, -120, 6720, 3360
Offset: 1
n/m 1 2 3 4 5 6 7
------------------------------------------------
1 | 3
2 | 4 -24
3 | 5 -70 210
4 | 6 -96 -48 960 -1920
5 | 7 -126 -126 1386 1386 -12012 18018
------------------------------------------------
Pendulum:
A273506,
A273507,
A274076,
A274078,
A274130,
A274131,
A038534,
A056982,
A000984,
A001790,
A038533,
A046161,
A273496.
-
R[n_] := b Plus[1, Total[b^# R[#, q] & /@ Range[n]]]
Vp[n_] := Total[2 v[# + 2] q^(# + 2) & /@ Range[n]]
H[n_] := Expand[1/2*r^2 + Vp[n]]
RRules[n_] := With[{H = Series[ReplaceAll[H[n], {q -> R[n] Q, r -> R[n]}], {b, 0, n + 2}]}, Function[{rules},
Nest[Rule[#[[1]], ReplaceAll[#[[2]], rules]] & /@ # &, rules, n]][
Flatten[R[#, q] -> Expand[-ReplaceAll[ Coefficient[H, b^(# + 2)], {R[#, q] -> 0}]] & /@ Range[n]]]]
xDot[n_] := Expand[Normal@Series[ReplaceAll[ Q^2 D[D[q[t], t]/q[t], t], {D[q[t], t] -> R[n] P, q[t] -> R[n] Q, r -> R[n], D[q[t], {t, 2}]
-> ReplaceAll[D[-(q^2/2 + Vp[n]), q], q -> R[n] Q]} ], {b, 0, n}] /. RRules[n] /. {P^2 -> 1 - Q^2}]
dt[n_] := Expand[Normal@Series[1/xDot[n], {b, 0, n}]]
basis[n_] := Times[Times @@ (v /@ #), Q^Total[#],2] & /@ (IntegerPartitions[n] /. x_Integer :> x + 2)
TriangleRow[n_, fun_] := Coefficient[fun, b^n #] & /@ basis[n]
With[{dt10 = dt[10]}, TriangleRow[#, dt10] /. v[_] -> 0 & /@ Range[10]]
Showing 1-4 of 4 results.
Comments