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

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

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Singular values decomposition, solve linear equations, matrix inversion... //
// Reference: 'COMPUTER METHODS FOR MATHEMATICAL COMPUTATIONS'                //
//            G.T.Forsythe; M.A.Malcolm; C.V Moler; Prenice-Hall,Inc.;1977    //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20011212 - Creation (uses CRW16) & test                                    //
// 20030326 - Struggle for safety (add some try/except checks)...             //
// 20230506 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_svd; // Singular Values Decomposition.

interface

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math,
 _crw_alloc, _crw_ef, _crw_zm;

 {
 *******************************************************************************
 Purpose:
     Singular values decomposition (abbreviation SVD) of M rows by N columns
   matrix A[M*N] is set of three matrix U,W,V such as A=U*W*V', where V' is
   "V transposed".
  U[M*M] columns is "left singular vectors",  corresponds to A*A' eigenvectors.
  V[N*N] columns is "right singular vectors", corresponds to A'*A eigenvectors.
  U and V matrix is unitary, it means, U'*U=I(M), V'*V=I(N), where I[N*N] is
  diagonal 1 matrix (I[i,i]=1, I[i,j]=0 for i<>j) of size N.
  Matrix W[M*N] is diagonal matrix, such as W[i,i]>=0, W[i,j]=0 if i<>j.
  Diagonal elements W[i]=W[i,i],i=1..N is "singular values" of matrix A.
  Sqr(W[i]) corresponds to eigenvalues of A'*A matrix. All singular values
  always non-negative, W[i]>=0.
     ANY matrix have singular decomposition, and singular matrix too. If matrix
  is full rank, all W[i]>0. If matrix is singular, some of W[i]=0 or very small.
  In practice, we use small Eps value to detect "nearly zero" singular values.
  The value of Cond(A)=Max(W[i])/Min(W[i]) calls "condition value". If linear
  set have good condition, Cond(A) small (for example, Cond(A) < 1.0e+5).
  If Cond(A) large or infinity, linear set is singular or ill conditioned.
 *******************************************************************************
 How to solve least squares linear set and find "pseudo inverted" matrix:
     In least squares fitting methods we want to solve A*X=Y linear set with
  A[M*N],X[N],Y[M]. More exactly, we want to find X, such as residual vector
  R=A*X-Y length have minimal value |R|=sqrt(R'*R).
     First, |R|=|U'*R|, because unitary matrix does not change vector length.
   Let's make singular decomposition: A=U*W*V'. Let's call new variable vector
   V'*X as Z and constant vector U'*Y as D.
      We have: |R|=|U'*(A*X-Y)|=|U'*U*W*V'*X-U'*Y|=|W*Z-D|, because U'*U=I.
   This minimization problem more easy, because W is diagonal matrix.
   Solution is Z=pinv(W,Eps)*D, where pinv(W,Eps) is diagonal "pseudo inverted"
   matrix:
    pinv(W,Eps)[i]=1/W[i], if W[i]>Eps,
    pinv(W,Eps)[i]=0,      if W[i]<=Eps,
   where Eps is threshold for "nearly zero" values. We use Eps value for robust
   and stability. Now V'*X=pinv(W,Eps)*U'*Y, therefore, X=V*pinv(W,Eps)*U'*Y.
   Matrix pinv(A,Eps)=V*pinv(W,Eps)*U' is "pseudo inverted" matrix with Eps
   threshold.
  Result is:
   Solution of least square problem A*X=Y is X=pinv(A,Eps)*Y, where "pseudo
   inverted" matrix pinv(A,Eps)=V*pinv(W,Eps)*U' and Eps is some small value
   for stability.
 *******************************************************************************
 Note 1:
     In practice usually uses U[M*N] matrix and W[N] vector to keep, U and W
  matrix, because all W[i,j],i<>j always 0. It means, that we have no practical
  reasons to keep N+1..M columns of U matrix and non-diagonal W[i,j], they not
  uses.
     This SVD unit use U[M*N] matrix and W[N] vector too.
 *******************************************************************************
 Note 2:
  All matrixes keeps as long one-dimension array, by rows:
   Matrix[1..M,1..N]     <---> array[1..M*N]
   Matrix[i,k]           <---> array[(i-1)*N+(j-1)]; i=1..M; k=1..N;
  or
   Matrix[0..M-1,0..N-1] <---> array[0..M*N-1]
   Matrix[i,k]           <---> array[i*N+j]; i=0..M-1; k=0..N-1;
 *******************************************************************************
 Note 3:
  We use "public" and "actual" column matrix dimension. "Public" dimension uses
  in matrix "type" declaration and define memory usage and address calculation.
  "Actual" dimension always less or equal to "public". That is really used
  matrix dimension.
 *******************************************************************************
 }

 {
 Type for singular values decompositions
 }
type
 TSVD=class(TMasterObject)
 private
  myM   : Integer;
  myN   : Integer;
  myU   : PDoubleArray;
  myW   : PDoubleArray;
  myV   : PDoubleArray;
  myRV1 : PDoubleArray;
  function  GetM:Integer;
  function  GetN:Integer;
  function  GetU:PDoubleArray;
  function  GetW:PDoubleArray;
  function  GetV:PDoubleArray;
 protected 
  function  CheckOk:Boolean; override;
 public
  {
  Allocate memory and  make decomposition of M rows by N columns matrix A,
  given in one dimension array with public column dimension NA, such as
  A[i,j]=A[i*NA+j], i=0..M-1, j=0..N-1. Test Ok to check if success.
  }
  constructor Create(var A:array of Double; MRow,NColumn,NA:Integer);
  destructor  Destroy; override;
 public
  {
  Find "nearly zero" threshold of singular values with given absolute and
  relative tolerance.
  }
  function  Eps(AbsEps,RelEps:Double):Double;
  {
  Find rank of matrix - number of non-zero singular values with aEps threshold.
  }
  function  Rank(aEps:Double):Integer;
  {
  Solve linear system A*X=Y as least square error, A*U*W*V', M*N size.
  }
  function  Solve(var X,Y:array of Double; aEps:Double):Boolean;
  {
  Find N*M pseudo-iverted matrix Res=pinv(A).
  NRes is public column dimension of Res.
  }
  function  PInvert(var Res:array of Double; NRes:Integer; aEps:Double):Boolean;
 public
  property M  : Integer      read GetM;  { Row dimension }
  property N  : Integer      read GetN;  { Column dimension }
  property U  : PDoubleArray read GetU;  { U[M*N] matrix in A=U*W*V' }
  property W  : PDoubleArray read GetW;  { W[N]   vector of singular values }
  property V  : PDoubleArray read GetV;  { V[N*N] matrix in A=U*W*V' }
 end;


function  NewSVD(var A:array of Double; MRow,NColumn,NA:Integer):TSVD;
procedure Kill(var TheObject:TSVD); overload;

 {
 Find least squares solution of A*X=Y linear system M rows by N  columns
 with matrix A given in one-dimension array by rows with column dimension NA:
 A[i,j]=A[i*NA+j], i=0..M-1, j=0..N-1.
 AbsEps,RelEps uses to evaluate Eps=RelEps*max(W[i])+AbsEps, uses to detect
 "nearly zero" singular values.
 }
function SVD_Solve(M,N,NA:Integer; var A,X,Y:array of Double; AbsEps,RelEps:Double):Boolean;

 {
 Find pseudo-inverted matrix invA(N*M) by given matrix A(M*N) using SVD.
 matrixes are in one-dimension arrays with column dimension NinvA, NA:
 A[i,j]=A[i*NA+j], i=0..M-1, j=0..N-1;
 invA[i,j]=invA[i*NinvA+j], i=0..N-1, j=0..M-1
 }
function SVD_PInvert(M,N,NA,NinvA:Integer; var A,invA:array of Double; AbsEps,RelEps:Double):Boolean;

 {
 SingularDecomposition actually makes singular values decomposition
 A=U*W*V' of M*N matrix A. That is main (low-level) procedure for SVD.
 All arrays given in one-dimension arrays by rows
 Matrix have public and real dimension
 Public dimension is dimension used in type definition of matrix
 Real dimension is actually-use dimension (may be <= then public dimension)
 M,N      - matrix real dimension (number of rows,columns)
 NA,NU,NV - matrix public dimensions (number of columns, must be >= N)
 A(M,NA)  - input matrix  - A[i,j]=A[i*NA+j], i=0..M-1, j=0..N-1
 U(M,NU)  - output matrix - U[i,j]=U[i*NU+j], i=0..M-1, j=0..N-1
            of right transform
 W(N)     - output vector of singular values
 V(N,NV)  - output matrix - V[i,k]=V(i*NV+k], i=1..N-1, k=1..N-1
            of left transform
 RV1(max(N,M)) - internally use array
 Output array W of singular values will be sorted as W[i+1]>=W[i]
 }
function SingularDecomposition(var A,U,W,V,RV1:array of Double;
                               M,N,NA,NU,NV:Integer;
                               MatU,MatV:Boolean):Boolean;

implementation

 {
 *******************
 TSVD implementation
 *******************
 }
constructor TSVD.Create(var A:array of Double; MRow,NColumn,NA:Integer);
var
 Success : Boolean;
begin
 inherited Create;
 Exceptions:=false;
 myM:=0;
 myN:=0;
 myU:=nil;
 myW:=nil;
 myV:=nil;
 myRV1:=nil;
 Success:=false;
 if (MRow>0) and (NColumn>0) and (@A<>nil) and (NA>=NColumn) then
 try
  myM:=MRow;
  myN:=NColumn;
  myW:=Allocate((myN+myM*myN+myN*myN+max(myM,myN))*sizeof(Double));
  if Assigned(myW) then begin {W,U,V,RV1 placed in single large array}
   myU:=@myW[myN];
   myV:=@myW[myN+myM*myN];
   myRV1:=@myW[myN+myM*myN+myN*myN];
   Success:=SingularDecomposition(A,myU^,myW^,myV^,myRV1^,myM,myN,NA,myN,myN,true,true);
  end;
 except
  on E:Exception do ErrorReport(E,'Create');
 end;
 if not Success then begin
  Deallocate(Pointer(myW));
  myM:=0;
  myN:=0;
  myU:=nil;
  myW:=nil;
  myV:=nil;
  myRV1:=nil;
 end;
end;

destructor TSVD.Destroy;
begin
 Deallocate(Pointer(myW));
 myM:=0;
 myN:=0;
 myU:=nil;
 myW:=nil;
 myV:=nil;
 myRV1:=nil;
 inherited Destroy;
end;

function TSVD.CheckOk:Boolean;
begin
 Result:=Assigned(myW);
end;

function TSVD.GetM:Integer;
begin
 if Assigned(Self) then Result:=myM else Result:=0;
end;

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

function TSVD.GetU:PDoubleArray;
begin
 if Assigned(Self) then Result:=myU else Result:=nil;
end;

function TSVD.GetW:PDoubleArray;
begin
 if Assigned(Self) then Result:=myW else Result:=nil;
end;

function TSVD.GetV:PDoubleArray;
begin
 if Assigned(Self) then Result:=myV else Result:=nil;
end;

function TSVD.Eps(AbsEps,RelEps:Double):Double;
begin
 if Ok
 then Result:=max(max(MachEps,myN*max(MachEps*myW[0],AbsEps)),myN*max(MachEps,RelEps*myW[0]))
 else Result:=0;
end;

function TSVD.Rank(aEps:Double):Integer;
var
 i         : Integer;
 threshold : Double;
begin
 Result:=0;
 if Ok then
 try
  threshold:=max(Eps(0,0),aEps);
  for i:=myN-1 downto 0 do if myW[i]>=threshold then begin
   Result:=i+1; { note: W[i] sorted after decomposition! }
   break;
  end;
 except
  on E:Exception do ErrorReport(E,'Rank');
 end;
end;

function TSVD.Solve(var X,Y:array of Double; aEps:Double):Boolean;
var i,j,iNU,iNV,MatrixRank:Integer; s:Double;
begin
 Result:=false;
 if Ok and (@X<>nil) and (@Y<>nil) then
 try
  for i:=0 to myN-1 do X[i]:=0;
  MatrixRank:=Rank(aEps);
  for j:=0 to MatrixRank-1 do begin
   s:=0;
   iNU:=0;
   for i:=0 to myM-1 do begin
    s:=s+myU[iNU+j]*Y[i];
    iNU:=iNU+myN;
   end;
   s:=s/myW[j];
   iNV:=0;
   for i:=0 to myN-1 do begin
    X[i]:=X[i]+s*myV[iNV+j];
    iNV:=iNV+myN;
   end;
  end;
  Result:=true;
 except
  on E:Exception do ErrorReport(E,'Solve');
 end;
end;

function TSVD.PInvert(var Res:array of Double; NRes:Integer; aEps:Double):Boolean;
var
 i,j,k,iNV,jNU,iM,MatrixRank:Integer;
 s:Double;
begin
 Result:=false;
 if Ok and (@Res<>nil) and (NRes>=M) then
 try
  iNV:=0;
  iM:=0;
  MatrixRank:=Rank(aEps);
  for i:=0 to myN-1 do begin
   jNU:=0;
   for j:=0 to myM-1 do begin
    s:=0;
    for k:=0 to MatrixRank-1 do s:=s+myV[iNV+k]*myU[jNU+k]/myW[k];
    Res[iM+j]:=s;
    jNU:=jNU+myN;
   end;
   iNV:=iNV+myN;
   iM:=iM+NRes;
  end;
  Result:=true;
 except
  on E:Exception do ErrorReport(E,'PInvert');
 end;
end;

function  NewSVD(var A:array of Double; MRow,NColumn,NA:Integer):TSVD;
begin
 Result:=nil;
 try
  Result:=TSVD.Create(A,MRow,NColumn,NA);
  if not Result.Ok then Kill(Result);
 except
  on E:Exception do begin
   BugReport(E,nil,'NewSVD');
   Kill(Result);
  end;
 end;
end;

procedure Kill(var TheObject:TSVD); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end;
end;

function SVD_Solve(M,N,NA:Integer; var A,X,Y:array of Double; AbsEps,RelEps:Double):Boolean;
var SVD:TSVD;
begin
 Result:=false;
 try
  SVD:=TSVD.Create(A,M,N,NA);
  try
   Result:=SVD.Ok and SVD.Solve(X,Y,SVD.Eps(AbsEps,RelEps));
  finally
   Kill(SVD);
  end;
 except
  on E:Exception do BugReport(E,nil,'SVD_Solve');
 end;
end;

function SVD_PInvert(M,N,NA,NinvA:Integer; var A,invA:array of Double; AbsEps,RelEps:Double):Boolean;
var SVD:TSVD;
begin
 Result:=false;
 try
  SVD:=TSVD.Create(A,M,N,NA);
  try
   Result:=SVD.Ok and SVD.PInvert(invA,NinvA,SVD.Eps(AbsEps,RelEps));
  finally
   Kill(SVD);
  end;
 except
  on E:Exception do BugReport(E,nil,'SVD_PInvert');
 end;
end;

 {
 Singular decomposition A=U*W*V' of M*N matrix A
 All arrays given in one-dimension arrays by rows
 A(M,NA) - input matrix  - A[i,j]=A[i*NA+j], i=0..M-1, j=0..N-1
 U(M,NU) - output matrix - U[i,j]=U[i*NU+j], i=0..M-1, j=0..N-1
 W(N)    - output vector of singular values
 V(N,NV) - output matrix - V[i,k]=V(i*NV+k], i=1..N-1, k=1..N-1
 RV1(max(N,M)) - internally use array
 Note:
 every time, when it possible, we will use
  kNU:=i*NU;
  for k:=i to M-1 do begin
   U[kNU+j]:=...;
   ...
   kNU:=kNU+NU;
  end;
 instead of
  for k:=i to M-1 do begin
   U[k*NU+j]:=...;
   ...
  end;
 for more fast (kNU will be equal to k*NU, but without multiplication).
 }
function SingularDecomposition(var A,U,W,V,RV1:array of Double;
                               M,N,NA,NU,NV:Integer;
                               MatU,MatV:Boolean):Boolean;
var
 i,its,MN,j,k,l,ii,i1,kk,k1,LL,L1,iNA,iNU,kNU,jNU,LNU,iNV,jNV,kNV,LNV:Integer;
 c,s,F,G,H,x,y,z,scale,anorm:Double;
const
 MaxIter=30;
Label
 190,210,270,290,360,390,460,475,490,520,540,565,650;
 function sign( a,b:Double):Double;
 begin
  if b<=0 then sign:=-abs(a) else sign:=abs(a);
 end;
 function amax1(a,b:Double):Double;
 begin
  if a>b then amax1:=a else amax1:=b;
 end;
 procedure SortSingularValues;
  procedure Sort(l,r:Integer);
  var i,j,k,kNV,kNU:Integer; x,y:Double;
  begin
   i:=l;
   j:=r;
   x:=W[(l+r) shr 1];
   repeat
    while W[i]>x do i:=i+1;
    while x>W[j] do j:=j-1;
    if i <= j then begin
     y:=W[i];
     W[i]:=W[j];
     W[j]:=y;
     if MatV then begin
      kNV:=0;
      for k:=0 to N-1 do begin
       y:=V[kNV+i];
       V[kNV+i]:=V[kNV+j];
       V[kNV+j]:=y;
       kNV:=kNV+NV;
      end;
     end;
     if MatU then begin
      kNU:=0;
      for k:=0 to M-1 do begin
       y:=U[kNU+i];
       U[kNU+i]:=U[kNU+j];
       U[kNU+j]:=y;
       kNU:=kNU+NU;
      end;
     end;
     i:=i+1;
     j:=j-1;
    end;
   until i>j;
   if l<j then Sort(l,j);
   if i<r then Sort(i,r);
  end;
 begin
  Sort(0,N-1);
 end;
begin
 {}
 Result:=false;
 if (N<1)
 or (M<1)
 or (NA<N)
 or (NU<N)
 or (NV<N)
 or (@A=nil)
 or (@U=nil)
 or (@W=nil)
 or (MatV and (@V=nil))
 or (@RV1=nil)
 then exit;
 Result:=true;
 {}
 if @A<>@U then begin
  iNA:=0;
  iNU:=0;
  for i:=0 to M-1 do begin
   for j:=0 to N-1 do U[iNU+j]:=A[iNA+j];
   iNA:=iNA+NA;
   iNU:=iNU+NU;
  end;
 end;
 {}
 G:=0;
 scale:=0;
 anorm:=0;
 iNU:=0;
 LNU:=0;
 L:=0;
 L1:=0;
 for i:=0 to N-1 do begin
  L:=L+1;
  LNU:=LNU+NU;
  RV1[i]:=scale*G;
  G:=0;
  s:=0;
  scale:=0;
  if i>M-1 then goto 210;
  kNU:=iNU;
  for k:=i to M-1 do begin
   scale:=scale+abs(U[kNU+i]);
   kNU:=kNU+NU;
  end;
  if scale=0 then goto 210;
  kNU:=iNU;
  for k:=i to M-1 do begin
   U[kNU+i]:=U[kNU+i]/scale;
   s:=s+sqr(U[kNU+i]);
   kNU:=kNU+NU;
  end;
  F:=U[iNU+i];
  G:=-sign(sqrt(s),f);
  H:=F*G-s;
  U[iNU+i]:=F-G;
  if i=N-1 then goto 190;
  for j:=L to N-1 do begin
   s:=0;
   kNU:=iNU;
   for k:=i to M-1 do begin
    s:=s+U[kNU+i]*U[kNU+j];
    kNU:=kNU+NU;
   end;
   F:=s/H;
   kNU:=iNU;
   for k:=i to M-1 do begin
    U[kNU+j]:=U[kNU+j]+F*U[kNU+i];
    kNU:=kNU+NU;
   end;
  end;
190:
  kNU:=iNU;
  for k:=i to M-1 do begin
   U[kNU+i]:=scale*U[kNU+i];
   kNU:=kNU+NU;
  end;
210:
  W[i]:=scale*G;
  G:=0;
  s:=0;
  scale:=0;
  if (i>M-1) or (i=N-1) then goto 290;
  for k:=L to N-1 do scale:=scale+abs(U[iNU+k]);
  if scale=0 then goto 290;
  for k:=L to N-1 do begin
   U[iNU+k]:=U[iNU+k]/scale;
   s:=s+sqr(U[iNU+k]);
  end;
  F:=U[iNU+L];
  G:=-sign(sqrt(s),F);
  H:=F*G-s;
  U[iNU+L]:=F-G;
  for k:=L to N-1 do RV1[k]:=U[iNU+k]/H;
  if i=M-1 then goto 270;
  jNU:=LNU;
  for j:=L to M-1 do begin
   s:=0;
   for k:=L to N-1 do s:=s+U[jNU+k]*U[iNU+k];
   for k:=L to N-1 do U[jNU+k]:=U[jNU+k]+s*RV1[k];
   jNU:=jNU+NU;
  end;
270:
  for k:=L to N-1 do U[iNU+k]:=U[iNU+k]*scale;
290:
  anorm:=amax1(anorm,abs(W[i])+abs(RV1[i]));
  iNU:=iNU+NU;
 end;
 {}
 if MatV then begin
  i:=N-1;
  L:=i+1;
  iNU:=i*NU;
  iNV:=i*NV;
  LNU:=L*NU;
  LNV:=L*NV;
  for ii:=0 to N-1 do begin
   if i=N-1 then goto 390;
   if G=0 then goto 360;
   jNV:=LNV;
   for j:=L to N-1 do begin
    V[jNV+i]:=(U[iNU+j]/U[iNU+L])/G;
    jNV:=jNV+NV;
   end;
   for j:=L to N-1 do begin
    s:=0;
    kNV:=LNV;
    for k:=L to N-1 do begin
     s:=s+U[iNU+k]*V[kNV+j];
     kNV:=kNV+NV;
    end;
    kNV:=LNV;
    for k:=L to N-1 do begin
     V[kNV+j]:=V[kNV+j]+s*V[kNV+i];
     kNV:=kNV+NV;
    end;
   end;
360:
   jNV:=LNV;
   for j:=L to N-1 do begin
    V[iNV+j]:=0;
    V[jNV+i]:=0;
    jNV:=jNV+NV;
   end;
390:
   V[iNV+i]:=1;
   G:=RV1[i];
   i:=i-1;
   L:=L-1;
   iNU:=iNU-NU;
   iNV:=iNV-NV;
   LNU:=LNU-NU;
   LNV:=LNV-NV;
  end;
 end;
 {}
 if MatU then begin
  MN:=N;
  if (M<N) then MN:=M;
  i:=MN-1;
  L:=i+1;
  iNU:=i*NU;
  iNV:=i*NV;
  LNU:=L*NU;
  LNV:=L*NV;
  for ii:=0 to MN-1 do begin
   G:=W[i];
   if i<>N-1 then for j:=L to N-1 do U[iNU+j]:=0;
   if G=0 then goto 475;
   if i=MN-1 then goto 460;
   for j:=L to N-1 do begin
    s:=0;
    kNU:=LNU;
    for k:=L to M-1 do begin
     s:=s+U[kNU+i]*U[kNU+j];
     kNU:=kNU+NU;
    end;
    F:=(s/U[iNU+i])/G;
    kNU:=iNU;
    for k:=i to M-1 do begin
     U[kNU+j]:=U[kNU+j]+F*U[kNU+i];
     kNU:=kNU+NU;
    end;
   end;
460:
   jNU:=iNU;
   for j:=i to M-1 do begin
    U[jNU+i]:=U[jNU+i]/G;
    jNU:=jNU+NU;
   end;
   goto 490;
475:
   jNU:=iNU;
   for j:=i to M-1 do begin
    U[jNU+i]:=0;
    jNU:=jNU+NU;
   end;
490:
   U[iNU+i]:=U[iNU+i]+1;
   i:=i-1;
   L:=L-1;
   iNU:=iNU-NU;
   iNV:=iNV-NV;
   LNU:=LNU-NU;
   LNV:=LNV-NV;
  end;
 end;
 {}
 for kk:=0 to N-1 do begin
  k1:=N-2-kk;
  k:=k1+1;
  its:=0;
520:
  for LL:=0 to k do begin
   L1:=k-LL-1;
   L:=L1+1;
   if (abs(RV1[L])+anorm=anorm) then goto 565;
   if (abs(W[L1])+anorm=anorm) then goto 540;
  end;
540:
  C:=0;
  s:=1;
  for i:=L to k do begin
   F:=s*RV1[i];
   RV1[i]:=RV1[i]*C;
   if (abs(F)+anorm=anorm) then goto 565;
   G:=W[i];
   H:=sqrt(sqr(F)+sqr(G));
   W[i]:=H;
   c:=G/H;
   s:=-F/H;
   if MatU then begin
    jNU:=0;
    for j:=0 to M-1 do begin
     y:=U[jNU+L1];
     z:=U[jNU+i];
     U[jNU+L1]:=y*c+z*s;
     U[jNU+i]:=-y*s+z*c;
     jNU:=jNU+NU;
    end;
   end;
  end;
565:
  z:=W[k];
  if L=k then goto 650;
  if(its=MaxIter) then begin {too many iterations}
   Result:=false;
   exit;
  end;
  its:=its+1;
  x:=W[L];
  y:=W[k1];
  G:=RV1[k1];
  H:=RV1[k];
  F:=((y-z)*(y+z)+(G-H)*(G+H))/(2*H*y);
  G:=sqrt(sqr(F)+1);
  F:=((x-z)*(x+z)+H*(y/(F+sign(G,F))-H))/x;
  c:=1;
  s:=1;
  for i1:=L to k1 do begin
   i:=i1+1;
   G:=RV1[i];
   y:=W[i];
   H:=s*G;
   G:=c*G;
   z:=sqrt(sqr(F)+Sqr(H));
   RV1[i1]:=z;
   c:=F/z;
   s:=H/z;
   F:=x*c+G*s;
   G:=-x*s+G*c;
   H:=y*s;
   y:=y*c;
   if MatV then begin
    jNV:=0;
    for j:=0 to N-1 do begin
     x:=V[jNV+i1];
     z:=V[jNV+i];
     V[jNV+i1]:=x*c+z*s;
     V[jNV+i]:=-x*s+z*c;
     jNV:=jNV+NV;
    end;
   end;
   z:=sqrt(sqr(F)+sqr(H));
   W[i1]:=z;
   if z<>0 then begin
    c:=F/z;
    s:=H/z;
   end;
   F:=c*G+s*y;
   x:=-s*G+c*y;
   if MatU then begin
    jNU:=0;
    for j:=0 to M-1 do begin
     y:=U[jNU+i1];
     z:=U[jNU+i];
     U[jNU+i1]:=y*c+z*s;
     U[jNU+i]:=-y*s+z*c;
     jNU:=jNU+NU;
    end;
   end;
  end;
  RV1[L]:=0;
  RV1[k]:=F;
  W[k]:=x;
  goto 520;
650:
  if z<0 then begin
   W[k]:=-z;
   if MatV then begin
    jNV:=0;
    for j:=0 to N-1 do begin
     V[jNV+k]:=-V[jNV+k];
     jNV:=jNV+NV;
    end;
   end;
  end;
 end;
 SortSingularValues;
end;

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

procedure Init_crw_svd;
begin
end;

procedure Free_crw_svd;
begin
end;

initialization

 Init_crw_svd;

finalization

 Free_crw_svd;

end.

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

