Update: The link in the late Jens-Peer Kuska's MathGroup post is no longer working, and it seems there are no other locations on the web to download the package from. So, here I post the contents of the package with gratitute to Jens-Peer Kuska for his continuing service to the Mathematica community.
Nonparametric Splines package - Jens-Peer Kuska
BeginPackage["NonParametricSplines`"]
CubicSplineInterpolation::usage="CubicSplineInterpolation[x,y] compute a cubic spline interpolation function. It return a CubicSpline[] function, the function should have smooth first and second derivatives.."
CubicSpline::usage="CubicSpline[] represent a interpolation function returned by CubicSplineInterpolation[]."
AkimaSplineInterpolation::usage="AkimaSplineInterpolation[x,y] compute a Akima spline interpolation. It return a AkimaSpline[] function with smooth first derivative."
AkimaSpline::usage="AkimaSpline[] represent a interpolation function returned by AkimaSplineInterpolation[].."
ExtractSplineData::usage="ExtractSplineData[spline_] return the list of the original {x,y} pairs."
Begin["`Private`"]
ExtractSplineData[CubicSpline[x_,y_,__]]:=Transpose[{x,y}]
ExtractSplineData[AkimaSpline[x_,y_,__]]:=Transpose[{x,y}]
SplineDataRange[CubicSpline[x_,__]]:={Min[#],Max[#]} &[x]
SplineDataRange[AkimaSpline[x_,__]]:={Min[#],Max[#]} &[x]
CubicSplineInterpolation[x_, y_, yp1_, ypn_] :=
Module[{n, u, d2y, i, sig, p, qn, un},
n = Length[y];
u = Table[0, {n}];
d2y = u;
If[NumericQ[yp1],
d2y[[1]] = 0.5;
u[[1]] = (3.0/(x[[2]] - x[[1]]))*((y[[2]] - y[[1]])/(x[[2]] - x[[1]]) - yp1);
];
Do[
sig = (x[[i]] - x[[i - 1]])/(x[[i + 1]] - x[[i - 1]]);
p = sig*d2y[[i - 1]] + 2.0;
d2y[[i]] = (sig - 1.0)/p;
u[[i]] = (y[[i + 1]] - y[[i]])/(x[[i + 1]] - x[[i]]) - (y[[i]] - y[[i - 1]])/(x[[i]] - x[[i - 1]]);
u[[i]] = (6.0*u[[i]]/(x[[i + 1]] - x[[i - 1]]) - sig*u[[i - 1]])/p, {i, 2, n - 1} ];
If[NumericQ[ypn], qn = 0.5; un = (3.0/(x[[n]] -
x[[n - 1]]))*(ypn - (y[[n]] - y[[n - 1]])/(x[[n]] -
x[[n - 1]])),
un = qn = 0.0 ];
d2y[[n]] = (un - qn*u[[n - 1]])/(qn*d2y[[n - 1]] + 1.0);
Do[d2y[[i]] = d2y[[i]]*d2y[[i + 1]] + u[[i]], {i, n - 1, 1, -1}];
CubicSpline[x, y, d2y]
]
CubicSplineInterpolation[xy : {{_?NumericQ, _?NumericQ} ..}, yp1_, ypn_] :=
CubicSplineInterpolation[Sequence @@ Transpose[xy], yp1, ypn]
CubicSplineInterpolation[xy : {{_?NumericQ, _?NumericQ} ..}] :=
CubicSplineInterpolation[Sequence @@ Transpose[xy], Automatic, Automatic]
spline = Compile[{{x, _Real, 1}, {y, _Real, 1}, {d2y, _Real, 1}, {t, _Real}},
Module[{a, b, h, low = 1, hi = Length[x], j},
While[hi - low > 1, j = Quotient[hi + low, 2];
If[x[[j]] > t, hi = j, low = j] ];
h = x[[hi]] - x[[low]];
a = (x[[hi]] - t)/h;
b = 1 - a;
a*y[[low]] + b*y[[hi]] + ((a^3 - a)*d2y[[low]] + (b^3 - b)*d2y[[low]])*h^2/6
]];
dspline = Compile[{{x, _Real, 1}, {y, _Real, 1}, {d2y, _Real, 1}, {t, _Real}},
Module[{a, b, h, low = 1, hi = Length[x], j},
While[hi - low > 1,
j = Quotient[hi + low, 2];
If[x[[j]] > t, hi = j, low = j]];
h = x[[hi]] - x[[low]];
a = (x[[hi]] - t)/h;
b = 1 - a;
(y[[hi]] - y[[low]])/h +h*((3*b^2 - 1)*d2y[[hi]] - (3*a^2 - 1)*d2y[[low]])/6
]];
ddspline = Compile[{{x, _Real, 1}, {y, _Real, 1}, {d2y, _Real, 1}, {t, _Real}},
Module[{a, b, h, low = 1, hi = Length[x], j},
While[hi - low > 1, j = Quotient[hi + low, 2];
If[x[[j]] > t, hi = j, low = j] ];
h = x[[hi]] - x[[low]];
a = (x[[hi]] - t)/h;
b = 1 - a;
b*d2y[[hi]] + a*d2y[[low]] ]];
CubicSpline[x_, y_, d2y_][t_?NumericQ] := spline[x, y, d2y, t]
CubicSpline[x_, y_, d2y_]'[t_?NumericQ] := dspline[x, y, d2y, t]
CubicSpline[x_, y_, d2y_]''[t_?NumericQ] := ddspline[x, y, d2y, t]
Format[CubicSpline[x_, _, _]] := CubicSpline[{First[x], Last[x]}, "<>"]
AkimaSplineInterpolation[x_List, y_List, yp1_, ypn_] /; Length[x] == Length[y] :=
Module[{i, n, m, t, tmp1, tmp2},
n = Length[x];
m = Table[0, {n + 4}];
Do[ m[[i + 2]] = (y[[i + 1]] - y[[i]])/(x[[i + 1]] - x[[i]]), {i, 1, n - 1}];
If[NumericQ[yp1], m[[1]] = m[[2]] = yp1, m[[1]] = m[[2]] = m[[3]] ];
If[NumericQ[ypn], m[[n + 3]] = m[[n + 4]] = ypn,
m[[n + 3]] = m[[n + 4]] = m[[n - 1]] ];
m=N[m];
t = Table[0, {n}];
Do[ tmp1 = Abs[m[[i + 3]] - m[[i + 2]]];
tmp2 = Abs[m[[i + 1]] - m[[i]]];
t[[i]] = If[tmp1 + tmp2 > 0, (* Then *)
(tmp1*m[[i + 1]] + tmp2*m[[i + 2]])/ (tmp1 + tmp2),
(* Else *) (m[[i + 1]] + m[[i + 2]])/2 ], {i, 1, n}];
AkimaSpline[x, y, t]
]
AkimaSplineInterpolation[xy : {{_?NumericQ, _?NumericQ} ..}, yp1_, ypn_] :=
AkimaSplineInterpolation[Sequence @@ Transpose[xy], yp1, ypn]
AkimaSplineInterpolation[xy : {{_?NumericQ, _?NumericQ} ..}] :=
AkimaSplineInterpolation[Sequence @@ Transpose[xy], Automatic, Automatic]
aspline = Compile[{{x, _Real, 1}, {y, _Real, 1}, {ta, _Real, 1}, {t, _Real}},
Module[{a, b, c, d, h, del, tmp, low = 1, hi = Length[x], j},
While[hi - low > 1, j = Quotient[hi + low, 2];
If[x[[j]] > t, hi = j, low = j] ];
h = 1.0/(x[[hi]] - x[[low]]);
a = y[[low]];
b = ta[[low]];
tmp = (y[[hi]] - y[[low]])*h;
c = (3.0*tmp - 2.0*ta[[low]] - ta[[hi]])*h;
d = (ta[[low]] + ta[[hi]] - 2.0*tmp)*h*h;
del = t - x[[low]];
a + del*(b + del*(c + del*d)) ]];
daspline = Compile[{{x, _Real, 1}, {y, _Real, 1}, {ta, _Real, 1}, {t, _Real}},
Module[{b, c, d, h, del, tmp, low = 1, hi = Length[x], j},
While[hi - low > 1,
j = Quotient[hi + low, 2];
If[x[[j]] > t, hi = j, low = j] ];
h = 1.0/(x[[hi]] - x[[low]]);
b = ta[[low]];
tmp = (y[[hi]] - y[[low]])*h;
c = (3.0*tmp - 2.0*ta[[low]] - ta[[hi]])*h;
d = (ta[[low]] + ta[[hi]] - 2.0*tmp)*h*h;
del = t - x[[low]];
b + (2.0* c + 3.0* d *del) *del ]];
AkimaSpline[x_, y_, ta_][t_?NumericQ] := aspline[x, y, ta, t]
AkimaSpline[x_, y_, ta_]'[t_?NumericQ] := daspline[x, y, ta, t]
Format[AkimaSpline[x_, _, _]] := AkimaSpline[{First[x], Last[x]}, "<>"]
End[]
EndPackage[]
AkimaSplineInterpolation in the NonParametricSplines package seems to be a good fit for your needs.
EDIT: The package does not come with the Mathematica installation; it was posted in 2008 in MathGroup by the late Jens-Peer Kuska. The link in the MathGroup post for Kuska's zipped files is still active.
Needs["NonParametricSplines`"]
dataset = {{0, 0}, {5000., 0.00373625}, {10000., 0.0269361}, {15000., 0.0621601},
{20000., 0.121612}, {25000., 0.178247}, {30000., 0.234482}, {40000., 0.3516},
{50000., 0.453972}, {75000., 0.654898}, {100000., 0.78906}, {200000., 0.952381},
{500000., 0.991166}, {1.*10^6, 0.997134}, {1.5*10^6, 0.998442},
{2.*10^6, 0.998977}, {5.*10^6, 0.999727}, {1.*10^7, 0.9999}, {10000000000, 1}};
asi = AkimaSplineInterpolation[dataset]
(* ==> AkimaSpline[{0,10000000000},"<>"] *)
Manipulate[Show[
ListPlot[dataset[[;; i]], PlotMarkers -> {Automatic, Medium}, Frame -> True],
Plot[asi[x], {x, 0, 10000000}, Frame -> True, PlotStyle -> {Red, Thick}, PlotRange -> All]],
{{i, 10, "i"}, 10, 19, 1}]
Screenshot:
Interpolation[..., InterpolationOrder -> 3, Method -> "Hermite"]is not doing this. – László May 23 '12 at 00:49