* small updates, crlf fix, and RTE 207 problem

packages/numlib/det.pas

@@ -1,15 +1,15 @@
-{
-    $Id$
+{
+    $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])
+    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)
+
+    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.
@@ -18,409 +18,395 @@
     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.
-{
+ **********************************************************************}
+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);
+
+var og          : ArbFloat absolute ogx;
+    bg          : ArbFloat absolute bgx;
+    MaxExp      : ArbInt   absolute maxexpx;
+
+
+implementation
+
+uses mdt;
+
+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
+  Revision 1.2  2000-01-25 20:21:41  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:57  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/dsl.pas

@@ -1,21 +1,21 @@
-{
-    $Id$
+{
+    $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])
+    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.
+
+    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.
@@ -24,513 +24,515 @@
     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.
-{
+ **********************************************************************}
+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
+  Revision 1.2  2000-01-25 20:21:41  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/eig.pas

@@ -1,818 +1,820 @@
-{
-    $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.
-
-{
+{
+    $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
+  Revision 1.2  2000-01-25 20:21:41  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/eigh1.pas

@@ -1,15 +1,15 @@
-{
-    $Id$
+{
+    $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])
+    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.
+
+    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.
@@ -18,915 +18,917 @@
     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.
-
-
-{
+ **********************************************************************}
+
+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
+  Revision 1.2  2000-01-25 20:21:41  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/eigh2.pas

@@ -1,15 +1,15 @@
-{
-    $Id$
+{
+    $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])
+    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.
+
+    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.
@@ -18,842 +18,844 @@
     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.
-
-
-{
+ **********************************************************************}
+
+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
+  Revision 1.2  2000-01-25 20:21:41  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/int.pas

@@ -1,1072 +1,1074 @@
-{
-    $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.
-{
+{
+    $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
+  Revision 1.2  2000-01-25 20:21:41  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/inv.pas

@@ -1,276 +1,278 @@
-{
-    $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.
-{
+{
+    $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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/iom.pas

@@ -1,15 +1,15 @@
-{
-    $Id$
+{
+    $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])
+    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.
+
+    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.
@@ -18,102 +18,104 @@
     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.
-
-{
+ **********************************************************************}
+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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/ipf.pas

@@ -1,891 +1,893 @@
-{
-    $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.
-{
+{
+    $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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/mdt.pas

@@ -1,962 +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.
-
-{
+{
+    $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 was originally undocumented, but is probably an variant of DET.
+    Det accepts vectors as arguments, while MDT calculates determinants for
+    matrices.
+
+    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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/numlib.pas

@@ -1,16 +1,16 @@
-{
-    $Id$
+{
+    $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])
+    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.
+
+    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.
@@ -19,296 +19,298 @@
     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.
-{
+ **********************************************************************}
+
+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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/ode.pas

@@ -1,339 +1,341 @@
-{
-    $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.
-{
+{
+    $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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/omv.pas

@@ -1,14 +1,14 @@
-{
-    $Id$
+{
+    $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])
+    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.
+
+    This unit contains some basic matrix operations.
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -17,258 +17,260 @@
     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.
-{
+ **********************************************************************}
+
+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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/roo.pas

@@ -1,1444 +1,1446 @@
-{
-    $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.
-{
+{
+    $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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/sle.pas

@@ -1,2286 +1,2288 @@
-{
-    $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.
-{
+{
+    $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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/spe.pas

@@ -1,1308 +1,1310 @@
-{
-    $Id$
+{
+    $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])
+    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)
+
+    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.
-{
+    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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/spl.pas

@@ -1,15 +1,15 @@
-{
-    $Id$
+{
+    $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])
+    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.
+
+    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.
@@ -18,1105 +18,1107 @@
     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.
-{
+ **********************************************************************}
+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
+  Revision 1.2  2000-01-25 20:21:42  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}

packages/numlib/timer.pas

@@ -1,117 +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.
+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

@@ -1,15 +1,15 @@
-{
-    $Id$
+{
+    $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])
+    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
+
+    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.
@@ -18,156 +18,155 @@
     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.
-
+ **********************************************************************}
+
+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

@@ -1,512 +1,570 @@
-{
-    $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.
-
-
-
-{
+{
+    $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 }
+
+{$DEFINE 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}
+
+{Copied from Det. Needs ArbExtended conditional}
+const               {  og = 8^-maxexp, ogý>=midget,
+                       bg = 8^maxexp,  bgý<=giant
+
+                       midget and giant are defined in typ.pas}
+
+{$IFDEF ArbExtended}
+     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;
+{$ELSE}
+     ogx: Float8Arb= (84, 254, 32, 128, 32, 0, 0, 32);
+     bgx: Float8Arb= (149, 255, 255, 255, 255, 255, 239, 95);
+  maxexpx : ArbInt = 170;
+{$ENDIF}
+
+
+
+{Like standard EXP(), but for very small values (near lowest possible
+      ArbFloat this version returns 0}
+Function exp(x: ArbFloat): ArbFloat;
+
+type
+
+
+     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;
+                   procedure Unary;
+                   Function  Im    : ArbFloat;
+                   Function  Arg   : ArbFloat;
+                   procedure MinC(c: complex);
+                   procedure MaxC(c: complex);
+                   Procedure TransF(var t: complex);
+
+               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;
+
+     transformorg  = record offset: complex; ss, sc: real end;
+     transform = record
+                       offsetx, offsety, scalex, scaley: ArbFloat
+                 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.MinC(c: complex);
+begin if c.xreal<xreal then xreal := c.xreal;
+      if c.imag<imag then imag := c.imag
+end;
+
+procedure Complex.Maxc(c: complex);
+begin if c.xreal>xreal then xreal := c.xreal;
+      if c.imag>imag then imag := c.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.TransF(var t: complex);
+var w: complex;
+    tt: transformorg absolute t;
+begin
+   w := Self; Conjugate;
+   with tt do
+    begin
+     w.scale(ss);
+     scale(sc);
+     Add(offset)
+    end;
+   Add(w)
+end;
+
+
+procedure Complex.Unary;
+begin
+ xreal := -xreal;
+ imag := -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
+  Revision 1.2  2000-01-25 20:21:41  marco
+   * small updates, crlf fix, and RTE 207 problem
+
+  Revision 1.1  2000/01/24 22:08:58  marco
    * initial version
-
-
-}
-
+
+
+}