 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2001, <kouriakine@mail.ru>
 Functions to fit data via splines, polinoms & etc.
 Modifications:
 20011213 - creation, uses CRW16
 20011214 - Test Ok.
 20030328 - Struggle for safety (add some try/except checks)...
 ****************************************************************************
 }

unit _spline;

{$I _sysdef}

interface

uses
 sysutils, math, _alloc, _ef, _zm, _sort, _svd, _lsqpoly;

 {
 *******************************************************************************
 Interpolation and smoothing routines: linear, polynoms, splines...
 *******************************************************************************
 }
 {
 Purpose:
  Linear interpolation of y(x) function in given table at given point.
 Arguments:
  (x[i],y[i]) is arrays of y(x) function table.
  N           is number of points in (x,y) arrays.
  t           is point where evaluation should be done.
 Notes:
  1) Array x[i] must be sorted as x[i]<=x[i+1]. Function do not test that x[i]
     is sorted or not. If x not sorted, result will be wrong.
  2) Table (x[i],y[i]) may contains different points with equals x[i].
     If so, y will be average of points with equals x.
 }
function LinearInterpolation(const x,y:array of Double; N:Integer; t:Double):Double;

 {
 Purpose:
  Evaluate polynom with given coefficients at given point.
 Arguments:
  Poly is coefficients of polynom P(t)=Poly[0]+Poly[1]*t+Poly[2]*t^2+..+Poly[N-1]*t^(N-1)
  N    is polynom power plus 1.
  t    is point where evaluation should be done.
 Notes:
  1) Classic Horner's method.
  2) Use FindPoly to calculate polynom coefficients.
 }
function EvalPoly(const Poly:array of Double; N:Integer; t:Double):Double;

 {
 Purpose:
  Find coefficients of polynom by given y(x) table with least squares method.
 Arguments:
  N         is polinom power plus 1. That is array size for coeficients.
  x0,Scale  is center and scaling factor. Uses t=(x-X0)/Scale transform.
  x,y       is y(x) table arrays.
  M         is dimension of x,y arrays.
 Result:
  Function allocate buffer of N doubles and evaluate coefficients poly[N]
  of N-1 power polynom P(x)=P(t(x))=P(t)=poly[0]+poly[1]*t+..+poly[N-1]*t^(N-1)
  where t=(x-X0)/Scale. Return value is pointer to allocated buffer.
 Notes:
  1) Do not forget call Deallocate(Pointer(Poly)) procedure after use polynom.
  2) Uses SVD to calculate polynom.
 }
function FindPoly(N:Integer; X0,Scale:Double; const x,y:array of Double; M:Integer):PDoubleArray;

 {
 Purpose:
  Evaluate value or derivative of cubic spline at given point.
 Arguments:
  x,z,k  is arrays of spline coefficients.
  N      is number of points in x,z,k arrays.
  t      is point where evaluation should be done.
  NDeriv is derivative number: 0=value, 1=first derivative, etc.
 Notes:
  1) Use LS_Spline to evaluate x,z,k arrays.
 }
function EvalSpline(N:Integer; const x,z,k:array of Double; t:Double; NDeriv:Integer=0):Double;

 {
 Purpose:
  LS_Spline find coefficients of smoothing spline for given y(x) function table.
 Arguments:
  N           is dimension of y(x) table arrays and of coefficient arrays.
  x,y         is y(x) function table arrays with N dimension.
  p           is point's dispersion array. Must be p[i]>=0.
              If p[i]=0, spline value at point x[i] will be equals to y[i].
              If p[i]>0, spline value at point x[i] will be smoothed.
              Use all p[i]=0 to create spline for interpolation and p[i]>0,
              for example, p[i]=alpha>0 to smooth data.
  k,z         is result N dimension arrays to evaluate spline via EvalSpline call.
  pL,pR,nL,nR is left and right endpoints condition.
              nL,nR define number of derivative at endpoint, pL,pR define value.
 Notes:
  1) After call LS_Spline(N,x,y,z,p,k,pp,pL,pR), you may evaluate spline value
     via EvalSpline(N,x,z,k,t) call.
 }
function LS_Spline(N:Integer; const x,y,p:array of Double; var z,k:array of Double;
                   nL:Integer=2; pL:Double=0; nR:Integer=2; pR:Double=0):Boolean;

 {
 *******************************************************************************
 Purpose:
  TReinschSpline class encapsulate service to find and use Reinsch's smoothing
  cubic spline.
 Arguments:
  See LS_Spline.
 *******************************************************************************
 }
type
 TReinschSpline=class(TMasterObject)
 private
  myN : Integer;
  myX : PDoubleArray;
  myZ : PDoubleArray;
  myK : PDoubleArray;
  function  GetN:Integer;
  function  GetX:PDoubleArray;
  function  GetZ:PDoubleArray;
  function  GetK:PDoubleArray;
 protected
  function  CheckOk:Boolean; override;
 public
  constructor Create(const x,y,w:array of Double; NumPoints:Integer;
                     nL:Integer=2; vL:Double=0; nR:Integer=2; vR:Double=0);
  destructor  Destroy;override;
  function    Get(t:Double; NDeriv:Integer=0):Double;
 public
  property    N  : Integer      read GetN;
  property    X  : PDoubleArray read GetX;
  property    Z  : PDoubleArray read GetZ;
  property    K  : PDoubleArray read GetK;
 end;

function  NewReinschSpline(const x,y,w:array of Double; NumPoints:Integer;
                           nL:Integer=2; vL:Double=0; nR:Integer=2; vR:Double=0):TReinschSpline;
procedure Kill(var TheObject:TReinschSpline); overload;

 {
 *******************************************************************************
 Windowed smoothing routines
 *******************************************************************************
 }
 {
 Purpose:
  Windowed smoothing of y(x) function use [t-window..t+window] interval of data
  and kernel function to fit data in given point. WindowedKernelSmoothing uses
  polynomial fit, WindowedIntegrationSmoothing use integration to find average
  value.
 Arguments:
  x,y     is N-dimension arrays with y(x) function table.
          The x array must be sorted as x[i+1]>=x[i].
  N       is dimension of data arrays.
  Where   point where evaluation should be done.
  Window  local area [Where-Window..Where+Window] of data uses for smoothing.
  Power   power of least square polynom.
  Kernel  kernel function uses to calculate weight w(x)=Kernel((x-Window)/Window)
          of each data point.
 }
type
 TSmoothKernel = function(x:Double; CustomData:Pointer):Double;

function WindowedKernelSmoothing(const x          : array of Double;
                                 const y          : array of Double;
                                       N          : Integer;
                                       Where      : Double;
                                       Window     : Double;
                                       Power      : Integer;
                                       Kernel     : TSmoothKernel;
                                       CustomData : Pointer = nil ) : Double;
function WindowedIntegrationSmoothing(const x          : array of Double;
                                      const y          : array of Double;
                                            N          : Integer;
                                            Where      : Double;
                                            Window     : Double;
                                            Kernel     : TSmoothKernel;
                                            CustomData : Pointer = nil ) : Double;

 {
 *******************************************************************************
 Utility functions to solve sparse linear equations
 *******************************************************************************
 }

 {
 Purpose:
  Solve 3 - diagonal set:
  a(j)*x(j-1)+b(j)*x(j)+c(j)*x(j+1)=d(j), j=1..n
  evaluation method from book David Potter, 'Computational phisics':
   v(n-1)=-a(n)/b(n),
   u(n-1)=d(n)/b(n),
   v(j-1)=-a(j)/(c(j)*v(j)+b(j)),
   u(j-1)=(d(j)-c(j)*u(j))/(c(j)*v(j)+b(j)),
   x(j+1)=v(j)*x(j)+u(j),
   using v(j)<-->a(j+1), u(j)<-->b(j+1) to minimize memory
 }
procedure Progonka(n:Integer; var a,b,c,x,d:array of Double);

 {
 Purpose:
  Solve 3-diagonal system: a[i]*x[i-1]+b[i]*x[i]+c[i]*x[i+1]=d[i],i=0..N-1
  uses Gauss elimination.
 }
procedure Solve3DiagonalSet(N:Integer; var a,b,c,x,d:array of Double);

 {
 Purpose:
  Solve 5-diagonal system:
  a[i]*x[i-2]+b[i]*x[i-1]+c[i]*x[i]+e[i]*x[i+1]+g[i]*x[i+2]=d[i],i=0..N-1
  uses Gauss elimination.
 }
procedure Solve5DiagonalSet(N:Integer; var a,b,c,e,g,x,d:array of Double);

implementation

 {
 *******************************************************************************
 Interpolation routines
 *******************************************************************************
 }
function LinearInterpolation(const x,y:array of Double; N:Integer; t:Double):Double;
var i,j,k,n1,n2:Integer; x1,x2,y1,y2:Double;
begin
 Result:=0;
 if (N>0) and (@x<>nil) and (@y<>nil) then begin
  if N=1 then Result:=y[0] else begin
   i:=FindIndex(N,x[0],t);
   j:=i+1;
   x1:=x[i];
   y1:=y[i];
   n1:=1;
   k:=i-1;
   while (k>=0) and (x[k]=x1) do begin
    y1:=y1+y[k];
    inc(n1);
    dec(k);
   end;
   x2:=x[j];
   y2:=y[j];
   n2:=1;
   k:=j+1;
   while (k<N) and (x[k]=x2) do begin
    y2:=y2+y[k];
    inc(n2);
    inc(k);
   end;
   if x1<>x2 then begin
    if n1>1 then y1:=y1/n1;
    if n2>1 then y2:=y2/n2;
    Result:=y1+(y2-y1)*(t-x1)/(x2-x1)
   end else Result:=(y1+y2)/(n1+n2);
  end;
 end;
end;

function EvalPoly(const Poly:array of Double; N:Integer; t:Double):Double;
var i:Integer;
begin
 Result:=0;
 if @Poly<>nil then for i:=N-1 downto 0 do Result:=Result*t+Poly[i];
end;

function FindPoly(N:Integer; X0,Scale:Double; const x,y:array of Double; M:Integer):PDoubleArray;
var i,j,k:Integer; t:Double; A,B:PDoubleArray;
begin
 Result:=Allocate(N*sizeof(Result[0]));
 try
  A:=Allocate(N*N*sizeof(A[0]));
  B:=Allocate(N*sizeof(B[0]));
  try
   if (Result<>nil) and (A<>nil) and (B<>nil) and (@x<>nil) and (@y<>nil) then begin
    for j:=0 to M-1 do begin
     t:=(x[j]-X0)/Scale;
     Result[0]:=1; for i:=1 to N-1 do Result[i]:=Result[i-1]*t;
     for i:=0 to N-1 do for k:=0 to N-1 do a[i*N+k]:=a[i*N+k]+Result[i]*Result[k];
     for i:=0 to N-1 do b[i]:=b[i]+y[j]*Result[i];
    end;
    if not SVD_Solve(N,N,N,A[0],Result[0],B[0],0,2*N*MachEps) then Deallocate(Pointer(Result));
   end else Deallocate(Pointer(Result));
  finally
   Deallocate(Pointer(A));
   Deallocate(Pointer(B));
  end;
 except
  on E:Exception do begin
   Deallocate(Pointer(Result));
   BugReport(E);
  end;
 end;
end;

function EvalSpline(N:Integer; const x,z,k:array of Double; t:Double; NDeriv:Integer=0):Double;
var d1,d2,h:Double; i:Integer;
begin
 Result:=0;
 if (N>1) and (@x<>nil) and (@z<>nil) and (@k<>nil) then begin
  i:=FindIndex(N,x,t);
  d1:=t-x[i];
  d2:=x[i+1]-t;
  h:=x[i+1]-x[i];
  case NDeriv of
   0:Result:=(d2/h)*(k[i  ]*(sqr(d2)-sqr(h))/6+z[i  ])+
             (d1/h)*(k[i+1]*(sqr(d1)-sqr(h))/6+z[i+1]);
   1:Result:=(-(k[i  ]*(3*sqr(d2)-sqr(h))*(1/6)+z[i  ])+
               (k[i+1]*(3*sqr(d1)-sqr(h))*(1/6)+z[i+1]))/h;
   2:Result:=(k[i]*d2+k[i+1]*d1)/h;
   3:Result:=(-k[i]+k[i+1])/h;
   else Result:=0;
  end;
 end;
end;

function LS_Spline(N:Integer; const x,y,p:array of Double; var z,k:array of Double;
                   nL:Integer=2; pL:Double=0; nR:Integer=2; pR:Double=0):Boolean;
Label Quit;
var i:Integer; a,b,c,d,e,g:PDoubleArray; hi,hi1,hi2,h1,h2:Double;
begin
 Result:=false;
 if (@x<>nil) and (@y<>nil) and (@z<>nil) and (@k<>nil) and (@p<>nil) and (N>2) then
 try
  a:=Allocate(N*sizeof(a[0]));
  b:=Allocate(N*sizeof(b[0]));
  c:=Allocate(N*sizeof(c[0]));
  d:=Allocate(N*sizeof(d[0]));
  e:=Allocate(N*sizeof(e[0]));
  g:=Allocate(N*sizeof(g[0]));
  try
   if (a=nil) or (b=nil) or (c=nil) or (d=nil) or (e=nil) or (g=nil) then goto Quit;
   for i:=0 to N-2 do if x[i+1]<=x[i] then goto Quit;
   for i:=1 to N-2 do begin
    hi :=x[i]-x[i-1];
    hi1:=x[i+1]-x[i];
    c[i]:=(hi+hi1)/3+p[i-1]/sqr(hi)+sqr(1/hi+1/hi1)*p[i]+p[i+1]/sqr(hi1);
    d[i]:=(y[i+1]-y[i])/hi1-(y[i]-y[i-1])/hi;
   end;
   for i:=1 to N-3 do begin
    hi:=x[i]-x[i-1];
    hi1:=x[i+1]-x[i];
    hi2:=x[i+2]-x[i+1];
    e[i]:=hi1/6-((1/hi+1/hi1)*p[i]+(1/hi1+1/hi2)*p[i+1])/hi1;
    g[i]:=(p[i+1]/hi1)/hi2;
   end;
   c[0]:=1;
   d[0]:=0;
   e[0]:=0;
   g[0]:=0;
   c[N-1]:=1;
   d[N-1]:=0;
   e[N-2]:=0;
   g[N-3]:=0;
   case nL of
    1:begin
       h1:=(x[1]-x[0]);
       h2:=(x[2]-x[1]);
       c[0]:=h1/3+(p[0]+p[1])/sqr(h1);
       d[0]:=(y[1]-y[0])/h1-pL;
       e[0]:=h1/6-p[1]*(1/h1+1/h2)/h1-p[0]/sqr(h1);
       g[0]:=(p[1]/h1)/h2;
      end;
    2:begin
       c[0]:=1;
       d[0]:=pL;
       e[0]:=0;
       g[0]:=0;
      end;
   end;
   case nR of
    1:begin
       h1:=(x[N-1]-x[N-2]);
       h2:=(x[N-2]-x[N-3]);
       c[N-1]:=h1/3+(p[N-1]+p[N-2])/sqr(h1);
       d[N-1]:=pR-(y[N-1]-y[N-2])/h1;
       e[N-2]:=h1/6-p[N-2]*(1/h1+1/h2)/h1-p[N-1]/sqr(h1);
       g[N-3]:=(p[N-2]/h1)/h2;
      end;
    2:begin
       c[N-1]:=1;
       d[N-1]:=pR;
       e[N-2]:=0;
       g[N-3]:=0;
      end;
   end;
   for i:=0 to N-2 do b[i+1]:=e[i];
   for i:=0 to N-3 do a[i+2]:=g[i];
   Solve5DiagonalSet(N,a[0],b[0],c[0],e[0],g[0],k,d[0]);
   d[0]:=(k[1]-k[0])/(x[1]-x[0]);
   for i:=1 to N-2 do d[i]:=(k[i+1]-k[i])/(x[i+1]-x[i])-(k[i]-k[i-1])/(x[i]-x[i-1]);
   d[N-1]:=-(k[N-1]-k[N-2])/(x[N-1]-x[N-2]);
   for i:=0 to N-1 do z[i]:=y[i]-p[i]*d[i];
   Result:=true;
Quit:
  finally
   Deallocate(Pointer(a));
   Deallocate(Pointer(b));
   Deallocate(Pointer(c));
   Deallocate(Pointer(d));
   Deallocate(Pointer(e));
   Deallocate(Pointer(g));
  end;
 except
  on E:Exception do BugReport(E);
 end;
end;

 {
 *****************************
 TReinschSpline implementation
 *****************************
 }
function  TReinschSpline.CheckOk:Boolean;
begin
 Result:=myN>2;
end;

function  TReinschSpline.GetN:Integer;
begin
 if Assigned(Self) then Result:=myN else Result:=0;
end;

function  TReinschSpline.GetX:PDoubleArray;
begin
 if Assigned(Self) then Result:=myX else Result:=nil;
end;

function  TReinschSpline.GetZ:PDoubleArray;
begin
 if Assigned(Self) then Result:=myZ else Result:=nil;
end;

function  TReinschSpline.GetK:PDoubleArray;
begin
 if Assigned(Self) then Result:=myK else Result:=nil;
end;

function  TReinschSpline.Get(t:Double; NDeriv:Integer=0):Double;
begin
 Result:=0;
 if Assigned(Self) then Result:=EvalSpline(myN,myX[0],myZ[0],myK[0],t,NDeriv);
end;

constructor TReinschSpline.Create(const x,y,w:array of Double; NumPoints:Integer;
                                  nL:Integer=2; vL:Double=0; nR:Integer=2; vR:Double=0);
var i:Integer; Success:Boolean;
begin
 inherited Create;
 myN:=max(0,NumPoints);
 myX:=Allocate(myN*sizeof(myX[0]));
 myZ:=Allocate(myN*sizeof(myZ[0]));
 myK:=Allocate(myN*sizeof(myK[0]));
 Success:=false;
 if (@x<>nil) and (@y<>nil) and (@w<>nil) and (myN>2) and
    (AllocSize(myX)=myN*sizeof(myX[0])) and
    (AllocSize(myZ)=myN*sizeof(myZ[0])) and
    (AllocSize(myK)=myN*sizeof(myK[0]))
 then begin
  for i:=0 to myN-1 do myX[i]:=x[i];
  Success:=LS_Spline(myN,x,y,w,myZ[0],myK[0],nL,vL,nR,vR);
 end;
 if not Success then begin
  myN:=0;
  Deallocate(Pointer(myX));
  Deallocate(Pointer(myZ));
  Deallocate(Pointer(myK));
 end;
end;

destructor TReinschSpline.Destroy;
begin
 myN:=0;
 Deallocate(Pointer(myX));
 Deallocate(Pointer(myZ));
 Deallocate(Pointer(myK));
 inherited Destroy;
end;

function NewReinschSpline(const x,y,w:array of Double; NumPoints:Integer;
                          nL:Integer=2; vL:Double=0; nR:Integer=2; vR:Double=0):TReinschSpline;
begin
 Result:=nil;
 try
  Result:=TReinschSpline.Create(x,y,w,NumPoints,nL,vL,nR,vR);
  if not Result.Ok then Kill(Result);
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure Kill(var TheObject:TReinschSpline); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end; 
end;

 {
 *******************************************************************************
 Windowed smoothing routines
 *******************************************************************************
 }
function WindowedKernelSmoothing(const x          : array of Double;
                                 const y          : array of Double;
                                       N          : Integer;
                                       Where      : Double;
                                       Window     : Double;
                                       Power      : Integer;
                                       Kernel     : TSmoothKernel;
                                       CustomData : Pointer = nil ) : Double;
label
 Linear;
const
 MaxPower=5;
var
  wLo,wHi:Double;
  wmin,wmax,ip,i,j,k:Integer;
  summa,norma,weight,delta,pow:Extended;
  Plane:array[0..(MaxPower+1)*(MaxPower+1)-1] of Double;
  RSide:array[0..(MaxPower+1)-1] of Double;
  Res  :array[0..(MaxPower+1)-1] of Double;
  Poly :array[0..(MaxPower+1)-1] of Extended;
begin
 if Power<0 then begin
  Result:=WindowedIntegrationSmoothing(x,y,n,Where,Window,Kernel);
  exit;
 end;
 if not Assigned(Kernel) then goto Linear;
 if Window<=0 then goto Linear;
 if Power>MaxPower then Power:=MaxPower;
 wLo:=Where-Window;
 wHi:=Where+Window;
 wmin:=FindIndex(n,x,wLo);
 wmax:=FindIndex(n,x,wHi);
 while (wmax<N-1) and (x[wmax]<=wHi) do inc(wmax);
 if wmax>N-1 then wmax:=N-1;
 if wmax-wmin<Power then goto Linear;
 if Power=0 then begin
  summa:=0;
  norma:=0;
  for i:=wmin to wmax do begin
   delta:=(x[i]-Where)/Window;
   if abs(delta)>1 then weight:=0 else weight:=Kernel(delta,CustomData);
   norma:=norma+weight;
   summa:=summa+y[i]*weight;
  end;
  if norma<>0 then summa:=summa/norma else goto Linear;
  Result:=summa;
 end else begin
  FillChar(Plane,(Power+1)*(Power+1)*sizeof(Plane[0]),0);
  FillChar(RSide,(Power+1)*sizeof(RSide[0]),0);
  for i:=wmin to wmax do begin
   delta:=(x[i]-Where)/Window;
   if abs(delta)>1 then weight:=0 else weight:=Kernel(delta,CustomData);
   Poly[0]:=1;
   for j:=1 to Power do Poly[j]:=Poly[j-1]*delta;
   ip:=0;
   for j:=0 to Power do begin
    RSide[j]:=RSide[j]+y[i]*Poly[j]*weight;
    for k:=0 to Power do begin
     Plane[ip]:=Plane[ip]+Poly[j]*Poly[k]*weight;
     inc(ip);
    end;
   end;
  end;
  if Partial_Pivoting(Power+1,Power+1,Plane,Res,RSide,MachEps*100)<>0 then goto Linear;
  Result:=Res[0];
 end;
 exit;
Linear:
 Result:=LinearInterpolation(x,y,n,Where);
end;

function WindowedIntegrationSmoothing(const x          : array of Double;
                                      const y          : array of Double;
                                            N          : Integer;
                                            Where      : Double;
                                            Window     : Double;
                                            Kernel     : TSmoothKernel;
                                            CustomData : Pointer = nil ) : Double;
var i,i1,i2:Integer; sum,norm,a,b:Double;
 procedure AddTrapezium(x1,y1,x2,y2:Double);
 var w1,w2:Double;
 begin
  w1:=Kernel((x1-Where)/Window,CustomData);
  w2:=Kernel((x2-Where)/Window,CustomData);
  sum:=sum+0.5*(y1*w1+y2*w2)*(x2-x1);
  norm:=norm+0.5*(w1+w2)*(x2-x1);
 end;
begin
 a:=max(Where-Window,x[0]);
 b:=min(Where+Window,x[N-1]);
 if (a>=b) or (not Assigned(Kernel)) then begin
  Result:=LinearInterpolation(x,y,N,Where);
  exit;
 end;
 i1:=FindIndex(N,x,a);
 i2:=FindIndex(N,x,b);
 sum:=0;
 norm:=0;
 AddTrapezium(a,LinearInterpolation(x,y,N,a),x[i1],y[i1]);
 for i:=i1 to i2-1 do AddTrapezium(x[i],y[i],x[i+1],y[i+1]);
 AddTrapezium(x[i2],y[i2],b,LinearInterpolation(x,y,N,b));
 if norm>0 then Result:=sum/norm else Result:=LinearInterpolation(x,y,N,Where);
end;

 {
 *******************************************************************************
 Utility functions to solve sparse linear equations
 *******************************************************************************
 }
procedure Progonka(n:Integer; var a,b,c,x,d:array of Double);
var a1:Double; j:Integer;
begin
 a[0]:=0;
 a[n-1]:=-a[n-1]/b[n-1];
 b[n-1]:=d[n-1]/b[n-1];
 for j:=n-2 downto 0 do begin
  a1:=1/(c[j]*a[j+1]+b[j]);
  a[j]:=-a[j]*a1;
  b[j]:=(d[j]-c[j]*b[j+1])*a1;
 end;
 x[0]:=b[0];
 for j:=1 to n-1 do x[j]:=a[j]*x[j-1]+b[j];
end;

procedure Solve3DiagonalSet(N:Integer; var a,b,c,x,d:array of Double);
var i:Integer; f:Double;
begin
 for i:=1 to N-1 do begin
  f:=a[i]/b[i-1];
  b[i]:=b[i]-f*c[i-1];
  d[i]:=d[i]-f*d[i-1];
 end;
 x[N-1]:=d[N-1]/b[N-1];
 for i:=N-2 downto 0 do x[i]:=(d[i]-c[i]*x[i+1])/b[i];
end;

procedure Solve5DiagonalSet(N:Integer; var a,b,c,e,g,x,d:array of Double);
var i,i1,i2:Integer; f:Double;
begin
 for i:=0 to N-2 do begin
  i1:=i+1;
  i2:=i+2;
  f:=b[i1]/c[i];
  c[i1]:=c[i1]-f*e[i];
  e[i1]:=e[i1]-f*g[i];
  d[i1]:=d[i1]-f*d[i];
  if i2>N-1 then continue;
  f:=a[i2]/c[i];
  b[i2]:=b[i2]-f*e[i];
  c[i2]:=c[i2]-f*g[i];
  d[i2]:=d[i2]-f*d[i];
 end;
 x[N-1]:=d[N-1]/c[N-1];
 if N<2 then exit;
 x[N-2]:=(d[N-2]-e[N-2]*x[N-1])/c[N-2];
 for i:=N-3 downto 0 do x[i]:=(d[i]-e[i]*x[i+1]-g[i]*x[i+2])/c[i];
end;

end.
