長さを変えた15個の振り子を一斉に揺らす実験


長さを変えた15個の振り子を一斉に揺らす実験(動画)をMathematicaでシミュレートする。

2次元

3次元

手順は以下のとおり。

  1. 運動方程式の確認(g=1、m=1、糸はたるまないことを仮定)
  2. 1分間の振動数が整数になるような振り子の長さを求める
  3. 運動方程式を解いて結果をアニメーションにする

ラグランジの運動方程式は次のように確認できる。

lagrangian = (r \[Theta]'[t] )^2/2 - r Cos[\[Theta][t]];
D[D[lagrangian, \[Theta]'[t]], t] + D[lagrangian, \[Theta][t]]

r Sin[theta[t]] + r^2 theta''[t]

これを使って、シミュレーションを作る。

(* 1分間の振動数が整数になる長さを求める *)
tMax = 60; (* maximum time *)
n = 15; (* number of objects *)
theta = Table[Unique[], {n}];
initialAngle = Pi/6;
r = Table[
   First[x /. Solve[
      tMax/(4 Sqrt[x] EllipticK[Sin[initialAngle/2]^2]) == (20 + i), x]
    ], {i, 1, n}];

(* 運動方程式を解く *)
equations = Flatten[Table[{
     (* ラグランジの運動方程式 *)
     r[[i]] Sin[theta[[i]][t]] + r[[i]]^2 theta[[i]]''[t] == 0,
     theta[[i]][0] == Pi/6,
     theta[[i]]'[0] == 0},
    {i, 1, n}]];
solution = NDSolve[equations, theta, {t, 0, 1.1 tMax}];

(* 2次元アニメーション *)
Animate[
 points = Table[First[
    {r[[i]]  Sin[theta[[i]][t]], -r[[i]]  Cos[theta[[i]][t]]}
      /. solution /. t -> T], {i, 1, n}];
 Graphics[{
     Black, Disk[#, 0.005],
     Gray, Line[{{0, 0}, #}]} &
   /@ points,
  PlotRange -> {{-0.8 Max[r], 0.8 Max[r]}, {0, -1.1 Max[r]}}],
 {T, 0, 1.1 tMax}, DefaultDuration -> 1.1 tMax, 
 SaveDefinitions -> True]

実行結果は冒頭の動画の通り。UMMでも確かめられる。

最後の部分を次のようにすれば3次元になる。

(* 3次元アニメーション *)
Animate[
 points = Table[First[
    {i Max@r/n, r[[i]] Sin[theta[[i]][t]], -r[[i]] Cos[theta[[i]][t]]}
      /. solution /. t -> T], {i, 1, n}];
 Graphics3D[{
     Black, Sphere[#, 0.005],
     Gray, Line[{{#[[1]], 0, 0}, #}]} &
   /@ points,
  PlotRange -> {{0, 1.1 Max@r}, {-0.7 Max@r, 
     0.7 Max@r}, {0, -1.1 Max@r}}],
 {T, 0, 1.1 tMax}, DefaultDuration -> 1.1 tMax, 
 SaveDefinitions -> True]

参考

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です