Work.

1 files changed, 69 insertions, 12 deletions

diff --git a/schofield.wl b/schofield.wl
index fdb76e3..6adbe10 100644
--- a/schofield.wl
+++ b/schofield.wl
@@ -1,12 +1,7 @@
 
 BeginPackage["Schofield`"]
 
-β::usage = "Gives the exponent for the magnetization."
-δ::usage = "Exponent."
-α::usage = "Exponent."
-Δ::usage = "Exponent."
-
-$Assumptions = {θc > 0, θi > 0, θc > θi, gC[_] ∈ Reals, B > 0, γ > 0}
+$Assumptions = {θc > 0, θc > 1, gC[_] ∈ Reals, B > 0, γ > 0}
 
 β[D_:2] := Piecewise[
   {
@@ -37,18 +32,80 @@ $Assumptions = {θc > 0, θi > 0, θc > θi, gC[_] ∈ Reals, B > 0, γ > 0}
 
 Δ[D_:2] := β[D] δ[D]
 
-f[θi_:1][n_][θ_] := (θ / θi)^2 - 1
+f[θ_] := θ^2 - 1
 g[gC_:gC, θc_:θc][n_][θ_] := (1 - (θ/θc)^2) Sum[gC[i] θ^(2i+1), {i, 0, n}]
 
-I\[ScriptCapitalM]f[γ_][y_] := (1 + (1 + γ x) / x) Exp[-1/x]
-R\[ScriptCapitalM]f[γ_][y_] := (1 - y - γ y) Exp[1/y] ExpIntegralEi[-1/y] / (π y)
+I\[ScriptCapitalM]f[y_] := (1 + 1 / x) Exp[-1/x]
+R\[ScriptCapitalM]f[y_] := (1 - y) Exp[1/y] ExpIntegralEi[-1/y] / (π y)
+
+R\[ScriptCapitalM][2][B_, θc_, M0_][θ_] := - M0 (R\[ScriptCapitalM]f[B(θc - θ)] - R\[ScriptCapitalM]f[B(θc + θ)])
 
-R\[ScriptCapitalM][2][γ_, B_, θc_, M0_][θ_] := - M0 (R\[ScriptCapitalM]f[γ][B(θc - θ)] - R\[ScriptCapitalM]f[γ][B(θc + θ)])
+ruleB[2][f_, g_] := π / (2 1.3578383417066) (Δ g[θc] f[θc]^(-Δ[2]-1) f'[θc] - g'[θc] / f[θc]^Δ[2])
 
 eqLow[D_:2][f_, g_][m_] := SeriesCoefficient[
-  R\[ScriptCapitalM][D][γ, B, θc, M0][θ] + f[θ]^β[D] Gl'[g[θ] f[θ]^(-Δ[D])],
+  R\[ScriptCapitalM][D][B, θc, M0][θ] + f[θ]^β[D] Gl'[g[θ] / f[θ]^Δ[D]],
   {θ, θc, m},
-  Assumptions -> Join[$Assumptions, {θ < θc, θ > θi}]
+  Assumptions -> Join[$Assumptions, {θ < θc, θ > 1}]
+]
+
+eqHigh[D_:2][f_, g_][m_] := SeriesCoefficient[
+  R\[ScriptCapitalM][D][B, θc, M0][θ] + (-f[θ])^β[D] Gh'[g[θ] / (-f[θ])^Δ[D]],
+  {θ, 0, m},
+  Assumptions -> Join[$Assumptions, {θ > 0, θ < 1}]
 ]
+
+eqMid[D_:2][f_, g_][m_] := SeriesCoefficient[
+  R\[ScriptCapitalM][D][B, θc, M0][θ] + g[θ]^(1/δ[D]) ((2 - α[D]) Φ'[η] - η Φ'[η]) / Δ[D] /. η -> f[θ] / g[θ]^(1 / Δ[D]),
+  {θ, 1, m},
+  Assumptions -> Join[$Assumptions, {θ > 0, θ < θc}]
+]
+
+eq[D_:2][f_, g_][m_] := Flatten[{eqLow[D][f, g][#], eqMid[D][f, g][#], eqHigh[D][f, g][#]} & /@ Range[0, m]]
+
+Φs = {
+  -1.197733383797993,
+  -0.318810124891,
+  0.110886196683,
+  0.01642689465,
+  -2.639978 10^-4,
+  -5.140526 10^-4,
+  2.08856 10^-4,
+  -4.4819 10^-5
+}
+
+Gls = {
+  0,
+  -1.3578383417066,
+  -0.048953289720,
+  0.038863932,
+  -0.068362119,
+  0.18388370,
+  -0.6591714,
+  2.937665,
+  -15.61
+}
+
+Ghs = {
+  0,
+  0,
+  -1.8452280782328,
+  0,
+  8.333711750,
+  0,
+  -95.16896,
+  0,
+  1457.62,
+  0,
+  -25891
+}
+
+dRule[sym_][f_, i_] := Derivative[i[[1]] - 1][sym][0] -> f (i[[1]] - 1)!
+
+ΦRules = MapIndexed[dRule[Φ], Φs];
+GlRules = MapIndexed[dRule[Gl], Gls];
+GhRules = MapIndexed[dRule[Gh], Ghs];
+
+rules[f_, g_] := Join[{B -> ruleB[2][f, g]}, ΦRules, GlRules, GhRules]
+
 EndPackage[]