Mercurial > hg > octave-lyh
diff liboctave/floatCHOL.cc @ 7789:82be108cc558
First attempt at single precision tyeps
* * *
corrections to qrupdate single precision routines
* * *
prefer demotion to single over promotion to double
* * *
Add single precision support to log2 function
* * *
Trivial PROJECT file update
* * *
Cache optimized hermitian/transpose methods
* * *
Add tests for tranpose/hermitian and ChangeLog entry for new transpose code
author | David Bateman <dbateman@free.fr> |
---|---|
date | Sun, 27 Apr 2008 22:34:17 +0200 |
parents | |
children | 25bc2d31e1bf |
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/liboctave/floatCHOL.cc @@ -0,0 +1,291 @@ +/* + +Copyright (C) 1994, 1995, 1996, 1997, 2002, 2003, 2004, 2005, 2007 + John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave 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 the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// updating/downdating by Jaroslav Hajek 2008 + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <vector> + +#include "fRowVector.h" +#include "floatCHOL.h" +#include "f77-fcn.h" +#include "lo-error.h" + +extern "C" +{ + F77_RET_T + F77_FUNC (spotrf, SPOTRF) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&, + float*, const octave_idx_type&, octave_idx_type& + F77_CHAR_ARG_LEN_DECL); + + F77_RET_T + F77_FUNC (spotri, SPOTRI) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&, + float*, const octave_idx_type&, octave_idx_type& + F77_CHAR_ARG_LEN_DECL); + + F77_RET_T + F77_FUNC (spocon, SPOCON) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&, + float*, const octave_idx_type&, const float&, + float&, float*, octave_idx_type*, + octave_idx_type& F77_CHAR_ARG_LEN_DECL); + F77_RET_T + F77_FUNC (sch1up, SCH1UP) (const octave_idx_type&, float*, float*, float*); + + F77_RET_T + F77_FUNC (sch1dn, SCH1DN) (const octave_idx_type&, float*, float*, float*, + octave_idx_type&); + + F77_RET_T + F77_FUNC (sqrshc, SQRSHC) (const octave_idx_type&, const octave_idx_type&, const octave_idx_type&, + float*, float*, const octave_idx_type&, const octave_idx_type&); + + F77_RET_T + F77_FUNC (schinx, SCHINX) (const octave_idx_type&, const float*, float*, const octave_idx_type&, + const float*, octave_idx_type&); + + F77_RET_T + F77_FUNC (schdex, SCHDEX) (const octave_idx_type&, const float*, float*, const octave_idx_type&); +} + +octave_idx_type +FloatCHOL::init (const FloatMatrix& a, bool calc_cond) +{ + octave_idx_type a_nr = a.rows (); + octave_idx_type a_nc = a.cols (); + + if (a_nr != a_nc) + { + (*current_liboctave_error_handler) ("FloatCHOL requires square matrix"); + return -1; + } + + octave_idx_type n = a_nc; + octave_idx_type info; + + chol_mat = a; + float *h = chol_mat.fortran_vec (); + + // Calculate the norm of the matrix, for later use. + float anorm = 0; + if (calc_cond) + anorm = chol_mat.abs().sum().row(static_cast<octave_idx_type>(0)).max(); + + F77_XFCN (spotrf, SPOTRF, (F77_CONST_CHAR_ARG2 ("U", 1), + n, h, n, info + F77_CHAR_ARG_LEN (1))); + + xrcond = 0.0; + if (info != 0) + info = -1; + else if (calc_cond) + { + octave_idx_type spocon_info = 0; + + // Now calculate the condition number for non-singular matrix. + Array<float> z (3*n); + float *pz = z.fortran_vec (); + Array<octave_idx_type> iz (n); + octave_idx_type *piz = iz.fortran_vec (); + F77_XFCN (spocon, SPOCON, (F77_CONST_CHAR_ARG2 ("U", 1), n, h, + n, anorm, xrcond, pz, piz, spocon_info + F77_CHAR_ARG_LEN (1))); + + if (spocon_info != 0) + info = -1; + } + else + { + // If someone thinks of a more graceful way of doing this (or + // faster for that matter :-)), please let me know! + + if (n > 1) + for (octave_idx_type j = 0; j < a_nc; j++) + for (octave_idx_type i = j+1; i < a_nr; i++) + chol_mat.xelem (i, j) = 0.0; + } + + return info; +} + +static FloatMatrix +chol2inv_internal (const FloatMatrix& r) +{ + FloatMatrix retval; + + octave_idx_type r_nr = r.rows (); + octave_idx_type r_nc = r.cols (); + + if (r_nr == r_nc) + { + octave_idx_type n = r_nc; + octave_idx_type info = 0; + + FloatMatrix tmp = r; + float *v = tmp.fortran_vec(); + + if (info == 0) + { + F77_XFCN (spotri, SPOTRI, (F77_CONST_CHAR_ARG2 ("U", 1), n, + v, n, info + F77_CHAR_ARG_LEN (1))); + + // If someone thinks of a more graceful way of doing this (or + // faster for that matter :-)), please let me know! + + if (n > 1) + for (octave_idx_type j = 0; j < r_nc; j++) + for (octave_idx_type i = j+1; i < r_nr; i++) + tmp.xelem (i, j) = tmp.xelem (j, i); + + retval = tmp; + } + } + else + (*current_liboctave_error_handler) ("chol2inv requires square matrix"); + + return retval; +} + +// Compute the inverse of a matrix using the Cholesky factorization. +FloatMatrix +FloatCHOL::inverse (void) const +{ + return chol2inv_internal (chol_mat); +} + +void +FloatCHOL::set (const FloatMatrix& R) +{ + if (R.is_square ()) + chol_mat = R; + else + (*current_liboctave_error_handler) ("FloatCHOL requires square matrix"); +} + +void +FloatCHOL::update (const FloatMatrix& u) +{ + octave_idx_type n = chol_mat.rows (); + + if (u.length () == n) + { + FloatMatrix tmp = u; + + OCTAVE_LOCAL_BUFFER (float, w, n); + + F77_XFCN (sch1up, SCH1UP, (n, chol_mat.fortran_vec (), + tmp.fortran_vec (), w)); + } + else + (*current_liboctave_error_handler) ("FloatCHOL update dimension mismatch"); +} + +octave_idx_type +FloatCHOL::downdate (const FloatMatrix& u) +{ + octave_idx_type info = -1; + + octave_idx_type n = chol_mat.rows (); + + if (u.length () == n) + { + FloatMatrix tmp = u; + + OCTAVE_LOCAL_BUFFER (float, w, n); + + F77_XFCN (sch1dn, SCH1DN, (n, chol_mat.fortran_vec (), + tmp.fortran_vec (), w, info)); + } + else + (*current_liboctave_error_handler) ("FloatCHOL downdate dimension mismatch"); + + return info; +} + +octave_idx_type +FloatCHOL::insert_sym (const FloatMatrix& u, octave_idx_type j) +{ + octave_idx_type info = -1; + + octave_idx_type n = chol_mat.rows (); + + if (u.length () != n+1) + (*current_liboctave_error_handler) ("FloatCHOL insert dimension mismatch"); + else if (j < 0 || j > n) + (*current_liboctave_error_handler) ("FloatCHOL insert index out of range"); + else + { + FloatMatrix chol_mat1 (n+1, n+1); + + F77_XFCN (schinx, SCHINX, (n, chol_mat.data (), chol_mat1.fortran_vec (), + j+1, u.data (), info)); + + chol_mat = chol_mat1; + } + + return info; +} + +void +FloatCHOL::delete_sym (octave_idx_type j) +{ + octave_idx_type n = chol_mat.rows (); + + if (j < 0 || j > n-1) + (*current_liboctave_error_handler) ("FloatCHOL delete index out of range"); + else + { + FloatMatrix chol_mat1 (n-1, n-1); + + F77_XFCN (schdex, SCHDEX, (n, chol_mat.data (), chol_mat1.fortran_vec (), j+1)); + + chol_mat = chol_mat1; + } +} + +void +FloatCHOL::shift_sym (octave_idx_type i, octave_idx_type j) +{ + octave_idx_type n = chol_mat.rows (); + float dummy; + + if (i < 0 || i > n-1 || j < 0 || j > n-1) + (*current_liboctave_error_handler) ("FloatCHOL shift index out of range"); + else + F77_XFCN (sqrshc, SQRSHC, (0, n, n, &dummy, chol_mat.fortran_vec (), i+1, j+1)); +} + +FloatMatrix +chol2inv (const FloatMatrix& r) +{ + return chol2inv_internal (r); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/