svd.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
-------------------------> GNU Sather - sourcefile <-------------------------
-- Copyright (C) 2000 by K Hopper, University of Waikato, New Zealand --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute and/or modify it under the terms of the GNU Library General --
-- Public License (LGPL) as published by the Free Software Foundation; --
-- either version 2 of the license, or (at your option) any later version. --
-- This library 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. See Doc/LGPL for more details. --
-- The license text is also available from: Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --
--------------> Please email comments to <bug-sather@gnu.org> <--------------
class NR_SVD
class NR_SVD is
-- This class implements the singular value decomposition algorithm
-- derived from Numerical Recipes.
-- This algorithm is known to have a problem with an obscure case (but
-- works almost all of the time). Better algorithms are being worked on.
-- The IF statements protect accesses outside the matrices when
-- the loop index points to the last row/column as the sub-loop will never
-- start when the start index is greater than the stop index and a sub-loop
-- uses the next index value as its index.
-- Version 1.2 Sep 97. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 21 Nov 95 bg Original for Sather 1.0 Dist
-- 12 Jul 96 bh Fixed bugs and converted for MAT & VEC use
-- 3 Sep 97 kh Revised for cards and portability.
-- 22 Mar 01 djw A few minor bug fixes
private const Max_Iterations : CARD := 30 ; -- Should be enough!
pythag(
frst,
scnd : FLT
) : FLT is
-- This routine solves the pythagorean quadratic
--
-- sqrt(frst^2 + scnd^2)
--
-- without either destructive overflow or underflow.
res : FLT ;
loc_frst : FLT := frst.abs ;
loc_scnd : FLT := scnd.abs ;
loc_temp : FLT ;
if loc_frst > loc_scnd then -- loc_scnd may be zero here!
loc_temp := loc_scnd / loc_frst ;
res := loc_frst * (1.0 + loc_temp * loc_temp).sqrt
elsif loc_scnd /= 0.0 then
loc_temp := loc_frst / loc_scnd ;
res := loc_scnd * (1.0 + loc_temp * loc_temp).sqrt
end ;
return res
end ;
svd(
frst : MAT,
vect : VEC,
scnd : MAT
)
pre frst.nr >= frst.nc
and vect.dim = frst.nc
and scnd.nr = frst.nc
and scnd.nc = frst.nc is
-- This routine computes the singular value decomposition of frst so that
-- frst vect scnd^T is the original value of frst. The algorithm is
-- based on that given in 'Numerical Recipes in C' p68.
rows : CARD := frst.nr ;
cols : CARD := frst.nc ;
next : CARD := 0 ; -- column!
break_val : CARD := 0 ; -- passed out of loop, etc
-- The first section implements Householder's reduction
-- to bi-diagonal form!
res_vect : VEC := res_vect.create(cols) ;
scale : FLT := 0.0 ; -- during diagonalization.
factor : FLT := 0.0 ; -- used during scaling.
divisor : FLT := 0.0 ;
sum : FLT := 0.0 ;
field : FLT := 0.0 ; -- arbitrary matrix element value
anorm : FLT := 0.0 ;
coeff : FLT := 0.0 ;
loc_val : FLT := 0.0 ;
tmp_1 : FLT := 0.0 ;
tmp_2 : FLT := 0.0 ;
-- Householder reduction to bidiagonal form
loop
outer : CARD := 0.upto!(cols - 1) ;
next := outer + 1 ;
res_vect[outer] := scale * factor ;
factor := 0.0 ;
sum := 0.0 ;
scale := 0.0 ;
if outer < rows then
loop
inner : CARD := outer.upto!(rows - 1) ;
scale := scale + frst[inner,outer].abs
end ;
if scale /= 0.0 then
loop
inner : CARD := outer.upto!(rows - 1) ;
frst[inner,outer] := frst[inner,outer] / scale ;
sum := sum + frst[inner,outer] * frst[inner,outer]
end ;
field := frst[outer,outer] ; -- diagonal element
if field < 0.0 then
factor := sum.sqrt
else
factor := -sum.sqrt
end ;
divisor := field * factor - sum ;
frst[outer,outer] := field - factor ;
loop
inner : CARD := next.upto!(cols - 1) ;
sum := 0.0 ;
loop
index : CARD := outer.upto!(rows - 1) ;
sum := sum + frst[index,outer] * frst[index,outer]
end ;
field := sum / divisor ;
loop
index : CARD := outer.upto!(rows - 1) ;
frst[index,inner] := frst[index,inner] +
field * frst[index,outer]
end
end ;
loop
inner : CARD := outer.upto!(rows - 1) ;
frst[inner,outer] := frst[inner,outer] * scale
end
end
end ;
res_vect[outer] := scale * factor ;
factor := 0.0 ;
sum := 0.0 ;
scale := 0.0 ;
if (outer < rows)
and (outer /= cols - 1) then
loop
inner : CARD := next.upto!(cols - 1) ;
scale := scale + frst[outer,inner].abs
end ;
if scale /= 0.0 then
loop
inner : CARD := next.upto!(cols - 1) ;
frst[outer,inner] := frst[outer,inner] / scale ;
sum := sum + frst[outer,inner] * frst[outer,inner]
end ;
field := frst[outer,next] ;
if field < 0.0 then
factor := sum.sqrt
else
factor := -sum.sqrt
end ;
divisor := field * factor - scale ;
frst[outer,next] := field - factor ;
loop
inner : CARD := next.upto!(cols - 1) ;
res_vect[inner] := frst[outer,inner] / divisor
end ;
loop
inner : CARD := next.upto!(rows - 1) ;
sum := 0.0 ;
loop
index : CARD := next.upto!(cols - 1) ;
sum := sum + frst[inner,index] + frst[inner,index]
end ;
loop
index : CARD := next.upto!(cols - 1) ;
frst[inner,index] := frst[inner,index] +
sum * res_vect[index]
end
end ;
loop
inner : CARD := next.upto!(cols - 1) ;
frst[outer,inner] := frst[outer,inner] * scale
end
end
end ;
anorm := anorm.max(vect[outer] + res_vect[outer]).abs
end ;
-- Now accumulate right-hand transformations, remembering that
-- next currently has the value cols!!!
loop
outer : CARD := (cols - 1).downto!(0) ;
if outer < cols - 1 then
if factor /= 0.0 then
loop -- double div to avoid underflow
inner : CARD := next.upto!(cols - 1) ;
scnd[inner,outer] :=
(frst[outer,inner] / frst[outer,next]) / factor
end ;
loop
inner : CARD := next.upto!(cols - 1) ;
sum := 0.0 ;
loop
index : CARD := next.upto!(cols - 1) ;
sum := sum + frst[outer,index] * scnd[index,inner]
end ;
loop
index : CARD := next.upto!(cols - 1) ;
scnd[index,inner] := scnd[index,inner] +
sum * scnd[index,outer]
end
end
end ;
loop
inner : CARD := next.upto!(cols - 1) ;
scnd[outer,inner] := 0.0 ;
scnd[inner,outer] := 0.0
end
end ;
scnd[outer,outer] := 1.0 ;
factor := res_vect[outer] ;
next := outer
end ;
-- Next accumulate the left-hand transformations.
loop
outer : CARD := (cols.min(rows) - 1).downto!(0) ;
next := outer + 1 ;
factor := vect[outer] ;
loop -- initialize row to zeroes
inner : CARD := next.upto!(cols - 1) ;
frst[outer,inner] := 0.0
end ;
if factor /= 0.0 then
factor := 1.0 / factor ;
loop
inner : CARD := next.upto!(cols - 1) ;
sum := 0.0 ;
loop
index : CARD := next.upto!(rows - 1) ;
sum := sum + frst[index,outer] * frst[index,outer]
end ;
field := (sum / frst[outer,outer]) * factor ;
loop
index : CARD := next.upto!(rows - 1) ;
frst[index,inner] := frst[index,inner] +
field * frst[index,outer]
end
end ;
loop
inner : CARD := outer.upto!(rows - 1) ;
frst[inner,outer] := frst[inner,outer] * factor
end
else -- factor is zero!
loop
inner : CARD := outer.upto!(rows - 1) ;
frst[inner,outer] := 0.0
end
end ;
frst[outer,outer] := frst[outer,outer] + 1.0
end ;
-- The next phase diagonalizes the bidiagonal form with
-- an arbitrary Max_Iterations.
loop
outer : CARD := (cols - 1).downto!(0) ;
loop
iter_cnt : CARD := 1.upto!(Max_Iterations) ;
zero_flag : BOOL := true ; -- optimist!
loop
inner : CARD := outer.downto!(0) ;
next := outer - 1 ;
if (res_vect[inner].abs.flt + anorm) = anorm then
zero_flag := false ;
break_val := inner ;
break!
end ;
if (vect[next].abs.flt + anorm) = anorm then
break_val := inner ;
break!
end
end ;
if zero_flag then
coeff := 0.0 ;
sum := 1.0 ;
loop
inner : CARD := break_val.upto!(outer) ;
field := sum * res_vect[inner] ;
res_vect[inner] := coeff * res_vect[inner] ;
if (field.abs.flt + anorm) /= anorm then
factor := vect[inner] ;
divisor := pythag(field, factor) ;
vect[inner] := divisor ;
divisor := 1.0 / divisor ;
coeff := factor * divisor ;
sum := -field * divisor ;
loop
index : CARD := 0.upto!(rows - 1) ;
tmp_1 := frst[index,next] ;
tmp_2 := frst[index,inner] ;
frst[index,next] := tmp_1 * coeff +
tmp_2 * sum ;
frst[index,inner] :=
tmp_2 * coeff + tmp_1 * sum
end
end
end
end ;
tmp_2 := vect[outer] ;
if break_val = outer then -- converging!
if tmp_2 < 0.0 then -- singular value is non-negative
vect[outer] := -tmp_2 ;
loop
inner : CARD := 0.upto!(cols - 1) ;
scnd[inner,outer] := -scnd[inner,outer]
end
end ;
break!
end ;
if iter_cnt = Max_Iterations then
raise frst
end ;
-- Now shift from bottom 2 by 2 minor
loc_val := vect[break_val] ;
next := outer - 1 ;
tmp_1 := vect[next] ;
factor := res_vect[next] ;
divisor := res_vect[outer] ;
field := ((tmp_1 - tmp_2) * (tmp_1 + tmp_2) +
(factor - divisor) * (factor + divisor)) /
(2.0 * divisor * tmp_1) ;
factor := pythag(field, 1.0) ;
if field >= 0.0 then
field := ((loc_val - tmp_2) * (loc_val + tmp_2) +
divisor * ((tmp_1 / (field + factor.abs)) -
divisor)) / loc_val
else
field := ((loc_val - tmp_2) * (loc_val + tmp_2) +
divisor * ((tmp_1 / (field - factor.abs)) -
divisor)) / loc_val
end ;
-- Next QR transformation
coeff := 1.0 ;
sum := 1.0 ;
loop
inner : CARD := break_val.upto!(next) ;
next := inner + 1 ;
factor := res_vect[next] ;
tmp_1 := vect[next] ;
divisor := sum * factor ;
factor := coeff * factor ;
tmp_2 := pythag(field,divisor) ;
res_vect[inner] := tmp_2 ;
coeff := field / tmp_2 ;
sum := divisor / tmp_2 ;
field := loc_val * coeff + factor * sum ;
factor := factor * coeff - loc_val * sum ;
divisor := tmp_1 * sum ;
tmp_1 := tmp_1 * coeff ;
loop
index : CARD := break_val.upto!(cols - 1) ;
loc_val := scnd[index,inner] ;
tmp_2 := scnd[index,next] ;
scnd[index,inner] := loc_val * coeff + tmp_2 * sum ;
scnd[index,next] := tmp_2 * coeff - loc_val * sum
end ;
tmp_2 := pythag(field,divisor) ;
vect[inner] := tmp_2 ;
if tmp_2 /= 0.0 then
tmp_2 := 1.0 / tmp_2 ;
coeff := field * tmp_2 ;
sum := divisor * tmp_2
end ;
field := (coeff * factor) + (sum * tmp_1) ;
loc_val := (coeff *tmp_1) - (sum * factor) ;
loop
index : CARD := 0.upto!(rows - 1) ;
tmp_1 := frst[index,inner] ;
tmp_2 := frst[index,next] ;
frst[index,inner] := tmp_1 * coeff + tmp_2 * sum ;
frst[index,next] := tmp_2 * coeff - tmp_1 * sum
end
end ;
res_vect[break_val] := 0.0 ;
res_vect[outer] := field ;
vect[outer] := loc_val
end
end ;
end ;
end ; -- NR_SVD