* initial version

packages/numlib/det.pas

@@ -0,0 +1,426 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Determinants for different kinds of matrices (different with respect
+                 to symmetry)
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit det;
+
+interface
+{$I DIRECT.INC}
+
+uses typ;
+
+{Generic determinant}
+procedure detgen(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
+
+{determinant symmetrical matrix}
+procedure detgsy(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
+
+{determinant of a symmetrical positive definitive matrix}
+procedure detgpd(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
+
+{determinant of a generic bandmatrix}
+procedure detgba(n, l, r: ArbInt; var a, f: ArbFloat; var k, term:ArbInt);
+
+{determinant of a symmetrical positive definitive bandmatrix}
+procedure detgpb(n, l: ArbInt; var a, f: ArbFloat; var k, term:ArbInt);
+
+{determinant of a tridiagonal matrix}
+procedure detgtr(n: ArbInt; var l, d, u, f: ArbFloat; var k, term:ArbInt);
+
+implementation
+
+uses mdt;
+
+const               {  og = 8^-maxexp, ogý>=midget,
+                       bg = 8^maxexp,  bgý<=giant
+
+                       midget and giant are defined in typ.pas}
+
+{$IFNDEF ArbExtended}
+     ogx: Float8Arb= (84, 254, 32, 128, 32, 0, 0, 32);
+     bgx: Float8Arb= (149, 255, 255, 255, 255, 255, 239, 95);
+  maxexpx : ArbInt = 170;
+{$ENDIF}
+
+{$IFDEF Arb}
+     ogx: Float10Arb = (51,158,223,249,51,243,4,181,224,31);
+     bgx: Float10Arb = (108,119,117,92,70,38,155,234,254,95);
+  maxexpx : ArbInt = 2740;
+{$ENDIF}
+
+var og          : ArbFloat absolute ogx;
+    bg          : ArbFloat absolute bgx;
+    MaxExp      : ArbInt   absolute maxexpx;
+
+procedure detgen(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
+
+var
+    kk, ind, ind1, ns, i        : ArbInt;
+    u, ca                       : ArbFloat;
+    pa, acopy                   : ^arfloat1;
+    p                           : ^arint1;
+begin
+  if (n<1) or (rwidth<1) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pa:=@a;
+  ns:=n*sizeof(ArbFloat);
+  getmem(p, n*sizeof(ArbInt));
+  getmem(acopy, n*ns);
+  ind:=1; ind1:=1;
+  for i:=1 to n do
+    begin
+      move(pa^[ind1], acopy^[ind], ns);
+      ind1:=ind1+rwidth; ind:=ind+n
+    end; {i}
+  mdtgen(n, n, acopy^[1], p^[1], ca, term);
+  if term=1 then
+    begin
+      f:=1; k:=0; kk:=1; ind:=1;
+      while (kk<=n) and (f<>0) do
+        begin
+          u:=acopy^[ind];
+          while (u<>0) and (abs(u)<og) do
+            begin
+              u:=u/og; k:=k-maxexp
+            end; {underflow control}
+          while abs(u)>bg do
+            begin
+              u:=u/bg; k:=k+maxexp
+            end; {overflow control}
+          f:=f*u;
+          if p^[kk]<>kk then f:=-f;
+          while (f<>0) and (abs(f)<og) do
+            begin
+              f:=f/og; k:=k-maxexp
+            end; {underflow control}
+          while abs(f)>bg do
+            begin
+              f:=f/bg; k:=k+maxexp
+            end; {overflow control}
+          kk:=kk+1; ind:=ind+n+1
+        end; {kk}
+    end {term=1}
+  else {term=4}
+    begin
+      f:=0; k:=0; term:=1
+    end;
+  freemem(p, n*sizeof(ArbInt));
+  freemem(acopy, n*ns)
+end; {detgen}
+
+procedure detgsy(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
+
+var i, kk, ind, ind1, s : ArbInt;
+    u, ca               : ArbFloat;
+    pa, acopy           : ^arfloat1;
+    p                   : ^arint1;
+    q                   : ^arbool1;
+begin
+  if (n<1) or (rwidth<1) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pa:=@a;
+  getmem(p, n*sizeof(ArbInt));
+  getmem(q, n*sizeof(boolean));
+  s:=sizeof(ArbFloat);
+  getmem(acopy, n*n*s);
+  ind:=1; ind1:=1;
+  for i:=1 to n do
+    begin
+      move(pa^[ind1], acopy^[ind], i*s);
+      ind1:=ind1+rwidth; ind:=ind+n
+    end; {i}
+  mdtgsy(n, n, acopy^[1], p^[1], q^[1], ca, term);
+  if term=1 then
+    begin
+      f:=1; k:=0; kk:=1; ind:=1;
+      while (kk<=n) and (f<>0) do
+        begin
+          u:=acopy^[ind];
+          while (u<>0) and (abs(u)<og) do
+            begin
+              u:=u/og; k:=k-maxexp
+            end; {underflow control}
+          while abs(u)>bg do
+            begin
+              u:=u/bg; k:=k+maxexp
+            end; {overflow control}
+          f:=f*u;
+          if q^[kk] then f:=-f;
+          while (f<>0) and (abs(f)<og) do
+            begin
+              f:=f/og; k:=k-maxexp
+            end; {underflow control}
+          while abs(f)>bg do
+            begin
+              f:=f/bg; k:=k+maxexp
+            end; {overflow control}
+          kk:=kk+1; ind:=ind+n+1
+        end; {kk}
+    end {term=1}
+  else {term=4}
+    begin
+      term:=1; f:=0; k:=0
+    end;
+  freemem(p, n*sizeof(ArbInt));
+  freemem(q, n*sizeof(boolean));
+  freemem(acopy, n*n*s)
+end; {detgsy}
+
+procedure detgpd(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
+
+var
+   i, kk, ind, ind1, s : ArbInt;
+   u, ca               : ArbFloat;
+   pa, acopy           : ^arfloat1;
+begin
+  if (n<1) or (rwidth<1) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pa:=@a;
+  s:=sizeof(ArbFloat);
+  getmem(acopy, n*n*s);
+  ind:=1; ind1:=1;
+  for i:=1 to n do
+    begin
+      move(pa^[ind1], acopy^[ind], i*s);
+      ind1:=ind1+rwidth; ind:=ind+n
+    end; {i}
+  mdtgpd(n, n, acopy^[1], ca, term);
+  if term=1 then
+    begin
+      f:=1; k:=0; kk:=1; ind:=1;
+      while kk<=n do
+        begin
+          u:=sqr(acopy^[ind]);
+          while u < og do
+            begin
+              u:=u/og; k:=k-maxexp
+            end; {underflow control}
+          while u > bg do
+            begin
+              u:=u/bg; k:=k+maxexp
+            end; {overflow control}
+          f:=f*u;
+          while f < og do
+            begin
+              f:=f/og; k:=k-maxexp
+            end; {underflow control}
+          while f > bg do
+            begin
+              f:=f/bg; k:=k+maxexp
+            end; {overflow control}
+          kk:=kk+1; ind:=ind+n+1
+        end; {kk}
+    end; {term=1}
+  freemem(acopy, n*n*s)
+end; {detgpd}
+
+procedure detgba(n, l, r: ArbInt; var a, f: ArbFloat;
+                 var k, term:ArbInt);
+var
+    rwidth, s, ns, kk, ii, i, j, jj, ll : ArbInt;
+    u, ca                               : ArbFloat;
+    pa, l1, acopy                       : ^arfloat1;
+    p                                   : ^arint1;
+begin
+  if (n<1) or (l<0) or (r<0) or (l>n-1) or (r>n-1) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pa:=@a;
+  s:=sizeof(ArbFloat); ns:=n*s;
+  ll:=l+r+1;
+  getmem(acopy, ll*ns);
+  getmem(l1, l*ns);
+  getmem(p, n*sizeof(ArbInt));
+  jj:=1; ii:=1;
+  for i:=1 to n do
+    begin
+      if i <= l+1 then
+        begin
+          if i <= n-r then rwidth:=r+i else rwidth:=n
+        end else
+          if i <= n-r then rwidth:=ll else rwidth:=n-i+l+1;
+      if i > l then kk:=ii else kk:=ii+l-i+1;
+      move(pa^[jj], acopy^[kk], rwidth*s);
+      jj:=jj+rwidth; ii:=ii+ll;
+    end; {i}
+  mdtgba(n, l, r, ll, acopy^[1], l, l1^[1], p^[1], ca, term);
+  if term=1 then
+    begin
+      f:=1; k:=0; kk:=1; ii:=1;
+      while (kk<=n) and (f<>0) do
+        begin
+          u:=acopy^[ii];
+          while (u<>0) and (abs(u)<og) do
+            begin
+              u:=u/og; k:=k-maxexp
+            end; {underflow control}
+          while abs(u)>bg do
+            begin
+              u:=u/bg; k:=k+maxexp
+            end; {overflow control}
+          f:=f*u;
+          if p^[kk]<>kk then f:=-f;
+          while (f<>0) and (abs(f)<og) do
+            begin
+              f:=f/og; k:=k-maxexp
+            end; {underflow control}
+          while abs(f)>bg do
+            begin
+              f:=f/bg; k:=k+maxexp
+            end; {overflow control}
+          kk:=kk+1; ii:=ii+ll
+        end; {kk}
+    end {term=1}
+  else {term=4}
+    begin
+      term:=1; f:=0; k:=0
+    end;
+  freemem(acopy, ll*ns);
+  freemem(l1, l*ns);
+  freemem(p, n*sizeof(ArbInt))
+end; {detgba}
+
+procedure detgpb(n, l: ArbInt; var a, f: ArbFloat; var k, term: ArbInt);
+
+var
+  rwidth, kk, ii, ns, ll, jj, i, s  : ArbInt;
+          u, ca                     : ArbFloat;
+          pa, acopy                 : ^arfloat1;
+begin
+  if (n<1) or (l<0) or (l>n-1) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pa:=@a;
+  ll:=l+1;
+  s:=sizeof(ArbFloat); ns:=s*n;
+  getmem(acopy, ll*ns);
+  jj:=1; ii:=1;
+  for i:=1 to n do
+    begin
+      if i>l then rwidth:=ll else rwidth:=i;
+      move(pa^[jj], acopy^[ii+ll-rwidth], rwidth*s);
+      jj:=jj+rwidth; ii:=ii+ll
+    end; {i}
+  mdtgpb(n, l, ll, acopy^[1], ca, term);
+  if term=1 then
+    begin
+      f:=1; k:=0; kk:=1; ii:=ll;
+      while (kk<=n) do
+        begin
+          u:=sqr(acopy^[ii]);
+          while u < og do
+            begin
+              u:=u/og; k:=k-maxexp
+            end; {underflow control}
+          while u > bg do
+            begin
+              u:=u/bg; k:=k+maxexp
+            end; {overflow control}
+          f:=f*u;
+          while f < og do
+            begin
+              f:=f/og; k:=k-maxexp
+            end; {underflow control}
+          while f > bg do
+            begin
+              f:=f/bg; k:=k+maxexp
+            end; {overflow control}
+          kk:=kk+1; ii:=ii+ll
+        end; {kk}
+    end; {term=1}
+  freemem(acopy, ll*ns);
+end; {detgpb}
+
+procedure detgtr(n: ArbInt; var l, d, u, f: ArbFloat; var k, term:ArbInt);
+
+var
+          ns, kk              : ArbInt;
+          uu, ca              : ArbFloat;
+  pl, pd, pu, l1, d1, u1, u2  : ^arfloat1;
+  p                           : ^arbool1;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pl:=@l; pd:=@d; pu:=@u;
+  ns:=n*sizeof(ArbFloat);
+  getmem(l1, ns);
+  getmem(d1, ns);
+  getmem(u1, ns);
+  getmem(u2, ns);
+  getmem(p, n*sizeof(boolean));
+  mdtgtr(n, pl^[1], pd^[1], pu^[1], l1^[1], d1^[1], u1^[1], u2^[1],
+         p^[1], ca, term);
+  if term=1 then
+    begin
+      f:=1; k:=0; kk:=1;
+      while (kk<=n) and (f<>0) do
+        begin
+          if p^[kk] then f:=-f;
+          uu:=d1^[kk];
+          while (uu<>0) and (abs(uu)<og) do
+            begin
+              uu:=uu/og; k:=k-maxexp
+            end; {underflow control}
+          while abs(uu)>bg do
+            begin
+              uu:=uu/bg; k:=k+maxexp
+            end; {overflow control}
+          f:=f*uu;
+          while (f<>0) and (abs(f)<og) do
+            begin
+              f:=f/og; k:=k-maxexp
+            end; {underflow control}
+          while abs(f)>bg do
+            begin
+              f:=f/bg; k:=k+maxexp
+            end; {overflow control}
+          kk:=kk+1
+        end; {kk}
+    end {term=1}
+  else {term=4}
+    begin
+      term:=1; f:=0; k:=0
+    end;
+  freemem(l1, ns);
+  freemem(d1, ns);
+  freemem(u1, ns);
+  freemem(u2, ns);
+  freemem(p, n*sizeof(boolean));
+end; {detgtr}
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:57  marco
+   * initial version
+
+
+}
+

packages/numlib/dsl.pas

@@ -0,0 +1,536 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Unknown unit. There doesn't exist any documentation for it, it isn't
+    commented, and I don't recognize the algortism directly.
+    I added some comments, since suffixes of the procedures seem to indicate
+    some features of the matrixtype (from unit SLE)
+    So probably Some pivot matrix?
+
+    This code was probably internal in older libs, and only exported
+    in later versions.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+Unit dsl;
+
+interface
+{$I DIRECT.INC}
+
+
+uses typ;
+
+{Gen=generic, matrix without special or unknown ordering}
+Procedure dslgen(n, rwidth: ArbInt; Var alu: ArbFloat; Var p: ArbInt;
+                 Var b, x: ArbFloat; Var term: ArbInt);
+
+{"tridiagonal matrix"}
+Procedure dslgtr(n: ArbInt; Var l1, d1, u1, u2: ArbFloat;
+                 Var p: boolean; Var b, x: ArbFloat; Var term: ArbInt);
+
+{Symmetrical matrix}
+Procedure dslgsy(n, rwidth: ArbInt; Var alt: ArbFloat; Var p: ArbInt;
+                 Var q: boolean; Var b, x: ArbFloat; Var term: ArbInt);
+
+{Symmetrical positive definitive matrix}
+Procedure dslgpd(n, rwidth: ArbInt; Var al, b, x: ArbFloat;
+                 Var term: ArbInt);
+
+{Generic "band" matrix}
+Procedure dslgba(n, lb, rb, rwa: ArbInt; Var au: ArbFloat; rwl: ArbInt;
+                 Var l: ArbFloat; Var p: ArbInt; Var b, x: ArbFloat;
+                 Var term: ArbInt);
+
+{Positive definite bandmatrix}
+Procedure dslgpb(n, lb, rwidth: ArbInt; Var al, b, x: ArbFloat;
+                 Var term: ArbInt);
+
+{Special tridiagonal matrix}
+Procedure dsldtr(n:ArbInt; Var l, d, u, b, x: ArbFloat; Var term: ArbInt);
+
+implementation
+
+Procedure dslgen(n, rwidth: ArbInt; Var alu: ArbFloat; Var p: ArbInt;
+                 Var b, x: ArbFloat; Var term: ArbInt);
+
+Var 
+                          success : boolean;
+    indk, j, k, indexpivot, kmin1 : ArbInt;
+                      h, pivot, s : ArbFloat;
+                               pp : ^arint1;
+                     palu, pb, px : ^arfloat1;
+
+Begin
+  If (n<1) Or (rwidth<1) Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  pp := @p;
+ palu := @alu;
+ pb := @b;
+ px := @x;
+  move(pb^, px^, n*sizeof(ArbFloat));
+  For k:=1 To n Do
+    Begin
+      indexpivot := pp^[k];
+      If indexpivot  <> k Then
+        Begin
+          h := px^[k];
+         px^[k] := px^[indexpivot];
+          px^[indexpivot] := h
+        End {indexpivot <> k}
+    End; {k}
+  For k:=2 To n Do
+    Begin
+      s := px^[k];
+     kmin1 := k-1;
+      For j:=1 To kmin1 Do
+        s := s-palu^[(k-1)*rwidth+j]*px^[j];
+      px^[k] := s
+    End; {k}
+  success := true;
+ k := n+1;
+  while (k>1) and success Do
+    Begin
+      k := k-1;
+     indk := (k-1)*rwidth;
+      pivot := palu^[indk+k];
+      If pivot=0 Then
+        success := false
+      Else
+        Begin
+          s := px^[k];
+          For j:=k+1 To n Do
+            s := s-palu^[indk+j]*px^[j];
+          px^[k] := s/pivot
+        End {pivot <> 0}
+    End; {k}
+  If success Then
+    term := 1
+  Else
+    term := 2
+End; {dslgen}
+
+Procedure dslgtr(n: ArbInt; Var l1, d1, u1, u2: ArbFloat;
+                 Var p: boolean; Var b, x: ArbFloat; Var term: ArbInt);
+
+Var 
+                    i, j, nmin1 : ArbInt;
+                          h, di : ArbFloat;
+                        success : boolean;
+          pd1, pu1, pu2, pb, px : ^arfloat1;
+                            pl1 : ^arfloat2;
+                             pp : ^arbool1;
+Begin
+  If n<1 Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  pl1 := @l1;  pd1 := @d1;  pu1 := @u1; pu2 := @u2; pb := @b;  px := @x;
+ pp := @p;
+  move(pb^, px^, n*sizeof(ArbFloat));
+  success := true;
+ i := 0;
+  while (i<>n) and success Do
+    Begin
+      i := i+1;
+     success := pd1^[i]<>0
+    End; {i}
+  If success Then
+    Begin
+      nmin1 := n-1;
+     j := 1;
+      while j <> n Do
+        Begin
+          i := j;
+         j := j+1;
+          If pp^[i] Then
+            Begin
+              h := px^[i];
+             px^[i] := px^[j];
+             px^[j] := h-pl1^[j]*px^[i]
+            End {pp^[i]}
+          Else
+            px^[j] := px^[j]-pl1^[j]*px^[i]
+        End;  {j}
+      di := pd1^[n];
+      px^[n] := px^[n]/di;
+      If n > 1 Then
+        Begin
+          di := pd1^[nmin1];
+          px^[nmin1] := (px^[nmin1]-pu1^[nmin1]*px^[n])/di
+        End; {n > 1}
+      For i:=n-2 Downto 1 Do
+        Begin
+          di := pd1^[i];
+          px^[i] := (px^[i]-pu1^[i]*px^[i+1]-pu2^[i]*px^[i+2])/di
+        End {i}
+    End; {success}
+  If success Then
+    term := 1
+  Else
+    term := 2
+End; {dslgtr}
+
+Procedure dslgsy(n, rwidth: ArbInt; Var alt: ArbFloat; Var p: ArbInt;
+                 Var q: boolean; Var b, x: ArbFloat; Var term: ArbInt);
+
+Var 
+    i, indexpivot, imin1, j, jmin1, iplus1, imin2, ns, ii  : ArbInt;
+                                          success, regular : boolean;
+                                                 h, ct, di : ArbFloat;
+                               palt, pb, px, y, l, d, u, v : ^arfloat1;
+                                                        pp : ^arint1;
+                                                        pq : ^arbool1;
+
+Begin
+  If (n<1) Or (rwidth<1) Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  palt := @alt;
+ pp := @p;
+ pq := @q;
+ pb := @b;
+ px := @x;
+  ns := n*sizeof(ArbFloat);
+  getmem(l, ns);
+  getmem(d, ns);
+  getmem(u, ns);
+  getmem(v, ns);
+  getmem(y, ns);
+  move(pb^, y^, ns);
+  success := true;
+ i := 0;
+ ii := 1;
+  while (i<>n) and success Do
+    Begin
+      i := i+1;
+     success := palt^[ii]<>0;
+     ii := ii+rwidth+1
+    End; {i}
+  If success Then
+    Begin
+      For i:=1 To n Do
+        Begin
+          indexpivot := pp^[i];
+          If indexpivot <> i Then
+            Begin
+              h := y^[i];
+             y^[i] := y^[indexpivot];
+              y^[indexpivot] := h
+            End {indexpivot <> i}
+        End; {i}
+      i := 0;
+      while i<n Do
+        Begin
+          imin1 := i;
+         i := i+1;
+         j := 1;
+         h := y^[i];
+          while j<imin1 Do
+            Begin
+              jmin1 := j;
+             j := j+1;
+              h := h-palt^[(i-1)*rwidth+jmin1]*y^[j]
+            End; {j}
+          y^[i] := h
+        End; {i}
+      d^[1] := palt^[1];
+     di := d^[1];
+      If n>1 Then
+        Begin
+          l^[1] := palt^[rwidth+1];
+         d^[2] := palt^[rwidth+2];
+          di := d^[2];
+          u^[1] := palt^[2]
+        End; {n>1}
+      imin1 := 1;
+     i := 2;
+      while i<n Do
+        Begin
+          imin2 := imin1;
+         imin1 := i;
+         i := i+1;
+          ii := (i-1)*rwidth;
+          l^[imin1] := palt^[ii+imin1];
+         d^[i] := palt^[ii+i];
+         di := d^[i];
+          u^[imin1] := palt^[ii-rwidth+i];
+         v^[imin2] := palt^[ii-2*rwidth+i]
+        End; {i}
+      dslgtr(n, l^[1], d^[1], u^[1], v^[1], pq^[1], y^[1], px^[1], term);
+      i := n+1;
+     imin1 := n;
+      while i>2 Do
+        Begin
+          iplus1 := i;
+         i := imin1;
+         imin1 := imin1-1;
+         h := px^[i];
+          For j:=iplus1 To n Do
+            h := h-palt^[(j-1)*rwidth+imin1]*px^[j];
+          px^[i] := h
+        End; {i}
+      For i:=n Downto 1 Do
+        Begin
+          indexpivot := pp^[i];
+          If indexpivot <> i Then
+            Begin
+              h := px^[i];
+             px^[i] := px^[indexpivot];
+              px^[indexpivot] := h
+            End {indexpivot <> i}
+        End {i}
+   End; {success}
+  If success Then
+    term := 1
+  Else
+    term := 2;
+  freemem(l, ns);
+  freemem(d, ns);
+  freemem(u, ns);
+  freemem(v, ns);
+  freemem(y, ns)
+End; {dslgsy}
+
+Procedure dslgpd(n, rwidth: ArbInt; Var al, b, x: ArbFloat;
+                 Var term: ArbInt);
+
+Var 
+       ii, imin1, i, j : ArbInt;
+                h, lii : ArbFloat;
+               success : boolean;
+           pal, pb, px : ^arfloat1;
+Begin
+  If (n<1) Or (rwidth<1) Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  pal := @al;
+ pb := @b;
+ px := @x;
+  move(pb^, px^, n*sizeof(ArbFloat));
+  success := true;
+ i := 0;
+ ii := 1;
+  while (i<>n) and success Do
+    Begin
+      i := i+1;
+     success := pal^[ii]<>0;
+     ii := ii+rwidth+1
+    End; {i}
+  If success Then
+    Begin
+      For i:=1 To n Do
+        Begin
+          ii := (i-1)*rwidth;
+          h := px^[i];
+         imin1 := i-1;
+          For j:=1 To imin1 Do
+            h := h-pal^[ii+j]*px^[j];
+          lii := pal^[ii+i];
+          px^[i] := h/lii
+        End; {i}
+      For i:=n Downto 1 Do
+        Begin
+          h := px^[i];
+          For j:=i+1 To n Do
+            h := h-pal^[(j-1)*rwidth+i]*px^[j];
+          px^[i] := h/pal^[(i-1)*rwidth+i]
+        End {i}
+    End; {success}
+  If success Then
+    term := 1
+  Else
+    term := 2
+End;  {dslgpd}
+
+Procedure dslgba(n, lb, rb, rwa: ArbInt; Var au: ArbFloat; rwl: ArbInt;
+                 Var l: ArbFloat; Var p: ArbInt; Var b, x: ArbFloat;
+                 Var term: ArbInt);
+
+Var 
+   i, j, k, ipivot, ubi, ubj : ArbInt;
+   h, pivot                  : ArbFloat;
+   pau, pl, px, pb           : ^arfloat1;
+   pp                        : ^arint1;
+
+Begin
+  If (n<1) Or (lb<0) Or (rb<0) Or (lb>n-1)
+        Or (rb>n-1) Or (rwa<1) Or (rwl<0) Then
+    Begin
+      term := 3;
+     exit
+    End; {term=3}
+  pau := @au;
+ pl := @l;
+ pb := @b;
+ px := @x;
+ pp := @p;
+  move(pb^, px^, n*sizeof(ArbFloat));
+  ubi := lb;
+  For k:=1 To n Do
+    Begin
+      ipivot := pp^[k];
+      If ipivot <> k Then
+        Begin
+          h := px^[k];
+         px^[k] := px^[ipivot];
+          px^[ipivot] := h
+        End; {ipivot <> k}
+      If ubi<n Then
+        ubi := ubi+1;
+      For i:=k+1 To ubi Do
+        px^[i] := px^[i]-px^[k]*pl^[(k-1)*rwl+i-k]
+    End; {k}
+  ubj := 0;
+ i := n;
+ term := 1;
+  while (i >= 1) and (term=1) Do
+    Begin
+      If ubj<rb+lb+1 Then
+        ubj := ubj+1;
+      h := px^[i];
+      For j:=2 To ubj Do
+        h := h-pau^[(i-1)*rwa+j]*px^[i+j-1];
+      pivot := pau^[(i-1)*rwa+1];
+      If pivot=0 Then
+        term := 2
+      Else
+        px^[i] := h/pivot;
+      i := i-1
+    End {i}
+End; {dslgba}
+
+Procedure dslgpb(n, lb, rwidth: ArbInt; Var al, b, x: ArbFloat;
+                 Var term: ArbInt);
+
+Var 
+   ll, ii, llmin1, p, i, q, k : ArbInt;
+            h, hh, alim       : ArbFloat;
+                  pal, pb, px : ^arfloat1;
+Begin
+  If (lb<0) Or (lb>n-1) Or (n<1) Or (rwidth<1) Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  pal := @al;
+ pb := @b;
+ px := @x;
+  move(pb^, px^, n*sizeof(ArbFloat));
+  ll := lb+1;
+  llmin1 := ll-1;
+ p := ll+1;
+ term := 1;
+ i := 1;
+  while (i <= n) and (term=1) Do
+    Begin
+      ii := (i-1)*rwidth;
+      If p>1 Then
+        p := p-1;
+      h := px^[i];
+     q := i;
+      For k:=llmin1 Downto p Do
+        Begin
+          q := q-1;
+         h := h-pal^[ii+k]*px^[q]
+        End; {k}
+      alim := pal^[ii+ll];
+      If alim=0 Then
+        term := 2
+      Else
+        px^[i] := h/alim;
+      i := i+1
+    End; {i}
+  If term=1 Then
+    Begin
+      p := ll+1;
+      For i:=n Downto 1 Do
+        Begin
+          If p>1 Then
+            p := p-1;
+          q := i;
+         h := px^[i];
+          For k:=llmin1 Downto p Do
+            Begin
+              q := q+1;
+             h := h-pal^[(q-1)*rwidth+k]*px^[q]
+            End; {k}
+          px^[i] := h/pal^[(i-1)*rwidth+ll]
+        End {i}
+    End {term=1}
+End; {dslgpb}
+
+Procedure dsldtr(n:ArbInt; Var l, d, u, b, x: ArbFloat; Var term: ArbInt);
+
+Var 
+                   i, j : ArbInt;
+                     di : ArbFloat;
+         pd, pu, pb, px : ^arfloat1;
+                     pl : ^arfloat2;
+Begin
+  If n<1 Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  pl := @l;
+ pd := @d;
+ pu := @u;
+ pb := @b;
+ px := @x;
+  move(pb^, px^, n*sizeof(ArbFloat));
+  j := 1;
+  while j <> n Do
+    Begin
+      i := j;
+     j := j+1;
+     px^[j] := px^[j]-pl^[j]*px^[i]
+    End;
+  di := pd^[n];
+  If di=0 Then
+    term := 2
+  Else
+    term := 1;
+  If term=1 Then
+    px^[n] := px^[n]/di;
+  i := n-1;
+  while (i >= 1) and (term=1) Do
+    Begin
+      di := pd^[i];
+      If di=0 Then
+        term := 2
+      Else
+        px^[i] := (px^[i]-pu^[i]*px^[i+1])/di;
+      i := i-1
+    End; {i}
+End; {dsldtr}
+
+End.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/eig.pas

@@ -0,0 +1,818 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit eig;
+{$I DIRECT.INC}
+
+interface
+
+uses typ;
+
+const versie = 'augustus 1993';
+
+procedure eiggs1(var a: ArbFloat; n, rwidth: ArbInt; var lam: ArbFloat;
+                 var term: ArbInt);
+
+procedure eiggs2(var a: ArbFloat; n, rwidth, k1, k2: ArbInt;
+                 var lam: ArbFloat; var term: ArbInt);
+
+procedure eiggs3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: ArbFloat;
+                 rwidthx: ArbInt; var term: ArbInt);
+
+procedure eiggs4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var lam, x: ArbFloat;
+                 rwidthx: ArbInt; var m2, term: ArbInt);
+
+procedure eigts1(var d, cd: ArbFloat; n: ArbInt; var lam: ArbFloat;
+                 var term: ArbInt);
+
+procedure eigts2(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;
+                 var term: ArbInt);
+
+procedure eigts3(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;
+                 rwidth: ArbInt; var term: ArbInt);
+
+procedure eigts4(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam, x: ArbFloat;
+                 rwidth: ArbInt; var m2, term: ArbInt);
+
+procedure eigbs1(var a: ArbFloat; n, l: ArbInt; var lam: ArbFloat;
+                 var term: ArbInt);
+
+procedure eigbs2(var a: ArbFloat; n, l, k1, k2: ArbInt; var lam: ArbFloat;
+                 var term: ArbInt);
+
+procedure eigbs3(var a: ArbFloat; n, l: ArbInt; var lam, x: ArbFloat;
+                 rwidthx: ArbInt; var term: ArbInt);
+
+procedure eigbs4(var a: ArbFloat; n, l, k1, k2: ArbInt;
+                 var lam, x: ArbFloat;  rwidthx: ArbInt;
+                 var m2, term: ArbInt);
+
+procedure eigge1(var a: ArbFloat; n, rwidth: ArbInt; var lam: complex;
+                 var term: ArbInt);
+
+procedure eigge3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: complex;
+                 rwidthx: ArbInt; var term: ArbInt);
+
+procedure eiggg1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
+                 rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt);
+
+procedure eiggg2(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;
+                 rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt);
+
+procedure eiggg3(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
+                 rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;
+                 var term: ArbInt);
+
+procedure eiggg4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;
+                 rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;
+                 var m2, term: ArbInt);
+
+procedure eigsv1(var a: ArbFloat; m, n, rwidth: ArbInt; var sig: ArbFloat;
+                 var term: ArbInt);
+
+procedure eigsv3(var a: ArbFloat; m, n, rwidtha: ArbInt; var sig, u: ArbFloat;
+                 rwidthu: ArbInt; var v: ArbFloat; rwidthv: ArbInt;
+                 var term: ArbInt);
+
+implementation
+
+uses eigh1, eigh2;
+
+procedure eiggs1(var a: ArbFloat; n, rwidth: ArbInt; var lam: ArbFloat;
+                 var term: ArbInt);
+var            i, sr, nsr : ArbInt;
+    d, cd, dh, cdh, u, pa : ^arfloat1;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pa:=@a;
+  sr:=sizeof(ArbFloat); nsr:=n*sr;
+  getmem(d, nsr); getmem(cd, nsr); getmem(dh, nsr); getmem(cdh, nsr);
+  getmem(u, n*nsr);
+  for i:=1 to n do move(pa^[(i-1)*rwidth+1], u^[(i-1)*n+1], i*sr);
+  tred1(u^[1], n, n, d^[1], cd^[1], term);
+  move(d^[1], dh^[1], nsr); move(cd^[1], cdh^[1], nsr);
+  tql1(d^[1], cd^[1], n, lam, term);
+  if term=2 then bisect(dh^[1], cdh^[1], n, 1, n, 0, lam, term);
+  freemem(d, nsr); freemem(cd, nsr); freemem(dh, nsr); freemem(cdh, nsr);
+  freemem(u, n*nsr);
+end; {eiggs1}
+
+procedure eiggs2(var a: ArbFloat; n, rwidth, k1, k2: ArbInt;
+                 var lam: ArbFloat; var term: ArbInt);
+var          i, sr, nsr : ArbInt;
+           d, cd, u, pa : ^arfloat1;
+begin
+  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pa:=@a;
+  sr:=sizeof(ArbFloat); nsr:=n*sr;
+  getmem(d, nsr); getmem(cd, nsr); getmem(u, n*nsr);
+  for i:=1 to n do move(pa^[(i-1)*rwidth+1], u^[(i-1)*n+1], i*sr);
+  tred1(u^[1], n, n, d^[1], cd^[1], term);
+  bisect(d^[1], cd^[1], n, k1, k2, 0, lam, term);
+  freemem(d, nsr); freemem(cd, nsr); freemem(u, n*nsr);
+end; {eiggs2}
+
+procedure eiggs3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: ArbFloat;
+                 rwidthx: ArbInt; var term: ArbInt);
+var   nsr : ArbInt;
+    d, cd : ^arfloat1;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end;
+  nsr:=n*sizeof(ArbFloat);
+  getmem(d, nsr); getmem(cd, nsr);
+  tred2(a, n, rwidtha, d^[1], cd^[1], x, rwidthx, term);
+  tql2(d^[1], cd^[1], n, lam, x, rwidthx, term);
+  freemem(d, nsr); freemem(cd, nsr)
+end;  {eiggs3}
+
+procedure eiggs4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var lam, x: ArbFloat;
+                 rwidthx: ArbInt; var m2, term: ArbInt);
+var      i, sr, nsr : ArbInt;
+       pa, d, cd, u : ^arfloat1;
+begin
+  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pa:=@a;
+  sr:=sizeof(ArbFloat); nsr:=n*sr;
+  getmem(d, nsr); getmem(cd, nsr); getmem(u, n*nsr);
+  for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], i*sr);
+  tred1(u^[1], n, n, d^[1], cd^[1], term);
+  trsturm1(d^[1], cd^[1], n, k1, k2, lam, x, rwidthx, m2, term);
+  trbak1(u^[1], n, n, cd^[1], k1, k2, x, rwidthx);
+  freemem(d, nsr); freemem(cd, nsr); freemem(u, n*nsr) { toegevoegd 3 apr 92 }
+end; {eiggs4}
+
+procedure eigts1(var d, cd: ArbFloat; n: ArbInt; var lam: ArbFloat;
+                 var term: ArbInt);
+var               sr, nsr : ArbInt;
+         pd, pcd, dh, cdh : ^arfloat1;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  sr:=sizeof(ArbFloat); nsr:=n*sr;
+  pd:=@d; pcd:=@cd; getmem(dh, nsr); getmem(cdh, nsr);
+  move(pd^[1], dh^[1], nsr); move(pcd^[1], cdh^[2], (n-1)*sr);
+  tql1(dh^[1], cdh^[1], n, lam, term);
+  if term=2 then
+    begin
+      move(pd^[1], dh^[1], nsr); move(pcd^[1], cdh^[2], (n-1)*sr);
+      bisect(dh^[1], cdh^[1], n, 1, n, 0, lam, term)
+    end;
+  freemem(dh, nsr); freemem(cdh, nsr);
+end; {eigts1}
+
+procedure eigts2(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;
+                 var term: ArbInt);
+var               sr, nsr : ArbInt;
+                 pcd, cdh : ^arfloat1;
+begin
+  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pcd:=@cd;
+  term:=1; sr:=sizeof(ArbFloat); nsr:=n*sr; getmem(cdh, nsr);
+  move(pcd^[1], cdh^[2], (n-1)*sr);
+  bisect(d, cdh^[1], n, k1, k2, 0, lam, term);
+  freemem(cdh, nsr)
+end; {eigts2}
+
+procedure eigts3(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;
+                 rwidth: ArbInt; var term: ArbInt);
+var             i, sr, nsr : ArbInt;
+              px, pcd, cdh : ^arfloat1;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end;
+  px:=@x; pcd:=@cd;
+  sr:=sizeof(ArbFloat); nsr:=n*sr;
+  getmem(cdh, nsr);
+  move(pcd^[1], cdh^[2], (n-1)*sr);
+  for i:=1 to n do fillchar(px^[(i-1)*rwidth+1], nsr, 0);
+  for i:=1 to n do px^[(i-1)*rwidth+i]:=1;
+  tql2(d, cdh^[1], n, lam, px^[1], rwidth, term);
+  freemem(cdh, nsr);
+end;  {eigts3}
+
+procedure eigts4(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam, x: ArbFloat;
+                 rwidth: ArbInt; var m2, term: ArbInt);
+var                    sr : ArbInt;
+                 pcd, cdh : ^arfloat1;
+begin
+  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  term:=1;
+  pcd:=@cd; sr:=sizeof(ArbFloat);
+  getmem(cdh, n*sr);
+  move(pcd^[1], cdh^[2], (n-1)*sr);
+  trsturm1(d, cdh^[1], n, k1, k2, lam, x, rwidth, m2, term);
+  freemem(cdh, n*sr)
+end; {eigts4}
+
+procedure eigbs1(var a: ArbFloat; n, l: ArbInt; var lam: ArbFloat;
+                 var term: ArbInt);
+var             u, d, cd : ^arfloat1;
+      uwidth, i, sr, nsr : ArbInt;
+begin
+  if (n<1) or (l<0) or (l>n-1) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  sr:=sizeof(ArbFloat); nsr:=n*sr; uwidth:=l+1;
+  getmem(u, uwidth*nsr); getmem(d, nsr); getmem(cd, nsr);
+  transf(a, n, l, u^[1], uwidth);
+  bandrd1(u^[1], n, l, uwidth, d^[1], cd^[1]);
+  eigts1(d^[1], cd^[2], n, lam, term);
+  freemem(u, uwidth*nsr); freemem(d, nsr); freemem(cd, nsr);
+end; {eigbs1}
+
+procedure eigbs2(var a: ArbFloat; n, l, k1, k2: ArbInt; var lam: ArbFloat;
+                 var term: ArbInt);
+var                  u, d, cd : ^arfloat1;
+           i, sr, nsr, uwidth : ArbInt;
+begin
+  if (n<1) or (k1<1) or (k2<k1) or (k2>n) or (l<0) or (l>n-1) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  sr:=sizeof(ArbFloat); nsr:=n*sr; uwidth:=l+1;
+  getmem(u, uwidth*nsr); getmem(d, nsr); getmem(cd, nsr);
+  transf(a, n, l, u^[1], uwidth);
+  bandrd1(u^[1], n, l, uwidth, d^[1], cd^[1]);
+  eigts2(d^[1], cd^[2], n, k1, k2, lam, term);
+  freemem(u, uwidth*nsr); freemem(d, nsr); freemem(cd, nsr)
+end; {eigbs2}
+
+procedure eigbs3(var a: ArbFloat; n, l: ArbInt; var lam, x: ArbFloat;
+                 rwidthx: ArbInt; var term: ArbInt);
+var                  u, d, cd : ^arfloat1;
+           i, sr, nsr, uwidth : ArbInt;
+begin
+  if (n<1) or (l<0) or (l>n-1) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  sr:=sizeof(ArbFloat); nsr:=n*sr; uwidth:=l+1;
+  getmem(u, uwidth*nsr); getmem(d, nsr); getmem(cd, nsr);
+  transf(a, n, l, u^[1], uwidth);
+  bandrd2(u^[1], n, l, uwidth, d^[1], cd^[1], x, rwidthx);
+  tql2(d^[1], cd^[1], n, lam, x, rwidthx, term);
+  freemem(u, uwidth*nsr); freemem(d, nsr); freemem(cd, nsr)
+end; {eigbs3}
+
+procedure eigbs4(var a: ArbFloat; n, l, k1, k2: ArbInt;
+                 var lam, x: ArbFloat;  rwidthx: ArbInt;
+                 var m2, term: ArbInt);
+var  i, j, k, m, uwidth : ArbInt;
+     plam, px, pa, v, u : ^arfloat1;
+                s, norm : ArbFloat;
+begin
+  if (n<1) or (k1<1) or (k2<k1) or (k2>n) or (l<0) or (l>n-1) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  plam:=@lam; px:=@x; pa:=@a; getmem(v, n*sizeof(ArbFloat));
+  uwidth:=l+1; getmem(u, n*uwidth*sizeof(ArbFloat));
+  eigbs2(a, n, l, k1, k2, plam^[1], term);
+  { kijk of norm(A-lambda.I)=0 }
+  { zo ja, lever dan de eenheidsvectoren e(k1) t/m e(k2) af }
+  norm:=0; j:=1;
+  for i:=1 to n do
+  begin
+      if i<=l then m:=i else m:=l+1; s:=0;
+      for k:=j to j+m-1 do
+      if k=j+m-1 then s:=s+abs(pa^[k]-plam^[1]) else s:=s+abs(pa^[k]);
+      if s>norm then norm:=s;
+      j:=j+m
+  end;
+  if norm=0 then
+  begin
+      for i:=k1 to k2 do for j:=1 to n do
+      if j=i then px^[(j-1)*rwidthx+i-k1+1]:=1
+      else px^[(j-1)*rwidthx+i-k1+1]:=0;
+      freemem(v, n*sizeof(ArbFloat)); freemem(u, n*uwidth*sizeof(ArbFloat));
+      m2:=k2; term:=1; exit
+  end;
+  transf(a, n, l, u^[1], uwidth);
+  i:=k1; m2:=k1-1;
+  while (i <= k2) and (term=1) do
+    begin
+      bandev(u^[1], n, l, uwidth, plam^[i-k1+1], v^[1], term);
+      if term=1 then
+        begin
+          m2:=i; for j:=1 to n do px^[(j-1)*rwidthx+i-k1+1]:=v^[j]
+        end;
+      i:=i+1
+    end; {i}
+  freemem(v, n*sizeof(ArbFloat));
+  freemem(u, n*uwidth*sizeof(ArbFloat));
+end; {eigbs4}
+
+procedure eigge1(var a: ArbFloat; n, rwidth: ArbInt; var lam: complex;
+                 var term: ArbInt);
+var pa, h, dummy : ^arfloat1;
+           i, ns : ArbInt;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end;
+  ns:=n*sizeof(ArbFloat); pa:=@a;
+  getmem(dummy, ns); getmem(h, n*ns);
+  for i:=1 to n do move(pa^[(i-1)*rwidth+1], h^[(i-1)*n+1], ns);
+  orthes(h^[1], n, n, dummy^[1]);
+  hessva(h^[1], n, n, lam, term);
+  freemem(dummy, ns); freemem(h, n*ns);
+end;  {eigge1}
+
+procedure eigge3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: complex;
+                 rwidthx: ArbInt; var term: ArbInt);
+var     pa, pd, u, v: ^arfloat1;
+    m1, m2, i, j, ns: ArbInt;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end;
+  ns:=n*sizeof(ArbFloat); getmem(pd, ns); getmem(u, n*ns); getmem(v, n*ns);
+  pa:=@a; for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], ns);
+  balance(u^[1], n, n, m1, m2, pd^[1]);
+  orttrans(u^[1], n, n, v^[1], n);
+  hessvec(u^[1], n, n, lam, v^[1], n, term);
+  if term=1 then
+    begin
+      balback(pd^[1], n, m1, m2, 1, n, v^[1], n);
+      normeer(lam, n, v^[1], n);
+      transx(v^[1], n, n, lam, x, rwidthx)
+    end;
+  freemem(pd, ns); freemem(u, n*ns); freemem(v, n*ns);
+end;  {eigge3}
+
+procedure eiggg1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
+                 rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt);
+var u, v, pa, pb : ^arfloat1;
+        i, j, ns : ArbInt;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end;
+  pa:=@a; pb:=@b; ns:=n*sizeof(ArbFloat); getmem(u, n*ns); getmem(v, n*ns);
+  for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], ns);
+  for i:=1 to n do move(pb^[(i-1)*rwidthb+1], v^[(i-1)*n+1], ns);
+  reduc1(u^[1], n, n, v^[1], n, term);
+  if term=1 then eiggs1(u^[1], n, n, lam, term);
+  freemem(u, n*ns); freemem(v, n*ns);
+end; {eiggg1}
+
+procedure eiggg2(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;
+                 rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt);
+var u, v, pa, pb : ^arfloat1;
+        i, j, ns : ArbInt;
+begin
+  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
+    begin
+      term:=3; exit
+    end;
+  pa:=@a; pb:=@b; ns:=n*sizeof(ArbFloat); getmem(u, n*ns); getmem(v, n*ns);
+  for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], ns);
+  for i:=1 to n do move(pb^[(i-1)*rwidthb+1], v^[(i-1)*n+1], ns);
+  reduc1(u^[1], n, n, v^[1], n, term);
+  if term=1 then eiggs2(u^[1], n, n, k1, k2, lam, term);
+  freemem(u, n*ns); freemem(v, n*ns)
+end; {eiggg2}
+
+procedure eiggg3(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
+                 rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;
+                 var term: ArbInt);
+var u, v, pa, pb : ^arfloat1;
+        i, j, ns : ArbInt;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end;
+  pa:=@a; pb:=@b;
+  ns:=n*sizeof(ArbFloat);
+  getmem(u, n*ns); getmem(v, n*ns);
+  for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], ns);
+  for i:=1 to n do move(pb^[(i-1)*rwidthb+1], v^[(i-1)*n+1], ns);
+  reduc1(u^[1], n, n, v^[1], n, term);
+  if term=1 then
+    begin
+      eiggs3(u^[1], n, n, lam, x, rwidthx, term);
+      if term=1 then rebaka(v^[1], n, n, 1, n, x, rwidthx, term)
+    end;
+  freemem(u, n*ns); freemem(v, n*ns)
+end; {eiggg3}
+
+procedure eiggg4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;
+                 rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;
+                 var m2, term: ArbInt);
+
+var u, v, pa, pb : ^arfloat1;
+     i, j, ns, t : ArbInt;
+begin
+  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
+    begin
+      term:=3; exit
+    end;
+  pa:=@a; pb:=@b; ns:=n*sizeof(ArbFloat); getmem(u, n*ns); getmem(v, n*ns);
+  for i:=1 to n do move(pa^[(i-1)*rwidtha+1], u^[(i-1)*n+1], ns);
+  for i:=1 to n do move(pb^[(i-1)*rwidthb+1], v^[(i-1)*n+1], ns);
+  reduc1(u^[1], n, n, v^[1], n, term);
+  if term=1 then
+    begin
+      eiggs4(u^[1], n, n, k1, k2, lam, x, rwidthx, m2, term);
+      if m2 < k2 then term:=4;
+      if m2 > k1-1 then
+        begin
+          rebaka(v^[1], n, n, k1, m2, x, rwidthx, t);
+          if t=2 then
+            begin
+              term:=4; m2:=k1-1
+            end
+        end
+    end;
+  freemem(u, n*ns); freemem(v, n*ns)
+end; {eiggg4}
+
+procedure eigsv1(var a: ArbFloat; m, n, rwidth: ArbInt; var sig: ArbFloat;
+                 var term: ArbInt);
+
+var                     pa, pq, u, e : ^arfloat1;
+          i, j, k, l, ns, ii, jj, kk : ArbInt;
+ c, f, g, h, p, s, x, y, z, eps, tol : ArbFloat;
+                  conv, goon, cancel : boolean;
+begin
+  if (n<1) or (m<n) then
+    begin
+      term:=3; exit
+    end;
+  pa:=@a; pq:=@sig; term:=1;
+  ns:=n*sizeof(ArbFloat); getmem(e, ns); getmem(u, m*ns);
+  for i:=1 to m do move(pa^[(i-1)*rwidth+1], u^[(i-1)*n+1], ns);
+  g:=0; x:=0; tol:=midget/macheps;
+  for i:=1 to n do
+    begin
+      ii:=(i-1)*n; e^[i]:=g;
+      s:=0; for j:=i to m do s:=s+sqr(u^[(j-1)*n+i]);
+      if s<tol then g:=0 else
+        begin
+          f:=u^[ii+i]; if f<0 then g:=sqrt(s) else g:=-sqrt(s);
+          h:=f*g-s; u^[ii+i]:=f-g;
+          for j:=i+1 to n do
+            begin
+              s:=0;
+              for k:=i to m do
+                begin
+                  kk:=(k-1)*n; s:=s+u^[kk+i]*u^[kk+j]
+                end; {k}
+              f:=s/h;
+              for k:=i to m do
+                begin
+                  kk:=(k-1)*n; u^[kk+j]:=u^[kk+j]+f*u^[kk+i]
+                end {k}
+            end {j}
+        end; {s}
+      pq^[i]:=g; s:=0;
+      for j:=i+1 to n do s:=s+sqr(u^[ii+j]);
+      if s < tol then g:=0 else
+        begin
+          f:=u^[ii+i+1]; if f < 0 then g:=sqrt(s) else g:=-sqrt(s);
+          h:=f*g-s; u^[ii+i+1]:=f-g;
+          for j:=i+1 to n do e^[j]:=u^[ii+j]/h;
+          for j:=i+1 to m do
+            begin
+              s:=0; jj:=(j-1)*n;
+              for k:=i+1 to n do s:=s+u^[jj+k]*u^[ii+k];
+              for k:=i+1 to n do u^[jj+k]:=u^[jj+k]+s*e^[k]
+            end {j}
+        end; {s}
+      y:=abs(pq^[i])+abs(e^[i]); if y > x then x:=y
+    end; {i}
+  eps:=macheps*x;
+  for k:=n downto 1 do
+    begin
+      conv:=false;
+      repeat
+        l:=k; goon:=true;
+        while goon do
+          begin
+            if abs(e^[l]) <= eps then
+              begin
+                goon:=false; cancel:=false
+              end else
+            if abs(pq^[l-1]) <= eps then
+              begin
+                goon:=false; cancel:=true
+              end
+            else l:=l-1
+          end; {goon}
+        if cancel then
+          begin
+            c:=0; s:=1;
+            i:=l; goon:=true;
+            while goon do
+              begin
+                f:=s*e^[i]; e^[i]:=c*e^[i]; goon:=abs(f) > eps;
+                if goon then
+                  begin
+                    g:=pq^[i]; h:=sqrt(f*f+g*g); pq^[i]:=h;
+                    c:=g/h; s:=-f/h;
+                    i:=i+1; goon:=i <= k
+                  end {goon}
+              end {while goon}
+          end; {cancel}
+        z:=pq^[k];
+        if k=l then conv:=true else
+          begin
+            x:=pq^[l]; y:=pq^[k-1]; g:=e^[k-1]; h:=e^[k];
+            f:=((y-z)*(y+z)+(g-h)*(g+h))/(2*h*y); g:=sqrt(f*f+1);
+            if f < 0 then s:=f-g else s:=f+g;
+            f:=((x-z)*(x+z)+h*(y/s-h))/x;
+            c:=1; s:=1;
+            for i:=l+1 to k do
+              begin
+                g:=e^[i]; y:=pq^[i]; h:=s*g; g:=c*g;
+                z:=sqrt(f*f+h*h); e^[i-1]:=z; c:=f/z; s:=h/z;
+                f:=x*c+g*s; g:=-x*s+g*c; h:=y*s; y:=y*c;
+                z:=sqrt(f*f+h*h); pq^[i-1]:=z; c:=f/z; s:=h/z;
+                f:=c*g+s*y; x:=-s*g+c*y
+              end; {i}
+            e^[l]:=0; e^[k]:=f; pq^[k]:=x
+          end {k <> l}
+      until conv;
+      if z < 0 then pq^[k]:=-z
+    end; {k}
+  for i:=1 to n do
+    begin
+      k:=i; p:=pq^[i];
+      for j:=i+1 to n do
+        if pq^[j] < p then
+          begin
+            k:=j; p:=pq^[j]
+          end;
+        if k <> i then
+          begin
+            pq^[k]:=pq^[i]; pq^[i]:=p
+          end
+    end; {i}
+  freemem(e, ns); freemem(u, m*ns)
+end; {eigsv1}
+
+procedure eigsv3(var a: ArbFloat; m, n, rwidtha: ArbInt; var sig, u: ArbFloat;
+                 rwidthu: ArbInt; var v: ArbFloat; rwidthv: ArbInt;
+                 var term: ArbInt);
+
+var                pa, pu, pq, pv, e : ^arfloat1;
+          i, j, k, l, ns, ii, jj, kk : ArbInt;
+ c, f, g, h, p, s, x, y, z, eps, tol : ArbFloat;
+                  conv, goon, cancel : boolean;
+begin
+  if (n<1) or (m<n)
+  then
+    begin
+      term:=3; exit
+    end;
+  pa:=@a; pu:=@u; pq:=@sig; pv:=@v; term:=1;
+  ns:=n*sizeof(ArbFloat); getmem(e, ns);
+  for i:=1 to m do move(pa^[(i-1)*rwidtha+1], pu^[(i-1)*rwidthu+1], ns);
+  g:=0; x:=0; tol:=midget/macheps;
+  for i:=1 to n do
+    begin
+      ii:=(i-1)*rwidthu;
+      e^[i]:=g; s:=0;
+      for j:=i to m do s:=s+sqr(pu^[(j-1)*rwidthu+i]);
+      if s<tol then g:=0 else
+        begin
+          f:=pu^[ii+i]; if f<0 then g:=sqrt(s) else g:=-sqrt(s);
+          h:=f*g-s; pu^[ii+i]:=f-g;
+          for j:=i+1 to n do
+            begin
+              s:=0;
+              for k:=i to m do
+                begin
+                  kk:=(k-1)*rwidthu; s:=s+pu^[kk+i]*pu^[kk+j]
+                end; {k}
+              f:=s/h;
+              for k:=i to m do
+                begin
+                  kk:=(k-1)*rwidthu; pu^[kk+j]:=pu^[kk+j]+f*pu^[kk+i]
+                end {k}
+            end {j}
+        end; {s}
+      pq^[i]:=g; s:=0; for j:=i+1 to n do s:=s+sqr(pu^[ii+j]);
+      if s < tol then g:=0 else
+        begin
+          f:=pu^[ii+i+1];
+          if f < 0 then g:=sqrt(s) else g:=-sqrt(s);
+          h:=f*g-s; pu^[ii+i+1]:=f-g;
+          for j:=i+1 to n do e^[j]:=pu^[ii+j]/h;
+          for j:=i+1 to m do
+            begin
+              s:=0; jj:=(j-1)*rwidthu;
+              for k:=i+1 to n do s:=s+pu^[jj+k]*pu^[ii+k];
+              for k:=i+1 to n do pu^[jj+k]:=pu^[jj+k]+s*e^[k]
+            end {j}
+        end; {s}
+      y:=abs(pq^[i])+abs(e^[i]); if y > x then x:=y
+    end; {i}
+  for i:=n downto 1 do
+    begin
+      ii:=(i-1)*rwidthu;
+      if g <> 0 then
+        begin
+          h:=pu^[ii+i+1]*g;
+          for j:=i+1 to n do pv^[(j-1)*rwidthv+i]:=pu^[ii+j]/h;
+          for j:=i+1 to n do
+            begin
+              s:=0;
+              for k:=i+1 to n do s:=s+pu^[ii+k]*pv^[(k-1)*rwidthv+j];
+              for k:=i+1 to n do
+                begin
+                  kk:=(k-1)*rwidthv; pv^[kk+j]:=pv^[kk+j]+s*pv^[kk+i]
+                end {k}
+            end {j}
+        end; {g}
+      ii:=(i-1)*rwidthv;
+      for j:=i+1 to n do
+        begin
+          pv^[ii+j]:=0; pv^[(j-1)*rwidthv+i]:=0
+        end; {j}
+      pv^[ii+i]:=1; g:=e^[i]
+    end; {i}
+  for i:=n downto 1 do
+    begin
+      g:=pq^[i]; ii:=(i-1)*rwidthu;
+      for j:=i+1 to n do pu^[ii+j]:=0;
+      if g <> 0 then
+        begin
+          h:=pu^[ii+i]*g;
+          for j:=i+1 to n do
+            begin
+              s:=0;
+              for k:=i+1 to m do
+                begin
+                  kk:=(k-1)*rwidthu; s:=s+pu^[kk+i]*pu^[kk+j]
+                end; {k}
+              f:=s/h;
+              for k:=i to m do
+                begin
+                  kk:=(k-1)*rwidthu;
+                  pu^[kk+j]:=pu^[kk+j]+f*pu^[kk+i]
+                end {k}
+            end; {j}
+          for j:=i to m do
+            begin
+              jj:=(j-1)*rwidthu+i; pu^[jj]:=pu^[jj]/g
+            end {j}
+        end {g}
+      else
+        for j:=i to m do pu^[(j-1)*rwidthu+i]:=0;
+      pu^[ii+i]:=pu^[ii+i]+1
+    end; {i}
+  eps:=macheps*x;
+  for k:=n downto 1 do
+    begin
+      conv:=false;
+      repeat
+        l:=k; goon:=true;
+        while goon do
+          begin
+            if abs(e^[l]) <= eps then
+              begin
+                goon:=false; cancel:=false
+              end else
+            if abs(pq^[l-1]) <= eps then
+              begin
+                goon:=false; cancel:=true
+              end else l:=l-1
+          end; {goon}
+        if cancel then
+          begin
+            c:=0; s:=1; i:=l; goon:=true;
+            while goon do
+              begin
+                f:=s*e^[i]; e^[i]:=c*e^[i]; goon:=abs(f) > eps;
+                if goon then
+                  begin
+                    g:=pq^[i]; h:=sqrt(f*f+g*g); pq^[i]:=h;
+                    c:=g/h; s:=-f/h;
+                    for j:=1 to m do
+                      begin
+                        jj:=(j-1)*rwidthu; y:=pu^[jj+l-1]; z:=pu^[jj+i];
+                        pu^[jj+l-1]:=y*c+z*s; pu^[jj+i]:=-y*s+z*c
+                      end; {j}
+                    i:=i+1; goon:=i <= k
+                  end {goon}
+              end {while goon}
+          end; {cancel}
+        z:=pq^[k]; if k=l then conv:=true else
+          begin
+            x:=pq^[l]; y:=pq^[k-1]; g:=e^[k-1]; h:=e^[k];
+            f:=((y-z)*(y+z)+(g-h)*(g+h))/(2*h*y); g:=sqrt(f*f+1);
+            if f < 0 then s:=f-g else s:=f+g;
+            f:=((x-z)*(x+z)+h*(y/s-h))/x;
+            c:=1; s:=1;
+            for i:=l+1 to k do
+              begin
+                g:=e^[i]; y:=pq^[i]; h:=s*g; g:=c*g;
+                z:=sqrt(f*f+h*h); e^[i-1]:=z; c:=f/z; s:=h/z;
+                f:=x*c+g*s; g:=-x*s+g*c; h:=y*s; y:=y*c;
+                for j:=1 to n do
+                  begin
+                    jj:=(j-1)*rwidthv;
+                    x:=pv^[jj+i-1]; z:=pv^[jj+i];
+                    pv^[jj+i-1]:=x*c+z*s; pv^[jj+i]:=-x*s+z*c
+                  end; {j}
+                z:=sqrt(f*f+h*h); pq^[i-1]:=z; c:=f/z; s:=h/z;
+                f:=c*g+s*y; x:=-s*g+c*y;
+                for j:=1 to m do
+                  begin
+                    jj:=(j-1)*rwidthu;
+                    y:=pu^[jj+i-1]; z:=pu^[jj+i];
+                    pu^[jj+i-1]:=y*c+z*s; pu^[jj+i]:=-y*s+z*c
+                  end {j}
+              end; {i}
+            e^[l]:=0; e^[k]:=f; pq^[k]:=x
+          end {k <> l}
+      until conv;
+      if z < 0 then
+        begin
+          pq^[k]:=-z;
+          for j:=1 to n do
+            begin
+              jj:=(j-1)*rwidthv+k; pv^[jj]:=-pv^[jj]
+            end {j}
+        end {z}
+    end; {k}
+  for i:=1 to n do
+    begin
+      k:=i; p:=pq^[i];
+      for j:=i+1 to n do
+        if pq^[j] < p then
+          begin
+            k:=j; p:=pq^[j]
+          end;
+        if k <> i then
+          begin
+            pq^[k]:=pq^[i]; pq^[i]:=p;
+            for j:=1 to m do
+              begin
+                jj:=(j-1)*rwidthu;
+                p:=pu^[jj+i]; pu^[jj+i]:=pu^[jj+k]; pu^[jj+k]:=p;
+              end;
+            for j:=1 to n do
+              begin
+                jj:=(j-1)*rwidthv;
+                p:=pv^[jj+i]; pv^[jj+i]:=pv^[jj+k]; pv^[jj+k]:=p
+              end { interchange in u and v column i with comlumn k }
+          end
+    end; {i}
+  freemem(e, ns)
+end; {eigsv3}
+end.
+
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/eigh1.pas

@@ -0,0 +1,932 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             Documentation by Michael van Canneyt ([email protected])
+
+    This is a helper unit for the unit eig. The functions aren't documented,
+    so if you find out what it does, please mail it to us.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit eigh1;
+{$I DIRECT.INC}
+
+interface
+
+uses typ;
+
+procedure tred1(var a: ArbFloat; n, rwidth: ArbInt; var d, cd: ArbFloat;
+                var term: ArbInt);
+procedure tred2(var a: ArbFloat; n, rwidtha: ArbInt; var d, cd, x: ArbFloat;
+                  rwidthx: ArbInt; var term: ArbInt);
+procedure tql1(var d, cd: ArbFloat; n: ArbInt;
+               var lam: ArbFloat; var term: ArbInt);
+procedure tql2(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;
+               rwidth: ArbInt; var term: ArbInt);
+procedure bisect(var d, cd: ArbFloat; n, k1, k2: ArbInt; eps: ArbFloat;
+                 var lam: ArbFloat; var term: ArbInt);
+procedure trbak1(var a: ArbFloat; n, rwidtha: ArbInt; var cd: ArbFloat;
+                 k1, k2: ArbInt; var x: ArbFloat; rwidthx: ArbInt);
+procedure trsturm1(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;
+                   var x: ArbFloat; rwidth: ArbInt; var m2, term: ArbInt);
+procedure transf(var a: ArbFloat; n, l: ArbInt; var b: ArbFloat; rwidthb: ArbInt);
+procedure bandrd1(var a: ArbFloat; n, m, rwidth: ArbInt; var d, cd: ArbFloat);
+procedure bandrd2(var a: ArbFloat; n, m, rwidtha: ArbInt; var d, cd, x: ArbFloat;
+                  rwidthx: ArbInt);
+procedure bandev(var a: ArbFloat; n, m, rwidth: ArbInt; lambda: ArbFloat;
+                 var v: ArbFloat; var term: ArbInt);
+
+implementation
+
+procedure tred1(var a: ArbFloat; n, rwidth: ArbInt; var d, cd: ArbFloat;
+                var term: ArbInt);
+
+var  i, ii, jj, j, k, l, sr : ArbInt;
+               f, g, h, tol : ArbFloat;
+             pa, pd, pcd : ^arfloat1;
+begin
+  if n<1 then
+  begin
+      term:=3; exit
+  end; {wrong input}
+  pa:=@a; pd:=@d; pcd:=@cd;
+  sr:=sizeof(ArbFloat);
+  tol:=midget/macheps;
+  for i:=1 to n do pd^[i]:=pa^[(i-1)*rwidth+i];
+  for i:=n downto 1 do
+  begin
+      ii:=(i-1)*rwidth; l:=i-2; h:=0;
+      if i=1 then f:=0 else f:=pa^[ii+i-1];
+      for k:=1 to l do h:=h+sqr(pa^[ii+k]);
+      if h <= tol then
+        begin
+          pcd^[i]:=f;
+          for j:=1 to i-1 do pa^[ii+j]:=0;
+        end else
+        begin
+          h:=h+f*f; l:=l+1;
+          if f<0 then g:=sqrt(h) else g:=-sqrt(h);
+          pcd^[i]:=g;
+          h:=h-f*g; pa^[ii+i-1]:=f-g; f:=0;
+          for j:=1 to l do
+            begin
+              g:=0;
+              for k:=1 to j do g:=g+pa^[(j-1)*rwidth+k]*pa^[ii+k];
+              for k:=j+1 to l do g:=g+pa^[(k-1)*rwidth+j]*pa^[ii+k];
+              g:=g/h; pcd^[j]:=g; f:=f+g*pa^[ii+j]
+            end; {j}
+          h:=f/(h+h);
+          for j:=1 to l do
+            begin
+              jj:=(j-1)*rwidth;
+              f:=pa^[ii+j]; pcd^[j]:=pcd^[j]-h*f; g:=pcd^[j];
+              for k:=1 to j do pa^[jj+k]:=pa^[jj+k]-f*pcd^[k]-g*pa^[ii+k]
+            end {j}
+        end;  {h > tol}
+      h:=pd^[i]; pd^[i]:=pa^[ii+i]; pa^[ii+i]:=h
+    end; {i}
+  term:=1
+end; {tred1}
+
+procedure tred2(var a: ArbFloat; n, rwidtha: ArbInt; var d, cd, x: ArbFloat;
+                  rwidthx: ArbInt; var term: ArbInt);
+
+var i, j, k, l, ii, jj, kk : ArbInt;
+         f , g, h, hh, tol : ArbFloat;
+           pa, pd, pcd, px : ^arfloat1;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end;
+  tol:=midget/macheps;
+  pa:=@a; pd:=@d; pcd:=@cd; px:=@x;
+  for i:=1 to n do
+    move(pa^[1+(i-1)*rwidtha], px^[1+(i-1)*rwidthx], i*sizeof(ArbFloat));
+  for i:=n downto 2 do
+    begin
+      l:=i-2; ii:=(i-1)*rwidthx; f:=px^[i-1+ii];
+      g:=0; for k:=1 to l do g:=g+sqr(px^[k+ii]);
+      h:=g+f*f;
+      if g<=tol then
+        begin
+          pcd^[i]:=f; pd^[i]:=0
+        end else
+        begin
+          l:=l+1; if f<0 then g:=sqrt(h) else g:=-sqrt(h);
+          pcd^[i]:=g;
+          h:=h-f*g; px^[i-1+ii]:=f-g; f:=0;
+          for j:=1 to l do
+            begin
+              jj:=(j-1)*rwidthx; px^[i+jj]:=px^[j+ii]/h;
+              g:=0; for k:=1 to j do g:=g+px^[k+jj]*px^[k+ii];
+              for k:=j+1 to l do g:=g+px^[j+(k-1)*rwidthx]*px^[k+ii];
+              pcd^[j]:=g/h; f:=f+g*px^[i+jj]
+            end;
+          hh:=f/(h+h);
+          for j:=1 to l do
+            begin
+              jj:=(j-1)*rwidthx; f:=px^[j+ii];
+              pcd^[j]:=pcd^[j]-hh*f; g:=pcd^[j];
+              for k:=1 to j do px^[k+jj]:=px^[k+jj]-f*pcd^[k]-g*px^[k+ii]
+             end;
+          pd^[i]:=h
+        end
+    end;
+  pd^[1]:=0; pcd^[1]:=0;
+  for i:=1 to n do
+    begin
+      ii:=(i-1)*rwidthx; l:=i-1;
+      if pd^[i] <> 0 then
+        for j:=1 to l do
+          begin
+            g:=0; for k:=1 to l do g:=g+px^[k+ii]*px^[j+(k-1)*rwidthx];
+             for k:=1 to l do
+               begin
+                 kk:=(k-1)*rwidthx; px^[j+kk]:=px^[j+kk]-g*px^[i+kk]
+               end
+          end;
+      pd^[i]:=px^[i+ii]; px^[i+ii]:=1;
+      for j:=1 to l do
+        begin
+          px^[j+ii]:=0; px^[i+(j-1)*rwidthx]:=0
+        end
+    end;
+  term:=1;
+end {tred2};
+
+procedure tql1(var d, cd: ArbFloat; n: ArbInt;
+               var lam: ArbFloat; var term: ArbInt);
+
+var                  i, j, l, m : ArbInt;
+   meps, b, c, f, g, h, p, r, s : ArbFloat;
+                    conv, shift : boolean;
+                  pd, pcd, plam : ^arfloat1;
+
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pd:=@d; pcd:=@cd; plam:=@lam;
+  conv:=true; meps:=macheps;
+  for i:=2 to n do pcd^[i-1]:=pcd^[i];
+  pcd^[n]:=0; f:=0; b:=0; l:=0;
+  while (l<n) and conv do
+    begin
+      l:=l+1; j:=0; h:=meps*(abs(pd^[l])+abs(pcd^[l]));
+      if b<h then b:=h;
+      m:=l-1; repeat m:=m+1 until abs(pcd^[m]) <= b;
+      while (abs(pcd^[l])>b) and conv do
+        begin
+          g:=pd^[l]; p:=(pd^[l+1]-g)/(2*pcd^[l]);
+          if abs(p)>1 then r:=abs(p)*sqrt(1+sqr(1/p)) else r:=sqrt(sqr(p)+1);
+          if p<0 then pd^[l]:=pcd^[l]/(p-r) else pd^[l]:=pcd^[l]/(p+r);
+          h:=g-pd^[l];
+          for i:=l+1 to n do pd^[i]:=pd^[i]-h;
+          f:=f+h; p:=pd^[m]; c:=1; s:=0;
+          for i:=m-1 downto l do
+            begin
+              g:=c*pcd^[i]; h:=c*p;
+              if abs(p) >= abs(pcd^[i]) then
+                begin
+                  c:=pcd^[i]/p; r:=sqrt(c*c+1);
+                  pcd^[i+1]:=s*p*r; s:=c/r; c:=1/r
+                end
+              else
+                begin
+                  c:=p/pcd^[i]; r:=sqrt(c*c+1);
+                  pcd^[i+1]:=s*pcd^[i]*r; s:=1/r; c:=c/r
+                end;
+              p:=c*pd^[i]-s*g; pd^[i+1]:=h+s*(c*g+s*pd^[i])
+            end; {i}
+          pcd^[l]:=s*p; pd^[l]:=c*p; j:=j+1; conv:=j <= 30
+        end; {while}
+      if conv then
+        begin
+          p:=pd^[l]+f; i:=l; shift:=true;
+          while shift and (i>1) do
+            begin
+              if p>=plam^[i-1] then shift:= false else plam^[i]:=plam^[i-1];
+              i:=i-1
+            end; {while}
+          if not shift then plam^[i+1]:=p else plam^[i]:=p
+        end  {if conv}
+    end; {l}
+  if conv then term:=1 else term:=2
+end; {tql1}
+
+procedure tql2(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;
+               rwidth: ArbInt; var term: ArbInt);
+var i, j, k, l, m, kk, ki, ki1, jj, ji, jk, sr, ns, n1s : ArbInt;
+                                                   conv : boolean;
+                           meps, b, c, f, g, h, p, r, s : ArbFloat;
+                            pd, pcd, plam, px, c1d, ccd : ^arfloat1;
+begin
+  if n<1 then
+    begin
+      term:=3; exit
+    end;
+  sr:=sizeof(ArbFloat); ns:=n*sizeof(ArbFloat); n1s:=ns-sr;
+  getmem(c1d, ns); getmem(ccd, ns);
+  pd:=@d; pcd:=@cd; plam:=@lam; px:=@x;
+  move(pcd^[2], ccd^[1], n1s); ccd^[n]:=0; move(pd^[1], c1d^[1], ns);
+  conv:= true; meps:=macheps; f:=0; b:=0; l:=0;
+  while (l<n) and conv do
+    begin
+      l:=l+1; j:=0; h:=meps*(abs(c1d^[l])+abs(ccd^[l]));
+      if b<h then b:=h;
+      m:=l; while abs(ccd^[m])>b do m:=m+1;
+      while (abs(ccd^[l])>b) and conv do
+        begin
+          g:=c1d^[l]; p:=(c1d^[l+1]-g)/(2*ccd^[l]);
+          if abs(p)>1
+          then r:=abs(p)*sqrt(1+sqr(1/p)) else r:=sqrt(sqr(p)+1);
+          if p<0 then c1d^[l]:=ccd^[l]/(p-r) else c1d^[l]:=ccd^[l]/(p+r);
+          h:=g-c1d^[l];
+          for i:=l+1 to n do c1d^[i]:=c1d^[i]-h;
+          f:=f+h; p:=c1d^[m]; c:=1; s:=0;
+          for i:=m-1 downto l do
+            begin
+              g:=c*ccd^[i]; h:=c*p;
+              if abs(p)>=abs(ccd^[i]) then
+                 begin
+                   c:=ccd^[i]/p; r:=sqrt(c*c+1);
+                   ccd^[i+1]:=s*p*r; s:=c/r; c:=1/r
+                 end else
+                begin
+                  c:=p/ccd^[i]; r:=sqrt(c*c+1);
+                  ccd^[i+1]:=s*ccd^[i]*r; s:=1/r; c:=c/r
+                end;
+                p:=c*c1d^[i]-s*g; c1d^[i+1]:=h+s*(c*g+s*c1d^[i]);
+                for k:=1 to n do
+                  begin
+                    kk:=(k-1)*rwidth; ki:=i+kk; ki1:=ki+1;
+                    h:=px^[ki1]; px^[ki1]:=s*px^[ki]+c*h;
+                    px^[ki]:=c*px^[ki]-s*h
+                  end
+              end;
+            ccd^[l]:=s*p; c1d^[l]:=c*p; j:=j+1; conv:=j<=30
+        end;
+      if conv
+      then
+        plam^[l]:=c1d^[l]+f
+    end;
+  if conv then
+    for i:=1 to n do
+      begin
+        k:=i; p:=plam^[i];
+        for j:=i+1 to n do
+          if plam^[j]<p then
+            begin
+              k:=j; p:=plam^[j]
+            end;
+          if k <> i then
+            begin
+              plam^[k]:=plam^[i]; plam^[i]:=p;
+              for j:=1 to n do
+                begin
+                  jj:=(j-1)*rwidth; ji:=i+jj; jk:=k+jj;
+                  p:=px^[ji]; px^[ji]:=px^[jk]; px^[jk]:=p
+                end
+            end
+      end;
+  if conv then term:=1 else term:=2;
+  freemem(c1d, ns); freemem(ccd, ns)
+end; {tql2}
+
+procedure bisect(var d, cd: ArbFloat; n, k1, k2: ArbInt; eps: ArbFloat;
+                 var lam: ArbFloat; var term: ArbInt);
+
+var                  a, i, k, sr : ArbInt;
+    pd, pcd, plam, codsq, xlower : ^arfloat1;
+      meps, eps1, q, xmin, xmax,
+       xl, xu, lambdak, h, diagi : ArbFloat;
+
+begin
+  if (n<1) or (k1<1) or (k2<k1) or (k2>n) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  term:=1;
+  pd:=@d; pcd:=@cd; plam:=@lam;
+  sr:=sizeof(ArbFloat);
+  getmem(codsq, n*sr); getmem(xlower, n*sr);
+  meps:=macheps;
+  for i:=2 to n do codsq^[i]:=sqr(pcd^[i]);
+  xmin:=pd^[n]; xmax:=xmin;
+  if n > 1 then
+    begin
+      h:=abs(pcd^[n]); xmin:=xmin-h; xmax:=xmax+h
+    end ;
+  for i:=n-1 downto 1 do
+    begin
+      h:=abs(pcd^[i+1]);
+      if i<>1 then h:=h+abs(pcd^[i]);
+      diagi:=pd^[i];
+      if diagi-h<xmin then xmin:=diagi-h;
+      if diagi+h>xmax then xmax:=diagi+h
+    end; {i}
+  if xmin+xmax>0 then eps1:=meps*xmax
+  else eps1:=-meps*xmin;
+  if eps <= 0 then eps:=eps1;
+  for i:=k1 to k2 do
+    begin
+      plam^[i-k1+1]:=xmax; xlower^[i]:=xmin
+    end;
+  xu:=xmax;
+  for k:=k2 downto k1 do
+    begin
+      if xu>plam^[k-k1+1] then xu:=plam^[k-k1+1];
+      i:=k; repeat xl:=xlower^[i]; i:=i-1 until (i<k1) or (xl>xmin);
+      while xu-xl>2*meps*(abs(xl)+abs(xu))+eps do
+        begin
+          lambdak:=xl+(xu-xl)/2; q:=pd^[1]-lambdak;
+          if q<0 then a:=1 else a:=0;
+          for i:=2 to n do
+            begin
+              if q=0 then q:=meps;
+              q:=pd^[i]-lambdak-codsq^[i]/q;
+              if q<0 then a:=a+1
+            end; {i}
+          if a<k then
+            begin
+              if a<k1 then
+                begin
+                  xl:=lambdak; xlower^[k]:=lambdak
+                end else
+                begin
+                  xl:=lambdak; xlower^[a+1]:=lambdak;
+                  if plam^[a-k1+1]>lambdak then plam^[a-k1+1]:=lambdak
+                end
+            end else xu:=lambdak
+        end; {while}
+      plam^[k-k1+1]:=xl+(xu-xl)/2
+    end;  {k}
+  freemem(codsq, n*sr); freemem(xlower, n*sr)
+end; {bisect}
+
+procedure trbak1(var a: ArbFloat; n, rwidtha: ArbInt; var cd: ArbFloat;
+                 k1, k2: ArbInt; var x: ArbFloat; rwidthx: ArbInt);
+
+var  i, j, k, l, ii, ind : ArbInt;
+                    h, s : ArbFloat;
+             pa, px, pcd : ^arfloat1;
+begin
+  pa:=@a; px:=@x; pcd:=@cd;
+  for i:=3 to n do
+    begin
+      ii:=(i-1)*rwidtha;
+      l:=i-1; h:=pcd^[i]*pa^[ii+i-1];
+      if h <> 0 then
+      for j:=1 to k2-k1+1 do
+        begin
+          s:=0; for k:=1 to l do s:=s+pa^[ii+k]*px^[(k-1)*rwidthx+j]; s:=s/h;
+          for k:=1 to l do
+            begin
+              ind:=(k-1)*rwidthx+j; px^[ind]:=px^[ind]+s*pa^[ii+k]
+            end; {k}
+        end  {j}
+    end  {i}
+end;  {trbak1}
+
+procedure trsturm1(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;
+                   var x: ArbFloat; rwidth: ArbInt; var m2, term: ArbInt);
+
+var
+                     ns, nb, a, i, k, s, its, group, j : ArbInt;
+                                      continu, nonfail : boolean;
+       eps1, eps2, eps3, eps4, q,  xmin, xmax, xl, xu,
+  x1, x0, u, v, norm, meps, lambdak, h, diagi, codiagi : ArbFloat;
+      codsq, d1, e, f, y, z, xlower, pd, pcd, plam, px : ^arfloat1;
+                                                   int : ^arbool1;
+begin
+  if (n<1) or (k1<1) or (k1>k2) or (k2>n) then
+    begin
+      term:=3; exit
+    end; {wrong input}
+  pd:=@d; pcd:=@cd; plam:=@lam; px:=@x;
+  ns:=n*sizeof(ArbFloat); nb:=n*sizeof(boolean);
+  getmem(codsq, ns); getmem(d1, ns); getmem(e, ns); getmem(f, ns);
+  getmem(y, ns); getmem(z, ns); getmem(xlower, ns); getmem(int, nb);
+  meps:=macheps;
+  norm:=abs(pd^[1]);
+  for i:=2 to n do norm:=norm+abs(pd^[i])+abs(pcd^[i]);
+  if norm=0 then
+    begin
+  { matrix is nulmatrix: eigenwaarden zijn alle 0 en aan de
+    eigenvectoren worden de eenheidsvectoren e(k1) t/m e(k2) toegekend }
+      for k:=k1 to k2 do plam^[k-k1+1]:=0;
+      for i:=1 to n do
+        fillchar(px^[(i-1)*rwidth+1], (k2-k1+1)*sizeof(ArbFloat), 0);
+      for k:=k1 to k2 do px^[(k-1)*rwidth+k-k1+1]:=1;
+      m2:=k2; term:=1;
+      freemem(codsq, ns); freemem(d1, ns); freemem(e, ns); freemem(f, ns);
+      freemem(y, ns); freemem(z, ns); freemem(xlower, ns); freemem(int, nb);
+      exit
+    end; {norm=0}
+  for i:=2 to n do codsq^[i]:=sqr(pcd^[i]);
+  xmin:=pd^[n]; xmax:=xmin;
+  if n>1 then
+    begin
+      h:=abs(pcd^[n]); xmin:=xmin-h; xmax:=xmax+h
+    end;
+  for i:=n-1 downto 1 do
+    begin
+      diagi:=pd^[i];
+      h:=abs(pcd^[i+1]);
+      if i<>1 then h:=h+abs(pcd^[i]);
+      if diagi-h<xmin then xmin:=diagi-h;
+      if diagi+h>xmax then xmax:=diagi+h;
+    end; {i}
+  if xmax+xmin>0 then eps1:=meps*xmax else eps1:=-meps*xmin;
+  for i:=k1 to k2 do
+    begin
+      plam^[i-k1+1]:=xmax; xlower^[i]:=xmin
+    end;
+  xu:=xmax;
+  for k:=k2 downto k1 do
+    begin
+      if xu>plam^[k-k1+1] then xu:=plam^[k-k1+1];
+      i:=k; repeat xl:=xlower^[i]; i:=i-1 until (i<k1) or (xl>xmin);
+      while xu-xl>2*eps1 do
+        begin
+          lambdak:=xl+(xu-xl)/2; q:=pd^[1]-lambdak;
+          if q<0 then a:=1 else a:=0;
+          for i:=2 to n do
+            begin
+              if q=0 then q:=meps;
+              q:=pd^[i]-lambdak-codsq^[i]/q;
+              if q<0 then a:=a+1;
+            end; {i}
+          if a<k then
+            begin
+              if a<k1 then
+                begin
+                  xl:=lambdak; xlower^[k]:=lambdak
+                end else
+                begin
+                  xlower^[a+1]:=lambdak; xl:=lambdak;
+                  if plam^[a-k1+1]>lambdak then plam^[a-k1+1]:=lambdak
+                end
+            end else xu:=lambdak
+        end;  {while}
+      plam^[k-k1+1]:=xl+(xu-xl)/2;
+    end; {k}
+  eps2:=norm*1e-3; eps3:=meps*norm; eps4:=eps3*n;
+  group:=0; s:=1; k:=k1; nonfail:=true; m2:=k1-1;
+  while (k <= k2) and nonfail do
+    begin
+      x1:=plam^[k-k1+1];
+      if k <> k1 then
+        begin
+          if x1-x0<eps2 then group:=group+1 else group:=0;
+          if x1 <= x0 then x1:=x0+eps3
+        end; {k <> k1}
+      u:=eps4/sqrt(n);
+      for i:=1 to n do z^[i]:=u;
+      u:=pd^[1]-x1;
+      if n=1 then v:=0 else v:=pcd^[2];
+      for i:=2 to n do
+        begin
+          if pcd^[i]=0 then codiagi:=eps3 else codiagi:=pcd^[i];
+          if abs(codiagi) >= abs(u) then
+            begin
+              xu:=u/codiagi; y^[i]:=xu; d1^[i-1]:=codiagi;
+              e^[i-1]:=pd^[i]-x1;
+              if i=n then f^[i-1]:=0 else f^[i-1]:=pcd^[i+1];
+              u:=v-xu*e^[i-1]; v:=-xu*f^[i-1];
+              int^[i]:=true
+            end else
+            begin
+              xu:=codiagi/u; y^[i]:=xu; d1^[i-1]:=u; e^[i-1]:=v;
+              f^[i-1]:=0; u:=pd^[i]-x1-xu*v;
+              if i<n then v:=pcd^[i+1];
+              int^[i]:=false
+            end
+        end;  {i}
+      if u=0 then d1^[n]:=eps3 else d1^[n]:=u;
+      e^[n]:=0; f^[n]:=0;
+      its:=1; continu:=true;
+      while continu and nonfail do
+        begin
+          for i:=n downto 1 do
+            begin
+              z^[i]:=(z^[i]-u*e^[i]-v*f^[i])/d1^[i]; v:=u; u:=z^[i]
+            end;
+          for j:=m2-group+1 to m2 do
+            begin
+              xu:=0;
+              for i:=1 to n do xu:=xu+z^[i]*px^[(i-1)*rwidth+j-k1+1];
+              for i:=1 to n do z^[i]:=z^[i]-xu*px^[(i-1)*rwidth+j-k1+1]
+            end; {j}
+          norm:=0; for i:=1 to n do norm:=norm+abs(z^[i]);
+          if norm<1 then
+            begin
+              if norm=0 then
+                begin
+                  z^[s]:=eps4;
+                  if s<n then s:=s+1 else s:=1
+                end else
+                begin
+                  xu:=eps4/norm;
+                  for i:=1 to n do z^[i]:=z^[i]*xu
+                end;
+              for i:=2 to n do
+                if int^[i] then
+                  begin
+                    u:=z^[i-1]; z^[i-1]:=z^[i]; z^[i]:=u-y^[i]*z^[i]
+                  end else z^[i]:=z^[i]-y^[i]*z^[i-1];
+              its:=its+1; if its=5 then nonfail:=false;
+            end {norm < 1}
+          else continu:=false
+        end; {while continu ^ nonfail}
+      if nonfail then
+        begin
+          u:=0; for i:=1 to n do u:=u+sqr(z^[i]);
+          xu:=1/sqrt(u); m2:=m2+1;
+          for i:=1 to n do px^[(i-1)*rwidth+m2-k1+1]:=z^[i]*xu;
+          x0:=x1; k:=k+1;
+        end
+    end;  {k}
+  if m2=k2 then term:=1 else term:=2;
+  freemem(codsq, ns); freemem(d1, ns); freemem(e, ns); freemem(f, ns);
+  freemem(y, ns); freemem(z, ns); freemem(xlower, ns); freemem(int, nb);
+end  {trsturm1};
+
+procedure transf(var a: ArbFloat; n, l: ArbInt; var b: ArbFloat; rwidthb: ArbInt);
+
+{ a bevat de linksonder bandelementen van een symmetrische matrix A met
+ lengte n en bandbreedte l, rijsgewijs aaneengesloten.
+ na afloop bevatten de kolommen van b de diagonalen van A, met dien
+ vestande dat de hoofddiagonaal van A in de eerste kolom van b staat,
+ de een na langste codiagonaal in de tweede kolom
+ (behalve de onderste plaats) enzovoort.
+ De niet opgevulde plaatsen komen in b dus rechtsonder te staan. }
+
+var             pa, pb: ^arfloat1;
+     ii, jj, i, j, rwa: ArbInt;
+begin
+  pa:=@a; pb:=@b;
+  ii:=1; jj:=0;
+  for i:=1 to n do
+  begin
+    if i>l then rwa:=l+1 else rwa:=i;
+    if i>l+1 then jj:=jj+rwidthb else jj:=jj+1;
+    for j:=1 to rwa do pb^[jj+(j-1)*(rwidthb-1)]:=pa^[ii+j-1];
+    ii:=ii+rwa;
+  end
+end;
+
+procedure banddek(n, m1, m2: ArbInt; var au, l: ArbFloat; var p: ArbInt);
+var                      pa, pl, norm: ^arfloat1;
+                                   pp: ^arint1;
+    i, j, ll, ii, k, t, pk, ind, ind1: ArbInt;
+                   piv, c, x, maxnorm: ArbFloat;
+begin
+   pa:=@au; pl:=@l; pp:=@p;
+   getmem(norm, n*sizeof(ArbFloat));
+   t:=m1; ll:=m1+m2+1;
+   for i:=1 to m1 do
+   begin
+     ind:=(i-1)*ll;
+     for j:=m1+1-i to ll do pa^[ind+j-t]:=pa^[ind+j];
+     t:=t-1;
+     for j:=ll-t to ll do pa^[ind+j]:=0
+   end;
+   t:=1;
+   for i:=n downto n-m2+1 do
+   begin
+     ind:=(i-1)*ll;
+     for j:=t+m1+1 to ll do pa^[ind+j]:=0;
+     t:=t+1
+   end;
+   maxnorm:=0;
+   for k:=1 to n do
+   begin
+     c:=0; ind:=(k-1)*ll;
+     for j:=1 to ll do c:=c+abs(pa^[ind+j]);
+     if c>maxnorm then maxnorm:=c;
+     if c=0 then norm^[k]:=1 else norm^[k]:=c
+   end;
+   t:=m1;
+   for k:=1 to n do
+   begin
+     ind:=(k-1)*ll;
+     x:=abs(pa^[ind+1])/norm^[k]; pk:=k;
+     t:=t+1; if t>n then t:=n;
+     for i:=k+1 to t do
+     begin
+       c:=abs(pa^[(i-1)*ll+1])/norm^[i];
+       if c>x then
+       begin
+         x:=c; pk:=i
+       end
+     end;
+     ind1:=(pk-1)*ll;
+     pp^[k]:=pk;
+     if pk <> k then
+     begin
+       for j:=1 to ll do
+       begin
+         c:=pa^[ind+j]; pa^[ind+j]:=pa^[ind1+j]; pa^[ind1+j]:=c
+       end;
+       norm^[pk]:=norm^[k]
+     end;
+     piv:=pa^[ind+1];
+     if piv <> 0 then
+     begin
+       for i:=k+1 to t do
+       begin
+         ii:=(i-1)*ll;
+         c:=pa^[ii+1]/piv; pl^[(k-1)*m1+i-k]:=c;
+         for j:=2 to ll do pa^[ii+j-1]:=pa^[ii+j]-c*pa^[ind+j];
+         pa^[ii+ll]:=0
+       end
+     end else
+     begin
+       pa^[ind+1]:=macheps*maxnorm;
+       for i:=k+1 to t do
+       begin
+         ii:=(i-1)*ll;
+         pl^[(k-1)*m1+i-k]:=0;
+         for j:=2 to ll do pa^[ii+j-1]:=pa^[ii+j];
+         pa^[ii+ll]:=0
+       end {i}
+     end {piv=0}
+   end; {k}
+  freemem(norm, n*sizeof(ArbFloat))
+end; {banddek}
+
+procedure bandsol(n, m1, m2: ArbInt; var au, l: ArbFloat;
+                  var p: ArbInt; var b: ArbFloat);
+var          pa, pl, pb: ^arfloat1;
+                     pp: ^arint1;
+  ll, i, j, k, pk, t, w: ArbInt;
+                      x: ArbFloat;
+begin
+  pa:=@au; pl:=@l; pb:=@b; pp:=@p;
+  for k:=1 to n do
+  begin
+    pk:=pp^[k];
+    if pk <> k then
+    begin
+      x:=pb^[k]; pb^[k]:=pb^[pk]; pb^[pk]:=x
+    end;
+    t:=k+m1; if t>n then t:=n;
+    for i:=k+1 to t do pb^[i]:=pb^[i]-pl^[(k-1)*m1+i-k]*pb^[k]
+  end; {k}
+  t:=1; ll:=m1+m2+1;
+  for i:=n downto 1 do
+  begin
+    x:=pb^[i]; w:=i-1;
+    for j:=2 to t do x:=x-pa^[(i-1)*ll+j]*pb^[j+w];
+    pb^[i]:=x/pa^[(i-1)*ll+1];
+    if t<ll then t:=t+1
+  end {i}
+end; {bandsol}
+
+procedure bandrd1(var a: ArbFloat; n, m, rwidth: ArbInt; var d, cd: ArbFloat);
+
+{ wilkinson linear algebra ii/8 procedure bandrd; matv = false }
+
+var      j, k, l, r, maxr, maxl, ugl, ikr, jj, jj1, i, ll : ArbInt;
+                            b, c, s, s2, c2, cs, u, u1, g : ArbFloat;
+                                              pa, pd, pcd : ^arfloat1;
+begin
+  pa:=@a; pd:=@d; pcd:=@cd;
+  for k:=1 to n-2 do
+    begin
+      if n-k<m then maxr:=n-k else maxr:=m;
+      for r:=maxr downto 2 do
+        begin
+          ikr:=(k-1)*rwidth+r+1; g:=pa^[ikr]; j:=k+r;
+          while (g <> 0) and (j <= n) do
+            begin
+              if j=k+r then
+                begin
+                  b:=-pa^[ikr-1]/pa^[ikr]; ugl:=k
+                end else
+                begin
+                  b:=-pa^[(j-m-2)*rwidth+m+1]/g; ugl:=j-m
+                end;
+              s:=1/sqrt(1+b*b); c:=b*s; c2:=c*c; s2:=s*s; cs:=c*s;
+              jj:=(j-1)*rwidth+1; jj1:=jj-rwidth;
+              u:=c2*pa^[jj1]-2*cs*pa^[jj1+1]+s2*pa^[jj];
+              u1:=s2*pa^[jj1]+2*cs*pa^[jj1+1]+c2*pa^[jj];
+              pa^[jj1+1]:=cs*(pa^[jj1]-pa^[jj])+(c2-s2)*pa^[jj1+1];
+              pa^[jj1]:=u; pa^[jj]:=u1;
+              for l:=ugl to j-2 do
+                begin
+                  ll:=(l-1)*rwidth+j-l+1;
+                  u:=c*pa^[ll-1]-s*pa^[ll];
+                  pa^[ll]:=s*pa^[ll-1]+c*pa^[ll];
+                  pa^[ll-1]:=u;
+                end; {l}
+              if j <> k+r then
+                begin
+                  i:=(j-m-2)*rwidth+m+1; pa^[i]:=c*pa^[i]-s*g
+                end;
+              if n-j < m-1 then maxl:=n-j else maxl:=m-1;
+              for l:=1 to maxl do
+                begin
+                  u:=c*pa^[jj1+l+1]-s*pa^[jj+l];
+                  pa^[jj+l]:=s*pa^[jj1+l+1]+c*pa^[jj+l];
+                  pa^[jj1+l+1]:=u
+                end; {l}
+              if j+m <= n then
+                begin
+                  g:=-s*pa^[jj+m]; pa^[jj+m]:=c*pa^[jj+m]
+                end;
+              j:=j+m;
+            end {j}
+        end {r}
+    end; {k}
+  pd^[1]:=pa^[1]; pcd^[1]:=0;
+  for j:=2 to n do
+    begin
+      pd^[j]:=pa^[(j-1)*rwidth+1];
+      if m>0 then pcd^[j]:=pa^[(j-2)*rwidth+2] else pcd^[j]:=0
+    end {j}
+end; {bandrd1}
+
+procedure bandrd2(var a: ArbFloat; n, m, rwidtha: ArbInt; var d, cd, x: ArbFloat;
+                  rwidthx: ArbInt);
+
+{ wilkinson linear algebra ii/8 procedure bandrd; matv = true }
+
+var      j, k, l, r, maxr, maxl, ugl, ikr, jj, jj1, i, ll, ns : ArbInt;
+                                b, c, s, s2, c2, cs, u, u1, g : ArbFloat;
+                                              pa, pd, pcd, px : ^arfloat1;
+begin
+  pa:=@a; pd:=@d; pcd:=@cd; px:=@x; ns:=n*sizeof(ArbFloat);
+  for j:=1 to n do fillchar(px^[(j-1)*rwidthx+1], ns, 0);
+  for j:=1 to n do px^[(j-1)*rwidthx+j]:=1;
+  for k:=1 to n-2 do
+    begin
+      if n-k<m then maxr:=n-k else maxr:=m;
+      for r:=maxr downto 2 do
+        begin
+          ikr:=(k-1)*rwidtha+r+1; g:=pa^[ikr]; j:=k+r;
+          while (g <> 0) and (j <= n) do
+            begin
+              if j=k+r then
+                begin
+                  b:=-pa^[ikr-1]/pa^[ikr]; ugl:=k
+                end else
+                begin
+                  b:=-pa^[(j-m-2)*rwidtha+m+1]/g; ugl:=j-m
+                end;
+              s:=1/sqrt(1+b*b); c:=b*s; c2:=c*c; s2:=s*s; cs:=c*s;
+              jj:=(j-1)*rwidtha+1; jj1:=jj-rwidtha;
+              u:=c2*pa^[jj1]-2*cs*pa^[jj1+1]+s2*pa^[jj];
+              u1:=s2*pa^[jj1]+2*cs*pa^[jj1+1]+c2*pa^[jj];
+              pa^[jj1+1]:=cs*(pa^[jj1]-pa^[jj])+(c2-s2)*pa^[jj1+1];
+              pa^[jj1]:=u; pa^[jj]:=u1;
+              for l:=ugl to j-2 do
+                begin
+                  ll:=(l-1)*rwidtha+j-l+1; u:=c*pa^[ll-1]-s*pa^[ll];
+                  pa^[ll]:=s*pa^[ll-1]+c*pa^[ll]; pa^[ll-1]:=u;
+                end; {l}
+              if j <> k+r then
+                begin
+                  i:=(j-m-2)*rwidtha+m+1; pa^[i]:=c*pa^[i]-s*g
+                end;
+              if n-j < m-1 then maxl:=n-j else maxl:=m-1;
+              for l:=1 to maxl do
+                begin
+                  u:=c*pa^[jj1+l+1]-s*pa^[jj+l];
+                  pa^[jj+l]:=s*pa^[jj1+l+1]+c*pa^[jj+l];
+                  pa^[jj1+l+1]:=u
+                end; {l}
+              if j+m <= n then
+                begin
+                  g:=-s*pa^[jj+m]; pa^[jj+m]:=c*pa^[jj+m]
+                end;
+              for l:=1 to n do
+                begin
+                  ll:=(l-1)*rwidthx+j; u:=c*px^[ll-1]-s*px^[ll];
+                  px^[ll]:=s*px^[ll-1]+c*px^[ll]; px^[ll-1]:=u
+                end; {ll}
+              j:=j+m;
+            end {j}
+        end {r}
+    end; {k}
+  pd^[1]:=pa^[1]; pcd^[1]:=0;
+  for j:=2 to n do
+    begin
+      pd^[j]:=pa^[(j-1)*rwidtha+1];
+      if m>0 then pcd^[j]:=pa^[(j-2)*rwidtha+2] else pcd^[j]:=0
+    end {j}
+end; {bandrd2}
+
+procedure bandev(var a: ArbFloat; n, m, rwidth: ArbInt; lambda: ArbFloat;
+                 var v: ArbFloat; var term: ArbInt);
+
+var                              pa, pv, au, l, u : ^arfloat1;
+                                                p : ^arint1;
+          ind, ii, i, k, t, j, its, w, sr, ns, ll : ArbInt;
+    meps, eps, s, norm, lambdak, x, y, r1, d1, ca : ArbFloat;
+begin
+  pa:=@a; pv:=@v;
+  sr:=sizeof(ArbFloat); ns:=n*sr; ll:=2*m+1;
+  getmem(au, ll*ns); getmem(l, m*ns); getmem(u, ns);
+  getmem(p, n*sizeof(ArbInt));
+  norm:=0; meps:=macheps;
+  for i:=1 to n do
+    begin
+      s:=0; if i-m<1 then k:=i-1 else k:=m; ii:=(i-1)*rwidth;
+      if n-i<m then w:=n-i+1 else w:=m+1;
+      for j:=1 to w do s:=s+abs(pa^[ii+j]);
+      for j:=1 to k do s:=s+abs(pa^[(i-j-1)*rwidth+j+1]);
+      if s>norm then norm:=s
+    end; {norm}
+  eps:=norm*meps;
+  if eps<midget then
+    begin
+      pv^[1]:=1;
+      for j:=2 to n do pv^[j]:=0;
+      term:=1;
+      freemem(au, ll*ns); freemem(l, m*ns); freemem(u, ns);
+      freemem(p, n*sizeof(ArbInt));
+      exit
+    end; {eps<midget}
+  for i:=1 to n do
+    begin
+      if n-i<m then w:=n-i else w:=m;
+      ind:=(i-1)*ll; ii:=(i-1)*rwidth;
+      move(pa^[ii+2], au^[ind+m+2], w*sr);
+      fillchar(au^[ind+m+w+2], (m-w)*sr, 0);
+      if i-1<m then w:=i-1 else w:=m;
+      for j:=1 to w do au^[ind+m-j+1]:=pa^[(i-j-1)*rwidth+j+1];
+      fillchar(au^[ind+1], (m-w)*sr, 0);
+      au^[ind+m+1]:=pa^[ii+1]-lambda
+    end; {i}
+  banddek(n, m, m, au^[1], l^[1], p^[1]);
+  t:=-m;
+  for i:=n downto 1 do
+    begin
+      ind:=(i-1)*ll;
+      x:=1; w:=i+m;
+      for j:=1-m to t do x:=x-au^[ind+m+j+1]*pv^[j+w];
+      pv^[i]:=x/au^[ind+1];
+      if t<m then t:=t+1
+    end; {i}
+  x:=0;
+  for i:=1 to n do
+    if abs(pv^[i])>abs(x) then
+      begin
+        x:=pv^[i]; j:=i
+      end;
+  its:=0; x:=1/x;
+  for i:=1 to n do
+    begin
+      u^[i]:=x*pv^[i]; pv^[i]:=u^[i]
+    end; {i}
+  repeat
+    bandsol(n, m, m, au^[1], l^[1], p^[1], pv^[1]);
+    y:=1/pv^[j]; x:=0;
+    for i:=1 to n do
+      if abs(pv^[i])>abs(x) then
+        begin
+          x:=pv^[i]; j:=i
+        end; {i}
+    x:=1/x; d1:=0;
+    for i:=1 to n do
+      begin
+        r1:=abs((u^[i]-y*pv^[i])*x);
+        if r1>d1 then d1:=r1; u^[i]:=x*pv^[i]; pv^[i]:=u^[i]
+      end; {i}
+    its:=its+1
+  until (d1<=eps) or (its>5);
+  if d1<=eps then
+    begin
+      term:=1; x:=0; for i:=1 to n do x:=x+sqr(pv^[i]); x:=1/sqrt(x);
+      for i:=1 to n do pv^[i]:=pv^[i]*x;
+    end else term:=2;
+  freemem(au, ll*ns); freemem(l, m*ns); freemem(u, ns);
+  freemem(p, n*sizeof(ArbInt));
+end; {bandev}
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/eigh2.pas

@@ -0,0 +1,859 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             Documentation by Michael van Canneyt ([email protected])
+
+    This is a helper unit for the unit eig. These functions aren't documented,
+    so if you find out what it does, please mail it to us.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit eigh2;
+{$I DIRECT.INC}
+
+interface
+
+uses typ;
+
+procedure orthes(var a: ArbFloat; n, rwidth: ArbInt; var u: ArbFloat);
+procedure hessva(var h: ArbFloat; n, rwidth: ArbInt; var lam: complex;
+                 var term: ArbInt);
+procedure balance(var a: ArbFloat; n, rwidtha: ArbInt; var low, hi: ArbInt;
+                  var d: ArbFloat);
+procedure orttrans(var a: ArbFloat; n, rwidtha: ArbInt; var q: ArbFloat;
+                   rwidthq: ArbInt);
+procedure balback(var pd: ArbFloat; n, m1, m2, k1, k2: ArbInt; var pdx: ArbFloat;
+                  rwidth: ArbInt);
+procedure hessvec(var h: ArbFloat; n, rwidthh: ArbInt; var lam: complex;
+                  var v: ArbFloat; rwidthv: ArbInt; var term: ArbInt);
+procedure normeer(var lam: complex; n: ArbInt; var v: ArbFloat;
+                  rwidthv: ArbInt);
+procedure transx(var v: ArbFloat; n, rwidthv: ArbInt; var lam, x: complex;
+                 rwidthx: ArbInt);
+procedure reduc1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
+                 rwidthb: ArbInt; var term: ArbInt);
+procedure rebaka(var l: ArbFloat; n, rwidthl, k1, k2: ArbInt; var x: ArbFloat;
+                 rwidthx: ArbInt; var term: ArbInt);
+
+implementation
+
+procedure orthes(var a: ArbFloat; n, rwidth: ArbInt; var u: ArbFloat);
+var               pa, pu, d : ^arfloat1;
+    sig, sig2, h, f, g, tol : ArbFloat;
+                    k, i, j : ArbInt;
+begin
+  pa:=@a; pu:=@u; tol:=midget/macheps;
+  getmem(d, n*sizeof(ArbFloat));
+  for k:=1 to n-2 do
+    begin
+      sig2:=0;
+      for i:=k+2 to n do
+        begin
+          d^[i]:=pa^[(i-1)*rwidth+k]; f:=d^[i]; sig2:=sig2+sqr(f)
+        end; {i}
+      if sig2<tol then
+        begin
+          pu^[k]:=0; for i:=k+2 to n do pa^[(i-1)*rwidth+k]:=0
+        end else
+        begin
+          f:=pa^[k*rwidth+k]; sig2:=sig2+sqr(f);
+          if f<0 then sig:=sqrt(sig2) else sig:=-sqrt(sig2);
+          pa^[k*rwidth+k]:=sig;
+          h:=sig2-f*sig; d^[k+1]:=f-sig; pu^[k]:=d^[k+1];
+          for j:=k+1 to n do
+          begin
+            f:=0; for i:=k+1 to n do f:=f+d^[i]*pa^[(i-1)*rwidth+j]; f:=f/h;
+           for i:=k+1 to n do pa^[(i-1)*rwidth+j]:=pa^[(i-1)*rwidth+j]-f*d^[i]
+          end; {j}
+          for i:=1 to n do
+          begin
+            f:=0; for j:=k+1 to n do f:=f+d^[j]*pa^[(i-1)*rwidth+j]; f:=f/h;
+           for j:=k+1 to n do pa^[(i-1)*rwidth+j]:=pa^[(i-1)*rwidth+j]-f*d^[j]
+          end {i}
+        end
+    end;  {k}
+  freemem(d, n*sizeof(ArbFloat));
+end  {orthes};
+
+procedure hessva(var h: ArbFloat; n, rwidth: ArbInt; var lam: complex;
+                 var term: ArbInt);
+var   i, j, k, kk, k1, k2, k3, l, m, mr,
+                ik, nn, na, n1, n2, its : ArbInt;
+        meps, p, q, r, s, t, w, x, y, z : ArbFloat;
+                          test, notlast : boolean;
+                                     ph : ^arfloat1;
+                                   plam : ^arcomp1;
+begin
+  ph:=@h; plam:=@lam;
+  t:=0; term:=1; meps:=macheps; nn:=n;
+  while (nn >= 1) and (term=1) do
+    begin
+      n1:=(nn-1)*rwidth; na:=nn-1; n2:=(na-1)*rwidth;
+      its:=0;
+      repeat
+        l:=nn+1; test:=true;
+        while test and (l>2) do
+          begin
+            l:=l-1;
+            test:=abs(ph^[(l-1)*(rwidth+1)]) >
+                  meps*(abs(ph^[(l-2)*rwidth+l-1])+abs(ph^[(l-1)*rwidth+l]))
+          end;
+        if (l=2) and  test then l:=l-1;
+        if l<na then
+          begin
+            x:=ph^[n1+nn]; y:=ph^[n2+na]; w:=ph^[n1+na]*ph^[n2+nn];
+            if (its=10) or (its=20) then
+              begin
+                {form exceptional shift}
+                t:=t+x;
+                for i:=1 to nn do ph^[(i-1)*rwidth+i]:=ph^[(i-1)*rwidth+i]-x;
+                s:=abs(ph^[n1+na])+abs(ph^[n1+nn-2]);
+                y:=0.75*s; x:=y; w:=-0.4375*sqr(s);
+              end; {shift}
+            {look for two consecutive small sub-diag elmts}
+            m:=nn-1; test:= true ;
+            repeat
+              m:=m-1; mr:=m*rwidth;
+              z:=ph^[mr-rwidth+m]; r:=x-z; s:=y-z;
+              p:=(r*s-w)/ph^[mr+m]+ph^[mr-rwidth+m+1];
+              q:=ph^[mr+m+1]-z-r-s; r:=ph^[mr+rwidth+m+1];
+              s:=abs(p)+abs(q)+abs(r); p:=p/s; q:=q/s; r:=r/s;
+              if m <> l then
+                test:=abs(ph^[mr-rwidth+m-1])*(abs(q)+abs(r)) <=
+                      meps*abs(p)*(abs(ph^[mr-2*rwidth+m-1])+abs(z)+
+                                                    abs(ph^[mr+m+1]))
+            until (m=l) or test;
+            for i:=m+2 to nn do ph^[(i-1)*rwidth+i-2]:=0;
+            for i:=m+3 to nn do ph^[(i-1)*rwidth+i-3]:=0;
+            { double qp-step involving rows l to nn and columns m to nn}
+            for k:=m to na do
+              begin
+                notlast:=k <> na;
+                if k <> m then
+                  begin
+                    p:=ph^[(k-1)*(rwidth+1)]; q:=ph^[k*rwidth+k-1];
+                    if notlast then r:=ph^[(k+1)*rwidth+k-1] else r:=0;
+                    x:=abs(p)+abs(q)+abs(r);
+                    if x>0 then
+                      begin
+                        p:=p/x; q:=q/x; r:=r/x
+                      end
+                  end else x:=1;
+                if x>0 then
+                begin
+                  s:=sqrt(p*p+q*q+r*r); if p<0 then s:=-s;
+                  if k <> m then ph^[(k-1)*(rwidth+1)]:=-s*x else
+                  if l <> m then
+                    begin
+                      kk:=(k-1)*(rwidth+1); ph^[kk]:=-ph^[kk]
+                    end;
+                  p:=p+s; x:=p/s; y:=q/s; z:=r/s; q:=q/p; r:=r/p;
+                  { row moxification}
+                  for j:=k to nn do
+                    begin
+                      k1:=(k-1)*rwidth+j; k2:=k1+rwidth; k3:=k2+rwidth;
+                      p:=ph^[k1]+q*ph^[k2];
+                      if notlast then
+                        begin
+                          p:=p+r*ph^[k3]; ph^[k3]:=ph^[k3]-p*z;
+                        end;
+                      ph^[k2]:=ph^[k2]-p*y; ph^[k1]:=ph^[k1]-p*x;
+                    end;  {j}
+                  if k+3<nn then j:=k+3 else j:=nn;
+                  { column modification}
+                  for i:=l to j do
+                    begin
+                      ik:=(i-1)*rwidth+k;
+                      p:=x*ph^[ik]+y*ph^[ik+1];
+                      if notlast then
+                        begin
+                          p:=p+z*ph^[ik+2]; ph^[ik+2]:=ph^[ik+2]-p*r;
+                        end;
+                      ph^[ik+1]:=ph^[ik+1]-p*q; ph^[ik]:=ph^[ik]-p;
+                    end  {i}
+                end  {x <> 0}
+              end  {k};
+          end;  {l < na}
+        its:=its+1
+      until (l=na) or (l=nn) or (its=30);
+      if l=nn then
+        begin  { one root found}
+          plam^[nn].Init(ph^[n1+nn]+t, 0); nn:=na
+        end else
+      if l=na then
+        begin  { two roots found}
+          x:=ph^[n1+nn]; y:=ph^[n2+na]; w:=ph^[n1+na]*ph^[n2+nn];
+          p:=(y-x)/2; q:=p*p+w; y:=sqrt(abs(q)); x:=x+t;
+          if q>0 then
+            begin  {  ArbFloat pair}
+              if p<0 then y:=-y; y:=p+y;
+              plam^[na].Init(x+y, 0); plam^[nn].Init(x-w/y, 0)
+            end else
+            begin { complex pair}
+              plam^[na].Init(x+p, y); plam^[nn].Init(x+p, -y)
+            end;
+          nn:=nn-2
+        end else term:=2
+    end {while }
+end  {hessva};
+
+procedure balance(var a: ArbFloat; n, rwidtha: ArbInt; var low, hi: ArbInt;
+                  var d: ArbFloat);
+
+const radix = 2;
+
+var   i, j, k, l, ii, jj: ArbInt;
+    b2, b, c, f, g, r, s: ArbFloat;
+                  pa, pd: ^arfloat1;
+           nonconv, cont: boolean;
+
+  procedure exc(j, k: ArbInt);
+  var i, ii, jj, kk: ArbInt;
+                  h: ArbFloat;
+  begin
+    pd^[k]:=j;
+    if j <> k then
+      begin
+        for i:=1 to n do
+          begin
+            ii:=(i-1)*rwidtha;
+            h:=pa^[ii+j]; pa^[ii+j]:=pa^[ii+k]; pa^[ii+k]:=h
+          end; {i}
+        for i:=1 to n do
+          begin
+            jj:=(j-1)*rwidtha+i; kk:=(k-1)*rwidtha+i;
+            h:=pa^[jj]; pa^[jj]:=pa^[kk]; pa^[kk]:=h
+         end; {i}
+     end {j <> k}
+  end {exc};
+begin
+  pa:=@a; pd:=@d; b:=radix; b2:=b*b; l:=1; k:=n; cont:=true;
+  while cont do
+    begin
+      j:=k+1;
+      repeat
+        j:=j-1; r:=0; jj:=(j-1)*rwidtha;
+        for i:=1 to j-1 do r:=r+abs(pa^[jj+i]);
+        for i:=j+1 to k do r:=r+abs(pa^[jj+i]);
+      until (r=0) or (j=1);
+      if r=0 then
+        begin
+          exc(j,k); k:=k-1
+        end;
+      cont:=(r=0) and (k >= 1);
+    end;
+  cont:= true ;
+  while cont do
+    begin
+      j:=l-1;
+      repeat
+        j:=j+1; r:=0;
+        for i:=l to j-1 do r:=r+abs(pa^[(i-1)*rwidtha+j]);
+        for i:=j+1 to k do r:=r+abs(pa^[(i-1)*rwidtha+j])
+      until (r=0) or (j=k);
+      if r=0 then
+        begin
+          exc(j,l); l:=l+1
+        end;
+      cont:=(r=0) and (l <= k);
+    end;
+  for i:=l to k do pd^[i]:=1;
+  low:=l; hi:=k; nonconv:=l <= k;
+  while nonconv do
+    begin
+      for i:=l to k do
+        begin
+          c:=0; r:=0;
+          for j:=l to i-1 do
+            begin
+              c:=c+abs(pa^[(j-1)*rwidtha+i]);
+              r:=r+abs(pa^[(i-1)*rwidtha+j])
+            end;
+          for j:=i+1 to k do
+            begin
+              c:=c+abs(pa^[(j-1)*rwidtha+i]);
+              r:=r+abs(pa^[(i-1)*rwidtha+j])
+            end;
+          g:=r/b; f:=1; s:=c+r;
+          while c<g do
+            begin
+              f:=f*b; c:=c*b2
+            end;
+          g:=r*b;
+          while c >= g do
+            begin
+              f:=f/b; c:=c/b2
+            end;
+          if (c+r)/f<0.95*s then
+            begin
+              g:=1/f; pd^[i]:=pd^[i]*f; ii:=(i-1)*rwidtha;
+              for j:=l to n do pa^[ii+j]:=pa^[ii+j]*g;
+              for j:=1 to k do pa^[(j-1)*rwidtha+i]:=pa^[(j-1)*rwidtha+i]*f;
+            end else nonconv:=false
+        end
+     end {while}
+end; {balance}
+
+procedure orttrans(var a: ArbFloat; n, rwidtha: ArbInt; var q: ArbFloat;
+                   rwidthq: ArbInt);
+
+var                 i, j, k : ArbInt;
+    sig, sig2, f, g, h, tol : ArbFloat;
+                  pa, pq, d : ^arfloat1;
+
+begin
+  pa:=@a; pq:=@q; tol:=midget/macheps;
+  getmem(d, n*sizeof(ArbFloat));
+  for k:=1 to n-2 do
+    begin
+      sig2:=0;
+      for i:=k+2 to n do
+        begin
+          d^[i]:=pa^[(i-1)*rwidtha+k]; f:=d^[i]; sig2:=sig2+sqr(f)
+        end;
+      if sig2<tol then
+        begin
+          d^[k+1]:=0; for i:=k+2 to n do pa^[(i-1)*rwidtha+k]:=0
+        end else
+        begin
+          f:=pa^[k*rwidtha+k]; sig2:=sig2+sqr(f);
+          if f<0 then sig:=sqrt(sig2) else sig:=-sqrt(sig2);
+          pa^[k*rwidtha+k]:=sig; h:=sig2-f*sig; d^[k+1]:=f-sig;
+          for j:=k+1 to n do
+            begin
+              f:=0; for i:=k+1 to n do f:=f+d^[i]*pa^[(i-1)*rwidtha+j];
+              f:=f/h;
+              for i:=k+1 to n do
+                pa^[(i-1)*rwidtha+j]:=pa^[(i-1)*rwidtha+j]-f*d^[i];
+            end;
+          for i:=1 to n do
+            begin
+              f:=0; for j:=k+1 to n do f:=f+d^[j]*pa^[(i-1)*rwidtha+j];
+              f:=f/h;
+              for j:=k+1 to n do
+                pa^[(i-1)*rwidtha+j]:=pa^[(i-1)*rwidtha+j]-f*d^[j];
+            end
+        end
+    end; {k}
+  for i:=1 to n do
+    begin
+      pq^[(i-1)*rwidthq+i]:=1;
+      for j:=1 to i-1 do
+        begin
+          pq^[(i-1)*rwidthq+j]:=0; pq^[(j-1)*rwidthq+i]:=0
+        end
+    end;
+  for k:=n-2 downto 1 do
+    begin
+      h:=pa^[k*rwidtha+k]*d^[k+1];
+      if h <> 0
+      then
+        begin
+          for i:=k+2 to n do d^[i]:=pa^[(i-1)*rwidtha+k];
+          for i:=k+2 to n do pa^[(i-1)*rwidtha+k]:=0;
+          for j:=k+1 to n do
+            begin
+              f:=0; for i:=k+1 to n do f:=f+d^[i]*pq^[(i-1)*rwidthq+j];
+              f:=f/h;
+              for i:=k+1 to n do
+                pq^[(i-1)*rwidthq+j]:=pq^[(i-1)*rwidthq+j]+f*d^[i]
+            end
+        end
+    end;
+  freemem(d, n*sizeof(ArbFloat));
+end; {orttrans}
+
+procedure balback(var pd: ArbFloat; n, m1, m2, k1, k2: ArbInt; var pdx: ArbFloat;
+                  rwidth: ArbInt);
+
+var i, j, k, ii, kk: ArbInt;
+                  s: ArbFloat;
+          ppd, ppdx: ^arfloat1;
+
+begin
+  ppd:=@pd; ppdx:=@pdx;
+  for i:=m1 to m2 do
+    begin
+      ii:=(i-1)*rwidth; s:=ppd^[i];
+      for j:=k1 to k2 do ppdx^[ii+j]:=ppdx^[ii+j]*s;
+    end;
+  for i:=m1-1 downto 1 do
+    begin
+      k:=round(ppd^[i]); ii:=(i-1)*rwidth; kk:=(k-1)*rwidth;
+      if k <> i then
+        for j:=k1 to k2 do
+          begin
+            s:=ppdx^[ii+j]; ppdx^[ii+j]:=ppdx^[kk+j]; ppdx^[kk+j]:=s
+          end
+    end;
+  for i:=m2+1 to n do
+    begin
+      k:=round(ppd^[i]); ii:=(i-1)*rwidth; kk:=(k-1)*rwidth;
+      if k <> i then
+        for j:=k1 to k2 do
+          begin
+            s:=ppdx^[ii+j]; ppdx^[ii+j]:=ppdx^[kk+j]; ppdx^[kk+j]:=s
+          end
+    end
+end; {balback}
+
+procedure cdiv(xr, xi, yr, yi: ArbFloat; var zr, zi: ArbFloat);
+var h:ArbFloat;
+begin
+  if abs(yr)>abs(yi) then
+    begin
+      h:=yi/yr; yr:=h*yi+yr;
+      zr:=(xr+h*xi)/yr; zi:=(xi-h*xr)/yr;
+    end else
+    begin
+      h:=yr/yi; yi:=h*yr+yi;
+      zr:=(h*xr+xi)/yi; zi:=(h*xi-xr)/yi
+    end
+end; {cdiv}
+
+procedure hessvec(var h: ArbFloat; n, rwidthh: ArbInt; var lam: complex;
+                  var v: ArbFloat; rwidthv: ArbInt; var term: ArbInt);
+
+var                        iterate, stop, notlast, contin: boolean;
+           i, j, k, l, m, na, its, en, n1, n2, ii, kk, ll,
+                                   ik, i1, k0, k1, k2, mr: ArbInt;
+    meps, p, q, r, s, t, w, x, y, z, ra, sa, vr, vi, norm: ArbFloat;
+                                                   ph, pv: ^arfloat1;
+                                                   plam  : ^arcomp1;
+begin
+  ph:=@h; pv:=@v; plam:=@lam;
+  term:=1; en:=n; t:=0; meps:=macheps;
+  while (term=1) and (en>=1) do
+    begin
+      its:=0; na:=en-1; iterate:=true;
+      while iterate and (term=1) do
+        begin
+          l:=en; contin:=true;
+          while (l>=2) and contin do
+            begin
+              ll:=(l-1)*rwidthh+l;
+              if abs(ph^[ll-1])>meps*(abs(ph^[ll-rwidthh-1])+abs(ph^[ll]))
+              then l:=l-1 else contin:=false
+            end;
+          n1:=(na-1)*rwidthh; n2:=(en-1)*rwidthh; x:=ph^[n2+en];
+          if l=en then
+            begin
+              iterate:=false; plam^[en].Init(x+t, 0); ph^[n2+en]:=x+t;
+              en:=en-1
+            end else
+            if l=en-1 then
+              begin
+                iterate:=false; y:=ph^[n1+na]; w:=ph^[n2+na]*ph^[n1+en];
+                p:=(y-x)/2; q:=p*p+w; z:=sqrt(abs(q)); x:=x+t;
+                ph^[n2+en]:=x; ph^[n1+na]:=y+t;
+                if q>0 then
+                  begin
+                    if p<0 then z:=p-z else z:=p+z; plam^[na].Init(x+z, 0);
+                    s:=x-w/z; plam^[en].Init(s, 0);
+                    x:=ph^[n2+na]; r:=sqrt(x*x+z*z); p:=x/r; q:=z/r;
+                    for j:=na to n do
+                      begin
+                        z:=ph^[n1+j]; ph^[n1+j]:=q*z+p*ph^[n2+j];
+                        ph^[n2+j]:=q*ph^[n2+j]-p*z
+                      end;
+                    for i:=1 to en do
+                      begin
+                        ii:=(i-1)*rwidthh;
+                        z:=ph^[ii+na]; ph^[ii+na]:=q*z+p*ph^[ii+en];
+                        ph^[ii+en]:=q*ph^[ii+en]-p*z;
+                      end;
+                    for i:=1 to n do
+                      begin
+                        ii:=(i-1)*rwidthv;
+                        z:=pv^[ii+na]; pv^[ii+na]:=q*z+p*pv^[ii+en];
+                        pv^[ii+en]:=q*pv^[ii+en]-p*z;
+                      end
+                  end {q>0}
+                else
+                  begin
+                    plam^[na].Init(x+p, z); plam^[en].Init(x+p, -z)
+                  end;
+                en:=en-2;
+              end {l=en-1}
+            else
+              begin
+                y:=ph^[n1+na]; w:=ph^[n1+en]*ph^[n2+na];
+                if (its=10) or (its=20)
+                then
+                  begin
+                    t:=t+x;
+                    for i:=1 to en do
+                      ph^[(i-1)*rwidthh+i]:=ph^[(i-1)*rwidthh+i]-x;
+                    s:=abs(ph^[n2+na])+abs(ph^[n1+en-2]);
+                    y:=0.75*s; x:=y; w:=-0.4375*s*s;
+                  end;
+                m:=en-1; stop:=false;
+                repeat
+                  m:=m-1; mr:=m*rwidthh;
+                  z:=ph^[mr-rwidthh+m]; r:=x-z; s:=y-z;
+                  p:=(r*s-w)/ph^[mr+m]+ph^[mr-rwidthh+m+1];
+                  q:=ph^[mr+m+1]-z-r-s; r:=ph^[mr+rwidthh+m+1];
+                  s:=abs(p)+abs(q)+abs(r); p:=p/s; q:=q/s; r:=r/s;
+                  if m>l then
+                    stop:=abs(ph^[mr-rwidthh+m-1])*(abs(q)+abs(r))<=
+                          meps*abs(p)*(abs(ph^[mr-2*rwidthh+m-1])+
+                                          abs(z)+abs(ph^[mr+m+1]))
+                until stop or (m=l);
+                for i:=m+2 to en do ph^[(i-1)*rwidthh+i-2]:=0;
+                for i:=m+3 to en do ph^[(i-1)*rwidthh+i-3]:=0;
+                for k:=m to na do
+                  begin
+                    k0:=(k-1)*rwidthh; k1:=k0+rwidthh; k2:=k1+rwidthh;
+                    notlast:=k<na; contin:=true;
+                    if k>m then
+                      begin
+                        p:=ph^[k0+k-1]; q:=ph^[k1+k-1];
+                        if notlast then r:=ph^[k2+k-1] else r:=0;
+                        x:=abs(p)+abs(q)+abs(r);
+                        if x>0 then
+                          begin
+                            p:=p/x; q:=q/x; r:=r/x
+                          end else contin:=false
+                      end;
+                    if contin then
+                      begin
+                        s:=sqrt(p*p+q*q+r*r);
+                        if p<0 then s:=-s;
+                        if k>m then ph^[k0+k-1]:=-s*x else
+                        if l <> m then ph^[k0+k-1]:=-ph^[k0+k-1];
+                        p:=p+s; x:=p/s; y:=q/s; z:=r/s; q:=q/p; r:=r/p;
+                        for j:=k to n do
+                          begin
+                            p:=ph^[k0+j]+q*ph^[k1+j];
+                            if notlast then
+                              begin
+                                p:=p+r*ph^[k2+j];
+                                ph^[k2+j]:=ph^[k2+j]-p*z
+                              end;
+                            ph^[k1+j]:=ph^[k1+j]-p*y;
+                            ph^[k0+j]:=ph^[k0+j]-p*x
+                          end; {j}
+                        if k+3<en then j:=k+3 else j:=en;
+                        for i:=1 to j do
+                          begin
+                            ik:=(i-1)*rwidthh+k;
+                            p:=x*ph^[ik]+y*ph^[ik+1];
+                            if notlast then
+                              begin
+                                p:=p+z*ph^[ik+2]; ph^[ik+2]:=ph^[ik+2]-p*r
+                              end;
+                            ph^[ik+1]:=ph^[ik+1]-p*q; ph^[ik]:=ph^[ik]-p
+                          end;  {i}
+                        for i:=1 to n do
+                          begin
+                            ik:=(i-1)*rwidthv+k;
+                            p:=x*pv^[ik]+y*pv^[ik+1];
+                            if notlast then
+                              begin
+                                p:=p+z*pv^[ik+2]; pv^[ik+2]:=pv^[ik+2]-p*r
+                              end;
+                            pv^[ik+1]:=pv^[ik+1]-p*q; pv^[ik]:=pv^[ik]-p
+                          end  {i}
+                      end  {contin}
+                  end;  {k}
+                its:=its+1; if its >= 30 then term:=2
+              end  {ifl}
+        end  {iterate}
+    end;  {term=1}
+  if term=1 then
+    begin
+      norm:=0; k:=1;
+      for i:=1 to n do
+        begin
+          for j:=k to n do norm:=norm+abs(ph^[(i-1)*rwidthh+j]);
+          k:=i
+        end;
+      if norm=0 then
+        begin
+         { matrix is nulmatrix: eigenwaarden zijn alle 0 en aan de
+           eigenvectoren worden de eenheidsvectoren toegekend }
+          for i:=1 to n do plam^[i].Init(0, 0);
+          for i:=1 to n do
+            fillchar(pv^[(i-1)*rwidthv+1], n*sizeof(ArbFloat), 0);
+          for i:=1 to n do pv^[(i-1)*rwidthv+i]:=1;
+          exit
+        end; {norm=0}
+      for en:=n downto 1 do
+        begin
+          p:=plam^[en].re; q:=plam^[en].im; na:=en-1;
+          n1:=(na-1)*rwidthh; n2:=(en-1)*rwidthh;
+          if q=0 then
+            begin
+              m:=en; ph^[n2+en]:=1;
+              for i:=na downto 1 do
+                begin
+                  ii:=(i-1)*rwidthh; i1:=ii+rwidthh;
+                  w:=ph^[ii+i]-p; r:=ph^[ii+en];
+                  for j:=m to na do r:=r+ph^[ii+j]*ph^[(j-1)*rwidthh+en];
+                  if plam^[i].im < 0 then
+                    begin
+                      z:=w; s:=r
+                    end else
+                    begin
+                      m:=i; if plam^[i].im=0 then
+                      if w=0 then ph^[ii+en]:=-r/(meps*norm)
+                      else ph^[ii+en]:=-r/w else
+                        begin
+                          x:=ph^[ii+i+1]; y:=ph^[i1+i];
+                          q:=sqr(plam^[i].xreal-p)+sqr(plam^[i].imag);
+                          ph^[ii+en]:=(x*s-z*r)/q; t:=ph^[ii+en];
+                          if abs(x)>abs(z) then ph^[i1+en]:=(-r-w*t)/x
+                          else ph^[i1+en]:=(-s-y*t)/z;
+                        end  {plam^[i].imag > 0}
+                    end  {plam^[i].imag >= 0}
+                end  {i}
+            end {q=0}
+          else
+            if q<0 then
+              begin
+                m:=na;
+                if abs(ph^[n2+na]) > abs(ph^[n1+en]) then
+                  begin
+                    ph^[n1+na]:=-(ph^[n2+en]-p)/ph^[n2+na];
+                    ph^[n1+en]:=-q/ph^[n2+na];
+                  end else
+                  cdiv(-ph^[n1+en], 0, ph^[n1+na]-p, q,
+                        ph^[n1+na], ph^[n1+en]);
+                ph^[n2+na]:=1; ph^[n2+en]:=0;
+                for i:=na-1 downto 1 do
+                  begin
+                    ii:=(i-1)*rwidthh; i1:=ii+rwidthh;
+                    w:=ph^[ii+i]-p; ra:=ph^[ii+en]; sa:=0;
+                    for j:=m to na do
+                      begin
+                        ra:=ra+ph^[ii+j]*ph^[(j-1)*rwidthh+na];
+                        sa:=sa+ph^[ii+j]*ph^[(j-1)*rwidthh+en]
+                      end;
+                    if plam^[i].imag < 0 then
+                      begin
+                        z:=w; r:=ra; s:=sa
+                      end else
+                      begin
+                        m:=i;
+                        if plam^[i].imag=0
+                        then cdiv(-ra, -sa, w, q, ph^[ii+na], ph^[ii+en])
+                        else
+                          begin
+                            x:=ph^[ii+i+1]; y:=ph^[i1+i];
+                            vr:=sqr(plam^[i].xreal-p)+sqr(plam^[i].imag)-q*q;
+                            vi:=(plam^[i].xreal-p)*q*2;
+                            if (vr=0) and (vi=0)
+                            then
+                               vr:=meps*norm*(abs(w)+abs(q)+abs(x)+
+                                                   abs(y)+abs(z));
+                            cdiv(x*r-z*ra+q*sa, x*s-z*sa-q*ra, vr, vi,
+                                 ph^[ii+na], ph^[ii+en]);
+                            if abs(x)>abs(z)+abs(q)
+                            then
+                              begin
+                                ph^[i1+na]:=(-ra-w*ph^[ii+na]+q*ph^[ii+en])/x;
+                                ph^[i1+en]:=(-sa-w*ph^[ii+en]-q*ph^[ii+na])/x
+                              end
+                            else
+                              cdiv(-r-y*ph^[ii+na], -s-y*ph^[ii+en],
+                                   z, q, ph^[i1+na], ph^[i1+en])
+                          end  {plam^[i].imag > 0}
+                      end {plam^[i].imag >= 0}
+                  end  {i}
+              end
+        end  {backsubst};
+      for j:=n downto 1 do
+        begin
+          m:=j; l:=j-1;
+          if plam^[j].imag < 0 then
+            begin
+              for i:=1 to n do
+                begin
+                  ii:=(i-1)*rwidthv; y:=0; z:=0;
+                  for k:=1 to m do
+                    begin
+                      kk:=(k-1)*rwidthh;
+                      y:=y+pv^[ii+k]*ph^[kk+l];
+                      z:=z+pv^[ii+k]*ph^[kk+j]
+                    end;
+                  pv^[ii+l]:=y; pv^[ii+j]:=z
+                end  {i}
+            end else
+            if plam^[j].imag=0 then
+              for i:=1 to n do
+                begin
+                  z:=0;
+                  ii:=(i-1)*rwidthv;
+                  for k:=1 to m do z:=z+pv^[ii+k]*ph^[(k-1)*rwidthh+j];
+                  pv^[ii+j]:=z;
+                end  {i}
+        end {j}
+    end  {term=1}
+end;  {hessvec}
+
+procedure normeer(var lam: complex; n: ArbInt; var v: ArbFloat;
+                  rwidthv: ArbInt);
+
+var              i, j, k, ii, kk: ArbInt;
+               max, s, t, vr, vi: ArbFloat;
+                              pv: ^arfloat1;
+                            plam: ^arcomp1;
+begin
+  plam:=@lam; pv:=@v; j:=1;
+  while j<=n do
+    if plam^[j].imag=0 then
+      begin
+        s:=0; for i:=1 to n do s:=s+sqr(pv^[(i-1)*rwidthv+j]); s:=sqrt(s);
+        for i:=1 to n do pv^[(i-1)*rwidthv+j]:=pv^[(i-1)*rwidthv+j]/s;
+        j:=j+1
+      end else
+      begin
+        max:=0; s:=0;
+        for i:=1 to n do
+          begin
+            ii:=(i-1)*rwidthv;
+            t:=sqr(pv^[ii+j])+sqr(pv^[ii+j+1]); s:=s+t;
+            if t>max then
+              begin
+                max:=t; k:=i
+              end
+          end;
+        kk:=(k-1)*rwidthv;
+        s:=sqrt(max/s); t:=pv^[kk+j+1]/s; s:=pv^[kk+j]/s;
+        for i:=1 to n do
+          begin
+            ii:=(i-1)*rwidthv;
+            vr:=pv^[ii+j]; vi:=pv^[ii+j+1];
+            cdiv(vr, vi, s, t, pv^[ii+j], pv^[ii+j+1]);
+          end;
+        pv^[kk+j+1]:=0; j:=j+2;
+      end
+end; {normeer}
+
+procedure transx(var v: ArbFloat; n, rwidthv: ArbInt; var lam, x: complex;
+                 rwidthx: ArbInt);
+
+var  i, j, ix, iv : ArbInt;
+               pv : ^arfloat1;
+         plam, px : ^arcomp1;
+begin
+  pv:=@v; plam:=@lam; px:=@x;
+  for i:=1 to n do
+    if plam^[i].imag > 0 then
+      for j:=1 to n do
+        begin
+          iv:=(j-1)*rwidthv+i; ix:=(j-1)*rwidthx+i;
+          px^[ix].xreal:=pv^[iv]; px^[ix].imag:=pv^[iv+1]
+        end else
+    if plam^[i].imag < 0 then
+      for j:=1 to n do
+        begin
+          iv:=(j-1)*rwidthv+i; ix:=(j-1)*rwidthx+i;
+          px^[ix].xreal:=pv^[iv-1]; px^[ix].imag:=-pv^[iv]
+        end else
+      for j:=1 to n do
+        begin
+          iv:=(j-1)*rwidthv+i; ix:=(j-1)*rwidthx+i;
+          px^[ix].xreal:=pv^[iv]; px^[ix].imag:=0
+        end
+end; {transx}
+
+procedure reduc1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;
+                 rwidthb: ArbInt; var term: ArbInt);
+
+var  i, j, k, ia, ja, ib, jb : ArbInt;
+                        x, y : ArbFloat;
+                      pa, pb : ^arfloat1;
+begin
+  pa:=@a; pb:=@b;
+  term:=1; i:=0;
+  while (i<n) and (term=1) do
+    begin
+      i:=i+1; j:=i-1; jb:=(j-1)*rwidthb; ib:=(i-1)*rwidthb;
+      while (j<n) and (term=1) do
+        begin
+          j:=j+1; jb:=jb+rwidthb; x:=pb^[jb+i];
+          for k:=1 to i-1 do x:=x-pb^[ib+k]*pb^[jb+k];
+            if i=j then
+              begin
+                if x<=0 then term:=2 else
+                  begin
+                    y:=sqrt(x); pb^[ib+i]:=y
+                  end
+              end else pb^[jb+i]:=x/y
+        end  {j}
+    end; {i}
+  if term=1 then
+    begin
+      for i:=1 to n do
+        begin
+          ib:=(i-1)*rwidthb; y:=pb^[ib+i];
+          for j:=i to n do
+            begin
+              ja:=(j-1)*rwidtha; x:=pa^[ja+i];
+              for k:=i-1 downto 1 do x:=x-pb^[ib+k]*pa^[ja+k];
+                pa^[ja+i]:=x/y;
+            end {j}
+        end; {i}
+      for j:=1 to n do
+        begin
+          ja:=(j-1)*rwidtha;
+          for i:=j to n do
+            begin
+              ia:=(i-1)*rwidtha; ib:=(i-1)*rwidthb; x:=pa^[ia+j];
+              for k:=i-1 downto j do x:=x-pa^[(k-1)*rwidtha+j]*pb^[ib+k];
+              for k:=j-1 downto 1 do x:=x-pa^[ja+k]*pb^[ib+k];
+              pa^[ia+j]:=x/pb^[ib+i]
+            end {i}
+        end {j}
+    end {term=1};
+end; {reduc1}
+
+procedure rebaka(var l: ArbFloat; n, rwidthl, k1, k2: ArbInt; var x: ArbFloat;
+                 rwidthx: ArbInt; var term: ArbInt);
+
+var         pl, px : ^arfloat1;
+   i, j, k, il, ix : ArbInt;
+                y : ArbFloat;
+begin
+  pl:=@l; px:=@x; term:=1; il:=1;
+  for i:=1 to n do
+    begin
+      if pl^[il]=0 then
+        begin
+          term:=2; exit
+        end;
+      il:=il+rwidthl+1
+    end; {i}
+  for j:=1 to k2-k1+1 do
+    for i:=n downto 1 do
+      begin
+        il:=(i-1)*rwidthl; ix:=(i-1)*rwidthx; y:=px^[ix+j];
+        for k:=i+1 to n do y:=y-pl^[(k-1)*rwidthl+i]*px^[(k-1)*rwidthx+j];
+        px^[ix+j]:=y/pl^[il+i]
+      end
+end; {rebaka}
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/int.pas

@@ -0,0 +1,1072 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Integration. This routine is fit for smooth "integrand" so no singularities,
+    sharp edges, or quickly oscillating behaviour.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+Unit int;
+{$I DIRECT.INC}
+
+interface
+
+uses typ;
+
+Var 
+    limit    : ArbInt;
+    epsrel   : ArbFloat;
+
+{calc int(x,a,b,f(x)) for a function with a nice behaviour in the
+interval [A,B]}
+
+Procedure int1fr(f: rfunc1r; a, b, ae: ArbFloat; Var integral, err: ArbFloat;
+                 Var term: ArbInt);
+
+implementation
+
+Function amin1(x, y: ArbFloat): ArbFloat;
+Begin
+    If x<y Then amin1 := x
+ Else amin1 := y
+End;
+
+Function amax1(x, y: ArbFloat): ArbFloat;
+Begin
+    If x>y Then amax1 := x
+ Else amax1 := y
+End;
+
+Procedure qk21(f: rfunc1r; a, b: ArbFloat;
+               Var result, abserr, resabs, resasc: ArbFloat);
+
+Const 
+
+ xgk: array[1..11] Of ArbFloat = 
+                                ( 0.9956571630258081, 0.9739065285171717,
+                                  0.9301574913557082, 0.8650633666889845,
+                                  0.7808177265864169, 0.6794095682990244,
+                                  0.5627571346686047, 0.4333953941292472,
+                                  0.2943928627014602, 0.1488743389816312, 0);
+
+ wgk: array[1..11] Of ArbFloat = 
+                                ( 0.1169463886737187e-1, 0.3255816230796473e-1,
+                                  0.5475589657435200e-1, 0.7503967481091995e-1,
+                                  0.9312545458369761e-1, 0.1093871588022976,
+                                  0.1234919762620659,    0.1347092173114733,
+                                  0.1427759385770601,    0.1477391049013385,
+                                  0.1494455540029169);
+
+ wg: array[1..5] Of ArbFloat = 
+                              ( 0.6667134430868814e-1, 0.1494513491505806,
+                                0.2190863625159820,    0.2692667193099964,
+                                0.2955242247147529);
+
+Var  absc, centr, dhlgth, fc, fsum, fval1, fval2,
+     hlgth, resg, resk, reskh: ArbFloat;
+     j, jtw, jtwm1: ArbInt;
+          fv1, fv2: ^arfloat1;
+Begin
+   getmem(fv1, 10*sizeof(ArbFloat));
+ getmem(fv2, 10*sizeof(ArbFloat));
+   centr := (a+b)/2;
+ hlgth := (b-a)/2;
+ dhlgth := abs(hlgth);
+ resg := 0;
+   fc := f(centr);
+ resk := wgk[11]*fc;
+ resabs := abs(resk);
+   For j:=1 To 5 Do
+    Begin
+       jtw := 2*j;
+     absc := hlgth*xgk[jtw];
+       fval1 := f(centr-absc);
+     fval2 := f(centr+absc);
+       fv1^[jtw] := fval1;
+     fv2^[jtw] := fval2;
+     fsum := fval1+fval2;
+       resg := resg+wg[j]*fsum;
+     resk := resk+wgk[jtw]*fsum;
+       resabs := resabs+wgk[jtw]*(abs(fval1)+abs(fval2))
+    End;
+   For j:=1 To 5 Do
+    Begin
+       jtwm1 := 2*j-1;
+     absc := hlgth*xgk[jtwm1];
+       fval1 := f(centr-absc);
+     fval2 := f(centr+absc);
+       fv1^[jtwm1] := fval1;
+     fv2^[jtwm1] := fval2;
+     fsum := fval1+fval2;
+       resk := resk+wgk[jtwm1]*fsum;
+       resabs := resabs+wgk[jtwm1]*(abs(fval1)+abs(fval2))
+    End;
+   reskh := resk/2;
+ resasc := wgk[11]*abs(fc-reskh);
+   For j:=1 To 10 Do
+     resasc := resasc+wgk[j]*(abs(fv1^[j]-reskh)+abs(fv2^[j]-reskh));
+   result := resk*hlgth;
+ resabs := resabs*dhlgth;
+ resasc := resasc*dhlgth;
+   abserr := abs((resk-resg)*hlgth);
+   If (resasc <> 0) And (abserr <> 0)
+    Then abserr := resasc*amin1(1,exp(1.5*ln(200*abserr/resasc)));
+   If resabs > midget/(50*macheps)
+    Then abserr := amax1((50*macheps)*resabs, abserr);
+   freemem(fv1, 10*sizeof(ArbFloat));
+ freemem(fv2, 10*sizeof(ArbFloat));
+End;
+
+Procedure qpsrt(limit: ArbInt;
+                Var last, maxerr: ArbInt;
+                Var ermax, elist1: ArbFloat;
+                Var iord1, nrmax: ArbInt);
+
+Var errmax, errmin: ArbFloat;
+    i, ibeg, ido, isucc,
+    j, jbnd, jupbn, k : ArbInt;
+    continue : boolean;
+    elist : arfloat1 absolute elist1;
+    iord  : arint1 absolute iord1;
+Begin
+      If (last<=2)
+       Then
+       Begin
+          iord[1] := 1;
+          iord[2] := 2;
+          maxerr := iord[nrmax];
+          ermax := elist[maxerr];
+          exit
+       End;
+
+      errmax := elist[maxerr];
+      ido := nrmax-1;
+      i := 0;
+      If ido>0 Then
+       Repeat
+          Inc(i);
+          isucc := iord[nrmax-1];
+          If errmax>elist[isucc]
+           Then
+           Begin
+               iord[nrmax] := isucc;
+               nrmax := nrmax-1
+           End
+        Else i := ido
+       Until (i=ido);
+
+      jupbn := last;
+      If (last>(limit Div 2+2)) Then jupbn := limit+3-last;
+      errmin := elist[last];
+      jbnd := jupbn-1;
+      ibeg := nrmax+1;
+
+      If (ibeg>jbnd)
+       Then
+       Begin
+         iord[jbnd] := maxerr;
+         iord[jupbn] := last;
+         maxerr := iord[nrmax];
+         ermax := elist[maxerr];
+         exit
+       End;
+
+      i := ibeg-1;
+      continue := true;
+      while (i<jbnd) and continue Do
+      Begin
+        Inc(i);
+        isucc := iord[i];
+        If (errmax<elist[isucc])
+         Then iord[i-1] := isucc
+        Else continue := false
+      End;
+      If continue
+       Then
+       Begin
+          iord[jbnd] := maxerr;
+          iord[jupbn] := last
+       End
+ Else
+      Begin
+          iord[i-1] := maxerr;
+          k := jbnd;
+          continue := true;
+          j := i-1;
+          while (j<jbnd) and continue Do
+          Begin
+             Inc(j);
+             isucc := iord[k];
+             If errmin<elist[isucc]
+              Then continue := false
+             Else
+              Begin
+                 iord[k+1] := isucc;
+                 Dec(k)
+              End
+          End;
+          If continue Then iord[i] := last
+                      Else iord[k+1] := last
+      End;
+
+      maxerr := iord[nrmax];
+      ermax := elist[maxerr]
+
+End;
+
+Type 
+     stock = array[1..52] Of ArbFloat;
+     hulpar = array[1..3] Of ArbFloat;
+
+Procedure qelg(Var n: ArbInt;
+               Var epstab: stock;
+               Var result, abserr: ArbFloat;
+               Var res3la: hulpar;
+               Var nres: ArbInt);
+
+Var 
+     delta1, delta2, delta3,
+     epsinf, error, err1, err2, err3,
+     e0, e1, e2, e3, e0abs, e1abs, e2abs, e3abs,
+     res, ss, tol1, tol2, tol3: ArbFloat;
+     i, ib, ib2, k1, k2, k3,
+     limexp, num, newelm:  ArbInt;
+     continue: boolean;
+Begin
+      Inc(nres);
+      abserr := giant;
+      result := epstab[n];
+
+      If (n<3) Then exit;
+
+      limexp := 50;
+      epstab[n+2] := epstab[n];
+      epstab[n] := giant;
+      num := n;
+      k1 := n;
+      continue := true;
+      i := 1;
+      newelm := (n-1) Div 2;
+      while (i<=newelm) and continue Do
+      Begin
+        k2 := k1-1;
+        k3 := k1-2;
+        res := epstab[k1+2];
+        e0 := epstab[k3];
+        e1 := epstab[k2];
+        e2 := res;
+        e0abs := abs(e0);
+        e1abs := abs(e1);
+        e2abs := abs(e2);
+        delta2 := e2-e1;
+        err2 := abs(delta2);
+
+        If e1abs>e2abs
+         Then tol2 := e1abs*macheps
+        Else tol2 := e2abs*macheps;
+
+        delta3 := e1-e0;
+        err3 := abs(delta3);
+        If e1abs>e0abs
+         Then tol3 := e1abs*macheps
+        Else tol3 := e0abs*macheps;
+
+        If (err2<=tol2) And (err3<=tol3)
+         Then
+         Begin
+           result := res;
+           abserr := err2+err3;
+           If abserr<5*macheps*abs(result)
+            Then abserr := 5*macheps*abs(result);
+           exit
+         End;
+
+        e3 := epstab[k1];
+        epstab[k1] := e1;
+        delta1 := e1-e3;
+        err1 := abs(delta1);
+        e3abs := abs(e3);
+
+        If e1abs<e3abs
+         Then tol1 := e3abs*macheps
+        Else tol1 := e1abs*macheps;
+
+        continue := false;
+
+        If (err1<=tol1) Or (err2<=tol2) Or (err3<=tol3)
+         Then n := 2*i-1
+        Else
+         Begin
+           ss := 1/delta1 + 1/delta2 - 1/delta3;
+           epsinf := abs(ss*e1);
+           If (epsinf>1e-4)
+            Then
+            Begin
+              continue := true;
+              res := e1+1/ss;
+              epstab[k1] := res;
+              k1 := k1-2;
+              error := err2+abs(res-e2)+err3;
+              If (error<=abserr)
+               Then
+               Begin
+                 abserr := error;
+                 result := res
+               End
+            End
+          Else n := 2*i-1
+         End;
+        Inc(i)
+
+      End;
+
+      If n=limexp Then n := 2*(limexp Div 2)-1;
+
+      If Odd(Num) Then ib := 1
+ Else ib := 2;
+
+      For i:=1 To newelm+1 Do
+       Begin
+         ib2 := ib+2;
+         epstab[ib] := epstab[ib2];
+         ib := ib2
+       End;
+
+      Move(epstab[num-n+1], epstab[1], n*SizeOf(ArbFloat));
+
+      If (nres<4)
+       Then
+       Begin
+         res3la[nres] := result;
+         abserr := giant
+       End
+ Else
+      Begin
+         abserr := abs(result-res3la[3]) +
+                   abs(result-res3la[2]) +
+                   abs(result-res3la[1]);
+         res3la[1] := res3la[2];
+         res3la[2] := res3la[3];
+         res3la[3] := result;
+         If abserr<5*macheps*abs(result)
+          Then abserr := 5*macheps*abs(result)
+      End
+End;
+
+Procedure qagse(f: rfunc1r; a, b, epsabs, epsrel: ArbFloat;
+                limit: ArbInt; Var result, abserr: ArbFloat;
+                Var neval, ier, last: ArbInt);
+
+Var abseps, area, area1, area12, area2, a1, a2, b1, b2, correc, defabs,
+    defab1, defab2, dres, erlarg, erlast, errbnd, errmax,
+    error1, error2, erro12, errsum, ertest, resabs, reseps, small: ArbFloat;
+    id, ierro, iroff1, iroff2, iroff3, jupbnd, k, ksgn,
+    ktmin, maxerr, nres, nrmax, numrl2, sr, lsr: ArbInt;
+    extrap, noext, go_on, jump, smallers, p0, p1, p2, p3: boolean;
+    alist, blist, elist, rlist: ^arfloat1;
+    res3la: hulpar;
+    rlist2: stock;
+    iord: ^arint1;
+Begin
+  sr := sizeof(ArbFloat);
+ lsr := limit*sr;
+  getmem(alist, lsr);
+  getmem(blist, lsr);
+  getmem(elist, lsr);
+  getmem(iord, limit*sizeof(ArbInt));
+  getmem(rlist, lsr);
+  ier := 0;
+ neval := 0;
+ last := 0;
+ result := 0;
+ abserr := 0;
+  alist^[1] := a;
+ blist^[1] := b;
+ rlist^[1] := 0;
+ elist^[1] := 0;
+  If (epsabs <= 0) And (epsrel < amax1(0.5e+02*macheps, 0.5e-14)) Then
+   Begin
+      ier := 6;
+      freemem(rlist, lsr);
+      freemem(iord, limit*sizeof(ArbInt));
+      freemem(elist, lsr);
+      freemem(blist, lsr);
+      freemem(alist, lsr);
+      exit
+   End;
+  ierro := 0;
+  qk21(f, a, b, result, abserr, defabs, resabs);
+ dres := abs(result);
+  errbnd := amax1(epsabs, epsrel*dres);
+  last := 1;
+ rlist^[1] := result;
+ elist^[1] := abserr;
+  iord^[1] := 1;
+  If (abserr <= 100*macheps*defabs) And (abserr>errbnd) Then ier := 2;
+  If limit=1 Then ier := 1;
+  If (ier <> 0) Or ((abserr <= errbnd) And (abserr <> resabs)) Or (abserr=0)
+   Then
+   Begin
+      neval := 21;
+      freemem(rlist, lsr);
+      freemem(iord, limit*sizeof(ArbInt));
+      freemem(elist, lsr);
+      freemem(blist, lsr);
+      freemem(alist, lsr);
+      exit
+   End;
+  rlist2[1] := result;
+ errmax := abserr;
+ maxerr := 1;
+ area := result;
+  errsum := abserr;
+ abserr := giant;
+ nrmax := 1;
+ nres := 0;
+ numrl2 := 2;
+ ktmin := 0;
+  extrap := false;
+ noext := false;
+ iroff1 := 0;
+ iroff2 := 0;
+ iroff3 := 0;
+ ksgn := -1;
+  If dres >= (1-50*macheps)*defabs Then ksgn := 1;
+  go_on := limit > 1;
+ smallers := false;
+  while go_on Do
+    Begin
+      inc(last);
+     a1 := alist^[maxerr];
+      b1 := (alist^[maxerr]+blist^[maxerr])/2;
+     a2 := b1;
+     b2 := blist^[maxerr];
+      erlast := errmax;
+      qk21(f, a1, b1, area1, error1, resabs, defab1);
+      qk21(f, a2, b2, area2, error2, resabs, defab2);
+      area12 := area1+area2;
+     erro12 := error1+error2;
+      errsum := errsum+erro12-errmax;
+     area := area+area12-rlist^[maxerr];
+      If (defab1 <> error1) And (defab2 <> error2) Then
+        Begin
+          If (abs(rlist^[maxerr]-area12) <= 1e-5*abs(area12))
+              And (erro12 >= 0.99*errmax) Then
+           Begin
+            If extrap Then inc(iroff2)
+            Else inc(iroff1)
+           End;
+          If (last > 10) And (erro12 > errmax) Then inc(iroff3)
+        End;
+      rlist^[maxerr] := area1;
+     rlist^[last] := area2;
+      errbnd := amax1(epsabs, epsrel*abs(area));
+      If (iroff1+iroff2 >= 10) Or (iroff3>=20) Then ier := 2;
+      If iroff2>=5 Then ierro := 3;
+     If last=limit Then ier := 1;
+      If amax1(abs(a1),abs(b2)) <= (1+100*macheps)*(abs(a2)+1000*midget)
+       Then ier := 4;
+      If error2 <= error1 Then
+        Begin
+          alist^[last] := a2;
+         blist^[maxerr] := b1;
+         blist^[last] := b2;
+          elist^[maxerr] := error1;
+         elist^[last] := error2
+        End
+     Else
+        Begin
+          alist^[maxerr] := a2;
+         alist^[last] := a1;
+         blist^[last] := b1;
+          rlist^[maxerr] := area2;
+         rlist^[last] := area1;
+          elist^[maxerr] := error2;
+         elist^[last] := error1
+        End;
+      qpsrt(limit, last, maxerr, errmax, elist^[1], iord^[1], nrmax);
+      If errsum <= errbnd Then
+        Begin
+          smallers := true;
+         go_on := false
+        End
+     Else
+        Begin
+          If ier <> 0 Then go_on := false
+         Else
+            Begin
+              If (last=2) Or (Not noext) Then
+                Begin
+                  If last <> 2 Then
+                    Begin
+                      erlarg := erlarg-erlast;
+                      If abs(b1-a1) > small Then erlarg := erlarg+erro12;
+                      If extrap Or
+                         (abs(blist^[maxerr]-alist^[maxerr]) <= small) Then
+                        Begin
+                          If Not extrap Then nrmax := 2;
+                         extrap := true;
+                          jump := false;
+                          If (ierro <> 3) And (erlarg>=ertest) Then
+                            Begin
+                              id := nrmax;
+                             jupbnd := last;
+                              If last > 2+limit/2 Then jupbnd := limit+3-last;
+                              k := id;
+                              while (k <= jupbnd) and (Not jump) Do
+                                Begin
+                                  maxerr := iord^[nrmax];
+                                  errmax := elist^[maxerr];
+                                  If abs(blist^[maxerr]-alist^[maxerr]) > small
+                                   Then jump := true
+                                  Else
+                                    Begin
+                                      nrmax := nrmax+1;
+                                     k := k+1
+                                    End
+                                End;
+                            End; {(ierro <> 3) and (erlarg>=ertest)}
+                          If Not jump Then
+                            Begin
+                              numrl2 := numrl2+1;
+                             rlist2[numrl2] := area;
+                              qelg(numrl2, rlist2, reseps, abseps,
+                                   res3la, nres);
+                              ktmin := ktmin+1;
+                              If (ktmin > 5) And (abserr < 1e-3*errsum)
+                               Then ier := 5;
+                              If abseps < abserr Then
+                                Begin
+                                  ktmin := 0;
+                                 abserr := abseps;
+                                 result := reseps;
+                                  correc := erlarg;
+                                  ertest := amax1(epsabs,epsrel*abs(reseps));
+                                  If abserr <= ertest Then go_on := false
+                                End;
+                              If go_on Then
+                                Begin
+                                  If numrl2=1 Then noext := true;
+                                  If ier=5 Then go_on := false
+                                 Else
+                                    Begin
+                                      maxerr := iord^[1];
+                                     errmax := elist^[maxerr];
+                                      nrmax := 1;
+                                     extrap := false;
+                                     small := small/2;
+                                      erlarg := errsum
+                                    End; {ier <> 5}
+                                End; {go_on}
+                            End; {not jump}
+                        End;  { abs(blist^[maxerr]-alist^[maxerr]) <= small }
+                    End
+                 Else {last=2}
+                      Begin
+                        small := abs(b-a)*0.375;
+                       erlarg := errsum;
+                        ertest := errbnd;
+                       rlist2[2] := area
+                      End
+                End; {last=2 or not noext}
+            End; {ier <> 0}
+        End; {errsum <= errbnd}
+      If go_on Then go_on := last < limit
+    End; {while go_on}
+  p0 := false;
+ p1 := false;
+ p2 := false;
+ p3 := false;
+  If (abserr=giant) Or smallers Then p0 := true
+ Else
+  If ier+ierro=0 Then p1 := true;
+  If Not (p0 Or p1) Then
+    Begin
+      If ierro=3 Then abserr := abserr+correc;
+      If ier=0 Then ier := 3;
+      If (result <> 0) And (area <> 0) Then p2 := true
+     Else
+      If abserr > errsum Then p0 := true
+     Else
+      If area=0 Then p3 := true
+     Else p1 := true
+    End;
+  If p2 Then
+    Begin
+      If abserr/abs(result) > errsum/abs(area) Then p0 := true
+     Else p1 := true
+    End;
+  If p1 Then
+    Begin
+      If (ksgn=-1) And (amax1(abs(result),abs(area)) <= defabs*0.01)
+       Then p3 := true
+     Else
+      If (0.01 > result/area) Or (result/area > 100) Or (errsum>abs(area))
+       Then ier := 6;
+      p3 := true
+    End;
+  If p0 Then
+    Begin
+      result := 0;
+      For k:=1 To last Do
+       result := result+rlist^[k]
+    End;
+  If Not p3 Then abserr := errsum;
+  If ier>2 Then ier := ier-1;
+  neval := 42*last-21;
+  freemem(alist, lsr);
+ freemem(blist, lsr);
+ freemem(elist, lsr);
+  freemem(rlist, lsr);
+ freemem(iord, limit*sizeof(ArbInt));
+End;
+
+
+{    single-precision machine constants
+   r1mach(1) = b**(emin-1), the midget positive magnitude..
+   r1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude.
+   r1mach(3) = b**(-t), the midget relative spacing.
+   r1mach(4) = b**(1-t), the largest relative spacing.
+   r1mach(5) = log10(b)
+}
+
+Procedure qk15i(f: rfunc1r; boun: ArbFloat;
+                inf: ArbInt;
+                a, b: ArbFloat;
+                Var result, abserr, resabs, resasc: ArbFloat);
+
+Const  xgk : array[1..8] Of ArbFloat = (
+                                        0.9914553711208126, 0.9491079123427585,
+                                        0.8648644233597691, 0.7415311855993944,
+                                        0.5860872354676911, 0.4058451513773972,
+                                        0.2077849550078985, 0.0000000000000000);
+      wgk : array[1..8] Of ArbFloat = (
+                                       0.02293532201052922,0.06309209262997855,
+                                       0.1047900103222502, 0.1406532597155259,
+                                       0.1690047266392679, 0.1903505780647854,
+                                       0.2044329400752989, 0.2094821410847278);
+      wg : array[1..8] Of ArbFloat = (
+                                      0, 0.1294849661688697,
+                                      0, 0.2797053914892767,
+                                      0, 0.3818300505051189,
+                                      0, 0.4179591836734694);
+
+Var  absc, absc1, absc2, centr,
+     dinf, fc, fsum, fval1, fval2,
+     hlgth, resg, resk, reskh,
+     tabsc1, tabsc2: ArbFloat;
+
+     fv1, fv2: array[1..7] Of ArbFloat;
+
+     j, min0: ArbInt;
+Begin
+      If inf<1 Then dinf := inf
+ Else dinf := 1;
+      centr := 0.5*(a+b);
+      hlgth := 0.5*(b-a);
+      tabsc1 := boun+dinf*(1-centr)/centr;
+      fval1 := f(tabsc1);
+      If (inf=2) Then fval1 := fval1+f(-tabsc1);
+      fc := (fval1/centr)/centr;
+      resg := wg[8]*fc;
+      resk := wgk[8]*fc;
+      resabs := abs(resk);
+      For j:=1 To 7 Do
+       Begin
+        absc := hlgth*xgk[j];
+        absc1 := centr-absc;
+        absc2 := centr+absc;
+        tabsc1 := boun+dinf*(1-absc1)/absc1;
+        tabsc2 := boun+dinf*(1-absc2)/absc2;
+        fval1 := f(tabsc1);
+        fval2 := f(tabsc2);
+        If (inf=2) Then fval1 := fval1+f(-tabsc1);
+        If (inf=2) Then fval2 := fval2+f(-tabsc2);
+        fval1 := (fval1/absc1)/absc1;
+        fval2 := (fval2/absc2)/absc2;
+        fv1[j] := fval1;
+        fv2[j] := fval2;
+        fsum := fval1+fval2;
+        resg := resg+wg[j]*fsum;
+        resk := resk+wgk[j]*fsum;
+        resabs := resabs+wgk[j]*(abs(fval1)+abs(fval2))
+       End;
+
+      reskh := resk*0.5;
+      resasc := wgk[8]*abs(fc-reskh);
+
+      For j:=1 To 7 
+       Do
+       resasc := resasc+wgk[j]*(abs(fv1[j]-reskh)+abs(fv2[j]-reskh));
+
+      result := resk*hlgth;
+      resasc := resasc*hlgth;
+      resabs := resabs*hlgth;
+      abserr := abs((resk-resg)*hlgth);
+
+      If (resasc<>0) And (abserr<>0)
+       Then
+       Begin
+           reskh := 200*abserr/resasc;
+           If reskh<1
+            Then abserr := resasc*reskh*sqrt(reskh)
+           Else abserr := resasc
+       End;
+
+      If (resabs>midget/(50*macheps))
+       Then
+       Begin
+           reskh := macheps*50*resabs;
+           If abserr<reskh Then abserr := reskh
+       End
+End;
+
+
+
+Procedure qagie(f: rfunc1r;
+                bound: ArbFloat;
+                inf: ArbInt;
+                epsabs, epsrel: ArbFloat;
+                Var result, abserr: ArbFloat;
+                Var ier: ArbInt);
+
+{ procedure qagie is vertaald vanuit de PD-quadpack-Fortran-routine QAGIE
+  naar Turbo Pascal, waarbij de volgende parameters uit de parameterlijst
+  verdwenen zijn:
+      limit , zoiets als 'maximale recursie diepte' vervangen door globale
+              variabele limit, initieel op 500 gezet
+      last  , actuele 'recursie diepte'
+      workarrays: alist, blist, rlist, elist en iord ,
+                  vervangen door dynamische locale arrays
+      neval , het aantal functie-evaluaties
+}
+
+Var  abseps, area, area1, area12, area2,
+     a1, a2, b1,b2, correc,
+     defabs, defab1, defab2, dres,
+     erlarg, erlast, errbnd, h,
+     errmax, error1, error2, erro12, errsum, ertest, resabs,
+     reseps, small: ArbFloat;
+     res3la : hulpar;
+
+     rlist, alist, blist, elist: ^arfloat1;
+     iord: ^arint1;
+     rlist2 : stock;
+     id, ierro, iroff1, iroff2, iroff3, jupbnd,
+     k, ksgn, ktmin, last, maxerr, nres, nrmax, numrl2: ArbInt;
+     continue, break, extrap, noext : boolean;
+Begin
+      ier := 6;
+      h := 50*macheps;
+      If h<0.5e-14 Then h := 0.5e-14;
+      If (epsabs<=0) And (epsrel<h) Then exit;
+
+      If (inf=2) Then bound := 0;
+
+      qk15i(f, bound, inf, 0, 1, result, abserr, defabs, resabs);
+
+      dres := abs(result);
+
+      errbnd := epsrel*dres;
+      If epsabs>errbnd Then errbnd := epsabs;
+
+      ier := 2;
+      If (abserr<=100*macheps*defabs) And (abserr>errbnd) Then exit;
+      ier := 0;
+      If ((abserr<=errbnd) And (abserr<>resabs)) Or (abserr=0) Then exit;
+
+      GetMem(rlist, limit*SizeOf(ArbFloat));
+      GetMem(alist, limit*SizeOf(ArbFloat));
+      GetMem(blist, limit*SizeOf(ArbFloat));
+      GetMem(elist, limit*SizeOf(ArbFloat));
+      GetMem(iord, limit*SizeOf(ArbInt));
+
+      alist^[1] := 0;
+      blist^[1] := 1;
+      rlist^[1] := result;
+      elist^[1] := abserr;
+      iord^[1]  := 1;
+      rlist2[1] := result;
+      errmax    := abserr;
+      maxerr    := 1;
+      area      := result;
+      errsum    := abserr;
+      abserr    := giant;
+      nrmax     := 1;
+      nres      := 0;
+      ktmin     := 0;
+      numrl2    := 2;
+      extrap    := false;
+      noext     := false;
+      ierro     := 0;
+      iroff1    := 0;
+      iroff2    := 0;
+      iroff3    := 0;
+
+      If dres>=(1-50*macheps)*defabs Then ksgn := 1
+ Else ksgn := -1;
+
+      last := 1;
+      continue := true;
+      while (last<limit) and (ier=0) and continue Do
+      Begin
+        Inc(last);
+        a1 := alist^[maxerr];
+        b1 := 0.5*(alist^[maxerr]+blist^[maxerr]);
+        a2 := b1;
+        b2 := blist^[maxerr];
+        erlast := errmax;
+        qk15i(f, bound, inf, a1, b1, area1, error1, resabs, defab1);
+        qk15i(f, bound, inf, a2, b2, area2, error2, resabs, defab2);
+        area12 := area1+area2;
+        erro12 := error1+error2;
+        errsum := errsum+erro12-errmax;
+        area := area+area12-rlist^[maxerr];
+        If (defab1<>error1) And (defab2<>error2)
+         Then
+         Begin
+           If (abs(rlist^[maxerr]-area12)<=1e-5*abs(area12)) And
+              (erro12>=0.99*errmax)
+            Then If extrap Then Inc(iroff2)
+          Else Inc(iroff1);
+           If (last>10) And (erro12>errmax) Then Inc(iroff3)
+         End;
+        rlist^[maxerr] := area1;
+        rlist^[last] := area2;
+
+        errbnd := epsrel*abs(area);
+        If errbnd<epsabs Then errbnd := epsabs;
+
+        If (iroff1+iroff2>=10) Or (iroff3>=20) Then ier := 2;
+        If (iroff2>=5) Then ierro := 3;
+        If (last=limit) Then ier := 1;
+        h := abs(a1);
+       If h<abs(b2) Then h := abs(b2);
+        If h<=(1+100*macheps)*(abs(a2)+1000*midget) Then ier := 3;
+        If (error2<=error1) Then
+         Begin
+           alist^[last] := a2;
+           blist^[maxerr] := b1;
+           blist^[last] := b2;
+           elist^[maxerr] := error1;
+           elist^[last] := error2
+         End
+       Else
+        Begin
+           alist^[maxerr] := a2;
+           alist^[last] := a1;
+           blist^[last] := b1;
+           rlist^[maxerr] := area2;
+           rlist^[last] := area1;
+           elist^[maxerr] := error2;
+           elist^[last] := error1
+        End;
+        qpsrt(limit, last, maxerr, errmax, elist^[1], iord^[1], nrmax);
+
+        If (errsum<=errbnd) Then continue := false;
+
+        If (ier=0) And continue Then
+         If last=2 Then
+          Begin
+            small := 0.375;
+            erlarg := errsum;
+            ertest := errbnd;
+            rlist2[2] := area
+          End
+       Else
+        If Not noext Then
+         Begin
+           erlarg := erlarg-erlast;
+           If (abs(b1-a1)>small) Then erlarg := erlarg+erro12;
+           break := false;
+           If Not extrap Then
+            If (abs(blist^[maxerr]-alist^[maxerr])>small)
+             Then break := true
+           Else
+            Begin
+                extrap :=  true;
+                nrmax := 2
+            End;
+           If Not break And (ierro<>3) And (erlarg>ertest) Then
+            Begin
+              id := nrmax;
+              jupbnd := last;
+              If (last>(2+limit Div 2)) Then jupbnd := limit+3-last;
+              k := id-1;
+              while (k<jupbnd) and not break 
+              Do
+             Begin
+                 Inc(k);
+                 maxerr := iord^[nrmax];
+                 errmax := elist^[maxerr];
+                 If (abs(blist^[maxerr]-alist^[maxerr])>small)
+                  Then break := true
+                 Else Inc(nrmax)
+              End
+            End;
+           If Not break Then
+            Begin
+              Inc(numrl2);
+              rlist2[numrl2] := area;
+              qelg(numrl2, rlist2, reseps, abseps, res3la, nres);
+              Inc(ktmin);
+
+              If (ktmin>5) And (abserr<1e-3*errsum) Then ier := 4;
+
+              If (abseps<abserr)
+               Then
+               Begin
+                  ktmin := 0;
+                  abserr := abseps;
+                  result := reseps;
+                  correc := erlarg;
+                  ertest := epsrel*abs(reseps);
+                  If epsabs>ertest Then ertest := epsabs;
+                  If (abserr<=ertest) Then continue := false
+               End;
+            End;
+           If continue And Not break Then
+            Begin
+              If (numrl2=1) Then noext := true;
+              If ier<>4 Then
+               Begin
+                 maxerr := iord^[1];
+                 errmax := elist^[maxerr];
+                 nrmax := 1;
+                 extrap :=  false;
+                 small := small*0.5;
+                 erlarg := errsum
+               End
+            End
+         End
+      End;
+
+      h := 0;
+ For k := 1 To last Do
+  h := h+rlist^[k];
+      FreeMem(rlist, limit*SizeOf(ArbFloat));
+      FreeMem(alist, limit*SizeOf(ArbFloat));
+      FreeMem(blist, limit*SizeOf(ArbFloat));
+      FreeMem(elist, limit*SizeOf(ArbFloat));
+      FreeMem(iord, limit*SizeOf(ArbInt));
+
+      If (errsum<=errbnd) Or (abserr=giant) Then
+       Begin
+        result := h;
+            abserr := errsum;
+            exit
+       End;
+
+      If (ier+ierro)=0 Then
+       Begin
+           h := abs(result);
+           If h<abs(area) Then h := abs(area);
+           If (ksgn<>-1) Or (h>defabs*0.01) Then
+            If (0.01>result/area) Or (result/area>100) Or (errsum>abs(area))
+             Then ier := 5;
+           exit
+       End;
+
+      If ierro=3 Then abserr := abserr+correc;
+      If ier=0 Then ier := 2;
+
+      If (result<>0) And (area<>0) Then
+       If abserr/abs(result)>errsum/abs(area)
+        Then
+        Begin
+           result := h;
+           abserr := errsum;
+           exit
+        End
+      Else
+       Begin
+           h := abs(result);
+           If h<abs(area) Then h := abs(area);
+           If (ksgn<>-1) Or (h>defabs*0.01) Then
+            If (0.01>result/area) Or (result/area>100) Or (errsum>abs(area))
+             Then ier := 5;
+           exit
+       End;
+
+      If abserr>errsum Then
+       Begin
+        result := h;
+            abserr := errsum;
+            exit
+       End;
+
+      If area<>0
+       Then
+       Begin
+           h := abs(result);
+           If h<abs(area) Then h := abs(area);
+           If (ksgn<>-1) Or (h>defabs*0.01) Then
+            If (0.01>result/area) Or (result/area>100) Or (errsum>abs(area))
+             Then ier := 5
+       End
+End;
+
+Procedure int1fr(f: rfunc1r; a, b, ae: ArbFloat; Var integral, err: ArbFloat;
+                 Var term: ArbInt);
+
+Var neval, ier, last, inf: ArbInt;
+Begin
+     term := 3;
+ integral := NaN;
+     If abs(a)=infinity
+      Then If abs(b)=infinity
+            Then If (a=b)
+                  Then exit
+               Else
+                Begin
+                    qagie(f, 0, 2, ae, epsrel, integral, err, ier);
+                    If a=infinity Then integral := -integral
+                End
+          Else If a=-infinity
+                Then qagie(f, b, -1, ae, epsrel, integral, err, ier)
+               Else
+                Begin
+                    qagie(f, b, 1, ae, epsrel, integral, err, ier);
+                    integral := -integral
+                End
+     Else If abs(b)=infinity
+           Then If b=-infinity
+                 Then
+                 Begin
+                    qagie(f, a, -1, ae, epsrel, integral, err, ier);
+                    integral := -integral
+                 End
+ Else qagie(f, a, 1, ae, epsrel, integral, err, ier)
+          Else qagse(f, a, b, ae, epsrel, limit, integral, err, neval, ier, last);
+     term := 4;
+     If ier=6 Then term := 3;
+     If ier=0 Then term := 1;
+     If (ier=2) Or (ier=4) Then term := 2
+End;
+
+Begin
+    limit    := 500;
+    epsrel   := 0;
+End.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/inv.pas

@@ -0,0 +1,276 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Calculate inverses for different kinds of matrices (different with respect
+                 to symmetry)
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit inv;
+{$I DIRECT.INC}
+
+interface
+
+uses typ;
+
+{Calc inverse for a matrix with unknown symmetry. General version. }
+procedure invgen(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
+
+{Calc inverse for a symmetrical matrix}
+procedure invgsy(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
+
+{Calc inverse for a positive definite symmetrical matrix}
+procedure invgpd(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
+
+implementation
+
+uses mdt, dsl;
+
+procedure invgen(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
+var
+     success                          : boolean;
+     inn, ii, i, j, k, kk, indexpivot : ArbInt;
+     ca, h, pivot, l, s               : ArbFloat;
+     pa, save                         : ^arfloat1;
+     p                                : ^arint1;
+
+begin
+  if (n<1) or (rwidth<1) then
+  begin
+      term:=3; exit
+  end; {wrong input}
+  pa:=@ai;
+  getmem(p, n*sizeof(ArbInt)); getmem(save, n*sizeof(ArbFloat));
+  mdtgen(n, rwidth, pa^[1], p^[1], ca, term);
+  if term=1 then
+  begin
+      inn:=(n-1)*rwidth+n; pivot:=pa^[inn];
+      if pivot=0 then success:=false else
+      begin
+          success:=true; pa^[inn]:=1/pivot; k:=n;
+          while (k>1) and success do
+          begin
+              k:=k-1; kk:=(k-1)*rwidth;
+              for i:=k+1 to n do save^[i]:=-pa^[(i-1)*rwidth+k];
+              for i:=k+1 to n do
+              begin
+                  ii:=(i-1)*rwidth;
+                  s:=0;
+                  for j:=k+1 to n do s:=s+pa^[ii+j]*save^[j];
+                  pa^[ii+k]:=s
+              end; {i}
+              for j:=k+1 to n do save^[j]:=pa^[kk+j];
+              pivot:=pa^[kk+k];
+              if pivot=0 then success:=false else
+              begin
+                  s:=0;
+                  for i:=k+1 to n do s:=s-save^[i]*pa^[(i-1)*rwidth+k];
+                  pa^[kk+k]:=(1+s)/pivot;
+                  for j:=k+1 to n do
+                  begin
+                      s:=0;
+                      for i:=k+1 to n do s:=s-save^[i]*pa^[(i-1)*rwidth+j];
+                      pa^[(k-1)*rwidth+j]:=s/pivot
+                  end {j}
+              end {pivot <> 0}
+          end; {k}
+          if success then
+          for k:=n downto 1 do
+          begin
+              indexpivot:=p^[k];
+              if indexpivot <> k then
+              for i:=1 to n do
+              begin
+                  ii:=(i-1)*rwidth;
+                  h:=pa^[ii+k]; pa^[ii+k]:=pa^[ii+indexpivot];
+                  pa^[ii+indexpivot]:=h
+              end {i}
+          end {k}
+      end; {pivot <> 0}
+      if (not success) then term:=2
+  end else term:=2;
+  freemem(p, n*sizeof(ArbInt)); freemem(save, n*sizeof(ArbFloat));
+end; {invgen}
+
+procedure invgsy(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
+
+var ind, ind1, i, m, pk, j,
+    kmin1, k, imin2, nsr,
+    imin1, jmin1, iplus1            : ArbInt;
+    success                         : boolean;
+    di, h, ca                       : ArbFloat;
+    pa, l, d, u, v, e, e1, x        : ^arfloat1;
+    p                               : ^arint1;
+    q                               : ^arbool1;
+begin
+  if (n<1) or (rwidth<1) then
+  begin
+      term:=3; exit
+  end; {wrong input}
+  pa:=@ai;
+  getmem(p, n*sizeof(ArbInt)); getmem(q, n*sizeof(boolean));
+  nsr:=n*sizeof(ArbFloat);
+  getmem(l, nsr); getmem(d, nsr); getmem(u, nsr);
+  getmem(v, nsr); getmem(e, nsr); getmem(e1, nsr);
+  getmem(x, ((n+1)*nsr) div 2);
+  mdtgsy(n, rwidth, pa^[1], p^[1], q^[1], ca, term);
+  if term=1 then
+  begin
+      success:=true; i:=1; ind:=1;
+      while (i<>n+1) and success do
+      begin
+          success:=pa^[ind]<>0; ind:=ind+rwidth+1; i:=i+1
+      end; {i}
+      if success then
+      begin
+          d^[1]:=pa^[1]; di:=d^[1]; l^[1]:=pa^[rwidth+1];
+          d^[2]:=pa^[rwidth+2]; di:=d^[2]; u^[1]:=pa^[2];
+          imin1:=1; i:=2;
+          while i<n do
+          begin
+              imin2:=imin1; imin1:=i; i:=i+1; ind:=imin1*rwidth;
+              l^[imin1]:=pa^[ind+imin1]; d^[i]:=pa^[ind+i]; di:=d^[i];
+              u^[imin1]:=pa^[ind-rwidth+i]; v^[imin2]:=pa^[ind-2*rwidth+i]
+          end; {i}
+          m:=0; k:=0;
+          while k<n do
+          begin
+              kmin1:=k; k:=k+1;
+              for i:=1 to kmin1 do e^[i]:=0;
+              e^[k]:=1; i:=k;
+              while i<n do
+              begin
+                  imin1:=i; i:=i+1; h:=0;
+                  if k=1 then j:=1 else j:=kmin1;
+                  while j<imin1 do
+                  begin
+                      jmin1:=j; j:=j+1;
+                      h:=h-pa^[(i-1)*rwidth+jmin1]*e^[j]
+                  end; {j}
+                  e^[i]:=h
+              end; {i}
+              dslgtr(n, l^[1], d^[1], u^[1], v^[1], q^[1],
+                     e^[1], e1^[1], term);
+              i:=n+1; imin1:=n;
+              while i>2 do
+              begin
+                  iplus1:=i; i:=imin1; imin1:=imin1-1; h:=e1^[i];
+                  for j:=iplus1 to n do
+                    h:=h-pa^[(j-1)*rwidth+imin1]*e1^[j];
+                  e1^[i]:=h
+              end; {i}
+              for i:=k to n do
+              begin
+                  m:=m+1; x^[m]:=e1^[i]
+              end
+          end; {k}
+          m:=0;
+          for k:=1 to n do for i:=k to n do
+          begin
+              m:=m+1; pa^[(i-1)*rwidth+k]:=x^[m]
+          end; {i,k}
+          for k:=n-1 downto 2 do
+          begin
+              pk:=p^[k];
+              if pk <> k then
+              begin
+                  kmin1:=k-1; ind:=(k-1)*rwidth; ind1:=(pk-1)*rwidth;
+                  for j:=1 to kmin1 do
+                  begin
+                      h:=pa^[ind+j];
+                      pa^[ind+j]:=pa^[ind1+j]; pa^[ind1+j]:=h
+                  end; {j}
+                  for j:=pk downto k do
+                  begin
+                      ind:=(j-1)*rwidth;
+                      h:=pa^[ind+k];
+                      pa^[ind+k]:=pa^[ind1+j]; pa^[ind1+j]:=h
+                  end; {j}
+                  for i:=pk to n do
+                  begin
+                      ind:=(i-1)*rwidth;
+                      h:=pa^[ind+k];
+                      pa^[ind+k]:=pa^[ind+pk]; pa^[ind+pk]:=h
+                  end {i}
+              end {pk <> k}
+          end {k}
+      end; {success}
+      if (not success) then term:=2 else
+      for i:=1 to n do
+      begin
+          ind:=(i-1)*rwidth;
+          for j:=i+1 to n do pa^[ind+j]:=pa^[(j-1)*rwidth+i]
+      end {i}
+  end else term:=2;
+  freemem(l, nsr); freemem(d, nsr); freemem(u, nsr);
+  freemem(v, nsr); freemem(e, nsr); freemem(e1, nsr);
+  freemem(x, ((n+1)*nsr) div 2);
+end; {invgsy}
+
+procedure invgpd(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt);
+var success             : boolean;
+    i, j, k, kmin1, ind : ArbInt;
+    tk, h, ca           : ArbFloat;
+    pa, t               : ^arfloat1;
+begin
+  if (n<1) or (rwidth<1) then
+  begin
+      term:=3; exit
+  end; {wrong input}
+  pa:=@ai;
+  mdtgpd(n, rwidth, pa^[1], ca, term);
+  getmem(t, n*sizeof(ArbFloat));
+  if term=1 then
+  begin
+      success:=true; ind:=1; k:=1;
+      while (k<>n+1) and success do
+      begin
+          success:=pa^[ind]<>0; k:=k+1; ind:=ind+rwidth+1
+      end; {k}
+      if success then
+      begin
+          for k:=n downto 1 do
+          begin
+              for i:=k to n do t^[i]:=pa^[(i-1)*rwidth+k];
+              tk:=t^[k];
+              for i:=n downto k do
+              begin
+                  if i=k then h:=1/tk else h:=0;
+                  ind:=(i-1)*rwidth;
+                  for j:=k+1 to i do h:=h-pa^[ind+j]*t^[j];
+                  for j:=i+1 to n do h:=h-pa^[(j-1)*rwidth+i]*t^[j];
+                  pa^[ind+k]:=h/tk
+              end {i}
+          end {k}
+      end; {success}
+      if (not success) then term:=2 else
+      for i:=1 to n do
+      begin
+          ind:=(i-1)*rwidth;
+          for j:=i+1 to n do pa^[ind+j]:=pa^[(j-1)*rwidth+i]
+      end; {i}
+  end; {term=1}
+  freemem(t, n*sizeof(ArbFloat));
+end; {invgpd}
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/iom.pas

@@ -0,0 +1,119 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Basic In and output of matrix and vector types. Maybe too simple for
+    your application, but still handy for logging and debugging.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit iom;
+
+interface
+{$I direct.inc}
+
+uses typ;
+
+const
+    npos  : ArbInt = 78;
+
+{Read a n-dimensional vector v from textfile}
+procedure iomrev(var inp: text; var v: ArbFloat; n: ArbInt);
+
+{Read a m x n-dimensional matrix a from textfile}
+procedure iomrem(var inp: text; var a: ArbFloat; m, n, rwidth: ArbInt);
+
+{Write a n-dimensional vectorv v to textfile}
+procedure iomwrv(var out: text; var v: ArbFloat; n, form: ArbInt);
+
+{Write a m x n-dimensional matrix a to textfile}
+procedure iomwrm(var out: text; var a: ArbFloat; m, n, rwidth, form: ArbInt);
+
+implementation
+
+procedure iomrev(var inp: text; var v: ArbFloat; n: ArbInt);
+
+var pv : ^arfloat1;
+     i : ArbInt;
+
+BEGIN
+  pv:=@v; for i:=1 to n do read(inp, pv^[i])
+END {iomrev};
+
+procedure iomrem(var inp: text; var a: ArbFloat; m, n, rwidth: ArbInt);
+
+var    pa : ^arfloat1;
+     i, k : ArbInt;
+
+BEGIN
+  pa:=@a; k:=1;
+  for i:=1 to m do
+    BEGIN
+      iomrev(inp, pa^[k], n); Inc(k, rwidth)
+    END
+END {iomrem};
+
+procedure iomwrv(var out: text; var v: ArbFloat; n, form: ArbInt);
+
+var  pv     : arfloat1 absolute v;
+     i, i1  : ArbInt;
+BEGIN
+  if form>maxform then form:=maxform  else
+  if form<minform then form:=minform;
+  i1:=npos div (form+2);
+  for i:=1 to n do
+  if ((i mod i1)=0) or (i=n) then writeln(out, pv[i]:form)
+                             else write(out, pv[i]:form, '':2)
+END {iomwrv};
+
+procedure iomwrm(var out: text; var a: ArbFloat; m, n, rwidth, form: ArbInt);
+
+var  pa                            : ^arfloat1;
+     i, k, nb, i1, l, j, r, l1, kk : ArbInt;
+
+BEGIN
+  if (n<1) or (m<1) then exit;
+  pa:=@a;
+  if form>maxform then form:=maxform else
+  if form<minform then form:=minform;
+  i1:=npos div (form+2); l1:=0;
+  nb:=n div i1; r:=n mod i1;
+  if r>0 then Inc(nb);
+  for l:=1 to nb do
+    BEGIN
+      k:=l1+1; if (r>0) and (l=nb) then i1:=r;
+      for i:=1 to m do
+        BEGIN
+          kk:=k;
+          for j:=1 to i1-1 do
+            BEGIN
+              write(out, pa^[kk]:form, '':2); Inc(kk)
+            END;
+          writeln(out, pa^[kk]:form); Inc(k, rwidth)
+        END;
+      Inc(l1, i1); if l<nb then writeln(out)
+    END;
+END {iomwrm};
+
+END.
+
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/ipf.pas

@@ -0,0 +1,891 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Interpolate and (curve) fitting.
+    Slegpb in this unit patched parameters slightly. Units IPF and sle
+    were not in the same revision in this numlib copy (which was a
+    copy of the work directory of the author) .
+
+    Contains two undocumented functions. If you recognize the algoritm,
+    mail us.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{
+ }
+unit ipf;
+{$I direct.inc}
+interface
+
+uses typ, mdt, dsl, sle, spe;
+
+{ Determine natural cubic spline "s" for data set (x,y), output to (a,d2a)
+ term=1 success,
+     =2 failure calculating "s"
+     =3 wrong input (e.g. x,y is not sorted increasing on x)}
+procedure ipffsn(n: ArbInt; var x, y, a, d2a: ArbFloat; var term: ArbInt);
+
+{calculate d2s from x,y, which can be used to calculate s}
+procedure ipfisn(n: ArbInt; var x, y, d2s: ArbFloat; var term: ArbInt);
+
+{Calculate function value for dataset (x,y), with n.c. spline d2s for
+x value t. Return (corrected) y value.
+s calculated from x,y, with e.g. ipfisn}
+function  ipfspn(n: ArbInt; var x, y, d2s: ArbFloat; t: ArbFloat;
+                 var term: ArbInt): ArbFloat;
+
+{Calculate n-degree polynomal b for dataset (x,y) with n elements
+ using the least squares method.}
+procedure ipfpol(m, n: ArbInt; var x, y, b: ArbFloat; var term: ArbInt);
+
+
+                {**** undocumented ****}
+
+function spline(    n     : ArbInt;
+                    x     : complex;
+                var ac    : complex;
+                var gammar: ArbFloat;
+                    u1    : ArbFloat;
+                    pf    : complex): ArbFloat;
+
+                {**** undocumented ****}
+
+procedure splineparameters
+          (    n                 : ArbInt;
+           var ac, alfadc        : complex;
+           var lambda,
+               gammar, u1,
+               kwsom, energie    : ArbFloat;
+           var pf                : complex);
+
+implementation
+
+
+procedure ipffsn(n: ArbInt; var x, y, a, d2a: ArbFloat; var term: ArbInt);
+
+var                    i, j, sr, n1s, ns1, ns2: ArbInt;
+   s, lam, lam0, lam1, lambda, ey, ca, p, q, r: ArbFloat;
+     px, py, pd, pa, pd2a,
+  h, z, diagb, dinv, qty, qtdinvq, c, t, tl: ^arfloat1;
+                                         ub: boolean;
+
+  procedure solve; {n, py, qty, h, qtdinvq, dinv, lam, t, pa, pd2a, term}
+  var i: ArbInt;
+      p, q, r, ca: ArbFloat;
+             f, c: ^arfloat1;
+  begin
+    getmem(f, 3*ns1); getmem(c, ns1);
+    for i:=1 to n-1 do
+      begin
+        f^[3*i]:=qtdinvq^[3*i]+lam*t^[2*i];
+        if i > 1
+        then
+          f^[3*i-1]:=qtdinvq^[3*i-1]+lam*t^[2*i-1];
+        if i > 2
+        then
+          f^[3*i-2]:=qtdinvq^[3*i-2];
+        if lam=0
+        then
+          c^[i]:=qty^[i]
+        else
+          c^[i]:=lam*qty^[i]
+      end;
+    slegpb(n-1, 2,{ 3,} f^[1], c^[1], pd2a^[1], ca, term);
+    if term=2
+    then
+      begin
+        freemem(f, 3*ns1); freemem(c, ns1);
+        exit
+      end;
+    p:=1/h^[1];
+    if lam=0
+    then
+      r:=1
+    else
+      r:=1/lam;
+    q:=1/h^[2]; pa^[1]:=py^[1]-r*dinv^[1]*p*pd2a^[1];
+    pa^[2]:=py^[2]-r*dinv^[2]*(pd2a^[2]*q-(p+q)*pd2a^[1]); p:=q;
+    for i:=3 to n-1 do
+      begin
+        q:=1/h^[i];
+        pa^[i]:=py^[i]-r*dinv^[i]*
+                (p*pd2a^[i-2]-(p+q)*pd2a^[i-1]+q*pd2a^[i]);
+        p:=q
+      end;
+    q:=1/h^[n];
+    pa^[n]:=py^[n]-r*dinv^[n]*(p*pd2a^[n-2]-(p+q)*pd2a^[n-1]);
+    pa^[n+1]:=py^[n+1]-r*dinv^[n+1]*q*pd2a^[n-1];
+    if lam=0
+    then
+      for i:=1 to n-1 do
+        pd2a^[i]:=0;
+    freemem(f, 3*ns1); freemem(c, ns1);
+  end; {solve}
+
+    function e(var c, h: ArbFloat; n:ArbInt): ArbFloat;
+    var i:ArbInt;
+        s:ArbFloat;
+        pc, ph: ^arfloat1;
+    begin
+      ph:=@h; pc:=@c;
+      s:=ph^[1]*pc^[1]*pc^[1];
+      for i:=1 to n-2 do
+        s:=s+(pc^[i]*(pc^[i]+pc^[i+1])+pc^[i+1]*pc^[i+1])*ph^[i+1];
+      e:=(s+pc^[n-1]*pc^[n-1]*ph^[n])/3
+    end; {e}
+
+    function cr(lambda: ArbFloat): ArbFloat;
+    var s, crs: ArbFloat;
+             i: ArbInt;
+    begin
+      cr:=0; lam:=lambda;
+      solve; { n, py, qty, h, qtdinvq, dinv, lam, t, pa, pd2a, term }
+      if term=2
+      then
+        exit;
+      crs:=ey;
+      if lam <> 0
+      then
+        begin
+          crs:=crs+e(pd2a^[1], h^[1], n);
+          s:=0;
+          for i:=1 to n-1 do
+            s:=s+pd2a^[i]*qty^[i];
+          crs:=crs-2*s
+        end;
+      s:=0;
+      for i:=1 to n+1 do
+        s:=s+sqr(pa^[i]-py^[i])*diagb^[i];
+      cr:=crs-s
+    end; {cr}
+
+    procedure roof1r(a, b, ae, re: ArbFloat; var x: ArbFloat);
+
+    var fa, fb, c, fc, m, tol, w1, w2 : ArbFloat;
+                                    k : ArbInt;
+                                 stop : boolean;
+
+    begin
+      fa:=cr(a);
+      if term=2
+      then
+        exit;
+      fb:=cr(b);
+      if term=2
+      then
+        exit;
+      if abs(fb)>abs(fa)
+      then
+        begin
+          c:=b; fc:=fb; x:=a; b:=a; fb:=fa; a:=c; fa:=fc
+        end
+      else
+        begin
+          c:=a; fc:=fa; x:=b
+        end;
+      k:=0;
+      tol:=ae+re*spemax(abs(a), abs(b));
+      w1:=abs(b-a); stop:=false;
+      while (abs(b-a)>tol) and (fb<>0) and (not stop) do
+        begin
+          m:=(a+b)/2;
+          if (k>=2) or (fb=fc)
+          then
+            x:=m
+          else
+            begin
+              x:=(b*fc-c*fb)/(fc-fb);
+              if abs(b-x)<tol
+              then
+                x:=b-tol*spesgn(b-a);
+              if spesgn(x-m)=spesgn(x-b)
+              then
+                x:=m
+            end;
+          c:=b; fc:=fb; b:=x; fb:=cr(x);
+          if term=2
+          then
+            exit;
+          if spesgn(fa)*spesgn(fb)>0
+          then
+            begin
+              a:=c; fa:=fc; k:=0
+            end
+          else
+            k:=k+1;
+          if abs(fb)>=abs(fa)
+          then
+            begin
+              c:=b; fc:=fb; x:=a; b:=a; fb:=fa; a:=c; fa:=fc; k:=0
+            end;
+          tol:=ae+re*spemax(abs(a), abs(b));
+          w2:=abs(b-a);
+          if w2>=w1
+          then
+            stop:=true;
+          w1:=w2
+        end
+    end; {roof1r}
+
+procedure NoodGreep;
+var I, j: ArbInt;
+begin
+  i:=1;
+  while i <= n do
+    begin
+      if (pd^[i] <= 0) or (px^[i+1] <= px^[i])
+      then
+        begin
+          term:=3;
+          exit
+        end;
+      i:=i+1
+    end;
+  if pd^[n+1] <= 0
+  then
+    begin
+      term:=3;
+      exit
+    end;
+  for i:=1 to n+1 do
+    dinv^[i]:=1/pd^[i];
+  for i:=1 to n do
+    h^[i]:=px^[i+1]-px^[i];
+  t^[2]:=(h^[1]+h^[2])/3;
+  for i:=2 to n-1 do
+    begin
+      t^[2*i]:=(h^[i]+h^[i+1])/3; t^[2*i-1]:=h^[i]/6
+    end;
+  move(t^[1], tl^[1], ns2);
+  mdtgpb(n-1, 1, 2, tl^[1], ca, term);
+  if term=2
+  then
+    exit;
+  z^[1]:=1/(h^[1]*tl^[2]);
+  for j:=2 to n-1 do
+    z^[j]:=-(tl^[2*j-1]*z^[j-1])/tl^[2*j];
+  s:=0;
+  for j:=1 to n-1 do
+    s:=s+sqr(z^[j]);
+  diagb^[1]:=s;
+  z^[1]:=(-1/h^[1]-1/h^[2])/tl^[2];
+  if n>2
+  then
+    z^[2]:=(1/h^[2]-tl^[3]*z^[1])/tl^[4];
+  for j:=3 to n-1 do
+    z^[j]:=-tl^[2*j-1]*z^[j-1]/tl^[2*j];
+  s:=0;
+  for j:=1 to n-1 do
+    s:=s+sqr(z^[j]);
+  diagb^[2]:=s;
+  for i:=2 to n-2 do
+    begin
+      z^[i-1]:=1/(h^[i]*tl^[2*(i-1)]);
+      z^[i]:=(-1/h^[i]-1/h^[i+1]-tl^[2*i-1]*z^[i-1])/tl^[2*i];
+      z^[i+1]:=(1/h^[i+1]-tl^[2*i+1]*z^[i])/tl^[2*(i+1)];
+      for j:=i+2 to n-1 do
+        z^[j]:=-tl^[2*j-1]*z^[j-1]/tl^[2*j];
+      s:=0;
+      for j:=i-1 to n-1 do
+        s:=s+sqr(z^[j]);
+      diagb^[i+1]:=s
+    end;
+  z^[n-2]:=1/(h^[n-1]*tl^[2*(n-2)]);
+  z^[n-1]:=(-1/h^[n-1]-1/h^[n]-tl^[2*n-3]*z^[n-2])/tl^[2*(n-1)];
+  s:=0;
+  for j:=n-2 to n-1 do
+    s:=s+sqr(z^[j]);
+  diagb^[n]:=s;
+  diagb^[n+1]:=1/sqr(h^[n]*tl^[2*(n-1)]);
+  p:=1/h^[1];
+  for i:=2 to n do
+    begin
+      q:=1/h^[i]; qty^[i-1]:=py^[i+1]*q-py^[i]*(p+q)+py^[i-1]*p;
+      p:=q
+    end;
+  p:=1/h^[1]; q:=1/h^[2]; r:=1/h^[3];
+  qtdinvq^[3]:=dinv^[1]*p*p+dinv^[2]*(p+q)*(p+q)+dinv^[3]*q*q;
+  if n>2
+  then
+    begin
+      qtdinvq^[6]:=dinv^[2]*q*q+dinv^[3]*(q+r)*(q+r)+dinv^[4]*r*r;
+      qtdinvq^[5]:=-(dinv^[2]*(p+q)+dinv^[3]*(q+r))*q;
+      p:=q; q:=r;
+      for i:=3 to n-1 do
+        begin
+          r:=1/h^[i+1];
+          qtdinvq^[3*i]:=dinv^[i]*q*q+dinv^[i+1]*(q+r)*(q+r)+dinv^[i+2]*r*r;
+          qtdinvq^[3*i-1]:=-(dinv^[i]*(p+q)+dinv^[i+1]*(q+r))*q;
+          qtdinvq^[3*i-2]:=dinv^[i]*p*q;
+          p:=q; q:=r
+        end
+    end;
+  dslgpb(n-1, 1, 2, tl^[1], qty^[1], c^[1], term);
+  if term=2
+  then
+    exit;
+  ey:=e(c^[1], h^[1], n);
+  lam0:=0;
+  s:=cr(lam0);
+  if term=2
+  then
+    exit;
+  if s >= 0
+  then
+    begin
+      lambda:=0; term:=4
+    end
+  else
+    begin
+      lam1:=1e-8; ub:=false;
+      while (not ub) and (lam1<=1.1e8) do
+        begin
+          s:=cr(lam1);
+          if term=2
+          then
+            exit;
+          if s  >= 0
+          then
+            ub:=true
+          else
+            begin
+              lam0:=lam1; lam1:=10*lam1
+            end
+        end;
+      if not ub
+      then
+        begin
+          term:=4; lambda:=lam0
+        end
+      else
+        roof1r(lam0, lam1, 0, 1e-6, lambda);
+      if term=2
+      then
+        exit
+    end;
+
+end;
+
+begin
+  term:=1;
+  if n < 2
+  then
+    begin
+      term:=3; exit
+    end;
+  sr:=sizeof(ArbFloat);
+  n1s:=(n+1)*sr;
+  ns2:=2*(n-1)*sr;
+  ns1:=(n-1)*sr;
+  getmem(dinv, n1s);
+  getmem(h, n*sr);
+  getmem(t, ns2);
+  getmem(tl, ns2);
+  getmem(z, ns1);
+  getmem(diagb, n1s);
+  getmem(qtdinvq, 3*ns1);
+  getmem(c, ns1);
+  getmem(qty, ns1);
+
+   getmem(pd, n1s);
+ { pd:=@d; }
+  px:=@x;
+  py:=@y;
+  pa:=@a;
+  pd2a:=@d2a;
+  { de gewichten van de punten worden op 1 gezet}
+  for i:=1 to n+1 do
+    pd^[i]:=1;
+
+  NoodGreep;
+
+  freemem(dinv, n1s);
+  freemem(h, n*sr);
+  freemem(t, ns2);
+  freemem(tl, ns2);
+  freemem(z, ns1);
+  freemem(diagb, n1s);
+  freemem(qtdinvq, 3*ns1);
+  freemem(c, ns1);
+  freemem(qty, ns1);
+
+  freemem(pd, n1s);
+end; {ipffsn}
+
+procedure ortpol(m, n: ArbInt; var x, alfa, beta: ArbFloat);
+
+var
+                             i, j, ms : ArbInt;
+    xppn1, ppn1, ppn, p, alfaj, betaj : ArbFloat;
+               px, pal, pbe, pn, pn1 : ^arfloat1;
+                                 temp : pointer;
+begin
+  mark(temp);
+  px:=@x; pal:=@alfa; pbe:=@beta; ms:=m*sizeof(ArbFloat);
+  getmem(pn, ms); getmem(pn1, ms);
+  xppn1:=0; ppn1:=m;
+  for i:=1 to m do
+    begin
+      pn^[i]:=0; pn1^[i]:=1; xppn1:=xppn1+px^[i]
+    end;
+  pal^[1]:=xppn1/ppn1; pbe^[1]:=0;
+  for j:=2 to n do
+    begin
+      alfaj:=pal^[j-1]; betaj:=pbe^[j-1];
+      ppn:=ppn1; ppn1:=0; xppn1:=0;
+      for i:=1 to m do
+        begin
+          p:=(px^[i]-alfaj)*pn1^[i]-betaj*pn^[i];
+          pn^[i]:=pn1^[i]; pn1^[i]:=p; p:=p*p;
+          ppn1:=ppn1+p; xppn1:=xppn1+px^[i]*p
+        end; {i}
+      pal^[j]:=xppn1/ppn1; pbe^[j]:=ppn1/ppn
+    end; {j}
+  release(temp)
+end; {ortpol}
+
+procedure ortcoe(m, n: ArbInt; var x, y, alfa, beta, a: ArbFloat);
+
+var                        i, j, mr : ArbInt;
+         fpn, ppn, p, alphaj, betaj : ArbFloat;
+    px, py, pal, pbe, pa, pn, pn1 : ^arfloat1;
+                               temp : pointer;
+
+begin
+  mark(temp); mr:=m*sizeof(ArbFloat);
+  px:=@x; py:=@y; pal:=@alfa; pbe:=@beta; pa:=@a;
+  getmem(pn, mr); getmem(pn1, mr);
+  fpn:=0;
+  for i:=1 to m do
+    begin
+      pn^[i]:=0; pn1^[i]:=1; fpn:=fpn+py^[i]
+    end; {i}
+  pa^[1]:=fpn/m;
+  for j:=1 to n do
+    begin
+      fpn:=0; ppn:=0; alphaj:=pal^[j]; betaj:=pbe^[j];
+      for i:=1 to m do
+        begin
+          p:=(px^[i]-alphaj)*pn1^[i]-betaj*pn^[i];
+          pn^[i]:=pn1^[i]; pn1^[i]:=p;
+          fpn:=fpn+py^[i]*p; ppn:=ppn+p*p
+        end; {i}
+      pa^[j+1]:=fpn/ppn
+    end; {j}
+  release(temp)
+end; {ortcoe}
+
+procedure polcoe(n:ArbInt; var alfa, beta, a, b: ArbFloat);
+
+var            k, j : ArbInt;
+           pal, pbe : ^arfloat1;
+            pa, pb  : ^arfloat0;
+
+begin
+  pal:=@alfa; pbe:=@beta; pa:=@a; pb:=@b;
+  move(pa^[0], pb^[0], (n+1)*sizeof(ArbFloat));
+  for j:=0 to n-1 do
+    for k:=n-j-1 downto 0 do
+      begin
+        pb^[k+j]:=pb^[k+j]-pal^[k+1]*pb^[k+j+1];
+        if k+j<>n-1
+        then
+          pb^[k+j]:=pb^[k+j]-pbe^[k+2]*pb^[k+j+2]
+      end
+end; {polcoe}
+
+procedure ipfpol(m, n: ArbInt; var x, y, b: ArbFloat; var term: ArbInt);
+
+var                      i, ns: ArbInt;
+                          fsum: ArbFloat;
+            px, py, alfa, beta: ^arfloat1;
+                         pb, a: ^arfloat0;
+begin
+  if (n<0) or (m<1)
+  then
+    begin
+      term:=3; exit
+    end;
+  term:=1;
+  if n = 0
+  then
+    begin
+      py:=@y; pb:=@b;
+      fsum:=0;
+      for i:=1 to m do
+        fsum:=fsum+py^[i];
+      pb^[0]:=fsum/m
+    end
+  else
+    begin
+      if n>m-1
+      then
+        begin
+          pb:=@b;
+          fillchar(pb^[m], (n-m+1)*sizeof(ArbFloat), 0);
+          n:=m-1
+        end;
+      ns:=n*sizeof(ArbFloat);
+      getmem(alfa, ns); getmem(beta, ns);
+      getmem(a, (n+1)*sizeof(ArbFloat));
+      ortpol(m, n, x, alfa^[1], beta^[1]);
+      ortcoe(m, n, x, y, alfa^[1], beta^[1], a^[0]);
+      polcoe(n, alfa^[1], beta^[1], a^[0], b);
+      freemem(alfa, ns); freemem(beta, ns);
+      freemem(a, (n+1)*sizeof(ArbFloat));
+    end
+end; {ipfpol}
+
+procedure ipfisn(n: ArbInt; var x, y, d2s: ArbFloat; var term: ArbInt);
+
+var
+                   s, i : ArbInt;
+               p, q, ca : ArbFloat;
+        px, py, h, b, t : ^arfloat0;
+                   pd2s : ^arfloat1;
+begin
+  px:=@x; py:=@y; pd2s:=@d2s;
+  term:=1;
+  if n < 2
+  then
+    begin
+      term:=3; exit
+    end; {n<2}
+  s:=sizeof(ArbFloat);
+  getmem(h, n*s);
+  getmem(b, (n-1)*s);
+  getmem(t, 2*(n-1)*s);
+  for i:=0 to n-1 do
+    h^[i]:=px^[i+1]-px^[i];
+  q:=1/6; p:=2*q;
+  t^[1]:=p*(h^[0]+h^[1]);
+  for i:=2 to n-1 do
+    begin
+      t^[2*i-1]:=p*(h^[i-1]+h^[i]); t^[2*i-2]:=q*h^[i-1]
+    end; {i}
+  p:=1/h^[0];
+  for i:=2 to n do
+    begin
+      q:=1/h^[i-1]; b^[i-2]:=py^[i]*q-py^[i-1]*(p+q)+py^[i-2]*p; p:=q
+    end;
+  slegpb(n-1, 1, {2,} t^[0], b^[0], pd2s^[1], ca, term);
+  freemem(h, n*s);
+  freemem(b, (n-1)*s);
+  freemem(t, 2*(n-1)*s);
+end; {ipfisn}
+
+function ipfspn(n: ArbInt; var x, y, d2s: ArbFloat; t:ArbFloat;
+                var term: ArbInt): ArbFloat;
+
+var
+   px, py       : ^arfloat0;
+   pd2s         : ^arfloat1;
+   i, j, m      : ArbInt;
+   d, s3, h, dy : ArbFloat;
+begin
+  i:=1; term:=1;
+  if n<2
+  then
+    begin
+      term:=3; exit
+    end; {n<2}
+  px:=@x; py:=@y; pd2s:=@d2s;
+  if t <= px^[0]
+  then
+    begin
+      h:=px^[1]-px^[0];
+      dy:=(py^[1]-py^[0])/h-h*pd2s^[1]/6;
+      ipfspn:=py^[0]+(t-px^[0])*dy
+    end { t <= x[0] }
+  else
+  if t >= px^[n]
+  then
+    begin
+      h:=px^[n]-px^[n-1];
+      dy:=(py^[n]-py^[n-1])/h+h*pd2s^[n-1]/6;
+      ipfspn:=py^[n]+(t-px^[n])*dy
+    end { t >= x[n] }
+  else
+    begin
+      i:=0; j:=n;
+      while j <> i+1 do
+        begin
+          m:=(i+j) div 2;
+          if t>=px^[m]
+          then
+            i:=m
+          else
+            j:=m
+        end; {j}
+      h:=px^[i+1]-px^[i];
+      d:=t-px^[i];
+      if i=0
+      then
+        begin
+          s3:=pd2s^[1]/h;
+          dy:=(py^[1]-py^[0])/h-h*pd2s^[1]/6;
+          ipfspn:=py^[0]+d*(dy+d*d*s3/6)
+        end
+      else
+      if i=n-1
+      then
+        begin
+          s3:=-pd2s^[n-1]/h;
+          dy:=(py^[n]-py^[n-1])/h-h*pd2s^[n-1]/3;
+          ipfspn:=py^[n-1]+d*(dy+d*(pd2s^[n-1]/2+d*s3/6))
+        end
+      else
+        begin
+          s3:=(pd2s^[i+1]-pd2s^[i])/h;
+          dy:=(py^[i+1]-py^[i])/h-h*(2*pd2s^[i]+pd2s^[i+1])/6;
+          ipfspn:=py^[i]+d*(dy+d*(pd2s^[i]/2+d*s3/6))
+        end
+   end  { x[0] < t < x[n] }
+end; {ipfspn}
+
+function p(x, a, z:complex): ArbFloat;
+begin
+      x.sub(a);
+      p:=x.Inp(z)
+end;
+
+function e(x, y: complex): ArbFloat;
+const c1: ArbFloat = 0.01989436788646;
+var s: ArbFloat;
+begin x.sub(y);
+      s := x.norm;
+      if s=0 then e:=0 else e:=c1*s*ln(s)
+end;
+
+function spline(    n     : ArbInt;
+                    x     : complex;
+                var ac    : complex;
+                var gammar: ArbFloat;
+                    u1    : ArbFloat;
+                    pf    : complex): ArbFloat;
+var i     : ArbInt;
+    s     : ArbFloat;
+    a     : arcomp0 absolute ac;
+    gamma : arfloat0 absolute gammar;
+begin
+    s := u1 + p(x, a[n-2], pf);
+    for i:=0 to n do s := s + gamma[i]*e(x,a[i]);
+    spline := s
+end;
+
+procedure splineparameters
+          (    n                 : ArbInt;
+           var ac, alfadc        : complex;
+           var lambda,
+               gammar, u1,
+               kwsom, energie    : ArbFloat;
+           var pf                : complex);
+
+   procedure SwapC(var v, w: complex);
+   var x: complex;
+   begin
+       x := v; v := w; w := x
+   end;
+
+   procedure pxpy(a, b, c: complex; var p:complex);
+   var det: ArbFloat;
+   begin
+        b.sub(a); c.sub(a); det := b.xreal*c.imag-b.imag*c.xreal;
+        b.sub(c); p.Init(b.imag/det, -b.xreal/det)
+   end;
+
+   procedure pfxpfy(a, b, c: complex; f: vector; var pf: complex);
+   begin
+      b.sub(a); c.sub(a);
+      f.j := f.j-f.i; f.k := f.k-f.i;
+      pf.init(f.j*c.imag - f.k*b.imag, -f.j*c.xreal + f.k*b.xreal);
+      pf.scale(1/(b.xreal*c.imag - b.imag*c.xreal))
+   end;
+
+   function InpV(n: ArbInt; var v1, v2: ArbFloat): ArbFloat;
+   var i: ArbInt;
+       a1: arfloat0 absolute v1;
+       a2: arfloat0 absolute v2;
+       s : ArbFloat;
+   begin
+       s := 0;
+       for i:=0 to n-1 do s := s + a1[i]*a2[i];
+       InpV := s
+   end;
+
+   PROCEDURE SPDSOL(    N  : INTEGER;
+                    VAR AP : pointer;
+                    VAR B  : ArbFloat);
+   VAR I, J, K : INTEGER;
+       H       : ArbFloat;
+       a       : ^ar2dr absolute ap;
+       bx      : arfloat0 absolute b;
+   BEGIN
+      for k:=0 to n do
+      BEGIN
+          h := sqrt(a^[k]^[k]-InpV(k, a^[k]^[0], a^[k]^[0]));
+          a^[k]^[k] := h;
+          FOR I:=K+1 TO N do a^[i]^[k] := (a^[i]^[k] - InpV(k, a^[k]^[0], a^[i]^[0]))/h;
+          BX[K] := (bx[k] - InpV(k, a^[k]^[0], bx[0]))/h
+      END;
+      FOR I:=N DOWNTO 0 do
+      BEGIN
+          H := BX[I];
+          FOR J:=I+1 TO N DO H := H - A^[J]^[I]*BX[J];
+          BX[I] := H/A^[I]^[I]
+      END
+   END;
+
+var i, j, i1 : ArbInt;
+    x, h,
+    absdet,
+    absdetmax,
+    s, s1, ca: ArbFloat;
+    alfa, dv, hulp,
+    u, v, w  : vector;
+    e22      : array[0..2] of vector;
+    e21, b   : ^arvect0;
+    k, c     : ^ar2dr;
+    gamma    : arfloat0 absolute gammar;
+    an2, an1, an, z,
+    vz, wz   : complex;
+    a        : arcomp0 absolute ac;
+    alfad    : arcomp0 absolute alfadc;
+
+begin
+
+  i1:=0;
+  x:=a[0].xreal;
+  for i:=1 to n do
+  begin
+       h:=a[i].xreal;
+       if h<x then begin i1:=i; x:=h end
+  end;
+  SwapC(a[n-2], a[i1]);
+  SwapC(alfad[n-2], alfad[i1]);
+
+  x:=a[0].xreal;
+  i1 := 0;
+  for i:=1 to n do
+  begin
+       h:=a[i].xreal;
+       if h>x then begin i1:=i; x:=h end
+  end;
+  SwapC(a[n-1], a[i1]);
+  SwapC(alfad[n-1], alfad[i1]);
+
+  vz := a[n-2]; vz.sub(a[n-1]);
+
+  absdetmax := -1;
+  for i:=0 to n do
+  begin
+    wz := a[i]; wz.sub(a[n-2]);
+    absdet := abs(wz.imag*vz.xreal-wz.xreal*vz.imag);
+    if absdet>absdetmax then begin i1:=i; absdetmax:=absdet end
+  end;
+  SwapC(a[n], a[i1]);
+  SwapC(alfad[n], alfad[i1]);
+
+  an2 := a[n-2]; an1 := a[n-1]; an := a[n];
+  alfa.i := alfad[n-2].xreal; dv.i := alfad[n-2].imag;
+  alfa.j := alfad[n-1].xreal; dv.j := alfad[n-1].imag;
+  alfa.k := alfad[n  ].xreal; dv.k := alfad[n  ].imag;
+
+  n := n - 3;
+
+  GetMem(k, (n+1)*SizeOf(pointer));
+  for j:=0 to n do GetMem(k^[j], (j+1)*SizeOf(ArbFloat));
+
+  GetMem(e21, (n+1)*SizeOf(vector));
+  GetMem(b, (n+1)*SizeOf(vector));
+
+  pxpy(an2,an1,an,z); for i:=0 to n do b^[i].i:=1+p(a[i],an2,z);
+  pxpy(an1,an,an2,z); for i:=0 to n do b^[i].j:=1+p(a[i],an1,z);
+  pxpy(an,an2,an1,z); for i:=0 to n do b^[i].k:=1+p(a[i],an,z);
+
+  e22[0].init(0,e(an1,an2),e(an,an2));
+  e22[1].init(e(an1,an2),0,e(an,an1));
+  e22[2].init(e(an,an2),e(an,an1),0);
+
+  for j:=0 to n do e21^[j].init(e(an2,a[j]),e(an1,a[j]),e(an,a[j]));
+
+  GetMem(c, (n+1)*SizeOf(pointer));
+  for j:=0 to n do GetMem(c^[j], (j+1)*SizeOf(ArbFloat));
+
+  for i:=0 to n do
+  for j:=0 to i do
+  begin
+    if j=i then s:=0 else s:=e(a[i],a[j]);
+    hulp.init(b^[j].Inprod(e22[0]), b^[j].Inprod(e22[1]), b^[j].Inprod(e22[2]));
+    hulp.sub(e21^[j]);
+    k^[i]^[j] := s+b^[i].InProd(hulp)-b^[j].Inprod(e21^[i]);
+    if j=i then s:=1/alfad[i].imag else s:=0;
+    hulp.init(b^[j].i/dv.i, b^[j].j/dv.j, b^[j].k/dv.k);
+    c^[i]^[j] := k^[i]^[j] + (s + b^[i].Inprod(hulp))/lambda
+  end;
+
+  for i:=0 to n do gamma[i]:=alfad[i].xreal - b^[i].Inprod(alfa);
+
+  SpdSol(n, pointer(c), gamma[0]);
+
+  for j:=n downto 0 do FreeMem(c^[j], (j+1)*SizeOf(ArbFloat));
+  FreeMem(c, (n+1)*SizeOf(pointer));
+
+  s:=0; for j:=0 to n do s:=s+b^[j].i*gamma[j]; w.i:=s; gamma[n+1] := -s;
+  s:=0; for j:=0 to n do s:=s+b^[j].j*gamma[j]; w.j:=s; gamma[n+2] := -s;
+  s:=0; for j:=0 to n do s:=s+b^[j].k*gamma[j]; w.k:=s; gamma[n+3] := -s;
+  FreeMem(b, (n+1)*SizeOf(vector));
+
+  u.init(w.i/dv.i, w.j/dv.j, w.k/dv.k);
+  u.scale(1/lambda);
+  u.add(alfa);
+
+  s:=0; for j:=0 to n do s:=s+e21^[j].i*gamma[j]; v.i := e22[0].inprod(w)-s;
+  s:=0; for j:=0 to n do s:=s+e21^[j].j*gamma[j]; v.j := e22[1].inprod(w)-s;
+  s:=0; for j:=0 to n do s:=s+e21^[j].k*gamma[j]; v.k := e22[2].inprod(w)-s;
+  FreeMem(e21, (n+1)*SizeOf(vector));
+
+  u.add(v);
+
+  pfxpfy(an2, an1, an, u, pf); u1:=u.i;
+
+  kwsom := 0; for j:=0 to n do kwsom:=kwsom+sqr(gamma[j])/alfad[j].imag;
+  kwsom := kwsom+sqr(w.i)/dv.i+sqr(w.j)/dv.j+sqr(w.k)/dv.k;
+  kwsom := kwsom/sqr(lambda);
+
+  s:=0;
+  for i:=0 to n do
+  begin s1:=0;
+        for j:=0 to i do s1:=s1+k^[i]^[j]*gamma[j];
+        for j:=i+1 to n do s1:=s1+k^[j]^[i]*gamma[j];
+        s := gamma[i]*s1+s
+  end;
+  for j:=n downto 0 do FreeMem(k^[j], (j+1)*SizeOf(ArbFloat));
+  FreeMem(k, (n+1)*SizeOf(pointer));
+  energie := s
+
+end {splineparameters};
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/mdt.pas

@@ -0,0 +1,962 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Unit with undocumented procedures. If you recognize the algoritms, please
+    contact one of the above people.
+
+    This is probably only one actual procedure/algoritm, but (faster)
+    variants exist for special matrices. (like band, tridiagonal etc)
+
+    Contrary to the other undocumented units, this unit is exported in the
+    DLL.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+Unit mdt;
+
+interface
+{$I DIRECT.INC}
+
+uses typ, dsl, omv;
+
+Procedure mdtgen(n, rwidth: ArbInt; Var alu: ArbFloat; Var p: ArbInt;
+                 Var ca:ArbFloat; Var term: ArbInt);
+
+Procedure mdtgtr(n: ArbInt; Var l, d, u, l1, d1, u1, u2: ArbFloat;
+                 Var p: boolean; Var ca: ArbFloat; Var term: ArbInt);
+
+Procedure mdtgsy(n, rwidth: ArbInt; Var a: ArbFloat; Var pp:ArbInt;
+                 Var qq:boolean; Var ca:ArbFloat; Var term:ArbInt);
+
+Procedure mdtgpd(n, rwidth: ArbInt; Var al, ca: ArbFloat; Var term: ArbInt);
+
+Procedure mdtgba(n, lb, rb, rwa: ArbInt; Var a: ArbFloat; rwl: ArbInt;
+                 Var l:ArbFloat; Var p: ArbInt; Var ca: ArbFloat; Var term:ArbInt);
+
+Procedure mdtgpb(n, lb, rwidth: ArbInt; Var al, ca: ArbFloat;
+                 Var term: ArbInt);
+
+Procedure mdtdtr(n: ArbInt; Var l, d, u, l1, d1, u1: ArbFloat;
+                 Var term:ArbInt);
+
+implementation
+
+Procedure mdtgen(n, rwidth: ArbInt; Var alu: ArbFloat; Var p: ArbInt;
+                 Var ca:ArbFloat; Var term: ArbInt);
+
+Var 
+         indi, indk, nsr, ind, i, j, k, indexpivot : ArbInt;
+      normr, sumrowi, pivot, l, normt, maxim, h, s : ArbFloat;
+                                   palu, sumrow, t : ^arfloat1;
+                                                pp : ^arint1;
+                                          singular : boolean;
+Begin
+  If (n<1) Or (rwidth<1) Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  palu := @alu;
+  pp := @p;
+  nsr := n*sizeof(ArbFloat);
+  getmem(sumrow, nsr);
+  getmem(t, nsr);
+  normr := 0;
+  singular := false ;
+  For i:=1 To n Do
+    Begin
+      ind := (i-1)*rwidth;
+      pp^[i] := i;
+      sumrowi := 0;
+      For j:=1 To n Do
+        sumrowi := sumrowi+abs(palu^[ind+j]);
+      sumrow^[i] := sumrowi;
+     h := 2*random-1;
+     t^[i] := sumrowi*h;
+      h := abs(h);
+     If normr<h Then normr := h;
+      If sumrowi=0 Then
+        singular := true
+    End; {i}
+  For k:=1 To n Do
+    Begin
+      maxim := 0;
+     indexpivot := k;
+      For i:=k To n Do
+        Begin
+          ind := (i-1)*rwidth;
+          sumrowi := sumrow^[i];
+          If sumrowi <> 0 Then
+            Begin
+              h := abs(palu^[ind+k])/sumrowi;
+              If maxim<h Then
+                Begin
+                  maxim := h;
+                 indexpivot := i
+                End {maxim<h}
+            End {sumrow <> 0}
+        End; {i}
+      If maxim=0 Then
+        singular := true
+      Else
+        Begin
+          If indexpivot <> k Then
+            Begin
+              ind := (indexpivot-1)*rwidth;
+              indk := (k-1)*rwidth;
+              For j:=1 To n Do
+                Begin
+                  h := palu^[ind+j];
+                  palu^[ind+j] := palu^[indk+j];
+                  palu^[indk+j] := h
+                End; {j}
+              h := t^[indexpivot];
+             t^[indexpivot] := t^[k];
+              t^[k] := h;
+             pp^[k] := indexpivot;
+              sumrow^[indexpivot] := sumrow^[k]
+            End; {indexpivot <> k}
+          pivot := palu^[(k-1)*rwidth+k];
+          For i:=k+1 To n Do
+            Begin
+              ind := (i-1)*rwidth;
+              l := palu^[ind+k]/pivot;
+              palu^[ind+k] := l;
+              If l <> 0 Then
+                Begin
+                  For j:=k+1 To n Do
+                    palu^[ind+j] := palu^[ind+j]-l*palu^[(k-1)*rwidth+j];
+                  If Not singular Then
+                    t^[i] := t^[i]-l*t^[k]
+                End {l <> 0}
+            End {i}
+        End {maxim <> 0}
+    End; {k}
+    If Not singular Then
+      Begin
+        normt := 0;
+        For i:=n Downto 1 Do
+          Begin
+            indi := (i-1)*rwidth;
+            s := 0;
+            For j:=i+1 To n Do
+              s := s+t^[j]*palu^[indi+j];
+            t^[i] := (t^[i]-s)/palu^[indi+i];
+            h := abs(t^[i]);
+            If normt<h Then
+              normt := h
+          End; {i}
+        ca := normt/normr
+      End; {not singular}
+    If singular Then
+      Begin
+        term := 4;
+       ca := giant
+      End
+    Else
+      term := 1;
+  freemem(sumrow, nsr);
+  freemem(t, nsr)
+End; {mdtgen}
+
+Procedure mdtgtr(n: ArbInt; Var l, d, u, l1, d1, u1, u2: ArbFloat;
+                 Var p: boolean; Var ca: ArbFloat; Var term: ArbInt);
+
+Var 
+                         i, j, k, nmin1, sr : ArbInt;
+   normr, normt, sumrowi, h, lj, di, ui, ll : ArbFloat;
+                                       sing : boolean;
+           pd, pu, pd1, pu1, pu2, t, sumrow : ^arfloat1;
+                                    pl, pl1 : ^arfloat2;
+                                         pp : ^arbool1;
+Begin
+  If n<1 Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  pl := @l;
+ pd := @d;
+ pu := @u;
+  pl1 := @l1;
+ pd1 := @d1;
+ pu1 := @u1;
+ pu2 := @u2;
+ pp := @p;
+  sr := sizeof(ArbFloat);
+  move(pl^, pl1^, (n-1)*sr);
+  move(pd^, pd1^, n*sr);
+  move(pu^, pu1^, (n-1)*sr);
+  getmem(t, n*sr);
+  getmem(sumrow, n*sr);
+  normr := 0;
+ sing := false;
+  nmin1 := n-1;
+  For i:=1 To n Do
+    Begin
+      pp^[i] := false;
+      If i=1 Then
+        sumrowi := abs(pd^[1])+abs(pu^[1])
+      Else
+        If i=n Then
+          sumrowi := abs(pl^[n])+abs(pd^[n])
+        Else
+          sumrowi := abs(pl^[i])+abs(pd^[i])+abs(pu^[i]);
+      sumrow^[i] := sumrowi;
+     h := 2*random-1;
+     t^[i] := sumrowi*h;
+      h := abs(h);
+      If normr<h Then
+        normr := h;
+      If sumrowi=0 Then
+        sing := true
+    End; {i}
+  j := 1;
+  while (j <> n) Do
+    Begin
+      i := j;
+     j := j+1;
+     lj := pl1^[j];
+      If lj <> 0 Then
+        Begin
+          di := pd1^[i];
+          If di=0 Then
+            pp^[i] := true
+          Else
+            pp^[i] := abs(di/sumrow^[i])<abs(lj/sumrow^[j]);
+          If pp^[i] Then
+            Begin
+              ui := pu1^[i];
+             pd1^[i] := lj;
+              pu1^[i] := pd1^[j];
+             pl1^[j] := di/lj;
+             ll := pl1^[j];
+              pd1^[j] := ui-ll*pd1^[j];
+              If i<nmin1 Then
+                Begin
+                  pu2^[i] := pu1^[j];
+                  pu1^[j] := -ll*pu2^[i]
+                End; {i<nmin1}
+              sumrow^[j] := sumrow^[i];
+              If (Not sing) Then
+                Begin
+                  h := t^[i];
+                 t^[i] := t^[j];
+                  t^[j] := h-ll*t^[i]
+                End {not sing}
+            End {pp^[i]}
+          Else
+            Begin
+              pl1^[j] := lj/di;
+             ll := pl1^[j];
+              pd1^[j] := pd1^[j]-ll*pu1^[i];
+              If i<nmin1 Then
+                pu2^[i] := 0;
+              If (Not sing) Then
+                t^[j] := t^[j]-ll*t^[i]
+            End {not pp^[i]}
+        End {lj<>0}
+      Else
+        Begin
+          If i<nmin1 Then
+            pu2^[i] := 0;
+          If pd1^[i]=0 Then
+            sing := true
+        End {lj=0}
+    End; {j}
+  If pd1^[n]=0 Then
+    sing := true;
+  If (Not sing) Then
+    Begin
+      normt := 0;
+      t^[n] := t^[n]/pd1^[n];
+      h := abs(t^[n]);
+      If normt<h Then
+        normt := h;
+      If n > 1 Then
+        Begin
+          t^[nmin1] := (t^[nmin1]-pu1^[nmin1]*t^[n])/pd1^[nmin1];
+          h := abs(t^[nmin1])
+        End; {n > 1}
+      If normt<h Then
+        normt := h;
+      For i:=n-2 Downto 1 Do
+        Begin
+          t^[i] := (t^[i]-pu1^[i]*t^[i+1]-pu2^[i]*t^[i+2])/pd1^[i];
+          h := abs(t^[i]);
+          If normt<h Then
+            normt := h
+        End; {i}
+      ca := normt/normr
+    End; {not sing}
+  If (sing) Then
+    Begin
+      term := 4;
+     ca := giant
+    End {sing}
+  Else
+    term := 1;
+  freemem(t, n*sr);
+  freemem(sumrow, n*sr)
+End; {mdtgtr}
+
+Procedure mdtgsy(n, rwidth: ArbInt; Var a: ArbFloat; Var pp:ArbInt;
+                 Var qq:boolean; Var ca:ArbFloat; Var term:ArbInt);
+
+Var 
+   i, j, kmin1, k, kplus1, kmin2, imin2, nsr, nsi, nsb, ii,
+   imin1, jmin1, indexpivot, iplus1, indi, indj, indk, indp       : ArbInt;
+   ra, h, absh, maxim, pivot, ct, norma, sumrowi, normt, normr, s : ArbFloat;
+                               alt, l, d, t, u, v, l1, d1, u1, t1 : ^arfloat1;
+                                                                p : ^arint1;
+                                                                q : ^arbool1;
+Begin
+  If (n<1) Or (rwidth<1) Then
+    Begin
+      term := 3;
+     exit
+    End; {if}
+  alt := @a;
+ p := @pp;
+ q := @qq;
+  nsr := n*sizeof(ArbFloat);
+  nsi := n*sizeof(ArbInt);
+  nsb := n*sizeof(boolean);
+  getmem(l, nsr);
+  getmem(d, nsr);
+  getmem(t, nsr);
+  getmem(u, nsr);
+  getmem(v, nsr);
+  getmem(l1, nsr);
+  getmem(d1, nsr);
+  getmem(u1, nsr);
+  getmem(t1, nsr);
+  norma := 0;
+  For i:=1 To n Do
+    Begin
+      indi := (i-1)*rwidth;
+      p^[i] := i;
+     sumrowi := 0;
+      For j:=1 To i Do
+        sumrowi := sumrowi+abs(alt^[indi+j]);
+      For j:=i+1 To n Do
+        sumrowi := sumrowi+abs(alt^[(j-1)*rwidth+i]);
+      If norma<sumrowi Then
+        norma := sumrowi
+    End; {i}
+  kmin1 := -1;
+ k := 0;
+ kplus1 := 1;
+  while k<n Do
+    Begin
+      kmin2 := kmin1;
+     kmin1 := k;
+     k := kplus1;
+     kplus1 := kplus1+1;
+      indk := kmin1*rwidth;
+      If k>3 Then
+        Begin
+          t^[2] := alt^[rwidth+2]*alt^[indk+1]+alt^[2*rwidth+2]*alt^[indk+2];
+          For i:=3 To kmin2 Do
+            Begin
+              indi := (i-1)*rwidth;
+              t^[i] := alt^[indi+i-1]*alt^[indk+i-2]+alt^[indi+i]
+                       *alt^[indk+i-1]+alt^[indi+rwidth+i]*alt^[indk+i]
+            End; {i}
+          t^[kmin1] := alt^[indk-rwidth+kmin2]*alt^[indk+k-3]
+                       +alt^[indk-rwidth+kmin1]*alt^[indk+kmin2]
+                       +alt^[indk+kmin1];
+          h := alt^[indk+k];
+          For j:=2 To kmin1 Do
+            h := h-t^[j]*alt^[indk+j-1];
+          t^[k] := h;
+          alt^[indk+k] := h-alt^[indk+kmin1]*alt^[indk+kmin2]
+        End {k>3}
+      Else
+       If k=3 Then
+        Begin
+          t^[2] := alt^[rwidth+2]*alt^[2*rwidth+1]+alt^[2*rwidth+2];
+          h := alt^[2*rwidth+3]-t^[2]*alt^[2*rwidth+1];
+          t^[3] := h;
+          alt^[2*rwidth+3] := h-alt^[2*rwidth+2]*alt^[2*rwidth+1]
+        End  {k=3}
+      Else
+       If k=2 Then
+        t^[2] := alt^[rwidth+2];
+      maxim := 0;
+      For i:=kplus1 To n Do
+        Begin
+          indi := (i-1)*rwidth;
+          h := alt^[indi+k];
+          For j:=2 To k Do
+            h := h-t^[j]*alt^[indi+j-1];
+          absh := abs(h);
+          If maxim<absh Then
+            Begin
+              maxim := absh;
+             indexpivot := i
+            End; {if}
+          alt^[indi+k] := h
+        End; {i}
+      If maxim <> 0 Then
+        Begin
+          If indexpivot>kplus1 Then
+            Begin
+              indp := (indexpivot-1)*rwidth;
+              indk := k*rwidth;
+              p^[kplus1] := indexpivot;
+              For j:=1 To k Do
+                Begin
+                  h := alt^[indk+j];
+                  alt^[indk+j] := alt^[indp+j];
+                  alt^[indp+j] := h
+                End; {j}
+              For j:=indexpivot Downto kplus1 Do
+                Begin
+                  indj := (j-1)*rwidth;
+                  h := alt^[indj+kplus1];
+                  alt^[indj+kplus1] := alt^[indp+j];
+                  alt^[indp+j] := h
+                End; {j}
+              For i:=indexpivot To n Do
+                Begin
+                  indi := (i-1)*rwidth;
+                  h := alt^[indi+kplus1];
+                  alt^[indi+kplus1] := alt^[indi+indexpivot];
+                  alt^[indi+indexpivot] := h
+                End  {i}
+            End; {if}
+          pivot := alt^[k*rwidth+k];
+          For i:=k+2 To n Do
+            alt^[(i-1)*rwidth+k] := alt^[(i-1)*rwidth+k]/pivot
+        End {maxim <> 0}
+    End; {k}
+  d^[1] := alt^[1];
+ i := 1;
+  while i<n Do
+    Begin
+      imin1 := i;
+     i := i+1;
+      u^[imin1] := alt^[(i-1)*rwidth+imin1];
+      l^[imin1] := u^[imin1];
+     d^[i] := alt^[(i-1)*rwidth+i]
+    End; {i}
+  mdtgtr(n, l^[1], d^[1], u^[1], l1^[1], d1^[1], u1^[1], v^[1],
+         q^[1], ct, term);
+  alt^[1] := d1^[1];
+ alt^[rwidth+1] := l1^[1];
+  alt^[rwidth+2] := d1^[2];
+ alt^[2] := u1^[1];
+  imin1 := 1;
+ i := 2;
+  while i<n Do
+    Begin
+      imin2 := imin1;
+     imin1 := i;
+     i := i+1;
+      indi := imin1*rwidth;
+      alt^[indi+imin1] := l1^[imin1];
+     alt^[indi+i] := d1^[i];
+      alt^[(imin1-1)*rwidth+i] := u1^[imin1];
+      alt^[(imin2-1)*rwidth+i] := v^[imin2]
+    End; {i}
+  If term=1 Then
+    Begin
+      normr := 0;
+      For i:=1 To n Do
+        Begin
+          t^[i] := 2*random-1;
+         h := t^[i];
+          h := abs(h);
+          If normr<h Then
+            normr := h
+        End; {i}
+      i := 0;
+      while i<n Do
+        Begin
+          imin1 := i;
+         i := i+1;
+         j := 1;
+         h := t^[i];
+          while j<imin1 Do
+            Begin
+              jmin1 := j;
+             j := j+1;
+              h := h-alt^[(i-1)*rwidth+jmin1]*t^[j]
+            End; {j}
+          t^[i] := h
+        End; {i}
+      dslgtr(n, l1^[1], d1^[1], u1^[1], v^[1], q^[1], t^[1], t1^[1], term);
+      i := n+1;
+     imin1 := n;
+     normt := 0;
+      while i>2 Do
+        Begin
+          iplus1 := i;
+         i := imin1;
+         imin1 := imin1-1;
+         h := t1^[i];
+          For j:=iplus1 To n Do
+            h := h-alt^[(j-1)*rwidth+imin1]*t1^[j];
+          t1^[i] := h;
+         h := abs(h);
+          If normt<h Then
+            normt := h
+        End; {i}
+      ca := norma*normt/normr
+    End {term=1}
+  Else ca := giant;
+  freemem(l, nsr);
+  freemem(d, nsr);
+  freemem(t, nsr);
+  freemem(u, nsr);
+  freemem(v, nsr);
+  freemem(l1, nsr);
+  freemem(d1, nsr);
+  freemem(u1, nsr);
+  freemem(t1, nsr)
+End; {mdtgsy}
+
+Procedure mdtgpd(n, rwidth: ArbInt; Var al, ca: ArbFloat; Var term: ArbInt);
+
+Var 
+    posdef                               : boolean;
+    i, j, k, kmin1, indk, indi           : ArbInt;
+    h, lkk, normr, normt, sumrowi, norma : ArbFloat;
+    pal, t                               : ^arfloat1;
+Begin
+  If (n<1) Or (rwidth<1) Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  getmem(t, sizeof(ArbFloat)*n);
+  pal := @al;
+  normr := 0;
+  posdef := true;
+  norma := 0;
+  For i:=1 To n Do
+    Begin
+      sumrowi := 0;
+      For j:=1 To i Do
+        sumrowi := sumrowi+abs(pal^[(i-1)*rwidth+j]);
+      For j:=i+1 To n Do
+        sumrowi := sumrowi+abs(pal^[(j-1)*rwidth+i]);
+      If norma<sumrowi Then
+        norma := sumrowi;
+      t^[i] := 2*random-1;
+     h := t^[i];
+      h := abs(h);
+      If normr<h Then
+        normr := h
+    End; {i}
+  k := 0;
+  while (k<n) and posdef Do
+    Begin
+      kmin1 := k;
+     k := k+1;
+      indk := (k-1)*rwidth;
+      lkk := pal^[indk+k];
+      For j:=1 To kmin1 Do
+        lkk := lkk-sqr(pal^[indk+j]);
+      If lkk <= 0 Then
+        posdef := false
+      Else
+        Begin
+          pal^[indk+k] := sqrt(lkk);
+         lkk := pal^[indk+k];
+          For i:=k+1 To n Do
+            Begin
+              indi := (i-1)*rwidth;
+              h := pal^[indi+k];
+              For j:=1 To kmin1 Do
+                h := h-pal^[indk+j]*pal^[indi+j];
+              pal^[indi+k] := h/lkk
+            End; {i}
+          h := t^[k];
+          For j:=1 To kmin1 Do
+            h := h-pal^[indk+j]*t^[j];
+          t^[k] := h/lkk
+        End {posdef}
+    End; {k}
+  If posdef Then
+    Begin
+      normt := 0;
+      For i:=n Downto 1 Do
+        Begin
+          h := t^[i];
+          For j:=i+1 To n Do
+            h := h-pal^[(j-1)*rwidth+i]*t^[j];
+          t^[i] := h/pal^[(i-1)*rwidth+i];
+          h := abs(t^[i]);
+          If normt<h Then
+            normt := h
+        End; {i}
+      ca := norma*normt/normr
+    End; {posdef}
+  If posdef Then
+    term := 1
+  Else
+    term := 2;
+  freemem(t, sizeof(ArbFloat)*n);
+End; {mdtgpd}
+
+Procedure mdtgba(n, lb, rb, rwa: ArbInt; Var a: ArbFloat; rwl: ArbInt;
+                 Var l:ArbFloat; Var p: ArbInt; Var ca: ArbFloat; Var term:ArbInt);
+
+Var 
+  sr, i, j, k, ipivot, m, lbj, lbi, ubi, ls,
+             ii, jj, ll, s, js, jl, ubj       : ArbInt;
+  ra, normr, sumrowi, pivot, normt, maxim, h  : ArbFloat;
+          pl, au, sumrow, t, row              : ^arfloat1;
+                                           pp : ^arint1;
+
+Begin
+  If (n<1) Or (lb<0) Or (rb<0) Or (lb>n-1) Or (rb>n-1) Or (rwl<0) Or (rwa<1) Then
+    Begin
+      term := 3;
+     exit
+    End; {term=3}
+  sr := sizeof(ArbFloat);
+  au := @a;
+ pl := @l;
+ pp := @p;
+  ll := lb+rb+1;
+  ls := ll*sr;
+  getmem(sumrow, n*sr);
+  getmem(t, n*sr);
+  getmem(row, ls);
+  lbi := n-rb+1;
+ lbj := 0;
+  jj := 1;
+  For i:=lb Downto 1 Do
+    Begin
+      move(au^[i+jj], au^[jj], (ll-i)*sr);
+      fillchar(au^[jj+ll-i], i*sr, 0);
+      jj := jj+rwa
+    End; {i}
+  jj := (n-rb)*rwa+ll;
+  For i:=1 To rb Do
+    Begin
+      fillchar(au^[jj], i*sr, 0);
+      jj := jj+rwa-1
+    End; {i}
+  normr := 0;
+ term := 1;
+  ii := 1;
+  For i:=1 To n Do
+    Begin
+      pp^[i] := i;
+      sumrowi := omvn1v(au^[ii], ll);
+      ii := ii+rwa;
+      sumrow^[i] := sumrowi;
+      h := 2*random-1;
+     t^[i] := sumrowi*h;
+      h := abs(h);
+      If normr<h Then
+        normr := h;
+      If sumrowi=0 Then
+        term := 4
+    End; {i}
+  ubi := lb;
+ jj := 1;
+  For k:=1 To n Do
+    Begin
+      maxim := 0;
+     ipivot := k;
+     ii := jj;
+      If ubi<n Then
+        ubi := ubi+1;
+      For i:=k To ubi Do
+        Begin
+          sumrowi := sumrow^[i];
+          If sumrowi <> 0 Then
+            Begin
+              h := abs(au^[ii])/sumrowi;
+              ii := ii+rwa;
+              If maxim<h Then
+                Begin
+                  maxim := h;
+                 ipivot := i
+                End {maxim<h}
+            End {sumrowi <> 0}
+        End; {i}
+      If maxim=0 Then
+        Begin
+          lbj := 1;
+         ubj := ubi-k;
+          For j:=lbj To ubj Do
+            pl^[(k-1)*rwl+j] := 0;
+          For i:=k+1 To ubi Do
+            Begin
+              ii := (i-1)*rwa;
+              For j:=2 To ll Do
+                au^[ii+j-1] := au^[ii+j];
+              au^[ii+ll] := 0
+            End; {i}
+          term := 4
+        End {maxim=0}
+      Else
+        Begin
+          If ipivot <> k Then
+            Begin
+              ii := (ipivot-1)*rwa+1;
+              move(au^[ii], row^, ls);
+              move(au^[jj], au^[ii], ls);
+              move(row^, au^[jj], ls);
+              h := t^[ipivot];
+             t^[ipivot] := t^[k];
+             t^[k] := h;
+              pp^[k] := ipivot;
+              sumrow^[ipivot] := sumrow^[k]
+            End; {ipivot <> k}
+          pivot := au^[jj];
+         jl := 0;
+         ii := jj;
+          For i:=k+1 To ubi Do
+            Begin
+              jl := jl+1;
+              ii := ii+rwa;
+              h := au^[ii]/pivot;
+              pl^[(k-1)*rwl+jl] := h;
+              For j:=0 To ll-2 Do
+                au^[ii+j] := au^[ii+j+1]-h*au^[jj+j+1];
+              au^[ii+ll-1] := 0;
+              If term=1 Then
+                t^[i] := t^[i]-h*t^[k]
+            End {i}
+        End; {maxim <> 0}
+      jj := jj+rwa
+    End; {k}
+  If term=1 Then
+    Begin
+      normt := 0;
+     ubj := -lb-1;
+      jj := n*rwa+1;
+      For i:=n Downto 1 Do
+        Begin
+          jj := jj-rwa;
+          If ubj<rb Then
+            ubj := ubj+1;
+          h := t^[i];
+          For j:=1 To ubj+lb Do
+            h := h-au^[jj+j]*t^[i+j];
+          t^[i] := h/au^[jj];
+          h := abs(t^[i]);
+          If normt<h Then
+            normt := h
+        End; {i}
+      ca := normt/normr
+    End {term=1}
+  Else
+   ca := giant;
+  freemem(sumrow, n*sr);
+  freemem(t, n*sr);
+  freemem(row, ls)
+End; {mdtgba}
+
+Procedure mdtgpb(n, lb, rwidth: ArbInt; Var al, ca: ArbFloat;
+                 Var term: ArbInt);
+
+Var 
+    posdef                                           : boolean;
+    i, j, k, r, p, q, ll, llmin1, jmin1, indi        : ArbInt;
+    h, normr, normt, sumrowi, alim, norma            : ArbFloat;
+    pal, t                                           : ^arfloat1;
+
+    Procedure decomp(i, r: ArbInt);
+
+    Var 
+        k, ii, ir : ArbInt;
+    Begin
+      ii := (i-1)*rwidth;
+      ir := (r-1)*rwidth;
+      h := pal^[ii+j];
+     q := ll-j+p;
+      For k:=p To jmin1 Do
+        Begin
+          h := h-pal^[ii+k]*pal^[ir+q];
+         q := q+1
+        End; {k}
+      If j<ll Then
+        pal^[ii+j] := h/pal^[ir+ll]
+    End; {decomp}
+
+    Procedure lmin1t(i: ArbInt);
+
+    Var 
+        k:ArbInt;
+    Begin
+      h := t^[i];
+     q := i;
+      For k:=llmin1 Downto p Do
+        Begin
+          q := q-1;
+         h := h-pal^[indi+k]*t^[q]
+        End; {k}
+      t^[i] := h/alim
+    End; {lmin1t}
+
+Begin
+  If (lb<0) Or (lb>n-1) Or (n<1) Or (rwidth<1) Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  pal := @al;
+  getmem(t, n*sizeof(ArbFloat));
+  ll := lb+1;
+ normr := 0;
+ p := ll+1;
+ norma := 0;
+  For i:=1 To n Do
+    Begin
+      If p>1 Then
+        p := p-1;
+      indi := (i-1)*rwidth+p;
+      sumrowi := omvn1v(pal^[indi], ll-p+1);
+      r := i;
+     j := ll;
+      while (r<n) and (j>1) Do
+        Begin
+          r := r+1;
+         j := j-1;
+          sumrowi := sumrowi+abs(pal^[(r-1)*rwidth+j])
+        End; {r,j}
+      If norma<sumrowi Then
+        norma := sumrowi;
+      h := 2*random-1;
+     t^[i] := h;
+      h := abs(h);
+      If normr<h Then
+        normr := h
+    End; {i}
+    llmin1 := ll-1;
+    p := ll+1;
+    i := 0;
+    posdef := true ;
+    while (i<n) and posdef Do
+      Begin
+        i := i+1;
+        indi := (i-1)*rwidth;
+        If p>1 Then
+          p := p-1;
+        r := i-ll+p;
+       j := p-1;
+        while j<llmin1 Do
+          Begin
+            jmin1 := j;
+           j := j+1;
+            decomp(i, r);
+           r := r+1
+          End; {j}
+        jmin1 := llmin1;
+       j := ll;
+       decomp(i, i);
+        If h <= 0 Then
+          posdef := false
+        Else
+          Begin
+            alim := sqrt(h);
+           pal^[indi+ll] := alim;
+            lmin1t(i)
+          End
+      End; {i}
+    If posdef Then
+      Begin
+        normt := 0;
+       p := ll+1;
+        For i:=n Downto 1 Do
+          Begin
+            If p>1 Then
+              p := p-1;
+            q := i;
+           h := t^[i];
+            For k:=llmin1 Downto p Do
+              Begin
+                q := q+1;
+               h := h-pal^[(q-1)*rwidth+k]*t^[q]
+              End; {k}
+            t^[i] := h/pal^[(i-1)*rwidth+ll];
+            h := abs(t^[i]);
+            If normt<h Then
+              normt := h
+          End; {i}
+        ca := norma*normt/normr
+      End; {posdef}
+    If posdef Then
+      term := 1
+    Else
+      term := 2;
+  freemem(t, n*sizeof(ArbFloat));
+End; {mdtgpb}
+
+Procedure mdtdtr(n: ArbInt; Var l, d, u, l1, d1, u1: ArbFloat;
+                 Var term:ArbInt);
+
+Var
+                      i, j, s : ArbInt;
+                       lj, di : ArbFloat;
+             pd, pu, pd1, pu1 : ^arfloat1;
+                      pl, pl1 : ^arfloat2;
+
+Begin
+  If n<1 Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  pl := @l;
+  pd := @d;
+  pu := @u;
+  pl1 := @l1;
+  pd1 := @d1;
+  pu1 := @u1;
+  s := sizeof(ArbFloat);
+  move(pl^, pl1^, (n-1)*s);
+  move(pd^, pd1^, n*s);
+  move(pu^, pu1^, (n-1)*s);
+  j := 1;
+  di := pd1^[j];
+  If di=0 Then
+    term := 2
+  Else
+    term := 1;
+  while (term=1) and (j <> n) Do
+    Begin
+     i := j;
+     j := j+1;
+     lj := pl1^[j]/di;
+     pl1^[j] := lj;
+     di := pd1^[j]-lj*pu1^[i];
+     pd1^[j] := di;
+     If di=0 Then
+      term := 2
+    End {j}
+End; {mdtdtr}
+
+Begin
+  randseed := 12345
+End.
+
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/ntest.pas

@@ -0,0 +1,56 @@
+
+TYPE ArbFloat=extended; {Any float, sensible values are Real Or extended}
+     ArrayByte= ARRAY[0..SIZEOF(ArbFloat)-1] OF BYTE;
+     Float10Arb=ArrayByte;
+
+PROCEDURE DisplayBinValue(Flt : ArbFloat);
+
+VAR      FltArr : ArrayByte;
+         I      : LONGINT;
+
+BEGIN
+ Writeln(Flt);
+ Move(Flt,FltArr,SIZEOF(ArbFloat));
+ FOR I:=0 TO SIZEOF(ArbFloat)-1 DO
+  BEGIN
+   Write(FltArr[I]);
+   IF I<> (SIZEOF(ArbFloat)-1 ) THEN
+    Write(', ');
+  END;
+ Writeln;
+END;
+
+FUNCTION  CreateFloat(Sign:BOOLEAN;Mantissa1:comp;Exponent:LONGINT):ArbFloat;
+
+VAR L : ArrayByte;
+
+BEGIN
+ FillChar(L,8,#0);
+ IF Sign THEN
+  L[SIZEOF(ArbFloat)-1]:=128;
+
+END;
+CONST
+    ETC1 : Float10Arb = (0,0,$00,$00,$00,$00,0,128,192,63);
+    ETC2 : Float10Arb = ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$D6,$FE,127);
+    ETC3 : Float10Arb = (1,0,0,0,0,0,0,0,0,0);
+    ETC4 : Float10Arb = (0,0,0,0,0,0,0,0,$F0,$7F);
+    ETC5 : Float10Arb = (0,0,0,0,0,0,0,$80,$F0,$7F);
+
+VAR L:ArbFloat;
+
+BEGIN
+{ writeln(extended(ETC2));
+ L:=ln(extended(ETC2));
+ DisplayBinValue(L);
+ writeln(extended(ETC3));
+ L:=ln(extended(ETC3));
+ DisplayBinValue(L);}
+ L:=extended(ETC4);
+ writeln(L);
+ DisplayBinValue(L);
+ L:=extended(ETC5);
+ writeln(L);
+ DisplayBinValue(L);
+
+END.

packages/numlib/numlib.pas

@@ -0,0 +1,314 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             Documentation by Michael van Canneyt ([email protected])
+
+    This unit exports all functions in the tpnumlib dll. (a header file more
+    or less) Programs based on this unit don't require the other sources to
+    compile/build, only the DLL, direct.inc and this file are needed.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit NumLib;
+
+interface
+{$I direct.inc}
+
+uses typ;
+
+CONST Numlib_dll_version=2;        {Original is 1, first FPC version=2}
+
+{not wrapped to 80 columns yet, since this is easier for copying and
+pasting, and adding of the external lines}
+
+{Added; if the internal version of this unit and dll differ,
+this function returns FALSE, and program can abort}
+FUNCTION CheckVersion: BOOLEAN;
+
+procedure detgen(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure detgsy(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure detgpd(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure detgba(n, l, r: ArbInt; var a, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure detgpb(n, l: ArbInt; var a, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure detgtr(n: ArbInt; var l, d, u, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure dslgen(n, rwidth: ArbInt; var alu: ArbFloat; var p: ArbInt;var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure dslgtr(n: ArbInt; var l1, d1, u1, u2: ArbFloat; var p: boolean; var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure dslgsy(n, rwidth: ArbInt; var alt: ArbFloat; var p: ArbInt;var q: boolean; var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure dslgpd(n, rwidth: ArbInt; var al, b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure dslgba(n, lb, rb, rwa: ArbInt; var au: ArbFloat; rwl: ArbInt;var l: ArbFloat; var p: ArbInt; var b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure dslgpb(n, lb, rwidth: ArbInt; var al, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure dsldtr(n:ArbInt; var l, d, u, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eiggs1(var a: ArbFloat; n, rwidth: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eiggs2(var a: ArbFloat; n, rwidth, k1, k2: ArbInt;var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eiggs3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eiggs4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigts1(var d, cd: ArbFloat; n: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigts2(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigts3(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;rwidth: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigts4(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam, x: ArbFloat;rwidth: ArbInt; var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigbs1(var a: ArbFloat; n, l: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigbs2(var a: ArbFloat; n, l, k1, k2: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigbs3(var a: ArbFloat; n, l: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigbs4(var a: ArbFloat; n, l, k1, k2: ArbInt;var lam, x: ArbFloat;  rwidthx: ArbInt;var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigge1(var a: ArbFloat; n, rwidth: ArbInt; var lam: complex;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigge3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: complex;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eiggg1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eiggg2(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eiggg3(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eiggg4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigsv1(var a: ArbFloat; m, n, rwidth: ArbInt; var sig: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure eigsv3(var a: ArbFloat; m, n, rwidtha: ArbInt; var sig, u: ArbFloat;rwidthu: ArbInt; var v: ArbFloat; rwidthv: ArbInt;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure int1fr(f: rfunc1r; a, b, ae: ArbFloat; var integral, err: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure invgen(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure invgsy(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure invgpd(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure iomrev(var inp: text; var v: ArbFloat; n: ArbInt);
+procedure iomrem(var inp: text; var a: ArbFloat; m, n, rwidth: ArbInt);
+procedure iomwrv(var out: text; var v: ArbFloat; n, form: ArbInt);
+procedure iomwrm(var out: text; var a: ArbFloat; m, n, rwidth, form: ArbInt);
+procedure mdtgen(n, rwidth: ArbInt; var alu: ArbFloat; var p: ArbInt;var ca:ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure mdtgtr(n: ArbInt; var l, d, u, l1, d1, u1, u2: ArbFloat; var p: boolean; var ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure mdtgsy(n, rwidth: ArbInt; var a: ArbFloat; var pp:ArbInt;var qq:boolean; var ca:ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure mdtgpd(n, rwidth: ArbInt; var al, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure mdtgba(n, lb, rb, rwa: ArbInt; var a: ArbFloat; rwl: ArbInt;var l:ArbFloat; var p: ArbInt; var ca: ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure mdtgpb(n, lb, rwidth: ArbInt; var al, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure mdtdtr(n: ArbInt; var l, d, u, l1, d1, u1: ArbFloat;var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure odeiv1(f: rfunc2r; a, ya: ArbFloat; var b, yb: ArbFloat;ae: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure odeiv2(f: oderk1n; a: ArbFloat; var ya, b, yb: ArbFloat;n: ArbInt; ae: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function omvinp(var a, b: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure omvmmm(var a: ArbFloat; m, n, rwa: ArbInt;var b: ArbFloat; k, rwb: ArbInt;var c: ArbFloat; rwc: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure omvmmv(var a: ArbFloat; m, n, rwidth: ArbInt; var b, c: ArbFloat); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function omvn1m(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function omvn1v(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function omvn2v(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function omvnfm(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function omvnmm(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function omvnmv(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure omvtrm(var a: ArbFloat; m, n, rwa: ArbInt;var c: ArbFloat; rwc: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure roobin(n: ArbInt; a: complex; var z: complex; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure roof1r(f: rfunc1r; a, b, ae, re: ArbFloat; var x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure roopol(var a: ArbFloat; n: ArbInt; var z: complex;var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure rooqua(p, q: ArbFloat; var z1, z2: complex); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure roofnr(f: roofnrfunc; n: ArbInt; var x, residu: ArbFloat; re: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure sledtr(n: ArbInt; var l, d, u, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegba(n, l, r: ArbInt;var a, b, x, ca: ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegbal(n, l, r: ArbInt;var a1; var b1, x1, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegen(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegenl(n: ArbInt;var a1;var b1, x1, ca: ArbFloat;                  var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegls(var a: ArbFloat; m, n, rwidtha: ArbInt; var b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure sleglsl(var a1; m, n: ArbInt; var b1, x1: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegpb(n, l: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegpbl(n, l: ArbInt;var a1; var b1, x1, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegpd(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegpdl(n: ArbInt; var a1; var b1, x1, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegsy(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegsyl(n: ArbInt; var a1; var b1, x1, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure slegtr(n:ArbInt; var l, d, u, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function spebi0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
+function spebi1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
+function spebj0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
+function spebj1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
+function spebk0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
+function spebk1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
+function speby0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}
+function speby1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
+function speent(x: ArbFloat): longint; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}
+function speerf(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}
+function speefc(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}
+function spegam(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}
+function spelga(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 20 oktober 1993}
+function spemax(a, b: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}
+function spepol(x: ArbFloat; var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}
+function spepow(a, b: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}
+function spesgn(x: ArbFloat): ArbInt; {ok 26 oktober 1993}
+function spears(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 21 oktober 1993}
+function spearc(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 21 oktober 1993}
+function spesih(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
+function specoh(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
+function spetah(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
+function speash(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
+function speach(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
+function speath(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}
+function  spl1bspv(q: ArbInt; var kmin1, c1: ArbFloat; x: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function  spl2bspv(qx, qy: ArbInt; var kxmin1, kymin1, c11: ArbFloat; x, y: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure spl1bspf(M, Q: ArbInt; var XYW1: ArbFloat;var Kmin1, C1, residu: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure spl2bspf(M, Qx, Qy: ArbInt; var XYZW1: ArbFloat;var Kxmin1, Kymin1, C11, residu: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure spl1nati(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure spl1naki(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure spl1cmpi(n: ArbInt; var xyc1: ArbFloat; dy1, dyn: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure spl1peri(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function  spl1pprv(n: ArbInt; var xyc1: ArbFloat; t: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure spl1nalf(n: ArbInt; var xyw1: ArbFloat; lambda:ArbFloat;var xac1, residu: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function spl2natv(n: ArbInt; var xyg0: ArbFloat; u, v: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure spl2nalf(n: ArbInt; var xyzw1: ArbFloat; lambda:ArbFloat;var xyg0, residu: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+//procedure Intsle(l: ArbInt; e: ArbFloat); {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function dllversion:LONGINT; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function exp(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function MachCnst(n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure ipffsn(n: ArbInt; var x, y, a, d2a: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure ipfisn(n: ArbInt; var x, y, d2s: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function  ipfspn(n: ArbInt; var x, y, d2s: ArbFloat; t: ArbFloat;var term: ArbInt): ArbFloat;{$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure ipfpol(m, n: ArbInt; var x, y, b: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}
+function spline(n: ArbInt; x: complex; var ac: complex; var gammar: ArbFloat; u1: ArbFloat; pf: complex): ArbFloat;{$IFDEF Needsstdcall} stdcall; {$ENDIF}
+procedure splineparameters (n: ArbInt; var ac, alfadc: complex; var lambda, gammar, u1, kwsom, energie: ArbFloat; var pf: complex);{$IFDEF Needsstdcall} stdcall; {$ENDIF}
+
+implementation
+
+
+procedure detgen(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   1;
+procedure detgsy(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   2;
+procedure detgpd(n, rwidth: ArbInt; var a, f: ArbFloat; var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   3;
+procedure detgba(n, l, r: ArbInt; var a, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                external 'TpNumLib'  index   4;
+procedure detgpb(n, l: ArbInt; var a, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                   external 'TpNumLib'  index   5;
+procedure detgtr(n: ArbInt; var l, d, u, f: ArbFloat; var k, term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                external 'TpNumLib'  index   6;
+procedure dslgen(n, rwidth: ArbInt; var alu: ArbFloat; var p: ArbInt;var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                               external 'TpNumLib'  index   7;
+procedure dslgtr(n: ArbInt; var l1, d1, u1, u2: ArbFloat; var p: boolean; var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                          external 'TpNumLib'  index   8;
+procedure dslgsy(n, rwidth: ArbInt; var alt: ArbFloat; var p: ArbInt;var q: boolean; var b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                               external 'TpNumLib'  index   9;
+procedure dslgpd(n, rwidth: ArbInt; var al, b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   10;
+procedure dslgba(n, lb, rb, rwa: ArbInt; var au: ArbFloat; rwl: ArbInt;var l: ArbFloat; var p: ArbInt; var b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}              external 'TpNumLib'  index   11;
+procedure dslgpb(n, lb, rwidth: ArbInt; var al, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                        external 'TpNumLib'  index   12;
+procedure dsldtr(n:ArbInt; var l, d, u, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                external 'TpNumLib'  index   13;
+procedure eiggs1(var a: ArbFloat; n, rwidth: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                external 'TpNumLib'  index   14;
+procedure eiggs2(var a: ArbFloat; n, rwidth, k1, k2: ArbInt;var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                         external 'TpNumLib'  index   15;
+procedure eiggs3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                            external 'TpNumLib'  index   16;
+procedure eiggs4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                external 'TpNumLib'  index   17;
+procedure eigts1(var d, cd: ArbFloat; n: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                     external 'TpNumLib'  index   18;
+procedure eigts2(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                             external 'TpNumLib'  index   19;
+procedure eigts3(var d, cd: ArbFloat; n: ArbInt; var lam, x: ArbFloat;rwidth: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                  external 'TpNumLib'  index   20;
+procedure eigts4(var d, cd: ArbFloat; n, k1, k2: ArbInt; var lam, x: ArbFloat;rwidth: ArbInt; var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                      external 'TpNumLib'  index   21;
+procedure eigbs1(var a: ArbFloat; n, l: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                      external 'TpNumLib'  index   22;
+procedure eigbs2(var a: ArbFloat; n, l, k1, k2: ArbInt; var lam: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                              external 'TpNumLib'  index   23;
+procedure eigbs3(var a: ArbFloat; n, l: ArbInt; var lam, x: ArbFloat;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                  external 'TpNumLib'  index   24;
+procedure eigbs4(var a: ArbFloat; n, l, k1, k2: ArbInt;var lam, x: ArbFloat;  rwidthx: ArbInt;var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                      external 'TpNumLib'  index   25;
+procedure eigge1(var a: ArbFloat; n, rwidth: ArbInt; var lam: complex;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                  external 'TpNumLib'  index   26;
+procedure eigge3(var a: ArbFloat; n, rwidtha: ArbInt; var lam, x: complex;rwidthx: ArbInt; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                             external 'TpNumLib'  index   27;
+procedure eiggg1(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                              external 'TpNumLib'  index   28;
+procedure eiggg2(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                      external 'TpNumLib'  index   29;
+procedure eiggg3(var a: ArbFloat; n, rwidtha: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}           external 'TpNumLib'  index   30;
+procedure eiggg4(var a: ArbFloat; n, rwidtha, k1, k2: ArbInt; var b: ArbFloat;rwidthb: ArbInt; var lam, x: ArbFloat; rwidthx: ArbInt;var m2, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}external 'TpNumLib'  index   31;
+procedure eigsv1(var a: ArbFloat; m, n, rwidth: ArbInt; var sig: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                              external 'TpNumLib'  index   32;
+procedure eigsv3(var a: ArbFloat; m, n, rwidtha: ArbInt; var sig, u: ArbFloat;rwidthu: ArbInt; var v: ArbFloat; rwidthv: ArbInt;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}        external 'TpNumLib'  index   33;
+procedure int1fr(f: rfunc1r; a, b, ae: ArbFloat; var integral, err: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                           external 'TpNumLib'  index   34;
+procedure invgen(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                  external 'TpNumLib'  index   35;
+procedure invgsy(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                  external 'TpNumLib'  index   36;
+procedure invgpd(n, rwidth: ArbInt; var ai: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                  external 'TpNumLib'  index   37;
+procedure iomrev(var inp: text; var v: ArbFloat; n: ArbInt);                                                                                                                                      external 'TpNumLib'  index   38;
+procedure iomrem(var inp: text; var a: ArbFloat; m, n, rwidth: ArbInt);                                                                                                                           external 'TpNumLib'  index   39;
+procedure iomwrv(var out: text; var v: ArbFloat; n, form: ArbInt);                                                                                                                                external 'TpNumLib'  index   40;
+procedure iomwrm(var out: text; var a: ArbFloat; m, n, rwidth, form: ArbInt);                                                                                                                     external 'TpNumLib'  index   41;
+procedure mdtgen(n, rwidth: ArbInt; var alu: ArbFloat; var p: ArbInt;var ca:ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                  external 'TpNumLib'  index   42;
+procedure mdtgtr(n: ArbInt; var l, d, u, l1, d1, u1, u2: ArbFloat; var p: boolean; var ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                   external 'TpNumLib'  index   43;
+procedure mdtgsy(n, rwidth: ArbInt; var a: ArbFloat; var pp:ArbInt;var qq:boolean; var ca:ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                     external 'TpNumLib'  index   44;
+procedure mdtgpd(n, rwidth: ArbInt; var al, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                              external 'TpNumLib'  index   45;
+procedure mdtgba(n, lb, rb, rwa: ArbInt; var a: ArbFloat; rwl: ArbInt;var l:ArbFloat; var p: ArbInt; var ca: ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                  external 'TpNumLib'  index   46;
+procedure mdtgpb(n, lb, rwidth: ArbInt; var al, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                           external 'TpNumLib'  index   47;
+procedure mdtdtr(n: ArbInt; var l, d, u, l1, d1, u1: ArbFloat;var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                           external 'TpNumLib'  index   48;
+procedure odeiv1(f: rfunc2r; a, ya: ArbFloat; var b, yb: ArbFloat;ae: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                        external 'TpNumLib'  index   49;
+procedure odeiv2(f: oderk1n; a: ArbFloat; var ya, b, yb: ArbFloat;n: ArbInt; ae: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                             external 'TpNumLib'  index   50;
+function omvinp(var a, b: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                 external 'TpNumLib'  index   51;
+procedure omvmmm(var a: ArbFloat; m, n, rwa: ArbInt;var b: ArbFloat; k, rwb: ArbInt;var c: ArbFloat; rwc: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                        external 'TpNumLib'  index   52;
+procedure omvmmv(var a: ArbFloat; m, n, rwidth: ArbInt; var b, c: ArbFloat); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                              external 'TpNumLib'  index   53;
+function omvn1m(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                         external 'TpNumLib'  index   54;
+function omvn1v(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                    external 'TpNumLib'  index   55;
+function omvn2v(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                    external 'TpNumLib'  index   56;
+function omvnfm(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                         external 'TpNumLib'  index   57;
+function omvnmm(var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                         external 'TpNumLib'  index   58;
+function omvnmv(var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                    external 'TpNumLib'  index   59;
+procedure omvtrm(var a: ArbFloat; m, n, rwa: ArbInt;var c: ArbFloat; rwc: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                        external 'TpNumLib'  index   60;
+procedure roobin(n: ArbInt; a: complex; var z: complex; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                external 'TpNumLib'  index   61;
+procedure roof1r(f: rfunc1r; a, b, ae, re: ArbFloat; var x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                   external 'TpNumLib'  index   62;
+procedure roopol(var a: ArbFloat; n: ArbInt; var z: complex;var k, term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                         external 'TpNumLib'  index   63;
+procedure rooqua(p, q: ArbFloat; var z1, z2: complex); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                    external 'TpNumLib'  index   64;
+procedure roofnr(f: roofnrfunc; n: ArbInt; var x, residu: ArbFloat; re: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                       external 'TpNumLib'  index   65;
+procedure sledtr(n: ArbInt; var l, d, u, b, x: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                               external 'TpNumLib'  index   66;
+procedure slegba(n, l, r: ArbInt;var a, b, x, ca: ArbFloat; var term:ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   67;
+procedure slegbal(n, l, r: ArbInt;var a1; var b1, x1, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                    external 'TpNumLib'  index   68;
+procedure slegen(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                          external 'TpNumLib'  index   69;
+procedure slegenl(n: ArbInt;var a1;var b1, x1, ca: ArbFloat;                  var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                          external 'TpNumLib'  index   70;
+procedure slegls(var a: ArbFloat; m, n, rwidtha: ArbInt; var b, x: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                            external 'TpNumLib'  index   71;
+procedure sleglsl(var a1; m, n: ArbInt; var b1, x1: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                           external 'TpNumLib'  index   72;
+procedure slegpb(n, l: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                               external 'TpNumLib'  index   73;
+procedure slegpbl(n, l: ArbInt;var a1; var b1, x1, ca: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                       external 'TpNumLib'  index   74;
+procedure slegpd(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                          external 'TpNumLib'  index   75;
+procedure slegpdl(n: ArbInt; var a1; var b1, x1, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                          external 'TpNumLib'  index   76;
+procedure slegsy(n, rwidth: ArbInt; var a, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                          external 'TpNumLib'  index   77;
+procedure slegsyl(n: ArbInt; var a1; var b1, x1, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                          external 'TpNumLib'  index   78;
+procedure slegtr(n:ArbInt; var l, d, u, b, x, ca: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                             external 'TpNumLib'  index   79;
+function spebi0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   80;
+function spebi1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   81;
+function spebj0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   82;
+function spebj1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   83;
+function spebk0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   84;
+function spebk1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   85;
+function speby0(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 22 september 1993}                                                                                            external 'TpNumLib'  index   86;
+function speby1(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index   87;
+function speent(x: ArbFloat): longint; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}                                                                                               external 'TpNumLib'  index   88;
+function speerf(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}                                                                                              external 'TpNumLib'  index   89;
+function speefc(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}                                                                                              external 'TpNumLib'  index   90;
+function spegam(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 25 oktober 1993}                                                                                              external 'TpNumLib'  index   91;
+function spelga(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 20 oktober 1993}                                                                                              external 'TpNumLib'  index   92;
+function spemax(a, b: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}                                                                                           external 'TpNumLib'  index   93;
+function spepol(x: ArbFloat; var a: ArbFloat; n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}                                                                  external 'TpNumLib'  index   94;
+function spepow(a, b: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 26 oktober 1993}                                                                                           external 'TpNumLib'  index   95;
+function spesgn(x: ArbFloat): ArbInt; {ok 26 oktober 1993}                                                                                                                                        external 'TpNumLib'  index   96;
+function spears(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 21 oktober 1993}                                                                                              external 'TpNumLib'  index   97;
+function spearc(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 21 oktober 1993}                                                                                              external 'TpNumLib'  index   98;
+function spesih(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index   99;
+function specoh(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index  100;
+function spetah(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index  101;
+function speash(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index  102;
+function speach(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index  103;
+function speath(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF} {ok 28 september 1993}                                                                                            external 'TpNumLib'  index  104;
+function  spl1bspv(q: ArbInt; var kmin1, c1: ArbFloat; x: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                          external 'TpNumLib'  index  105;
+function  spl2bspv(qx, qy: ArbInt; var kxmin1, kymin1, c11: ArbFloat; x, y: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                        external 'TpNumLib'  index  106;
+procedure spl1bspf(M, Q: ArbInt; var XYW1: ArbFloat;var Kmin1, C1, residu: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                    external 'TpNumLib'  index  107;
+procedure spl2bspf(M, Qx, Qy: ArbInt; var XYZW1: ArbFloat;var Kxmin1, Kymin1, C11, residu: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                    external 'TpNumLib'  index  108;
+procedure spl1nati(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                      external 'TpNumLib'  index  109;
+procedure spl1naki(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                      external 'TpNumLib'  index  110;
+procedure spl1cmpi(n: ArbInt; var xyc1: ArbFloat; dy1, dyn: ArbFloat;var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                   external 'TpNumLib'  index  111;
+procedure spl1peri(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                      external 'TpNumLib'  index  112;
+function  spl1pprv(n: ArbInt; var xyc1: ArbFloat; t: ArbFloat; var term: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                               external 'TpNumLib'  index  113;
+procedure spl1nalf(n: ArbInt; var xyw1: ArbFloat; lambda:ArbFloat;var xac1, residu: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                          external 'TpNumLib'  index  114;
+function spl2natv(n: ArbInt; var xyg0: ArbFloat; u, v: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                               external 'TpNumLib'  index  115;
+procedure spl2nalf(n: ArbInt; var xyzw1: ArbFloat; lambda:ArbFloat;var xyg0, residu: ArbFloat; var term: ArbInt); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                         external 'TpNumLib'  index  116;
+{procedure Intsle(l: ArbInt; e: ArbFloat); {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                                 external 'TpNumLib'  index  117;}
+function dllversion:LONGINT; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                                              external 'TpNumLib'  index   117;
+function exp(x: ArbFloat): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                                      external 'TpNumLib'  index  118;
+function MachCnst(n: ArbInt): ArbFloat; {$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                                                   external 'TpNumLib'  index  119;
+procedure ipffsn(n: ArbInt; var x, y, a, d2a: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                 external 'TpNumLib'  index  120;
+procedure ipfisn(n: ArbInt; var x, y, d2s: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                    external 'TpNumLib'  index  121;
+function  ipfspn(n: ArbInt; var x, y, d2s: ArbFloat; t: ArbFloat;var term: ArbInt): ArbFloat;{$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                              external 'TpNumLib'  index  122;
+procedure ipfpol(m, n: ArbInt; var x, y, b: ArbFloat; var term: ArbInt);{$IFDEF Needsstdcall} stdcall; {$ENDIF}                                                                                   external 'TpNumLib'  index  123;
+function spline(n: ArbInt; x: complex; var ac: complex; var gammar: ArbFloat; u1: ArbFloat; pf: complex): ArbFloat;{$IFDEF Needsstdcall} stdcall; {$ENDIF}                                        external 'TpNumLib'  index  124;
+procedure splineparameters (n: ArbInt; var ac, alfadc: complex; var lambda, gammar, u1, kwsom, energie: ArbFloat; var pf: complex);{$IFDEF Needsstdcall} stdcall; {$ENDIF}                        external 'TpNumLib'  index  125;
+
+
+FUNCTION CheckVersion: BOOLEAN;
+
+BEGIN
+ CheckVersion:=dllVersion=Numlib_dll_version;
+END;
+
+
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/numlib.txt

@@ -0,0 +1,111 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             Documentation by Michael van Canneyt ([email protected])
+
+    This is an internal document with information collected during porting
+    numlib to FPC
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+NumLib ported.txt, internals or "Developpers docs".
+
+ARBFLOAT, basic Floating point type.
+-----------------------------------
+
+In the FPC revision instead of picking a certain floating point type,
+a new type "ArbFloat" is defined which is used as floating point type
+throughout the entire library. If the floating point type is changed,
+define or undefine ArbExtended and add the machineconstants change to
+the type selected.
+
+This allows IEEE Double (64bit) and Extended(80bit).
+
+ARBINT, basic INTEGER type.
+-----------------------------------
+
+Because in plain FPC mode Integer =16-bits (for TP compatibility), and in
+Delphi 32-bits, I changed all integers to ArbInt.
+The basic idea is the same as ArbFloat, but it is less consequently used,
+mainly because some typecastings of pointers to words existed. These
+typecastings should never be 16-bits in FPC, so all local variables are
+longint. (which is currently always 32bits)
+
+VECTOR or MATRIX as ArbFloat.
+-----------------------------------
+NumLib often passes Matrices and Vectors as one ArbFloat + some integer
+values, then maps the following pmatrix type over it, and accesses it as an
+array or vector:
+
+procedure dosomething(var invalue:ArbFloat);
+
+type Row=ARRAY[0..maxelements] OF ArbFloat;
+     Matrix=Array[0..maxelements] OF ^ROW;
+     pmatrix=^matrix;
+
+Var pa : pmatrix;
+begin
+ pa=@invalue;
+ pa[x]^[y]:=valuexy
+END;
+
+The calling side looks like this:
+
+VAR L : ARRAY[0..1999] OF ArbFloat;
+
+DoSomething(L[0]);
+
+-----------
+Questions that remain open/incompleteneses in the package we got:
+
+- Typ, mdt and Dsl,spl are undocumented. Typ is quite understandable though.
+  Mdt and dsl contain probably procedures that, in earlier version were
+  used as locals in some unit. When the procedures were also used in other units,
+  they were moved to a different unit, but the documentation wasn't extended.
+  SPL is different in many ways. Contains comments (including some english
+  ones)
+- All procedures with an extra l appended to the name in unit SLE are
+  undocumented.
+- The archive we got seems to be a copy of the working directory of the author,
+    a snapshot during a never finished restructure. (probably matlab and
+    similar programs took over)
+   The sources/finished directory was the "new" archive, which generated a
+   .dll. All graphics using routines, and new units were never finished.
+   The problem is that also the documentation was never finished.
+- How to implement a less ugly calling convention, without loosing speed.
+  (which still can be important in nummerics)?
+
+Other remarks:
+- Spe needs some constants recalculated to get full precision for extended,
+  the files to calc the constants aren't included. (copied from some reference
+  book?) Some units have literature references in the documentation. Spe
+  (Murphy's law) doesn't.
+
+-------------
+Some translation problems:
+
+I left the term "Bandmatrix" untranslated, and give the mathematical definition
+here, and hope you know what it is in english:
+
+If A is a "n x n" bandmatrix with leftbound l, and rightbound r then
+
+Aij=0 if j<i-l or j>i+r
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:11:28  marco
+   * initial version
+
+
+}

packages/numlib/ode.pas

@@ -0,0 +1,339 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Solve first order starting value differential eqs, and
+    sets of first order starting value differential eqs,
+
+    Both versions are not suited for stiff differential equations
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+Unit ode;
+{$I DIRECT.INC}
+
+
+interface
+
+uses typ;
+
+{Solve first order, starting value, differential eqs,
+Calc y(b) for dy/dx=f(x,y) and y(a)=ae}
+
+Procedure odeiv1(f: rfunc2r; a, ya: ArbFloat; Var b, yb: ArbFloat;
+                 ae: ArbFloat; Var term: ArbInt);
+
+{ The same as above, for a set of equations. ya and yb are vectors}
+Procedure odeiv2(f: oderk1n; a: ArbFloat; Var ya, b, yb: ArbFloat;
+                 n: ArbInt; ae: ArbFloat; Var term: ArbInt);
+
+implementation
+
+Procedure odeiv1(f: rfunc2r; a, ya: ArbFloat; Var b, yb: ArbFloat;
+                 ae: ArbFloat; Var term: ArbInt);
+
+Var last, first, reject, goon         : boolean;
+    x, y, d, h, xl, yl, int, hmin,
+    absh,k0, k1, k2, k3, k4, k5,
+    discr, tol, mu, mu1, fh, hl       : ArbFloat;
+Begin
+    x := a;
+ y := ya;
+ d := b-a;
+ yb := y;
+ term := 1;
+    If ae <= 0 Then
+     Begin
+        term := 3;
+      exit
+     End;
+    If d <> 0 Then
+     Begin
+        xl := x;
+      yl := y;
+      h := d/4;
+      absh := abs(h);
+        int := abs(d);
+      hmin := int*1e-6;
+        ae := ae/int;
+      first := true;
+      goon := true;
+        while goon Do
+        Begin
+            absh := abs(h);
+            If absh < hmin Then
+             Begin
+                If h>0 Then h := hmin
+              Else h := -hmin;
+                absh := hmin
+             End;
+            If (h >= b-xl) = (h >= 0) Then
+             Begin
+                last := true;
+              h := b-xl;
+              absh := abs(h)
+             End
+         Else last := false;
+            x := xl;
+         y := yl;
+         k0 := f(x,y)*h;
+            x := xl+h*2/9;
+         y := yl+k0*2/9;
+         k1 := f(x,y)*h;
+            x := xl+h/3;
+         y := yl+(k0+k1*3)/12;
+         k2 := f(x,y)*h;
+            x := xl+h/2;
+         y := yl+(k0+k2*3)/8;
+         k3 := f(x,y)*h;
+            x := xl+h*0.8;
+         y := yl+(k0*53-k1*135+k2*126+k3*56)/125;
+         k4 := f(x,y)*h;
+            If last Then x := b
+         Else x := xl+h;
+            y := yl+(k0*133-k1*378+k2*276+k3*112+k4*25)/168;
+         k5 := f(x,y)*h;
+            discr := abs(21*(k0-k3)-162*(k2-k3)-125*(k4-k3)+42*(k5-k3))/14;
+            tol := absh*ae;
+            mu := 1/(1+discr/tol)+0.45;
+            reject := discr > tol;
+            If reject Then
+             Begin
+                If absh <= hmin Then
+                 Begin
+                    b := xl;
+                  yb := yl;
+                  term := 2;
+                  exit
+                 End;
+                h := mu*h
+             End
+         Else
+            Begin
+                If first Then
+                 Begin
+                    first := false;
+                  hl := h;
+                  h := mu*h
+                 End
+             Else
+                Begin
+                    fh := mu*h/hl+mu-mu1;
+                 hl := h;
+                 h := fh*h
+                End;
+                mu1 := mu;
+                y := yl+(-k0*63+k1*189-k2*36-k3*112+k4*50)/28;
+             k5 := f(x,y)*hl;
+                y := yl+(k0*35+k2*162+k4*125+k5*14)/336;
+                If b <> x Then
+                 Begin
+                    xl := x;
+                  yl := y
+                 End
+             Else
+                Begin
+                    yb := y;
+                 goon := false
+                End
+            End {not reject}
+        End; {while}
+     End {d<>0}
+End; {odeiv1}
+
+Procedure odeiv2(f: oderk1n; a: ArbFloat; Var ya, b, yb: ArbFloat;
+                 n: ArbInt; ae: ArbFloat; Var term: ArbInt);
+
+Var pya, pyb, yl, k0, k1, k2, k3, k4, k5, y : ^arfloat1;
+    i, jj, ns                               : ArbInt;
+    last, first, reject, goon               : boolean;
+    x, xl, hmin, int, hl, absh, fhm,
+    discr, tol, mu, mu1, fh, d, h           : ArbFloat;
+Begin
+    If (ae <= 0) Or (n < 1) Then
+     Begin
+        term := 3;
+      exit
+     End;
+    ns := n*sizeof(ArbFloat);
+    pya := @ya;
+ pyb := @yb;
+ move(pya^[1], pyb^[1], ns);
+ term := 1;
+    getmem(yl, ns);
+ getmem(k0, ns);
+ getmem(k1, ns);
+ getmem(k2, ns);
+    getmem(k3, ns);
+ getmem(k4, ns);
+ getmem(k5, ns);
+ getmem(y, ns);
+    x := a;
+ d := b-a;
+ move(pya^[1], y^[1], ns);
+    If d <> 0 Then
+     Begin
+        xl := x;
+      move(y^[1], yl^[1], ns);
+      h := d/4;
+      absh := abs(h);
+        int := abs(d);
+      hmin := int*1e-6;
+      hl := ae;
+      ae := ae/int;
+        first := true;
+      goon := true;
+        while goon Do
+        Begin
+            absh := abs(h);
+            If absh < hmin Then
+             Begin
+                If h > 0 Then h := hmin
+              Else h := -hmin;
+                absh := hmin
+             End;
+            If (h >= b-xl) = (h >= 0) Then
+             Begin
+                last := true;
+              h := b-xl;
+              absh := abs(h)
+             End
+         Else last := false;
+            x := xl;
+         move(yl^[1], y^[1], ns);
+            f(x, y^[1], k0^[1]);
+            For i:=1 To n Do
+             k0^[i] := k0^[i]*h;
+            x := xl+h*2/9;
+            For jj:=1 To n Do
+             y^[jj] := yl^[jj]+k0^[jj]*2/9;
+            f(x, y^[1], k1^[1]);
+            For i:=1 To n Do
+             k1^[i] := k1^[i]*h;
+            x := xl+h/3;
+            For jj:=1 To n Do
+             y^[jj] := yl^[jj]+(k0^[jj]+k1^[jj]*3)/12;
+            f(x, y^[1], k2^[1]);
+            For i:=1 To n Do
+             k2^[i] := k2^[i]*h;
+            x := xl+h/2;
+            For jj:=1 To n Do
+             y^[jj] := yl^[jj]+(k0^[jj]+k2^[jj]*3)/8;
+            f(x, y^[1], k3^[1]);
+            For i:=1 To n Do
+             k3^[i] := k3^[i]*h;
+            x := xl+h*0.8;
+            For jj:=1 To n Do
+             y^[jj] := yl^[jj]+
+                       (k0^[jj]*53-k1^[jj]*135+k2^[jj]*126+k3^[jj]*56)/125;
+            f(x, y^[1], k4^[1]);
+            For i:=1 To n Do
+             k4^[i] := k4^[i]*h;
+            If last Then x := b
+         Else x := xl+h;
+            For jj:=1 To n Do
+             y^[jj] := yl^[jj]+(k0^[jj]*133-k1^[jj]*378+k2^[jj]*276+
+                               k3^[jj]*112+k4^[jj]*25)/168;
+            f(x, y^[1], k5^[1]);
+            For i:=1 To n Do
+             k5^[i] := k5^[i]*h;
+            reject := false;
+         fhm := 0;
+         tol := absh*ae;
+            For jj:=1 To n Do
+             Begin
+                discr := abs((k0^[jj]-k3^[jj])*21-(k2^[jj]-k3^[jj])*162-
+                         (k4^[jj]-k3^[jj])*125+(k5^[jj]-k3^[jj])*42)/14;
+                reject := (discr > tol) Or  reject;
+              fh := discr/tol;
+                If fh > fhm Then fhm := fh
+             End; {jj}
+            mu := 1/(1+fhm)+0.45;
+            If reject Then
+             Begin
+                If absh <= hmin Then
+                 Begin
+                    b := xl;
+                  move(yl^[1], pyb^[1], ns);
+                  term := 2;
+                    freemem(yl, ns);
+                  freemem(k0, ns);
+                    freemem(k1, ns);
+                  freemem(k2, ns);
+                    freemem(k3, ns);
+                  freemem(k4, ns);
+                    freemem(k5, ns);
+                  freemem(y, ns);
+                  exit
+                 End;
+                h := mu*h
+             End
+         Else
+            Begin
+                If first Then
+                 Begin
+                    first := false;
+                  hl := h;
+                  h := mu*h
+                 End
+             Else
+                Begin
+                    fh := mu*h/hl+mu-mu1;
+                 hl := h;
+                 h := fh*h
+                End;
+                mu1 := mu;
+                For jj:=1 To n Do
+                 y^[jj] := yl^[jj]+(-k0^[jj]*63+k1^[jj]*189
+                                  -k2^[jj]*36-k3^[jj]*112+k4^[jj]*50)/28;
+                f(x, y^[1], k5^[1]);
+                For i:=1 To n Do
+                 k5^[i] := k5^[i]*hl;
+                For jj:=1 To n Do
+                 y^[jj] := yl^[jj]+(k0^[jj]*35+k2^[jj]*162+k4^[jj]*125
+                           +k5^[jj]*14)/336;
+                If b <> x Then
+                 Begin
+                    xl := x;
+                  move(y^[1], yl^[1], ns)
+                 End
+             Else
+                Begin
+                    move(y^[1], pyb^[1], ns);
+                 goon := false
+                End
+            End {not reject}
+       End {while}
+     End; {d<>0}
+  freemem(yl, ns);
+ freemem(k0, ns);
+ freemem(k1, ns);
+ freemem(k2, ns);
+  freemem(k3, ns);
+ freemem(k4, ns);
+ freemem(k5, ns);
+ freemem(y, ns)
+End; {odeiv2}
+
+End.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/omv.pas

@@ -0,0 +1,274 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    This unit contains some basic matrix operations.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+Unit omv;
+{$I direct.inc}
+
+interface
+
+uses typ;
+
+{Calculates inproduct of vectors a and b which have N elements. The first
+element is passed in a and b}
+Function omvinp(Var a, b: ArbFloat; n: ArbInt): ArbFloat;
+
+{Multiplication of two matrices C=AxB }
+Procedure omvmmm(Var a: ArbFloat; m, n, rwa: ArbInt;
+                 Var b: ArbFloat; k, rwb: ArbInt;
+                 Var c: ArbFloat; rwc: ArbInt);
+
+{Multiplication of a matrix(A) with a vector(B), C=A x B}
+Procedure omvmmv(Var a: ArbFloat; m, n, rwidth: ArbInt; Var b, c: ArbFloat);
+
+{Calculate 1-Norm of matrix A}
+Function omvn1m(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
+
+{Calculate 1-Norm of vector A}
+Function omvn1v(Var a: ArbFloat; n: ArbInt): ArbFloat;
+
+{Calculate 2-Norm of vector A}
+Function omvn2v(Var a: ArbFloat; n: ArbInt): ArbFloat;
+
+{Calculate Frobenius-Norm of mxn matrix A}
+Function omvnfm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
+
+{Calculates maximum (infinite) norm of mxn matrix a}
+Function omvnmm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
+
+{Calculates maximum (infinite) norm of n-Vector }
+Function omvnmv(Var a: ArbFloat; n: ArbInt): ArbFloat;
+
+{Transponate mxn matrix A  (which was declared rwa bytes wide), put
+it to C (rwc was declared elements wide)}
+Procedure omvtrm(Var a: ArbFloat; m, n, rwa: ArbInt; Var c: ArbFloat;
+                        rwc: ArbInt);
+
+IMPLEMENTATION
+
+Function omvinp(Var a, b: ArbFloat; n: ArbInt): ArbFloat;
+
+Var        pa, pb : ^arfloat1;
+                i : ArbInt;
+                s : ArbFloat;
+Begin
+  If n<1 Then
+    exit(0);
+  pa := @a;
+ pb := @b;
+ s := 0;
+  For i:=1 To n Do
+    Begin
+      s := s+pa^[i]*pb^[i]
+    End; {i}
+  omvinp := s
+End; {omvinp}
+
+Procedure omvmmm(Var a: ArbFloat; m, n, rwa: ArbInt;
+                 Var b: ArbFloat; k, rwb: ArbInt;
+                 Var c: ArbFloat; rwc: ArbInt);
+
+Var           pa, pb, pc : ^arfloat1;
+     i, j, l, inda, indc : ArbInt;
+                       s : ArbFloat;
+Begin
+  If (m<1) Or (n<1) Or (k<1) Then
+   exit;
+  pa := @a;
+ pb := @b;
+ pc := @c;
+  For i:=1 To m Do
+    Begin
+      inda := (i-1)*rwa;
+      indc := (i-1)*rwc;
+      For j:=1 To k Do
+        Begin
+          s := 0;
+          For l:=1 To n Do
+            s := s+pa^[inda+l]*pb^[(l-1)*rwb+j];
+          pc^[indc+j] := s
+        End {j}
+    End; {i}
+End; {omvmmm}
+
+Procedure omvmmv(Var a: ArbFloat; m, n, rwidth: ArbInt; Var b, c: ArbFloat);
+
+Var     pa, pb, pc : ^arfloat1;
+         i, j, ind : ArbInt;
+Begin
+  If (m<1) Or (n<1) Then
+    exit;
+  pa := @a;
+ pb := @b;
+ pc := @c;
+ ind := 0;
+  For i:=1 To m Do
+    Begin
+      pc^[i] := omvinp(pa^[ind+1], pb^[1], n);
+      ind := ind+rwidth
+    End; {i}
+End; {omvmmv}
+
+Function omvn1m(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
+
+Var           pa : ^arfloat1;
+            i, j : ArbInt;
+     norm, normc : ArbFloat;
+
+Begin
+  If (m<1) Or (n<1) Then
+    exit;
+  pa := @a;
+ norm := 0;
+  For j:=1 To n Do
+    Begin
+      normc := 0;
+      For i:=1 To m Do
+        normc := normc+abs(pa^[j+(i-1)*rwidth]);
+      If norm<normc Then
+        norm := normc
+    End;
+  omvn1m := norm
+End {omvn1m};
+
+Function omvn1v(Var a: ArbFloat; n: ArbInt): ArbFloat;
+
+Var   pa : ^arfloat1;
+       i : ArbInt;
+    norm : ArbFloat;
+
+Begin
+  If n<1 Then
+    exit;
+  pa := @a;
+  norm := 0;
+  For i:=1 To n Do
+    norm := norm+abs(pa^[i]);
+  omvn1v := norm
+End {omvn1v};
+
+Function omvn2v(Var a: ArbFloat; n: ArbInt): ArbFloat;
+
+Var   pa : ^arfloat1;
+       i : ArbInt;
+    norm : ArbFloat;
+
+Begin
+  If n<1 Then
+    exit;
+  pa := @a;
+  norm := 0;
+  For i:=1 To n Do
+    norm := norm+sqr(pa^[i]);
+  omvn2v := sqrt(norm)
+End {omvn2v};
+
+Function omvnfm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
+
+Var      pa : ^arfloat1;
+    i, j, k : ArbInt;
+       norm : ArbFloat;
+
+Begin
+  If (m<1) Or (n<1) Then
+    exit;
+  pa := @a;
+ norm := 0;
+ k := 0;
+  For i:=1 To m Do
+    Begin
+      For j:=1 To n Do
+        norm := norm+sqr(pa^[j+k]);
+      k := k+rwidth
+    End;
+  omvnfm := sqrt(norm)
+End {omvnfm};
+
+Function omvnmm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
+
+Var          pa : ^arfloat1;
+           i, k : ArbInt;
+    normr, norm : ArbFloat;
+
+Begin
+  If (m<1) Or (n<1) Then
+    exit;
+  pa := @a;
+ norm := 0;
+ k := 0;
+  For i:=1 To m Do
+    Begin
+      normr := omvn1v(pa^[1+k], n);
+      If norm<normr Then
+        norm := normr;
+      k := k+rwidth
+    End;
+  omvnmm := norm
+End {omvnmm};
+
+Function omvnmv(Var a: ArbFloat; n: ArbInt): ArbFloat;
+
+Var       pa : ^arfloat1;
+           i : ArbInt;
+    norm, aa : ArbFloat;
+
+Begin
+  If (n<1) Then
+    exit;
+  pa := @a;
+  norm := 0;
+  For i:=1 To n Do
+    Begin
+      aa := abs(pa^[i]);
+      If aa>norm Then
+        norm := aa
+    End;
+  omvnmv := norm
+End {omvnmv};
+
+Procedure omvtrm(Var a: ArbFloat; m, n, rwa: ArbInt;
+                 Var c: ArbFloat; rwc: ArbInt);
+
+Var        pa, pc : ^arfloat1;
+           ind, i, j : ArbInt;
+
+Begin
+  If (m<1) Or (n<1) Then
+    exit;
+  pa := @a;
+ pc := @c;
+ ind := 0;
+  For i:=1 To m Do
+    Begin
+      For j:=1 To n Do
+        pc^[(j-1)*rwc+i] := pa^[ind+j];
+      ind := ind+rwa
+    End; {i}
+End; {omvtrm}
+
+End.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/roo.pas

@@ -0,0 +1,1444 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Unit to find roots of (various kinds of) equations
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+Unit roo;
+{$i direct.inc}
+
+interface
+
+uses typ, spe;
+
+{Find the all roots of the binomial eq. x^n=a, with "a" a complex number}
+
+Procedure roobin(n: ArbInt; a: complex; Var z: complex; Var term: ArbInt);
+
+{Find root point of f(x)=0 with f(x) a continuous function on domain [a,b]
+ If f(a)*f(b)<=0 then there must be (at least) one rootpoint}
+
+Procedure roof1r(f: rfunc1r; a, b, ae, re: ArbFloat; Var x: ArbFloat;
+                 Var term: ArbInt);
+
+{Determine all zeropoints for a given n'th degree polynomal with real
+coefficients}
+
+Procedure roopol(Var a: ArbFloat; n: ArbInt; Var z: complex;
+                 Var k, term: ArbInt);
+
+{Find roots for a simple 2th degree eq  x^2+px+q=0 with p and q real}
+
+Procedure rooqua(p, q: ArbFloat; Var z1, z2: complex);
+
+{Roofnr is undocumented, but verry big}
+
+Procedure roofnr(f: roofnrfunc; n: ArbInt; Var x, residu: ArbFloat; re: ArbFloat;
+                 Var term: ArbInt);
+
+{ term : 1     succesful termination
+         2     Couldn't reach the specified precision
+               Value X is the best one which could be found.
+         3     Wrong input
+         4     Too many functionvalues calculated, try to recalc with the
+                calculated X
+         5     Not enough progress. Possibly there is no solution, or the
+               solution is too close to 0. Try to choose a different
+               initial startingvalue
+         6     Process wants to calculate a function value outside the by
+               "deff" defined area.
+}
+
+implementation
+
+Procedure roobin(n: ArbInt; a: complex; Var z: complex; Var term: ArbInt);
+{ This procedure solves the binomial equation z**n = a, with a complex}
+
+Var         i, j, k : ArbInt;
+    w, fie, dfie, r : ArbFloat;
+                 pz : ^arcomp1;
+Begin
+  If n<1 Then
+   Begin
+      term := 2;
+    exit
+   End;
+  term := 1;
+ pz := @z;
+ dfie := 2*pi/n;
+ k := 1;
+  If a.im=0 Then
+   Begin
+      If a.re>0 Then
+       Begin
+          r := spepow(a.re, 1/n);
+        pz^[1].Init(r, 0);
+          k := k+1;
+        i := (n-1) Div 2;
+          If Not odd(n) Then
+           Begin
+              pz^[k].Init(-r, 0);
+            k := k+1
+           End;
+          For j:=1 To i Do
+           Begin
+              w := j*dfie;
+              pz^[k].Init(r*cos(w), r*sin(w));
+              pz^[k+1] := pz^[k];
+            pz^[k+1].Conjugate;
+              k := k+2
+           End
+       End
+    Else
+      Begin
+          fie := pi/n;
+       r := spepow(-a.re, 1/n);
+       i := n Div 2-1;
+          If odd(n) Then
+           Begin
+              pz^[k].Init(-r, 0);
+            k := k+1
+           End;
+          For j:=0 To i Do
+           Begin
+              w := fie+j*dfie;
+              pz^[k].Init(r*cos(w), r*sin(w));
+              pz^[k+1] := pz^[k];
+            pz^[k+1].Conjugate;
+              k := k+2
+           End
+      End
+   End
+ Else
+  Begin
+      If abs(a.re)>=abs(a.im) Then
+       r := spepow(abs(a.re)*sqrt(1+sqr(a.im/a.re)), 1/n)
+      Else r := spepow(abs(a.im)*sqrt(1+sqr(a.re/a.im)), 1/n);
+      fie := a.arg/n;
+   i := n Div 2;
+      For j:=0 To n-1 Do
+       Begin
+          w := fie+(j-i)*dfie;
+          pz^[j+1].Init(r*cos(w), r*sin(w))
+       End
+   End
+End {roobin};
+
+Procedure roof1r(f: rfunc1r; a, b, ae, re: ArbFloat; Var x: ArbFloat;
+                 Var term: ArbInt);
+
+Var fa, fb, c, fc, m, tol, w1, w2 : ArbFloat;
+                                k : ArbInt;
+                             stop : boolean;
+
+Begin
+  fa := f(a);
+ fb := f(b);
+  If (spesgn(fa)*spesgn(fb)=1) Or (ae<0) Or (re<0)
+   Then  {wrong input}
+    Begin
+      term := 3;
+     exit
+    End;
+  If abs(fb)>abs(fa) Then
+    Begin
+      c := b;
+     fc := fb;
+     x := a;
+     b := a;
+     fb := fa;
+     a := c;
+     fa := fc
+    End
+ Else
+    Begin
+      c := a;
+     fc := fa;
+     x := b
+    End;
+  k := 0;
+  tol := ae+re*spemax(abs(a), abs(b));
+  w1 := abs(b-a);
+ stop := false;
+  while (abs(b-a)>tol) and (fb<>0) and (Not stop) Do
+    Begin
+      m := (a+b)/2;
+      If (k>=2) Or (fb=fc) Then x := m
+     Else
+        Begin
+          x := (b*fc-c*fb)/(fc-fb);
+          If abs(b-x)<tol Then x := b-tol*spesgn(b-a);
+          If spesgn(x-m)=spesgn(x-b) Then x := m
+        End;
+      c := b;
+     fc := fb;
+     b := x;
+     fb := f(x);
+      If spesgn(fa)*spesgn(fb)>0 Then
+        Begin
+          a := c;
+         fa := fc;
+         k := 0
+        End
+     Else k := k+1;
+      If abs(fb)>=abs(fa) Then
+        Begin
+          c := b;
+         fc := fb;
+         x := a;
+         b := a;
+         fb := fa;
+         a := c;
+         fa := fc;
+         k := 0
+        End;
+      tol := ae+re*spemax(abs(a), abs(b));
+      w2 := abs(b-a);
+      If w2>=w1 Then
+        Begin
+          stop := true;
+         term := 2
+        End;
+      w1 := w2
+    End;
+  If Not stop Then term := 1
+End {roof1r};
+
+Procedure roopol(Var a: ArbFloat; n: ArbInt; Var z: complex;
+                 Var k, term: ArbInt);
+
+Const max = 50;
+
+Type  rnep2 = array[-2..$ffe0 div SizeOf(ArbFloat)] Of ArbFloat;
+
+Var rk, i, j, l, m, length, term1                             : ArbInt;
+    p, q, r, s, f, df, delp, delq, delr, telp, telq, sn, sn1,
+    sn2, noise, noise1, noise2, g, absr, maxcoef, coef, d, t,
+    maxx, fac, meps                                           : ArbFloat;
+    convergent, linear, quadratic                             : boolean;
+    u, v                                                      : complex;
+    pa                                                        : ^arfloat1;
+    pb, pc, ph                                                : ^rnep2;
+    pz                                                        : ^arcomp1;
+
+Function gcd(n, m: ArbInt): ArbInt;
+{ This function computes the greatest common divisor of m and n}
+
+Var r : ArbInt;
+Begin
+    r := n Mod m;
+    while r>0 Do
+    Begin
+        n := m;
+     m := r;
+     r := n Mod m
+    End;
+    gcd := m
+End {gcd};
+Begin
+    If n<1 Then
+     Begin
+        term := 3;
+      exit
+     End;
+    length := (n+3)*sizeof(ArbFloat);
+    getmem(pb, length);
+ getmem(pc, length);
+ getmem(ph, length);
+    meps := macheps;
+    pa := @a;
+ pz := @z;
+    pb^[-2] := 0;
+ pb^[-1] := 0;
+ pc^[-2] := 0;
+ pc^[-1] := 0;
+ ph^[-1] := 0;
+ ph^[0] := 1;
+    For i:=1 To n Do
+     ph^[i] := pa^[i];
+    k := 0;
+    while (n>0) and (ph^[n]=0) Do
+    Begin
+        k := k+1;
+     pz^[k].Init(0, 0);
+     n := n-1
+    End;
+    If n>0 Then
+     Begin
+        l := n;
+      i := 1;
+        while (l>1) and (i<n) Do
+        Begin
+            If ph^[i] <> 0 Then l := gcd(l, n-i);
+         i := i+1
+        End;
+        If l>1 Then
+         Begin
+            n := n Div l;
+            For i:=1 To n Do
+             ph^[i] := ph^[l*i]
+         End
+     End;
+    convergent := true ;
+    while (n>0) and convergent Do
+    Begin
+        linear := false;
+     quadratic := false ;
+        If n=1 Then
+         Begin
+            r := -ph^[1]/ph^[0];
+          linear := true
+         End;
+        If n=2 Then
+         Begin
+            p := ph^[1]/ph^[0];
+          q := ph^[2]/ph^[0];
+          quadratic := true
+         End;
+        If n>2 Then
+         Begin
+            If (ph^[n-1]=0) Or (ph^[n-2]=0) Then
+             Begin
+                maxcoef := abs(ph^[n-1]/ph^[n]);
+                For i:=2 To n Do
+                 Begin
+                    coef := spepow(abs(ph^[n-i]/ph^[n]),1/i);
+                    If maxcoef<coef Then maxcoef := coef
+                 End;
+                maxcoef := 2*maxcoef
+             End;
+            If ph^[n-1]=0 Then r := -spesgn(ph^[0])*spesgn(ph^[n])/maxcoef
+            Else r := -ph^[n]/ph^[n-1];
+            If ph^[n-2]=0 Then
+             Begin
+                p := 0;
+              q := -1/sqr(maxcoef)
+             End
+          Else
+            Begin
+                q := ph^[n]/ph^[n-2];
+             p := (ph^[n-1]-q*ph^[n-3])/ph^[n-2]
+            End;
+            m := 0;
+            while (m<max) and (Not linear) and (Not quadratic) Do
+            Begin
+                m := m+1;
+                For j:=0 To n Do
+                 pb^[j] := ph^[j]-p*pb^[j-1]-q*pb^[j-2];
+                For j:=0 To n-2 Do
+                 pc^[j] := pb^[j]-p*pc^[j-1]-q*pc^[j-2];
+                pc^[n-1] := -p*pc^[n-2]-q*pc^[n-3];
+                s := sqr(pc^[n-2])-pc^[n-1]*pc^[n-3];
+                telp := pb^[n-1]*pc^[n-2]-pb^[n]*pc^[n-3];
+                telq := pb^[n]*pc^[n-2]-pb^[n-1]*pc^[n-1];
+                If s=0 Then
+                 Begin
+                    delp := telp;
+                  delq := telq
+                 End
+             Else
+                Begin
+                    delp := telp/s;
+                 delq := telq/s
+                End;
+                noise1 := 0;
+             sn1 := 0;
+             sn := 1;
+                noise2 := 4*abs(pb^[n])+3*abs(p*pb^[n-1]);
+                For j:=n-1 Downto 0 Do
+                 Begin
+                    g := 4*abs(pb^[j])+3*abs(p*pb^[j-1]);
+                    noise1 := noise1+g*abs(sn);
+                    sn2 := sn1;
+                  sn1 := sn;
+                  sn := -p*sn1-q*sn2;
+                    noise2 := noise2+g*abs(sn)
+                 End;
+                d := p*p-4*q;
+                absr := abs(r);
+             f := ph^[0];
+             df := 0;
+             noise := abs(f)/2;
+                For j:=1 To n Do
+                 Begin
+                    df := f+r*df;
+                  f := ph^[j]+r*f;
+                  noise := abs(f)+absr*noise
+                 End;
+                If df=0 Then delr := f
+             Else delr := f/df;
+                If (abs(telp)<=meps*(noise1*abs(pc^[n-2])+
+                               noise2*abs(pc^[n-3])))
+                   And
+                   (abs(telq)<=meps*(noise1* abs(pc^[n-1])+
+                             noise2*abs(pc^[n-2])))
+                 Then quadratic := true
+                Else
+                 Begin
+                    p := p+delp;
+                  q := q+delq
+                 End;
+                If abs(f)<=2*meps*noise Then linear := true
+             Else r := r-delr
+            End
+         End;
+        convergent := linear Or quadratic;
+        If linear Then
+         Begin
+            If l=1 Then
+             Begin
+                k := k+1;
+              pz^[k].xreal := r;
+              pz^[k].imag := 0
+             End
+          Else
+            Begin
+                u.init(r, 0);
+             roobin(l, u, pz^[k+1], term1);
+             k := k+l
+            End;
+            maxx := 0;
+          rk := 0;
+          fac := 1;
+            For j:=n Downto 0 Do
+             Begin
+                s := abs(ph^[j]*fac);
+              fac := fac*r;
+                If s>maxx Then
+                 Begin
+                    maxx := s;
+                  rk := j-1
+                 End
+             End;
+            For j:=1 To rk Do
+             ph^[j] := ph^[j]+r*ph^[j-1];
+            If rk<n-1 Then
+             Begin
+                s := ph^[n-1];
+              ph^[n-1] := -ph^[n]/r;
+                For j:=n-2 Downto rk+1 Do
+                 Begin
+                    t := ph^[j];
+                  ph^[j] := (ph^[j+1]-s)/r;
+                  s := t
+                 End
+             End;
+            n := n-1;
+         End
+     Else
+        If quadratic Then
+         Begin
+            If l=1 Then
+             Begin
+                rooqua(p,q,pz^[k+1],pz^[k+2]);
+              k := k+2
+             End
+          Else
+            Begin
+                rooqua(p,q,u,v);
+             roobin(l,u,pz^[k+1],term1);
+                roobin(l,v,pz^[k+l+1],term1);
+             k := k+2*l
+            End;
+            n := n-2;
+            For j:=1 To n Do
+             ph^[j] := ph^[j]-p*ph^[j-1]-q*ph^[j-2]
+         End
+  End;
+  If k<n Then term := 2
+ Else term := 1;
+  freemem(pb, length);
+ freemem(pc, length);
+ freemem(ph, length);
+End {roopol};
+
+Procedure rooqua(p, q: ArbFloat; Var z1, z2: complex);
+
+Var s, d : ArbFloat;
+Begin
+    p := -p/2;
+ d := sqr(p)-q;
+    If d<0 Then
+     Begin
+        z1.Init(p, sqrt(-d));
+      z2 := z1;
+      z2.conjugate
+     End
+ Else
+    Begin
+        If p>0 Then s := p+sqrt(d)
+     Else s := p-sqrt(d);
+        If s=0 Then
+         Begin
+            z1.Init(0, 0);
+          z2 := z1
+         End
+     Else
+        Begin
+            z1.Init(s, 0);
+         z2.Init(q/s, 0)
+        End
+    End
+End {rooqua};
+
+Procedure roo001(uplo, trans, diag: char; n: ArbInt; Var ap1, x1: ArbFloat;
+                 incx: ArbInt);
+
+Var 
+    ap   : arfloat1 absolute ap1;
+    x    : arfloat1 absolute x1;
+    temp : ArbFloat;
+    i, info, ix, j, jx, k, kk, kx: ArbInt;
+    nounit: boolean;
+Begin
+    info := 0;
+ uplo := upcase(uplo);
+ trans := upcase(trans);
+ diag := upcase(diag);
+    If n=0 Then exit;
+    nounit := diag='N';
+    If incx<=0 Then kx := 1-(n-1)*incx
+ Else kx := 1;
+    If trans='N' Then
+     Begin
+        If uplo='U' Then
+         Begin
+            kk := 1;
+          jx := kx;
+            For j:=1 To n Do
+             Begin
+                If x[jx]<>0 Then
+                 Begin
+                    temp := x[jx];
+                  ix := kx;
+                    For k:=kk To kk+j-2 Do
+                     Begin
+                        x[ix] := x[ix]+temp*ap[k];
+                        inc(ix, incx)
+                     End;
+                    If nounit Then x[jx] := x[jx]*ap[kk+j-1]
+                 End;
+                inc(jx, incx);
+              inc(kk, j)
+             End
+         End
+      Else
+        Begin
+            kk := n*(n+1) Div 2;
+         inc(kx, (n-1)*incx);
+         jx := kx;
+            For j:=n Downto 1 Do
+             Begin
+               If x[jx]<>0 Then
+                Begin
+                   temp := x[jx];
+                 ix := kx;
+                   For k:=kk Downto kk-(n-(j+1)) Do
+                    Begin
+                       x[ix] := x[ix]+temp*ap[k];
+                     dec(ix, incx)
+                    End;
+                   If nounit Then x[jx] := x[jx]*ap[kk-n+j]
+                End;
+               dec(jx, incx);
+              dec(kk, n-j+1)
+             End
+        End
+     End
+ Else
+    Begin
+        If uplo='U' Then
+         Begin
+            kk := n*(n+1) Div 2;
+          jx := kx+(n-1)*incx;
+            For j:= n Downto 1 Do
+             Begin
+               temp := x[jx];
+              ix := jx;
+               If nounit Then temp := temp*ap[kk];
+               For k:= kk-1 Downto kk-j+1 Do
+                Begin
+                   dec(ix, incx);
+                 temp := temp+ap[k]*x[ix]
+                End;
+               x[jx] := temp;
+              dec(jx, incx);
+              dec(kk, j)
+             End
+         End
+     Else
+        Begin
+            kk := 1;
+         jx := kx;
+            For j:=1 To n Do
+             Begin
+                temp := x[jx];
+              ix := jx;
+                If nounit Then temp := temp*ap[kk];
+                For k:=kk+1 To kk+n-j Do
+                 Begin
+                    inc(ix, incx);
+                  temp := temp+ap[k]*x[ix]
+                 End;
+                x[jx] := temp;
+              inc(jx, incx);
+              inc(kk, n-j+1)
+             End
+        End
+    End
+End;
+
+Procedure roo002(uplo, trans, diag: char; n: ArbInt;
+                  Var ap1, x1: ArbFloat; incx: ArbInt );
+
+Var ap : arfloat1 absolute ap1;
+    x  : arfloat1 absolute x1;
+    temp : ArbFloat;
+    i, info, ix, j, jx, k, kk, kx: ArbInt;
+    nounit: boolean;
+Begin
+    info := 0;
+ uplo := upcase(uplo);
+ trans := upcase(trans);
+ diag := upcase(diag);
+    If n=0 Then exit;
+    nounit := diag='N';
+    If incx<=0 Then kx := 1-(n-1)*incx
+ Else kx := 1;
+    If trans='N' Then
+     Begin
+        If uplo='U' Then
+         Begin
+            kk := n*(n+1) Div 2;
+          jx := kx+(n-1)*incx;
+            For j:=n Downto 1 Do
+             Begin
+                If x[jx]<>0 Then
+                 Begin
+                    If nounit Then x[jx] := x[jx]/ap[kk];
+                    temp := x[jx];
+                  ix := jx;
+                    For k:=kk-1 Downto kk-j+1 Do
+                     Begin
+                        dec(ix, incx);
+                      x[ix] := x[ix]-temp*ap[k];
+                     End
+                 End;
+                dec(jx, incx);
+              dec(kk, j)
+             End
+         End
+      Else
+        Begin
+            kk := 1;
+         jx := kx;
+            For j:=1 To n Do
+             Begin
+                If x[jx]<>0 Then
+                 Begin
+                    If nounit Then x[jx] := x[jx]/ap[kk];
+                    temp := x[jx];
+                  ix := jx;
+                    For k:= kk+1 To kk+n-j Do
+                     Begin
+                        inc(ix, incx);
+                      x[ix] := x[ix]-temp*ap[k]
+                     End;
+                 End;
+                inc(jx, incx);
+              inc(kk, n-j+1)
+             End
+         End
+     End
+ Else
+     Begin
+         If uplo='U' Then
+          Begin
+             kk := 1;
+           jx := kx;
+             For j:= 1 To n Do
+              Begin
+                 temp := x[jx];
+               ix := kx;
+                 For k:= kk To kk+j-2 Do
+                  Begin
+                     temp := temp-ap[k]*x[ix];
+                     inc(ix, incx);
+                  End;
+                 If nounit Then temp := temp/ap[kk+j-1];
+                 x[jx] := temp;
+               inc(jx, incx);
+               inc(kk, j)
+              End
+          End
+      Else
+          Begin
+              kk := n*(n+1) Div 2;
+           kx := kx+(n-1)*incx;
+           jx := kx;
+              For j:=n Downto 1 Do
+               Begin
+                  temp := x[jx];
+                ix := kx;
+                  For k:= kk Downto kk-(n-(j+1)) Do
+                   Begin
+                      temp := temp-ap[k]*x[ix];
+                    dec(ix, incx)
+                   End;
+                  If nounit Then temp := temp/ap[kk-n+j];
+                  x[jx] := temp;
+                dec(jx, incx);
+                dec(kk, n-j+1)
+               End
+          End
+     End
+End;
+
+Procedure roo003( n: ArbInt; Var x1: ArbFloat; incx: ArbInt;
+                  Var scale, sumsq: ArbFloat );
+
+Var absxi : ArbFloat;
+    i, ix : ArbInt;
+    x     : arfloat1 absolute x1;
+Begin
+    ix := 1;
+    If n>0 Then
+     For i:=1 To n Do
+      Begin
+        If x[ix]<>0 Then
+         Begin
+            absxi := abs(x[ix]);
+            If (scale<absxi) Then
+             Begin
+                sumsq := 1+sumsq*sqr(scale/absxi);
+              scale := absxi
+             End
+          Else sumsq := sumsq + sqr(absxi/scale)
+         End;
+        inc(ix, incx)
+      End
+End;
+
+Function norm2( n: ArbInt; Var x1: ArbFloat; incx: ArbInt): ArbFloat;
+
+Var  scale, ssq : ArbFloat;
+     sqt: ArbFloat;
+Begin
+    If n<1 Then norm2 := 0
+ Else
+    If n=1 Then norm2 := abs(x1)
+ Else
+    Begin
+        scale := 0;
+     ssq := 1;
+        roo003(n, x1, incx, scale, ssq );
+        sqt := sqrt( ssq );
+        If scale<(giant/sqt) Then norm2 := scale*sqt
+     Else norm2 := giant
+    End
+End;
+
+Procedure roo004(n: ArbInt; Var r1, diag1, qtb1: ArbFloat;
+                 delta: ArbFloat; Var x1: ArbFloat);
+
+Var 
+   r     : arfloat1 absolute r1;
+   diag  : arfloat1 absolute diag1;
+   qtb   : arfloat1 absolute qtb1;
+   x     : arfloat1 absolute x1;
+   wa1, wa2     : ^arfloat1;
+   alpha, bnorm, gnorm, qnorm, sgnorm, temp: ArbFloat;
+   i, j, jj, l  : ArbInt;
+Begin
+    getmem(wa1, n*sizeof(ArbFloat));
+ getmem(wa2, n*sizeof(ArbFloat));
+    jj := 1;
+    For j:=1 To n Do
+     Begin
+        wa1^[j] := r[jj];
+        If r[jj]=0 Then
+         Begin
+            temp := 0;
+          l := j;
+            For i:=1 To j-1 Do
+             Begin
+               If abs(r[l])>temp Then temp := abs(r[l]);
+               inc(l, n-i)
+             End;
+            If temp=0 Then r[jj] := macheps
+          Else r[jj] := macheps*temp
+         End;
+        inc(jj, n-j+1)
+     End;
+    move(qtb, x, n*sizeof(ArbFloat));
+    roo002('l','t','n', n, r1, x1, 1);
+    jj := 1;
+    For j:=1 To n Do
+     Begin
+        r[jj] := wa1^[j];
+        inc(jj, n - j + 1)
+     End;
+    For j:=1 To n Do
+     wa2^[j] := diag[j]*x[j];
+    qnorm := norm2(n, wa2^[1], 1);
+    If qnorm>delta Then
+     Begin
+        move(qtb, wa1^, n*sizeof(ArbFloat));
+        roo001('l','n','n', n, r1, wa1^[1], 1);
+        For i:=1 To n Do
+         wa1^[i] := wa1^[i]/diag[i];
+        gnorm := norm2(n, wa1^[1], 1);
+        sgnorm := 0;
+      alpha := delta/qnorm;
+        If gnorm<>0 Then
+         Begin
+            For j:=1 To n Do
+             wa1^[j] := (wa1^[j]/gnorm)/diag[j];
+            move(wa1^, wa2^, n*sizeof(ArbFloat));
+            roo001('l','t','n',n,r1,wa2^[1],1);
+            temp := norm2(n, wa2^[1],1);
+            sgnorm := (gnorm/temp)/temp;
+            alpha := 0;
+            If sgnorm<delta Then
+             Begin
+                bnorm := norm2(n, qtb1, 1);
+                temp := (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta);
+                temp := temp-(delta/qnorm)*sqr(sgnorm/delta) +
+                        sqrt(sqr(temp-delta/qnorm) +
+                         (1-sqr(delta/qnorm))*(1-sqr(sgnorm/delta)));
+                alpha := ((delta/qnorm)*(1-sqr(sgnorm/delta)))/temp
+             End
+         End;
+        If sgnorm<delta Then temp := (1-alpha)*sgnorm
+                        Else temp := (1-alpha)*delta;
+        For j:=1 To n Do
+         x[j] := temp*wa1^[j] + alpha*x[j]
+     End;
+    freemem(wa2, n*sizeof(ArbFloat));
+ freemem(wa1, n*sizeof(ArbFloat));
+End;
+
+Procedure roo005(fcn: roofnrfunc; n: ArbInt; Var x1, fvec1, fjac1: ArbFloat;
+                 ldfjac: ArbInt; Var iflag: ArbInt; ml, mu: ArbInt;
+                 epsfcn: ArbFloat; Var wa1, wa2: arfloat1);
+
+Var   eps, h, temp: ArbFloat;
+     i, j, k, msum: ArbInt;
+     x     : arfloat1 absolute x1;
+     fvec  : arfloat1 absolute fvec1;
+     fjac  : arfloat1 absolute fjac1;
+     deff  : boolean;
+Begin
+    If epsfcn>macheps Then eps := sqrt(epsfcn)
+ Else eps := sqrt(macheps);
+    msum := ml+mu+1;
+    If msum>=n Then
+     Begin
+        For j:=1 To n Do
+         Begin
+           temp := x[j];
+          h := eps*abs(temp);
+          If h=0 Then h := eps;
+          x[j] := temp+h;
+           deff := true;
+          fcn(x1, wa1[1], deff);
+          If Not deff Then iflag := -1;
+           If iflag<0 Then exit;
+           x[j] := temp;
+           For i:= 1 To n Do
+            fjac[j+(i-1)*ldfjac] := (wa1[i]-fvec[i])/h
+         End
+     End
+ Else
+    Begin
+        For k:=1  To msum Do
+         Begin
+            j := k;
+            while j <= n Do
+                      Begin
+                       wa2[j] := x[j];
+                       h := eps*abs(wa2[j]);
+                       If h=0 Then h := eps;
+                       x[j] := wa2[j]+h;
+                       inc(j, msum)
+                      End;
+            deff := true;
+          fcn(x1, wa1[1], deff);
+          If Not deff Then iflag := -1;
+            If iflag<0 Then exit;
+            j := k;
+            while j<= n Do
+                      Begin
+                       x[j] := wa2[j];
+                       h := eps*abs(wa2[j]);
+                       If h=0 Then h := eps;
+                       For i:=1 To n Do
+                        Begin
+                         fjac[j+(i-1)*ldfjac] := 0;
+                         If (i>=(j-mu)) And (i<=(j+ml))
+                          Then fjac[j+(i-1)*ldfjac] := (wa1[i]-fvec[i])/h
+                        End;
+                       inc(j, msum)
+                      End
+         End
+    End
+End;
+
+Procedure roo006(trans: char; m, n: ArbInt; alpha: ArbFloat; Var a1: ArbFloat;
+                 lda: ArbInt; Var x1: ArbFloat; incx : ArbInt; beta: ArbFloat;
+                 Var y1: ArbFloat; incy : ArbInt);
+
+Var  temp : ArbFloat;
+     i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny: ArbInt;
+     x     : arfloat1 absolute x1;
+     y     : arfloat1 absolute y1;
+     a     : arfloat1 absolute a1;
+Begin
+    info := 0;
+ trans := upcase(trans);
+    If (m=0) Or (n=0) Or ((alpha=0) And (beta=1)) Then exit;
+    If trans='N' Then
+     Begin
+        lenx := n;
+      leny := m
+     End
+ Else
+    Begin
+        lenx := m;
+     leny := n
+    End;
+    If incx>0 Then kx := 1
+ Else kx := 1-(lenx-1)*incx;
+    If incy>0 Then ky := 1
+ Else ky := 1-(leny-1)*incy;
+    If (beta<>1) Then
+     Begin
+        iy := ky;
+        If beta=0 Then
+         For i:=1 To leny Do
+          Begin
+            y[iy] := 0;
+           inc(iy, incy)
+          End
+          Else
+           For i:=1 To leny Do
+            Begin
+             y[iy] := beta*y[iy];
+             inc(iy, incy)
+            End;
+     End;
+   If alpha=0 Then exit;
+   If trans='N' Then
+    Begin
+       jx := kx;
+       For j:=1 To n Do
+        Begin
+           If x[jx]<>0 Then
+            Begin
+               temp := alpha*x[jx];
+             iy := ky;
+               For i:=1 To m Do
+                Begin
+                  y[iy] := y[iy]+temp*a[j+(i-1)*lda];
+                 inc(iy, incy)
+                End
+            End;
+           inc(jx, incx)
+        End
+    End
+ Else
+   Begin
+       jy := ky;
+       For j:=1 To n Do
+        Begin
+           temp := 0;
+         ix := kx;
+           For i:=1 To m Do
+            Begin
+               temp := temp+a[j+(i-1)*lda]*x[ix];
+               inc(ix, incx)
+            End;
+           y[jy] := y[jy]+alpha*temp;
+           inc(jy, incy)
+        End
+   End
+End;
+
+Procedure roo007(m, n: ArbInt; alpha: ArbFloat; Var x1: ArbFloat; incx: ArbInt;
+                  Var y1: ArbFloat; incy: ArbInt; Var a1: ArbFloat; lda: ArbInt);
+
+Var                    temp: ArbFloat;
+     i, info, ix, j, jy, kx: ArbInt;
+     x     : arfloat1 absolute x1;
+     y     : arfloat1 absolute y1;
+     a     : arfloat1 absolute a1;
+Begin
+    info := 0;
+    If (m=0) Or (n=0) Or (alpha=0) Then exit;
+    If incy>0 Then jy := 1
+ Else jy := 1-(n-1)*incy;
+    If incx>0 Then kx := 1
+ Else kx := 1-(m-1)*incx;
+    For j:=1 To n Do
+     Begin
+        If y[jy]<>0 Then
+         Begin
+            temp := alpha*y[jy];
+            ix  := kx;
+            For i:=1 To m Do
+             Begin
+               a[j +(i-1)*lda] := a[j + (i-1)*lda] + x[ix]*temp;
+               inc(ix, incx)
+             End
+         End;
+        inc(jy, incy)
+     End
+End;
+
+Procedure roo008(n: ArbInt; Var q1: ArbFloat; ldq: ArbInt; Var wa: arfloat1);
+
+Var       q: arfloat1 absolute q1;
+    i, j, k: ArbInt;
+Begin
+     For j:=2 To n Do
+      For i:=1 To j-1 Do
+       q[j+(i-1)*ldq] := 0;
+     For k:=n Downto 1 Do
+      Begin
+         If (q[k+(k-1)*ldq]<>0) And (k<>n) Then
+          Begin
+            roo006('t', n-k+1, n-k, 1, q[k+1+(k-1)*ldq], ldq,
+                   q[k +(k-1)*ldq], ldq, 0, wa[k+1], 1);
+            roo007(n-k+1, n-k, -1/q[k+(k-1)*ldq], q[k+(k-1)*ldq], ldq,
+                   wa[k+1], 1, q[k+1+(k-1)*ldq], ldq)
+          End;
+         For i:=k + 1 To n Do
+          q[k+(i-1)*ldq] := -q[k+(i-1)*ldq];
+         q[k+(k-1)*ldq] := 1-q[k+(k-1)*ldq]
+      End;
+End;
+
+Procedure roo009(n: ArbInt; Var a1: ArbFloat; lda: ArbInt;
+                 Var rdiag1, acnorm1: ArbFloat);
+
+Var  a       : arfloat1 absolute a1;
+     rdiag   : arfloat1 absolute rdiag1;
+     acnorm  : arfloat1 absolute acnorm1;
+     ajnorm  : ArbFloat;
+     i, j    : ArbInt;
+Begin
+    For j:=1 To n Do
+     acnorm[j] := norm2(n, a[j], lda);
+    For j:=1 To n Do
+     Begin
+        ajnorm := norm2(n-j+1, a[j+(j-1)*lda], lda);
+        If ajnorm<>0 Then
+         Begin
+            If a[j+(j-1)*lda]<0 Then ajnorm := -ajnorm;
+            For i:=j To n Do
+             a[j+(i-1)*lda] := a[j+(i-1)*lda]/ajnorm;
+            a[j+(j-1)*lda] := a[j+(j-1)*lda]+1;
+            If j<>n Then
+             Begin
+               roo006('t', n-j+1, n-j, 1, a[j+1+(j-1)*lda], lda,
+                      a[j+(j-1)*lda], lda, 0, rdiag[j+1], 1);
+               roo007(n-j+1, n-j, -1/a[j+(j-1)*lda], a[j+(j-1)*lda], lda,
+                      rdiag[j+1], 1, a[j+1+(j-1)*lda], lda)
+             End
+         End;
+         rdiag[j] := -ajnorm
+     End
+End;
+
+Procedure roo010(n: ArbInt; Var x1: ArbFloat; incx: ArbInt;
+                  Var y1: ArbFloat; incy: ArbInt; c, s:ArbFloat );
+
+Var temp1: ArbFloat;
+    x : arfloat1 absolute x1;
+    y : arfloat1 absolute y1;
+    i, ix, iy: ArbInt;
+Begin
+   If incy>=0 Then iy := 1
+ Else iy := 1-(n-1)*incy;
+   If incx>=0 Then ix := 1
+ Else ix := 1-(n-1)*incx;
+   For i:=1 To n Do
+    Begin
+      temp1 := x[ix];
+     x[ix] := s*y[iy]+c*temp1;
+     y[iy] := c*y[iy]-s*temp1;
+      inc(ix, incx);
+     inc(iy, incy)
+    End
+End;
+
+Procedure roo011(m, n: ArbInt; Var a1: ArbFloat; lda: ArbInt; Var v1, w1: ArbFloat);
+
+Var a: arfloat1 absolute a1;
+    v: arfloat1 absolute v1;
+    w: arfloat1 absolute w1;
+    sine, cosine: ArbFloat;
+    j, nm1, nmj: ArbInt;
+Begin
+    nm1 := n-1;
+    For nmj:=1 To nm1 Do
+     Begin
+        j := n-nmj;
+        If (abs(v[j])>1) Then
+         Begin
+            cosine := 1/v[j];
+          sine := sqrt(1-sqr(cosine))
+         End
+      Else
+        Begin
+            sine := v[j];
+         cosine := sqrt(1-sqr(sine))
+        End;
+        roo010(m, a[n], lda, a[j], lda, cosine, sine)
+     End;
+   For j:=1 To nm1 Do
+    Begin
+       If (abs(w[j])>1) Then
+        Begin
+           cosine := 1/w[j];
+         sine := sqrt(1-sqr(cosine))
+        End
+     Else
+       Begin
+           sine := w[j];
+        cosine := sqrt(1-sqr(sine))
+       End;
+       roo010(m, a[j], lda, a[n], lda, cosine, sine)
+    End
+End;
+
+Procedure roo012(m, n: ArbInt; Var s1: ArbFloat; ls: ArbInt;
+                 Var u1, v1, w1: ArbFloat; Var sing: boolean);
+
+Const   one = 1.0;
+ p5 = 0.5;
+ p25 = 0.25;
+ zero = 0.0;
+
+Var    cosine, cotan, sine, tangnt, tau: ArbFloat;
+                  i, j, jj, l, nm1, nmj: ArbInt;
+    s : arfloat1 absolute s1;
+    u : arfloat1 absolute u1;
+    v : arfloat1 absolute v1;
+    w : arfloat1 absolute w1;
+Begin
+    jj := (n*(2*m-n+1)) Div 2 - (m-n);
+    If m>=n Then move(s[jj], w[n], (m-n+1)*sizeof(ArbFloat));
+    nm1 := n-1;
+    For nmj:=1 To nm1 Do
+     Begin
+       j := n-nmj;
+      jj := jj-(m-j+1);
+      w[j] := zero;
+       If (v[j]<>zero) Then
+        Begin
+           If (abs(v[n])<abs(v[j])) Then
+            Begin
+               cotan := v[n]/v[j];
+                sine := p5/sqrt(p25+p25*sqr(cotan));
+               cosine := sine*cotan;
+               If (abs(cosine)*giant)>one
+                Then tau := one/cosine
+             Else tau := one
+            End
+         Else
+           Begin
+               tangnt := v[j]/v[n];
+               cosine := p5/sqrt(p25+p25*sqr(tangnt));
+               sine := cosine*tangnt;
+               tau := sine;
+           End;
+           v[n] := sine*v[j]+cosine*v[n];
+           v[j] := tau;
+           roo010(m-j+1, w[j], 1, s[jj], 1, cosine, sine)
+        End
+     End;
+   For i:=1 To m Do
+    w[i] := w[i]+v[n]*u[i];
+   sing := false;
+   For j:=1 To nm1 Do
+    Begin
+       If w[j]<>zero Then
+        Begin
+           If abs(s[jj])<abs(w[j]) Then
+            Begin
+               cotan := s[jj]/w[j];
+             sine := p5/sqrt(p25+p25*sqr(cotan));
+               cosine := sine*cotan;
+               If (abs(cosine)*giant)>one Then tau := one/cosine
+             Else tau := one
+            End
+         Else
+            Begin
+                tangnt := w[j]/s[jj];
+             cosine := p5/sqrt(p25+p25*sqr(tangnt));
+                sine := cosine*tangnt;
+             tau := sine
+            End;
+            roo010(m-j+1, s[jj], 1, w[j], 1, cosine, sine);
+            w[j] := tau
+        End;
+       If (s[jj]=zero) Then sing := true;
+     inc(jj, m-j+1)
+    End;
+   If m>=n Then move(w[n], s[jj], (m-n+1)*sizeof(ArbFloat));
+   If s[jj]=zero Then sing := true
+End;
+
+Procedure roo013(fcn: roofnrfunc; n: ArbInt; Var x1, fvec1: ArbFloat;
+                 xtol: ArbFloat; maxfev, ml, mu: ArbInt; epsfcn: ArbFloat;
+                 Var diag1: ArbFloat; factor: ArbFloat; Var info: ArbInt;
+                 Var fjac1: ArbFloat; ldfjac: ArbInt;
+                 Var r1: ArbFloat; lr: ArbInt; Var qtf1: ArbFloat);
+
+Const p1 = 0.1;
+ p5 = 0.5;
+ p001 = 0.001;
+ p0001 = 0.0001;
+
+Var  diag : arfloat1 absolute diag1;
+     fjac : arfloat1 absolute fjac1;
+     fvec : arfloat1 absolute fvec1;
+     qtf  : arfloat1 absolute qtf1;
+     r    : arfloat1 absolute r1;
+     wa1, wa2, wa3, wa4: ^arfloat1;
+     x    : arfloat1 absolute x1;
+     actred, delta, fnorm, fnorm1, pnorm,
+     prered, ratio, sum, temp, xnorm : ArbFloat;
+     i, iflag, iter, j, jm1, l, msum, ncfail, ncsuc, nfev,
+     nslow1, nslow2, ns : ArbInt;
+     jeval, sing, deff: boolean;
+Begin
+    info := 1;
+ iflag := 0;
+ nfev := 0;
+ ns := n*sizeof(ArbFloat);
+    For j:=1 To n Do
+     If diag[j]<=0 Then exit;
+    iflag := 1;
+ deff := true;
+ fcn(x1, fvec1, deff);
+    If Not deff Then iflag := -1;
+ nfev := 1;
+    If iflag<0 Then
+     Begin
+        info := iflag;
+      exit
+     End;
+    fnorm := norm2(n, fvec1, 1);
+    msum := ml+mu+1;
+ If msum>n Then msum := n;
+    getmem(wa1, ns);
+ getmem(wa2, ns);
+ getmem(wa3, ns);
+ getmem(wa4, ns);
+    iter := 1;
+ ncsuc := 0;
+ ncfail := 0;
+ nslow1 := 0;
+ nslow2 := 0;
+    while (info=1) and (iflag>=0) Do
+    Begin
+        jeval := true;
+     iflag := 2;
+        roo005(fcn, n, x1, fvec1, fjac1, ldfjac, iflag, ml, mu, epsfcn,
+               wa1^, wa2^);
+        inc(nfev, msum);
+        If iflag>=0 Then
+         Begin
+            roo009(n, fjac1, ldfjac, wa1^[1], wa2^[1]);
+            If iter=1 Then
+             Begin
+                For j:=1 To n Do
+                 wa3^[j] := diag[j]*x[j];
+                xnorm := norm2(n, wa3^[1], 1);
+                delta := factor*xnorm;
+                If delta=0 Then delta := factor;
+             End;
+             For i:=1 To n Do
+              qtf[i] := fvec[i];
+             For j:=1 To n Do
+              If fjac[j+(j-1)*ldfjac]<>0 Then
+               Begin
+                sum := 0;
+                For i:=j To n Do
+                 sum := sum+fjac[j+(i-1)*ldfjac]*qtf[i];
+                temp := -sum/fjac[j+(j-1)*ldfjac];
+                For i:=j To n Do
+                 qtf[i] := qtf[i]+fjac[j+(i-1)*ldfjac]*temp
+               End;
+             sing := false;
+             For j:=1 To n Do
+              Begin
+                l := j;
+               jm1 := j-1;
+                For i:=1 To jm1 Do
+                 Begin
+                   r[l] := fjac[j+(i-1)*ldfjac];
+                  inc(l, n-i)
+                 End;
+                r[l] := wa1^[j];
+                If wa1^[j]=0 Then sing := true
+              End;
+             roo008(n, fjac1, ldfjac, wa1^);
+             Repeat
+                roo004(n, r1, diag1, qtf1, delta, wa1^[1]);
+                For j:=1 To n Do
+                 Begin
+                   wa1^[j] := -wa1^[j];
+                  wa2^[j] := x[j]+wa1^[j];
+                   wa3^[j] := diag[j]*wa1^[j]
+                 End;
+                pnorm := norm2(n, wa3^[1], 1);
+                If iter=1 Then If pnorm<delta Then delta := pnorm;
+                iflag := 1;
+                deff := true;
+                fcn(wa2^[1], wa4^[1], deff);
+                If Not deff Then iflag := -1;
+                inc(nfev);
+                If iflag>0 Then
+                 Begin
+                   fnorm1 := norm2(n, wa4^[1], 1);
+                   If fnorm1<fnorm Then actred := 1-sqr(fnorm1/fnorm)
+                   Else actred := -1;
+                   move(wa1^, wa3^, n*sizeof(ArbFloat));
+                   roo001('l','t','n', n, r1, wa3^[1], 1);
+                   For i:=1 To n Do
+                    wa3^[i] := wa3^[i] + qtf[i];
+                   temp := norm2(n, wa3^[1], 1);
+                   If temp<fnorm
+                    Then prered := 1 - sqr(temp/fnorm)
+                   Else prered := 1;
+                   If prered>0 Then ratio := actred/prered
+                  Else ratio := 0;
+                   If ratio<p1 Then
+                    Begin
+                      ncsuc := 0;
+                     inc(ncfail);
+                     delta := p5*delta
+                    End
+                  Else
+                   Begin
+                      ncfail := 0;
+                    inc(ncsuc);
+                      If (ratio>=p5) Or (ncsuc>1)
+                       Then If delta<pnorm/p5 Then delta := pnorm/p5;
+                      If abs(ratio-1)<=p1 Then delta := pnorm/p5
+                   End;
+                   If ratio>=p0001 Then
+                    Begin
+                      For j:=1 To n Do
+                       Begin
+                          x[j] := wa2^[j];
+                        wa2^[j] := diag[j]*x[j];
+                          fvec[j] := wa4^[j]
+                       End;
+                      xnorm := norm2(n, wa2^[1], 1);
+                     fnorm := fnorm1;
+                     inc(iter)
+                    End;
+                   inc(nslow1);
+                   If actred>=p001 Then nslow1 := 0;
+                   If jeval Then inc(nslow2);
+                   If actred>=p1 Then nslow2 := 0;
+                   If (delta<=xtol*xnorm) Or
+                      (fnorm=0) Or (pnorm=0) Then info := 0
+                   Else If nfev>=maxfev Then info := 2
+                        Else If delta<=macheps*xnorm Then info := 3
+                             Else If nslow2=5 Then info := 4
+                                  Else If nslow1=10 Then info := 5;
+                   If (info=1) And (ncfail<>2) Then
+                    Begin
+                      roo006('t', n, n, 1, fjac1, ldfjac, wa4^[1], 1, 0,
+                              wa2^[1], 1);
+                      If ratio>=p0001 Then move(wa2^, qtf, ns);
+                      For j:=1 To n Do
+                       Begin
+                         wa2^[j] := (wa2^[j]-wa3^[j])/pnorm;
+                         wa1^[j] := diag[j]*((diag[j]*wa1^[j])/pnorm)
+                       End;
+                      roo012(n, n, r1, lr, wa1^[1], wa2^[1], wa3^[1], sing);
+                      roo011(n, n, fjac1, ldfjac, wa2^[1], wa3^[1]);
+                      roo011(1, n, qtf1, 1, wa2^[1], wa3^[1]);
+                      jeval := false
+                    End
+                 End
+             Until (iflag<0) Or (ncfail=2) Or (info<>1)
+         End
+      End;
+   freemem(wa4, ns);
+ freemem(wa3, ns);
+ freemem(wa2, ns);
+ freemem(wa1, ns);
+   If iflag<0 Then info := iflag;
+End;
+
+Procedure roofnr(f: roofnrfunc; n: ArbInt; Var x, residu: ArbFloat; re: ArbFloat;
+                 Var term: ArbInt);
+
+Var       j, lr, ns          : ArbInt;
+      wa1, wa2, wa3, wa4, fx : ^arfloat1;
+Begin
+    ns := n*sizeof(ArbFloat);
+    If n<=0 Then term := 3
+ Else
+    Begin
+        If re<0 Then term := 3
+     Else
+        Begin
+            lr := (n*(n+1)) Div 2;
+            getmem(wa1, ns);
+         getmem(wa2, ns);
+         getmem(wa3, lr*sizeof(ArbFloat));
+            getmem(wa4, n*ns);
+         getmem(fx, ns);
+            For j:=1 To n Do
+             wa1^[j] := 1;
+            roo013(f, n, x, fx^[1], re, 200*(n+1), n-1, n-1, 0, wa1^[1],
+                   100.0, term, wa4^[1], n, wa3^[1], lr, wa2^[1]);
+            residu := Norm2(n, fx^[1], 1);
+            freemem(fx, ns);
+         freemem(wa4, n*ns);
+            freemem(wa3, lr*sizeof(ArbFloat));
+         freemem(wa2, ns);
+         freemem(wa1, ns);
+            If term<0 Then term := 6
+         Else
+            Case term Of
+             0: term := 1;
+             2: term := 4;
+             3: term := 2;
+             4, 5: term := 5;
+            End
+        End
+    End
+End;
+End.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/sle.pas

@@ -0,0 +1,2286 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    !! modifies randseed, might not exactly work as TP version!!!
+
+    Solve set of linear equations of the type Ax=b, for generic, and a
+    variety of special matrices.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{Solve set of linear equations of the type Ax=b, for generic, and a variety of
+special matrices.
+One (generic) function for overdetermined sets of this kind : slegls
+
+overdetermined are sets that look like this: (I don't know if I
+translated "overdetermined" right)
+
+    6   1  2  3     9
+    3   9  3  4     2
+   17  27 42 15    62
+   17  27 42 15    61
+
+The two bottom rows look much alike, which introduces a big uncertainty in the
+result, therefore these matrices need special treatment.
+
+All procedures have similar procedure with a "L" appended to the name. We
+didn't receive docs for those procedures. If you know what the difference is,
+please mail us }
+
+Unit sle;
+interface
+{$I DIRECT.INC}
+
+uses typ, omv;
+
+{solve for special tridiagonal matrices}
+Procedure sledtr(n: ArbInt; Var l, d, u, b, x: ArbFloat; Var term: ArbInt);
+
+{solve for generic bandmatrices}
+Procedure slegba(n, l, r: ArbInt;
+                 Var a, b, x, ca: ArbFloat; Var term:ArbInt);
+
+Procedure slegbal(n, l, r: ArbInt;
+                  Var a1; Var b1, x1, ca: ArbFloat; Var term: ArbInt);
+
+{generic solve for all matrices}
+Procedure slegen(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
+                 Var term: ArbInt);
+
+Procedure slegenl(    n: ArbInt;
+                  Var a1;
+                  Var b1, x1, ca: ArbFloat;
+                  Var term: ArbInt);
+
+{solve for overdetermined matrices, see unit comments}
+Procedure slegls(Var a: ArbFloat; m, n, rwidtha: ArbInt; Var b, x: ArbFloat;
+                 Var term: ArbInt);
+
+
+Procedure sleglsl(Var a1; m, n: ArbInt; Var b1, x1: ArbFloat;
+                  Var term: ArbInt);
+
+{Symmetrical positive definitive bandmatrices}
+Procedure slegpb(n, l: ArbInt; Var a, b, x, ca: ArbFloat;
+                 Var term: ArbInt);
+
+Procedure slegpbl(n, l: ArbInt;
+                  Var a1; Var b1, x1, ca: ArbFloat; Var term: ArbInt);
+
+{Symmetrical positive definitive matrices}
+Procedure slegpd(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
+                 Var term: ArbInt);
+
+Procedure slegpdl(n: ArbInt; Var a1; Var b1, x1, ca: ArbFloat;
+                  Var term: ArbInt);
+
+{Symmetrical matrices}
+Procedure slegsy(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
+                 Var term: ArbInt);
+
+Procedure slegsyl(n: ArbInt; Var a1; Var b1, x1, ca: ArbFloat;
+                  Var term: ArbInt);
+
+{tridiagonal matrices}
+Procedure slegtr(n:ArbInt; Var l, d, u, b, x, ca: ArbFloat;
+                 Var term: ArbInt);
+
+implementation
+
+Uses DSL,MDT;
+
+{Here originally stood an exact copy of mdtgtr from unit mdt}
+{Here originally stood an exact copy of dslgtr from unit DSL}
+
+Procedure decomp(Var qr: ArbFloat; m, n, rwidthq: ArbInt; Var alpha: ArbFloat;
+                 Var pivot, term: ArbInt);
+
+Var  i, j, jbar, k, ns, ii        : ArbInt;
+     beta, sigma, alphak, qrkk, s : ArbFloat;
+     pqr, pal, y, sum             : ^arfloat1;
+     piv                          : ^arint1;
+
+Begin
+  term := 1;
+  pqr := @qr;
+  pal := @alpha;
+  piv := @pivot;
+  ns := n*sizeof(ArbFloat);
+  getmem(y, ns);
+  getmem(sum, ns);
+  For j:=1 To n Do
+    Begin
+      s := 0;
+      For i:=1 To m Do
+        s := s+sqr(pqr^[(i-1)*rwidthq+j]);
+      sum^[j] := s;
+      piv^[j] := j
+    End; {j}
+  For k:=1 To n Do
+    Begin
+      sigma := sum^[k];
+      jbar := k;
+      For j:=k+1 To n Do
+        If sigma < sum^[j] Then
+          Begin
+            sigma := sum^[j];
+           jbar := j
+          End;
+      If jbar <> k
+       Then
+        Begin
+          i := piv^[k];
+          piv^[k] := piv^[jbar];
+          piv^[jbar] := i;
+          sum^[jbar] := sum^[k];
+          sum^[k] := sigma;
+          For i:=1 To m Do
+            Begin
+              ii := (i-1)*rwidthq;
+              sigma := pqr^[ii+k];
+              pqr^[ii+k] := pqr^[ii+jbar];
+              pqr^[ii+jbar] := sigma
+            End; {i}
+        End; {column interchange}
+      sigma := 0;
+      For i:=k To m Do
+        sigma := sigma+sqr(pqr^[(i-1)*rwidthq+k]);
+      If sigma=0 Then
+        Begin
+          term := 2;
+          freemem(y, ns);
+          freemem(sum, ns);
+          exit
+        End;
+      qrkk := pqr^[(k-1)*rwidthq+k];
+      If qrkk < 0 Then
+        alphak := sqrt(sigma)
+      Else
+        alphak := -sqrt(sigma);
+      pal^[k] := alphak;
+      beta := 1/(sigma-qrkk*alphak);
+      pqr^[(k-1)*rwidthq+k] := qrkk-alphak;
+      For j:=k+1 To n Do
+        Begin
+          s := 0;
+          For i:=k To m Do
+            Begin
+              ii := (i-1)*rwidthq;
+              s := s+pqr^[ii+k]*pqr^[ii+j]
+            End; {i}
+          y^[j] := beta*s
+        End; {j}
+      For j:=k+1 To n Do
+        Begin
+          For i:=k To m Do
+            Begin
+              ii := (i-1)*rwidthq;
+              pqr^[ii+j] := pqr^[ii+j]-pqr^[ii+k]*y^[j]
+            End; {i}
+          sum^[j] := sum^[j]-sqr(pqr^[(k-1)*rwidthq+j])
+        End {j}
+    End; {k}
+  freemem(y, ns);
+ freemem(sum, ns);
+End; {decomp}
+
+Procedure decomp1(Var qr1; m, n: ArbInt; Var alpha1: ArbFloat;
+                  Var pivot1, term: ArbInt);
+
+Var             i, j, jbar, k, ns : ArbInt;
+     beta, sigma, alphak, qrkk, s : ArbFloat;
+     qr                           : ar2dr1 absolute qr1;
+     alpha                        : arfloat1 absolute alpha1;
+     pivot                        : arint1 absolute pivot1;
+     y, sum                       : ^arfloat1;
+Begin
+  term := 1;
+  ns := n*sizeof(ArbFloat);
+  getmem(y, ns);
+ getmem(sum, ns);
+  For j:=1 To n Do
+    Begin
+      s := 0;
+      For i:=1 To m Do
+       s := s+sqr(qr[i]^[j]);
+      sum^[j] := s;
+     pivot[j] := j
+    End; {j}
+  For k:=1 To n Do
+    Begin
+      sigma := sum^[k];
+     jbar := k;
+      For j:=k+1 To n Do
+        If sigma < sum^[j]
+         Then
+          Begin
+            sigma := sum^[j];
+           jbar := j
+          End;
+      If jbar <> k
+       Then
+        Begin
+          i := pivot[k];
+         pivot[k] := pivot[jbar];
+         pivot[jbar] := i;
+          sum^[jbar] := sum^[k];
+         sum^[k] := sigma;
+          For i:=1 To m Do
+            Begin
+              sigma := qr[i]^[k];
+             qr[i]^[k] := qr[i]^[jbar];
+              qr[i]^[jbar] := sigma
+            End; {i}
+        End; {column interchange}
+      sigma := 0;
+      For i:=k To m Do
+       sigma := sigma+sqr(qr[i]^[k]);
+      If sigma=0
+       Then
+        Begin
+          term := 2;
+         freemem(y, ns);
+         freemem(sum, ns);
+         exit
+        End;
+      qrkk := qr[k]^[k];
+      If qrkk < 0 Then alphak := sqrt(sigma)
+     Else alphak := -sqrt(sigma);
+      alpha[k] := alphak;
+      beta := 1/(sigma-qrkk*alphak);
+      qr[k]^[k] := qrkk-alphak;
+      For j:=k+1 To n Do
+        Begin
+          s := 0;
+         For i:=k To m Do
+          s := s+qr[i]^[k]*qr[i]^[j];
+         y^[j] := beta*s
+        End; {j}
+      For j:=k+1 To n Do
+        Begin
+          For i:=k To m Do
+           qr[i]^[j] := qr[i]^[j]-qr[i]^[k]*y^[j];
+          sum^[j] := sum^[j]-sqr(qr[k]^[j])
+        End {j}
+    End; {k}
+  freemem(y, ns);
+ freemem(sum, ns);
+End; {decomp1}
+
+Procedure solve(Var qr: ArbFloat; m, n, rwidthq: ArbInt; Var alpha: ArbFloat;
+                Var pivot: ArbInt; Var r, y: ArbFloat);
+
+Var    i, j, ii            : ArbInt;
+       gamma, s            : ArbFloat;
+       pqr, pal, pr, py, z : ^arfloat1;
+       piv                 : ^arint1;
+Begin
+  pqr := @qr;
+  pal := @alpha;
+  piv := @pivot;
+  pr := @r;
+  py := @y;
+  getmem(z, n*sizeof(ArbFloat));
+  For j:=1 To n Do
+    Begin
+      gamma := 0;
+      For i:=j To m Do
+        gamma := gamma+pqr^[(i-1)*rwidthq+j]*pr^[i];
+      gamma := gamma/(pal^[j]*pqr^[(j-1)*rwidthq+j]);
+      For i:=j To m Do
+        pr^[i] := pr^[i]+gamma*pqr^[(i-1)*rwidthq+j]
+    End; {j}
+  z^[n] := pr^[n]/pal^[n];
+  For i:=n-1 Downto 1 Do
+    Begin
+      s := pr^[i];
+      ii := (i-1)*rwidthq;
+      For j:=i+1 To n Do
+        s := s-pqr^[ii+j]*z^[j];
+      z^[i] := s/pal^[i]
+    End; {i}
+  For i:=1 To n Do
+    py^[piv^[i]] := z^[i];
+  freemem(z, n*sizeof(ArbFloat));
+End; {solve}
+
+Procedure solve1(Var qr1; m, n: ArbInt; Var alpha1: ArbFloat;
+                 Var pivot1: ArbInt; Var r1, y1: ArbFloat);
+
+Var    i, j                : ArbInt;
+       gamma, s            : ArbFloat;
+       qr                  : ar2dr1 absolute qr1;
+       alpha               : arfloat1 absolute alpha1;
+       r                   : arfloat1 absolute r1;
+       y                   : arfloat1 absolute y1;
+       pivot               : arint1 absolute pivot1;
+       z                   : ^arfloat1;
+Begin
+  getmem(z, n*sizeof(ArbFloat));
+  For j:=1 To n Do
+    Begin
+      gamma := 0;
+      For i:=j To m Do
+       gamma := gamma+qr[i]^[j]*r[i];
+      gamma := gamma/(alpha[j]*qr[j]^[j]);
+      For i:=j To m Do
+       r[i] := r[i]+gamma*qr[i]^[j]
+    End; {j}
+  z^[n] := r[n]/alpha[n];
+  For i:=n-1 Downto 1 Do
+    Begin
+      s := r[i];
+      For j:=i+1 To n Do
+       s := s-qr[i]^[j]*z^[j];
+      z^[i] := s/alpha[i]
+    End; {i}
+  For i:=1 To n Do
+   y[pivot[i]] := z^[i];
+  freemem(z, n*sizeof(ArbFloat));
+End; {solve1}
+
+Procedure sledtr(n: ArbInt; Var l, d, u, b, x: ArbFloat; Var term: ArbInt);
+
+Var               i, j, sr : ArbInt;
+                    lj, di : ArbFloat;
+        pd, pu, pb, px, dd : ^arfloat1;
+                        pl : ^arfloat2;
+Begin
+  If n<1
+   Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  pl := @l;
+ pd := @d;
+ pu := @u;
+ pb := @b;
+ px := @x;
+  sr := sizeof(ArbFloat);
+  getmem(dd, n*sr);
+  move(pb^, px^, n*sr);
+  j := 1;
+ di := pd^[j];
+ dd^[j] := di;
+  If di=0
+   Then
+    term := 2
+  Else
+    term := 1;
+  while (term=1) and (j <> n) Do
+    Begin
+      i := j;
+     j := j+1;
+     lj := pl^[j]/di;
+      di := pd^[j]-lj*pu^[i];
+     dd^[j] := di;
+      If di=0
+       Then
+        term := 2
+      Else
+        px^[j] := px^[j]-lj*px^[i]
+    End; {j}
+  If term=1
+   Then
+    Begin
+      px^[n] := px^[n]/dd^[n];
+      For i:=n-1 Downto 1 Do
+        px^[i] := (px^[i]-pu^[i]*px^[i+1])/dd^[i]
+    End; {term=1}
+  freemem(dd, n*sr);
+End; {sledtr}
+
+Procedure slegba(n, l, r: ArbInt;
+                 Var a, b, x, ca: ArbFloat; Var term:ArbInt);
+
+Var
+  sr, i, j, k, ipivot, m, lbj, lbi, ubi, ls,
+         ii, jj, ll, s, js, ubj, rwidth       : ArbInt;
+  ra, normr, sumrowi, pivot, normt, maxim, h  : ArbFloat;
+  pa, pb, px, au, sumrow, t, row              : ^arfloat1;
+Begin
+  If (n<1) Or (l<0) Or (r<0) Or (l>n-1) Or (r>n-1)
+   Then
+    Begin
+      term := 3;
+     exit
+    End; {term=3}
+  sr := sizeof(ArbFloat);
+  pa := @a;
+ pb := @b;
+ px := @x;
+  ll := l+r+1;
+  ls := ll*sr;
+  getmem(au, ls*n);
+  getmem(sumrow, n*sr);
+  getmem(t, n*sr);
+  getmem(row, ls);
+  move(pb^, px^, n*sr);
+  jj := 1;
+ ii := 1;
+  For i:=1 To n Do
+    Begin
+      If i <= l+1 Then
+        Begin
+          If i <= n-r Then rwidth := r+i
+         Else rwidth := n
+        End
+     Else
+          If i <= n-r Then rwidth := ll
+     Else rwidth := n-i+l+1;
+      move(pa^[jj], au^[ii], rwidth*sr);
+      fillchar(au^[ii+rwidth], (ll-rwidth)*sr, 0);
+      jj := jj+rwidth;
+     ii := ii+ll;
+    End; {i}
+  lbi := n-r+1;
+ lbj := 0;
+  normr := 0;
+ term := 1;
+  ii := 1;
+  For i:=1 To n Do
+    Begin
+      sumrowi := omvn1v(au^[ii], ll);
+      ii := ii+ll;
+      sumrow^[i] := sumrowi;
+      h := 2*random-1;
+     t^[i] := sumrowi*h;
+      h := abs(h);
+     If normr<h Then normr := h;
+      If sumrowi=0 Then term := 2
+    End; {i}
+  ubi := l;
+ k := 0;
+ jj := 1;
+  while (k<n) and (term=1) Do
+    Begin
+      maxim := 0;
+     k := k+1;
+     ipivot := k;
+     ii := jj;
+      If ubi<n
+       Then ubi := ubi+1;
+      For i:=k To ubi Do
+        Begin
+          sumrowi := sumrow^[i];
+          If sumrowi <> 0
+           Then
+            Begin
+              h := abs(au^[ii])/sumrowi;
+              ii := ii+ll;
+              If maxim<h
+               Then
+                Begin
+                  maxim := h;
+                 ipivot := i
+                End {maxim<h}
+            End {sumrowi <> 0}
+        End; {i}
+      If maxim=0
+       Then
+        term := 2
+      Else
+        Begin
+          If ipivot <> k
+           Then
+            Begin
+              ii := (ipivot-1)*ll+1;
+              move(au^[ii], row^, ls);
+              move(au^[jj], au^[ii], ls);
+              move(row^, au^[jj], ls);
+              h := t^[ipivot];
+             t^[ipivot] := t^[k];
+             t^[k] := h;
+              h := px^[ipivot];
+             px^[ipivot] := px^[k];
+             px^[k] := h;
+              sumrow^[ipivot] := sumrow^[k]
+            End; {ipivot <> k}
+          pivot := au^[jj];
+         ii := jj;
+          For i:=k+1 To ubi Do
+            Begin
+              ii := ii+ll;
+              h := au^[ii]/pivot;
+              For j:=0 To ll-2 Do
+                au^[ii+j] := au^[ii+j+1]-h*au^[jj+j+1];
+              au^[ii+ll-1] := 0;
+              t^[i] := t^[i]-h*t^[k];
+              px^[i] := px^[i]-h*px^[k];
+            End {i}
+        End; {maxim <> 0}
+        jj := jj+ll
+    End; {k}
+  If term=1
+   Then
+    Begin
+      normt := 0;
+     ubj := -l-1;
+      jj := n*ll+1;
+      For i:=n Downto 1 Do
+        Begin
+          jj := jj-ll;
+          If ubj<r
+           Then
+            ubj := ubj+1;
+          h := t^[i];
+          For j:=1 To ubj+l Do
+            h := h-au^[jj+j]*t^[i+j];
+          t^[i] := h/au^[jj];
+          h := px^[i];
+          For j:=1 To ubj+l Do
+            h := h-au^[jj+j]*px^[i+j];
+          px^[i] := h/au^[jj];
+          h := abs(t^[i]);
+          If normt<h
+           Then
+            normt := h
+        End; {i}
+        ca := normt/normr
+    End; {term=1}
+  freemem(au, ls*n);
+  freemem(sumrow, n*sr);
+  freemem(t, n*sr);
+  freemem(row, ls)
+End; {slegba}
+
+Procedure slegbal(n, l, r: ArbInt;
+                  Var a1; Var b1, x1, ca: ArbFloat; Var term:ArbInt);
+
+Var 
+  sr, i, j, k, ipivot, m, lbj, lbi, ubi, ls,
+                 ll, s, js, ubj, rwidth       : ArbInt;
+  ra, normr, sumrowi, pivot, normt, maxim, h  : ArbFloat;
+  a                                           : ar2dr1 absolute a1;
+  b                                           : arfloat1 absolute b1;
+  x                                           : arfloat1 absolute x1;
+  au                                          : par2dr1;
+  sumrow, t, row                              : ^arfloat1;
+Begin
+  If (n<1) Or (l<0) Or (r<0) Or (l>n-1) Or (r>n-1)
+   Then
+    Begin
+      term := 3;
+     exit
+    End; {term=3}
+  sr := sizeof(ArbFloat);
+ ll := l+r+1;
+ ls := ll*sr;
+  AllocateAr2dr(n, ll, au);
+  getmem(sumrow, n*sr);
+ getmem(t, n*sr);
+ getmem(row, ls);
+  move(b[1], x[1], n*sr);
+  For i:=1 To n Do
+    Begin
+      If i <= l+1 Then
+        Begin
+          If i <= n-r Then rwidth := r+i
+         Else rwidth := n
+        End
+     Else
+          If i <= n-r Then rwidth := ll
+     Else rwidth := n-i+l+1;
+      move(a[i]^, au^[i]^, rwidth*sr);
+      fillchar(au^[i]^[rwidth+1], (ll-rwidth)*sr, 0);
+    End; {i}
+  normr := 0;
+ term := 1;
+  For i:=1 To n Do
+    Begin
+      sumrowi := omvn1v(au^[i]^[1], ll);
+     sumrow^[i] := sumrowi;
+      h := 2*random-1;
+     t^[i] := sumrowi*h;
+      h := abs(h);
+     If normr<h Then normr := h;
+      If sumrowi=0 Then term := 2
+    End; {i}
+  ubi := l;
+ k := 0;
+  while (k<n) and (term=1) Do
+    Begin
+      maxim := 0;
+     k := k+1;
+     ipivot := k;
+      If ubi<n Then ubi := ubi+1;
+      For i:=k To ubi Do
+        Begin
+          sumrowi := sumrow^[i];
+          If sumrowi <> 0 Then
+            Begin
+              h := abs(au^[i]^[1])/sumrowi;
+              If maxim<h Then
+                Begin
+                  maxim := h;
+                 ipivot := i
+                End {maxim<h}
+            End {sumrowi <> 0}
+        End; {i}
+      If maxim=0 Then term := 2
+     Else
+        Begin
+          If ipivot <> k Then
+            Begin
+              move(au^[ipivot]^, row^, ls);
+              move(au^[k]^, au^[ipivot]^, ls);
+              move(row^, au^[k]^, ls);
+              h := t^[ipivot];
+             t^[ipivot] := t^[k];
+             t^[k] := h;
+              h := x[ipivot];
+             x[ipivot] := x[k];
+             x[k] := h;
+              sumrow^[ipivot] := sumrow^[k]
+            End; {ipivot <> k}
+          pivot := au^[k]^[1];
+          For i:=k+1 To ubi Do
+            Begin
+              h := au^[i]^[1]/pivot;
+              For j:=0 To ll-2 Do
+                au^[i]^[j+1] := au^[i]^[j+2]-h*au^[k]^[j+2];
+              au^[i]^[ll] := 0;
+              t^[i] := t^[i]-h*t^[k];
+              x[i] := x[i]-h*x[k];
+            End {i}
+        End; {maxim <> 0}
+    End; {k}
+  If term=1 Then
+    Begin
+      normt := 0;
+     ubj := -l-1;
+      For i:=n Downto 1 Do
+        Begin
+          If ubj<r Then ubj := ubj+1;
+          h := t^[i];
+          For j:=1 To ubj+l Do
+           h := h-au^[i]^[j+1]*t^[i+j];
+          t^[i] := h/au^[i]^[1];
+          h := x[i];
+          For j:=1 To ubj+l Do
+           h := h-au^[i]^[j+1]*x[i+j];
+          x[i] := h/au^[i]^[1];
+          h := abs(t^[i]);
+         If normt<h Then normt := h
+        End; {i}
+        ca := normt/normr
+    End; {term=1}
+  freemem(sumrow, n*sr);
+ freemem(t, n*sr);
+ freemem(row, ls);
+  DeAllocateAr2dr(n, ll, au);
+End; {slegbal}
+
+Procedure slegen(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
+                 Var term: ArbInt);
+
+Var 
+          nsr, i, j, k, ipiv, ip, ik, i1n, k1n : ArbInt;
+                                      singular : boolean;
+           normr, pivot, l, normt, maxim, h, s : ArbFloat;
+                pa, px, pb, au, sumrow, t, row : ^arfloat1;
+
+Begin
+  If (n<1) Or (rwidth<1)
+   Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  getmem(au, sqr(n)*sizeof(ArbFloat));
+  nsr := n*sizeof(ArbFloat);
+  getmem(t, nsr);
+  getmem(row, nsr);
+  getmem(sumrow, nsr);
+  pa := @a;
+ pb := @b;
+ px := @x;
+  For i:= 1 To n Do
+    move(pa^[1+(i-1)*rwidth], au^[1+(i-1)*n], nsr);
+  move(pb^[1], px^[1], nsr);
+  normr := 0;
+ singular := false ;
+ i := 0;
+ j := 0;
+  while (i<n) and  (Not singular) Do
+    Begin
+      i := i+1;
+     sumrow^[i] := omvn1v(au^[1+(i-1)*n], n);
+      If sumrow^[i]=0
+       Then
+        singular := true
+      Else
+        Begin
+          h := 2*random-1;
+         t^[i] := sumrow^[i]*h;
+         h := abs(h);
+          If normr<h
+           Then
+            normr := h
+        End
+    End;
+  k := 0;
+  while (k<n) and  not singular Do
+    Begin
+      k := k+1;
+     maxim := 0;
+     ipiv := k;
+      For i:=k To n Do
+        Begin
+          h := abs(au^[k+(i-1)*n])/sumrow^[i];
+          If maxim<h
+           Then
+            Begin
+              maxim := h;
+             ipiv := i
+            End
+        End;
+      If maxim=0
+       Then
+        singular := true
+      Else
+        Begin
+          k1n := (k-1)*n;
+          If ipiv <> k
+           Then
+            Begin
+              ip := 1+(ipiv-1)*n;
+             ik := 1+k1n;
+              move(au^[ip], row^[1], nsr);
+             move(au^[ik], au^[ip], nsr);
+              move(row^[1], au^[ik], nsr);
+              h := t^[ipiv];
+             t^[ipiv] := t^[k];
+             t^[k] := h;
+              h := px^[ipiv];
+             px^[ipiv] := px^[k];
+             px^[k] := h;
+              sumrow^[ipiv] := sumrow^[k]
+            End;
+          pivot := au^[k+k1n];
+          For i:=k+1 To n Do
+            Begin
+              i1n := (i-1)*n;
+             l := au^[k+i1n]/pivot;
+              If l <> 0
+               Then
+                Begin
+                  For j:=k+1 To n Do
+                    au^[j+i1n] := au^[j+i1n]-l*au^[j+k1n];
+                  t^[i] := t^[i]-l*t^[k];
+                  px^[i] := px^[i]-l*px^[k]
+                End
+            End
+        End
+    End;
+  If  Not singular
+   Then
+    Begin
+      normt := 0;
+      For i:=n Downto 1 Do
+        Begin
+          s := 0;
+         i1n := (i-1)*n;
+          For j:=i+1 To n Do
+            s := s+t^[j]*au^[j+i1n];
+          t^[i] := (t^[i]-s)/au^[i+i1n];
+          s := 0;
+          For j:=i+1 To n Do
+            s := s+px^[j]*au^[j+i1n];
+          px^[i] := (px^[i]-s)/au^[i+i1n];
+          h := abs(t^[i]);
+          If normt<h
+           Then
+            normt := h
+        End;
+      ca := normt/normr
+    End;
+   If singular
+    Then
+     term := 2
+   Else
+     term := 1;
+  freemem(au, sqr(n)*sizeof(ArbFloat));
+  freemem(t, nsr);
+  freemem(row, nsr);
+  freemem(sumrow, nsr);
+End; {slegen}
+
+Procedure slegenl(     n: ArbInt;
+                  Var a1;
+                  Var b1, x1, ca: ArbFloat;
+                  Var term: ArbInt);
+
+Var 
+     nsr, i, j, k, ipiv : ArbInt;
+               singular : boolean;
+     normr, pivot, l, normt, maxim, h, s : ArbFloat;
+     a : ar2dr1 absolute a1;
+     x : arfloat1 absolute x1;
+     b : arfloat1 absolute b1;
+     au: par2dr1;
+     sumrow, t, row : ^arfloat1;
+Begin
+  If n<1 Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  AllocateAr2dr(n, n, au);
+  nsr := n*sizeof(ArbFloat);
+  getmem(t, nsr);
+  getmem(row, nsr);
+  getmem(sumrow, nsr);
+  For i:= 1 To n Do
+   move(a[i]^, au^[i]^, nsr);
+  move(b[1], x[1], nsr);
+  normr := 0;
+ singular := false ;
+ i := 0;
+ j := 0;
+  while (i<n) and  (Not singular) Do
+    Begin
+      i := i+1;
+     sumrow^[i] := omvn1v(au^[i]^[1], n);
+      If sumrow^[i]=0
+       Then
+        singular := true
+      Else
+        Begin
+          h := 2*random-1;
+         t^[i] := sumrow^[i]*h;
+         h := abs(h);
+          If normr<h
+           Then
+            normr := h
+        End
+    End;
+  k := 0;
+  while (k<n) and  not singular Do
+    Begin
+      k := k+1;
+     maxim := 0;
+     ipiv := k;
+      For i:=k To n Do
+        Begin
+          h := abs(au^[i]^[k])/sumrow^[i];
+          If maxim<h
+           Then
+            Begin
+              maxim := h;
+             ipiv := i
+            End
+        End;
+      If maxim=0
+       Then
+        singular := true
+      Else
+        Begin
+          If ipiv <> k
+           Then
+            Begin
+              move(au^[ipiv]^, row^, nsr);
+              move(au^[k]^, au^[ipiv]^, nsr);
+              move(row^, au^[k]^, nsr);
+              h := t^[ipiv];
+             t^[ipiv] := t^[k];
+             t^[k] := h;
+              h := x[ipiv];
+             x[ipiv] := x[k];
+             x[k] := h;
+              sumrow^[ipiv] := sumrow^[k]
+            End;
+          pivot := au^[k]^[k];
+          For i:=k+1 To n Do
+            Begin
+              l := au^[i]^[k]/pivot;
+              If l <> 0
+               Then
+                Begin
+                  For j:=k+1 To n Do
+                    au^[i]^[j] := au^[i]^[j]-l*au^[k]^[j];
+                  t^[i] := t^[i]-l*t^[k];
+                  x[i] := x[i]-l*x[k]
+                End
+            End
+        End
+    End;
+  If  Not singular
+   Then
+    Begin
+      normt := 0;
+      For i:=n Downto 1 Do
+        Begin
+          s := 0;
+          For j:=i+1 To n Do
+            s := s+t^[j]*au^[i]^[j];
+          t^[i] := (t^[i]-s)/au^[i]^[i];
+          s := 0;
+          For j:=i+1 To n Do
+            s := s+x[j]*au^[i]^[j];
+          x[i] := (x[i]-s)/au^[i]^[i];
+          h := abs(t^[i]);
+          If normt<h
+           Then
+            normt := h
+        End;
+      ca := normt/normr
+    End;
+   If singular
+    Then
+     term := 2
+   Else
+     term := 1;
+  freemem(t, nsr);
+  freemem(row, nsr);
+  freemem(sumrow, nsr);
+  DeAllocateAr2dr(n, n, au);
+End; {slegenl}
+
+Procedure slegls(Var a: ArbFloat; m, n, rwidtha: ArbInt; Var b, x: ArbFloat;
+                 Var term: ArbInt);
+
+Var     i, j, ns, ms, ii                : ArbInt;
+        normy0, norme0, norme1, s       : ArbFloat;
+        pa, pb, px, qr, alpha, e, y, r  : ^arfloat1;
+        pivot                           : ^arint1;
+Begin
+  If (n<1) Or (m<n)
+   Then
+    Begin
+      term := 3;
+     exit
+    End;
+  pa := @a;
+ pb := @b;
+ px := @x;
+  ns := n*sizeof(ArbFloat);
+ ms := m*sizeof(ArbFloat);
+  getmem(qr, m*ns);
+ getmem(alpha, ns);
+ getmem(e, ns);
+ getmem(y, ns);
+  getmem(r, m*sizeof(ArbFloat));
+ getmem(pivot, n*sizeof(ArbInt));
+  For i:=1 To m Do
+    move(pa^[(i-1)*rwidtha+1], qr^[(i-1)*n+1], ns);
+  decomp(qr^[1], m, n, n, alpha^[1], pivot^[1], term);
+  If term=2
+   Then
+    Begin
+      freemem(qr, m*ns);
+     freemem(alpha, ns);
+     freemem(e, ns);
+     freemem(y, ns);
+      freemem(r, m*sizeof(ArbFloat));
+     freemem(pivot, n*sizeof(ArbInt));
+      exit
+    End;
+  move(pb^[1], r^[1], ms);
+  solve(qr^[1], m, n, n, alpha^[1], pivot^[1], r^[1], y^[1]);
+  For i:=1 To m Do
+    Begin
+      s := pb^[i];
+     ii := (i-1)*rwidtha;
+      For j:=1 To n Do
+        s := s-pa^[ii+j]*y^[j];
+      r^[i] := s
+    End; {i}
+  solve(qr^[1], m, n, n, alpha^[1], pivot^[1], r^[1], e^[1]);
+  normy0 := 0;
+ norme1 := 0;
+  For i:=1 To n Do
+    Begin
+      normy0 := normy0+sqr(y^[i]);
+     norme1 := norme1+sqr(e^[i])
+    End; {i}
+  If norme1 > 0.0625*normy0
+   Then
+    Begin
+      term := 2;
+      freemem(qr, m*ns);
+     freemem(alpha, ns);
+     freemem(e, ns);
+     freemem(y, ns);
+      freemem(r, m*sizeof(ArbFloat));
+     freemem(pivot, n*sizeof(ArbInt));
+      exit
+    End;
+  For i:=1 To n Do
+    px^[i] := y^[i];
+  freemem(qr, m*ns);
+ freemem(alpha, ns);
+ freemem(e, ns);
+ freemem(y, ns);
+  freemem(r, m*sizeof(ArbFloat));
+ freemem(pivot, n*sizeof(ArbInt));
+End; {slegls}
+
+Procedure sleglsl(Var a1; m, n: ArbInt; Var b1, x1: ArbFloat;
+                  Var term: ArbInt);
+
+Var     i, j, ns, ms                    : ArbInt;
+        normy0, norme0, norme1, s       : ArbFloat;
+        a                               : ar2dr1 absolute a1;
+        b                               : arfloat1 absolute b1;
+        x                               : arfloat1 absolute x1;
+        alpha, e, y, r                  : ^arfloat1;
+        qr                              : par2dr1;
+        pivot                           : ^arint1;
+Begin
+  If (n<1) Or (m<n)
+   Then
+    Begin
+      term := 3;
+     exit
+    End;
+  AllocateAr2dr(m, n, qr);
+  ns := n*sizeof(ArbFloat);
+ ms := m*sizeof(ArbFloat);
+  getmem(alpha, ns);
+ getmem(e, ns);
+ getmem(y, ns);
+  getmem(r, ms);
+ getmem(pivot, n*sizeof(ArbInt));
+  For i:=1 To m Do
+    move(a[i]^, qr^[i]^, ns);
+  decomp1(qr^[1], m, n, alpha^[1], pivot^[1], term);
+  If term=2
+   Then
+    Begin
+      freemem(qr, m*ns);
+     freemem(alpha, ns);
+     freemem(e, ns);
+     freemem(y, ns);
+      freemem(r, ms);
+     freemem(pivot, n*sizeof(ArbInt));
+      exit
+    End;
+  move(b[1], r^, ms);
+  solve1(qr^[1], m, n, alpha^[1], pivot^[1], r^[1], y^[1]);
+  For i:=1 To m Do
+    Begin
+      s := b[i];
+      For j:=1 To n Do
+       s := s-a[i]^[j]*y^[j];
+      r^[i] := s
+    End; {i}
+  solve1(qr^[1], m, n, alpha^[1], pivot^[1], r^[1], e^[1]);
+  normy0 := 0;
+ norme1 := 0;
+  For i:=1 To n Do
+    Begin
+      normy0 := normy0+sqr(y^[i]);
+     norme1 := norme1+sqr(e^[i])
+    End; {i}
+  If norme1 > 0.0625*normy0
+   Then
+    Begin
+      term := 2;
+      freemem(qr, m*ns);
+     freemem(alpha, ns);
+     freemem(e, ns);
+     freemem(y, ns);
+      freemem(r, m*sizeof(ArbFloat));
+     freemem(pivot, n*sizeof(ArbInt));
+      exit
+    End;
+  For i:=1 To n Do
+   x[i] := y^[i];
+  freemem(alpha, ns);
+ freemem(e, ns);
+ freemem(y, ns);
+  freemem(r, ms);
+ freemem(pivot, n*sizeof(ArbInt));
+  DeAllocateAr2dr(m, n, qr);
+End; {sleglsl}
+
+Procedure slegpb(n, l: ArbInt; Var a, b, x, ca: ArbFloat;
+                 Var term: ArbInt);
+
+Var
+    posdef                                                 : boolean;
+    i, j, k, r, p, q, jmin1, ii, jj, ri, ind,
+                                      ll, llm1, sr, rwidth : ArbInt;
+    h, normr, normt, sumrowi, hh, alim, norma              : ArbFloat;
+    pa, pb, px, al, t, v                                   : ^arfloat1;
+
+    Procedure decomp(i, r: ArbInt);
+
+    Var k: ArbInt;
+    Begin
+      ri := (r-1)*ll;
+      h := al^[ii+j];
+     q := ll-j+p;
+      For k:=p To jmin1 Do
+        Begin
+          h := h-al^[ii+k]*al^[ri+q];
+         q := q+1
+        End ;
+      If j<ll
+       Then
+        al^[ii+j] := h/al^[ri+ll];
+    End; {decomp}
+
+Begin
+  If (n<1) Or (l<0) Or (l>n-1)
+   Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  sr := sizeof(ArbFloat);
+  pa := @a;
+  pb := @b;
+  px := @x;
+  ll := l+1;
+  getmem(al, ll*n*sr);
+  getmem(t, n*sr);
+  getmem(v, ll*sr);
+  move(pb^, px^, n*sr);
+  jj := 1;
+  ii := 1;
+  For i:=1 To n Do
+    Begin
+      If i>l Then rwidth := ll
+     Else rwidth := i;
+      move(pa^[jj], al^[ii+ll-rwidth], rwidth*sr);
+      jj := jj+rwidth;
+     ii := ii+ll
+    End; {i}
+  normr := 0;
+ p := ll+1;
+ norma := 0;
+  For i:=1 To n Do
+    Begin
+      If p>1
+       Then
+        p := p-1;
+      For j:=p To ll Do
+        v^[j] := al^[j+(i-1)*ll];
+      sumrowi := omvn1v(v^[p], ll-p+1);
+      r := i;
+     j := ll;
+      while (r<n) and (j>1) Do
+        Begin
+          r := r+1;
+         j := j-1;
+          sumrowi := sumrowi+abs(al^[j+(r-1)*ll])
+        End; {r,j}
+      If norma<sumrowi
+       Then
+        norma := sumrowi;
+      h := 2*random-1;
+     t^[i] := h;
+      h := abs(h);
+      If normr<h
+       Then
+        normr := h
+    End; {i}
+  llm1 := ll-1;
+ p := ll+1;
+ i := 0;
+ posdef := true ;
+  while (i<n) and posdef Do
+    Begin
+      i := i+1;
+     If p>1 Then p := p-1;
+     r := i-ll+p;
+     j := p-1;
+      ii := (i-1)*ll;
+      while j<llm1 Do
+        Begin
+          jmin1 := j;
+         j := j+1;
+          decomp(i, r);
+          r := r+1
+        End ; {j}
+      jmin1 := llm1;
+     j := ll;
+      decomp(i, i);
+      If h <= 0
+       Then
+        posdef := false
+      Else
+        Begin
+          alim := sqrt(h);
+         al^[ii+ll] := alim;
+          h := t^[i];
+         q := i;
+          For k:=llm1 Downto p Do
+            Begin
+              q := q-1;
+             h := h-al^[ii+k]*t^[q]
+            End ;
+          t^[i] := h/alim;
+          h := px^[i];
+         q := i;
+          For k:=llm1 Downto p Do
+            Begin
+              q := q-1;
+             h := h-al^[ii+k]*px^[q]
+            End; {k}
+          px^[i] := h/alim
+        End {posdef}
+    End; {i}
+    If posdef
+     Then
+      Begin
+        normt := 0;
+       p := ll+1;
+        For i:=n Downto 1 Do
+          Begin
+            If p>1
+             Then
+              p := p-1;
+            q := i;
+           h := t^[i];
+           hh := px^[i];
+            For k:=llm1 Downto p Do
+              Begin
+                q := q+1;
+                ind := (q-1)*ll+k;
+                h := h-al^[ind]*t^[q];
+               hh := hh-al^[ind]*px^[q]
+              End; {k}
+            ind := i*ll;
+            t^[i] := h/al^[ind];
+           px^[i] := hh/al^[ind];
+            h := abs(t^[i]);
+            If normt<h
+             Then
+              normt := h
+         End; {i}
+       ca := norma*normt/normr
+     End ; {posdef}
+  If posdef
+   Then
+    term := 1
+  Else
+    term := 2;
+  freemem(al, ll*n*sr);
+  freemem(t, n*sr);
+  freemem(v, ll*sr);
+End;  {slegpb}
+
+Procedure slegpbl(n, l: ArbInt;
+                  Var a1; Var b1, x1, ca: ArbFloat; Var term: ArbInt);
+
+Var 
+    posdef                                    : boolean;
+    i, j, k, r, p, q, ll, sr, rwidth          : ArbInt;
+    h, normr, normt, sumrowi, hh, alim, norma : ArbFloat;
+    a                                         : ar2dr1 absolute a1;
+    b                                         : arfloat1 absolute b1;
+    x                                         : arfloat1 absolute x1;
+    al                                        : par2dr1;
+    t, v                                      : ^arfloat1;
+
+    Procedure decomp(r: ArbInt);
+
+    Var k: ArbInt;
+    Begin
+      h := al^[i]^[j];
+     q := ll-j+p;
+      For k:=p To j-1 Do
+        Begin
+          h := h-al^[i]^[k]*al^[r]^[q];
+         Inc(q)
+        End ;
+      If j<ll Then al^[i]^[j] := h/al^[r]^[ll];
+    End; {decomp}
+
+Begin
+  If (n<1) Or (l<0) Or (l>n-1)
+   Then
+    Begin
+      term := 3;
+     exit
+    End; {wrong input}
+  sr := sizeof(ArbFloat);
+  ll := l+1;
+  AllocateAr2dr(n, ll, al);
+  getmem(t, n*sr);
+ getmem(v, ll*sr);
+  move(b[1], x[1], n*sr);
+  For i:=1 To n Do
+    Begin
+      If i>l Then rwidth := ll
+     Else rwidth := i;
+      move(a[i]^, al^[i]^[ll-rwidth+1], rwidth*sr);
+    End; {i}
+  normr := 0;
+ p := ll+1;
+ norma := 0;
+  For i:=1 To n Do
+    Begin
+      If p>1 Then Dec(p);
+      For j:=p To ll Do
+       v^[j] := al^[i]^[j];
+      sumrowi := omvn1v(v^[p], ll-p+1);
+      r := i;
+     j := ll;
+      while (r<n) and (j>1) Do
+        Begin
+          Inc(r);
+         Dec(j);
+          sumrowi := sumrowi+abs(al^[r]^[j])
+        End; {r,j}
+      If norma<sumrowi Then norma := sumrowi;
+      h := 2*random-1;
+     t^[i] := h;
+      h := abs(h);
+     If normr<h Then normr := h
+    End; {i}
+  p := ll+1;
+ i := 0;
+ posdef := true ;
+  while (i<n) and posdef Do
+    Begin
+      Inc(i);
+     If p>1 Then Dec(p);
+     r := i-ll+p;
+     j := p-1;
+      while j<ll-1 Do
+        Begin
+          Inc(j);
+         decomp(r);
+         Inc(r)
+        End ; {j}
+      j := ll;
+     decomp(i);
+      If h <= 0 Then posdef := false
+     Else
+        Begin
+          alim := sqrt(h);
+         al^[i]^[ll] := alim;
+          h := t^[i];
+         q := i;
+          For k:=ll-1 Downto p Do
+            Begin
+              q := q-1;
+             h := h-al^[i]^[k]*t^[q]
+            End ;
+          t^[i] := h/alim;
+          h := x[i];
+         q := i;
+          For k:=ll-1 Downto p Do
+            Begin
+              q := q-1;
+             h := h-al^[i]^[k]*x[q]
+            End; {k}
+          x[i] := h/alim
+        End {posdef}
+    End; {i}
+    If posdef
+     Then
+      Begin
+        normt := 0;
+       p := ll+1;
+        For i:=n Downto 1 Do
+          Begin
+            If p>1 Then Dec(p);
+            q := i;
+           h := t^[i];
+           hh := x[i];
+            For k:=ll-1 Downto p Do
+              Begin
+                Inc(q);
+                h := h-al^[q]^[k]*t^[q];
+               hh := hh-al^[q]^[k]*x[q]
+              End; {k}
+            t^[i] := h/al^[i]^[ll];
+           x[i] := hh/al^[i]^[ll];
+            h := abs(t^[i]);
+           If normt<h Then normt := h
+         End; {i}
+       ca := norma*normt/normr
+     End ; {posdef}
+  If posdef Then term := 1
+ Else term := 2;
+  freemem(t, n*sr);
+ freemem(v, ll*sr);
+  DeAllocateAr2dr(n, ll, al);
+End;  {slegpbl}
+
+Procedure slegpd(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
+                 Var term: ArbInt);
+
+Var 
+    sr, i, j, k, kmin1, kk, k1n, i1n, ik, ii : ArbInt;
+                                          pd : boolean;
+        h, lkk, normr, normt, sumrowi, norma : ArbFloat;
+                           pa, pb, px, al, t : ^arfloat1;
+
+Begin
+  If (n<1) Or (rwidth<1)
+   Then
+    Begin
+      term := 3;
+     exit
+    End;
+  sr := sizeof(ArbFloat);
+  getmem(al, sqr(n)*sr);
+ getmem(t, n*sr);
+  pa := @a;
+ pb := @b;
+ px := @x;
+  For i:=1 To n Do
+    move(pa^[1+(i-1)*rwidth], al^[1+(i-1)*n], i*sr);
+  move(pb^[1], px^[1], n*sr);
+  normr := 0;
+ pd := true ;
+ norma := 0;
+  For i:=1 To n Do
+    Begin
+      sumrowi := 0;
+      For j:=1 To i Do
+        sumrowi := sumrowi+abs(al^[j+(i-1)*n]);
+      For j:=i+1 To n Do
+        sumrowi := sumrowi+abs(al^[i+(j-1)*n]);
+      If norma<sumrowi
+       Then
+        norma := sumrowi;
+      t^[i] := 2*random-1;
+     h := abs(t^[i]);
+      If normr<h
+       Then
+        normr := h
+    End; {i}
+  k := 0;
+  while (k<n) and pd Do
+    Begin
+      kmin1 := k;
+     k := k+1;
+     k1n := (k-1)*n;
+     kk := k+k1n;
+     lkk := al^[kk];
+      For j:=1 To kmin1 Do
+        lkk := lkk-sqr(al^[j+k1n]);
+      If lkk<=0
+       Then
+        pd := false
+      Else
+        Begin
+          al^[kk] := sqrt(lkk);
+         lkk := al^[kk];
+          For i:=k+1 To n Do
+            Begin
+              i1n := (i-1)*n;
+             ik := k+i1n;
+             h := al^[ik];
+              For j:=1 To kmin1 Do
+                h := h-al^[j+k1n]*al^[j+i1n];
+              al^[ik] := h/lkk
+            End; {i}
+          h := t^[k];
+          For j:=1 To kmin1 Do
+            h := h-al^[j+k1n]*t^[j];
+          t^[k] := h/lkk;
+          h := px^[k];
+          For j:=1 To kmin1 Do
+            h := h-al^[j+k1n]*px^[j];
+          px^[k] := h/lkk
+        End {lkk > 0}
+    End; {k}
+    If pd
+     Then
+      Begin
+        normt := 0;
+        For i:=n Downto 1 Do
+          Begin
+            ii := i+(i-1)*n;
+           h := t^[i];
+            For j:=i+1 To n Do
+              h := h-al^[i+(j-1)*n]*t^[j];
+            t^[i] := h/al^[ii];
+            h := px^[i];
+            For j:=i+1 To n Do
+              h := h-al^[i+(j-1)*n]*px^[j];
+            px^[i] := h/al^[ii];
+            h := abs(t^[i]);
+            If normt<h
+              Then
+                normt := h
+          End; {i}
+        ca := norma*normt/normr
+      End; {pd}
+  If pd
+   Then
+    term := 1
+  Else
+    term := 2;
+  freemem(al, sqr(n)*sr);
+ freemem(t, n*sr);
+End; {slegpd}
+
+Procedure slegpdl(n: ArbInt; Var a1; Var b1, x1, ca: ArbFloat;
+                  Var term: ArbInt);
+
+Var                   sr, i, j, k, kmin1 : ArbInt;
+                                      pd : boolean;
+    h, lkk, normr, normt, sumrowi, norma : ArbFloat;
+                                       a : ar2dr1 absolute a1;
+                                       b : arfloat1 absolute b1;
+                                       x : arfloat1 absolute x1;
+                                      al : par2dr1;
+                                       t : ^arfloat1;
+
+Begin
+  If n<1 Then
+    Begin
+      term := 3;
+     exit
+    End;
+  sr := sizeof(ArbFloat);
+  AllocateL2dr(n, al);
+ getmem(t, n*sr);
+  For i:=1 To n Do
+   move(a[i]^, al^[i]^, i*sr);
+  move(b[1], x[1], n*sr);
+  normr := 0;
+ pd := true ;
+ norma := 0;
+  For i:=1 To n Do
+    Begin
+      sumrowi := 0;
+      For j:=1 To i Do
+       sumrowi := sumrowi+abs(al^[i]^[j]);
+      For j:=i+1 To n Do
+       sumrowi := sumrowi+abs(al^[j]^[i]);
+      If norma<sumrowi Then norma := sumrowi;
+      t^[i] := 2*random-1;
+     h := abs(t^[i]);
+      If normr<h Then normr := h
+    End; {i}
+  k := 0;
+  while (k<n) and pd Do
+    Begin
+      kmin1 := k;
+     k := k+1;
+     lkk := al^[k]^[k];
+      For j:=1 To kmin1 Do
+       lkk := lkk-sqr(al^[k]^[j]);
+      If lkk<=0 Then pd := false
+     Else
+        Begin
+          al^[k]^[k] := sqrt(lkk);
+         lkk := al^[k]^[k];
+          For i:=k+1 To n Do
+            Begin
+              h := al^[i]^[k];
+              For j:=1 To kmin1 Do
+               h := h-al^[k]^[j]*al^[i]^[j];
+              al^[i]^[k] := h/lkk
+            End; {i}
+          h := t^[k];
+          For j:=1 To kmin1 Do
+           h := h-al^[k]^[j]*t^[j];
+          t^[k] := h/lkk;
+         h := x[k];
+          For j:=1 To kmin1 Do
+           h := h-al^[k]^[j]*x[j];
+          x[k] := h/lkk
+        End {lkk > 0}
+    End; {k}
+    If pd Then
+      Begin
+        normt := 0;
+        For i:=n Downto 1 Do
+          Begin
+            h := t^[i];
+            For j:=i+1 To n Do
+             h := h-al^[j]^[i]*t^[j];
+            t^[i] := h/al^[i]^[i];
+            h := x[i];
+            For j:=i+1 To n Do
+             h := h-al^[j]^[i]*x[j];
+            x[i] := h/al^[i]^[i];
+           h := abs(t^[i]);
+            If normt<h Then normt := h
+          End; {i}
+        ca := norma*normt/normr
+      End; {pd}
+  If pd Then term := 1
+ Else term := 2;
+  DeAllocateL2dr(n, al);
+ freemem(t, n*sr);
+End; {slegpdl}
+
+Procedure slegsy(n, rwidth: ArbInt; Var a, b, x, ca: ArbFloat;
+                 Var term:ArbInt);
+
+Var 
+   i, j, kmin1, k, kplus1, kmin2, imin2, nsr, nsi, nsb, ii,
+   imin1, jmin1, indexpivot, iplus1, indi, indj, indk, indp       : ArbInt;
+   ra, h, absh, maxim, pivot, ct, norma, sumrowi, normt, normr, s : ArbFloat;
+              pa, pb, pb1, px, alt, l, d, t, u, v, l1, d1, u1, t1 : ^arfloat1;
+                                                                p : ^arint1;
+                                                                q : ^arbool1;
+Begin
+  If (n<1) Or (rwidth<1)
+   Then
+    Begin
+      term := 3;
+     exit
+    End; {if}
+  pa := @a;
+ pb := @b;
+ px := @x;
+  nsr := n*sizeof(ArbFloat);
+  nsi := n*sizeof(ArbInt);
+  nsb := n*sizeof(boolean);
+  getmem(alt, n*nsr);
+  getmem(l, nsr);
+  getmem(d, nsr);
+  getmem(t, nsr);
+  getmem(u, nsr);
+  getmem(v, nsr);
+  getmem(p, nsi);
+  getmem(q, nsb);
+  getmem(l1, nsr);
+  getmem(d1, nsr);
+  getmem(u1, nsr);
+  getmem(t1, nsr);
+  getmem(pb1, nsr);
+  move(pb^, pb1^, nsr);
+  For i:=1 To n Do
+    Begin
+      indi := (i-1)*n;
+      For j:=1 To i Do
+        alt^[indi+j] := pa^[(i-1)*rwidth+j];
+    End; {i}
+  norma := 0;
+  For i:=1 To n Do
+    Begin
+      indi := (i-1)*n;
+      p^[i] := i;
+     sumrowi := 0;
+      For j:=1 To i Do
+        sumrowi := sumrowi+abs(alt^[indi+j]);
+      For j:=i+1 To n Do
+        sumrowi := sumrowi+abs(alt^[(j-1)*n+i]);
+      If norma<sumrowi
+       Then
+        norma := sumrowi
+    End; {i}
+  kmin1 := -1;
+ k := 0;
+ kplus1 := 1;
+  while k<n Do
+    Begin
+      kmin2 := kmin1;
+     kmin1 := k;
+     k := kplus1;
+     kplus1 := kplus1+1;
+      indk := kmin1*n;
+      If k>3
+       Then
+        Begin
+          t^[2] := alt^[n+2]*alt^[indk+1]+alt^[2*n+2]*alt^[indk+2];
+          For i:=3 To kmin2 Do
+            Begin
+              indi := (i-1)*n;
+              t^[i] := alt^[indi+i-1]*alt^[indk+i-2]+alt^[indi+i]
+                       *alt^[indk+i-1]+alt^[indi+n+i]*alt^[indk+i]
+            End; {i}
+          t^[kmin1] := alt^[indk-n+kmin2]*alt^[indk+k-3]
+                       +alt^[indk-n+kmin1]*alt^[indk+kmin2]
+                       +alt^[indk+kmin1];
+          h := alt^[indk+k];
+          For j:=2 To kmin1 Do
+            h := h-t^[j]*alt^[indk+j-1];
+          t^[k] := h;
+          alt^[indk+k] := h-alt^[indk+kmin1]*alt^[indk+kmin2]
+        End {k>3}
+      Else
+       If k=3
+        Then
+        Begin
+          t^[2] := alt^[n+2]*alt^[2*n+1]+alt^[2*n+2];
+          h := alt^[2*n+3]-t^[2]*alt^[2*n+1];
+          t^[3] := h;
+          alt^[2*n+3] := h-alt^[2*n+2]*alt^[2*n+1]
+        End  {k=3}
+      Else
+       If k=2
+        Then
+        t^[2] := alt^[n+2];
+      maxim := 0;
+      For i:=kplus1 To n Do
+        Begin
+          indi := (i-1)*n;
+          h := alt^[indi+k];
+          For j:=2 To k Do
+            h := h-t^[j]*alt^[indi+j-1];
+          absh := abs(h);
+          If maxim<absh
+           Then
+            Begin
+              maxim := absh;
+             indexpivot := i
+            End; {if}
+          alt^[indi+k] := h
+        End; {i}
+      If maxim <> 0
+       Then
+        Begin
+          If indexpivot>kplus1
+           Then
+            Begin
+              indp := (indexpivot-1)*n;
+              indk := k*n;
+              p^[kplus1] := indexpivot;
+              For j:=1 To k Do
+                Begin
+                  h := alt^[indk+j];
+                  alt^[indk+j] := alt^[indp+j];
+                  alt^[indp+j] := h
+                End; {j}
+              For j:=indexpivot Downto kplus1 Do
+                Begin
+                  indj := (j-1)*n;
+                  h := alt^[indj+kplus1];
+                  alt^[indj+kplus1] := alt^[indp+j];
+                  alt^[indp+j] := h
+                End; {j}
+              For i:=indexpivot To n Do
+                Begin
+                  indi := (i-1)*n;
+                  h := alt^[indi+kplus1];
+                  alt^[indi+kplus1] := alt^[indi+indexpivot];
+                  alt^[indi+indexpivot] := h
+                End  {i}
+            End; {if}
+          pivot := alt^[k*n+k];
+          For i:=k+2 To n Do
+            alt^[(i-1)*n+k] := alt^[(i-1)*n+k]/pivot
+        End {maxim <> 0}
+    End; {k}
+  d^[1] := alt^[1];
+ i := 1;
+  while i<n Do
+    Begin
+      imin1 := i;
+     i := i+1;
+      u^[imin1] := alt^[(i-1)*n+imin1];
+      l^[imin1] := u^[imin1];
+     d^[i] := alt^[(i-1)*n+i]
+    End; {i}
+  mdtgtr(n, l^[1], d^[1], u^[1], l1^[1], d1^[1], u1^[1], v^[1],
+         q^[1], ct, term);
+  If term=1
+   Then
+    Begin
+      normr := 0;
+      For i:=1 To n Do
+        Begin
+          t^[i] := 2*random-1;
+         h := t^[i];
+          h := abs(h);
+          If normr<h
+           Then
+            normr := h
+        End; {i}
+      For i:=1 To n Do
+        Begin
+          indexpivot := p^[i];
+          If indexpivot <> i
+           Then
+            Begin
+              h := pb1^[i];
+             pb1^[i] := pb1^[indexpivot];
+              pb1^[indexpivot] := h
+            End {if}
+        End; {i}
+      i := 0;
+      while i<n Do
+        Begin
+          indi := i*n;
+          imin1 := i;
+         i := i+1;
+         j := 1;
+         h := t^[i];
+         s := pb1^[i];
+          while j<imin1 Do
+            Begin
+              jmin1 := j;
+             j := j+1;
+              s := s-alt^[indi+jmin1]*pb1^[j];
+              h := h-alt^[indi+jmin1]*t^[j]
+            End; {j}
+          t^[i] := h;
+         pb1^[i] := s
+        End; {i}
+      dslgtr(n, l1^[1], d1^[1], u1^[1], v^[1], q^[1], pb1^[1], px^[1], term);
+      dslgtr(n, l1^[1], d1^[1], u1^[1], v^[1], q^[1], t^[1], t1^[1], term);
+      i := n+1;
+     imin1 := n;
+     normt := 0;
+      while i>2 Do
+        Begin
+          iplus1 := i;
+         i := imin1;
+         imin1 := imin1-1;
+          h := t1^[i];
+         s := px^[i];
+          For j:=iplus1 To n Do
+            Begin
+              indj := (j-1)*n+imin1;
+              h := h-alt^[indj]*t1^[j];
+              s := s-alt^[indj]*px^[j]
+            End; {j}
+          px^[i] := s;
+          t1^[i] := h;
+         h := abs(h);
+          If normt<h
+           Then
+            normt := h
+        End; {i}
+      For i:=n Downto 1 Do
+        Begin
+          indexpivot := p^[i];
+          If indexpivot <> i
+           Then
+            Begin
+              h := px^[i];
+             px^[i] := px^[indexpivot];
+              px^[indexpivot] := h
+            End {if}
+        End; {i}
+      ca := norma*normt/normr
+    End {term=1}
+  Else
+    term := 2;
+  freemem(alt, n*nsr);
+  freemem(l, nsr);
+  freemem(d, nsr);
+  freemem(t, nsr);
+  freemem(u, nsr);
+  freemem(v, nsr);
+  freemem(p, nsi);
+  freemem(q, nsb);
+  freemem(l1, nsr);
+  freemem(d1, nsr);
+  freemem(u1, nsr);
+  freemem(t1, nsr);
+  freemem(pb1, nsr);
+End; {slegsy}
+
+Procedure slegsyl(n: ArbInt; Var a1; Var b1, x1, ca: ArbFloat;
+                  Var term: ArbInt);
+
+Var 
+   i, j, kmin1, k, kplus1, kmin2, imin2, nsr, nsi, nsb, ii,
+   imin1, jmin1, indexpivot, iplus1, indi, indj, indk, indp       : ArbInt;
+   ra, h, absh, maxim, pivot, ct, norma, sumrowi, normt, normr, s : ArbFloat;
+                                           a : ar2dr1 absolute a1;
+                                           b : arfloat1 absolute b1;
+                                           x : arfloat1 absolute x1;
+           b0, l, d, t, u, v, l1, d1, u1, t1 : ^arfloat1;
+                                         alt : par2dr1;
+                                           p : ^arint1;
+                                           q : ^arbool1;
+Begin
+  If n<1 Then
+    Begin
+      term := 3;
+     exit
+    End; {if}
+  nsr := n*sizeof(ArbFloat);
+ nsi := n*sizeof(ArbInt);
+ nsb := n*sizeof(boolean);
+  AllocateL2dr(n, alt);
+  getmem(l, nsr);
+ getmem(d, nsr);
+ getmem(t, nsr);
+  getmem(u, nsr);
+ getmem(v, nsr);
+ getmem(p, nsi);
+  getmem(q, nsb);
+ getmem(l1, nsr);
+ getmem(d1, nsr);
+  getmem(u1, nsr);
+ getmem(t1, nsr);
+ getmem(b0, nsr);
+  move(b[1], b0^, nsr);
+  For i:=1 To n Do
+   move(a[i]^, alt^[i]^, i*sizeof(ArbFloat));
+  norma := 0;
+  For i:=1 To n Do
+    Begin
+      p^[i] := i;
+     sumrowi := 0;
+      For j:=1 To i Do
+       sumrowi := sumrowi+abs(alt^[i]^[j]);
+      For j:=i+1 To n Do
+       sumrowi := sumrowi+abs(alt^[j]^[i]);
+      If norma<sumrowi Then norma := sumrowi
+    End; {i}
+  k := 0;
+  while k<n Do
+    Begin
+      Inc(k);
+      If k>3 Then
+        Begin
+          t^[2] := alt^[2]^[2]*alt^[k]^[1]+alt^[3]^[2]*alt^[k]^[2];
+          For i:=3 To k-2 Do
+            t^[i] := alt^[i]^[i-1]*alt^[k]^[i-2]+alt^[i]^[i]
+                     *alt^[k]^[i-1]+alt^[i+1]^[i]*alt^[k]^[i];
+          t^[k-1] := alt^[k-1]^[k-2]*alt^[k]^[k-3]
+                     +alt^[k-1]^[k-1]*alt^[k]^[k-2]+alt^[k]^[k-1];
+          h := alt^[k]^[k];
+          For j:=2 To k-1 Do
+           h := h-t^[j]*alt^[k]^[j-1];
+          t^[k] := h;
+          alt^[k]^[k] := h-alt^[k]^[k-1]*alt^[k]^[k-2]
+        End {k>3}
+      Else
+       If k=3
+        Then
+        Begin
+          t^[2] := alt^[2]^[2]*alt^[3]^[1]+alt^[3]^[2];
+          h := alt^[3]^[3]-t^[2]*alt^[3]^[1];
+          t^[3] := h;
+          alt^[3]^[3] := h-alt^[3]^[2]*alt^[3]^[1]
+        End  {k=3}
+      Else
+       If k=2 Then t^[2] := alt^[2]^[2];
+      maxim := 0;
+      For i:=k+1 To n Do
+        Begin
+          h := alt^[i]^[k];
+          For j:=2 To k Do
+           h := h-t^[j]*alt^[i]^[j-1];
+          absh := abs(h);
+          If maxim<absh Then
+            Begin
+              maxim := absh;
+             indexpivot := i
+            End; {if}
+          alt^[i]^[k] := h
+        End; {i}
+      If maxim <> 0
+       Then
+        Begin
+          If indexpivot>k+1 Then
+            Begin
+              p^[k+1] := indexpivot;
+              For j:=1 To k Do
+                Begin
+                  h := alt^[k+1]^[j];
+                  alt^[k+1]^[j] := alt^[indexpivot]^[j];
+                  alt^[indexpivot]^[j] := h
+                End; {j}
+              For j:=indexpivot Downto k+1 Do
+                Begin
+                  h := alt^[j]^[k+1];
+                  alt^[j]^[k+1] := alt^[indexpivot]^[j];
+                  alt^[indexpivot]^[j] := h
+                End; {j}
+              For i:=indexpivot To n Do
+                Begin
+                  h := alt^[i]^[k+1];
+                  alt^[i]^[k+1] := alt^[i]^[indexpivot];
+                  alt^[i]^[indexpivot] := h
+                End  {i}
+            End; {if}
+          pivot := alt^[k+1]^[k];
+          For i:=k+2 To n Do
+           alt^[i]^[k] := alt^[i]^[k]/pivot
+        End {maxim <> 0}
+    End; {k}
+  d^[1] := alt^[1]^[1];
+ i := 1;
+  while i<n Do
+    Begin
+      Inc(i);
+      u^[i-1] := alt^[i]^[i-1];
+      l^[i-1] := u^[i-1];
+     d^[i] := alt^[i]^[i]
+    End; {i}
+  mdtgtr(n, l^[1], d^[1], u^[1], l1^[1], d1^[1], u1^[1], v^[1],
+         q^[1], ct, term);
+  If term=1 Then
+    Begin
+      normr := 0;
+      For i:=1 To n Do
+        Begin
+          t^[i] := 2*random-1;
+         h := t^[i];
+          h := abs(h);
+          If normr<h Then normr := h
+        End; {i}
+      For i:=1 To n Do
+        Begin
+          indexpivot := p^[i];
+          If indexpivot <> i
+           Then
+            Begin
+              h := b0^[i];
+             b0^[i] := b0^[indexpivot];
+              b0^[indexpivot] := h
+            End {if}
+        End; {i}
+      i := 0;
+      while i<n Do
+        Begin
+          Inc(i);
+         j := 1;
+         h := t^[i];
+         s := b0^[i];
+          while j<i-1 Do
+            Begin
+              Inc(j);
+              s := s-alt^[i]^[j-1]*b0^[j];
+              h := h-alt^[i]^[j-1]*t^[j]
+            End; {j}
+          t^[i] := h;
+         b0^[i] := s
+        End; {i}
+      dslgtr(n, l1^[1], d1^[1], u1^[1], v^[1], q^[1], b0^[1], x[1], term);
+      dslgtr(n, l1^[1], d1^[1], u1^[1], v^[1], q^[1], t^[1], t1^[1], term);
+      i := n+1;
+     normt := 0;
+      while i>2 Do
+        Begin
+          Dec(i);
+          h := t1^[i];
+         s := x[i];
+          For j:=i+1 To n Do
+            Begin
+              h := h-alt^[j]^[i-1]*t1^[j];
+              s := s-alt^[j]^[i-1]*x[j]
+            End; {j}
+          x[i] := s;
+         t1^[i] := h;
+         h := abs(h);
+          If normt<h Then normt := h
+        End; {i}
+      For i:=n Downto 1 Do
+        Begin
+          indexpivot := p^[i];
+          If indexpivot <> i Then
+            Begin
+              h := x[i];
+             x[i] := x[indexpivot];
+             x[indexpivot] := h
+            End {if}
+        End; {i}
+      ca := norma*normt/normr
+    End {term=1}
+  Else
+    term := 2;
+  freemem(l, nsr);
+ freemem(d, nsr);
+ freemem(t, nsr);
+  freemem(u, nsr);
+ freemem(v, nsr);
+ freemem(p, nsi);
+  freemem(q, nsb);
+ freemem(l1, nsr);
+ freemem(d1, nsr);
+  freemem(u1, nsr);
+ freemem(t1, nsr);
+ freemem(b0, nsr);
+  DeAllocateL2dr(n, alt);
+End; {slegsyl}
+
+Procedure slegtr(n:ArbInt; Var l, d, u, b, x, ca: ArbFloat;
+                 Var term: ArbInt);
+
+Var                           singular, ch : boolean;
+               i, j, nm1, sr, n1s, ns, n2s : ArbInt;
+            normr, normt, h, lj, di, ui, m : ArbFloat;
+                                    pl, ll : ^arfloat2;
+    pd, pu, pb, px, dd, uu1, u2, t, sumrow : ^arfloat1;
+Begin
+  If n<1
+   Then
+    Begin
+      term := 3;
+     exit
+    End; {n<1}
+  sr := sizeof(ArbFloat);
+ n1s := (n-1)*sr;
+ ns := n1s+sr;
+ n2s := n1s;
+  getmem(ll, n1s);
+  getmem(uu1, n1s);
+  getmem(u2, n2s);
+  getmem(dd, ns);
+  getmem(t, ns);
+  getmem(sumrow, ns);
+
+  pl := @l;
+ pd := @d;
+ pu := @u;
+ pb := @b;
+ px := @x;
+  move(pl^[2], ll^[2], n1s);
+  move(pd^[1], dd^[1], ns);
+  If n>1
+   Then
+    move(pu^[1], uu1^[1], n1s);
+  move(pb^[1], px^[1], ns);
+  normr := 0;
+ singular := false;
+  nm1 := n-1;
+ i := 0;
+  while (i<n) and not singular Do
+    Begin
+      i := i+1;
+      If i=1
+       Then
+        Begin
+          sumrow^[i] := abs(dd^[1]);
+          If n>1
+           Then
+            sumrow^[i] := sumrow^[i]+abs(uu1^[1])
+        End {i=1}
+      Else
+        If i=n
+         Then
+          sumrow^[i] := abs(ll^[n])+abs(dd^[n])
+        Else
+          sumrow^[i] := abs(ll^[i])+abs(dd^[i])+abs(uu1^[i]);
+      If sumrow^[i]=0
+       Then
+        singular := true
+      Else
+        Begin
+          h := 2*random-1;
+         t^[i] := sumrow^[i]*h;
+          h := abs(h);
+          If normr<h
+           Then
+            normr := h
+        End {sumrow^[i] <> 0}
+    End; {i}
+  j := 1;
+  while (j <> n) and  not singular Do
+    Begin
+      i := j;
+     j := j+1;
+     lj := ll^[j];
+      If lj <> 0
+       Then
+        Begin
+          di := dd^[i];
+          ch := abs(di/sumrow^[i])<abs(lj/sumrow^[j]);
+          If ch
+           Then
+            Begin
+              ui := uu1^[i];
+             dd^[i] := lj;
+             uu1^[i] := dd^[j];
+             m := di/lj;
+              dd^[j] := ui-m*dd^[j];
+              If i<nm1
+               Then
+                Begin
+                  u2^[i] := uu1^[j];
+                 uu1^[j] := -m*u2^[i]
+                End; {i<nm1}
+              sumrow^[j] := sumrow^[i];
+              h := t^[i];
+             t^[i] := t^[j];
+             t^[j] := h-m*t^[i];
+             h := px^[i];
+              px^[i] := px^[j];
+             px^[j] := h-m*px^[i]
+            End {ch}
+          Else
+            Begin
+              m := lj/di;
+             dd^[j] := dd^[j]-m*uu1^[i];
+              If i<nm1
+               Then
+                u2^[i] := 0;
+              t^[j] := t^[j]-m*t^[i];
+             px^[j] := px^[j]-m*px^[i]
+            End {not ch}
+        End {lj <> 0}
+      Else
+        Begin
+          If i < nm1
+            Then
+              u2^[i] := 0;
+          If dd^[i]=0
+           Then
+            singular := true
+        End {lj=0}
+    End; {j}
+  If dd^[n]=0
+   Then
+    singular := true;
+  If  Not singular
+    Then
+      Begin
+        normt := 0;
+       t^[n] := t^[n]/dd^[n];
+       px^[n] := px^[n]/dd^[n];
+       h := abs(t^[n]);
+        If normt<h
+         Then
+          normt := h;
+        If n>1
+         Then
+          Begin
+            t^[nm1] := (t^[nm1]-uu1^[nm1]*t^[n])/dd^[nm1];
+            px^[nm1] := (px^[nm1]-uu1^[nm1]*px^[n])/dd^[nm1];
+           h := abs(t^[nm1])
+          End; {n>1}
+        If normt<h
+         Then
+          normt := h;
+        For i:=n-2 Downto 1 Do
+          Begin
+            t^[i] := (t^[i]-uu1^[i]*t^[i+1]-u2^[i]*t^[i+2])/dd^[i];
+            px^[i] := (px^[i]-uu1^[i]*px^[i+1]-u2^[i]*px^[i+2])/dd^[i];
+            h := abs(t^[i]);
+            If normt<h
+             Then
+              normt := h
+          End; {i}
+        ca := normt/normr
+      End; {not singular}
+  If singular
+   Then
+    term := 2
+  Else
+    term := 1;
+  freemem(ll, n1s);
+  freemem(uu1, n1s);
+  freemem(u2, n2s);
+  freemem(dd, ns);
+  freemem(t, ns);
+  freemem(sumrow, ns);
+End; {slegtr}
+
+Begin
+  randseed := 12345
+End.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/spe.pas

@@ -0,0 +1,1308 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Special functions. (Currently, most of these functions only work for
+            ArbFloat=REAL/DOUBLE, not for Extended(at least not at full
+            precision, implement the tables in the diverse functions
+            for extended)
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit spe;
+{$I DIRECT.INC}
+
+interface
+
+uses typ;
+
+{  Calculate modified Besselfunction "of the first kind" I0(x) }
+function spebi0(x: ArbFloat): ArbFloat;
+
+{  Calculate modified Besselfunction "of the first kind" I1(x) }
+function spebi1(x: ArbFloat): ArbFloat;
+
+{  Calculate Besselfunction "of the first kind" J0(x) }
+function spebj0(x: ArbFloat): ArbFloat;
+
+{  Calculate Besselfunction "of the first kind" J1(x) }
+function spebj1(x: ArbFloat): ArbFloat;
+
+{  Calculate modified Besselfunction "of the second kind" K0(x) }
+function spebk0(x: ArbFloat): ArbFloat;
+
+{  Calculate modified Besselfunction "of the second kind" K1(x) }
+function spebk1(x: ArbFloat): ArbFloat;
+
+{  Calculate Besselfunction "of the second kind" Y0(x) }
+function speby0(x: ArbFloat): ArbFloat;
+
+{  Calculate Besselfunction "of the second kind" Y1(x) }
+function speby1(x: ArbFloat): ArbFloat;
+
+{  Entier function, calculates first integer greater or equal than X}
+function speent(x: ArbFloat): longint;
+
+{  Errorfunction ( 2/sqrt(pi)* Int(t,0,pi,exp(sqr(t)) )}
+function speerf(x: ArbFloat): ArbFloat;
+
+{  Errorfunction's complement ( 2/sqrt(pi)* Int(t,pi,inf,exp(sqr(t)) )}
+function speefc(x: ArbFloat): ArbFloat;
+
+{  Function to calculate the Gamma function ( int(t,0,inf,t^(x-1)*exp(-t)) }
+function spegam(x: ArbFloat): ArbFloat;
+
+{  Function to calculate the natural logaritm of the Gamma function}
+function spelga(x: ArbFloat): ArbFloat;
+
+{  "Calculates" the maximum of two ArbFloat values     }
+function spemax(a, b: ArbFloat): ArbFloat;
+
+{  Calculates the functionvalue of a polynomalfunction with n coefficients in a
+for variable X }
+function spepol(x: ArbFloat; var a: ArbFloat; n: ArbInt): ArbFloat;
+
+{ Calc a^b with a and b real numbers}
+function spepow(a, b: ArbFloat): ArbFloat;
+
+{ Returns sign of x (-1 for x<0, 0 for x=0 and 1 for x>0)  }
+function spesgn(x: ArbFloat): ArbInt;
+
+{  ArcSin(x) }
+function spears(x: ArbFloat): ArbFloat;
+
+{  ArcCos(x) }
+function spearc(x: ArbFloat): ArbFloat;
+
+{  Sinh(x) }
+function spesih(x: ArbFloat): ArbFloat;
+
+{  Cosh(x) }
+function specoh(x: ArbFloat): ArbFloat;
+
+{  Tanh(x) }
+function spetah(x: ArbFloat): ArbFloat;
+
+{  ArcSinH(x) }
+function speash(x: ArbFloat): ArbFloat;
+
+{  ArcCosh(x) }
+function speach(x: ArbFloat): ArbFloat;
+
+{  ArcTanH(x) }
+function speath(x: ArbFloat): ArbFloat;
+
+implementation
+
+function spebi0(x: ArbFloat): ArbFloat;
+
+const
+
+     xvsmall = 3.2e-9;
+          a1 : array[0..23] of ArbFloat =
+               (  3.08508322553671039e-1, -1.86478066609466760e-1,
+                  1.57686843969995904e-1, -1.28895621330524993e-1,
+                  9.41616340200868389e-2, -6.04316795007737183e-2,
+                  3.41505388391452157e-2, -1.71317947935716536e-2,
+                  7.70061052263382555e-3, -3.12923286656374358e-3,
+                  1.15888319775791686e-3, -3.93934532072526720e-4,
+                  1.23682594989692688e-4, -3.60645571444886286e-5,
+                  9.81395862769787105e-6, -2.50298975966588680e-6,
+                  6.00566861079330132e-7, -1.36042013507151017e-7,
+                  2.92096163521178835e-8, -5.94856273204259507e-9,
+                  1.13415934215369209e-9, -2.10071360134551962e-10,
+                  4.44484446637868974e-11,-7.48150165756234957e-12);
+          a2 : array[0..26] of ArbFloat =
+               (  1.43431781856850311e-1, -3.71571542566085323e-2,
+                  1.44861237337359455e-2, -6.30121694459896307e-3,
+                  2.89362046530968701e-3, -1.37638906941232170e-3,
+                  6.72508592273773611e-4, -3.35833513200679384e-4,
+                  1.70524543267970595e-4, -8.74354291104467762e-5,
+                  4.48739019580173804e-5, -2.28278155280668483e-5,
+                  1.14032404021741277e-5, -5.54917762110482949e-6,
+                  2.61457634142262604e-6, -1.18752840689765504e-6,
+                  5.18632519069546106e-7, -2.17653548816447667e-7,
+                  8.75291839187305722e-8, -3.34900221934314738e-8,
+                  1.24131668344616429e-8, -4.66215489983794905e-9,
+                  1.58599776268172290e-9, -3.80370174256271589e-10,
+                  1.23188158175419302e-10,-8.46900307934754898e-11,
+                  2.45185252963941089e-11);
+           a3: array[0..19] of ArbFloat =
+               (  4.01071065066847416e-1,  2.18216817211694382e-3,
+                  5.59848253337377763e-5,  2.79770701849785597e-6,
+                  2.17160501061222148e-7,  2.36884434055843528e-8,
+                  3.44345025431425567e-9,  6.47994117793472057e-10,
+                  1.56147127476528831e-10, 4.82726630988879388e-11,
+                  1.89599322920800794e-11, 1.05863621425699789e-11,
+                  8.27719401266046976e-12, 2.82807056475555021e-12,
+                 -4.34624739357691085e-12,-4.29417106720584499e-12,
+                  4.30812577328136192e-13, 1.44572313799118029e-12,
+                  4.73229306831831040e-14,-1.95679809047625728e-13);
+
+
+var t : ArbFloat;
+
+begin
+  t:=abs(x);
+  if t <=xvsmall
+  then
+    spebi0:=1
+  else
+  if t <= 4
+  then
+    spebi0 := exp(t)*spepol(t/2-1, a1[0], SizeOf(a1) div SizeOf(ArbFloat) -1)
+  else
+  if t <= 12
+  then
+    spebi0:=exp(t)*spepol(t/4-2, a2[0], SizeOf(a2) div SizeOf(ArbFloat) -1)
+  else { t > 12}
+    spebi0:=(exp(t)/sqrt(t))*
+            spepol(24/t-1, a3[0], SizeOf(a3) div SizeOf(ArbFloat) -1)
+end; {spebi0}
+
+function spebi1(x: ArbFloat): ArbFloat;
+
+
+const xvsmall = 3.2e-9;
+      a1: array[0..11] of ArbFloat =
+      ( 1.19741654963670236e+0, 9.28758890114609554e-1,
+        2.68657659522092832e-1, 4.09286371827770484e-2,
+        3.84763940423809498e-3, 2.45224314039278904e-4,
+        1.12849795779951847e-5, 3.92368710996392755e-7,
+        1.06662712314503955e-8, 2.32856921884663846e-10,
+        4.17372709788222413e-12,6.24387910353848320e-14);
+
+      a2: array[0..26] of ArbFloat =
+      ( 1.34142493292698178e-1, -2.99140923897405570e-2,
+        9.76021102528646704e-3, -3.40759647928956354e-3,
+        1.17313412855965374e-3, -3.67626180992174570e-4,
+        8.47999438119288094e-5,  5.21557319070236939e-6,
+       -2.62051678511418163e-5,  2.47493270133518925e-5,
+       -1.79026222757948636e-5,  1.13818992442463952e-5,
+       -6.63144162982509821e-6,  3.60186151617732531e-6,
+       -1.83910206626348772e-6,  8.86951515545183908e-7,
+       -4.05456611578551130e-7,  1.76305222240064495e-7,
+       -7.28978293484163628e-8,  2.84961041291017650e-8,
+       -1.07563514207617768e-8,  4.11321223904934809e-9,
+       -1.41575617446629553e-9,  3.38883570696523350e-10,
+       -1.10970391104678003e-10, 7.79929176497056645e-11,
+       -2.27061376122617856e-11);
+
+       a3: array[0..19] of ArbFloat =
+       ( 3.92624494204116555e-1, -6.40545360348237412e-3,
+        -9.12475535508497109e-5, -3.82795135453556215e-6,
+        -2.72684545741400871e-7, -2.82537120880041703e-8,
+        -3.96757162863209348e-9, -7.28107961041827952e-10,
+        -1.72060490748583241e-10,-5.23524129533553498e-11,
+        -2.02947854602758139e-11,-1.11795516742222899e-11,
+        -8.69631766630563635e-12,-3.05957293450420224e-12,
+         4.42966462319664333e-12, 4.47735589657057690e-12,
+        -3.95353303949377536e-13,-1.48765082315961139e-12,
+        -5.77176811730370560e-14, 1.99448557598015488e-13);
+
+var t : ArbFloat;
+
+begin
+  t:=abs(x);
+  if t <= xvsmall
+  then
+    spebi1:=x/2
+  else
+  if t <= 4
+  then
+    spebi1:=x*spepol(sqr(t)/8-1, a1[0], sizeof(a1) div sizeof(ArbFloat)-1)
+  else
+  if t <= 12
+  then
+    spebi1:=
+      exp(t)*spepol(t/4-2, a2[0], sizeof(a2) div sizeof(ArbFloat)-1)*spesgn(x)
+  else { t > 12}
+    spebi1:=
+      (exp(t)/sqrt(t))*
+      spepol(24/t-1, a3[0], sizeof(a3) div sizeof(ArbFloat)-1)*spesgn(x)
+end; {spebi1}
+
+function spebj0(x: ArbFloat): ArbFloat;
+const
+
+       xvsmall = 3.2e-9;
+          tbpi = 6.36619772367581343e-1;
+           a1 : array[0..5] of ArbFloat =
+           ( 1.22200000000000000e-17, -1.94383469000000000e-12,
+             7.60816359241900000e-8,  -4.60626166206275050e-4,
+             1.58067102332097261e-1,  -8.72344235285222129e-3);
+
+            b1 : array[0..5] of ArbFloat =
+            ( - 7.58850000000000000e-16, 7.84869631400000000e-11,
+              - 1.76194690776215000e-6,  4.81918006946760450e-3,
+              - 3.70094993872649779e-1,  1.57727971474890120e-1);
+
+            c1 : array[0..4] of ArbFloat =
+            ( 4.12532100000000000e-14, - 2.67925353056000000e-9,
+              3.24603288210050800e-5,  - 3.48937694114088852e-2,
+              2.65178613203336810e-1);
+
+            d1 : array[0..13] of ArbFloat =
+            ( 9.99457275788251954e-1, -5.36367319213004570e-4,
+              6.13741608010926000e-6, -2.05274481565160000e-7,
+              1.28037614434400000e-8, -1.21211819632000000e-9,
+              1.55005642880000000e-10,-2.48827276800000000e-11,
+              4.78702080000000000e-12,-1.06365696000000000e-12,
+              2.45294080000000000e-13,-6.41843200000000000e-14,
+              3.34028800000000000e-14,-1.17964800000000000e-14);
+
+             d2 : array[0..16] of ArbFloat =
+             ( -1.55551138795135187e-2,  6.83314909934390000e-5,
+               -1.47713883264594000e-6,  7.10621485930000000e-8,
+               -5.66871613024000000e-9,  6.43278173280000000e-10,
+               -9.47034774400000000e-11, 1.70330918400000000e-11,
+               -3.59094272000000000e-12, 8.59855360000000000e-13,
+               -2.28807680000000000e-13, 6.95193600000000000e-14,
+               -2.27942400000000000e-14, 4.75136000000000000e-15,
+               -1.14688000000000000e-15, 2.12992000000000000e-15,
+               -9.83040000000000000e-16);
+
+var t, g, y, t2, a, b, c, cx, sx : ArbFloat;
+    i, bov                       : ArbInt;
+
+begin
+  t:=abs(x);
+  if t<=xvsmall
+  then
+    spebj0:=1
+  else
+  if t<=8
+  then
+    begin
+      t:=0.03125*sqr(t)-1; t2:=2*t;
+      b:=0; c:=0;
+      bov:=sizeof(a1) div sizeof(ArbFloat) - 1;
+      for i:=0 to bov do
+        begin
+          a:=t2*c-b+a1[i];
+          if i<5
+          then
+            b:=t2*a-c+b1[i]
+          else
+            spebj0:=t*a-c+b1[i];
+          if i<bov
+          then
+            c:=t2*b-a+c1[i]
+          else
+            if i<5
+            then
+              spebj0:=t*b-a+c1[i]
+        end {i}
+    end {abs(x)<=8}
+  else
+    begin
+      g:=t-1/(2*tbpi); y:=sqrt(tbpi/t);
+      cx:=cos(g)*y; sx:=-sin(g)*y*8/t;
+      t:=128/sqr(t)-1;
+      spebj0:=cx*spepol(t, d1[0], sizeof(d1) div sizeof(ArbFloat) - 1)
+              + sx*spepol(t, d2[0], sizeof(d2) div sizeof(ArbFloat) - 1)
+    end {abs(x)>8}
+    
+end {spebj0};
+
+function spebj1(x: ArbFloat): ArbFloat;
+const
+
+       xvsmall = 3.2e-9;
+          tbpi = 6.36619772367581343e-1;
+      a1 : array[0..5] of ArbFloat =
+      ( 2.95000000000000000e-18, -5.77740420000000000e-13,
+        2.94970700727800000e-8,  -2.60444389348580680e-4,
+        1.77709117239728283e-1,  -1.19180116054121687e+0);
+
+      b1 : array[0..5] of ArbFloat =
+      ( -1.95540000000000000e-16, 2.52812366400000000e-11,
+        -7.61758780540030000e-7,  3.24027018268385747e-3,
+        -6.61443934134543253e-1,  6.48358770605264921e-1);
+
+      c1 : array[0..4] of ArbFloat =
+      ( 1.13857200000000000e-14, -9.42421298160000000e-10,
+        1.58870192399321300e-5,  -2.91755248061542077e-2,
+        1.28799409885767762e+0);
+
+       d1 : array[0..13] of ArbFloat =
+       ( 1.00090702627808217e+0,  8.98804941670557880e-4,
+        -7.95969469843846000e-6,  2.45367662227560000e-7,
+        -1.47085129889600000e-8,  1.36030580128000000e-9,
+        -1.71310758400000000e-10, 2.72040729600000000e-11,
+        -5.19113984000000000e-12, 1.14622464000000000e-12,
+        -2.63372800000000000e-13, 6.86387200000000000e-14,
+        -3.54508800000000000e-14, 1.24928000000000000e-14);
+
+       d2 : array[0..15] of ArbFloat =
+       ( 4.67768740274489776e-2,  -9.62145882205441600e-5,
+         1.82120185123076000e-6,  -8.29196070929200000e-8,
+         6.42013250344000000e-9,  -7.15110504800000000e-10,
+         1.03950931840000000e-10, -1.85248000000000000e-11,
+         3.87554432000000000e-12, -9.23228160000000000e-13,
+         2.50224640000000000e-13, -7.43936000000000000e-14,
+         1.75718400000000000e-14, -4.83328000000000000e-15,
+         5.32480000000000000e-15, -2.29376000000000000e-15);
+
+var t, g, y, t2, a, b, c, cx, sx : ArbFloat;
+    i, bov                       : ArbInt;
+
+begin
+  t:=abs(x);
+  if t<xvsmall
+  then
+    spebj1:=x/2
+  else
+  if t<=8
+  then
+    begin
+      t:=0.03125*sqr(t)-1; t2:=2*t;
+      b:=0; c:=0;
+      bov:=sizeof(a1) div sizeof(ArbFloat) - 1;
+      for i:=0 to bov do
+        begin
+          a:=t2*c-b+a1[i];
+          if i<bov
+          then
+            begin
+              b:=t2*a-c+b1[i];
+              c:=t2*b-a+c1[i]
+            end
+          else
+            spebj1:=(x/8)*(t*a-c+b1[i])
+        end {i}
+    end {abs(x)<=8}
+  else
+    begin
+      g:=t-1.5/tbpi; y:=sqrt(tbpi/t)*spesgn(x);
+      cx:=cos(g)*y; sx:=-sin(g)*y*8/t;
+      t:=128/sqr(t)-1;
+      spebj1:=cx*spepol(t, d1[0], sizeof(d1) div sizeof(ArbFloat) - 1)
+              + sx*spepol(t, d2[0], sizeof(d2) div sizeof(ArbFloat) - 1)
+    end {abs(x)>8}
+end {spebj1};
+
+function spebk0(x: ArbFloat): ArbFloat;
+
+const
+
+     egam = 0.57721566490153286;
+     xvsmall = 3.2e-9;
+     highexp = 745;
+
+      a0: array[0..7] of ArbFloat =
+      ( 1.12896092945412762e+0,  1.32976966478338191e-1,
+        4.07157485171389048e-3,  5.59702338227915383e-5,
+        4.34562671546158210e-7,  2.16382411824721532e-9,
+        7.49110736894134794e-12, 1.90674197514561280e-14);
+
+      a1: array[0..8] of ArbFloat =
+      ( 2.61841879258687055e-1,  1.52436921799395196e-1,
+        6.63513979313943827e-3,  1.09534292632401542e-4,
+        9.57878493265929443e-7,  5.19906865800665633e-9,
+        1.92405264219706684e-11, 5.16867886946332160e-14,
+        1.05407718191360000e-16);
+
+      a2: array[0..22] of ArbFloat =
+      ( 9.58210053294896496e-1, -1.42477910128828254e-1,
+        3.23582010649653009e-2, -8.27780350351692662e-3,
+        2.24709729617770471e-3, -6.32678357460594866e-4,
+        1.82652460089342789e-4, -5.37101208898441760e-5,
+        1.60185974149720562e-5, -4.83134250336922161e-6,
+        1.47055796078231691e-6, -4.51017292375200017e-7,
+        1.39217270224614153e-7, -4.32185089841834127e-8,
+        1.34790467361340101e-8, -4.20597329258249948e-9,
+        1.32069362385968867e-9, -4.33326665618780914e-10,
+        1.37999268074442719e-10, -3.19241059198852137e-11,
+        9.74410152270679245e-12, -7.83738609108569293e-12,
+        2.57466288575820595e-12);
+
+      a3: array[0..22] of ArbFloat =
+     ( 6.97761598043851776e-1, -1.08801882084935132e-1,
+       2.56253646031960321e-2, -6.74459607940169198e-3,
+       1.87292939725962385e-3, -5.37145622971910027e-4,
+       1.57451516235860573e-4, -4.68936653814896712e-5,
+       1.41376509343622727e-5, -4.30373871727268511e-6,
+       1.32052261058932425e-6, -4.07851207862189007e-7,
+       1.26672629417567360e-7, -3.95403255713518420e-8,
+       1.23923137898346852e-8, -3.88349705250555658e-9,
+       1.22424982779432970e-9, -4.03424607871960089e-10,
+       1.28905587479980147e-10,-2.97787564633235128e-11,
+       9.11109430833001267e-12,-7.39672783987933184e-12,
+       2.43538242247537459e-12);
+      a4: array[0..16] of ArbFloat =
+      ( 1.23688664769425422e+0,  -1.72683652385321641e-2,
+       -9.25551464765637133e-4,  -9.02553345187404564e-5,
+       -6.31692398333746470e-6,  -7.69177622529272933e-7,
+       -4.16044811174114579e-8,  -9.41555321137176073e-9,
+        1.75359321273580603e-10, -2.22829582288833265e-10,
+        3.49564293256545992e-11, -1.11391758572647639e-11,
+        2.85481235167705907e-12, -7.31344482663931904e-13,
+        2.06328892562554880e-13, -1.28108310826991616e-13,
+        4.43741979886551040e-14);
+
+
+var t: ArbFloat;
+
+begin
+  if x<=0
+  then
+    RunError(401);
+  if x<=xvsmall
+  then
+    spebk0:=-(ln(x/2)+egam)
+  else
+  if x<=1
+  then
+    begin
+      t:=2*sqr(x)-1;
+      spebk0:=-ln(x)*spepol(t, a0[0], sizeof(a0) div sizeof(ArbFloat) - 1)
+              + spepol(t, a1[0], sizeof(a1) div sizeof(ArbFloat) - 1)
+    end
+  else
+  if x<=2
+  then
+    spebk0:=exp(-x)*spepol(2*x-3, a2[0], sizeof(a2) div sizeof(ArbFloat) - 1)
+  else
+  if x<=4
+  then
+    spebk0:=exp(-x)*spepol(x-3, a3[0], sizeof(a3) div sizeof(ArbFloat) - 1)
+  else
+  if x <= highexp
+  then
+    spebk0:=exp(-x)*
+            spepol(10/(1+x)-1, a4[0], sizeof(a4) div sizeof(ArbFloat) - 1)/sqrt(x)
+  else
+    spebk0:=0
+end; {spebk0}
+
+function spebk1(x: ArbFloat): ArbFloat;
+
+const
+
+   xsmall = 7.9e-10;
+  highexp = 745;
+   a0: array[0..7] of ArbFloat =
+   ( 5.31907865913352762e-1,  3.25725988137110495e-2,
+     6.71642805873498653e-4,  6.95300274548206237e-6,
+     4.32764823642997753e-8,  1.79784792380155752e-10,
+     5.33888268665658944e-13, 1.18964962439910400e-15);
+
+   a1: array[0..7] of ArbFloat =
+   ( 3.51825828289325536e-1,  4.50490442966943726e-2,
+     1.20333585658219028e-3,  1.44612432533006139e-5,
+     9.96686689273781531e-8,  4.46828628435618679e-10,
+     1.40917103024514301e-12, 3.29881058019865600e-15);
+
+   a2: array[0..23] of ArbFloat =
+   ( 1.24316587355255299e+0, -2.71910714388689413e-1,
+     8.20250220860693888e-2, -2.62545818729427417e-2,
+     8.57388087067410089e-3, -2.82450787841655951e-3,
+     9.34594154387642940e-4, -3.10007681013626626e-4,
+     1.02982746700060730e-4, -3.42424912211942134e-5,
+     1.13930169202553526e-5, -3.79227698821142908e-6,
+     1.26265578331941923e-6, -4.20507152338934956e-7,
+     1.40138351985185509e-7, -4.66928912168020101e-8,
+     1.54456653909012693e-8, -5.13783508140332214e-9,
+     1.82808381381205361e-9, -6.15211416898895086e-10,
+     1.28044023949946257e-10, -4.02591066627023831e-11,
+     4.27404330568767242e-11, -1.46639291782948454e-11);
+
+   a3: array[0..23] of ArbFloat =
+   ( 8.06563480128786903e-1,  -1.60052611291327173e-1,
+     4.58591528414023064e-2,  -1.42363136684423646e-2,
+     4.55865751206724687e-3,  -1.48185472032688523e-3,
+     4.85707174778663652e-4,  -1.59994873621599146e-4,
+     5.28712919123131781e-5,  -1.75089594354079944e-5,
+     5.80692311842296724e-6,  -1.92794586996432593e-6,
+     6.40581814037398274e-7,  -2.12969229346310343e-7,
+     7.08723366696569880e-8,  -2.35855618461025265e-8,
+     7.79421651144832709e-9,  -2.59039399308009059e-9,
+     9.20781685906110546e-10, -3.09667392343245062e-10,
+     6.44913423545894175e-11, -2.02680401514735862e-11,
+     2.14736751065133220e-11, -7.36478297050421658e-12);
+
+    a4: array[0..16] of ArbFloat =
+    ( 1.30387573604230402e+0,   5.44845254318931612e-2,
+      4.31639434283445364e-3,   4.29973970898766831e-4,
+      4.04720631528495020e-5,   4.32776409784235211e-6,
+      4.07563856931843484e-7,   4.86651420008153956e-8,
+      3.82717692121438315e-9,   6.77688943857588882e-10,
+      6.97075379117731379e-12,  1.72026097285930936e-11,
+     -2.60774502020271104e-12,  8.58211523713560576e-13,
+     -2.19287104441802752e-13,  1.39321122940600320e-13,
+     -4.77850238111580160e-14);
+
+var t: ArbFloat;
+
+begin
+  if x<=0
+  then
+    RunError(402);
+  if x<=xsmall
+  then
+    spebk1:=1/x
+  else
+  if x<=1
+  then
+    begin
+      t:=2*sqr(x)-1;
+      spebk1:=( ln(x)*spepol(t, a0[0], sizeof(a0) div sizeof(ArbFloat) - 1)
+              -spepol(t, a1[0], sizeof(a1) div sizeof(ArbFloat) -1) )*x + 1/x
+    end
+  else
+  if x<=2
+  then
+    spebk1:=exp(-x)*spepol(2*x-3, a2[0], sizeof(a2) div sizeof(ArbFloat) - 1)
+  else
+  if x<=4
+  then
+    spebk1:=exp(-x)*spepol(x-3, a3[0], sizeof(a3) div sizeof(ArbFloat) - 1)
+  else
+  if x <= highexp
+  then
+    spebk1:=exp(-x)*spepol(10/(1+x)-1, a4[0],
+            sizeof(a4) div sizeof(ArbFloat) - 1)/sqrt(x)
+  else
+    spebk1:=0
+end; {spebk1}
+
+function speby0(x: ArbFloat): ArbFloat;
+
+const
+
+      tbpi = 6.36619772367581343e-1;
+      egam = 5.77215664901532861e-1;
+   xvsmall = 3.2e-9;
+   a1 : array[0..5] of ArbFloat =
+   ( 3.90000000000000000e-19, -8.74734100000000000e-14,
+     5.24879478733000000e-9,  -5.63207914105698700e-5,
+     4.71966895957633869e-2,   1.79034314077182663e-1);
+
+   b1 : array[0..5] of ArbFloat =
+   ( -2.69800000000000000e-17, 4.02633082000000000e-12,
+     -1.44072332740190000e-7,  7.53113593257774230e-4,
+     -1.77302012781143582e-1, -2.74474305529745265e-1);
+
+   c1 : array[0..5] of ArbFloat =
+   ( 1.64349000000000000e-15, -1.58375525420000000e-10,
+     3.20653253765480000e-6,  -7.28796247955207918e-3,
+     2.61567346255046637e-1,  -3.31461132032849417e-2);
+
+    d1 : array[0..13] of ArbFloat =
+    ( 9.99457275788251954e-1, -5.36367319213004570e-4,
+      6.13741608010926000e-6, -2.05274481565160000e-7,
+      1.28037614434400000e-8, -1.21211819632000000e-9,
+      1.55005642880000000e-10,-2.48827276800000000e-11,
+      4.78702080000000000e-12,-1.06365696000000000e-12,
+      2.45294080000000000e-13,-6.41843200000000000e-14,
+      3.34028800000000000e-14,-1.17964800000000000e-14);
+
+    d2 : array[0..16] of ArbFloat =
+    (-1.55551138795135187e-2,  6.83314909934390000e-5,
+     -1.47713883264594000e-6,  7.10621485930000000e-8,
+     -5.66871613024000000e-9,  6.43278173280000000e-10,
+     -9.47034774400000000e-11, 1.70330918400000000e-11,
+     -3.59094272000000000e-12, 8.59855360000000000e-13,
+     -2.28807680000000000e-13, 6.95193600000000000e-14,
+     -2.27942400000000000e-14, 4.75136000000000000e-15,
+     -1.14688000000000000e-15, 2.12992000000000000e-15,
+     -9.83040000000000000e-16);
+
+var t, g, y, t2, a, b, c, cx, sx : ArbFloat;
+    i, bov                       : ArbInt;
+
+begin
+  if x<=0
+  then
+    RunError(403);
+  if x<=xvsmall
+  then
+    speby0:=(ln(x/2)+egam)*tbpi
+  else
+  if x<=8
+  then
+    begin
+      t:=0.03125*sqr(x)-1; t2:=2*t;
+      b:=0; c:=0;
+      bov:=sizeof(a1) div sizeof(ArbFloat) - 1;
+      for i:=0 to bov do
+        begin
+          a:=t2*c-b+a1[i];
+          b:=t2*a-c+b1[i];
+          if i<bov
+          then
+            c:=t2*b-a+c1[i]
+          else
+            speby0:=t*b-a+c1[i]+tbpi*spebj0(x)*ln(x)
+        end {i}
+    end {x<=8}
+  else
+    begin
+      g:=x-1/(2*tbpi); y:=sqrt(tbpi/x);
+      cx:=cos(g)*y*8/x; sx:=sin(g)*y;
+      t:=128/sqr(x)-1;
+      speby0:=sx*spepol(t, d1[0], sizeof(d1) div sizeof(ArbFloat) - 1)
+            + cx*spepol(t, d2[0], sizeof(d2) div sizeof(ArbFloat) - 1)
+    end {x>8}
+end {speby0};
+
+function speby1(x: ArbFloat): ArbFloat;
+
+const
+    tbpi = 6.36619772367581343e-1;
+    xsmall = 7.9e-10;
+   a1 : array[0..5] of ArbFloat =
+   (-6.58000000000000000e-18, 1.21143321000000000e-12,
+    -5.68844003991900000e-8,  4.40478629867099510e-4,
+    -2.26624991556754924e-1, -1.28697384381350001e-1);
+
+   b1 : array[0..5] of ArbFloat =
+   ( 4.27730000000000000e-16,-5.17212147300000000e-11,
+     1.41662436449235000e-6, -5.13164116106108479e-3,
+     6.75615780772187667e-1,  2.03041058859342538e-2);
+
+   c1 : array[0..4] of ArbFloat =
+   (-2.44094900000000000e-14, 1.87547032473000000e-9,
+    -2.83046401495148000e-5,  4.23191803533369041e-2,
+    -7.67296362886645940e-1);
+    
+   d1 : array[0..13] of ArbFloat =
+   ( 1.00090702627808217e+0,  8.98804941670557880e-4,
+    -7.95969469843846000e-6,  2.45367662227560000e-7,
+    -1.47085129889600000e-8,  1.36030580128000000e-9,
+    -1.71310758400000000e-10, 2.72040729600000000e-11,
+    -5.19113984000000000e-12, 1.14622464000000000e-12,
+    -2.63372800000000000e-13, 6.86387200000000000e-14,
+    -3.54508800000000000e-14, 1.24928000000000000e-14);
+
+    d2 : array[0..15] of ArbFloat =
+    ( 4.67768740274489776e-2, -9.62145882205441600e-5,
+      1.82120185123076000e-6, -8.29196070929200000e-8,
+      6.42013250344000000e-9, -7.15110504800000000e-10,
+      1.03950931840000000e-10,-1.85248000000000000e-11,
+      3.87554432000000000e-12,-9.23228160000000000e-13,
+      2.50224640000000000e-13,-7.43936000000000000e-14,
+      1.75718400000000000e-14,-4.83328000000000000e-15,
+      5.32480000000000000e-15,-2.29376000000000000e-15);
+
+var t, g, y, t2, a, b, c, cx, sx : ArbFloat;
+    i, bov                       : ArbInt;
+
+begin
+  if x<=0
+  then
+    RunError(404);
+  if x<=xsmall
+  then
+    speby1:=-tbpi/x
+  else
+  if x<=8
+  then
+    begin
+      t:=0.03125*sqr(x)-1; t2:=2*t;
+      b:=0; c:=0;
+      bov:=sizeof(a1) div sizeof(ArbFloat) - 1;
+      for i:=0 to bov do
+        begin
+          a:=t2*c-b+a1[i];
+          if i<bov
+          then
+            begin
+              b:=t2*a-c+b1[i];
+              c:=t2*b-a+c1[i]
+            end
+          else
+          if bov=3   {single}
+          then
+            begin
+              b:=t2*a-c+b1[i];
+              speby1:=(t*b-a+c1[i])*x/8 + spebj1(x)*ln(x)*tbpi - tbpi/x
+            end
+          else
+            speby1:=(t*a-c+b1[i])*x/8 + spebj1(x)*ln(x)*tbpi - tbpi/x
+        end {i}
+    end {x<=8}
+  else
+    begin
+      g:=x-3/(2*tbpi); y:=sqrt(tbpi/x);
+      cx:=cos(g)*y*8/x; sx:=sin(g)*y;
+      t:=128/sqr(x)-1;
+      speby1:=sx*spepol(t, d1[0], sizeof(d1) div sizeof(ArbFloat) - 1)
+            + cx*spepol(t, d2[0], sizeof(d2) div sizeof(ArbFloat) - 1)
+    end {x>8}
+end {speby1};
+
+function speent(x : ArbFloat): longint;
+
+var tx : longint;
+
+begin
+  tx:=trunc(x);
+  if x>=0
+  then
+    speent:=tx
+  else
+    if x=tx
+    then
+      speent:=tx
+    else
+      speent:=tx-1
+end; {speent}
+
+function speerf(x : ArbFloat) : ArbFloat;
+const
+
+        xup = 6.25;
+     sqrtpi = 1.7724538509055160;
+     c : array[1..18] of ArbFloat =
+     ( 1.9449071068178803e0,  4.20186582324414e-2, -1.86866103976769e-2,
+       5.1281061839107e-3,   -1.0683107461726e-3,   1.744737872522e-4,
+      -2.15642065714e-5,      1.7282657974e-6,     -2.00479241e-8,
+      -1.64782105e-8,         2.0008475e-9,         2.57716e-11,
+      -3.06343e-11,           1.9158e-12,           3.703e-13,
+      -5.43e-14,             -4.0e-15,              1.2e-15);
+
+     d : array[1..17] of ArbFloat =
+     ( 1.4831105640848036e0, -3.010710733865950e-1, 6.89948306898316e-2,
+      -1.39162712647222e-2,   2.4207995224335e-3,  -3.658639685849e-4,
+       4.86209844323e-5,     -5.7492565580e-6,      6.113243578e-7,
+      -5.89910153e-8,         5.2070091e-9,        -4.232976e-10,
+       3.18811e-11,          -2.2361e-12,           1.467e-13,
+      -9.0e-15,               5.0e-16);
+
+  var t, s, s1, s2, x2: ArbFloat;
+         bovc, bovd, j: ArbInt;
+begin
+  bovc:=sizeof(c) div sizeof(ArbFloat);
+  bovd:=sizeof(d) div sizeof(ArbFloat);
+  t:=abs(x);
+  if t <= 2
+  then
+    begin
+      x2:=sqr(x)-2;
+      s1:=d[bovd]; s2:=0; j:=bovd-1;
+      s:=x2*s1-s2+d[j];
+      while j > 1 do
+        begin
+          s2:=s1; s1:=s; j:=j-1;
+          s:=x2*s1-s2+d[j]
+        end;
+      speerf:=(s-s2)*x/2
+    end
+  else
+    if t < xup
+    then
+      begin
+        x2:=2-20/(t+3);
+        s1:=c[bovc]; s2:=0; j:=bovc-1;
+        s:=x2*s1-s2+c[j];
+        while j > 1 do
+          begin
+            s2:=s1; s1:=s; j:=j-1;
+            s:=x2*s1-s2+c[j]
+          end;
+        x2:=((s-s2)/(2*t))*exp(-sqr(x))/sqrtpi;
+        speerf:=(1-x2)*spesgn(x)
+      end
+    else
+      speerf:=spesgn(x)
+end;  {speerf}
+
+function spemax(a, b: ArbFloat): ArbFloat;
+begin
+  if a>b
+  then
+    spemax:=a
+  else
+    spemax:=b
+end; {spemax}
+
+function speefc(x : ArbFloat) : ArbFloat;
+const
+
+   xlow = -6.25;
+  xhigh = 27.28;
+      c : array[0..22] of ArbFloat =
+      ( 1.455897212750385e-1, -2.734219314954260e-1,
+        2.260080669166197e-1, -1.635718955239687e-1,
+        1.026043120322792e-1, -5.480232669380236e-2,
+        2.414322397093253e-2, -8.220621168415435e-3,
+        1.802962431316418e-3, -2.553523453642242e-5,
+       -1.524627476123466e-4,  4.789838226695987e-5,
+        3.584014089915968e-6, -6.182369348098529e-6,
+        7.478317101785790e-7,  6.575825478226343e-7,
+       -1.822565715362025e-7, -7.043998994397452e-8,
+        3.026547320064576e-8,  7.532536116142436e-9,
+       -4.066088879757269e-9, -5.718639670776992e-10,
+        3.328130055126039e-10);
+
+  var t, s : ArbFloat;
+begin
+  if x <= xlow
+  then
+    speefc:=2
+  else
+  if x >= xhigh
+  then
+    speefc:=0
+  else
+    begin
+      t:=1-7.5/(abs(x)+3.75);
+      s:=exp(-x*x)*spepol(t, c[0], sizeof(c) div sizeof(ArbFloat) - 1);
+      if x < 0
+      then
+        speefc:=2-s
+      else
+        speefc:=s
+    end
+end {speefc};
+
+function spegam(x: ArbFloat): ArbFloat;
+const
+
+    tmax = 170;
+    a: array[0..23] of ArbFloat =
+    ( 8.86226925452758013e-1,  1.61691987244425092e-2,
+      1.03703363422075456e-1, -1.34118505705967765e-2,
+      9.04033494028101968e-3, -2.42259538436268176e-3,
+      9.15785997288933120e-4, -2.96890121633200000e-4,
+      1.00928148823365120e-4, -3.36375833240268800e-5,
+      1.12524642975590400e-5, -3.75499034136576000e-6,
+      1.25281466396672000e-6, -4.17808776355840000e-7,
+      1.39383522590720000e-7, -4.64774927155200000e-8,
+      1.53835215257600000e-8, -5.11961333760000000e-9,
+      1.82243164160000000e-9, -6.13513953280000000e-10,
+      1.27679856640000000e-10,-4.01499750400000000e-11,
+      4.26560716800000000e-11,-1.46381209600000000e-11);
+
+var tvsmall, t, g: ArbFloat;
+             m, i: ArbInt;
+begin
+  if sizeof(ArbFloat) = 6
+  then
+    tvsmall:=2*midget
+  else
+    tvsmall:=midget;
+  t:=abs(x);
+  if t > tmax
+  then
+    RunError(407);
+  if t < macheps
+  then
+    begin
+      if t < tvsmall
+      then
+        RunError(407);
+      spegam:=1/x
+    end
+  else  { abs(x) >= macheps }
+    begin
+      m:=trunc(x);
+      if x > 0
+      then
+        begin
+          t:=x-m; m:=m-1; g:=1;
+          if m<0
+          then
+            g:=g/x
+          else
+            if m>0
+            then
+              for i:=1 to m do
+                g:=(x-i)*g
+        end
+      else { x < 0 }
+        begin
+          t:=x-m+1;
+          if t=1
+          then
+            RunError(407);
+          m:=1-m;
+          g:=x;
+          for i:=1 to m do
+            g:=(i+x)*g;
+          g:=1/g
+        end;
+      spegam:=spepol(2*t-1, a[0], sizeof(a) div sizeof(ArbFloat) - 1)*g
+    end { abs(x) >= macheps }
+end; {spegam}
+
+function spelga(x: ArbFloat): ArbFloat;
+
+const
+
+    xbig = 7.7e7;
+    xmax = 2.559e305;
+  lnr2pi = 9.18938533204672742e-1;
+    a: array[0..23] of ArbFloat =
+    ( 8.86226925452758013e-1,  1.61691987244425092e-2,
+      1.03703363422075456e-1, -1.34118505705967765e-2,
+      9.04033494028101968e-3, -2.42259538436268176e-3,
+      9.15785997288933120e-4, -2.96890121633200000e-4,
+      1.00928148823365120e-4, -3.36375833240268800e-5,
+      1.12524642975590400e-5, -3.75499034136576000e-6,
+      1.25281466396672000e-6, -4.17808776355840000e-7,
+      1.39383522590720000e-7, -4.64774927155200000e-8,
+      1.53835215257600000e-8, -5.11961333760000000e-9,
+      1.82243164160000000e-9, -6.13513953280000000e-10,
+      1.27679856640000000e-10,-4.01499750400000000e-11,
+      4.26560716800000000e-11,-1.46381209600000000e-11);
+    b: array[0..5] of ArbFloat =
+    ( 8.33271644065786580e-2,  -6.16502049453716986e-6,
+      3.89978899876484712e-9,  -6.45101975779653651e-12,
+      2.00201927337982364e-14, -9.94561064728159347e-17);
+
+
+var t, g : ArbFloat;
+    m, i : ArbInt;
+
+begin
+  if x <= 0
+  then
+    RunError(408);
+  if x <= macheps
+  then
+    spelga:=-ln(x)
+  else
+  if x <= 15
+  then
+    begin
+      m:=trunc(x); t:=x-m; m:=m-1; g:=1;
+      if m < 0
+      then
+        g:=g/x
+      else
+      if m > 0
+      then
+        for i:=1 to m do
+          g:=(x-i)*g;
+      spelga:=ln(g*spepol(2*t-1, a[0], sizeof(a) div sizeof(ArbFloat) - 1))
+    end
+  else { x > 15 }
+  if x <= xbig
+  then
+    spelga:=(x-0.5)*ln(x) - x + lnr2pi
+            + spepol(450/sqr(x)-1, b[0], sizeof(b) div sizeof(ArbFloat) - 1)/x
+  else { x > xbig }
+  if x <= xmax
+  then
+    spelga:=(x-0.5)*ln(x) - x + lnr2pi
+  else  { x > xmax => x*ln(x) > giant }
+    RunError(408)
+end; {spelga}
+
+function spepol(x: ArbFloat; var a: ArbFloat; n: ArbInt): ArbFloat;
+var   pa : ^arfloat0;
+       i : ArbInt;
+    polx : ArbFloat;
+begin
+  pa:=@a;
+  polx:=0;
+  for i:=n downto 0 do
+    polx:=polx*x+pa^[i];
+  spepol:=polx
+end {spepol};
+
+function spepow(a, b: ArbFloat): ArbFloat;
+
+   function PowInt(a: double; n: longint): double;
+   var a1 : double;
+   begin
+     if n=0 then PowInt := 1 else
+     begin
+        a1 := 1;
+        if n<0 then begin a := 1/a; n := -n end;
+        while n>0
+        do if Odd(n)
+           then begin Dec(n); a1 := a1*a end
+           else begin n := n div 2; a := sqr(a) end;
+        PowInt := a1
+     end
+   end;
+
+var tb : longint;
+    fb : double;
+begin
+
+  { (a < 0, b niet geheel) of (a = 0, b <= 0), dan afbreken}
+  if (a=0) then if (b<=0) then RunError(400) else begin SpePow :=0; exit end;
+  tb := Trunc(b); fb := b-tb;
+  if (a<0) and (fb<>0) then RunError(400);
+
+  if a>0
+  then if fb=0 then SpePow := PowInt(a, tb)
+               else SpePow := PowInt(a, tb)*exp(fb*ln(a))
+  else if odd(tb) then Spepow := -PowInt(-a, tb)
+                  else SpePow := PowInt(-a, tb)
+
+end; {spepow}
+
+function spesgn(x: ArbFloat): ArbInt;
+
+begin
+  if x<0
+  then
+    spesgn:=-1
+  else
+    if x=0
+    then
+      spesgn:=0
+    else
+      spesgn:=1
+end; {spesgn}
+
+function spears(x: ArbFloat): ArbFloat;
+const
+
+    pi2 = 1.570796326794897;
+    a : array[0..17] of ArbFloat =
+    (  1.047197551196598e+0, 5.375149359132719e-2, 7.798902238957732e-3,
+       1.519668539582420e-3, 3.408637238430600e-4, 8.302317819598986e-5,
+       2.134554822576075e-5, 5.701781046148566e-6, 1.566985123962741e-6,
+       4.402076871418002e-7, 1.257811162594110e-7, 3.646577948300129e-8,
+       1.081021746966715e-8, 3.212744286269388e-9, 8.515014302985799e-10,
+       2.513296398553196e-10, 1.342121568282535e-10, 4.210346761190271e-11);
+
+var    y, u, t, s : ArbFloat;
+    uprang        : boolean;
+begin
+  if abs(x) > 1
+  then
+    RunError(401);
+  u:=sqr(x); uprang:= u > 0.5;
+  if uprang
+  then
+    u:=1-u;
+  t:=4*u-1; y:=spepol(t, a[0], sizeof(a) div sizeof(ArbFloat) - 1);
+  if uprang
+  then
+    begin
+      s:=pi2-sqrt(u)*y;
+      if x < 0
+      then
+        s:=-s;
+      spears:=s
+    end
+  else
+    spears:=x*y
+end;  {spears}
+
+function spearc(x: ArbFloat): ArbFloat;
+const
+
+    pi2 = 1.570796326794897;
+    a : array[0..17] of ArbFloat =
+    ( 1.047197551196598e+0,  5.375149359132719e-2,  7.798902238957732e-3,
+      1.519668539582420e-3,  3.408637238430600e-4,  8.302317819598986e-5,
+      2.134554822576075e-5,  5.701781046148566e-6,  1.566985123962741e-6,
+      4.402076871418002e-7,  1.257811162594110e-7,  3.646577948300129e-8,
+      1.081021746966715e-8,  3.212744286269388e-9,  8.515014302985799e-10,
+      2.513296398553196e-10, 1.342121568282535e-10, 4.210346761190271e-11);
+
+var u, t, y, s    : ArbFloat;
+    uprang        : boolean;
+begin
+  if abs(x)>1.0
+  then
+    RunError(402);
+  u:=sqr(x); uprang:=u>0.5;
+  if uprang
+  then
+    u:=1-u;
+  t:=4*u-1; y:=spepol(t, a[0], sizeof(a) div sizeof(ArbFloat) - 1);
+  if uprang
+  then
+    begin
+      s:=sqrt(u)*y;
+      if x<0
+      then
+        s:=2*pi2-s;
+      spearc:=s
+    end
+  else
+    spearc:=pi2-x*y
+end;  {spearc}
+
+function spesih(x: ArbFloat): ArbFloat;
+const
+
+    a : array[0..6] of ArbFloat =
+    ( 1.085441641272607e+0,  8.757509762437522e-2,  2.158779361257021e-3,
+      2.549839945498292e-5,  1.761854853281383e-7,  7.980704288665359e-10,
+      2.551377137317034e-12);
+
+var u : ArbFloat;
+begin
+  if abs(x)<=1.0
+  then
+    begin
+      u:=2*sqr(x)-1;
+      spesih:=x*spepol(u, a[0], sizeof(a) div sizeof(ArbFloat) - 1)
+    end
+  else
+  begin
+    u:=exp(x); spesih:=(u-1/u)/2
+  end
+end; {spesih}
+
+function specoh(x: ArbFloat): ArbFloat;
+var u: ArbFloat;
+begin
+  u:=exp(x); specoh:=(u+1/u)/2
+end; {specoh}
+
+function spetah(x: ArbFloat): ArbFloat;
+const
+    xhi = 18.50;
+    a : array[0..15] of ArbFloat =
+    ( 8.610571715805476e-1, -1.158834489728470e-1,  1.918072383973950e-2,
+     -3.225255180728459e-3,  5.433071386922689e-4, -9.154289983175165e-5,
+      1.542469328074432e-5, -2.599022539340038e-6,  4.379282308765732e-7,
+     -7.378980192173815e-8,  1.243517352745986e-8, -2.095373768837420e-9,
+      3.509758916273561e-10,-5.908745181531817e-11, 1.124199312776748e-11,
+     -1.907888434471600e-12);
+
+var t, y: ArbFloat;
+
+begin
+  t:=abs(x);
+  if t <= 1
+  then
+    begin
+      y:=2*sqr(x)-1;
+      spetah:=x*spepol(y, a[0], sizeof(a) div sizeof(ArbFloat) - 1)
+    end
+  else
+  if t < xhi
+  then
+    begin
+      y:=exp(2*x); spetah:=(y-1)/(y+1)
+    end
+  else
+    spetah:=spesgn(x)
+end; {spetah}
+
+function speash(x: ArbFloat): ArbFloat;
+const
+
+    xhi = 1e9;
+    c : array[0..18] of ArbFloat =
+    (  9.312298594527122e-1,  -5.736663926249348e-2,
+       9.004288574881897e-3,  -1.833458667045431e-3,
+       4.230023450529706e-4,  -1.050715136470630e-4,
+       2.740790473603819e-5,  -7.402952157663977e-6,
+       2.052474396638805e-6,  -5.807433412373489e-7,
+       1.670117348345774e-7,  -4.863477336087045e-8,
+       1.432753532351304e-8,  -4.319978113584910e-9,
+       1.299779213740398e-9,  -3.394726871170490e-10,
+       1.008344962167889e-10, -5.731943029121004e-11,
+       1.810792296549804e-11);
+
+
+var t : ArbFloat;
+
+begin
+  t:=abs(x);
+  if t <= 1 then
+    speash:=x*spepol(2*sqr(x)-1, c[0], sizeof(c) div sizeof(ArbFloat) - 1)
+  else
+  if t < xhi then
+    speash:=ln(sqrt(sqr(x)+1)+t)*spesgn(x)
+  else
+    speash:=ln(2*t)*spesgn(x)
+end; {speash}
+
+function speach(x: ArbFloat): ArbFloat;
+const
+
+    xhi = 1e9;
+
+begin
+  if x<1 then
+    RunError(405);
+  if x=1 then
+    speach:=0
+  else
+  if x<=xhi then
+    speach:=ln(x+sqrt(sqr(x)-1))
+  else
+    speach:=ln(2*x)
+end; {speach}
+
+function speath(x: ArbFloat): ArbFloat;
+const
+
+    c : array[0..19] of ArbFloat =
+    ( 1.098612288668110e+0,  1.173605223326117e-1,  2.309071936165689e-2,
+      5.449091889986991e-3,  1.404884102286929e-3,  3.816948426588058e-4,
+      1.073604335435426e-4,  3.095027782918129e-5,  9.088050814470148e-6,
+      2.706881064641104e-6,  8.155200644023077e-7,  2.479830612463254e-7,
+      7.588067811453948e-8,  2.339295963220429e-8,  7.408486568719348e-9,
+      2.319454882064018e-9,  5.960921368486746e-10, 1.820410351379402e-10,
+      1.184977617320312e-10, 3.856235316559190e-11);
+
+var t, u: ArbFloat;
+begin
+  t:=abs(x);
+  if t >= 1 then
+    RunError(406);
+  u:=sqr(x);
+  if u < 0.5 then
+    speath:=x*spepol(4*u-1, c[0], sizeof(c) div sizeof(ArbFloat) - 1)
+  else { 0.5 < x*x < 1 }
+    speath:=ln((1+t)/(1-t))/2*spesgn(x)
+end; {speath}
+
+var exitsave : pointer;
+
+procedure MyExit; Far;
+const ErrorS : array[400..408,1..6] of char =
+     ('spepow',
+      'spebk0',
+      'spebk1',
+      'speby0',
+      'speby1',
+      'speach',
+      'speath',
+      'spegam',
+      'spelga');
+
+var ErrFil : text;
+
+begin
+     ExitProc := ExitSave;
+     Assign(ErrFil, 'CON');
+     ReWrite(ErrFil);
+     if (ExitCode>=400) AND (ExitCode<=408) then
+       begin
+         write(ErrFil, 'critical error in ', ErrorS[ExitCode]);
+         ExitCode := 201
+       end;
+     Close(ErrFil)
+end;
+
+begin
+   ExitSave := ExitProc;
+   ExitProc := @MyExit;
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/spl.pas

@@ -0,0 +1,1122 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    Undocumented unit. B- and other Splines. Not imported by the other units
+    afaik.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit spl;
+{$I direct.inc}
+
+interface
+
+uses typ, sle;
+
+function  spl1bspv(q: ArbInt; var kmin1, c1: ArbFloat; x: ArbFloat; var term: ArbInt): ArbFloat;
+function  spl2bspv(qx, qy: ArbInt; var kxmin1, kymin1, c11: ArbFloat; x, y: ArbFloat; var term: ArbInt): ArbFloat;
+procedure spl1bspf(M, Q: ArbInt; var XYW1: ArbFloat;
+                 var Kmin1, C1, residu: ArbFloat;
+                 var term: ArbInt);
+procedure spl2bspf(M, Qx, Qy: ArbInt; var XYZW1: ArbFloat;
+                 var Kxmin1, Kymin1, C11, residu: ArbFloat;
+                 var term: ArbInt);
+procedure spl1nati(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
+procedure spl1naki(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
+procedure spl1cmpi(n: ArbInt; var xyc1: ArbFloat; dy1, dyn: ArbFloat;
+                 var term: ArbInt);
+procedure spl1peri(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
+function  spl1pprv(n: ArbInt; var xyc1: ArbFloat; t: ArbFloat; var term: ArbInt): ArbFloat;
+
+procedure spl1nalf(n: ArbInt; var xyw1: ArbFloat; lambda:ArbFloat;
+                     var xac1, residu: ArbFloat; var term: ArbInt);
+function spl2natv(n: ArbInt; var xyg0: ArbFloat; u, v: ArbFloat): ArbFloat;
+procedure spl2nalf(n: ArbInt; var xyzw1: ArbFloat; lambda:ArbFloat;
+                     var xyg0, residu: ArbFloat; var term: ArbInt);
+      { term = 1: succes,
+        term = 2: set linear equations is not "PD"
+        term = 4: Approx. number of points? On a line.
+        term = 3: wrong input n<3 or a weight turned out to be <=0 }
+implementation
+
+type
+    Krec = record K1, K2, K3, K4, K5, K6 : ArbFloat end;
+
+function spl1bspv(q: ArbInt; var kmin1, c1: ArbFloat; x: ArbFloat; var term: ArbInt): ArbFloat;
+var c    : arfloat1 absolute c1;
+    k    : arfloat_1 absolute kmin1;
+    D1, D2, D3,
+    E2, E3, E4, E5: ArbFloat;
+    pk   : ^Krec;
+    l, r, m : ArbInt;
+begin
+    spl1bspv := NaN;
+    term := 3;                           { q >=4 !     }
+    if q<4 then exit;                    { at least 1 interval   }
+    if (x<k[2]) or (x>k[q-1]) then exit; { x inside the interval }
+    term := 1;                           { Let's hope the params are good :-)}
+    l := 2; r := q-1;
+    while l+1<r do                       { after this loop goes: }
+     begin                                { k[l]<=x<=k[l+1] with  }
+      m := (l+r) div 2;                {   k[l] < k[l+1]       }
+      if x>=k[m] then l := m else r := m
+     end;
+    pk := @k[l-2];                       { the (de) Boor algoritm ..  }
+    with pk^ do
+     begin
+      E2 := X - K2; E3 := X - K3; E4 := K4 - X; E5 := K5 - X;
+      D2 := C[l]; D3 := C[l+1];
+      D1 := ((X-K1)*D2+E4*C[l-1])/(K4-K1);
+      D2 := (E2*D3+E5*D2)/(K5-K2);
+      D3 := (E3*C[l+2]+(K6-X)*D3)/(K6-K3);
+      D1 := (E2*D2+E4*D1)/(K4-K2);
+      D2 := (E3*D3+E5*D2)/(K5-K3);
+      spl1bspv := (E3*D2+E4*D1)/(K4-K3)
+    end;
+end;
+
+function  spl2bspv(qx, qy: ArbInt; var kxmin1, kymin1, c11: ArbFloat; x, y: ArbFloat; var term: ArbInt): ArbFloat;
+var  pd: ^arfloat1;
+  i, iy: ArbInt;
+      c: arfloat1 absolute c11;
+begin
+    GetMem(pd, qx*SizeOf(ArbFloat));
+    i := 0;
+    iy := 1;
+    repeat
+        i := i + 1;
+        pd^[i] := spl1bspv(qy, kymin1, c[iy], y, term);
+        Inc(iy, qy)
+    until (i=qx) or (term<>1);
+    if term=1
+    then spl2bspv := spl1bspv(qx, kxmin1, pd^[1], x, term)
+    else spl2bspv := NaN;
+    FreeMem(pd, qx*SizeOf(ArbFloat));
+end;
+
+(*  Bron: NAG LIBRARY SUBROUTINE  E02BAF *)
+
+function Imin(x, y: ArbInt): ArbInt;
+begin if x<y then Imin := x else Imin := y end;
+
+type ar4 = array[1..$ffe0 div (4*SizeOf(ArbFloat)),1..4] of ArbFloat;
+     ar3 = array[1..$ffe0 div (3*SizeOf(ArbFloat)),1..3] of ArbFloat;
+     r_3 = record x, y, w: ArbFloat end;
+     r3Ar= array[1..$ffe0 div SizeOf(r_3)] of r_3;
+     r_4 = record x, y, z, w: ArbFloat end;
+     r4Ar= array[1..$ffe0 div SizeOf(r_4)] of r_4;
+     r4  = array[1..4] of ArbFloat;
+     r2  = array[1..2] of ArbFloat;
+
+     r4x  = record xy: R2; alfa, d: ArbFloat end;
+     r4xAr= array[1..$ffe0 div SizeOf(r4x)] of r4x;
+     nsp2rec = array[0..$ff80 div (3*SizeOf(ArbFloat))] of
+               record xy: R2; gamma: ArbFloat end;
+
+procedure spl1bspf(M, Q: ArbInt; var XYW1: ArbFloat;
+                 var Kmin1, C1, residu: ArbFloat;
+                 var term: ArbInt);
+var work1: ^arfloat1;
+    work2: ^ar4;
+    c    : arfloat1 absolute c1;
+    k    : arfloat_1 absolute kmin1;
+    xyw  : r3Ar absolute XYW1;
+    r, j, jmax, l, lplus1, i, iplusj, jold, jrev,
+    jplusl, iu, lplusu : ArbInt;
+    s, k0, k4, sigma,
+    d, d4, d5, d6, d7, d8, d9,
+    e2, e3, e4, e5,
+    n1, n2, n3,
+    relemt, dprime, cosine, sine,
+    acol, arow, crow, ccol, ss     : ArbFloat;
+    pk   : ^Krec;
+
+label einde;
+(*
+      DOUBLE PRECISION  C(NCAP7), K(NCAP7), W(M), WORK1(M),
+     *                  WORK2(4,NCAP7), X(M), Y(M)
+     .. Local Scalars ..
+      DOUBLE PRECISION  ACOL, AROW, CCOL, COSINE, CROW, D, D4, D5, D6,
+     *                  D7, D8, D9, DPRIME, E2, E3, E4, E5, K0, K1, K2,
+     *                  K3, K4, K5, K6, N1, N2, N3, RELEMT, S, SIGMA,
+     *                  SINE, WI, XI
+      INTEGER           I, IERROR, IPLUSJ, IU, J, JOLD, JPLUSL, JREV, L,
+     *                  L4, LPLUS1, LPLUSU, NCAP, NCAP3, NCAPM1, R
+*)
+begin
+    term := 3;
+    if q<4 then exit;
+    if m<q then exit;
+(*
+     CHECK THAT THE VALUES OF  M  AND  NCAP7  ARE REASONABLE
+      IF (NCAP7.LT.8 .OR. M.LT.NCAP7-4) GO TO 420
+      NCAP = NCAP7 - 7
+      NCAPM1 = NCAP - 1
+      NCAP3 = NCAP + 3
+
+     IN ORDER TO DEFINE THE FULL B-SPLINE BASIS, AUGMENT THE
+     PRESCRIBED INTERIOR KNOTS BY KNOTS OF MULTIPLICITY FOUR
+     AT EACH END OF THE DATA RANGE.
+
+*)
+    for j:=-1 to 2 do k[j] := xyw[1].x;
+    for j:=q-1 to q+2 do k[j] := xyw[m].x;
+
+    if (k[3]<=xyw[1].x) or (k[q-2]>=xyw[m].x) then exit;
+(*
+     CHECK THAT THE KNOTS ARE ORDERED AND ARE INTERIOR
+     TO THE DATA INTERVAL.
+*)
+    j := 3; while (k[j]<=k[j+1]) and (j<q-2) do Inc(j);
+    if j<q-2 then exit;
+(*
+     CHECK THAT THE WEIGHTS ARE STRICTLY POSITIVE.
+*)
+    j := 1;
+    while (xyw[j].w>0) and (j<m) do Inc(j);
+    if xyw[j].w<=0 then exit;
+(*
+     CHECK THAT THE DATA ABSCISSAE ARE ORDERED, THEN FORM THE
+     ARRAY  WORK1  FROM THE ARRAY  X.  THE ARRAY  WORK1  CONTAINS
+     THE
+     SET OF DISTINCT DATA ABSCISSAE.
+*)
+    GetMem(Work1, m*SizeOf(ArbFloat));
+    GetMem(Work2, q*4*SizeOf(ArbFloat));
+    r := 1; work1^[1] := xyw[1].x;
+    j := 1;
+    while (j<m) do
+    begin
+       Inc(j);
+       if xyw[j].x>work1^[r]
+       then begin Inc(r); work1^[r] := xyw[j].x end
+       else if xyw[j].x<work1^[r] then goto einde;
+    end;
+    if r<q then goto einde;
+
+(*
+     CHECK THE FIRST  S  AND THE LAST  S  SCHOENBERG-WHITNEY
+     CONDITIONS ( S = MIN(NCAP - 1, 4) ).
+*)
+    jmax := Imin(q-4,4);
+    j := 1;
+    while (j<=jmax) do
+    begin
+      if (work1^[j]>=k[j+2]) or (k[q-j-1]>=work1^[r-j+1]) then goto einde;
+      Inc(j)
+    end;
+(*
+     CHECK ALL THE REMAINING SCHOENBERG-WHITNEY CONDITIONS.
+*)
+    Dec(r, 4); i := 4; j := 5;
+    while j<=q-4 do
+    begin
+       K0 := K[j+2]; K4 := K[J-2];
+       repeat Inc(i) until (Work1^[i]>k4);
+       if (I>R) or (WORK1^[I]>=K0) then goto einde;
+       Inc(j)
+    end;
+
+(*
+     INITIALISE A BAND TRIANGULAR SYSTEM (I.E. A
+     MATRIX AND A RIGHT HAND SIDE) TO ZERO. THE
+     PROCESSING OF EACH DATA POINT IN TURN RESULTS
+     IN AN UPDATING OF THIS SYSTEM. THE SUBSEQUENT
+     SOLUTION OF THE RESULTING BAND TRIANGULAR SYSTEM
+     YIELDS THE COEFFICIENTS OF THE B-SPLINES.
+*)
+    FillChar(Work2^, q*4*SizeOf(ArbFloat), 0);
+    FillChar(c, q*SizeOf(ArbFloat), 0);
+
+    SIGMA := 0; j := 0; jold := 0;
+    for i:=1 to m do
+    with xyw[i] do
+    begin
+(*
+        FOR THE DATA POINT  (X(I), Y(I))  DETERMINE AN INTERVAL
+        K(J + 3) .LE. X .LT. K(J + 4)  CONTAINING  X(I).  (IN THE
+        CASE  J + 4 .EQ. NCAP  THE SECOND EQUALITY IS RELAXED TO
+        INCLUDE
+        EQUALITY).
+*)
+       while (x>=k[j+2]) and (j<=q-4) do Inc(j);
+       if j<>jold then
+       begin
+         pk := @k[j-1];
+         with pk^ do
+         begin
+             D4 := 1/(K4-K1); D5 := 1/(K5-K2); D6 := 1/(K6-K3);
+             D7 := 1/(K4-K2); D8 := 1/(K5-K3); D9 := 1/(K4-K3)
+         end;
+         JOLD := J;
+       end;
+(*
+        COMPUTE AND STORE IN  WORK1(L) (L = 1, 2, 3, 4)  THE VALUES
+        OF
+        THE FOUR NORMALIZED CUBIC B-SPLINES WHICH ARE NON-ZERO AT
+        X=X(I).
+*)     with pk^ do
+       begin
+           E5 := k5 - X;
+           E4 := K4 - X;
+           E3 := X - K3;
+           E2 := X - K2;
+           N1 := W*D9;
+           N2 := E3*N1*D8;
+           N1 := E4*N1*D7;
+           N3 := E3*N2*D6;
+           N2 := (E2*N1+E5*N2)*D5;
+           N1 := E4*N1*D4;
+           WORK1^[4] := E3*N3;
+           WORK1^[3] := E2*N2 + (K6-X)*N3;
+           WORK1^[2] := (X-K1)*N1 + E5*N2;
+           WORK1^[1] := E4*N1;
+           CROW := Y*W;
+       end;
+(*
+        ROTATE THIS ROW INTO THE BAND TRIANGULAR SYSTEM USING PLANE
+        ROTATIONS.
+*)
+       for lplus1:=1 to 4 do
+       begin L := LPLUS1 - 1;
+          RELEMT := WORK1^[LPLUS1];
+          if relemt<>0 then
+          begin JPLUSL := J + L;
+            D := WORK2^[JPLUSL,1];
+            IF (ABS(RELEMT)>=D)
+            then DPRIME := ABS(RELEMT)*SQRT(1+sqr(D/RELEMT))
+            else DPRIME := D*SQRT(1+sqr(RELEMT/D));
+            WORK2^[JPLUSL,1] := DPRIME;
+            COSINE := D/DPRIME; SINE := RELEMT/DPRIME;
+            for iu :=2 to 4-l do
+            begin
+               LPLUSU := L + IU;
+               ACOL := WORK2^[JPLUSL,iu];
+               AROW := WORK1^[LPLUSU];
+               WORK2^[JPLUSL,iu] := COSINE*ACOL + SINE*AROW;
+               WORK1^[LPLUSU] := COSINE*AROW - SINE*ACOL
+            end;
+
+            CCOL := C[JPLUSL];
+            C[JPLUSL] := COSINE*CCOL + SINE*CROW;
+            CROW := COSINE*CROW - SINE*CCOL
+          end;
+       end;
+       SIGMA := SIGMA + sqr(CROW)
+   end;
+
+   residu := SIGMA;
+(*
+     SOLVE THE BAND TRIANGULAR SYSTEM FOR THE B-SPLINE
+     COEFFICIENTS. IF A DIAGONAL ELEMENT IS ZERO, AND HENCE
+     THE TRIANGULAR SYSTEM IS SINGULAR, THE IMPLICATION IS
+     THAT THE SCHOENBERG-WHITNEY CONDITIONS ARE ONLY JUST
+     SATISFIED. THUS IT IS APPROPRIATE TO EXIT IN THIS
+     CASE WITH THE SAME VALUE  (IFAIL=5)  OF THE ERROR
+     INDICATOR.
+*)
+    term := 2;
+    L := -1;
+    for jrev:=1 to q do
+    begin
+       J := q - JREV + 1; D := WORK2^[J,1];
+       if d=0 then goto einde;
+       IF l<3 then L := L + 1;
+       S := C[j];
+       for i:=1 to l do
+       begin
+         IPLUSJ := I + J;
+         S := S - WORK2^[j,i+1]*C[IPLUSJ];
+       end;
+       C[J] := S/D
+    end;
+
+    term:=1;
+einde:
+    FreeMem(Work2, q*4*SizeOf(ArbFloat));
+    FreeMem(Work1, m*SizeOf(ArbFloat))
+
+end;
+
+procedure spl2bspf(M, Qx, Qy: ArbInt; var XYZW1: ArbFloat;
+                 var Kxmin1, Kymin1, C11, residu: ArbFloat;
+                 var term: ArbInt);
+
+(* !!!!!!!! Test input !!!!!!!!!! *)
+
+(*
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c part 1: determination of the number of knots and their position.     c
+c ****************************************************************     c
+c given a set of knots we compute the least-squares spline sinf(x,y),  c
+c and the corresponding weighted sum of squared residuals fp=f(p=inf). c
+c if iopt=-1  sinf(x,y) is the requested approximation.                c
+c if iopt=0 or iopt=1 we check whether we can accept the knots:        c
+c   if fp <=s we will continue with the current set of knots.          c
+c   if fp > s we will increase the number of knots and compute the     c
+c      corresponding least-squares spline until finally  fp<=s.        c
+c the initial choice of knots depends on the value of s and iopt.      c
+c   if iopt=0 we first compute the least-squares polynomial of degree  c
+c     3 in x and 3 in y; nx=nminx=2*3+2 and ny=nminy=2*3+2.            c
+c     fp0=f(0) denotes the corresponding weighted sum of squared       c
+c     residuals                                                        c
+c   if iopt=1 we start with the knots found at the last call of the    c
+c     routine, except for the case that s>=fp0; then we can compute    c
+c     the least-squares polynomial directly.                           c
+c eventually the independent variables x and y (and the corresponding  c
+c parameters) will be switched if this can reduce the bandwidth of the c
+c system to be solved.                                                 c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc *)
+
+function Min(a, b:ArbInt): ArbInt;
+begin if a<b then Min := a else Min := b end;
+
+procedure WisselR(var x, y: ArbFloat);
+var h: ArbFloat; begin h := x; x := y; y := h end;
+
+procedure Wisseli(var x, y: ArbInt);
+var h: ArbInt; begin h := x; x := y; y := h end;
+
+procedure fprota(var cos1, sin1, a, b: ArbFloat);
+var store: ArbFloat;
+begin
+    store := b; b := cos1*b+sin1*a; a := cos1*a-sin1*store
+end;
+
+procedure fpgivs(var piv, ww, cos1, sin1: ArbFloat);
+var store, dd: ArbFloat;
+begin
+   store := abs(piv);
+   if store>=ww
+   then dd := store*sqrt(1+sqr(ww/piv))
+   else dd := ww*sqrt(1+sqr(piv/ww));
+   cos1 := ww/dd; sin1 := piv/dd; ww := dd
+end;
+
+procedure fpback(var a11, z1: ArbFloat; n, k: ArbInt; var c1: ArbFloat);
+(*
+   subroutine fpback calculates the solution of the system of
+   equations a*c = z with a a n x n upper triangular matrix
+   of bandwidth k.
+   ArbFloat a(.,k)
+*)
+var a: arfloat1 absolute a11;
+    z: arfloat1 absolute z1;
+    c: arfloat1 absolute c1;
+    i, l: ArbInt;
+    store : ArbFloat;
+begin
+    for i:=n downto 1 do
+    begin
+       store := z[i];
+       for l:=min(n+1-i,k)-1 downto 1 do store := store-c[i+l]*a[(i-1)*k+l+1];
+       c[i] := store/a[(i-1)*k+1]
+    end;
+end;
+
+procedure fpbspl(var kmin1: ArbFloat; x: ArbFloat; l: ArbInt; var h: r4);
+(*
+   subroutine fpbspl evaluates the 4 non-zero b-splines of
+   degree 3 at t(l) <= x < t(l+1) using the stable recurrence
+   relation of de boor and cox.
+*)
+var k : arfloat_1 absolute kmin1;
+    f : ArbFloat;
+    hh: array[1..3] of ArbFloat;
+    i, j, li, lj : ArbInt;
+begin
+    h[1] := 1;
+    for j:=1 to 3 do
+    begin
+       for i:=1 to j do hh[i] := h[i];
+       h[1] := 0;
+       for i:=1 to j do
+       begin
+          li := l+i; lj := li-j;
+          f := hh[i]/(k[li]-k[lj]);
+          h[i] := h[i]+f*(k[li]-x);
+          h[i+1] := f*(x-k[lj])
+       end;
+    end;
+end;
+
+procedure fporde(m, qx, qy: ArbInt; var xyzw1, kxmin1, kymin1: ArbFloat;
+                 var nummer1, index1: ArbInt);
+var xi, yi : ArbFloat;
+    i, im, num,
+    k, l   : ArbInt;
+    xyzw   : r4Ar absolute xyzw1;
+    kx     : arfloat_1 absolute kxmin1;
+    ky     : arfloat_1 absolute kymin1;
+    nummer : arint1 absolute nummer1;
+    index  : arint1 absolute index1;
+begin
+   for i:=1 to (qx-3)*(qy-3) do index[i] := 0;
+   for im:=1 to m do
+   with xyzw[im] do
+   begin
+     l := 2; while (x>=kx[l+1]) and (l<qx-2) do Inc(l);
+     k := 2; while (y>=ky[k+1]) and (k<qy-2) do Inc(k);
+     num := (l-2)*(qy-3)+k-1;
+     nummer[im] := index[num]; index[num] := im
+   end;
+end;
+
+label einde;
+
+var x0, x1, y0, y1, eps, cos1, sin1, dmax, sigma,
+    wi, zi, hxi, piv    : ArbFloat;
+    i, j, l, l1, l2, lx, ly, nreg, ncof, jrot,
+    inpanel, i1, j1,
+    iband, num, irot    : ArbInt;
+    xyzw                : r4Ar absolute xyzw1;
+    kx, ky              : ^arfloat_1;
+    a, f, h             : ^arfloat1;
+    c                   : arfloat1 absolute c11;
+    nummer, index       : ^arint1;
+    hx, hy              : r4;
+    ichang, fullrank    : boolean;
+begin
+
+    eps := 10*macheps;
+(*  find the position of the additional knots which are needed for the
+  b-spline representation of s(x,y) *)
+    iband := 1+min(3*qy+3,3*qx+3);
+    if qy>qx then
+    begin
+       ichang := true;
+       kx := @kymin1; ky := @kxmin1;
+       for i:=1 to m do with xyzw[i] do Wisselr(x, y);
+       WisselI(qx, qy)
+    end else
+    begin
+       ichang := false;
+       kx := @kxmin1; ky := @kymin1;
+    end;
+    with xyzw[1] do begin x0 := x; x1 := x; y0 := y; y1 := y end;
+    for i:=2 to m do with xyzw[i] do
+    begin if x<x0 then x0 := x; if x>x1 then x1 := x;
+          if y<y0 then y0 := y; if y>y1 then y1 := y
+    end;
+    for i:=-1 to 2 do kx^[i] := x0;
+    for i:=-1 to 2 do ky^[i] := y0;
+    for i:=qx-1 to qx+2 do kx^[i] := x1;
+    for i:=qy-1 to qy+2 do ky^[i] := y1;
+(*  arrange the data points according to the panel they belong to *)
+    nreg := (qx-3)*(qy-3);
+    ncof := qx*qy;
+    GetMem(nummer, m*SizeOf(ArbInt));
+    GetMem(index, nreg*SizeOf(ArbInt));
+    GetMem(h, iband*SizeOf(ArbFloat));
+    GetMem(a, iband*ncof*SizeOf(ArbFloat));
+    GetMem(f, ncof*SizeOf(ArbFloat));
+    fporde(m, qx, qy, xyzw1, kx^[-1], ky^[-1], nummer^[1], index^[1]);
+    for i:=1 to ncof do f^[i] := 0;
+    for j:=1 to ncof*iband do a^[j] := 0;
+    residu := 0;
+(*  fetch the data points in the new order. main loop for the different panels *)
+    for num:=1 to nreg do
+    begin
+       lx := (num-1) div (qy-3); l1 := lx+2;
+       ly := (num-1) mod (qy-3); l2 := ly+2;
+       jrot := lx*qy+ly;
+       inpanel := index^[num];
+       while inpanel<>0 do
+       with xyzw[inpanel] do
+       begin
+          wi := w; zi := z*wi;
+          fpbspl(kx^[-1], x, l1, hx);
+          fpbspl(ky^[-1], y, l2, hy);
+          for i:=1 to iband do h^[i] := 0;
+          i1 := 0;
+          for i:=1 to 4 do
+          begin
+            hxi := hx[i]; j1 := i1;
+            for j:=1 to 4 do begin Inc(j1); h^[j1] := hxi*hy[j]*wi end;
+            Inc(i1, qy)
+          end;
+          irot := jrot;
+          for i:=1 to iband do
+          begin
+            Inc(irot); piv := h^[i];
+            if piv<>0 then
+            begin
+              fpgivs(piv, a^[(irot-1)*iband+1], cos1, sin1);
+              fprota(cos1, sin1, zi, f^[irot]);
+              for j:=i+1 to iband do
+                fprota(cos1, sin1, h^[j], a^[(irot-1)*iband+j-i+1])
+            end;
+          end;
+          residu := residu+sqr(zi);
+          inpanel := nummer^[inpanel]
+      end;
+   end;
+
+   dmax := 0;
+   i := 1;
+   while i<ncof*iband do
+   begin
+      if dmax<a^[i] then dmax:=a^[i]; Inc(i, iband)
+   end;
+
+   sigma := eps*dmax;
+   i := 1; fullrank := true;
+   while fullrank and (i<ncof*iband) do
+   begin
+      fullrank := a^[i]>sigma; Inc(i, iband)
+   end;
+
+   term := 2; if not fullrank then goto einde;
+   term := 1;
+
+   fpback(a^[1], f^[1], ncof, iband, c11);
+   if ichang then
+   begin
+      l1 := 1;
+      for i:=1 to qx do
+      begin
+        l2 := i;
+        for j:=1 to qy do
+        begin
+          f^[l2] := c[l1]; Inc(l1); Inc(l2, qx)
+        end;
+      end;
+      for i:=1 to ncof do c[i] := f^[i]
+   end;
+
+einde:
+   if ichang then for i:=1 to m do with xyzw[i] do Wisselr(x, y);
+   FreeMem(f, ncof*SizeOf(ArbFloat));
+   FreeMem(a, iband*ncof*SizeOf(ArbFloat));
+   FreeMem(h, iband*SizeOf(ArbFloat));
+   FreeMem(index, nreg*SizeOf(ArbInt));
+   FreeMem(nummer, m*SizeOf(ArbInt))
+end;
+
+
+procedure spl1nati(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
+var
+    xyc           : r3Ar absolute XYC1;
+    l, b, d, u, c : ^arfloat1;
+    h2, h3, s2, s3: ArbFloat;
+    i, m          : ArbInt;       { afmeting van op te lossen stelsel }
+begin
+    term:=3;
+    if n < 2 then exit;
+    for i:=2 to n do if xyc[i-1].x>=xyc[i].x then exit;
+    term:=1;
+    xyc[1].w := 0; xyc[n].w := 0;  { c1=cn=0 }
+    m := n-2;
+    if m=0 then exit;
+
+    getmem(u, n*SizeOf(ArbFloat));
+    getmem(l, n*Sizeof(ArbFloat));
+    getmem(d, n*SizeOf(ArbFloat));
+    getmem(c, n*SizeOf(ArbFloat));
+    getmem(b, n*SizeOf(ArbFloat));
+    h3:=xyc[2].x-xyc[1].x;
+    s3:=(xyc[2].y-xyc[1].y)/h3;
+
+    for i:=2 to n-1 do
+    begin
+      h2:=h3; h3:=xyc[i+1].x-xyc[i].x;
+      s2:=s3; s3:=(xyc[i+1].y-xyc[i].y)/h3;
+      l^[i]:=h2/6;
+      d^[i]:=(h2+h3)/3;
+      u^[i]:=h3/6;
+      b^[i]:=s3-s2
+    end;
+    sledtr(m, l^[3], d^[2], u^[2], b^[2], c^[2], term);
+    for i:=2 to n-1 do xyc[i].w := c^[i];
+    Freemem(b, n*SizeOf(ArbFloat));
+    Freemem(c, n*SizeOf(ArbFloat));
+    Freemem(d, n*SizeOf(ArbFloat));
+    Freemem(l, n*Sizeof(ArbFloat));
+    Freemem(u, n*SizeOf(ArbFloat));
+end; {spl1nati}
+
+procedure spl1naki(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
+var
+    xyc           : r3Ar absolute XYC1;
+    l, b, d, u, c : ^arfloat1;
+    h2, h3, s2, s3: ArbFloat;
+    i, m          : ArbInt;       { Dimensions of set lin eqs to solve}
+begin
+    term:=3;
+    if n < 4 then exit;
+    for i:=2 to n do if xyc[i-1].x>=xyc[i].x then exit;
+    term:=1;
+    m := n-2;
+    getmem(u, n*SizeOf(ArbFloat));
+    getmem(l, n*Sizeof(ArbFloat));
+    getmem(d, n*SizeOf(ArbFloat));
+    getmem(c, n*SizeOf(ArbFloat));
+    getmem(b, n*SizeOf(ArbFloat));
+    h3:=xyc[2].x-xyc[1].x;
+    s3:=(xyc[2].y-xyc[1].y)/h3;
+    for i:=2 to n-1 do
+    begin
+      h2:=h3; h3:=xyc[i+1].x-xyc[i].x;
+      s2:=s3; s3:=(xyc[i+1].y-xyc[i].y)/h3;
+      l^[i]:=h2/6;
+      d^[i]:=(h2+h3)/3;
+      u^[i]:=h3/6;
+      b^[i]:=s3-s2
+    end;
+    d^[n-1]:=d^[n-1]+h3/6*(1+h3/h2); l^[n-1]:=l^[n-1]-sqr(h3)/(6*h2);
+    h2:=xyc[2].x-xyc[1].x; h3:=xyc[3].x-xyc[2].x;
+    d^[2]:=d^[2]+h2/6*(1+h2/h3); u^[2]:=u^[2]-sqr(h2)/(6*h3);
+
+    sledtr(m, l^[3], d^[2], u^[2], b^[2], c^[2], term);
+    for i:=2 to n-1 do xyc[i].w := c^[i];
+    xyc[1].w := xyc[2].w + (h2/h3)*(xyc[2].w-xyc[3].w);
+    h2:=xyc[n-1].x-xyc[n-2].x; h3:=xyc[n].x-xyc[n-1].x;
+    xyc[n].w := xyc[n-1].w + (h3/h2)*(xyc[n-1].w-xyc[n-2].w);
+    Freemem(b, n*SizeOf(ArbFloat));
+    Freemem(c, n*SizeOf(ArbFloat));
+    Freemem(d, n*SizeOf(ArbFloat));
+    Freemem(l, n*Sizeof(ArbFloat));
+    Freemem(u, n*SizeOf(ArbFloat));
+end; {spl1naki}
+
+procedure spl1cmpi(n: ArbInt; var xyc1: ArbFloat; dy1, dyn: ArbFloat;
+                 var term: ArbInt);
+var
+    xyc           : r3Ar absolute XYC1;
+    l, b, d, u, c : ^arfloat1;
+    h2, h3, s2, s3: ArbFloat;
+    i             : ArbInt;     { Dimensions of set lin eqs to solve}
+begin
+    term:=3;
+    if n < 2 then exit;
+    for i:=2 to n do if xyc[i-1].x>=xyc[i].x then exit;
+    term:=1;
+    getmem(u, n*SizeOf(ArbFloat));
+    getmem(l, n*Sizeof(ArbFloat));
+    getmem(d, n*SizeOf(ArbFloat));
+    getmem(c, n*SizeOf(ArbFloat));
+    getmem(b, n*SizeOf(ArbFloat));
+    h3:=xyc[2].x-xyc[1].x;
+    s3:=(xyc[2].y-xyc[1].y)/h3;
+    d^[1] := h3/3; u^[1] := h3/6; b^[1] := -dy1+s3;
+    for i:=2 to n-1 do
+    begin
+      h2:=h3; h3:=xyc[i+1].x-xyc[i].x;
+      s2:=s3; s3:=(xyc[i+1].y-xyc[i].y)/h3;
+      l^[i]:=h2/6;
+      d^[i]:=(h2+h3)/3;
+      u^[i]:=h3/6;
+      b^[i]:=s3-s2
+    end;
+    d^[n] := h3/3; l^[n] := h3/6; b^[n] := dyn-s3;
+
+    sledtr(n, l^[2], d^[1], u^[1], b^[1], c^[1], term);
+    for i:=1 to n do xyc[i].w := c^[i];
+    Freemem(b, n*SizeOf(ArbFloat));
+    Freemem(c, n*SizeOf(ArbFloat));
+    Freemem(d, n*SizeOf(ArbFloat));
+    Freemem(l, n*Sizeof(ArbFloat));
+    Freemem(u, n*SizeOf(ArbFloat));
+end; {spl1cmpi}
+
+procedure spl1peri(n: ArbInt; var xyc1: ArbFloat; var term: ArbInt);
+var
+    xyc           : r3Ar absolute XYC1;
+    l, b, d, u, c, k : ^arfloat1;
+    k2, kn1, dy1, cn,
+    h2, h3, s2, s3: ArbFloat;
+    i, m          : ArbInt;             { Dimensions of set lin eqs to solve}
+begin
+    term:=3;
+    if n < 2 then exit;
+    if xyc[1].y<>xyc[n].y then exit;
+    for i:=2 to n do if xyc[i-1].x>=xyc[i].x then exit;
+    term:=1;
+    m := n-2;
+    xyc[1].w := 0; xyc[n].w := 0;  { c1=cn=0 }
+    if m=0 then exit;
+    if m=1 then
+    begin
+       h2:=xyc[2].x-xyc[1].x;
+       s2:=(xyc[2].y-xyc[1].y)/h2;
+       h3:=xyc[3].x-xyc[2].x;
+       s3:=(xyc[3].y-xyc[2].y)/h3;
+       xyc[2].w := 6*(s3-s2)/(h2+h3);
+       xyc[3].w := -xyc[2].w;
+       xyc[1].w := xyc[3].w;
+       exit
+    end;
+
+    getmem(u, n*SizeOf(ArbFloat));
+    getmem(l, n*Sizeof(ArbFloat));
+    getmem(k, n*SizeOf(ArbFloat));
+    getmem(d, n*SizeOf(ArbFloat));
+    getmem(c, n*SizeOf(ArbFloat));
+    getmem(b, n*SizeOf(ArbFloat));
+    h3:=xyc[2].x-xyc[1].x;
+    s3:=(xyc[2].y-xyc[1].y)/h3;
+    k2 := h3/6; dy1 := s3;
+    for i:=2 to n-1 do
+    begin
+      h2:=h3; h3:=xyc[i+1].x-xyc[i].x;
+      s2:=s3; s3:=(xyc[i+1].y-xyc[i].y)/h3;
+      l^[i]:=h2/6;
+      d^[i]:=(h2+h3)/3;
+      u^[i]:=h3/6;
+      b^[i]:=s3-s2;
+      k^[i]:=0
+    end;
+    kn1 := h3/6; k^[2] := k2; k^[n-1] := kn1;
+    sledtr(m, l^[3], d^[2], u^[2], k^[2], k^[2], term);
+    sledtr(m, l^[3], d^[2], u^[2], b^[2], c^[2], term);
+    cn := (dy1-s3-k2*c^[2]-kn1*c^[n-1])/(2*(k2+kn1)-k2*k^[2]-kn1*k^[n-1]);
+    for i:=2 to n-1 do xyc[i].w := c^[i] - cn*k^[i];
+    xyc[1].w := cn; xyc[n].w := cn;
+    Freemem(b, n*SizeOf(ArbFloat));
+    Freemem(c, n*SizeOf(ArbFloat));
+    Freemem(d, n*SizeOf(ArbFloat));
+    Freemem(l, n*Sizeof(ArbFloat));
+    Freemem(k, n*SizeOf(ArbFloat));
+    Freemem(u, n*SizeOf(ArbFloat));
+end; {spl1peri}
+
+function spl1pprv(n: ArbInt; var xyc1: ArbFloat; t: ArbFloat; var term: ArbInt): ArbFloat;
+var
+   xyc          : r3Ar absolute XYC1;
+   i, j, m      : ArbInt;
+   d, d3, h, dy : ArbFloat;
+begin                          { Assumption : x[i]<x[i+1] i=1..n-1 }
+  spl1pprv := NaN;
+  term:=3; if n<2 then exit;
+  if (t<xyc[1].x) or (t>xyc[n].x) then exit;
+  term:=1;
+  i:=1; j:=n;
+  while j <> i+1 do
+  begin
+      m:=(i+j) div 2;
+      if t>=xyc[m].x then i:=m else j:=m
+  end;   { x[i]<= t <=x[i+1] }
+  h     := xyc[i+1].x-xyc[i].x;
+  d     := t-xyc[i].x;
+  d3    :=(xyc[i+1].w-xyc[i].w)/h;
+  dy    :=(xyc[i+1].y-xyc[i].y)/h-h*(2*xyc[i].w+xyc[i+1].w)/6;
+  spl1pprv:= xyc[i].y+d*(dy+d*(xyc[i].w/2+d*d3/6))
+
+end; {spl1pprv}
+
+procedure spl1nalf(n: ArbInt; var xyw1: ArbFloat; lambda:ArbFloat;
+                     var xac1, residu: ArbFloat; var term: ArbInt);
+var
+   xyw        : r3Ar absolute xyw1;
+   xac        : r3Ar absolute xac1;
+   i, j, ncd  : ArbInt;
+   ca, crow   : ArbFloat;
+   h, qty     : ^arfloat1;
+   ch         : ^arfloat0;
+   qtdq       : ^arfloat1;
+begin
+   term := 3;                   { testing input}
+   if n<2 then exit;
+   for i:=2 to n do if xyw[i-1].x>=xyw[i].x then exit;
+   for i:=1 to n do if xyw[i].w<=0 then exit;
+   if lambda<0 then exit;
+   term := 1;
+   Move(xyw, xac, n*SizeOf(r_3));
+   if n=2 then begin xac[1].w := 0; xac[2].w := 0; exit end;
+
+   Getmem(ch, (n+2)*SizeOf(ArbFloat)); FillChar(ch^, (n+2)*SizeOf(ArbFloat), 0);
+   Getmem(h, n*SizeOf(ArbFloat));
+   Getmem(qty, n*SizeOf(ArbFloat));
+   ncd := n-3; if ncd>2 then ncd := 2;
+   Getmem(qtdq, ((n-2)*(ncd+1)-(ncd*(ncd+1)) div 2)*SizeOf(ArbFloat));
+   for i:=2 to n do h^[i] := 1/(xyw[i].x-xyw[i-1].x); h^[1] := 0;
+   for i:=1 to n-2
+   do qty^[i] := (h^[i+1]*xyw[i].y -
+                  (h^[i+1]+h^[i+2])*xyw[i+1].y +
+                  h^[i+2]*xyw[i+2].y);
+   j := 1; i := 1;
+   qtdq^[j] := sqr(h^[i+1])/xyw[i].w +
+               sqr(h^[i+1]+h^[i+2])/xyw[i+1].w +
+               sqr(h^[i+2])/xyw[i+2].w +
+               lambda*(1/h^[i+1]+1/h^[i+2])/3;
+   Inc(j);
+   if ncd>0 then
+   begin i := 2;
+      qtdq^[j] := -h^[i+1]*(h^[i]+h^[i+1])/xyw[i].w
+                  -h^[i+1]*(h^[i+1]+h^[i+2])/xyw[i+1].w +
+                   lambda/h^[i+1]/6;
+      Inc(j);
+      qtdq^[j] := sqr(h^[i+1])/xyw[i].w +
+                  sqr(h^[i+1]+h^[i+2])/xyw[i+1].w +
+                  sqr(h^[i+2])/xyw[i+2].w +
+                  lambda*(1/h^[i+1]+1/h^[i+2])/3;
+      Inc(j)
+   end;
+   for i:=3 to n-2
+   do begin
+      qtdq^[j] := h^[i]*h^[i+1]/xyw[i].w;
+      Inc(j);
+      qtdq^[j] := -h^[i+1]*(h^[i]+h^[i+1])/xyw[i].w
+                  -h^[i+1]*(h^[i+1]+h^[i+2])/xyw[i+1].w +
+                   lambda/h^[i+1]/6;
+      Inc(j);
+      qtdq^[j] := sqr(h^[i+1])/xyw[i].w +
+                  sqr(h^[i+1]+h^[i+2])/xyw[i+1].w +
+                  sqr(h^[i+2])/xyw[i+2].w +
+                  lambda*(1/h^[i+1]+1/h^[i+2])/3;
+      Inc(j)
+   end;
+   { Solving for c/lambda }
+   Slegpb(n-2, ncd, qtdq^[1], qty^[1], ch^[2], ca, term);
+   if term=1 then
+   begin
+       residu := 0;
+       for i:=1 to n do
+       begin
+         crow := (h^[i]*ch^[i-1] - (h^[i]+h^[i+1])*ch^[i]+h^[i+1]*ch^[i+1])
+                 /xyw[i].w;
+         xac[i].y := xyw[i].y - crow;
+         residu := residu + sqr(crow)*xyw[i].w
+       end;
+       xac[1].w := 0;
+       for i:=2 to n-1 do xac[i].w := lambda*ch^[i];
+       xac[n].w := 0;
+   end;
+   Freemem(qtdq, ((n-2)*(ncd+1)-(ncd*(ncd+1)) div 2)*SizeOf(ArbFloat));
+   Freemem(qty, n*SizeOf(ArbFloat));
+   Freemem(h, n*SizeOf(ArbFloat));
+   Freemem(ch, (n+2)*SizeOf(ArbFloat));
+end;
+
+
+procedure spl2nalf(n: ArbInt; var xyzw1: ArbFloat; lambda:ArbFloat;
+                   var xyg0, residu: ArbFloat; var term: ArbInt);
+type  R3 = array[1..3] of ArbFloat;
+      R33= array[1..3] of R3;
+      Rn3= array[1..$ffe0 div SizeOf(R3)] of R3;
+
+var b,e21t,ht   :^Rn3;
+    pfac        :par2dr1;
+    e22         :R33;
+    i,j,l,i1,i2,n3 :ArbInt;
+    s,s1,px,py,hr,ca,
+    x,absdet,x1,x2,
+    absdetmax   :ArbFloat;
+    vr          :R4x;
+    wr          :R2;
+    w,u         :R3;
+    a_alfa_d    :R4xAr absolute xyzw1;
+    a_gamma     :nsp2rec absolute xyg0;
+    gamma       :^arfloat1;
+
+
+  function e(var x,y:R2):ArbFloat;
+  const c1:ArbFloat=1/(16*pi);
+    var s:ArbFloat;
+    begin s:=sqr(x[1]-y[1]) +sqr(x[2]-y[2]);
+      if s=0 then e:=0 else e:=c1*s*ln(s)
+    end {e};
+
+   procedure pfxpfy(var a,b,c:R2;var f:r3; var pfx,pfy:ArbFloat);
+    var det:ArbFloat;
+    begin det:=(b[1]-a[1])*(c[2]-a[2]) - (b[2]-a[2])*(c[1]-a[1]);
+      pfx:=((f[2]-f[1])*(c[2]-a[2]) - (f[3]-f[1])*(b[2]-a[2]))/det;
+      pfy:=(-(f[2]-f[1])*(c[1]-a[1]) + (f[3]-f[1])*(b[1]-a[1]))/det
+    end {pfxpfy};
+
+  procedure pxpy(var a,b,c:R2; var px,py:ArbFloat);
+    var det : ArbFloat;
+    begin det:=(b[1]-a[1])*(c[2]-a[2]) - (b[2]-a[2])*(c[1]-a[1]);
+      px:=(b[2]-c[2])/det; py:=(c[1]-b[1])/det
+    end {pxpy};
+
+  function p(var x,a:R2; var px,py:ArbFloat):ArbFloat;
+    begin p:=1 + (x[1]-a[1])*px +(x[2]-a[2])*py end {p};
+
+  procedure slegpdlown(n: ArbInt; var a1; var bx1: ArbFloat;
+                    var term: ArbInt);
+   var i, j, k, kmin1 : ArbInt;
+       h, lkk : ArbFloat;
+       a  : ar2dr1 absolute a1;
+       x  : arfloat1 absolute bx1;
+   begin
+     k:=0; term := 2;
+     while (k<n) do
+       begin
+         kmin1:=k; k:=k+1; lkk:=a[k]^[k];
+         for j:=1 to kmin1 do lkk:=lkk-sqr(a[k]^[j]);
+         if lkk<=0 then exit else
+           begin
+             a[k]^[k]:=sqrt(lkk); lkk:=a[k]^[k];
+             for i:=k+1 to n do
+               begin
+                 h:=a[i]^[k];
+                 for j:=1 to kmin1 do h:=h-a[k]^[j]*a[i]^[j];
+                 a[i]^[k]:=h/lkk
+               end; {i}
+             h:=x[k];
+             for j:=1 to kmin1 do h:=h-a[k]^[j]*x[j];
+             x[k]:=h/lkk
+           end {lkk > 0}
+       end; {k}
+           for i:=n downto 1 do
+             begin
+               h:=x[i];
+               for j:=i+1 to n do h:=h-a[j]^[i]*x[j];
+               x[i]:=h/a[i]^[i];
+             end; {i}
+      term := 1
+   end;
+
+begin
+    term := 3; if n<3 then exit;
+    n3 := n - 3;
+    i1:=1; x1:=a_alfa_d[1].xy[1]; i2:=1; x2:=x1;
+    for i:= 2 to n do
+    begin hr:=a_alfa_d[i].xy[1];
+      if hr < x1 then begin i1:=i; x1:=hr end else
+      if hr > x2 then begin i2:=i; x2:=hr end;
+    end;
+    vr:=a_alfa_d[n-2]; a_alfa_d[n-2]:=a_alfa_d[i1]; a_alfa_d[i1]:=vr;
+    vr:=a_alfa_d[n-1]; a_alfa_d[n-1]:=a_alfa_d[i2]; a_alfa_d[i2]:=vr;
+
+    for i:=1 to 2 do vr.xy[i]:=a_alfa_d[n-2].xy[i]-a_alfa_d[n-1].xy[i];
+    absdetmax:=-1; i1:=0;
+    for i:=1 to n do
+    begin for j:=1 to 2 do wr[j]:=a_alfa_d[i].xy[j]-a_alfa_d[n-2].xy[j];
+      if a_alfa_d[i].d<=0 then exit;
+      absdet:=abs(wr[1]*vr.xy[2]-wr[2]*vr.xy[1]);
+      if absdet > absdetmax then begin i1:=i; absdetmax:=absdet end;
+    end;
+    term := 4;
+    if absdetmax<=macheps*abs(x2-x1) then exit;
+    term := 1;
+    vr:=a_alfa_d[n]; a_alfa_d[n]:=a_alfa_d[i1]; a_alfa_d[i1]:=vr;
+    GetMem(e21t, n3*SizeOf(r3));
+    GetMem(b, n3*SizeOf(r3));
+    GetMem(gamma, n*SizeOf(ArbFloat));
+
+    pxpy(a_alfa_d[n-2].xy,a_alfa_d[n-1].xy,a_alfa_d[n].xy,px,py);
+    for i:=1 to n3 do b^[i][1]:=p(a_alfa_d[i].xy,a_alfa_d[n-2].xy,px,py);
+    pxpy(a_alfa_d[n-1].xy,a_alfa_d[n].xy,a_alfa_d[n-2].xy,px,py);
+    for i:=1 to n3 do b^[i][2]:=p(a_alfa_d[i].xy,a_alfa_d[n-1].xy,px,py);
+    pxpy(a_alfa_d[n].xy,a_alfa_d[n-2].xy,a_alfa_d[n-1].xy,px,py);
+    for i:=1 to n3 do b^[i][3]:=p(a_alfa_d[i].xy,a_alfa_d[n].xy,px,py);
+    e22[1,1]:=0; e22[2,2]:=0; e22[3,3]:=0;
+    e22[2,1]:=e(a_alfa_d[n-1].xy,a_alfa_d[n-2].xy); e22[1,2]:=e22[2,1];
+    e22[3,1]:=e(a_alfa_d[n].xy,a_alfa_d[n-2].xy); e22[1,3]:=e22[3,1];
+    e22[3,2]:=e(a_alfa_d[n].xy,a_alfa_d[n-1].xy); e22[2,3]:=e22[3,2];
+    for i:=1 to 3 do
+    for j:=1 to n3 do e21t^[j,i]:=e(a_alfa_d[n3+i].xy,a_alfa_d[j].xy);
+
+    GetMem(ht, n3*SizeOf(r3));
+    for i:=1 to 3 do
+    for j:=1 to n3 do
+    begin s:=0;
+      for l:= 1 to 3 do s:=s+e22[i,l]*b^[j][l]; ht^[j][i]:=s
+    end;
+    AllocateL2dr(n3,pfac);
+    for i:= 1 to n3 do
+    for j:= 1 to i do
+    begin if j=i then s1:=0 else s1:=e(a_alfa_d[i].xy,a_alfa_d[j].xy);
+      for l:= 1 to 3 do s1:=s1+b^[i][l]*(ht^[j][l]-e21t^[j][l])-e21t^[i][l]*b^[j][l];
+      if j=i then s:=1/a_alfa_d[i].d else s:=0;
+      for l:= 1 to 3 do s:=s+b^[i][l]*b^[j][l]/a_alfa_d[n3+l].d;
+      pfac^[i]^[j] := s1+s/lambda
+    end;
+    for i:= 1 to n3 do
+      gamma^[i]:=a_alfa_d[i].alfa-b^[i][1]*a_alfa_d[n-2].alfa-b^[i][2]*a_alfa_d[n-1].alfa-b^[i][3]*a_alfa_d[n].alfa;
+    slegpdlown(n3,pfac^[1],gamma^[1],term);
+    DeAllocateL2dr(n3,pfac);
+    FreeMem(ht, n3*SizeOf(r3));
+
+    if term=1 then
+     begin
+      for i:= 1 to 3 do
+      begin s:= 0;
+        for j:= 1 to n3 do
+         s:=s+b^[j][i]*gamma^[j]; w[i]:=s;
+        gamma^[n3+i]:=-w[i]
+     end;{w=btgamma}
+      for i:=1 to 3 do
+      begin s:=0;
+        for l:=1 to n3 do s:=s+e21t^[l][i]*gamma^[l];
+        s1:=0;
+        for l:=1 to 3 do s1:=s1+e22[i,l]*w[l];
+        u[i]:=a_alfa_d[n3+i].alfa+w[i]/(lambda*a_alfa_d[n3+i].d)+s1-s
+      end;
+      with a_gamma[0] do
+      pfxpfy(a_alfa_d[n-2].xy,a_alfa_d[n-1].xy,a_alfa_d[n].xy,u,xy[1],xy[2]);
+      residu:=0;for i:=1 to n3 do residu:=residu+sqr(gamma^[i])/a_alfa_d[i].d;
+      for i:= 1 to 3 do residu:=residu+sqr(w[i])/a_alfa_d[n3+i].d;
+      residu:=residu/sqr(lambda);
+      a_gamma[0].gamma := u[1];
+      for i:=1 to n do
+      begin
+       a_gamma[i].xy := a_alfa_d[i].xy;
+       a_gamma[i].gamma := gamma^[i]
+      end;
+    end;
+    FreeMem(gamma, n*SizeOf(ArbFloat));
+    FreeMem(b, n3*SizeOf(r3));
+    FreeMem(e21t, n3*SizeOf(r3))
+  end;
+
+function spl2natv(n: ArbInt; var xyg0: ArbFloat; u, v: ArbFloat): ArbFloat;
+
+const c1: ArbFloat=1/(16*pi);
+
+  var i         : ArbInt;
+      s         : ArbFloat;
+      a_gamma   : nsp2rec absolute xyg0;
+      z         : R2;
+
+  function e(var x,y:R2):ArbFloat;
+    var s:ArbFloat;
+    begin
+      s:=sqr(x[1]-y[1]) + sqr(x[2]-y[2]);
+      if s=0 then
+       e:= 0
+      else
+       e:=s*ln(s)
+    end {e};
+
+  function pf(var x,a:R2;fa,pfx,pfy:ArbFloat):ArbFloat;
+    begin
+     pf:=fa + (x[1]-a[1])*pfx + (x[2]-a[2])*pfy
+    end {pf};
+
+  begin
+    s:=0;
+    z[1] := u;
+    z[2] := v;
+    for i:=1 to n do
+     s:=s+a_gamma[i].gamma*e(z, a_gamma[i].xy);
+    with a_gamma[0] do
+     spl2natv :=s*c1+pf(z,a_gamma[n-2].xy, gamma, xy[1], xy[2])
+  end;
+
+begin
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+

packages/numlib/timer.pas

@@ -0,0 +1,117 @@
+unit timer;
+
+{ NOT PORTED YET, BUT NOT USED BY OTHER LIBS/AND OR DLL AND MOST DEMOES}
+
+
+{$r-,s-}
+
+INTERFACE
+
+var
+  timeractive: boolean;
+  exacttime, mstime: longint;
+
+function timervalue: longint;          {Return time in 10 usec units}
+function mstimer: longint;             {Return time in ms}
+
+IMPLEMENTATION
+
+uses dos, crt;
+
+var
+  lowbyte, highbyte, ref: word;
+  timerid: integer;
+  saveint, exitsave: pointer;
+
+function inport(x: integer): byte;     {Read i/o port}
+  inline($5a/$eb/$00/$ec);
+
+{$F+}
+procedure clock(p: pointer); interrupt;
+{$F-}
+  {Interrupt service routine to update timer reference values}
+
+  const
+    incr = 5493;                       {Timer increment per interrupt}
+
+  begin
+    port[$43] := $00;                  {Latch timer 0}
+    lowbyte := inport($40);
+    highbyte := inport($40);
+    ref := (highbyte shl 8) + lowbyte; {Base for subsequent readings
+                                          within current clock interval}
+    exacttime := exacttime + incr;     {New 10 usec timer value}
+    mstime := mstime + 55;             {New ms timer value}
+    inline($9c/$ff/$1e/saveint);       {Chain to old interrupt}
+  end;
+
+function timervalue: longint;
+
+  {Get value of 10-usec timer}
+
+  var
+    dif, low, high: word;
+    t: longint;
+
+  begin
+    inline($fa);                         {Disable interrupts}
+    port[$43] := $00;                    {Latch timer}
+    low := inport($40);                  {Timer LSB}
+    high := inport($40);                 {MSB}
+    dif := ref - ((high shl 8) + low);   {Delta from last sync}
+    timervalue := exacttime + (longint(dif)*100 div 1193);
+    inline($fb);                         {Re-enable interrupts}
+  end;
+
+function mstimer: longint;
+
+  {Get value of millisecond timer}
+
+  var
+    dif, low, high: word;
+    t: longint;
+
+  begin
+    inline($fa);
+    port[$43] := $00;
+    low := inport($40);
+    high := inport($40);
+    inline($fb);
+    dif := ref - ((high shl 8) + low);
+    mstimer := mstime + (dif div 1193);
+  end;
+
+procedure inittimer;
+
+  begin
+    exacttime := 0;
+    mstime := 0;
+    if not timeractive then
+      begin
+        port[$43] := $34;   {Mode 2 - countdown
+                             (approx .84 microsecond ticks)}
+        port[$40] := $ff;   {Initialize timer value}
+        port[$40] := $ff;
+        getintvec(8, saveint);         {Save old interrupt address}
+        setintvec(8, @clock);          {Install new service routine}
+        timeractive := true;
+        delay(60);                     {Allow for first tick}
+      end;
+  end;
+
+{$f+} procedure myexit; {$f-}
+
+  {Assure timer interrupt restored before exit}
+
+  begin
+    if timeractive then
+      setintvec(8, saveint);
+    exitproc := exitsave;             {Restore TP exit chain}
+  end;
+
+begin  {unit initialization}
+  timeractive := false;
+  exitsave := exitproc;               {Insert exit routine}
+  exitproc := @myexit;
+  InitTimer
+end.

packages/numlib/tpnumlib.pas

@@ -0,0 +1,173 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             Documentation by Michael van Canneyt ([email protected])
+
+    This "library" imports 119 procedures from the numlib units, and throws
+    them in a dll file. The dll file can be accessed via numlib.pas
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+library tpnumlib;
+
+uses TYP, DET, DSL, EIG, INT, INV, IOM, MDT, ODE, OMV, ROO, SLE, SPE, SPL,IPF;
+
+exports
+
+
+ detgen          index      1,
+ detgsy          index      2,
+ detgpd          index      3,
+ detgba          index      4,
+ detgpb          index      5,
+ detgtr          index      6,
+
+ dslgen          index      7,
+ dslgtr          index      8,
+ dslgsy          index      9,
+ dslgpd          index     10,
+ dslgba          index     11,
+ dslgpb          index     12,
+ dsldtr          index     13,
+
+ eiggs1          index     14,
+ eiggs2          index     15,
+ eiggs3          index     16,
+ eiggs4          index     17,
+ eigts1          index     18,
+ eigts2          index     19,
+ eigts3          index     20,
+ eigts4          index     21,
+ eigbs1          index     22,
+ eigbs2          index     23,
+ eigbs3          index     24,
+ eigbs4          index     25,
+ eigge1          index     26,
+ eigge3          index     27,
+ eiggg1          index     28,
+ eiggg2          index     29,
+ eiggg3          index     30,
+ eiggg4          index     31,
+ eigsv1          index     32,
+ eigsv3          index     33,
+
+ int1fr          index     34,
+
+ invgen          index     35,
+ invgsy          index     36,
+ invgpd          index     37,
+
+ iomrev          index     38,
+ iomrem          index     39,
+ iomwrv          index     40,
+ iomwrm          index     41,
+
+ mdtgen          index     42,
+ mdtgtr          index     43,
+ mdtgsy          index     44,
+ mdtgpd          index     45,
+ mdtgba          index     46,
+ mdtgpb          index     47,
+ mdtdtr          index     48,
+
+ odeiv1          index     49,
+ odeiv2          index     50,
+
+ omvinp          index     51,
+ omvmmm          index     52,
+ omvmmv          index     53,
+ omvn1m          index     54,
+ omvn1v          index     55,
+ omvn2v          index     56,
+ omvnfm          index     57,
+ omvnmm          index     58,
+ omvnmv          index     59,
+ omvtrm          index     60,
+
+ roobin          index     61,
+ roof1r          index     62,
+ roopol          index     63,
+ rooqua          index     64,
+ roofnr          index     65,
+
+ sledtr          index     66,
+ slegba          index     67,
+ slegbal         index     68,
+ slegen          index     69,
+ slegenl         index     70,
+ slegls          index     71,
+ sleglsl         index     72,
+ slegpb          index     73,
+ slegpbl         index     74,
+ slegpd          index     75,
+ slegpdl         index     76,
+ slegsy          index     77,
+ slegsyl         index     78,
+ slegtr          index     79,
+
+ spebi0          index     80,
+ spebi1          index     81,
+ spebj0          index     82,
+ spebj1          index     83,
+ spebk0          index     84,
+ spebk1          index     85,
+ speby0          index     86,
+ speby1          index     87,
+ speent          index     88,
+ speerf          index     89,
+ speefc          index     90,
+ spegam          index     91,
+ spelga          index     92,
+ spemax          index     93,
+ spepol          index     94,
+ spepow          index     95,
+ spesgn          index     96,
+ spears          index     97,
+ spearc          index     98,
+ spesih          index     99,
+ specoh          index    100,
+ spetah          index    101,
+ speash          index    102,
+ speach          index    103,
+ speath          index    104,
+
+ spl1bspv        index    105,
+ spl2bspv        index    106,
+ spl1bspf        index    107,
+ spl2bspf        index    108,
+ spl1nati        index    109,
+ spl1naki        index    110,
+ spl1cmpi        index    111,
+ spl1peri        index    112,
+ spl1pprv        index    113,
+ spl1nalf        index    114,
+ spl2natv        index    115,
+ spl2nalf        index    116,
+ dllversion      index    117,
+// int1fr          index    117,                {existed twice, now used for dllversion}
+ exp             index    118,
+ MachCnst        index    119,
+ ipffsn          index    120,
+ ipfisn          index    121,
+ ipfspn          index    122,
+ ipfpol          index    123,
+ spline          index    124,
+ splineparameters index   125;
+
+
+begin
+
+end.
+

packages/numlib/typ.pas

@@ -0,0 +1,512 @@
+{
+    $Id$
+    This file is part of the Numlib package.
+    Copyright (c) 1986-2000 by
+     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
+     Computational centre of the Eindhoven University of Technology
+
+    FPC port Code          by Marco van de Voort ([email protected])
+             documentation by Michael van Canneyt ([email protected])
+
+    This is the most basic unit from NumLib.
+    The most important items this unit defines are matrix types and machine
+    constants
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{
+In the FPC revision, instead of picking a certain floating point type,
+ a new type "ArbFloat" is defined, which is used as floating point type
+ throughout the entire library. If you change the floating point type, you
+ should only have to change ArbFloat, and the machineconstants belonging to
+ the type you want.
+ However for IEEE Double (64bit) and Extended(80bit) these constants are
+ already defined, and autoselected by the library. (the library tests the
+ size of the float type in bytes for 8 and 10 and picks the appropiate
+ constants
+
+Also some stuff had to be added to get ipf running (vector object and
+complex.inp and scale methods)
+ }
+
+unit typ;
+
+{$I DIRECT.INC}                 {Contains "global" compilerswitches which
+                                  are imported into every unit of the library }
+
+{$unDEF ArbExtended}
+
+interface
+
+
+CONST numlib_version=2;         {used to detect version conflicts between
+                                  header unit and dll}
+      highestelement=20000;     {Maximal n x m dimensions of matrix.
+                                 +/- highestelement*SIZEOF(arbfloat) is
+                                  minimal size of matrix.}
+type {Definition of base types}
+     {$IFDEF ArbExtended}
+      ArbFloat    = extended;
+     {$ELSE}
+     ArbFloat    = double;
+     {$ENDIF}
+     ArbInt      = LONGINT;
+
+     Float8Arb  =ARRAY[0..7] OF BYTE;
+     Float10Arb =ARRAY[0..9] OF BYTE;
+
+CONST {Some constants for the variables below, in binary formats.}
+{$IFNDEF ArbExtended}
+        {First for REAL/Double}
+    TC1 :  Float8Arb  = ($00,$00,$00,$00,$00,$00,$B0,$3C);
+    TC2 :  Float8Arb  = ($FF,$FF,$FF,$FF,$FF,$FF,$EF,$7F);
+    TC3 :  Float8Arb  = ($00,$00,$00,$00,$01,$00,$10,$00);
+    TC4 :  Float8Arb  = ($00,$00,$00,$00,$00,$00,$F0,$7F);
+    TC5 :  Float8Arb  = ($EF,$39,$FA,$FE,$42,$2E,$86,$40);
+    TC6 :  Float8Arb  = ($D6,$BC,$FA,$BC,$2B,$23,$86,$C0);
+    TC7 :  Float8Arb  = ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF);
+{$ENDIF}
+
+     {For Extended}
+{$IFDEF ArbExtended}
+    TC1 : Float10Arb = (0,0,$00,$00,$00,$00,0,128,192,63);         {Eps}
+    TC2 : Float10Arb = ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$D6,$FE,127);  {9.99188560553925115E+4931}
+    TC3 : Float10Arb = (1,0,0,0,0,0,0,0,0,0);                      {3.64519953188247460E-4951}
+    TC4 : Float10Arb = (0,0,0,0,0,0,0,$80,$FF,$7F);                {Inf}
+    TC5 : Float10Arb = (18,25,219,91,61,101,113,177,12,64);        {1.13563488668777920E+0004}
+    TC6 : Float10Arb = (108,115,3,170,182,56,27,178,12,192);       {-1.13988053843083006E+0004}
+    TC7 : Float10Arb = ($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF);  {NaN}
+{$ENDIF}
+  { numdig  is the number of useful (safe) decimal places of an "ArbFloat"
+            for display.
+    minform is the number of decimal places shown by the rtls
+            write(x:ArbFloat)
+    maxform is the maximal number of decimal positions
+    }
+
+    numdig    = 25;
+    minform   = 10;
+    maxform   = 26;
+
+var
+    macheps  : ArbFloat absolute TC1;  { macheps = r - 1,  with r
+                                        the smallest ArbFloat > 1}
+    giant    : ArbFloat absolute TC2;  { the largest ArbFloat}
+    midget   : ArbFloat absolute TC3;  { the smallest positive ArbFloat}
+    infinity : ArbFloat absolute TC4;  { INF as defined in IEEE-754(double)
+                                         or intel (for extended)}
+    LnGiant  : ArbFloat absolute TC5;  {ln of giant}
+    LnMidget : ArbFloat absolute TC6;  {ln of midget}
+    NaN      : ArbFloat absolute TC7;  {Not A Number}
+
+{Like standard EXP(), but for very small values (near lowest possible
+      ArbFloat this version returns 0}
+Function exp(x: ArbFloat): ArbFloat; 
+
+type
+     transform = record
+                       offsetx, offsety, scalex, scaley: ArbFloat
+                 end;
+
+
+     Complex  = object          {Crude complex record. For me an example of
+                                 useless OOP, specially if you have operator overloading}
+                   xreal, imag : ArbFloat;
+                   procedure Init (r, i: ArbFloat);
+                   procedure Add  (c: complex);
+                   procedure Sub  (c: complex);
+                   function  Inp(z:complex):ArbFloat;
+                   procedure Conjugate;
+                   procedure Scale(s: ArbFloat);
+                   Function  Norm  : ArbFloat;
+                   Function  Size  : ArbFloat;
+                   Function  Re    : ArbFloat;
+                   Function  Im    : ArbFloat;
+                   Function  Arg   : ArbFloat;
+               end;
+
+    vector =  object
+               i, j, k: ArbFloat;
+               procedure Init (vii, vjj, vkk: ArbFloat);
+               procedure Unary;
+               procedure Add  (c: vector);
+               procedure Sub  (c: vector);
+               function  Vi : ArbFloat;
+               function  Vj : ArbFloat;
+               function  Vk : ArbFloat;
+               function  Norm  : ArbFloat;
+               Function  Norm8 : ArbFloat;
+               function  Size  : ArbFloat;
+               function  InProd(c: vector): ArbFloat;
+               procedure Uitprod(c: vector; var e: vector);
+               procedure Scale(s: ArbFloat);
+               procedure DScale(s: ArbFloat);
+               procedure Normalize;
+               procedure Rotate(calfa, salfa: ArbFloat; axe: vector);
+               procedure Show(p,q: ArbInt);
+            end;
+
+     {Standard Functions used in NumLib}
+     rfunc1r    = Function(x : ArbFloat): ArbFloat;
+     rfunc2r    = Function(x, y : ArbFloat): ArbFloat;
+
+     {Complex version}
+     rfunc1z    = Function(z: complex): ArbFloat;
+
+     {Special Functions}
+     oderk1n    = procedure(x: ArbFloat; var y, f: ArbFloat);  
+     roofnrfunc = procedure(var x, fx: ArbFloat; var deff: boolean);
+
+     {Definition of matrix types in NumLib. First some vectors.
+      The high boundery is a maximal number only. Vectors can be smaller, but
+      not bigger. The difference is the starting number}
+     arfloat0   = array[0..highestelement] of ArbFloat;
+     arfloat1   = array[1..highestelement] of ArbFloat;
+     arfloat2   = array[2..highestelement] of ArbFloat;
+     arfloat_1  = array[-1..highestelement] of ArbFloat;
+
+     {A matrix is an array of floats}
+     ar2dr      = array[0..highestelement] of ^arfloat0;
+     ar2dr1     = array[1..highestelement] of ^arfloat1;
+
+     {Matrices can get big, so we mosttimes allocate them on the heap.}
+     par2dr1    = ^ar2dr1;
+
+     {Integer vectors}
+     arint0     = array[0..highestelement] of ArbInt;
+     arint1     = array[1..highestelement] of ArbInt;
+
+     {Boolean (true/false) vectors}
+     arbool1    = array[1..highestelement] of boolean;
+
+     {Complex vectors}
+     arcomp0    = array[0..highestelement] of complex;
+     arcomp1    = array[1..highestelement] of complex;
+     arvect0    = array[0..highestelement] of vector;
+     vectors    = array[1..highestelement] of vector;
+
+     parcomp    = ^arcomp1;
+
+{(de) Allocate mxn matrix to A}
+procedure AllocateAr2dr(m, n: integer; var a: par2dr1);   
+procedure DeAllocateAr2dr(m, n: integer; var a: par2dr1); 
+
+{(de) allocate below-left triangle matrix for (de)convolution
+(a 3x3 matrix looks like this
+
+  x
+  x x
+  x x x)
+}
+procedure AllocateL2dr(n: integer; var a: par2dr1);
+procedure DeAllocateL2dr(n: integer; var a: par2dr1);     
+
+{Get the Re and Im parts of a complex type}
+Function Re(z: complex): ArbFloat;                            
+Function Im(z: complex): ArbFloat;
+
+{ Creates a string from a floatingpoint value}
+Function R2S(x: ArbFloat; p, q: integer): string;             
+
+{Calculate inproduct of V1 and V2, which are vectors with N elements;
+I1 and I2 are the SIZEOF the datatypes of V1 and V2
+MvdV: Change this to "V1,V2:array of ArbFloat and forget the i1 and i2
+parameters?}
+
+Function Inprod(var V1, V2; n, i1, i2: ArbInt): ArbFloat;
+
+{Return certain special machine constants.(macheps=1, Nan=7)}
+Function MachCnst(n: ArbInt): ArbFloat;
+
+function dllversion:LONGINT;
+
+implementation
+
+Function MachCnst(n: ArbInt): ArbFloat;
+begin
+    case n of
+    1: MachCnst := macheps;
+    2: MachCnst := giant;
+    3: MachCnst := midget;
+    4: MachCnst := infinity;
+    5: MachCnst := LnGiant;
+    6: MachCnst := LnMidget;
+    7: MachCnst := Nan;
+    end
+end;
+
+{ Are used in many of the example programs}
+Function Re(z: complex): ArbFloat;
+begin
+  Re := z.xreal
+end;
+
+Function Im(z: complex): ArbFloat;
+begin
+  Im := z.imag
+end;
+
+{Kind of Sysutils.TrimRight and TrimLeft called after eachother}
+procedure Compress(var s: string);
+var i, j: LONGINT;
+begin
+     j := length(s);
+     while (j>0) and (s[j]=' ') do dec(j);
+     i := 1;
+     while (i<=j) and (s[i]=' ') do Inc(i);
+     s := copy(s, i, j+1-i)
+end;
+
+Function R2S(x: ArbFloat; p, q: integer): string;
+var s: string;
+    i, j, k: integer;
+begin
+   if q=-1 then
+    begin
+        Str(x:p, s);
+        i := Pos('E', s)-1; k := i+1;
+        j := i+3; while (j<length(s)) and (s[j]='0') do inc(j);
+        while s[i]='0' do dec(i); if s[i]='.' then dec(i);
+        if s[j]='0' then s := copy(s,1,i) else
+        if s[k]='-' then
+         s := copy(s, 1, i)+'E-'+Copy(s, j, length(s)+1-j)
+        else
+         s := copy(s, 1, i)+'E'+Copy(s, j, length(s)+1-j)
+    end
+   else
+    Str(x:p:q, s);
+   Compress(s);
+   R2S := s
+end;
+
+procedure AllocateAr2dr(m, n: integer; var a: par2dr1);
+var i: integer;
+begin
+    GetMem(a, m*SizeOf(pointer));
+    for i:=1 to m do GetMem(a^[i], n*SizeOf(ArbFloat))
+end;
+
+procedure DeAllocateAr2dr(m, n: integer; var a: par2dr1);
+var i: integer;
+begin
+    for i:=m downto 1 do FreeMem(a^[i], n*SizeOf(ArbFloat));
+    FreeMem(a, m*SizeOf(pointer));
+    a := Nil
+end;
+
+procedure AllocateL2dr(n: integer; var a: par2dr1);
+var i: integer;
+begin
+    GetMem(a, n*SizeOf(pointer));
+    for i:=1 to n do GetMem(a^[i], i*SizeOf(ArbFloat))
+end;
+
+procedure DeAllocateL2dr(n: integer; var a: par2dr1);
+var i: integer;
+begin
+    for i:=n downto 1 do FreeMem(a^[i], i*SizeOf(ArbFloat));
+    FreeMem(a, n*SizeOf(pointer));
+    a := Nil
+end;
+
+var h, r, i: ArbFloat;
+
+procedure Complex.Init(r, i: ArbFloat);
+begin
+      xreal:= r;
+      imag := i
+end;
+
+procedure Complex.Conjugate;
+begin
+    imag := -imag
+end;
+
+function Complex.Inp(z:complex):ArbFloat;
+begin
+     Inp := xreal*z.xreal + imag*z.imag
+end;
+
+
+procedure Complex.Add(c: complex);
+begin
+    xreal := xreal + c.xreal; imag := imag + c.imag
+end;
+
+procedure Complex.Sub(c: complex);
+begin
+    xreal := xreal - c.xreal; imag := imag - c.imag
+end;
+
+Function Complex.Norm: ArbFloat;
+begin
+    Norm := Sqr(xreal) + Sqr(imag)
+end;
+
+Function Complex.Size: ArbFloat;
+begin
+    Size := Sqrt(Norm)
+end;
+
+Function Complex.Re: ArbFloat;
+begin
+    Re := xreal;
+end;
+
+Function Complex.Im: ArbFloat;
+begin
+    Im := imag
+end;
+
+
+procedure Complex.Scale(s:ArbFloat);
+begin
+    xreal := xreal*s; imag := imag*s
+end;
+
+Function Complex.Arg: ArbFloat;
+begin
+    if xreal=0 then
+    if imag>0 then Arg := 0.5*pi else
+    if imag=0 then Arg := 0 else Arg := -0.5*pi else
+    if xReal>0 then Arg := ArcTan(imag/xReal)
+    else if imag>=0 then Arg := ArcTan(imag/xReal) + pi
+                    else Arg := ArcTan(imag/xReal) - pi
+end;
+
+Function exp(x: ArbFloat): ArbFloat;
+begin
+    if x<LnMidget then exp := 0 else exp := system.exp(x)
+end;
+
+{ procedure berekent: v1 = v1 + r*v2 i1 en i2 geven de
+  increments in bytes voor v1 en v2 }
+
+Function Inprod(var V1, V2; n, i1, i2: ArbInt): ArbFloat;
+
+VAR i: LONGINT;
+    p1, p2: ^ArbFloat;
+    s: ArbFloat;
+begin
+  IF I1 <>SIZEOF(ArbFloat) THEN
+   BEGIN
+    WRITELN('1 Something went probably wrong while porting!');
+    HALT;
+   END;
+   p1 := @v1; p2 := @v2; s := 0;
+   for i:=1 to n do
+    begin
+     s := s + p1^*p2^;
+     Inc(longint(p1), i1);
+     Inc(longint(p2), i2)
+    end;
+    Inprod := s
+end;
+
+procedure Vector.Init(vii, vjj, vkk: ArbFloat);
+begin
+    i := vii; j := vjj; k := vkk
+end;
+
+procedure Vector.Unary;
+begin i := -i; j := -j; k := -k end;
+
+procedure Vector.Add(c: vector);
+begin
+    i := i + c.i; j := j + c.j; k := k + c.k
+end;
+
+procedure Vector.Sub(c: vector);
+begin
+    i := i - c.i; j := j - c.j; k := k - c.k
+end;
+
+function Vector.Vi : ArbFloat; begin Vi := i end;
+
+function Vector.Vj : ArbFloat; begin Vj := j end;
+
+function Vector.Vk : ArbFloat; begin Vk := k end;
+
+function Vector.Norm:ArbFloat;
+begin
+    Norm := Sqr(i) + Sqr(j) + Sqr(k)
+end;
+
+function Vector.Norm8:ArbFloat;
+var r: ArbFloat;
+begin
+    r := abs(i);
+    if abs(j)>r then r := abs(j);
+    if abs(k)>r then r := abs(k);
+    Norm8 := r
+end;
+
+function Vector.Size: ArbFloat;
+begin
+    Size := Sqrt(Norm)
+end;
+
+function Vector.InProd(c: vector): ArbFloat;
+begin
+     InProd := i*c.i + j*c.j + k*c.k
+end;
+
+procedure Vector.Uitprod(c: vector; var e: vector);
+begin
+      e.i := j*c.k - k*c.j;
+      e.j := k*c.i - i*c.k;
+      e.k := i*c.j - j*c.i
+end;
+
+procedure Vector.Scale(s: ArbFloat);
+begin
+    i := i*s; j := j*s; k := k*s
+end;
+
+procedure Vector.DScale(s: ArbFloat);
+begin
+    i := i/s; j := j/s; k := k/s
+end;
+
+procedure Vector.Normalize;
+begin
+    DScale(Size)
+end;
+
+procedure Vector.Show(p,q:ArbInt);
+begin writeln(i:p:q, 'I', j:p:q, 'J', k:p:q, 'K') end;
+
+procedure Vector.Rotate(calfa, salfa: arbfloat; axe: vector);
+var qv : vector;
+begin
+    Uitprod(axe, qv); qv.scale(salfa);
+    axe.scale((1-calfa)*Inprod(axe));
+    scale(calfa); sub(qv);  add(axe)
+end;
+
+function dllversion:LONGINT;
+
+BEGIN
+ dllversion:=numlib_version;
+END;
+
+
+END.
+
+
+
+{
+  $Log$
+  Revision 1.1  2000-01-24 22:08:58  marco
+   * initial version
+
+
+}
+