Big Rip & Big Crunch

wikipedia · Beitragvon **Yukterez** » Mi 4. Dez 2024, 05:55

Das ist die deutschsprachige Version. Bild

For the english version see here. Bild

Big Rip

Evolution eines Big Rip Universums mit H=H0·√[Ωr/a⁴+Ωm/a³+Ωk/a²+ΩΛ·a] (Zustandsgleichung für Λ: w=-4/3); Anfangsbedingungen bei a=1: H0=67.15, Ωm=0.315, ΩΛ=0.685, Ωr=0, Ωk=0 → der Big Rip tritt bei t=44.8 Milliarden Jahren nach dem Urknall ein. Raumzeitdiagramme in Proper, Comoving & Conformal Koordinaten, der Lichtkegel entspringt bei a=1, t=14.4169 Gyr. rH: Hubble Radius (blau), rE: Ereignishorizont (violett), rP: Partikelhorizont (grün), orange Kurve: Lichtkegel, graue Kurven: mitbewegte Weltlinien, R=r/a:

↑ proper, r(t) ◉ ↓ proper, r(a)

↑ proper, r(a) ◉ ↓ comoving, R(t)

↑ comoving, R(t) ◉ ↓ comoving, R(a)

↑ comoving, R(a) ◉ ↓ conformal, R(η)

↑ Raumzeitdiagramme ◉ ↓ Ω, ρ, E, a, ȧ, ä als Funktionen von t

Für einen Vergleich mit unserem Universum wo H=H0·√[Ωr/a⁴+Ωm/a³+Ωk/a²+ΩΛ] siehe hier. Code:

Code: Alles auswählen

   (* | Evolution of a Big Rip Universe | Simon Tyran, Vienna | www.yukterez.net | *)
   
   set = {"GlobalAdaptive", "MaxErrorIncreases"->100,
   Method->"GaussKronrodRule"};                                (* Integration Rule *)
   n = 100;                                                     (* Recursion Depth *)
   int[f_, {x_, xmin_, xmax_}] :=                                      (* Integral *)
   NIntegrate[f, {x, xmin, xmax},
   Method->set, MaxRecursion->n, WorkingPrecision->wp];
   wp = MachinePrecision;                                     (* Working Precision *)
   im = 320;                                                         (* Image Size *)
   tMax = 488/10 Gyr; tmax = tMax/Gyr;                        (* Integration Limit *)
   ηmax = 59.28619955687554;                               (* Conformal Plot Range *)
   prmax = 70; ptmax = tmax;                                    (* Time Plot Range *)
   
   c = 299792458 m/sek;                                              (* Lightspeed *)
   G = 667384*^-16 m^3 kg^-1 sek^-2;                            (* Newton Constant *)
   Gyr = 10^7*36525*24*3600 sek;                                  (* Billion Years *)
   Glyr = Gyr*c;                                             (* Billion Lightyears *)
   Mpc = 30856775777948584200000 m;                                  (* Megaparsec *)
   kB = 13806488*^-30 kg m^2/sek^2/K;                        (* Boltzmann Constant *)
   h = 662606957*^-42 kg m^2/sek;                               (* Planck Constant *)
   ρc[H_] := 3H^2/8/π/G;                                       (* Critical Density *)
   ρR = 8π^5 kB^4 T^4/15/c^5/h^3;                             (* Radiation Density *)
   ρΛ = ρc[H0] ΩΛ;                                          (* Dark Energy Density *)
   T = 2725/1000 K;                                             (* CMB Temperature *)
   kg = m = sek = 1;                                                   (* SI Units *)
   
   ΩR = 0;                             (* Radiation Proportion including Neutrinos *)
   ΩM = 315/1000;                       (* Matter Proportion including Dark Matter *)
   ΩΛ = 1-ΩM-ΩR;                                         (* Dark Energy Proportion *)
   ΩT = ΩR+ΩM+ΩΛ;                           (* Total Density over Critical Density *)
   ΩK = 1-ΩT;                                                 (* Curvature Density *)
   
   H0 = 67150 m/Mpc/sek;                                        (* Hubble Constant *)
   H[a_] := H0 Sqrt[ΩR/a^4+ΩM/a^3+ΩK/a^2+ΩΛ*a]                 (* Hubble Parameter *)
   
   sol = Quiet[NDSolve[{A'[t]/A[t] == H[A[t]], A[0] == 1*^-15},
   A, {t, 0, tMax},
   MaxSteps->∞, WorkingPrecision->wp]];
   
   a[t_] := Evaluate[(A[t]/.sol)[[1]]];                (* Scale Factor a by Time t *)
   т[a_] := int[1/A/H[A], {A, 0, a}];                  (* Time t by Scale Factor a *)
   rP[t_] := a[t] int[c/a[т], {т, 0, t}];          (* Proper Particle Horizon by t *)
   rp[a_] := a int[c/A^2/H[A], {A, 0, a}];         (* Proper Particle Horizon by a *)
   RP[t_] := int[c/a[т], {т, 0, t}];             (* Comoving Particle Horizon by t *)
   Rp[a_] := int[c/A^2/H[A], {A, 0, a}];         (* Comoving Particle Horizon by a *)
   rE[t_] := a[t] int[c/a[т], {т, t, tMax}];          (* Proper Event Horizon by t *)
   re[a_] := a int[c/A^2/H[A], {A, a, tMax}];         (* Proper Event Horizon by a *)
   RE[t_] := int[c/a[т], {т, t, tMax}];             (* Comoving Event Horizon by t *)
   Rε[a_] := int[c/A^2/H[A], {A, a, tMax}];         (* Comoving Event Horizon by a *)
   rL[t0_, t_] := a[t] int[c/a[т], {т, t, t0}];          (* Proper Light Cone by t *)
   rl[a0_, a_] := a int[c/A^2/H[A], {A, a, a0}];         (* Proper Light Cone by a *)
   RL[t0_, t_] := int[c/a[т], {т, t, t0}];             (* Comoving Light Cone by t *)
   Rl[a0_, a_] := int[c/A^2/H[A], {A, a, a0}];         (* Comoving Light Cone by a *)
   rH[t_] := c/H[a[t]];                               (* Proper Hubble Radius by t *)
   rh[a_] := c/H[a];                                  (* Proper Hubble Radius by a *)
   RH[t_] := c/H[a[t]]/a[t];                        (* Comoving Hubble Radius by t *)
   Rh[a_] := c/H[a]/a;                              (* Comoving Hubble Radius by a *)
   
   t0 = Re[t/.FindRoot[a[t]-1, {t, 10 Gyr}]]; ti = t Gyr; τi = τ Gyr;
   "t0"->t0/Gyr "Gyr"                                              (* Current Time *)
   
   ã[η_] := Quiet[FindRoot[Rp[Ã]/Glyr-η,     (* Scale Factor a by Conformal Time η *)
   {Ã, 0.00001}, WorkingPrecision->wp, MaxIterations->1000][[1, 2]]];
   ā = Quiet[Interpolation[Join[{{0, 0}}, 
   ParallelTable[{((Sin[η π/ηmax-π/2]+1) ηmax/2), 
   ã[((Sin[η π/ηmax-π/2]+1) ηmax/2)]}, {η, ηmax/im, ηmax, ηmax/im}]]]];
   
   Ť[η_] := Quiet[FindRoot[RP[τ Gyr]/Glyr-η,                             (* t by η *)
   {τ, 1}, WorkingPrecision->wp, MaxIterations->1000][[1, 2]]]
   (* ţ = Quiet[Interpolation[Join[{{0, 0}}, 
   ParallelTable[{((Sin[η π/ηmax-π/2]+1) ηmax/2), 
   Ť[((Sin[η π/ηmax-π/2]+1) ηmax/2)]}, {η, ηmax/im, ηmax, ηmax/im}]]]]; *)
   
   rpN = Rp[1]/Glyr;
    
   "PROPER DISTANCES, f(t)"
   
   pt = Quiet[Plot[
   {rH[τi]/Glyr, rP[τi]/Glyr, rE[τi]/Glyr},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]},
   {Darker[Green], Thickness[0.005]}, {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot1[t_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rL[ti, τi]/Glyr, -rL[ti, τi]/Glyr},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], pt]], 90 Degree]}}]];
   
   Do[Print[plot1[t]], {t, {t0/Gyr}}]
   
   plot2 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[a[τ Gyr] n^(7/2)/250, {n, 1, 55, 1}]],
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, ImagePadding->1]], 90 Degree]}}]]
   
   "COMOVING DISTANCES, f(t)"
   
   ct = Quiet[Plot[
   {rH[τi]/(a[τi]Glyr), rP[τi]/(a[τi]Glyr), rE[τi]/(a[τi]Glyr)},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]},
   {Darker[Green], Thickness[0.005]}, {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot3[t_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rL[ti, τi]/(a[τi]Glyr), -rL[ti, τi]/(a[τi]Glyr)},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], ct]], 90 Degree]}}]];
   
   Do[Print[plot3[t]], {t, {t0/Gyr}}]
   
   plot4 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n, {n, 10, 100, 10}]],
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, ImagePadding->1]], 90 Degree]}}]]
   
   "PROPER DISTANCES, f(a)"
   
   pa = Quiet[Plot[
   {rh[α]/Glyr, rp[α]/Glyr, re[α]/Glyr},
   {α, 0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, prmax Gyr/t0}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]},
   {Darker[Green], Thickness[0.005]}, {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot5[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rl[å, α]/Glyr, -rl[å, α]/Glyr},
   {α, 0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, prmax Gyr/t0}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], pa]], 90 Degree]}}]];
   
   Do[Print[plot5[å]], {å, {1}}]
   
   plot6 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[α n^(7/2)/250, {n, 1, 55, 1}]],
   {α, 0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, prmax Gyr/t0}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, ImagePadding->1]], 90 Degree]}}]]
   
   "COMOVING DISTANCES, f(a)"
   
   ca = Quiet[Plot[
   {rh[α]/Glyr/α, rp[α]/Glyr/α, re[α]/Glyr/α},
   {α, 0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, prmax Gyr/t0}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]},
   {Darker[Green], Thickness[0.005]}, {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot7[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rl[å, α]/Glyr/α, -rl[å, α]/Glyr/α},
   {α, 0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, prmax Gyr/t0}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], ca]], 90 Degree]}}]];
   
   Do[Print[plot7[å]], {å, {1}}]
   
   plot8 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n, {n, 10, 100, 10}]],
   {α, 0, prmax Gyr/t0}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, prmax Gyr/t0}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, ImagePadding->1]], 90 Degree]}}]]
   
   "CONFORMAL DIAGRAM, f(η)"
   
   cη = Quiet[Plot[
   {Rh[ā[Ct]]/Glyr, Ct, Rε[ā[Ct]]/Glyr},
   {Ct, 0, ηmax}, Frame->True, AspectRatio->prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]},
   {Darker[Green], Thickness[0.005]}, {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot9[η_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {η-Ct, Ct-η}, {Ct, 0, ηmax},
   Frame->True, AspectRatio->prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], cη]], 90 Degree]}}]];
   
   Do[Print[plot9[η]], {η, {rpN}}]
   
   plot10 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n, {n, 10, 100, 10}]],
   {Ct, 0, ηmax}, Frame->True, AspectRatio->prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, ImagePadding->1]], 90 Degree]}}]]
   
   s[text_] := Style[text, FontFamily->"Lucida Console", FontSize->36]

wikipedia · Beitragvon **Yukterez** » Mi 4. Dez 2024, 11:23

Big Crunch

Evolution eines Big Crunch Universums mit Ωr=2, Ωk=-1 und H=H0·√[Ωr/a⁴+Ωk/a²] (Ωm und ΩΛ wurden auf 0 gesetzt); Anfangsbedingungen bei a=1: H0=67.15 → der Big Crunch tritt t=√8/H0=41.1856 Milliarden Jahren nach dem Urknall ein (der Hubbleparameter wechselt bei a=√2 und t=√2/H0=20.5928 das Vorzeichen). Der finale mitbewegte Partikelhorizont reicht bis zur Antipode bei R=π·RK=64.6921 Glyr. Raumzeitdiagamme in Proper Distance r(t), Comoving Distance R(t) & nach Conformal Time R(η) Koordinaten. rH: Hubble Radius (blau), rE: Ereignishorizont (keiner), rP: Partikelhorizont (grün), rM: Antipode π·rK (violett), orange Kurve: Lichtkegel, graue Kurven: mitbewegte Weltlinien, R=r/a.

↑ proper, r(t) ◉ ↓ proper, r(a)

↑ proper, r(a) ◉ ↓ comoving, R(t)

↑ comoving, R(t) ◉ ↓ comoving, R(a)

↑ comoving, R(a) ◉ ↓ conformal, R(η)

↑ conformal, R(η) ◉ ↓ polar, R(t)→φ(Я) & R(a)→φ(Я) & R(η)→φ(Я)

↑ Raumzeitdiagramme ◉ ↓ Ω, ρ, E, a, ȧ, ä als Funktionen von t

Unten mit Ωm=2, Ωk=-1 → H wechselt bei a=2 und t=π/H0 das Vorzeichen (der Lichtkegel entspringt ebendann):

↑ proper, r(t) ◉ ↓ proper, r(a)

↑ proper, r(a) ◉ ↓ comoving, R(t)

↑ comoving, R(t) ◉ ↓ comoving, R(a)

↑ comoving, R(a) ◉ ↓ conformal, R(η)

↑ conformal, R(η) ◉ ↓ polar, R(t)→φ(Я) & R(a)→φ(Я) & R(η)→φ(Я)

↑ Raumzeitdiagramme ◉ ↓ Ω, ρ, E, a, ȧ, ä als Funktionen von t

Im materiedominierten Ωm=2 Szenario geht der finale mitbewegte Partikelhorizont bis zur doppelten Antipodendistanz, das Licht das hier beim Urknall emittiert wird macht bis zum Big Crunch einen kompletten Roundtrip durch das Universum.

Code: Alles auswählen

   (* Radiation Dominated Big Crunch Universe | Simon Tyran | https://yukterez.net *)
   
   set = {"GlobalAdaptive", "MaxErrorIncreases"->100};         (* Integration Rule *)
   n = 100;                                                     (* Recursion Depth *)
   int[f_, {x_, xmin_, xmax_}] :=                                      (* Integral *)
   Quiet[NIntegrate[f, {x, xmin, xmax},
   Method->set, MaxRecursion->n, WorkingPrecision->wp]];
   wp = MachinePrecision;                                     (* Working Precision *)
   im = 180;                                                         (* Image Size *)
   prmax = 70; ptmax = tmax;                                 (* Regular Plot Range *)
   
   c = 299792458 m/sek;                                              (* Lightspeed *)
   G = 667384*^-16 m^3 kg^-1 sek^-2;                            (* Newton Constant *)
   Gyr = 10^7*36525*24*3600 sek;                                  (* Billion Years *)
   Glyr = Gyr*c;                                             (* Billion Lightyears *)
   Mpc = 30856775777948584200000 m;                                  (* Megaparsec *)
   ρc[H_] := 3H^2/8/π/G;                                       (* Critical Density *)
   kg = m = sek = 1;                                                   (* SI Units *)
   
   ΩR = 2;                             (* Radiation Proportion including Neutrinos *)
   ΩM = 0;                              (* Matter Proportion including Dark Matter *)
   ΩΛ = 0;                                               (* Dark Energy Proportion *)
   ΩT = ΩR+ΩM+ΩΛ;                           (* Total Density over Critical Density *)
   ΩK = 1-ΩT;                                                 (* Curvature Density *)
   rK = c/H0/Sqrt[-ΩK];                                        (* Curvature Radius *)
   
   H0 = 67150 m/Mpc/sek;                                        (* Hubble Constant *)
   H[a_] := H0 Sqrt[ΩR/a^4+ΩM/a^3+ΩK/a^2+ΩΛ]                   (* Hubble Parameter *)
   Ж[t_] := (Sqrt[ΩR]+H0(t-t ΩR))/(t(2Sqrt[ΩR]+H0 (t-t ΩR)));
   
   a[t_]  := Re[Sqrt[H0 t (2Sqrt[ΩR]+H0 (t-t ΩR))]];   (* Scale Factor a by Time t *)
   т[a_]  := Re[(2H0 Sqrt[ΩR]-Sqrt[-4a^2 H0^2 (-1+ΩR)+4H0^2ΩR])/(2H0^2(ΩR-1))];
   
   rP[t_] := Re[a[t] int[c/a[т], {т, 0, t}]];      (* Proper Particle Horizon by t *)
   rp[a_] := Re[a int[c/A^2/H[A], {A, 0, a}]];     (* Proper Particle Horizon by a *)
   RP[t_] := Re[int[c/a[т], {т, 0, t}]];         (* Comoving Particle Horizon by t *)
   Rp[a_] := Re[int[c/A^2/H[A], {A, 0, a}]];     (* Comoving Particle Horizon by a *)
   
   rE[t_] := Nothing;                                 (* Proper Event Horizon by t *)
   re[a_] := Nothing;                                 (* Proper Event Horizon by a *)
   RE[t_] := Nothing;                               (* Comoving Event Horizon by t *)
   Rε[a_] := Nothing;                               (* Comoving Event Horizon by a *)
   
   rL[t0_, t_] := Re[a[t] int[c/a[т], {т, t, t0}]];      (* Proper Light Cone by t *)
   rl[a0_, a_] := Re[a int[c/A^2/H[A], {A, a, a0}]];     (* Proper Light Cone by a *)
   RL[t0_, t_] := Re[int[c/a[т], {т, t, t0}]];         (* Comoving Light Cone by t *)
   Rl[a0_, a_] := Re[int[c/A^2/H[A], {A, a, a0}]];     (* Comoving Light Cone by a *)
   
   rH[t_] := c/Abs[Ж[t]];                             (* Proper Hubble Radius by t *)
   rh[a_] := c/Abs[H[a]];                             (* Proper Hubble Radius by a *)
   RH[t_] := c/Abs[Ж[t]*a[t]];                      (* Comoving Hubble Radius by t *)
   Rh[a_] := c/Abs[H[a]*a];                         (* Comoving Hubble Radius by a *)

   t0 = Re[t/.FindRoot[a[t]-1, {t, 10 Gyr}]];    
   tmid = Sqrt[2]/H0; ti = t Gyr; τi = τ Gyr;
   "t0"->N[t0/Gyr] "Gyr"                                           (* Current Time *)
   
   tMax = 2*tmid; tmax = tMax/Gyr;
   rpN = π/2/H0/Gyr;
   ηmax = 2 rpN;
   
   RPa = Quiet[Interpolation[Join[{{Sqrt[2], rpN}},
   ParallelTable[{a[t], RP[t]/Glyr}, 
   {t, tmid+tmid/im, tMax-tmid/im, tmid/im}], 
   {{0, ηmax}}]]];

   Ť[η_] := Quiet[FindRoot[RP[τ Gyr]/Glyr-η,                             (* t by η *)
   {τ, ((Sin[η π/ηmax-π/2]+1)/2) ptmax}, WorkingPrecision->wp, 
   MaxIterations->1000][[1, 2]]]
   
   "PROPER DISTANCES, f(t)"
   
   pt = Quiet[Plot[
   {rH[τi]/Glyr, rP[τi]/Glyr, π rK a[τi]/Glyr, 
   2 π rK a[τi]/Glyr, 3 π rK a[τi]/Glyr},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]},
   {Darker[Green], Thickness[0.005]}, 
   {Purple, Thickness[0.005]},
   {{Purple, Thickness[0.005]}, Dashed}, 
   {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot1[t_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rL[ti, τi]/Glyr, -rL[ti, τi]/Glyr},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, 
   {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], pt]], 90 Degree]}}]];
   
   Do[Print[plot1[t]], {t, {ptmax/2}}]
   
   plot2 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[a[τ Gyr] n/Sqrt[2], {n, 10, 70, 10}], 
   Table[a[τ Gyr] n/Sqrt[2],
   {n, {100, 160, 340}}]], {τ, 0, ptmax}, Frame->True, 
   AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, 
   ImagePadding->1]], 90 Degree]}}]]
   
   "COMOVING DISTANCES, f(t)"
   
   ct = Quiet[Plot[
   {RH[τi]/Glyr, RP[τi]/Glyr, π rK/Glyr, 
   2 π rK/Glyr, 3 π rK/Glyr},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]},
   {Darker[Green], Thickness[0.005]}, 
   {Purple, Thickness[0.005]},
   {{Purple, Thickness[0.005]}, Dashed}, 
   {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot3[t_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rL[ti, τi]/(a[τi]Glyr), -rL[ti, τi]/(a[τi]Glyr)},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, 
   {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], ct]], 90 Degree]}}]];
   
   Do[Print[plot3[t]], {t, {ptmax/2}}]
   
   plot4 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n, {n, 10, 100, 10}]],
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, 
   ImagePadding->1]], 90 Degree]}}]]
   
   "PROPER DISTANCES, f(a)"
   
   pa = Quiet[Plot[
   {rh[α]/Glyr, rp[α]/Glyr, π rK α/Glyr, 
   2 π rK α/Glyr, 3 π rK α/Glyr},
   {α, 0, Sqrt[2]}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, Sqrt[2]}, {0, prmax}},
   PlotStyle->{{Thickness[2 0.005]},
   {Darker[Green], Thickness[2 0.005]}, 
   {Purple, Thickness[2 0.005]},
   {{Purple, Thickness[2 0.005]}, Dashed}, 
   {Purple, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   pb = Quiet[Plot[
   {rh[α]/Glyr, RPa[α] α, π rK α/Glyr, 
   2 π rK α/Glyr, 3 π rK α/Glyr},
   {α, 0, Sqrt[2]}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, Sqrt[2]}, {0, prmax}},
   PlotStyle->{{Thickness[2 0.005]},
   {Darker[Green], Thickness[2 0.005]}, 
   {Purple, Thickness[2 0.005]},
   {{Purple, Thickness[2 0.005]}, Dashed}, 
   {Purple, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot5a[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rl[å, α]/Glyr, -rl[å, α]/Glyr},
   {α, 0, Sqrt[2]}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, Sqrt[2]}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[2 0.005]}, 
   {{Orange, Thickness[2 0.005]}, Dashed}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], pa]], 90 Degree]}}]];
   
   plot5b[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rl[å, α]/Glyr, -rl[å, α]/Glyr},
   {α, 0, Sqrt[2]}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, Sqrt[2]}, {0, prmax}},
   PlotStyle->{{{Orange, Thickness[2 0.005]}, Dashed}, 
   {Orange, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], pb]], -90 Degree]}}]];
   
   Do[Print[plot5a[å]], {å, {Sqrt[2]}}]
   Do[Print[plot5b[å]], {å, {Sqrt[2]}}]
   
   plot6 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n α/Sqrt[8] , 
   {n, 20, 140, 20}], {90 α/Sqrt[2], 
   160 α/Sqrt[2], 1000 α/Sqrt[2]}],
   {α, 0, Sqrt[2]}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, Sqrt[2]}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[2 0.005],
   Gray}, {n, 1, 100}], ImageSize->im, 
   ImagePadding->1]], 90 Degree]}}]]
   
   "COMOVING DISTANCES, f(a)"
   
   ca = Quiet[Plot[
   {Rh[α]/Glyr, Rp[α]/Glyr, π rK/Glyr, 
   2 π rK/Glyr, 3 π rK/Glyr},
   {α, 0, Sqrt[2]}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, Sqrt[2]}, {0, prmax}},
   PlotStyle->{{Thickness[2 0.005]},
   {Darker[Green], Thickness[2 0.005]}, 
   {Purple, Thickness[2 0.005]},
   {{Purple, Thickness[2 0.005]}, Dashed}, 
   {Purple, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   cb = Quiet[Plot[
   {Rh[α]/Glyr, RPa[α], π rK/Glyr, 
   2 π rK/Glyr, 3 π rK/Glyr},
   {α, 0, Sqrt[2]}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, Sqrt[2]}, {0, prmax}},
   PlotStyle->{{Thickness[2 0.005]},
   {Darker[Green], Thickness[2 0.005]}, 
   {Purple, Thickness[2 0.005]},
   {{Purple, Thickness[2 0.005]}, Dashed}, 
   {Purple, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot7a[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {Rl[å, α]/Glyr, -Rl[å, α]/Glyr},
   {α, 0, Sqrt[2]}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, Sqrt[2]}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[2 0.005]}, 
   {{Orange, Thickness[2 0.005]}, Dashed}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], ca]], 90 Degree]}}]];
   
   plot7b[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {Rl[å, α]/Glyr, -Rl[å, α]/Glyr},
   {α, 0, Sqrt[2]}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, Sqrt[2]}, {0, prmax}},
   PlotStyle->{{{Orange, Thickness[2 0.005]}, Dashed}, 
   {Orange, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], cb]], -90 Degree]}}]];
   
   Do[Print[plot7a[å]], {å, {Sqrt[2]}}]
   Do[Print[plot7b[å]], {å, {Sqrt[2]}}]
   
   plot8 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n, {n, 10, 100, 10}]],
   {α, 0, Sqrt[2]}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, Sqrt[2]}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[2 0.005],
   Gray}, {n, 1, 100}], ImageSize->im, 
   ImagePadding->1]], 90 Degree]}}]]
   
   "CONFORMAL DIAGRAM, f(η)"
   
   cη = Quiet[Plot[
   {RH[Ť[Ct] Gyr]/Glyr, Ct, π rK/Glyr, 
   2 π rK/Glyr, 3 π rK/Glyr},
   {Ct, 0, ηmax}, Frame->True, AspectRatio->prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]}, 
   {Darker[Green], Thickness[0.005]}, 
   {Purple, Thickness[0.005]},
   {{Purple, Thickness[0.005]}, Dashed}, 
   {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot9[η_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {η-Ct, Ct-η}, {Ct, 0, ηmax},
   Frame->True, AspectRatio->prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, 
   {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], cη]], 90 Degree]}}]];
   
   Do[Print[plot9[η]], {η, {rpN}}]
   
   plot10 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n, {n, 10, 100, 10}]],
   {Ct, 0, ηmax}, Frame->True, AspectRatio->prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, 
   ImagePadding->1]], 90 Degree]}}]]
   
   s[text_] := Style[text, FontFamily->"Lucida Console", FontSize->36]

Code: Alles auswählen

   (* Matter Dominated Big Crunch Universe | Simon Tyran | http://org.yukterez.net *)
   
   set = {"GlobalAdaptive", "MaxErrorIncreases"->1000};        (* Integration Rule *)
   n = 1000;                                                    (* Recursion Depth *)
   int[f_, {x_, xmin_, xmax_}] :=                                      (* Integral *)
   Quiet[NIntegrate[f, {x, xmin, xmax},
   Method->set, MaxRecursion->n, WorkingPrecision->wp]];
   wp = 20;                                                   (* Working Precision *)
   im = 180;                                                         (* Image Size *)
   prmax = 140; ptmax = tmax;                                (* Regular Plot Range *)
   
   c = 299792458 m/sek;                                              (* Lightspeed *)
   G = 667384*^-16 m^3 kg^-1 sek^-2;                            (* Newton Constant *)
   Gyr = 10^7*36525*24*3600 sek;                                  (* Billion Years *)
   Glyr = Gyr*c;                                             (* Billion Lightyears *)
   Mpc = 30856775777948584200000 m;                                  (* Megaparsec *)
   kB = 13806488*^-30 kg m^2/sek^2/K;                        (* Boltzmann Constant *)
   h = 662606957*^-42 kg m^2/sek;                               (* Planck Constant *)
   ρc[H_] := 3H^2/8/π/G;                                       (* Critical Density *)
   ρR = 8π^5 kB^4 T^4/15/c^5/h^3;                             (* Radiation Density *)
   ρΛ = ρc[H0] ΩΛ;                                          (* Dark Energy Density *)
   T = 2725/1000 K;                                             (* CMB Temperature *)
   kg = m = sek = 1;                                                   (* SI Units *)
   
   ΩR = 0;                             (* Radiation Proportion including Neutrinos *)
   ΩM = 2;                              (* Matter Proportion including Dark Matter *)
   ΩΛ = 0;                                               (* Dark Energy Proportion *)
   ΩT = ΩR+ΩM+ΩΛ;                           (* Total Density over Critical Density *)
   ΩK = 1-ΩT;                                                 (* Curvature Density *)
   rK = c/H0/Sqrt[-ΩK];                                        (* Curvature Radius *)
   
   tmid = π/H0; 
   tMax = 2*tmid; 
   tmax = tMax/Gyr;
   
   a0 = 1*^-15;                                            (* Initial Scale Factor *)
   H0 = 67150 m/Mpc/sek;                                        (* Hubble Constant *)
    
   f1[x_]:=(ΩM Log[-Sqrt[1-ΩM] Sqrt[x]+Sqrt[ΩM+x-ΩM x]] Sqrt[ΩM+x-ΩM x]+
   Sqrt[1-ΩM] Sqrt[x] (ΩM+x-ΩM x))/((1-ΩM)^(3/2) x^(3/2) Sqrt[(ΩM+x-ΩM x)/x^3]);

   x1[t_]:=(-Sqrt[a0 (1-ΩM)] (-ΩM+a0 (-1+ΩM) (1+H0 t Sqrt[(a0+ΩM-a0 ΩM)/a0^3]))+
   ΩM Sqrt[a0+ΩM-a0 ΩM] Log[-Sqrt[a0 (1-ΩM)]+Sqrt[a0+ΩM-
   a0 ΩM]])/(a0^(3/2) (1-ΩM)^(3/2) Sqrt[(a0+ΩM-a0 ΩM)/a0^3]);

   sol = Quiet[NDSolve[{A'[t]/A[t] == H[A[t]], A[0] == a0},
   A, {t, 0, tmid},
   MaxSteps->∞, WorkingPrecision->wp]];
   
   H[a_] := H0 Sqrt[ΩR/a^4+ΩM/a^3+ΩK/a^2+ΩΛ]; Ж[t_] := H[a[t]]; (* Hubbleparameter *)
   
   Â[t_] := InverseFunction[f1[#1] &][x1[t]];            (*Scale Factor a by Time t*)
   Å[t_] := Evaluate[(A[t]/.sol)[[1]]];
   a[t_] := If[t<tmid, Re[Å[t]], Re[Å[tMax-t]]];
   
   (* a = Quiet[Interpolation[Join[{{0, a0}},
   ParallelTable[{tmid (Sin[π t/tmid/2])^4, Re[ã[tmid (Sin[π t/tmid/2])^4]]}, 
   {t, tmid/im, tmid-tmid/im, tmid/im}], 
   {{tmid, 2}},
   ParallelTable[{t, Re[ã[t]]}, 
   {t, tmid+tmid/im, tMax-tmid/im, tmid/im}],
   {{tMax, a0}}]]]; *)

   rP[t_] := a[t] int[c/a[т], {т, 0, t}];          (* Proper Particle Horizon by t *)
   rp[a_] := a int[c/A^2/H[A], {A, a0, a}];        (* Proper Particle Horizon by a *)
   RP[t_] := int[c/a[т], {т, 0, t}];             (* Comoving Particle Horizon by t *)
   Rp[a_] := int[c/A^2/H[A], {A, a0, a}];        (* Comoving Particle Horizon by a *)
   
   rE[t_] := Nothing;                                 (* Proper Event Horizon by t *)
   re[a_] := Nothing;                                 (* Proper Event Horizon by a *)
   RE[t_] := Nothing;                               (* Comoving Event Horizon by t *)
   Rε[a_] := Nothing;                               (* Comoving Event Horizon by a *)
   
   rL[t0_, t_] := a[t] int[c/a[т], {т, t, t0}];          (* Proper Light Cone by t *)
   rl[a0_, a_] := a int[c/A^2/H[A], {A, a, a0}];         (* Proper Light Cone by a *)
   RL[t0_, t_] := int[c/a[т], {т, t, t0}];             (* Comoving Light Cone by t *)
   Rl[a0_, a_] := int[c/A^2/H[A], {A, a, a0}];         (* Comoving Light Cone by a *)
   
   rH[t_] := c/Abs[Ж[t]];                             (* Proper Hubble Radius by t *)
   rh[a_] := If[1.99<a, Infinity, c/Abs[H[a]]];       (* Proper Hubble Radius by a *)   
   RH[t_] := c/Abs[Ж[t]a[t]];                       (* Comoving Hubble Radius by t *)
   Rh[a_] := If[a>1.99, Infinity, c/Abs[H[a]a]];    (* Comoving Hubble Radius by a *)
   
   t0 = Quiet[Re[t/.FindRoot[a[t]-1, {t, 10 Gyr}, WorkingPrecision->wp]]]; 
   ti = t Gyr; τi = τ Gyr;
   "t0"->t0/Gyr "Gyr"                                              (* Current Time *)

   ηmax = 2 π/H0/Gyr;
   rpN = ηmax/2;
   fx = 100/101;
   
   RPa = Quiet[Interpolation[Join[{{2, rpN}},
   ParallelTable[{a[t], RP[t]/Glyr}, 
   {t, tmid+tmid/im, tMax-tmid/im, tmid/im}], 
   {{0, ηmax}}]]];
   
   ηH = Quiet[Interpolation[Join[{{0, 0}}, (* Hubble Radius by Conformal Time *)
   ParallelTable[
   {RP[tMax (Sin[π t/tmax/2])^4]/Glyr, Rh[a[tMax (Sin[π t/tmax/2])^4]]/Glyr}, 
   {t, tmax/im, tmax-tmax/im, tmax/im}],
   {{ηmax, 0}}]]];
   
   "PROPER DISTANCES, f(t)"
   
   pt = Quiet[Plot[
   {rh[a[τi]]/Glyr, rP[τi]/Glyr, π rK a[τi]/Glyr, 
   2 π rK a[τi]/Glyr, 3 π rK a[τi]/Glyr},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]},
   {Darker[Green], Thickness[0.005]}, 
   {Purple, Thickness[0.005]},
   {{Purple, Thickness[0.005]}, Dashed}, 
   {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot1[t_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rL[ti, τi]/Glyr, -rL[ti, τi]/Glyr},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, 
   {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], pt]], 90 Degree]}}]];
   
   Do[Print[plot1[t]], {t, {tmax/2}}]
   
   plot2 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, 
   Table[a[τ Gyr] n/2, {n, 20, 140, 20}], 
   Table[a[τ Gyr] n/2, {n, {180, 260, 420}}]], 
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, 
   ImagePadding->1]], 90 Degree]}}]]
   
   "COMOVING DISTANCES, f(t)"
   
   ct = Quiet[Plot[
   {Rh[a[τi]]/Glyr, RP[τi]/Glyr, π rK/Glyr, 
   2 π rK/Glyr, 3 π rK/Glyr},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]},
   {Darker[Green], Thickness[0.005]}, 
   {Purple, Thickness[0.005]},
   {{Purple, Thickness[0.005]}, Dashed}, 
   {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot3[t_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {RL[ti, τi]/Glyr, -RL[ti, τi]/Glyr},
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, 
   {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], ct]], 90 Degree]}}]];
   
   Do[Print[plot3[t]], {t, {tmax/2}}]
   
   plot4 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n, {n, 10, prmax, 10}]],
   {τ, 0, ptmax}, Frame->True, AspectRatio->prmax/ptmax,
   FrameTicks->None, PlotRange->{{0, ptmax}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, 
   ImagePadding->1]], 90 Degree]}}]]
   
   "PROPER DISTANCES, f(a)"
   
   pa = Quiet[Plot[
   {rh[α]/Glyr, rp[α]/Glyr, π rK α/Glyr, 
   2 π rK α/Glyr, 3 π rK α/Glyr},
   {α, 0, 2}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, 2}, {0, prmax}},
   PlotStyle->{{Thickness[2 0.005]},
   {Darker[Green], Thickness[2 0.005]}, 
   {Purple, Thickness[2 0.005]},
   {{Purple, Thickness[2 0.005]}, Dashed}, 
   {Purple, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   pb = Quiet[Plot[
   {rh[α]/Glyr, RPa[α] α, π rK α/Glyr, 
   2 π rK α/Glyr, 3 π rK α/Glyr},
   {α, 0, 2}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, 2}, {0, prmax}},
   PlotStyle->{{Thickness[2 0.005]},
   {Darker[Green], Thickness[2 0.005]}, 
   {Purple, Thickness[2 0.005]},
   {{Purple, Thickness[2 0.005]}, Dashed}, 
   {Purple, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot5a[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rl[å, α]/Glyr, -rl[å, α]/Glyr},
   {α, 0, 2}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, 2}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[2 0.005]}, 
   {{Orange, Thickness[2 0.005]}, Dashed}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], pa]], 90 Degree]}}]];
   
   plot5b[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {rl[å, α]/Glyr, -rl[å, α]/Glyr},
   {α, 0, 2}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, 2}, {0, prmax}},
   PlotStyle->{{{Orange, Thickness[2 0.005]}, Dashed}, 
   {Orange, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], pb]], -90 Degree]}}]];
   
   Do[Print[plot5a[å]], {å, {2}}]
   Do[Print[plot5b[å]], {å, {2}}]
   
   plot6 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n α/2 , {n, 20, 140, 20}], 
   {90 α, 160 α, 1000 α}],
   {α, 0, 2}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, 2}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[2 0.005],
   Gray}, {n, 1, 100}], ImageSize->im, 
   ImagePadding->1]], 90 Degree]}}]]
   
   "COMOVING DISTANCES, f(a)"
   
   ca = Quiet[Plot[
   {Rh[α]/Glyr, Rp[α]/Glyr, π rK/Glyr, 
   2 π rK/Glyr, 3 π rK/Glyr},
   {α, 0, 2}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, 2}, {0, prmax}},
   PlotStyle->{{Thickness[2 0.005]},
   {Darker[Green], Thickness[2 0.005]}, 
   {Purple, Thickness[2 0.005]},
   {{Purple, Thickness[2 0.005]}, Dashed}, 
   {Purple, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   cb = Quiet[Plot[
   {Rh[α]/Glyr, RPa[α], π rK/Glyr, 
   2 π rK/Glyr, 3 π rK/Glyr},
   {α, 0, 2}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, 2}, {0, prmax}},
   PlotStyle->{{Thickness[2 0.005]},
   {Darker[Green], Thickness[2 0.005]}, 
   {Purple, Thickness[2 0.005]},
   {{Purple, Thickness[2 0.005]}, Dashed}, 
   {Purple, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot7a[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {Rl[å, α]/Glyr, -Rl[å, α]/Glyr},
   {α, 0, 2}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, 2}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[2 0.005]}, 
   {{Orange, Thickness[2 0.005]}, Dashed}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], ca]], 90 Degree]}}]];
   
   plot7b[å_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {Rl[å, α]/Glyr, -Rl[å, α]/Glyr},
   {α, 0, 2}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, 2}, {0, prmax}},
   PlotStyle->{{{Orange, Thickness[2 0.005]}, Dashed}, 
   {Orange, Thickness[2 0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], cb]], -90 Degree]}}]];
   
   Do[Print[plot7a[å]], {å, {2}}]
   Do[Print[plot7b[å]], {å, {2}}]
   
   plot8 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n, {n, 20, 200, 20}]],
   {α, 0, 2}, Frame->True, AspectRatio->2 prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, 2}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[2 0.005],
   Gray}, {n, 1, 100}], ImageSize->im, 
   ImagePadding->1]], 90 Degree]}}]]
   
   "CONFORMAL DIAGRAM, f(η)"
   
   cη = Quiet[Plot[
   {Piecewise[{
   {Piecewise[{{ηH[Ct], Ct<fx rpN}, 
   {1*^6, Ct>fx rpN}}], Ct<rpN},
   {Piecewise[{{1*^6, Ct<rpN/fx}, 
   {ηH[ηmax-Ct], Ct>rpN/fx}}], Ct>rpN}}], 
   Ct, π rK/Glyr, 
   2 π rK/Glyr, 3 π rK/Glyr},
   {Ct, 0, ηmax}, Frame->True, AspectRatio->prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}},
   PlotStyle->{{Thickness[0.005]},
   {Darker[Green], Thickness[0.005]}, 
   {Purple, Thickness[0.005]},
   {{Purple, Thickness[0.005]}, Dashed}, 
   {Purple, Thickness[0.005]}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], 
   ImagePadding->1,
   GridLines->{{}, {}}]];
   
   plot9[η_] := Rasterize[Grid[{{Rotate[Quiet[Show[Plot[
   {η-Ct, Ct-η}, {Ct, 0, ηmax},
   Frame->True, AspectRatio->prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}},
   PlotStyle->{{Orange, Thickness[0.005]}, 
   {{Orange, Thickness[0.005]}, Dashed}},
   ImageSize->im, Filling->Top, 
   FillingStyle->Opacity[0.1], ImagePadding->1,
   GridLines->{{}, {}}], cη]], 90 Degree]}}]];
   
   Do[Print[plot9[η]], {η, {rpN}}]
   
   plot10 = Rasterize[Grid[{{Rotate[Quiet[Plot[
   Join[{0}, Table[n, {n, 20, prmax, 20}]],
   {Ct, 0, ηmax}, Frame->True, AspectRatio->prmax/ηmax,
   FrameTicks->None, PlotRange->{{0, ηmax}, {0, prmax}},
   PlotStyle->Table[{Dashing->Large, Thickness[0.005],
   Gray}, {n, 1, 100}], ImageSize->im, 
   ImagePadding->1]], 90 Degree]}}]]
   
   s[text_] := Style[text, FontFamily->"Lucida Console", FontSize->36]

Metrik, Tensoren und Bewegungsgleichungen: hier entlang, für ein statisches Urknalluniversum siehe hier.

Notizblock