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