////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2023 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Function UNconstraint MINimization routines.                               //
// Literature:                                                                //
//  1.David M. Himmelblau, 1972, 'Applied nonlinear programming'              //
//  2.Podvalniy V.G., 1972, RFNC, 8/2839                                      //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20011214 - Creation (uses CRW16) & test                                    //
// 20230515 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_funmin; // Function UNconstraint MINimization

{$I _crw_sysdef}

{$IFDEF FPC}{$mode Delphi}{$ENDIF}{$H+}

interface

uses
 _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
 {$IFDEF UNIX} cthreads, dl, {$ENDIF}
 {$IFDEF WINDOWS} windows, {$ENDIF}
 sysutils, classes,
 _crw_alloc, _crw_svd;

 {
 objective function and progress viewer definitions

 TMinProblem - define objective function and gradient; if gradient not
               available, fill gradient array with 0
 TMinReport  - report about minimization progress
 params are:
    n       - dimension
    x       - argument
    f       - value
    g       - gradient or fill 0 if not available
    Custom  - points to any user data need to use
    Method  - name of applying method
    Comment - comment string
    return  - 0 if all Ok, else error (see ecXXX codes)
 }

type
 TMinProblem  = function(n      : Integer;
                     var x      : array of Double;
                     var f      : Double;
                     var g      : array of Double;
                         Custom : Pointer ) : Integer;

 TMinReport  = procedure(n       : Integer;
                     var x       : array of Double;
                     var f       : Double;
                     var g       : array of Double;
                         Custom  : Pointer;
                         Count   : Integer;
                   const Method  : ShortString;
                   const Comment : ShortString );

 {
 Next function types uses for least squares fitting
 TFitProcedure  describes fit function y(t)=f(t,x) depends of
                fit parameters x and gradient of f(t,x)
 TFitReport     describes procedure to display fit progress
 }

 TFitProblem=function(t      : Double;          { fit function argument }
                      n      : Integer;         { dimension of fit parameters }
                  var x      : array of Double; { fit parameters }
                  var f      : Double;          { function value f(t,x) }
                  var g      : array of Double; { gradient of f(x) at point t }
                      Custom : Pointer          { any user data }
                           ) : Integer;         { 0 if Ok, <>0 otherwise }

 TFitReport=procedure(m       : Integer;         { number of points to fit }
                const t       : array of Double; { [0..m-1] arguments }
                const y       : array of Double; { [0..m-1] values }
                const w       : array of Double; { [0..m-1] weights }
                      n       : Integer;         { dimension of fit parameters }
                const x       : array of Double; { fit parameters }
                const f       : Double;          { function value f(t,x) }
                const g       : array of Double; { gradient of f(x) at point t }
                      Custom  : Pointer;         { any user data }
                      Count   : Integer;         { function calls counter }
                const Method  : ShortString;     { comment on uses method }
                const Comment : ShortString);    { comment on current iteration }

 { minimization method codes }

const
 mNelderMead             = 0; {NM}
 mDavidonFletcherPowell  = 1; {DFP}
 mBroyden                = 2; {B}
 mPearson2               = 3; {P2}
 mPearson3               = 4; {P3}
 mZoutendijk             = 5; {Z}
 mSteward                = 6; {S}
 mFletcherReeves         = 7; {FR}
 mDavidon2               = 8; {D2}

 {
 ---------------------------------------------------------------------
 General minimization procedure, contains all algorithms.
 Use Method to switch given algorithm.

 Gradient evaluation:
  NM,S algoritms don't use gradient. Objective function may not evaluate
       gradient (fill with 0). Use this algorithms when analytic gradient
       unknown.
  DFP,B,P2,P3,Z,FR,D2 algoritms use analytic gradient.

 Convergence criteria:
  let (x,f,g)-current iteration, (x',f',g')-next iteration.
  tolx          - convergence criteria abs(x'-x) < tolx
  tolf          - convergence criteria abs(f'-f) < tolf
  tolg          - convergence criteria abs(g')   < tolg
 some algorithms uses different criteria:
  NM            - uses tolx,tolf
  DFP,B,P2,P3,Z - uses tolx,tolf,tolg
  S,FR,D2       - uses tolg

 Special params:
 Inf     - uses by DFP,B,P2,P3,Z,S,FR algorithms - that is user-defined
           function infimum. If f(x) will be < inf, error will generate.
 Size    - uses by NM algoritm, that is start size of simplex.
 Step    - uses by S algorithm, that is start step for digital gradient
           evaluation.
 EvalTol - uses by S algorithm, that is function evaluation precision.

 Memory:
 work array v must be at least (n+9)*nv size, where nv>n.
 that is one-dimension array for matrix row*col with row dimension
 row >= n+9 and column dimension col >= n+1
 ---------------------------------------------------------------------
 }
function GenMin(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var f        : Double;          { value }
 var g        : array of Double; { gradient }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { function calls counter }
     MaxCount : Integer;         { limit for Count }
     Method   : Integer;         { algorithm switch, 0..8 }
     tolx     : Double;          { x precision; NM,DFP,B,P2,P3,Z algoritm }
     tolf     : Double;          { f precision; NM,DFP,B,P2,P3,Z algoritm }
     tolg     : Double;          { g precision; DFP,B,P2,P3,Z,S,FR,D2 algoritm }
     inf      : Double;          { user-defined infimum; DFP,B,P2,P3,Z,S,FR }
     Size     : Double;          { start simplex; NM algorithm }
     Step     : Double;          { start step; S algorithm }
     EvalTol  : Double;          { function evaluation precision; S algorithm }
 var v        : array of Double; { work array at least (n+9)*nv, nv>n }
     nv       : Integer          { column dimension of work array; >n }
            ) : Integer;         { 0 or error code }

 {
 ---------------------------------------------------------------------
 General fixed minimization procedure, contains all algorithms.
 Use this procedure when some variables may be fixed.
 Fix[i] must be false for free variables and true for fixed.
 See also GenMin procedure.
 ---------------------------------------------------------------------
 }
function GenMinFix(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var f        : Double;          { value }
 var g        : array of Double; { gradient }
     Custom   : Pointer;        { any user data }
 var Count    : Integer;         { function calls counter }
     MaxCount : Integer;         { limit for Count }
     Method   : Integer;         { algorithm switch, 0..8 }
     tolx     : Double;          { x precision; NM,DFP,B,P2,P3,Z algoritm }
     tolf     : Double;          { f precision; NM,DFP,B,P2,P3,Z algoritm }
     tolg     : Double;          { g precision; DFP,B,P2,P3,Z,S,FR,D2 algoritm }
     inf      : Double;          { user-defined infimum; DFP,B,P2,P3,Z,S,FR }
     Size     : Double;          { start simplex; NM algorithm }
     Step     : Double;          { start step; S algorithm }
     EvalTol  : Double;          { function evaluation precision; S algorithm }
 var v        : array of Double; { work array at least (n+9)*nv, nv>n }
     nv       : Integer;         { column dimension of work array; >n }
 var Fix      : array of Boolean {true for fixed variables}
            ) : Integer;         { 0 or error code }

 {
 ---------------------------------------------------------------------
 General scaled minimization procedure, contains all algorithms.
 Use this procedure when some variables may be scaled.
 If some variables or function range too large or too small relative to 1,
 minimization will work bad. To get better result, we must transform
 variables and function range to 1.
 This procedure uses scale transformation
  f  --> f/fscale
  x  --> (x-xLo)/(xHi-xLo)
 to transform function range from [0..fscale] to [0..1] and variable
 scale from [xLo,xHi] to [0..1]. Minimization problem solves in this
 scaled space and after solution found, transforms back to  original
 space. It makes easy to use scaling because not need any changes in
 Problem and Report.
  Note:
    x,f,g,inf given in original space
    tolx,tolf,tolg,size,step given in scaled [0..1] space
    fscale is function range in original space
    [xLo,xHi] is variable range in original space
 See also GenMin procedure.
 ---------------------------------------------------------------------
 }
function GenMinScaled(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var f        : Double;          { value }
 var g        : array of Double; { gradient }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { function calls counter }
     MaxCount : Integer;         { limit for Count }
     Method   : Integer;         { algorithm switch, 0..8 }
     tolx     : Double;          { x precision; NM,DFP,B,P2,P3,Z algoritm }
     tolf     : Double;          { f precision; NM,DFP,B,P2,P3,Z algoritm }
     tolg     : Double;          { g precision; DFP,B,P2,P3,Z,S,FR,D2 algoritm }
     inf      : Double;          { user-defined infimum; DFP,B,P2,P3,Z,S,FR }
     Size     : Double;          { start simplex; NM algorithm }
     Step     : Double;          { start step; S algorithm }
     EvalTol  : Double;          { function evaluation precision; S algorithm }
 var v        : array of Double; { work array at least (n+9)*nv, nv>n }
     nv       : Integer;         { column dimension of work array; >n }
     fscale   : Double;          { scale of function}
 var xLo      : array of Double; { low x[i] range }
 var xHi      : array of Double  { high x[i] range }
            ) : Integer;         { 0 or error code }

 {
 ---------------------------------------------------------------------
 General scaled and fixed minimization procedure, contains all algorithms.
 Performs both scaling and fixing service for minimization problems.
 See also GenMin,GenMinFix,GenMinScaled.
 ---------------------------------------------------------------------
 }
function GenMinFixScaled(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var f        : Double;          { value }
 var g        : array of Double; { gradient }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { function calls counter }
     MaxCount : Integer;         { limit for Count }
     Method   : Integer;         { algorithm switch, 0..8 }
     tolx     : Double;          { x precision; NM,DFP,B,P2,P3,Z algoritm }
     tolf     : Double;          { f precision; NM,DFP,B,P2,P3,Z algoritm }
     tolg     : Double;          { g precision; DFP,B,P2,P3,Z,S,FR,D2 algoritm }
     inf      : Double;          { user-defined infimum; DFP,B,P2,P3,Z,S,FR }
     Size     : Double;          { start simplex; NM algorithm }
     Step     : Double;          { start step; S algorithm }
     EvalTol  : Double;          { function evaluation precision; S algorithm }
 var v        : array of Double; { work array at least (n+9)*nv, nv>n }
     nv       : Integer;         { column dimension of work array; >n }
 var Fix      : array of Boolean;{true for fixed variables}
     fscale   : Double;          { scale of function}
 var xLo      : array of Double; { low x[i] range }
 var xHi      : array of Double  { high x[i] range }
            ) : Integer;         { 0 or error code }

 {
 -----------------------------------------------------------------------
 Least squares fitting tools
 LSQFitSumOfSquares find sum of squares with weights
                    sum = sum ( w[i]*sqr(Fit(t[i],x)-y[i]), i=0..m-1 )
 LSQFitGessian      find digitally Gessian matrix
 LSQFitNormalMatrix find normal matrix of linear least squares (uses first
                    Taylor's term).  Matrix a also packed to 'fixed' space
                    a dimension = NumUnfixed(Fix,n)*NumUnfixed(Fix,n)
 LSQFitCov          Find covariation matrix for least squares
                    Covariation matrix packed to 'fixed' space
 LSQFit             find parametres x that minimize sum of squares
                    with weights:
                    x = arg min sum ( w[i]*sqr(Fit(t[i],x)-y[i]), i=0..m-1 )
 see also GemMinXXX
 -----------------------------------------------------------------------
 }
function LSQFitSumOfSquares(
                    m      : Integer;         { number of points to fit }
                var t      : array of Double; { [0..m-1] arguments }
                var y      : array of Double; { [0..m-1] values }
                var w      : array of Double; { [0..m-1] weights }
                    Fit    : TFitProblem;     { describes fit function }
                    n      : Integer;         { dimension of parametres }
                var x      : array of Double; { [0..n-1] parametres }
                var f      : Double;          { function value - sum of squares }
                var g      : array of Double; { gradient of function }
                    Custom : Pointer          { any user data }
                         ) : Integer;

function LSQFitGessian(
                m      : Integer;         { number of points to fit }
            var t      : array of Double; { [0..m-1] arguments }
            var y      : array of Double; { [0..m-1] values }
            var w      : array of Double; { [0..m-1] weights }
                Fit    : TFitProblem;     { describes fit function }
                n      : Integer;         { dimension of parametres }
            var x      : array of Double; { [0..n-1] parametres }
            var f      : Double;          { function value - sum of squares}
            var g      : array of Double; { gradient of f}
                Custom : Pointer;         { any user data }
            var h      : array of Double; { Gessian matrix h[i,j]=h[i*nh+j] }
                nh     : Integer;         { row dimension of h }
                dx     : Double           { step to evaluate digital deriv. }
                     ) : Integer;

function LSQFitNormalMatrix(
               m       : Integer;          {number of points to fit}
           var t       : array of Double;  {[0..m-1] argument array}
           var y       : array of Double;  {[0..m-1] data array}
           var w       : array of Double;  {[0..m-1] weight=1/dispersion array}
               Fit     : TFitProblem;      {fit function}
               n       : Integer;          {dimension of params}
           var x       : array of Double;  {vector of params}
           var fix     : array of Boolean; {fix flags}
           var a       : array of Double;  {a[i,j]=a[i*na+j] normal matrix}
               na      : Integer;          {row dimension of a}
               Custom  : Pointer           { any user data }
                     ) : Integer;
function LSQFitCov(
               m      : Integer;          {number of points to fit}
           var t      : array of Double;  {[0..m-1] argument array}
           var y      : array of Double;  {[0..m-1] data array}
           var w      : array of Double;  {[0..m-1] weight=1/dispersion array}
               Fit    : TFitProblem;      {fit function}
               n      : Integer;          {dimension of params}
           var x      : array of Double;  {vector of params}
           var fix    : array of Boolean; {fix flags}
           var a      : array of Double;  {a[i,j]=a[i*na+j] covariation matrix}
               na     : Integer;          {row dimension of a}
               Custom : Pointer           { any user data }
                    ) : Integer;

function LSQFit(
                m        : Integer;          { number of points to fit }
            var t        : array of Double;  { [0..m-1] arguments }
            var y        : array of Double;  { [0..m-1] values }
            var w        : array of Double;  { [0..m-1] weights }
                Fit      : TFitProblem;      { describes fit function }
                Report   : TFitReport;       { procedure to display progress }
                n        : Integer;          { dimension of parametres }
            var x        : array of Double;  { [0..n-1] parametres }
            var f        : Double;           { function value - sum of squares}
            var g        : array of Double;  { gradient of f}
                Custom   : Pointer;          { any user data }
            var Count    : Integer;          { function calls counter }
                MaxCount : Integer;          { limit for Count }
                Method   : Integer;          { algorithm switch, 0..9 }
                tolx     : Double;           { x tolerance }
                tolf     : Double;           { f tolerance }
                tolg     : Double;           { g tolerance }
                Inf      : Double;           { user-defined infimum, >=0 }
                Size     : Double;           { start simplex; NM algorithm }
                Step     : Double;           { start step; S algorithm }
                EvalTol  : Double;           { function evaluation precision }
            var a        : array of Double;  { work array[(n+10)*(n+1)] }
            var Fix      : array of Boolean; { true for fixed variables }
                fscale   : Double;           { scale of function }
            var xLo      : array of Double;  { low x[i] range }
            var xHi      : array of Double   { high x[i] range }
                ):Integer;


 {
 ---------------------------------------------------------------------
 Nelder-Mead simplex search algorithm. Uses when gradient unknown.
 ---------------------------------------------------------------------
 }
function  NelderMead(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var fx       : Double;          { value }
 var gx       : array of Double; { gradient; not uses in this algorithm }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { calls counter }
     MaxCount : Integer;         { limit for Count }
     tolx     : Double;          { x precision }
     tolf     : Double;          { f precision }
     tolg     : Double;          { g precision }
     Size     : Double;          { start simplex size or 0 }
 var v        : array of Double; { >= (N+6)*(N+1)-simplex vertex; work arrays }
     nv       : Integer          { >= n+1 - column dimension of v }
            ) : Integer;         { return 0 or error code }

 {
 ------------------------------------------------------------------------
 this is subprogram for minimization of function by
  1.Davidon-Fletcher-Powell
  2.Broyden
  3.Pearson-2
  4.Pearson-3
  5.Zoudtentijk (projected Newton)
 quasi-Newton algorithms.
 ------------------------------------------------------------------------
 }
function QuasiNewton(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var fx       : Double;          { value }
 var gx       : array of Double; { gradient }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { function calls counter }
     MaxCount : Integer;         { limit for Count }
     Method   : Integer;         { method, 1..5 }
     tolx     : Double;          { x precision }
     tolf     : Double;          { f precision }
     tolg     : Double;          { g precision }
     inf      : Double;          { infimum }
 var s        : array of Double; { work array[n] - search direction }
 var y        : array of Double; { work array[n] - x on next iteration }
 var gy       : array of Double; { work array[n] - gradient(y) }
 var dx       : array of Double; { work array[n] - delta x}
 var dg       : array of Double; { work array[n] - delta g}
 var hdg      : array of Double; { work array[n] - h*dg}
 var dgh      : array of Double; { work array[n] - dg*h}
 var dxhdg    : array of Double; { work array[n] - dx-h*dg}
 var h        : array of Double; { array[n*n] for hessian matrix }
     nh       : Integer          { column dimension of h; >=n }
            ) : Integer;         { return 0 or error code }

 {
 ------------------------------------------------------------------------
 Steward search. ( Davidon-Fletcher-Powell method with digital gradient).
 Uses when gradient unknown.
 ------------------------------------------------------------------------
 }
function Steward(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var fx       : Double;          { value }
 var gx       : array of Double; { gradient }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { calls counter }
     MaxCount : Integer;         { limit for Count }
     tolx     : Double;          { x precision }
     tolf     : Double;          { f precision }
     tolg     : Double;          { g precision }
     inf      : Double;          { infimum }
     Step     : Double;          { start step for gradient }
     EvalTol  : Double;          { function evaluation precision }
 var s        : array of Double; { work array >=n }
 var y        : array of Double; { work array >=n }
 var gy       : array of Double; { work array >=n }
 var xu       : array of Double; { work array >=n }
 var z        : array of Double; { work array >=n }
 var dx       : array of Double; { work array >=n }
 var e        : array of Double; { work array >=n }
 var w        : array of Double; { work array >=n }
 var g        : array of Double; { work array >=n }
 var h        : array of Double; { work array >= n*n }
     nh       : Integer          { column dimension of h  }
            ) : Integer;         { return 0 or error code }

 {
 -------------------------------------------------------------------------
 This is subprogram for minimization of function by Fletcher-Reeves method
 -------------------------------------------------------------------------
 }
function FletcherReeves(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var fx       : Double;          { value }
 var gx       : array of Double; { gradient }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { function calls counter }
     MaxCount : Integer;         { limit for Count }
     tolx     : Double;          { x precision }
     tolf     : Double;          { f precision }
     tolg     : Double;          { g precision }
     inf      : Double;          { infimum }
 var s        : array of Double  { work array[n] }
            ) : Integer;         { 0 or error code }



{
 ------------------------------------------------------------------------
 Subprogram for minimization of function (sec. method by Davidon)
 ------------------------------------------------------------------------
}
function Davidon2(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var fx       : Double;          { value }
 var gx       : array of Double; { gradient }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { calls counter }
     MaxCount : Integer;         { limit for Count }
     tolx     : Double;          { x precision }
     tolf     : Double;          { f precision }
     tolg     : Double;          { g precision }
 var s        : array of Double; { work array[n] for search direction }
 var y        : array of Double; { work array[n] for x on next iteration }
 var gy       : array of Double; { work array[n] for gx on next iteration }
 var h        : array of Double; { work array[n*n] for hessian }
     nh       : Integer          { column dimension of h }
            ) : Integer;         { 0 or error code }


 { error codes }

const
 ecOk         = 0;  { Ok,minimum found }
 ecBadDim     = 1;  { Bad dimension }
 ecBadMethod  = 2;  { Unknown method }
 ecBadArg     = 3;  { Invalid argument }
 ecBadVal     = 4;  { Invalid value }
 ecUserBreak  = 5;  { User breaks minimization process }
 ecFail       = 6;  { Convergence not achieved }
 ecInfPassed  = 7;  { Function value < user-defined infimum }
 ecBounds     = 8;  { Out of available bounds }
 ecInitErr    = 9;  { Init error }
 ecDoneErr    = 10; { Finit error }
 ecBadScale   = 11; { Invalid scale in GenMinScaled }
 ecBadWeight  = 12; { Invalid weights in least squares }
 ecDLLError   = 13; { Error loading DLL }
 ecOutOfMem   = 14; { Detect out of memory }

 {
 ------------------------
 Common Service routiners
 ------------------------
 }

 { scalar production of two vectors }
function ScPr(const x,y:array of Double; n:Integer):Double;

 { checking for convergence achieved }
function Convergence(a,b,tol:Double):Boolean;

 { checking for convergence achieved for argument }
function Convergence_x(const x,y:array of Double; tolx:Double; n:Integer):Boolean;

 { checking for convergence achieved for gradient }
function Convergence_g(const gy:array of Double; tolg:Double; n:Integer):Boolean;

 {
 isPack=true:
 'pack' params   - write to Pack array only that params from Normal,
                   which have flag Fixed=false
 isPack=false:
 'unpack' params - write back unfixed params from Pack array to Normal-
                   only that params, which have flag Fixed=false
 }
procedure PackFixed(var Normal :array of Double;
                    var Pack   :array of Double;
                    var Fixed  :array of Boolean;
                        N      :Integer;
                        isPack :Boolean);

 {
 find a number of fixed and unfixed papams in Fixed array
 convert index from original(unfixed) space to fixed and back
 }
function  NumFixed(var Fixed:array of Boolean; N:Integer):Integer;
function  NumUnFixed(var Fixed:array of Boolean; N:Integer):Integer;
function  IndexFixed(i,n:Integer; var Fixed:array of Boolean):Integer;
function  IndexUnFixed(i,n:Integer; var Fixed:array of Boolean):Integer;

 {
 Scale functions uses to transform function from [0..f] to [0..1]
 and variables x[i] from [xLo[i]..xHi[i]] to [0..1]
 }
procedure SetIdentityScale(var f:Double; var xLo,xHi:array of Double;
                           n:Integer);
function  IsScaleValid(var f:Double; var xLo,xHi:array of Double;
                      n:Integer):Boolean;
procedure ScaleFun(var Source,Dest,f:Double; Inverse:Boolean);
procedure ScaleArg(var Source,Dest,xLo,xHi:array of Double;
                   n:Integer; Inverse:Boolean);
procedure ScaleGrad(var Source,Dest:array of Double;
                    var f:Double; var xLo,xHi:array of Double;
                    n:Integer; Inverse:Boolean);
procedure ScaleGess(var Source,Dest:array of Double; m:Integer;
                    var f:Double; var xLo,xHi:array of Double;
                    n:Integer; Inverse:Boolean);

const
 ScaleForward            = false;
 ScaleBackward           = true;

 {
 ---------------------
 DLL Service routiners
 ---------------------
 }

 {
 Service to solve DLL-function fit
 }
function  DLLFit(t      : Double;
                 n      : Integer;
             var x      : array of Double;
             var f      : Double;
             var g      : array of Double;
                 Custom : Pointer) : Integer;
const
 FitLibrary  : THandle=0;
 FitFunction : function(t:Double; n:Integer;xptr,fptr,gptr,custom:pointer):Integer=nil;

function  LoadFitFunction(FileName,FunctionName:PChar):Boolean;
procedure FreeFitFunction;

implementation

{
 ---------------------------------------------------------------------
 General minimization procedure,contans all algorithms.
 Use Method to switch given algorithm.
 ---------------------------------------------------------------------
}
function GenMin(
     Problem : TMinProblem;     { objective function description }
     Report  : TMinReport;      { progress viewer }
     n       : Integer;         { dimension }
 var x       : array of Double; { argument }
 var f       : Double;          { value }
 var g       : array of Double; { gradient }
     Custom  : Pointer;         { any user data }
 var Count   : Integer;         { function calls counter }
     MaxCount: Integer;         { limit for Count }
     Method  : Integer;         { method, 0..8 }
     tolx    : Double;          { x precision }
     tolf    : Double;          { f precision }
     tolg    : Double;          { g precision }
     inf     : Double;          { infimum }
     Size    : Double;          { for Nelder-Mead }
     Step    : Double;          { for Steward }
     EvalTol : Double;          { for Steward }
 var v       : array of Double; { work array at least (n+6)*nv, nv>n }
     nv      : Integer          { column dimension of work array; >n }
           ) : Integer;         { 0 or error code }
var
 ErrorCode : Integer;
begin
 {check input}
 if (@Problem=nil) or (@Report=nil) or (@x=nil) or (@g=nil) or (@v=nil)
 then ErrorCode:=ecBadArg
 else
 {call method}
 case Method of
  mNelderMead:
   ErrorCode:=NelderMead(
            Problem,Report,n,x,f,g,Custom,Count,MaxCount,tolx,tolf,tolg,Size,v,nv
            );
  mDavidonFletcherPowell..mZoutendijk:
   ErrorCode:=QuasiNewton(
            Problem,Report,n,x,f,g,Custom,Count,MaxCount,Method,tolx,tolf,tolg,Inf,
            v[nv*(n+0)],v[nv*(n+1)],v[nv*(n+2)],v[nv*(n+3)],v[nv*(n+4)],
            v[nv*(n+5)],v[nv*(n+6)],v[nv*(n+7)],v,nv
            );
  mSteward:
   ErrorCode:=Steward(
            Problem,Report,n,x,f,g,Custom,Count,MaxCount,tolx,tolf,tolg,Inf,Step,
            EvalTol,v[nv*(n+0)],v[nv*(n+1)],v[nv*(n+2)],v[nv*(n+3)],
            v[nv*(n+4)],v[nv*(n+5)],v[nv*(n+6)],v[nv*(n+7)],v[nv*(n+8)],
            v,nv
            );
  mFletcherReeves:
   ErrorCode:=FletcherReeves(
            Problem,Report,n,x,f,g,Custom,Count,MaxCount,tolx,tolf,tolg,Inf,v
            );
  mDavidon2:
   ErrorCode:=Davidon2(
            Problem,Report,n,x,f,g,Custom,Count,MaxCount,tolx,tolf,tolg,
            v[nv*(n+0)],v[nv*(n+1)],v[nv*(n+2)],v,nv
            );
  else ErrorCode:=ecBadMethod;
 end;
 GenMin:=ErrorCode;
end;

 {
 internally use types for GenMinFix
 }
type
 TFixRecord = record
  N       : Integer;
  X       : PDoubleArray;
  G       : PDoubleArray;
  Fix     : PBooleanArray;
  Problem : TMinProblem;
  Report  : TMinReport;
  Custom  : Pointer;
 end;

 {
 internally use minimization problem for fixed params
 }
function FixedProblem(n      : Integer;
                  var x      : array of Double;
                  var f      : Double;
                  var g      : array of Double;
                      Custom : Pointer):Integer;
var
 UnFixed : ^TFixRecord absolute Custom;
begin
 {unpack argument from packed to original array}
 PackFixed(Unfixed.X[0],x,Unfixed.Fix[0],Unfixed.N,false);
 {call original problem}
 FixedProblem:=Unfixed.Problem(Unfixed.N,Unfixed.X[0],f,Unfixed.G[0],Unfixed.Custom);
 {pack gradient from original to packed array}
 PackFixed(Unfixed.G[0],g,Unfixed.Fix[0],Unfixed.N,true);
end;

 {
 minimization report for fixed params
 }
procedure FixedReport(n:Integer; var X:array of Double; var F:Double;
                    var g:array of Double; Custom:Pointer; Count:Integer; const Met,Com:ShortString);
var
 i       : Integer;
 UnFixed : ^TFixRecord absolute Custom;
begin
 {unpack argument from packed to original array}
 PackFixed(Unfixed.X[0],x,Unfixed.Fix[0],Unfixed.N,false);
 for i:=0 to Unfixed.N-1 do Unfixed.G[i]:=0;
 PackFixed(Unfixed.G[0],g,Unfixed.Fix[0],Unfixed.N,false);
 {and call original report}
 Unfixed.Report(Unfixed.N,Unfixed.X[0],f,Unfixed.G[0],Unfixed.Custom,Count,Met,Com);
end;

 {
 ---------------------------------------------------------------------
 General fixed minimization procedure, contains all algorithms.
 Use this procedure when some variables may be fixed.
 Fix[i] must be false for free variables and true for fixed.
 See also GenMin procedure.
 ---------------------------------------------------------------------
 }
function GenMinFix(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var f        : Double;          { value }
 var g        : array of Double; { gradient }
     Custom   : Pointer;
 var Count    : Integer;         { function calls counter }
     MaxCount : Integer;         { limit for Count }
     Method   : Integer;         { algorithm switch, 0..8 }
     tolx     : Double;          { x precision; NM,DFP,B,P2,P3,Z algoritm }
     tolf     : Double;          { f precision; NM,DFP,B,P2,P3,Z algoritm }
     tolg     : Double;          { g precision; DFP,B,P2,P3,Z,S,FR,D2 algoritm }
     inf      : Double;          { user-defined infimum; DFP,B,P2,P3,Z,S,FR }
     Size     : Double;          { start simplex; NM algorithm }
     Step     : Double;          { start step; S algorithm }
     EvalTol  : Double;          { function evaluation precision; S algorithm }
 var v        : array of Double; { work array at least (n+9)*nv, nv>n }
     nv       : Integer;         { column dimension of work array; >n }
 var Fix      : array of Boolean { true for fixed variables}
            ) : Integer;         { 0 or error code }
label
 Quit;
var
 i         : Integer;
 ErrorCode : Integer;
 FixedX    : PDoubleArray;
 FixedG    : PDoubleArray;
 Unfixed   : TFixRecord;
begin
 {prepare data for FixedProblem,FixedReport}
 Unfixed.N:=n;
 Unfixed.X:=@x;
 Unfixed.G:=@g;
 Unfixed.Fix:=@Fix;
 Unfixed.Problem:=Problem;
 Unfixed.Report:=Report;
 Unfixed.Custom:=Custom;
 {allocate temporary arrays for packed variables and check}
 FixedX:=Allocate(n*sizeof(Double));
 FixedG:=Allocate(n*sizeof(Double));
 {check input}
 ErrorCode:=ecBadArg;
 if (@Problem=nil) or (@Report=nil) or (@x=nil) or (@g=nil) or (@v=nil)
 or (@Fix=nil) then goto Quit;
 {check memory allocation}
 ErrorCode:=ecOutOfMem;
 if (FixedX=nil) or (FixedG=nil) then goto Quit;
 {check dimension of fixed problem}
 ErrorCode:=ecBadDim;
 if NumUnFixed(Fix,n)<1 then goto Quit;
 {pack argument from original to packed array}
 PackFixed(Unfixed.X[0],FixedX[0],Unfixed.Fix[0],Unfixed.N,true);
 {call problem with fixed variables removed}
 ErrorCode:=GenMin(FixedProblem,FixedReport,NumUnFixed(Fix,n),FixedX[0],f,
    FixedG[0],@Unfixed,Count,MaxCount,Method,tolx,tolf,tolg,inf,Size,Step,EvalTol,v,nv);
 {unpack argument from packed to original array}
 PackFixed(Unfixed.X[0],FixedX[0],Unfixed.Fix[0],Unfixed.N,false);
 for i:=0 to Unfixed.N-1 do Unfixed.G[i]:=0;
 PackFixed(Unfixed.G[0],FixedG[0],Unfixed.Fix[0],Unfixed.N,false);
 {free temporary arrays}
Quit:
 Deallocate(Pointer(FixedX));
 Deallocate(Pointer(FixedG));
 GenMinFix:=ErrorCode;
end;

 {
 internally use type for GenMinScaled,GenMinFixScaled
 }
type
 TScaling=record
  xs      : PDoubleArray;
  fs      : Double;
  gs      : PDoubleArray;
  fscale  : Double;
  xLo     : PDoubleArray;
  xHi     : PDoubleArray;
  Problem : TMinProblem;
  Report  : TMinReport;
  Custom  : Pointer;
 end;

 {
 ScaledProblem uses to solve minimization problem in scaled space
 }
function ScaledProblem(n      : Integer;
                   var x      : array of Double;
                   var f      : Double;
                   var g      : array of Double;
                       Custom : Pointer):Integer;
var
 S : ^TScaling absolute Custom;
begin
 {transform argument from scaled space back to original space}
 ScaleArg(x,S.xs[0],S.xLo[0],S.xHi[0],n,ScaleBackward);
 {call original problem in original space}
 ScaledProblem:=S.Problem(n,S.xs[0],S.fs,S.gs[0],S.Custom);
 {transform function and gradient from original to scaled space}
 ScaleFun(S.fs,f,S.fscale,ScaleForward);
 ScaleGrad(S.gs[0],g,S.fscale,S.xLo[0],S.xHi[0],n,ScaleForward);
end;

 {
 ScaledReport uses to report iteration data in scaled minimization problem
 }
procedure ScaledReport(n       : Integer;
                   var x       : array of Double;
                   var f       : Double;
                   var g       : array of Double;
                       Custom  : Pointer;
                       Count   : Integer;
                 const Method  : ShortString;
                 const Comment : ShortString );
var
 S : ^TScaling absolute Custom;
begin
 {transform argument,function and gradient from scaled-space to original}
 ScaleArg(x,S.xs[0],S.xLo[0],S.xHi[0],n,ScaleBackward);
 ScaleFun(f,S.fs,S.fscale,ScaleBackward);
 ScaleGrad(g,S.gs[0],S.fscale,S.xLo[0],S.xHi[0],n,ScaleBackward);
 {and then calls original report in original space}
 S.Report(n,S.xs[0],S.fs,S.gs[0],S.Custom,Count,Method,Comment);
end;

 {
 ---------------------------------------------------------------------
 General scaled minimization procedure, contains all algorithms.
 Use this procedure when some variables may be scaled.
 If some variables or function range too large or too small relative to 1,
 minimization will work bad. To get better result, we must transform
 variables and function range to 1.
 This procedure uses scale transformation
  f  --> f/fscale
  x  --> (x-xLo)/(xHi-xLo)
 to transform function range from [0..fscale] to [0..1] and variable
 scale from [xLo,xHi] to [0..1]. Minimization problem solves in this
 scaled space and after solution found, transforms back to  original
 space. It makes easy to use scaling because not need any changes in
 Problem and Report.
  Note:
    x,f,g,inf given in original space
    tolx,tolf,tolg,size,step given in scaled [0..1] space
    fscale is function range in original space
    [xLo,xHi] is variable range in original space
 See also GenMin procedure.
 ---------------------------------------------------------------------
 }
function GenMinScaled(
     Problem : TMinProblem;     { objective function description }
     Report  : TMinReport;      { progress viewer }
     n       : Integer;         { dimension }
 var x       : array of Double; { argument }
 var f       : Double;          { value }
 var g       : array of Double; { gradient }
     Custom  : Pointer;         { any user data }
 var Count   : Integer;         { function calls counter }
     MaxCount: Integer;         { limit for Count }
     Method  : Integer;         { algorithm switch, 0..8 }
     tolx    : Double;          { x precision; NM,DFP,B,P2,P3,Z algoritm }
     tolf    : Double;          { f precision; NM,DFP,B,P2,P3,Z algoritm }
     tolg    : Double;          { g precision; DFP,B,P2,P3,Z,S,FR,D2 algoritm }
     inf     : Double;          { user-defined infimum; DFP,B,P2,P3,Z,S,FR }
     Size    : Double;          { start simplex; NM algorithm }
     Step    : Double;          { start step; S algorithm }
     EvalTol : Double;          { function evaluation precision; S algorithm }
 var v       : array of Double; { work array at least (n+9)*nv, nv>n }
     nv      : Integer;         { column dimension of work array; >n }
     fscale  : Double;          { scale of function }
 var xLo     : array of Double; { low x[i] range }
 var xHi     : array of Double  { high x[i] range }
           ) : Integer;         { 0 or error code }
label
 Quit;
var
 Scaling   : TScaling;
 ErrorCode : Integer;
begin
 {prepare data for ScaledProblem,ScaledReport}
 Scaling.xs:=Allocate(n*sizeof(Double));
 Scaling.fs:=0;
 Scaling.gs:=Allocate(n*sizeof(Double));
 Scaling.fscale:=fscale;
 Scaling.xLo:=@xLo;
 Scaling.xHi:=@xHi;
 Scaling.Problem:=Problem;
 Scaling.Report:=Report;
 Scaling.Custom:=Custom;
 {check input}
 ErrorCode:=ecBadArg;
 if (@Problem=nil) or (@Report=nil) or (@x=nil) or (@g=nil) or (@v=nil)
 or (@xLo=nil) or (@xHi=nil) then goto Quit;
 {check memory}
 ErrorCode:=ecOutOfMem;
 if (Scaling.xs=nil) or (Scaling.gs=nil) then goto Quit;
 {check scaling}
 ErrorCode:=ecBadScale;
 if not IsScaleValid(fscale,xLo,xHi,n) then goto Quit;
 {transform argument and inf from original to scaled space}
 ScaleArg(x,x,xLo,xHi,n,ScaleForward);
 ScaleFun(inf,inf,fscale,ScaleForward);
 {solve scaled problem in scaled space}
 ErrorCode:=GenMin(ScaledProblem,ScaledReport,n,x,f,g,@Scaling,
   Count,MaxCount,Method,tolx,tolf,tolg,inf,Size,Step,EvalTol,v,nv);
 {transform back from scaled to original space}
 ScaleArg(x,x,xLo,xHi,n,ScaleBackward);
 ScaleFun(f,f,fscale,ScaleBackward);
 ScaleGrad(g,g,fscale,xLo,xHi,n,ScaleBackward);
 {free temporary arrays}
Quit:
 Deallocate(Pointer(Scaling.xs));
 Deallocate(Pointer(Scaling.gs));
 GenMinScaled:=ErrorCode;
end;


 {
 ---------------------------------------------------------------------
 General scaled and fixed minimization procedure, contains all algorithms.
 Performs both scaling and fixing service for minimization problems.
 See also GenMin,GenMinFix,GenMinScaled.
 ---------------------------------------------------------------------
 }
function GenMinFixScaled(
     Problem : TMinProblem;     { objective function description }
     Report  : TMinReport;      { progress viewer }
     n       : Integer;         { dimension }
 var x       : array of Double; { argument }
 var f       : Double;          { value }
 var g       : array of Double; { gradient }
     Custom  : Pointer;         { any user data }
 var Count   : Integer;         { function calls counter }
     MaxCount: Integer;         { limit for Count }
     Method  : Integer;         { algorithm switch, 0..8 }
     tolx    : Double;          { x precision; NM,DFP,B,P2,P3,Z algoritm }
     tolf    : Double;          { f precision; NM,DFP,B,P2,P3,Z algoritm }
     tolg    : Double;          { g precision; DFP,B,P2,P3,Z,S,FR,D2 algoritm }
     inf     : Double;          { user-defined infimum; DFP,B,P2,P3,Z,S,FR }
     Size    : Double;          { start simplex; NM algorithm }
     Step    : Double;          { start step; S algorithm }
     EvalTol : Double;          { function evaluation precision; S algorithm }
 var v       : array of Double; { work array at least (n+9)*nv, nv>n }
     nv      : Integer;         { column dimension of work array; >n }
 var Fix     : array of Boolean;{true for fixed variables}
     fscale  : Double;          { scale of function }
 var xLo     : array of Double; { low x[i] range }
 var xHi     : array of Double  { high x[i] range }
           ) : Integer;         { 0 or error code }
label
 Quit;
var
 Scaling   : TScaling;
 ErrorCode : Integer;
begin
 {prepare data for ScaledProblem,ScaledReport}
 Scaling.xs:=Allocate(n*sizeof(Double));
 Scaling.fs:=0;
 Scaling.gs:=Allocate(n*sizeof(Double));
 Scaling.fscale:=fscale;
 Scaling.xLo:=@xLo;
 Scaling.xHi:=@xHi;
 Scaling.Problem:=Problem;
 Scaling.Report:=Report;
 Scaling.Custom:=Custom;
 {check input}
 ErrorCode:=ecBadArg;
 if (@Problem=nil) or (@Report=nil) or (@x=nil) or (@g=nil) or (@v=nil)
 or (@Fix=nil) or (@xLo=nil) or (@xHi=nil) then goto Quit;
 {check memory}
 ErrorCode:=ecOutOfMem;
 if (Scaling.xs=nil) or (Scaling.gs=nil) then goto Quit;
 {check scaling}
 ErrorCode:=ecBadScale;
 if not IsScaleValid(fscale,xLo,xHi,n) then goto Quit;
 {transform argument and inf from original to scaled space}
 ScaleArg(x,x,xLo,xHi,n,ScaleForward);
 ScaleFun(inf,inf,fscale,ScaleForward);
 {solve scaled problem in scaled space}
 ErrorCode:=GenMinFix(ScaledProblem,ScaledReport,n,x,f,g,@Scaling,
   Count,MaxCount,Method,tolx,tolf,tolg,inf,Size,Step,EvalTol,v,nv,Fix);
 {transform back from scaled to original space}
 ScaleArg(x,x,xLo,xHi,n,ScaleBackward);
 ScaleFun(f,f,fscale,ScaleBackward);
 ScaleGrad(g,g,fscale,xLo,xHi,n,ScaleBackward);
 {free temporary arrays}
Quit:
 Deallocate(Pointer(Scaling.xs));
 Deallocate(Pointer(Scaling.gs));
 GenMinFixScaled:=ErrorCode;
end;

 {
 Internally uses to fit
 }
type
 TFitData=record
  m:Integer;
  t:PDoubleArray;
  y:PDoubleArray;
  w:PDoubleArray;
  gi:PDoubleArray;
  Fit:TFitProblem;
  Rep:TFitReport;
  Custom:Pointer;
 end;

 {
 Evaluates f = sum of squares and g = gradient of sum squares
  f = sum ( w[i] * sqr( fit(t[i],x) - y[i] ), i=0..m-1 )
 }
function SumOfSquares(
               n      : Integer;         {dimension of fit parameters}
           var x      : array of Double; {fit parameters}
           var f      : Double;          {function value f(t,x)}
           var g      : array of Double; {gradient of f(x) at point t}
               Custom : Pointer ) : Integer;
label
 Fault;
var
 i         : Integer;
 j         : Integer;
 errorcode : Integer;
 ti        : Double;
 yi        : Double;
 wi        : Double;
 fi        : Double;
 FitData   : ^TFitData absolute Custom;
begin
 {clear f,g}
 f:=0; fi:=0;
 for j:=0 to n-1 do g[j]:=0;
 { find: F(X)=sum of squares G(X)=gradient F(X) }
 for i:=0 to FitData.m-1 do begin
  ti:=FitData.t[i];
  yi:=FitData.y[i];
  wi:=FitData.w[i];
  errorcode:=FitData.Fit(ti,n,x,fi,FitData.gi[0],FitData.Custom);
  if errorcode<>0 then goto Fault;
  f:=f+wi*sqr(fi-yi);
  for j:=0 to n-1 do g[j]:=g[j]+2*wi*(fi-yi)*FitData.gi[j];
 end;
 SumOfSquares:=ecOk;
 exit;
Fault:
 SumOfSquares:=ErrorCode;
end;

procedure FitReport(n : Integer;
                var x       : array of Double;
                var f       : Double;
                var g       : array of Double;
                    Custom  : Pointer;
                    Count   : Integer;
              const Method  : ShortString;
              const Comment : ShortString
                    );
var
 FitData : ^TFitData absolute Custom;
begin
 FitData.Rep(FitData.m,FitData.t[0],FitData.y[0],FitData.w[0],n,x,f,g,FitData.Custom,Count,Method,Comment);
end;

function LSQFitSumOfSquares(
                    m      : Integer;
                var t      : array of Double;
                var y      : array of Double;
                var w      : array of Double;
                    Fit    : TFitProblem;
                    n      : Integer;
                var x      : array of Double;
                var f      : Double;
                var g      : array of Double;
                    Custom : Pointer
                    ):Integer;
label
 Quit;
var
 FitData   : TFitData;
 ErrorCode : Integer;
begin
 {initialize internal variables}
 FitData.m:=m;
 FitData.t:=@t;
 FitData.y:=@y;
 FitData.w:=@w;
 FitData.gi:=Allocate(n*sizeof(Double));
 FitData.Fit:=Fit;
 FitData.Custom:=Custom;
 {check input}
 ErrorCode:=ecBadArg;
 if (@Fit=nil) or (@t=nil) or (@y=nil) or (@w=nil) or (@x=nil) or (@g=nil)
 then goto Quit;
 {check memory allocation}
 ErrorCode:=ecOutOfMem;
 if (FitData.gi=nil) then goto Quit;
 {call sum of squares procedure}
 ErrorCode:=SumOfSquares(n,x,f,g,@FitData);
 {free allocated data}
Quit:
 Deallocate(Pointer(FitData.gi));
 LSQFitSumOfSquares:=ErrorCode;
end;

function LSQFitGessian(
                m      : Integer;                 { number of points to fit }
            var t      : array of Double;         { [0..m-1] arguments }
            var y      : array of Double;         { [0..m-1] values }
            var w      : array of Double;         { [0..m-1] weights }
                Fit    : TFitProblem;             { describes fit function }
                n      : Integer;                 { dimension of parametres }
            var x      : array of Double;         { [0..n-1] parametres }
            var f      : Double;                  { function value - sum of squares}
            var g      : array of Double;         { gradient of f}
                Custom : Pointer;                 { any user data }
            var h      : array of Double;         { Gessian matrix h[i,j]=h[i*nh+j] }
                nh     : Integer;                 { row dimension of h }
                dx     : Double                   { step to evaluate digital deriv. }
                     ) : Integer;
label
 Quit;
var
 i         : Integer;
 j         : Integer;
 ErrorCode : Integer;
 x1        : PDoubleArray;
 x2        : PDoubleArray;
 g1        : PDoubleArray;
 g2        : PDoubleArray;
begin
 {allocate internal variables}
 x1:=Allocate(n*sizeof(Double));
 x2:=Allocate(n*sizeof(Double));
 g1:=Allocate(n*sizeof(Double));
 g2:=Allocate(n*sizeof(Double));
 {check input}
 ErrorCode:=ecBadArg;
 if (@Fit=nil) or (@t=nil) or (@y=nil) or (@w=nil) or (@x=nil) or (@g=nil)
 or (@h=nil) then goto Quit;
 {check memory allocation}
 ErrorCode:=ecOutOfMem;
 if (x1=nil) or (x2=nil) or (g1=nil) or (g2=nil) then goto Quit;
 {evaluate matrix}
 for i:=0 to n-1 do begin
  for j:=0 to n-1 do x1[j]:=x[j];
  for j:=0 to n-1 do x2[j]:=x[j];
  x1[i]:=x1[i]-dx;
  x2[i]:=x2[i]+dx;
  ErrorCode:=LSQFitSumOfSquares(m,t,y,w,Fit,n,x1[0],f,g1[0],Custom);
  if ErrorCode<>ecOk then goto Quit;
  ErrorCode:=LSQFitSumOfSquares(m,t,y,w,Fit,n,x2[0],f,g2[0],Custom);
  if ErrorCode<>ecOk then goto Quit;
  for j:=0 to n-1 do h[i*nh+j]:=(g2[j]-g1[j])/(2*dx);
 end;
 ErrorCode:=LSQFitSumOfSquares(m,t,y,w,Fit,n,x,f,g,Custom);
 {free internal variables}
Quit:
 Deallocate(Pointer(x1));
 Deallocate(Pointer(x2));
 Deallocate(Pointer(g1));
 Deallocate(Pointer(g2));
 LSQFitGessian:=ErrorCode;
end;

function LSQFitNormalMatrix(
               m      : Integer;            {number of points to fit}
           var t      : array of Double;    {[0..m-1] argument array}
           var y      : array of Double;    {[0..m-1] data array}
           var w      : array of Double;    {[0..m-1] weight=1/dispersion array}
               Fit    : TFitProblem;      {fit function}
               n      : Integer;            {dimension of params}
           var x      : array of Double;    {vector of params}
           var fix    : array of Boolean; {fix flags}
           var a      : array of Double;    {a[i,j]=a[i*na+j] normal matrix}
               na     : Integer;           {row dimension of a}
               Custom : Pointer ) : Integer;
label
 Quit;
var
 j         : Integer;
 k         : Integer;
 ina       : Integer;
 ii        : Integer;
 jj        : Integer;
 ErrorCode : Integer;
 tk        : Double;
 wk        : Double;
 fk        : Double;
 g         : PDoubleArray;
begin
 fk:=0;
 g:=Allocate(n*sizeof(Double));
 ErrorCode:=ecBadArg;
 if (@Fit=nil) or (@t=nil) or (@y=nil) or (@w=nil) or (@x=nil) or (@g=nil)
 then goto Quit;
 ErrorCode:=ecOutOfMem;
 if g=nil then goto Quit;
 ina:=0;
 for ii:=0 to n-1 do begin
  if fix[ii] then continue;
  j:=0;
  for jj:=0 to n-1 do begin
   if fix[jj] then continue;
   a[ina+j]:=0;
   inc(j);
  end;
  inc(ina,na);
 end;
 for k:=0 to m-1 do begin
  tk:=t[k];
  wk:=w[k];
  ErrorCode:=Fit(tk,n,x,fk,g[0],Custom);
  if ErrorCode<>ecOk then goto Quit;
  ina:=0;
  for ii:=0 to n-1 do begin
   if fix[ii] then continue;
   j:=0;
   for jj:=0 to n-1 do begin
    if fix[jj] then continue;
    a[ina+j]:=a[ina+j]+wk*g[ii]*g[jj];
    inc(j);
   end;
   inc(ina,na);
  end;
 end;
Quit:
 Deallocate(Pointer(g));
 LSQFitNormalMatrix:=ErrorCode;
end;

function LSQFitCov(
               m      : Integer;
           var t      : array of Double;
           var y      : array of Double;
           var w      : array of Double;
               Fit    : TFitProblem;
               n      : Integer;
           var x      : array of Double;
           var fix    : array of Boolean;
           var a      : array of Double;
               na     : Integer;
               Custom : Pointer ):Integer;
label
 Quit;
var
 ErrorCode : Integer;
 i         : Integer;
 j         : Integer;
 ina       : Integer;
 nn        : Integer;
 nb        : Integer;
 f         : Double;
 g         : PDoubleArray;
 b         : PDoubleArray;
begin
 f:=0;
 g:=Allocate(n*sizeof(Double));
 b:=Allocate(Integer(n)*n*sizeof(Double));
 ErrorCode:=ecBadArg;
 if (@Fit=nil) or (@t=nil) or (@y=nil) or (@w=nil) or (@x=nil) or (@g=nil)
 or (@a=nil) then goto Quit;
 ErrorCode:=ecOutOfMem;
 if (g=nil) or (b=nil) then goto Quit;
 nb:=n;
 ErrorCode:=LSQFitNormalMatrix(m,t,y,w,Fit,n,x,fix,b[0],nb,Custom);
 if ErrorCode<>ecOk then goto Quit;
 nn:=NumUnFixed(fix,n);
 ErrorCode:=ecFail;
 if not SVD_PInvert(nn,nn,nb,na,b[0],a,0,0) then goto Quit;
 ErrorCode:=LSQFitSumOfSquares(m,t,y,w,Fit,n,x,f,g[0],Custom);
 if ErrorCode<>ecOk then goto Quit;
 f:=f/(m-nn);
 ina:=0;
 for i:=0 to nn-1 do begin
  for j:=0 to nn-1 do
  a[ina+j]:=a[ina+j]*f;
  inc(ina,na);
 end;
Quit:
 Deallocate(Pointer(b));
 Deallocate(Pointer(g));
 LSQFitCov:=ErrorCode;
end;

function LSQFit(
                m        : Integer;          { number of points to fit }
            var t        : array of Double;  { [0..m-1] arguments }
            var y        : array of Double;  { [0..m-1] values }
            var w        : array of Double;  { [0..m-1] weights }
                Fit      : TFitProblem;      { describes fit function }
                Report   : TFitReport;       { procedure to display progress }
                n        : Integer;          { dimension of parametres }
            var x        : array of Double;  { [0..n-1] parametres }
            var f        : Double;           { function value - sum of squares}
            var g        : array of Double;  { gradient of f}
                Custom   : Pointer;          { any user data }
            var Count    : Integer;          { function calls counter }
                MaxCount : Integer;          { limit for Count }
                Method   : Integer;          { algorithm switch, 0..9 }
                tolx     : Double;           { x tolerance }
                tolf     : Double;           { f tolerance }
                tolg     : Double;           { g tolerance }
                Inf      : Double;           { user-defined infimum, >=0 }
                Size     : Double;           { start simplex; NM algorithm }
                Step     : Double;           { start step; S algorithm }
                EvalTol  : Double;           { function evaluation precision }
            var a        : array of Double;  { work array[(n+10)*(n+1)] }
            var Fix      : array of Boolean; { true for fixed variables }
                fscale   : Double;           { scale of function }
            var xLo      : array of Double;  { low x[i] range }
            var xHi      : array of Double   { high x[i] range }
                ):Integer;
label
 Quit;
var
 ErrorCode : Integer;
 FitData   : TFitData;
begin
 {initialize internal variables}
 FitData.m:=m;
 FitData.t:=@t;
 FitData.y:=@y;
 FitData.w:=@w;
 FitData.gi:=Allocate(n*sizeof(Double));
 FitData.Fit:=Fit;
 FitData.Rep:=Report;
 FitData.Custom:=Custom;
 {check input}
 ErrorCode:=ecBadArg;
 if (@Fit=nil) or (@FitReport=nil) or (@x=nil) or (@g=nil) or (@a=nil)
 or (@xLo=nil) or (@xHi=nil) or (@Fix=nil) or (@t=nil) or (@y=nil)
 or (@w=nil) then goto Quit;
 {check memory allocation}
 ErrorCode:=ecOutOfMem;
 if (FitData.gi=nil) then goto Quit;
 {call minimization of least squares}
 ErrorCode:=GenMinFixScaled(SumOfSquares,FitReport,n,x,f,g,@FitData,
                            Count,MaxCount,Method,tolx,tolf,tolg,Inf,
                            Size,Step,EvalTol,a,n+1,Fix,fscale,xLo,xHi);
 {free allocated data and restore internal variables}
Quit:
 Deallocate(Pointer(FitData.gi));
 LSQFit:=ErrorCode;
end;

{
 ---------------------------------------------------------------------
 Nelder-Mead search. Use when gradient unknown.
 ---------------------------------------------------------------------
}
function  NelderMead(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var fx       : Double;          { value }
 var gx       : array of Double; { gradient; not uses in this algorithm }
     Custom   : Pointer;
 var Count    : Integer;         { calls counter }
     MaxCount : Integer;         { limit for Count }
     tolx     : Double;          { x precision }
     tolf     : Double;          { f precision }
     tolg     : Double;          { g precision }
     Size     : Double;          { start simplex size or 0 }
 var v        : array of Double; { >= (N+6)*(N+1)-simplex vertex; work arrays }
     nv       : Integer          { >= n+1 - column dimension of v }
            ) : Integer;         { return error code }
const
 reflect      = 1.0;
 contract     = 0.5;
 expand       = 2.0;
 shrink       = 0.5;
 StartSimplex = 0.1;
label
 StartIteration,Fault,TooManyIterations,MinimumFound;
var
 i,j,ErrorCode,nvj,nvlow,nvhigh,nvmid,nvb,nvr,nve,nvc,nvt:Integer;
 l,h,md,sum,tol:Double;
 is_Convergence:Boolean;
 how:ShortString;
 {
 call objective function for given row (nvrow-start of row)
 }
 function fun(nvrow:Integer):Integer;
 begin
  ErrorCode:=Problem(n,v[nvrow],v[nvrow+n],gx,Custom);
  inc(Count);
  fun:=ErrorCode;
 end;
 {
 report about minimization progress
 }
 procedure inform;
 begin
  if @Report<>nil then Report(n,x,fx,gx,Custom,Count,'Nelder-Mead',how);
 end;
 {
 check for convergence
 }
 function Convergence(a,b,tol:Double):Boolean;
 var checkit:Double;
 begin
  if(abs(a)<=tol) then checkit:=abs(a-b) else checkit:=abs((a-b)/a);
  Convergence:=(checkit<=tol);
 end;
begin
  {
  Note 1
  uses one long array v for all arrays, v must be >= (n+6)*(n+1);
  v equivalent to matrix with dimension  >=n+6 rows, nv>=n+1 columns
  each row=0..n+5 contains params and function value as :
   v[row*nv], row=0..n+5 - points to row
   v[row*nv+i], i=0..n-1 - vector of params of row
   v[row*nv+n]           - function value
  rows 0..n contains simplex vertex, next n+1..n+5 - work arrays
  Note 2
  in all for..do cycles uses
   nvj:=0; for j:=0 to n-1 do begin v[nvj]:=... inc(nvj,nv); end;
  instead of
   for j:=0 to n-1 do begin v[nv*j]:=...  end;
  to decrease multiplications in cycle. It more fast and compact.
  }
  ErrorCode:=ecBadDim;
  if nv<n+1 then goto Fault;
  nvb:=(n+1)*nv;
  nvr:=(n+2)*nv;
  nve:=(n+3)*nv;
  nvc:=(n+4)*nv;
  nvt:=(n+5)*nv;
  Count:=0;
  ErrorCode:=0;
  {
  create start simplex
  }
  if Size<=0 then Size:=StartSimplex;
  nvj:=0;
  for j:=0 to n do begin
   for i:=0 to n-1 do v[nvj+i]:=x[i];
   if j=n then for i:=0 to n-1 do v[nvj+i]:=(1-Size)*v[nvj+i]
          else if v[nvj+j]=0 then v[nvj+j]:=Size
                             else v[nvj+j]:=(1+Size)*v[nvj+j];
   if fun(nvj)<>0 then goto Fault;
   inc(nvj,nv);
  end;
  {
  iterations until simplex size < tolx or user break.
  }
  how:='Start.';
StartIteration:
  {
  low-simplex vertex with lowest value
  }
  nvlow:=0;
  l:=v[nvlow+n];
  nvj:=0;
  for j:=0 to n do begin
   if v[nvj+n]<l then begin
    l:=v[nvj+n];
    nvlow:=nvj;
   end;
   inc(nvj,nv);
  end;
  {
  high-simplex vertex with highest value
  }
  nvhigh:=0;
  h:=v[nvhigh+n];
  nvj:=0;
  for j:=0 to n do begin
   if v[nvj+n]>h then begin
    h:=v[nvj+n];
    nvhigh:=nvj;
   end;
   inc(nvj,nv);
  end;
  {
  mid-simplex vertex with highest value except high
  }
  nvmid:=nvlow;
  md:=v[nvmid+n];
  nvj:=0;
  for j:=0 to n do begin
   if (v[nvj+n]>md) and (nvj<>nvhigh) then begin
    md:=v[nvj+n];
    nvmid:=nvj;
   end;
   inc(nvj,nv);
  end;
  {
  solution is lowest vertex
  }
  for i:=0 to n-1 do x[i]:=v[nvlow+i];
  fx:=v[nvlow+n];
  {
  calls counter limit achieved?
  }
  if Count>MaxCount then goto TooManyIterations;
  {
  convergence achieved?
  }
  is_Convergence:=true;
  nvj:=0;
  for j:=0 to n do begin
   if nvj<>nvlow then
   for i:=0 to n do begin
    if i<n then tol:=tolx else tol:=tolf;
    is_Convergence:=is_Convergence and Convergence(v[nvlow+i],v[nvj+i],tol);
   end;
   if not is_Convergence then break;
   inc(nvj,nv);
  end;
  if is_Convergence then goto MinimumFound;
  {
  report about iteration
  }
  inform;
  {
  vb - 'bar' = center of all vertex - except high
  }
  for i:=0 to n-1 do begin
   sum:=0;
   nvj:=0;
   for j:=0 to n do begin
    if nvj<>nvhigh then sum:=sum+v[nvj+i];
    inc(nvj,nv);
   end;
   v[nvb+i]:=sum/n;
  end;
  {
  vr='reflect' reflection with coeff. reflect
  }
  for i:=0 to n-1 do v[nvr+i]:=v[nvb+i]+reflect*(v[nvb+i]-v[nvhigh+i]);
  if fun(nvr)<>0 then goto Fault;
  {
  (reflect,expand) or (contract,shrink)?
  }
  if v[nvr+n] < v[nvmid+n] then begin
    {
    may try to expand?
    }
    if v[nvr+n] < v[nvlow+n] then begin
      {
      ve-'expand'- expansion with coeff. expand
      }
      for i:=0 to n-1 do v[nve+i]:=v[nvb+i]+expand*(v[nvr+i]-v[nvb+i]);
      if fun(nve)<>0 then goto Fault;
      {
      expansion successfull?
      }
      if v[nve+n] < v[nvlow+n] then begin
        for i:=0 to n do v[nvhigh+i]:=v[nve+i];
        how:='Expand.';
        goto StartIteration;
      end;
    end;
    {
    expansion is not success, will reflect
    }
    for i:=0 to n do v[nvhigh+i]:=v[nvr+i];
    how:='Reflect.';
    goto StartIteration;
  end else begin
   {
   reflect >= mid- contract or shrink
   }
   for i:=0 to n do v[nvt+i]:=v[nvhigh+i];
   if v[nvr+n] < v[nvt+n] then for i:=0 to n do v[nvt+i]:=v[nvr+i];
   {
   'contract' vc = contraction with coeff contract
   }
   for i:=0 to n-1 do v[nvc+i]:=v[nvb+i]+contract*(v[nvt+i]-v[nvb+i]);
   if fun(nvc)<>0 then goto Fault;
   {
   success contract?
   }
   if v[nvc+n] < v[nvmid+n] then begin
    for i:=0 to n do v[nvhigh+i]:=v[nvc+i];
    how:='Contract.';
    goto StartIteration;
   end else begin
    {
    contruct not success ==> 'shrink' - shrinks with coeff. shrink
    around low vertex
    }
    nvj:=0;
    for j:=0 to n do begin
     if nvj<>nvlow then begin
      for i:=0 to n-1 do v[nvj+i]:=v[nvlow+i]+shrink*(v[nvj+i]-v[nvlow+i]);
      if fun(nvj)<>0 then goto Fault;
     end;
     inc(nvj,nv);
    end;
    how:='Shrink.';
    goto StartIteration;
   end;
  end;
  goto StartIteration;
  {
  different exit situations
  }
MinimumFound:
  how:='Stop because minimum found.';
  ErrorCode:=ecOk;
  inform;
  NelderMead:=ErrorCode;
  exit;
TooManyIterations:
  how:='Stop because too many iterations.';
  ErrorCode:=ecFail;
  inform;
  NelderMead:=ErrorCode;
  exit;
Fault:
  how:='Stop because error found.';
  inform;
  NelderMead:=ErrorCode;
  exit;
end;

{
 ------------------------------------------------------------------------
 this is subprogram for minimization of function by
  1.Davidon-Fletcher-Powell
  2.Broyden
  3.Pearson-2
  4.Pearson-3
  5.Zoudtentijk (projected Newton)
 quasi-Newton algorithms.
 ------------------------------------------------------------------------
}
function QuasiNewton(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var fx       : Double;          { value }
 var gx       : array of Double; { gradient }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { function calls counter }
     MaxCount : Integer;         { limit for Count }
     Method   : Integer;         { see mdXXX }
     tolx     : Double;          { x precision }
     tolf     : Double;          { f precision }
     tolg     : Double;          { g precision }
     inf      : Double;          { infimum }
 var s        : array of Double; { work array[n] - search direction }
 var y        : array of Double; { work array[n] - x on next iteration }
 var gy       : array of Double; { work array[n] - gradient(y) }
 var dx       : array of Double; { work array[n] - delta x}
 var dg       : array of Double; { work array[n] - delta g}
 var hdg      : array of Double; { work array[n] - h*dg}
 var dgh      : array of Double; { work array[n] - dg*h}
 var dxhdg    : array of Double; { work array[n] - dx-h*dg}
 var h        : array of Double; { array[n*n] for hessian matrix }
     nh       : Integer          { column dimension of h; >=n }
            ) : Integer;         { return 0 or error code }
const
 eps2                 = 0.01;
 RestartOnSingularity = true;
label
 Fault,Start,Restart,MinimumFound,TooManyIterations,InfPassed,
 SingularMatrix,NormalMatrix;
var
 fy,dxdg,dghdg,dgterm,alf,a1,a2,z,v,p,l,fl:Double;
 i,j,ErrorCode,inh,jnh,iter,ireset,nreset:Integer;
 MethodName,how:ShortString;
 {
 call objective function
 }
 function fun(var x:array of Double; var fx:Double; var gx:array of Double):Integer;
 begin
  ErrorCode:=Problem(n,x,fx,gx,Custom);
  Count:=Count+1;
  fun:=ErrorCode;
 end;
 {
 report about Iterations
 }
 procedure inform;
 begin
  if @Report<>nil then Report(n,x,fx,gx,Custom,Count,MethodName,how);
 end;
 {
 }
begin
 fy:=0;
 ErrorCode:=ecBadDim;
 if nh<n then goto Fault; { nh must be >=n }
 {
 check for method available
 }
 case Method of
  mDavidonFletcherPowell : Methodname:='Davidon,Fletcher-Powell';
  mBroyden               : Methodname:='Broyden';
  mPearson2              : Methodname:='Pearson-2';
  mPearson3              : Methodname:='Pearson-3';
  mZoutendijk            : Methodname:='Zoutendijk';
  else begin
   QuasiNewton:=ecBadMethod;
   exit;
  end;
 end;
 {
 some methods need to restart after n Steps
 }
 case Method of
  mPearson2   : nreset:=n+1;
  mPearson3   : nreset:=n+1;
  mZoutendijk : nreset:=n+1;
  else nreset:=0;
 end;
 {
 clear some variables
 }
 iter:=0;
 Count:=0;
 how:='Start.';
 {
 start point
 }
 if fun(x,fx,gx)<>0 then goto Fault;
 inform;
 {
 restart Iteration on first entry, on linear seach failed, on bad gessian
 }
Restart:
 ireset:=0;
 {
 set up the identity matrix and take gradient Step
 }
 inh:=0;
 for i:=0 to n-1 do begin
  for j:=0 to n-1 do h[inh+j]:=0;
  h[inh+i]:=1;
  s[i]:=-gx[i];
  inc(inh,nh);
 end;
 {
 start next Iteration
 }
Start:
 iter:=iter+1;
 ireset:=ireset+1;
 {
 find direction
 }
 inh:=0;
 for i:=0 to n-1 do begin
  s[i]:=-ScPr(h[inh],gx,n);
  inc(inh,nh);
 end;
 inform;
 if sqrt(ScPr(gx,gx,n))=0.0 then goto MinimumFound;
 if Count>MaxCount then goto TooManyIterations;
 if fx<inf then goto InfPassed;
 {
 linear search starting from (x,fx,gx) in direction s.
 result must to be in (y,fy,gy) after linear search.
 check for search direction available:
 }
 a1:=ScPr(gx,s,n);
 if a1>=0 then begin
  how:='Restart because bad direction.';
  goto Restart;
 end;
 {
 Step prediction
 }
 l:=-2*abs(inf-fx)/a1;
 if l>1 then l:=1;
 for i:=0 to n-1 do y[i]:=x[i]+l*s[i];
 if fun(y,fy,gy)<>0 then goto Fault;
 {
 cubic interpolation
 }
 repeat
  fl:=fy;
  if Count>MaxCount then goto TooManyIterations;
  a2:=ScPr(gy,s,n);
  z:=3*(fx-fy)/l+a1+a2;
  v:=z*z-a1*a2;
  p:=2*z+a1+a2;
  if p=0 then begin
   if a1=a2 then alf:=l else alf:=l*a1/(a1-a2);
  end else begin
   if v<=0 then alf:=l else alf:=l*(z+a1+sqrt(v))/p;
  end;
  if alf<>l then begin
   for i:=0 to n-1 do y[i]:=x[i]+alf*s[i];
   if fun(y,fy,gy)<>0 then goto Fault;
  end;
  if fy<=fl then break;
  if abs(ScPr(gy,s,n)/sqrt(ScPr(gy,gy,n))/sqrt(ScPr(s,s,n)))<=eps2 then break;
  l:=alf;
 until false;
 {
 now (x,fx,gx) is old and (y,fy,gy) is new point.
 Convergence criteria satisfied?
 }
 if Convergence(fx,fy,tolf) and
    Convergence_x(x,y,tolx,n) and
    Convergence_g(gy,tolg,n)  then goto MinimumFound;
 str(iter,how);
 how:='Iteration '+how;
 {
 Convergence criteria not satisfied. find a new direction matrix.
 find delta (dx=y-x),(dg=gy-gx) and correct gessian matrix using dx,dg.
 }
 for i:=0 to n-1 do begin
  dg[i]:=gy[i]-gx[i];
  dx[i]:=y[i]-x[i];
  gx[i]:=gy[i];
  x[i]:=y[i];
 end;
 fx:=fy;
 {
 correction of gessian matrix
 }
 inh:=0;
 for i:=0 to n-1 do begin
  hdg[i]:=ScPr(h[inh],dg,n);
  dxhdg[i]:=dx[i]-hdg[i];
  dgh[i]:=0;
  jnh:=0;
  for j:=0 to n-1 do begin
   dgh[i]:=dgh[i]+dg[j]*h[jnh+i];
   inc(jnh,nh);
  end;
  inc(inh,nh);
 end;
 dxdg:=ScPr(dx,dg,n);
 dghdg:=ScPr(dg,hdg,n);
 dgterm:=ScPr(dg,dxhdg,n);
 case Method of
  {
  Davidon,Fletcher-Powell method
  }
  mDavidonFletcherPowell:
   if (dxdg=0) or (dghdg=0) then goto SingularMatrix else begin
    inh:=0;
    for i:=0 to n-1 do begin
     for j:=0 to n-1 do
      h[inh+j]:=h[inh+j]+dx[i]*dx[j]/dxdg-hdg[i]*hdg[j]/dghdg;
     inc(inh,nh);
    end;
   end;
  {
  Broyden method
  }
  mBroyden:
   if (dgterm=0) then goto SingularMatrix else begin
    inh:=0;
    for i:=0 to n-1 do begin
     for j:=0 to n-1 do h[inh+j]:=h[inh+j]+dxhdg[i]*dxhdg[j]/dgterm;
     inc(inh,nh);
    end;
   end;
  {
  Pearson 2 method
  }
  mPearson2:
   if (dxdg=0) then goto SingularMatrix else begin
    inh:=0;
    for i:=0 to n-1 do begin
     for j:=0 to n-1 do h[inh+j]:=h[inh+j]+dxhdg[i]*dx[j]/dxdg;
     inc(inh,nh);
    end;
   end;
  {
  Pearson 3 method
  }
  mPearson3:
   if (dghdg=0) then goto SingularMatrix else begin
    inh:=0;
    for i:=0 to n-1 do begin
     for j:=0 to n-1 do h[inh+j]:=h[inh+j]+dxhdg[i]*dgh[j]/dghdg;
     inc(inh,nh);
    end;
   end;
  {
  projected (Zoutendijk) newton method
  }
  mZoutendijk:
   if (dghdg=0) then goto SingularMatrix else begin
    inh:=0;
    for i:=0 to n-1 do begin
     for j:=0 to n-1 do h[inh+j]:=h[inh+j]-hdg[i]*hdg[j]/dghdg;
     inc(inh,nh);
    end;
   end;
 end;
NormalMatrix:
 if ireset=nreset then begin
  how:='Restart because new cycle.';
  goto Restart;
 end;
 {
 go to next iteration
 }
 goto Start;
 {
 h matrix singularity found
 }
SingularMatrix:
 if RestartOnSingularity then begin
  how:='Restart because hessian singularity found.';
  goto Restart;
 end;
 how:='Stop because hessian singularity found.';
 inform;
 QuasiNewton:=ecFail;
 exit;
 {
 Convergence criteria satisfied
 }
MinimumFound:
 how:='Stop because minimum found.';
 inform;
 QuasiNewton:=ecOk;
 exit;
 {
 too many iterations
 }
TooManyIterations:
 how:='Stop because too many iterations.';
 ErrorCode:=ecFail;
 inform;
 QuasiNewton:=ErrorCode;
 exit;
 {
 function value < infimum (???)
 }
InfPassed:
 how:='Stop because function < user-defined infimum(f).';
 ErrorCode:=ecInfPassed;
 inform;
 QuasiNewton:=ErrorCode;
 exit;
 {
 error found
 }
Fault:
 how:='Stop because error found.';
 inform;
 QuasiNewton:=ErrorCode;
 exit;
end;


{
 ------------------------------------------------------------------------
 Steward search. ( Davidon-Fletcher-Powell method with digital gradient).
 ------------------------------------------------------------------------
}
function Steward(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var fx       : Double;          { value }
 var gx       : array of Double; { gradient }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { calls counter }
     MaxCount : Integer;         { limit for Count }
     tolx     : Double;          { x precision }
     tolf     : Double;          { f precision }
     tolg     : Double;          { g precision }
     inf      : Double;          { infimum }
     Step     : Double;          { start step for gradient }
     EvalTol  : Double;          { function evaluation precision }
 var s        : array of Double; { work array >=n }
 var y        : array of Double; { work array >=n }
 var gy       : array of Double; { work array >=n }
 var xu       : array of Double; { work array >=n }
 var z        : array of Double; { work array >=n }
 var dx       : array of Double; { work array >=n }
 var e        : array of Double; { work array >=n }
 var w        : array of Double; { work array >=n }
 var g        : array of Double; { work array >=n }
 var h        : array of Double; { work array >= n*n }
     nh       : Integer          { column dimension of h  }
            ) : Integer;         { return 0 or error code }
const
 StewStep0 = 1.0e-6;  { if Step=0 }
 EvalTol0  = 1.0e-12; { if EvalTol=0 }
 StewEps   = 0.01;    { 0<steweps<0.1 - const of method }
 Small     = 1E-14;   { for zero step }
label
 Restart,Quit,Iteration,Fault,MinimumFound,TooManyIterations,InfPassed;
var
 alf,pl,a,a1,a2,fu,fy:Double;
 i,j,ErrorCode,inh,iter:Integer;
 big,bad:Boolean;
 how:ShortString;
 {
 call objective function
 }
 function fun(var x:array of Double; var f:Double):Integer;
 begin
  ErrorCode:=Problem(n,x,f,g,Custom);
  inc(Count);
  fun:=ErrorCode;
 end;
 {
 report about iteration
 }
 procedure inform;
 begin
  if @Report<>nil then Report(n,x,fx,gx,Custom,Count,'Steward',how);
 end;
 {
 simulate fortran sign function
 }
 function SIGN(a,b:Double):Double;
 begin
  if b<0 then SIGN:=-abs(a) else SIGN:=abs(a);
 end;
 {
 x^y
 }
 function Power(x,y:Double):Double;
 var log:Double;
 begin
  if x=0 then Power:=x else begin
   log:=ln(x)*y;
   if log<-300 then Power:=0 else Power:=exp(log);
  end;
 end;
 {
 find Step to evaluate gradient
 }
 function StewStep(var et,al,gam,f:Double):Double;
 var a,b,absf,absal,absgam:Double;
 begin
  absf:=abs(f);
  absal:=abs(al);
  absgam:=abs(gam);
  a:=absf*absal*et;
  if sqr(gam)>a then begin
   b:=2*sqrt(absf*et/absal);
   b:=b*(1-absal*b/(3*absal*b+4*absgam));
  end else begin
   a:=absf*absgam*et/sqr(al);
   b:=2*Power(a,1/3);
   b:=b*(1-2*absgam/(3*absal*b+4*absgam));
  end;
  StewStep:=SIGN(b,al*gam);
 end;
begin
 fu:=0; fy:=0;
 ErrorCode:=ecBadDim;
 if nh<n then goto Fault; { nh must be >=n }
 Count:=0;
 iter:=0;
 ErrorCode:=0;
 alf:=0;
 if Step<=0 then Step:=StewStep0;
 if EvalTol<=0 then EvalTol:=EvalTol0;
 for i:=0 to n-1 do e[i]:=Step;
Restart:
 {
 set identity matrix h
 }
 inh:=0;
 for i:=0 to n-1 do begin
  for j:=0 to n-1 do h[inh+j]:=0;
  h[inh+i]:=1;
  w[i]:=1;
  inc(inh,nh);
 end;
 {
 calculate function and gradient
 }
 if fun(x,fx)<>0 then goto Fault;
 for i:=0 to n-1 do begin
  for j:=0 to n-1 do xu[j]:=x[j];
  xu[i]:=x[i]+e[i];
  if fun(xu,fu)<>0 then goto Fault;
  gy[i]:=(fu-fx)/e[i];
 end;
 how:='Restart.';
 inform;
Iteration:
 iter:=iter+1;
 for i:=0 to n-1 do gx[i]:=gy[i];
 inh:=0;
 for i:=0 to n-1 do begin
  s[i]:=-ScPr(h[inh],gx,n);
  inc(inh,nh);
 end;
 {
 Convergence achieved?
 }
 if Convergence_g(gx,tolg,n) then goto MinimumFound;
 if fx<inf then goto InfPassed;
 {
 h is negative?
 }
 a1:=ScPr(gx,s,n);
 if a1>=0 then goto Restart;
 {
 Step prediction
 }
 pl:=-2*abs(inf-fx)/a1;
 if pl>1 then pl:=1;
 for i:=0 to n-1 do xu[i]:=x[i]+pl*s[i];
 if fun(xu,fu)<>0 then goto Fault;
 {
 interpolation Step
 }
 a2:=fx-fu+a1*pl;
 if (a2<>0) and (alf>=0) and (alf<=pl) then alf:=0.5*a1*pl*pl/a2 else alf:=pl;
 for i:=0 to n-1 do begin
  dx[i]:=alf*s[i];
  y[i]:=x[i]+dx[i];
 end;
 if fun(y,fy)<>0 then goto Fault;
 str(iter,how);
 how:='Iteration '+how;
 inform;
 if(Count>MaxCount) then goto TooManyIterations;
 {
 correction if Step available
 }
 for i:=0 to n-1 do z[i]:=e[i];
 for i:=0 to n-1 do e[i]:=StewStep(EvalTol,w[i],gx[i],fy);
 bad:=false;
 for i:=0 to n-1 do if abs(e[i])<=Small then bad:=true;
 if bad then begin
  for i:=0 to n-1 do e[i]:=z[i];
  how:='Zero Step found!';
  inform;
 end;
 {
 Step big or small?
 }
 big:=false;
 for i:=0 to n-1 do if(0.5*abs(w[i]*e[i]/gx[i])>=StewEps) then big:=true;
 for j:=0 to n-1 do begin
  x[j]:=y[j];
  y[j]:=-gx[j];
 end;
 fx:=fy;
 {
 find gradient
 }
 if not big then begin
  for i:=0 to n-1 do begin
   for j:=0 to n-1 do xu[j]:=x[j];
   xu[i]:=x[i]+e[i];
   if fun(xu,fu)<>0 then goto Fault;
   gy[i]:=(fu-fx)/e[i];
  end;
 end else begin
  for i:=0 to n-1 do begin
   a:=abs(fy/w[i]);
   a1:=abs(gx[i]/w[i]);
   e[i]:=-a1+sqrt(sqr(a1)+200*a*EvalTol);
   z[i]:=x[i]+e[i];
   xu[i]:=x[i]-e[i];
   for j:=0 to n-1 do begin
    if(j=i) then continue;
    xu[j]:=x[j];
    z[j]:=x[j];
   end;
   if fun(xu,fx)<>0 then goto Fault;
   if fun(z,fu)<>0 then goto Fault;
   gy[i]:=(fu-fx)/(2*e[i]);
  end;
 end;
 for i:=0 to n-1 do y[i]:=gy[i]+y[i];
 fx:=fy;
 {
 find new direction and correct gessian (same as Davidon-Fletcher-Powell)
 }
 inh:=0;
 for i:=0 to n-1 do begin
  s[i]:=ScPr(h[inh],y,n);
  inc(inh,nh);
 end;
 a:=ScPr(s,y,n);
 inh:=0;
 for i:=0 to n-1 do begin
  for j:=0 to n-1 do h[inh+j]:=h[inh+j]-s[i]*s[j]/a;
  inc(inh,nh);
 end;
 a:=ScPr(dx,y,n);
 a1:=ScPr(dx,gx,n);
 inh:=0;
 for i:=0 to n-1 do begin
  for j:=0 to n-1 do begin
   h[inh+j]:=h[inh+j]+dx[i]*dx[j]/a;
   if i=j then
   w[i]:=w[i]+((1-alf*a1/a)*y[i]*y[j]+alf*(gx[i]*y[j]+gx[j]*y[i]))/a;
  end;
  inc(inh,nh);
 end;
 goto Iteration;
 {
 different variants of exit
 }
TooManyIterations:
 how:='Stop because too many iterations.';
 ErrorCode:=ecFail;
 goto quit;
MinimumFound:
 how:='Stop because minimum found.';
 ErrorCode:=0;
 goto quit;
InfPassed:
 how:='Stop because function < user-defined infimum(f).';
 ErrorCode:=ecInfPassed;
 goto quit;
Quit:
 inform;
 Steward:=ErrorCode;
 exit;
Fault:
 how:='Stop because error found.';
 Steward:=ErrorCode;
 inform;
end;

{
 -------------------------------------------------------------------------
 This is subprogram for minimization of function by Fletcher-Reeves method
 -------------------------------------------------------------------------
}
function FletcherReeves(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var fx       : Double;          { value }
 var gx       : array of Double; { gradient }
     Custom   : Pointer;
 var Count    : Integer;         { function calls counter }
     MaxCount : Integer;         { limit for Count }
     tolx     : Double;          { x precision }
     tolf     : Double;          { f precision }
     tolg     : Double;          { g precision }
     inf      : Double;          { infimum }
 var s        : array of Double  { work array[n] }
            ) : Integer;         { 0 or error code }
label
 Start,Quit,Fault,Interpolate,Extrapolate,LinearSearch,NextStep,
 ResetDirection,CorrectDirection,MinimumFound,StopOnIncrease,
 StopOnCount,InfPassed;
var
 zz,t,ww,ya,va,yb,vb,vc,bet,oldg,oldf,pp,gg,ak,hh:Double;
 i,j,nn,ErrorCode,iter:Integer;
 how:ShortString;
 {
 report about iterations
 }
 procedure inform;
 begin
  if @Report<>nil then Report(n,x,fx,gx,Custom,Count,'Fletcher-Reeves',how);
 end;
 {
 call objective function
 }
 function fun(var x:array of Double; var f:Double; var g:array of Double):Integer;
 begin
  ErrorCode:=Problem(n,x,f,g,Custom);
  inc(Count);
  fun:=ErrorCode;
 end;
begin
   Count:=0;
   iter:=0;
   if fun(x,fx,gx)<>0 then goto Fault;
   oldf:=fx;
   how:='Start.';
   inform;
   oldg:=ScPr(gx,gx,n);
   t:=0;
Start:
   iter:=iter+1;
   if fx>oldf then goto StopOnIncrease;
   if fx<inf then goto InfPassed;
   if Count>MaxCount then goto StopOnCount;
   oldf:=fx;
   nn:=n+1;
   for i:=0 to nn-1 do begin
    str(iter,how);
    how:='Iteration '+how;
    inform;
    gg:=ScPr(gx,gx,n);
    if Convergence_g(gx,tolg,n) then goto MinimumFound;
    if i=0 then goto ResetDirection;
CorrectDirection:
    bet:=gg/oldg;
    for j:=0 to n-1 do s[j]:=-gx[j]+bet*s[j];
    goto LinearSearch;
ResetDirection:
    for j:=0 to n-1 do s[j]:=-gx[j];
LinearSearch:
    yb:=fx;
    vb:=ScPr(gx,s,n);
    pp:=ScPr(s,s,n);
    if vb>=0 then goto NextStep;
    ak:=-2*abs(inf-fx)/vb;
    if (ak>0) and (sqr(ak)*pp<1) then hh:=ak else hh:=1/sqrt(pp);
    ak:=0;
Extrapolate:
    ya:=yb;
    va:=vb;
    for j:=0 to n-1 do x[j]:=x[j]+hh*s[j];
    if fun(x,fx,gx)<>0 then goto Fault;
    yb:=fx;
    vb:=ScPr(gx,s,n);
    if (vb>=0) or (yb>=ya) then begin
     t:=0;
     goto Interpolate;
    end;
    ak:=hh+ak;
    hh:=ak;
    goto Extrapolate;
Interpolate:
   if Count>MaxCount then goto StopOnCount;
    zz:=3.0*(ya-yb)/hh+va+vb;
    ww:=sqrt(zz*zz-va*vb);
    ak:=hh*(vb+ww-zz)/(vb-va+2.0*ww);
    for j:=0 to n-1 do x[j]:=x[j]+(t-ak)*s[j];
    if fun(x,fx,gx)<>0 then goto Fault;
    if (fx<=ya) and (fx<=yb) then goto NextStep;
    vc:=ScPr(gx,s,n);
    if vc>=0 then begin
     yb:=fx;
     vb:=vc;
     hh:=hh-ak;
     t:=0;
     goto interpolate;
    end else begin
     ya:=fx;
     va:=vc;
     hh:=ak;
     t:=hh;
     goto interpolate;
    end;
NextStep:
    oldg:=gg;
   end;
 goto Start;
 {
 different variants of exit
 }
Fault:
 how:='Stop because error found.';
 goto quit;
MinimumFound:
 how:='Stop because minimum found.';
 ErrorCode:=ecOk;
 goto quit;
StopOnIncrease:
 how:='Stop because function increased.';
 ErrorCode:=ecFail;
 goto quit;
StopOnCount:
 how:='Stop because too many iterations.';
 ErrorCode:=ecFail;
 goto quit;
InfPassed:
 how:='Stop because function < user-defined infimum(f).';
 ErrorCode:=ecInfPassed;
 goto quit;
Quit:
 inform;
 FletcherReeves:=ErrorCode;
end;

{
 ------------------------------------------------------------------------
 Subprogram for minimization of function (sec. method by Davidon)
 ------------------------------------------------------------------------
}
function Davidon2(
     Problem  : TMinProblem;     { objective function description }
     Report   : TMinReport;      { progress viewer }
     n        : Integer;         { dimension }
 var x        : array of Double; { argument }
 var fx       : Double;          { value }
 var gx       : array of Double; { gradient }
     Custom   : Pointer;         { any user data }
 var Count    : Integer;         { calls counter }
     MaxCount : Integer;         { limit for Count }
     tolx     : Double;          { x precision }
     tolf     : Double;          { f precision }
     tolg     : Double;          { g precision }
 var s        : array of Double; { work array[n] for search direction }
 var y        : array of Double; { work array[n] for x on next iteration }
 var gy       : array of Double; { work array[n] for gx on next iteration }
 var h        : array of Double; { work array[n*n] for hessian }
     nh       : Integer          { column dimension of h }
            ) : Integer;         { 0 or error code }
const
  dav2alf   : Double = 0.01;
  dav2bet   : Double = 10.0;
label
 Restart,Start,Quit,Fault,TooManyIterations,MinimumFound;
var
 i,j,ErrorCode,inh,iter:Integer;
 gl,gam,a,a1,a2,b1,b2,fy,s0:Double;
 how:ShortString;
 {
 report about iteration
 }
 procedure inform;
 begin
  if @Report<>nil then Report(n,x,fx,gx,Custom,Count,'Davidon-second',how);
 end;
 {
 call objective function
 }
 function fun(var x:array of Double; var f:Double; var g:array of Double):Integer;
 begin
  ErrorCode:=Problem(n,x,f,g,Custom);
  Count:=Count+1;
  fun:=ErrorCode;
 end;
begin
 fy:=0;
 ErrorCode:=ecBadDim;
 if nh<n then goto Fault; { nh must be >=n }
 Count:=0;
 ErrorCode:=0;
 iter:=0;
 a1:=-dav2alf/(1.0+dav2alf);
 a2:= dav2alf/(1.0-dav2alf);
 b1:=-dav2bet/(dav2bet+1.0);
 b2:=-dav2bet/(dav2bet-1.0);
Restart:
 if fun(x,fx,gx)<>0 then goto Fault;
 how:='Restart.';
 inh:=0;
 for i:=0 to n-1 do begin
  for j:=0 to n-1 do h[inh+j]:=0.0;
  if abs(gx[i])<1 then h[inh+i]:=1 else h[inh+i]:=1/sqr(gx[i]);
  inc(inh,nh);
 end;
Start:
 iter:=iter+1;
 inform;
 str(iter,how);
 how:='Iteration '+how;
 inh:=0;
 for i:=0 to n-1 do begin
  y[i]:=x[i]-ScPr(h[inh],gx,n);
  inc(inh,nh);
 end;
 if fun(y,fy,gy)<>0 then goto Fault;
 inh:=0;
 for i:=0 to n-1 do begin
  s[i]:=ScPr(h[inh],gy,n);
  inc(inh,nh);
 end;
 s0:=ScPr(s,gy,n);
 if s0<=0 then goto Restart;
 if Convergence_g(gy,tolg,n) then begin
  fx:=fy;
  for j:=0 to n-1 do x[j]:=y[j];
  for j:=0 to n-1 do gx[j]:=gy[j];
  goto MinimumFound;
 end;
 gam:=-ScPr(s,gx,n)/s0;
 a:=1/s0;
 if((a1<=gam)and(gam<=a2)) then gl:=(dav2alf-1)*a else
 if((b1<=gam)and(gam<=a1)) then gl:=-(2*gam+1)*a/(1+gam) else
 if((b2<=gam)and(gam<=b1)) then gl:=(dav2bet-1)*a else gl:=-a/(1+gam);
 inh:=0;
 for i:=0 to n-1 do begin
  for j:=0 to n-1 do h[inh+j]:=h[inh+j]+gl*s[i]*s[j];
  inc(inh,nh);
 end;
 if(Count>MaxCount) then goto TooManyIterations;
 if fy<=fx then begin
  fx:=fy;
  for i:=0 to n-1 do begin
   x[i]:=y[i];
   gx[i]:=gy[i];
  end;
 end;
 goto Start;
MinimumFound:
 how:='Stop because minimum found.';
 ErrorCode:=ecOk;
 goto Quit;
TooManyIterations:
 how:='Stop because too many iterations.';
 ErrorCode:=ecFail;
 goto Quit;
Quit:
 inform;
 Davidon2:=ErrorCode;
 exit;
Fault:
 how:='Stop because error found.';
 inform;
 Davidon2:=ErrorCode;
end;


 {
 -----------------
 Utilite functions
 -----------------
 }

 {scalar production of two vectors }
function ScPr(const x,y:array of Double; n:Integer):Double;
var s:Double; i:Integer;
begin
 s:=0;
 for i:=0 to n-1 do s:=s+x[i]*y[i];
 ScPr:=s;
end;

 { checking for convergence achieved }
function Convergence(a,b,tol:Double):Boolean;
var checkit:Double;
begin
 if abs(a)<=tol then checkit:=abs(a-b) else checkit:=abs((a-b)/a);
 Convergence:=(checkit<=tol);
end;

 { checking for convergence achieved for argument }
function Convergence_x(const x,y:array of Double; tolx:Double; n:Integer):Boolean;
var i:Integer;
begin
 Convergence_x:=false;
 for i:=0 to n-1 do if not Convergence(x[i],y[i],tolx) then exit;
 Convergence_x:=true;
end;

 { checking for convergence achieved for gradient }
function Convergence_g(const gy:array of Double; tolg:Double; n:Integer):Boolean;
var i:Integer;
begin
 Convergence_g:=false;
 for i:=0 to n-1 do if not Convergence(0,gy[i],tolg) then exit;
 Convergence_g:=true;
end;

 {
 isPack=true:
 'pack' params   - write to Pack array only that params from Normal,
                   which have flag Fixed=false
 isPack=false:
 'unpack' params - write back unfixed params from Pack array to Normal-
                   only that params, which have flag Fixed=false
 }
procedure PackFixed(var Normal :array of Double;
                    var Pack   :array of Double;
                    var Fixed  :array of Boolean;
                        N      :Integer;
                        isPack :Boolean);
var i,j:Integer;
begin
 j:=0;
 for i:=0 to N-1 do
 if not Fixed[i] then begin
  if isPack then Pack[j]:=Normal[i] else Normal[i]:=Pack[j];
  inc(j);
 end;
end;

 {
 find a number of fixed papams in Fixed array
 }
function NumFixed(var Fixed:array of Boolean; N:Integer):Integer;
var i,Cnt:Integer;
begin
 Cnt:=0;
 for i:=0 to N-1 do if Fixed[i] then inc(Cnt);
 NumFixed:=Cnt;
end;

function NumUnFixed(var Fixed:array of Boolean; N:Integer):Integer;
var i,Cnt:Integer;
begin
 Cnt:=0;
 for i:=0 to N-1 do if not Fixed[i] then inc(Cnt);
 NumUnFixed:=Cnt;
end;

function IndexFixed(i,n:Integer; var Fixed:array of Boolean):Integer;
var j,jj:Integer;
begin
 j:=0;
 for jj:=0 to n-1 do begin
  if Fixed[jj] then continue;
  if i=jj then break;
  inc(j);
 end;
 IndexFixed:=j;
end;

function IndexUnFixed(i,n:Integer; var Fixed:array of Boolean):Integer;
var j,jj:Integer;
begin
 j:=0;
 for jj:=0 to n-1 do begin
  if Fixed[jj] then continue;
  if i=j then break;
  inc(j);
 end;
 IndexUnFixed:=jj;
end;

 {
 ---------------
 Scale functions
 ---------------
 }
procedure SetIdentityScale(var f:Double; var xLo,xHi:array of Double;
                           n:Integer);
var i:Integer;
begin
 f:=1;
 for i:=0 to n-1 do xLo[i]:=0;
 for i:=0 to n-1 do xHi[i]:=1;
end;

function IsScaleValid(var f:Double; var xLo,xHi:array of Double;
                      n:Integer):Boolean;
var i:Integer;
begin
 IsScaleValid:=false;
 if f<=0 then exit;
 for i:=0 to n-1 do if xHi[i]<=xLo[i] then exit;
 IsScaleValid:=true;
end;

procedure ScaleFun(var Source,Dest,f:Double; Inverse:Boolean);
begin
 if Inverse then Dest:=Source*f else Dest:=Source/f;
END;

procedure ScaleArg(var Source,Dest,xLo,xHi:array of Double;
                   n:Integer; Inverse:Boolean);
var i:Integer;
begin
 if Inverse
 then for i:=0 to n-1 do Dest[i]:=xLo[i]+Source[i]*(xHi[i]-xLo[i])
 else for i:=0 to n-1 do Dest[i]:=(Source[i]-xLo[i])/(xHi[i]-xLo[i]);
end;

procedure ScaleGrad(var Source,Dest:array of Double;
                    var f:Double; var xLo,xHi:array of Double;
                    n:Integer; Inverse:Boolean);
var i:Integer;
begin
 if Inverse
 then for i:=0 to n-1 do Dest[i]:=Source[i]/((xHi[i]-xLo[i])/f)
 else for i:=0 to n-1 do Dest[i]:=Source[i]*((xHi[i]-xLo[i])/f);
end;

procedure ScaleGess(var Source,Dest:array of Double; m:Integer;
                    var f:Double; var xLo,xHi:array of Double;
                    n:Integer; Inverse:Boolean);
var i,j:Integer;
begin
 for i:=0 to n-1 do
 for j:=0 to n-1 do
 if Inverse
 then Dest[i*m+j]:=Source[i*m+j]/((xHi[i]-xLo[i])*(xHi[j]-xLo[j])/f)
 else Dest[i*m+j]:=Source[i*m+j]*((xHi[i]-xLo[i])*(xHi[j]-xLo[j])/f);
end;

 {
 ---------------------
 DLL Service routiners
 ---------------------
 }

function  DLLFit(t      : Double;
                 n      : Integer;
             var x      : array of Double;
             var f      : Double;
             var g      : array of Double;
                 Custom : Pointer) : Integer;
begin
 if Assigned(FitFunction)
 then DLLFit:=FitFunction(t,n,@x,@f,@g,Custom)
 else DLLFit:=ecDLLError;
end;

function LoadFitFunction(FileName,FunctionName:PChar):Boolean;
begin
 FreeFitFunction;
 FitLibrary:=SafeLoadLibrary(FileName);
 if FitLibrary<>0 then begin
  @FitFunction:=GetProcAddress(FitLibrary,FunctionName);
  if @FitFunction=nil then FreeFitFunction;
 end else FreeFitFunction;
 LoadFitFunction:=@FitFunction<>nil;
end;

procedure FreeFitFunction;
begin
 if FitLibrary<>0 then FreeLibrary(FitLibrary);
 FitLibrary:=0;
 FitFunction:=nil;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_funmin;
begin
end;

procedure Free_crw_funmin;
begin
end;

initialization

 Init_crw_funmin;

finalization

 Free_crw_funmin;

end.

//////////////
// END OF FILE
//////////////

