THE FOUCAULT PENDULUM
K.8.5.2
Ewald Roessl, Bernhard Schnizer, Franz Michel

Institut fuer Theoretische Physik
Technische Universitaet Graz
A-8010  Graz, Austria
Projekt Multimedial Lehre des
Zentralen Informatikdienstes der TU Graz

2002-06-14

Parameters

Internal Parameters

<<Calculus`VectorAnalysis`
<<LinearAlgebra`Orthogonalization`

ns = 
        10;                              (*numbers of pictures for the animation during 1 turn of the earth*) 
de = 
        Pi/18;                      (*angle which determines the width of the drawn part of the instantaneous plane*) 
rk = 
        4;                                (*radius of the earth (halfsphere)*) 
rp = 
        5.1;                             
drp = 
      1;                              (*determines the height in radial direction of the drawn part of instantaneous plane*) 
arrowl = 
      0.5;                  (*length of the drawn vector perpendicular to the instantaneous plane*)

philist=Table[ϕ, {ϕ, 0, 2π, π/ns}];       (*list of angles where to draw a picture*)

halfsphere		Plot of the earth
meridian		meridian at which the pendulum is located

halfsphere = ParametricPlot3D[
	{rk Sin[t] Cos[p], rk Sin[t] Sin[p], rk Cos[t],{EdgeForm[]}},
	{t,0,π/2}, {p,0,2π}, ColorOutput -> RGBColor, Axes-> False, Boxed-> False];
SetOptions[ParametricPlot3D,DisplayFunction->Identity];
meridian=Table[ParametricPlot3D[{rk Sin[t] Cos[philist[[i]]],rk Sin[t] Sin[philist[[i]]], rk Cos[t],{Thickness[0.012], Hue[0]}},
	{t,0,π/2}],{i,1,Length[philist]}];

Show[halfsphere, DisplayFunction ->  Identity ];

Start Button for Animations

start = 
        ButtonBox[
          StyleBox["Run Animation", "Title", 
            FontFamily -> "Helvetica"], 
          ButtonFunction :> 
            FrontEndExecute[{SelectionMove[EvaluationNotebook[], Before, 
                    ButtonCell] SelectionMove[EvaluationNotebook[], 
                    Previous, CellGroup] SelectionAnimate[
                    SelectedNotebook[], AnimationDisplayTime -> zeit]}], 
          ButtonEvaluator -> Automatic, 
          Active -> True];

Pendulum at Equator, Latitude  ψ = 0

Drawing the instantaneous planes of pendulum motion and the path of the pendulum

lre		corners of the polygon representing the instantaneous plane in spherical coordinates 
arrowev          vector perpendicular to the instantaneous plane
arrowre	arrowev located in the middle of the polygon

\(\(\(lre = 
        Table[{{\((rp + drp)\)\ Sin[the + de]\ Cos[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Sin[the + de]\ Sin[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Cos[
                  the + de]}, 
		{\((rp + drp)\)\ Sin[
                  the - de]\ Cos[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Sin[the - de]\ Sin[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Cos[
                  the - de]}, 
		{\((rp - drp)\)\ Sin[
                  the - de]\ Cos[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Sin[the - de]\ Sin[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Cos[
                  the - de]}, 
		{\((rp - drp)\)\ Sin[
                  the + de]\ Cos[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Sin[the + de]\ Sin[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Cos[the + de]}}, 
		{i, 1, 
            Length[philist]}];\)\(
\)
    \)\)
arrowev = 
        Table[Normalize[
            CrossProduct[lre[[i, 2]], 
              lre[[i, 1]]]], 
{i, 1, 
            Length[philist]}];

    
\(\(arrowre = 
        Table[{{\((rp)\)\ Sin[the]\ Cos[
                  philist[\([i]\)]], 
		\((rp)\)\ Sin[
                  the]\ Sin[
                  philist[\([i]\)]], 
		\((rp)\)\ Cos[
                  the]}, 
	
            arrowl\ arrowev[\([i]\)] + {\((rp)\)\ Sin[the]\ Cos[
                    philist[\([i]\)]], 
		\((rp)\)\ Sin[
                    the]\ Sin[
                    philist[\([i]\)]], 
		\((rp)\)\ Cos[
                    the]}}, 
{i, 1, 
            Length[philist]}];\)\)

dreh             angle of rotation of the instantaneous plane relative to the earth (axes of rotation going through the centre of the earth and the support point of the pendulum)
vect             union vector pointing from the centre of the earth to the support point of the pendulum

dreh = -Table[-philist[[i]] Sin[Pi/2 - the], {i, 1, 
              Length[philist]}];
vect = 
        Table[{Sin[the] Cos[philist[[i]]], 
            Sin[the] Sin[philist[[i]]], Cos[the]}, {i, 1, 
            Length[philist]}];

lrot               corners of the polygon
arrowrot       vector perpendicular to the instantaneous plane located in the middle of the polygon

lrot = 
        Table[
{lre[[i, 1]] Cos[dreh[[i]]] + 
              vect[[i]]*(vect[[i]] . lre[[i, 1]]) (1 - 
                    Cos[dreh[[i]]]) - 
              CrossProduct[vect[[i]], lre[[i, 1]]]*
                Sin[dreh[[i]]], 
            lre[[i, 2]] Cos[dreh[[i]]] + 
              vect[[i]]*(vect[[i]] . lre[[i, 2]]) (1 - 
                    Cos[dreh[[i]]]) - 
              CrossProduct[vect[[i]], lre[[i, 2]]]*
                Sin[dreh[[i]]], 
            lre[[i, 3]] Cos[dreh[[i]]] + 
              vect[[i]]*(vect[[i]] . lre[[i, 3]]) (1 - 
                    Cos[dreh[[i]]]) - 
              CrossProduct[vect[[i]], lre[[i, 3]]]*
                Sin[dreh[[i]]], 
            lre[[i, 4]] Cos[dreh[[i]]] + 
              vect[[i]]*(vect[[i]] . lre[[i, 4]]) (1 - 
                    Cos[dreh[[i]]]) - 
              CrossProduct[vect[[i]], lre[[i, 4]]]*
                Sin[dreh[[i]]]}, 
{i, 1, 
            Length[philist]}];

    
arrowrot = 
        Table[{arrowre[[i, 1]] Cos[dreh[[i]]] + 
              vect[[i]]*(vect[[i]] . arrowre[[i, 1]]) (1 - 
                    Cos[dreh[[i]]]) - 
              CrossProduct[vect[[i]], arrowre[[i, 1]]]*
                Sin[dreh[[i]]], 
            arrowre[[i, 2]] Cos[dreh[[i]]] + 
              vect[[i]]*(vect[[i]] . arrowre[[i, 2]]) (1 - 
                    Cos[dreh[[i]]]) - 
              CrossProduct[vect[[i]], arrowre[[i, 2]]]*
                Sin[dreh[[i]]]}, 
{i, 1, 
            Length[philist]}];

starline	               line representing the plane of the pendulum

starline = {Hue[0], AbsoluteThickness[3], 
          Line[{{-1, 0}, {1, 0}}]};

Animation

\(\(Table[
        Show[GraphicsArray[{
Show[
                Graphics3D[{Polygon[lrot[\([k]\)]], Hue[0], Thickness[0.007], 
                    Line[arrowrot[\([k]\)]]}, 
					\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {PlotRange\  -> \ {{\(-6\), 6}, {\(-6\), 6}, {\(-6\), 
                          6}}, 
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ViewPoint\  -> \ {9, 13, 10}}], \ halfsphere, meridian[\([k]\)], 
                Boxed -> \ False, ImageSize\  -> \ 800, \ 
                DisplayFunction\  -> \ Identity], 
              Show[Graphics[starline, \ Axes\  -> \ True], 
                DisplayFunction\  -> \ Identity\ ]}], 
          ImageSize\  -> \ 800, \ 
          DisplayFunction -> \ $DisplayFunction], \ \ \ \ \ \ \ \ 
							{k, 1, Length[philist]}];\)\)
SelectionMove[EvaluationNotebook[], After, 
        EvaluationCell];
SelectionMove[EvaluationNotebook[], Next, CellGroup];
FrontEndTokenExecute["OpenCloseGroup"];
start /. zeit -> 0.5 // DisplayForm

Pendulum at North Pole

Drawing the instantaneous planes of pendulum motion and the path of the pendulum

philist = 
        Table[ϕ, {ϕ, 0, 
            2  π, π/ns}];
\(\(lre = 
        Table[{{\((rp + drp)\)\ Sin[the + de]\ Cos[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Sin[the + de]\ Sin[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Cos[
                  the + de]}, 
		{\((rp + drp)\)\ Sin[
                  the - de]\ Cos[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Sin[the - de]\ Sin[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Cos[
                  the - de]}, 
		{\((rp - drp)\)\ Sin[
                  the - de]\ Cos[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Sin[the - de]\ Sin[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Cos[
                  the - de]}, 
		{\((rp - drp)\)\ Sin[
                  the + de]\ Cos[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Sin[the + de]\ Sin[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Cos[the + de]}}, 
		{i, 1, 
            Length[philist]}];\)
\)
arrowev = 
        Table[N[Normalize[
              CrossProduct[lre[[i, 2]], 
                lre[[i, 1]]]]], 
{i, 1, 
            Length[philist]}];

\(\(arrowre = 
        Table[{{\((rp)\)\ Sin[the]\ Cos[
                  philist[\([i]\)]], 
		\((rp)\)\ Sin[
                  the]\ Sin[
                  philist[\([i]\)]], 
		\((rp)\)\ Cos[
                  the]}, 
	
            arrowl\ arrowev[\([i]\)] + {\((rp)\)\ Sin[the]\ Cos[
                    philist[\([i]\)]], 
		\((rp)\)\ Sin[
                    the]\ Sin[
                    philist[\([i]\)]], 
		\((rp)\)\ Cos[
                    the]}}, 
{i, 1, 
            Length[philist]}];\)\)

dreh = -Table[-philist[[i]] Sin[Pi/2 - the], {i, 1, 
              Length[philist]}];
vect = 
        Table[{Sin[the] Cos[philist[[i]]], 
            Sin[the] Sin[philist[[i]]], Cos[the]}, {i, 1, 
            Length[philist]}];

\(\(\(lrot = 
        Table[{lre[\([i, 1]\)]\ Cos[dreh[\([i]\)]] + 
              vect[\([i]\)]*\((vect[\([i]\)] . lre[\([i, 1]\)])\)\ \((1 - 
                    Cos[dreh[\([i]\)]])\) - 
              CrossProduct[vect[\([i]\)], lre[\([i, 1]\)]]*
                Sin[dreh[\([i]\)]], 
            lre[\([i, 2]\)]\ Cos[dreh[\([i]\)]] + 
              vect[\([i]\)]*\((vect[\([i]\)] . lre[\([i, 2]\)])\)\ \((1 - 
                    Cos[dreh[\([i]\)]])\) - 
              CrossProduct[vect[\([i]\)], lre[\([i, 2]\)]]*
                Sin[dreh[\([i]\)]], 
            lre[\([i, 3]\)]\ Cos[dreh[\([i]\)]] + 
              vect[\([i]\)]*\((vect[\([i]\)] . lre[\([i, 3]\)])\)\ \((1 - 
                    Cos[dreh[\([i]\)]])\) - 
              CrossProduct[vect[\([i]\)], lre[\([i, 3]\)]]*
                Sin[dreh[\([i]\)]], 
            lre[\([i, 4]\)]\ Cos[dreh[\([i]\)]] + 
              vect[\([i]\)]*\((vect[\([i]\)] . lre[\([i, 4]\)])\)\ \((1 - 
                    Cos[dreh[\([i]\)]])\) - 
              CrossProduct[vect[\([i]\)], lre[\([i, 4]\)]]*
                Sin[dreh[\([i]\)]]}, {i, 1, Length[philist]}];\)\(
\)
    \)\)
arrowrot = 
        Table[{arrowre[[i, 1]] Cos[dreh[[i]]] + 
              vect[[i]]*(vect[[i]] . arrowre[[i, 1]]) (1 - 
                    Cos[dreh[[i]]]) - 
              CrossProduct[vect[[i]], arrowre[[i, 1]]]*
                Sin[dreh[[i]]], 
            arrowre[[i, 2]] Cos[dreh[[i]]] + 
              vect[[i]]*(vect[[i]] . arrowre[[i, 2]]) (1 - 
                    Cos[dreh[[i]]]) - 
              CrossProduct[vect[[i]], arrowre[[i, 2]]]*
                Sin[dreh[[i]]]}, 
{i, 1, 
            Length[philist]}];

UPendel            path of the pendulum relative to the earth

Ψ = π/2 - the;
Ω = 2 π/10;
ω = 2 π;
UPendel0 = 1;
UPendel = 
        Function[t, 
          UPendel0/
              2*
((1 + ((Ω Sin[Ψ])/(Sqrt[(((Ω Sin[Ψ]))^2) + (ω^2)]))) (E^(I (Sqrt[(((Ω Sin[Ψ]))^2) + (ω^2)]) t )) + (1 - ((Ω Sin[Ψ])/(Sqrt[(((Ω Sin[Ψ]))^2) + (ω^2)]))) (E^(-I (Sqrt[(((Ω Sin[Ψ]))^2) + (ω^2)]) t ))) (E^(-I Ω Sin[Ψ] t))];
Stern = 
        ParametricPlot[{Re[UPendel[t]], Im[UPendel[t]]}, {t, 0, 
            10/Sin[Ψ]},  AspectRatio ->  Automatic,  
          PlotStyle ->  Hue[0.3]];
starline = 
        Table[{Hue[0], AbsoluteThickness[3], 
            Line[{{Cos[
                    philist[[k]] Sin[Ψ]], -Sin[
                      philist[[k]] Sin[Ψ]]}, {-Cos[
                      philist[[k]] Sin[Ψ]], 
                  Sin[philist[[k]] Sin[Ψ]]}}], 
            AbsoluteThickness[1.5], 
            Circle[{0, 0}, 
              0.6, {-philist[[k]] Sin[Ψ], 0}]}, {k, 1, 
            Length[philist]}];

Animation

\(\(Table[
        Show[GraphicsArray[{
Show[
                Graphics3D[{Polygon[lrot[\([k]\)]], Hue[0], Thickness[0.007], 
                    Line[arrowrot[\([k]\)]]}, 
					\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {PlotRange\  -> \ {{\(-6\), 6}, {\(-6\), 6}, {\(-6\), 
                          6}}, 
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ViewPoint\  -> \ {9, 13, 10}}], \ halfsphere, meridian[\([k]\)], 
                Boxed -> \ False, ImageSize\  -> \ 800, \ 
                DisplayFunction\  -> \ Identity], 
              Show[Stern, \ Graphics[starline[\([k]\)]], 
                DisplayFunction\  -> \ Identity\ ]}], 
          ImageSize\  -> \ 800, \ 
          DisplayFunction -> \ $DisplayFunction], \ \ \ \ \ \ \ \ 
							{k, 1, Length[philist]}];\)\)
SelectionMove[EvaluationNotebook[], After, 
        EvaluationCell];
SelectionMove[EvaluationNotebook[], Next, CellGroup];
FrontEndTokenExecute["OpenCloseGroup"];
start /. zeit -> 0.5 // DisplayForm

Pendulum at Graz

Drawing the instantaneous planes of pendulum motion and the path of the pendulum

philist = 
        Table[ϕ, {ϕ, 0,  
            2  π/ 
                Sin[π/2 - the], π/(Ceiling[
                  ns/Sin[π/2 - the]])}];

SetOptions[ParametricPlot3D, 
        DisplayFunction -> Identity];
meridian = 
        Table[ParametricPlot3D[{rk Sin[t] Cos[philist[[i]]], 
              rk Sin[t] Sin[philist[[i]]], rk Cos[t], Hue[0]}, {t, 
              0, π/2}, ColorOutput -> RGBColor], {i, 1, 
            Length[philist]}];

\(\(\(lre = 
        Table[{{\((rp + drp)\)\ Sin[the + de]\ Cos[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Sin[the + de]\ Sin[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Cos[
                  the + de]}, 
		{\((rp + drp)\)\ Sin[
                  the - de]\ Cos[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Sin[the - de]\ Sin[
                  philist[\([i]\)]], 
		\((rp + 
                    drp)\)\ Cos[
                  the - de]}, 
		{\((rp - drp)\)\ Sin[
                  the - de]\ Cos[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Sin[the - de]\ Sin[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Cos[
                  the - de]}, 
		{\((rp - drp)\)\ Sin[
                  the + de]\ Cos[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Sin[the + de]\ Sin[
                  philist[\([i]\)]], 
		\((rp - 
                    drp)\)\ Cos[the + de]}}, 
		{i, 1, 
            Length[philist]}];\)\(
\)
    \)\)
arrowev = 
        Table[N[Normalize[
              CrossProduct[lre[[i, 2]], 
                lre[[i, 1]]]]], 
{i, 1, 
            Length[philist]}];

    
\(\(arrowre = 
        Table[{{\((rp)\)\ Sin[the]\ Cos[
                  philist[\([i]\)]], 
		\((rp)\)\ Sin[
                  the]\ Sin[
                  philist[\([i]\)]], 
		\((rp)\)\ Cos[
                  the]}, 
	
            arrowl\ arrowev[\([i]\)] + {\((rp)\)\ Sin[the]\ Cos[
                    philist[\([i]\)]], 
		\((rp)\)\ Sin[
                    the]\ Sin[
                    philist[\([i]\)]], 
		\((rp)\)\ Cos[
                    the]}}, 
{i, 1, 
            Length[philist]}];\)\)

dreh = -Table[-philist[[i]] Sin[Pi/2 - the], {i, 1, 
              Length[philist]}];
vect = 
        Table[{Sin[the] Cos[philist[[i]]], 
            Sin[the] Sin[philist[[i]]], Cos[the]}, {i, 1, 
            Length[philist]}];

\(\(\(lrot = 
        Table[{lre[\([i, 1]\)]\ Cos[dreh[\([i]\)]] + 
              vect[\([i]\)]*\((vect[\([i]\)] . lre[\([i, 1]\)])\)\ \((1 - 
                    Cos[dreh[\([i]\)]])\) - 
              CrossProduct[vect[\([i]\)], lre[\([i, 1]\)]]*
                Sin[dreh[\([i]\)]], 
            lre[\([i, 2]\)]\ Cos[dreh[\([i]\)]] + 
              vect[\([i]\)]*\((vect[\([i]\)] . lre[\([i, 2]\)])\)\ \((1 - 
                    Cos[dreh[\([i]\)]])\) - 
              CrossProduct[vect[\([i]\)], lre[\([i, 2]\)]]*
                Sin[dreh[\([i]\)]], 
            lre[\([i, 3]\)]\ Cos[dreh[\([i]\)]] + 
              vect[\([i]\)]*\((vect[\([i]\)] . lre[\([i, 3]\)])\)\ \((1 - 
                    Cos[dreh[\([i]\)]])\) - 
              CrossProduct[vect[\([i]\)], lre[\([i, 3]\)]]*
                Sin[dreh[\([i]\)]], 
            lre[\([i, 4]\)]\ Cos[dreh[\([i]\)]] + 
              vect[\([i]\)]*\((vect[\([i]\)] . lre[\([i, 4]\)])\)\ \((1 - 
                    Cos[dreh[\([i]\)]])\) - 
              CrossProduct[vect[\([i]\)], lre[\([i, 4]\)]]*
                Sin[dreh[\([i]\)]]}, {i, 1, Length[philist]}];\)\(
\)
    \)\)
arrowrot = 
        Table[{arrowre[[i, 1]] Cos[dreh[[i]]] + 
              vect[[i]]*(vect[[i]] . arrowre[[i, 1]]) (1 - 
                    Cos[dreh[[i]]]) - 
              CrossProduct[vect[[i]], arrowre[[i, 1]]]*
                Sin[dreh[[i]]], 
            arrowre[[i, 2]] Cos[dreh[[i]]] + 
              vect[[i]]*(vect[[i]] . arrowre[[i, 2]]) (1 - 
                    Cos[dreh[[i]]]) - 
              CrossProduct[vect[[i]], arrowre[[i, 2]]]*
                Sin[dreh[[i]]]}, 
{i, 1, 
            Length[philist]}];

Bahn des Pendelkörpers

Ψ = π/2 - the;
Ω = 2 π/10;
ω = 2 π;
UPendel0 = 1;
UPendel = 
        Function[t, 
          UPendel0/
              2*
((1 + ((Ω Sin[Ψ])/(Sqrt[(((Ω Sin[Ψ]))^2) + (ω^2)]))) (E^(I (Sqrt[(((Ω Sin[Ψ]))^2) + (ω^2)]) t )) + (1 - ((Ω Sin[Ψ])/(Sqrt[(((Ω Sin[Ψ]))^2) + (ω^2)]))) (E^(-I (Sqrt[(((Ω Sin[Ψ]))^2) + (ω^2)]) t ))) (E^(-I Ω Sin[Ψ] t))];
Stern = 
        ParametricPlot[{Re[UPendel[t]], Im[UPendel[t]]}, {t, 0, 
            10/Sin[Ψ]},  AspectRatio ->  Automatic,  
          PlotStyle ->  Hue[0.3]];

starline = 
        Table[{Hue[0], AbsoluteThickness[3], 
            Line[{{Cos[
                    philist[[k]] Sin[Ψ]], -Sin[
                      philist[[k]] Sin[Ψ]]}, {-Cos[
                      philist[[k]] Sin[Ψ]], 
                  Sin[philist[[k]] Sin[Ψ]]}}], 
            AbsoluteThickness[1.5], 
            Circle[{0, 0}, 
              0.6, {-philist[[k]] Sin[Ψ], 0}]}, {k, 1, 
            Length[philist]}];

Animation

\(\(Table[
        Show[GraphicsArray[{
Show[
                Graphics3D[{Polygon[lrot[\([k]\)]], Hue[0], Thickness[0.007], 
                    Line[arrowrot[\([k]\)]]}, 
					\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {PlotRange\  -> \ {{\(-6\), 6}, {\(-6\), 6}, {\(-6\), 
                          6}}, 
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ViewPoint\  -> {0, 0, 10}}], halfsphere, meridian[\([k]\)], 
                Boxed -> \ False, ImageSize\  -> \ 800, 
                DisplayFunction\  -> \ Identity], 
              Show[Stern, \ Graphics[starline[\([k]\)]], 
                DisplayFunction\  -> \ Identity\ ]}], 
          ImageSize\  -> \ 800, \ 
          DisplayFunction -> \ $DisplayFunction], \ \ \ \ \ \ \ \ 
							{k, 1, Length[philist]}];\)\)
SelectionMove[EvaluationNotebook[], After, 
        EvaluationCell];
SelectionMove[EvaluationNotebook[], Next, CellGroup];
FrontEndTokenExecute["OpenCloseGroup"];
start /. zeit -> 0.5 // DisplayForm