linear-algebra/0000755000175000017500000000000011756365433013276 5ustar juanpijuanpilinear-algebra/src/0000755000175000017500000000000011756365433014065 5ustar juanpijuanpilinear-algebra/src/pgmres.cc0000644000175000017500000001746111743761216015675 0ustar juanpijuanpi// Copyright (C) 2009 Carlo de Falco // // This program 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. // // 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. See the GNU General Public License for more // details. // // You should have received a copy of the GNU General Public License along with // this program; if not, see . #include #include #include #include class matrixfreematrix { public: virtual ColumnVector operator * (ColumnVector) = 0; }; class matrixfreematrixfun: public matrixfreematrix { private: octave_function *fun; public: matrixfreematrixfun (octave_value); ColumnVector operator * (ColumnVector); }; class matrixfreematrixmat: public matrixfreematrix { private: SparseMatrix mat; public: matrixfreematrixmat (octave_value); ColumnVector operator * (ColumnVector); }; class matrixfreematrixinvmat: public matrixfreematrix { private: SparseMatrix mat; public: matrixfreematrixinvmat (octave_value); ColumnVector operator * (ColumnVector); }; bool converged (double pbn, double prn, octave_idx_type iter, double prtol, octave_idx_type max_it) { return (((prtol != 0) && (prn <= prtol*pbn)) || (iter >= max_it)); } //----------------------//----------------------// DEFUN_DLD(pgmres,args,nargout,"\ \n [x, resids] = pgmres (A, b, x0, rtol, maxit, m, P)\ \n\ \n Solves A x = b using the Preconditioned GMRES iterative method\ \n with restart a.k.a. PGMRES(m).\ \n\n rtol is the relative tolerance,\ \n maxit the maximum number of iterations,\ \n x0 the initial guess and \ \n m is the restart parameter.\ \n\n A can be passed as a matrix or as a function handle or \ \n inline function f such that f(x) = A*x.\ \n\n The preconditioner P can be passed as a matrix or as a function handle or \ \n inline function g such that g(x) = P\\x.\n\n") { warning("'pgmres' has been deprecated in favor of 'gmres' now part of Octave core. This function will be removed from future versions of the 'linear-algebra' package"); octave_value_list retval; int nargin = args.length(); if (nargin != 7) { print_usage (); } else { matrixfreematrix *A=NULL, *invP=NULL; Matrix V, H; ColumnVector b, x0, x_old, res, B, resids; ColumnVector x, tmp, Y, little_res, ret; double prtol, prn, pbn; octave_idx_type max_it, restart, iter = 0, reit; // arg #1 if (args(0).is_function_handle () || args(0).is_inline_function ()) A = new matrixfreematrixfun (args (0)); else if (args(0).is_real_matrix ()) A = new matrixfreematrixmat (args (0)); else error ("pgmres: first argument is expected to be a function or matrix"); // arg #2 b = args(1).column_vector_value (); // arg #3 x0 = args(2).column_vector_value (); // arg #4 prtol = args(3).double_value (); // arg #5 max_it = args(4).idx_type_value (); // arg #6 restart = args(5).idx_type_value (); // arg #7 if (args(6).is_function_handle () || args(6).is_inline_function ()) invP = new matrixfreematrixfun (args (6)); else if (args(6).is_real_matrix ()) invP = new matrixfreematrixinvmat (args (6)); else error ("pgmres: last argument is expected to be a function or matrix"); if (! error_state) { x_old = x0; x = x_old; res = b - (*A) * x_old; res = (*invP) * res; prn = xnorm (res, 2.0); B = ColumnVector (restart + 1, 0.0); B(0) = prn; //begin loop iter = 0; reit = restart + 1; resids(0) = prn; pbn = xnorm ((*invP) * b, 2.0); while (! converged(pbn, prn, iter, prtol, max_it)) { // restart if (reit > restart) { reit = 1; x_old = x; res = b - (*A) * x_old; res = (*invP) * res; prn = xnorm (res, 2.0); B(0) = prn; H = Matrix (1, 1, 0.0); V = Matrix (b.length (), 1, 0.0); for (octave_idx_type ii = 0; ii < V.rows (); ii++) V(ii,0) = res(ii) / prn; } //basic iteration tmp = (*A) * (V.column (reit-1)); tmp = (*invP) * tmp; H.resize (reit+1, reit, 0.0); for (octave_idx_type j = 0; j < reit; j++) { H(j, reit-1) = (V.column (j).transpose ()) * tmp; tmp = tmp - (H (j, reit-1) * V.column (j)); } H(reit, reit-1) = xnorm (tmp, 2.0); V = V.append (tmp / H(reit, reit-1)); Y = (H.lssolve (B.extract_n (0, reit+1))); little_res = B.extract_n (0,reit+1) - H * Y.extract_n (0,reit); prn = xnorm (little_res, 2.0); x = x_old + V.extract_n (0, 0, V.rows (), reit) * Y.extract_n (0, reit); resids.resize (iter+1); resids(iter++) = prn ; reit++ ; } retval(1) = octave_value(resids); retval(0) = octave_value(x); } else print_usage (); delete A; delete invP; } return retval; } //----------------------//----------------------// matrixfreematrixfun::matrixfreematrixfun (octave_value A) { fun = A.function_value (); if (error_state) error ("error extracting function from first argument"); } ColumnVector matrixfreematrixfun::operator * (ColumnVector b) { ColumnVector res; octave_value_list retval; retval = feval (fun, octave_value(b), 1); res = retval(0).column_vector_value (); if ( error_state) { error ("error applying linear operator"); } return res; } //----------------------//----------------------// matrixfreematrixmat::matrixfreematrixmat (octave_value A) { mat = A.sparse_matrix_value (); if (error_state) error ("error extracting matrix value from first argument"); } ColumnVector matrixfreematrixmat::operator * (ColumnVector b) { return ColumnVector (mat * Matrix(b)); } //----------------------//----------------------// matrixfreematrixinvmat::matrixfreematrixinvmat (octave_value A) { mat = A.sparse_matrix_value (); if (error_state) error ("error extracting matrix value from first argument"); } ColumnVector matrixfreematrixinvmat::operator * (ColumnVector b) { return mat.solve(b); } /* %!shared A, b, dim %!test %! dim = 300; %! A = spdiags ([-ones(dim,1) 2*ones(dim,1) ones(dim,1)], [-1:1], dim, dim); %! b = ones(dim, 1); %! [x, resids] = pgmres (A, b, b, 1e-10,dim, dim, @(x) x./diag(A)); %! assert(x, A\b, 1e-9*norm(x,inf)) %! %!test %! [x, resids] = pgmres (A, b, b, 1e-10, 1e4, dim, @(x) diag(diag(A))\x); %! assert(x, A\b, 1e-7*norm(x,inf)) %! %!test %! A = sprandn (dim, dim, .1); %! A = A'*A; %! b = rand (dim, 1); %! [x, resids] = pgmres (@(x) A*x, b, b, 1e-10, dim, dim, @(x) diag(diag(A))\x); %! assert(x, A\b, 1e-9*norm(x,inf)) %! [x, resids] = pgmres (A, b, b, 1e-10, dim, dim, @(x) diag(diag(A))\x); %! assert(x, A\b, 1e-9*norm(x,inf)) %! %!test %! [x, resids] = pgmres (A, b, b, 1e-10, 1e6, dim, @(x) x./diag(A)); %! assert(x, A\b, 1e-7*norm(x,inf)) */ linear-algebra/src/dbleGSVD.cc0000644000175000017500000002104711743761216015765 0ustar juanpijuanpi// Copyright (C) 1996, 1997 John W. Eaton // Copyright (C) 2006 Pascal Dupuis // // This program 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. // // 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. See the GNU General Public License for more // details. // // You should have received a copy of the GNU General Public License along with // this program; if not, see . #ifdef HAVE_CONFIG_H #include #endif #include #include "dbleGSVD.h" #include "f77-fcn.h" /* uncomment those lines to monitor k and l #include "oct-obj.h" #include "pager.h" */ extern "C" { F77_RET_T F77_FUNC (dggsvd, DGGSVD) ( F77_CONST_CHAR_ARG_DECL, // JOBU (input) CHARACTER*1 F77_CONST_CHAR_ARG_DECL, // JOBV (input) CHARACTER*1 F77_CONST_CHAR_ARG_DECL, // JOBQ (input) CHARACTER*1 const octave_idx_type&, // M (input) INTEGER const octave_idx_type&, // N (input) INTEGER const octave_idx_type&, // P (input) INTEGER octave_idx_type &, // K (output) INTEGER octave_idx_type &, // L (output) INTEGER double*, // A (input/output) DOUBLE PRECISION array, dimension (LDA,N) const octave_idx_type&, // LDA (input) INTEGER double*, // B (input/output) DOUBLE PRECISION array, dimension (LDB,N) const octave_idx_type&, // LDB (input) INTEGER double*, // ALPHA (output) DOUBLE PRECISION array, dimension (N) double*, // BETA (output) DOUBLE PRECISION array, dimension (N) double*, // U (output) DOUBLE PRECISION array, dimension (LDU,M) const octave_idx_type&, // LDU (input) INTEGER double*, // V (output) DOUBLE PRECISION array, dimension (LDV,P) const octave_idx_type&, // LDV (input) INTEGER double*, // Q (output) DOUBLE PRECISION array, dimension (LDQ,N) const octave_idx_type&, // LDQ (input) INTEGER double*, // WORK (workspace) DOUBLE PRECISION array int*, // IWORK (workspace/output) INTEGER array, dimension (N) octave_idx_type& // INFO (output)INTEGER F77_CHAR_ARG_LEN_DECL F77_CHAR_ARG_LEN_DECL F77_CHAR_ARG_LEN_DECL ); } Matrix GSVD::left_singular_matrix_A (void) const { if (type_computed == GSVD::sigma_only) { (*current_liboctave_error_handler) ("dbleGSVD: U not computed because type == GSVD::sigma_only"); return Matrix (); } else return left_smA; } Matrix GSVD::left_singular_matrix_B (void) const { if (type_computed == GSVD::sigma_only) { (*current_liboctave_error_handler) ("dbleGSVD: V not computed because type == GSVD::sigma_only"); return Matrix (); } else return left_smB; } Matrix GSVD::right_singular_matrix (void) const { if (type_computed == GSVD::sigma_only) { (*current_liboctave_error_handler) ("dbleGSVD: X not computed because type == GSVD::sigma_only"); return Matrix (); } else return right_sm; } Matrix GSVD::R_matrix (void) const { if (type_computed != GSVD::std) { (*current_liboctave_error_handler) ("dbleGSVD: R not computed because type != GSVD::std"); return Matrix (); } else return R; } octave_idx_type GSVD::init (const Matrix& a, const Matrix& b, GSVD::type gsvd_type) { octave_idx_type info; octave_idx_type m = a.rows (); octave_idx_type n = a.cols (); octave_idx_type p = b.rows (); Matrix atmp = a; double *tmp_dataA = atmp.fortran_vec (); Matrix btmp = b; double *tmp_dataB = btmp.fortran_vec (); // octave_idx_type min_mn = m < n ? m : n; char jobu = 'U'; char jobv = 'V'; char jobq = 'Q'; octave_idx_type nrow_u = m; octave_idx_type nrow_v = p; octave_idx_type nrow_q = n; octave_idx_type k, l; switch (gsvd_type) { case GSVD::sigma_only: // Note: for this case, both jobu and jobv should be 'N', but // there seems to be a bug in dgesvd from Lapack V2.0. To // demonstrate the bug, set both jobu and jobv to 'N' and find // the singular values of [eye(3), eye(3)]. The result is // [-sqrt(2), -sqrt(2), -sqrt(2)]. // // For Lapack 3.0, this problem seems to be fixed. jobu = 'N'; jobv = 'N'; jobq = 'N'; nrow_u = nrow_v = nrow_q = 1; break; default: break; } type_computed = gsvd_type; if (! (jobu == 'N' || jobu == 'O')) { left_smA.resize (nrow_u, m); } double *u = left_smA.fortran_vec (); if (! (jobv == 'N' || jobv == 'O')) { left_smB.resize (nrow_v, p); } double *v = left_smB.fortran_vec (); if (! (jobq == 'N' || jobq == 'O')) { right_sm.resize (nrow_q, n); } double *q = right_sm.fortran_vec (); octave_idx_type lwork = 3*n; lwork = lwork > m ? lwork : m; lwork = (lwork > p ? lwork : p) + n; Array work (lwork, 1); Array alpha (n, 1); Array beta (n, 1); Array iwork (n, 1); F77_XFCN (dggsvd, DGGSVD, (F77_CONST_CHAR_ARG2 (&jobu, 1), F77_CONST_CHAR_ARG2 (&jobv, 1), F77_CONST_CHAR_ARG2 (&jobq, 1), m, n, p, k, l, tmp_dataA, m, tmp_dataB, p, alpha.fortran_vec (), beta.fortran_vec (), u, nrow_u, v, nrow_v, q, nrow_q, work.fortran_vec (), iwork.fortran_vec (), info F77_CHAR_ARG_LEN (1) F77_CHAR_ARG_LEN (1) F77_CHAR_ARG_LEN (1))); if (f77_exception_encountered) (*current_liboctave_error_handler) ("unrecoverable error in dggsvd"); if (info < 0) { (*current_liboctave_error_handler) ("dggsvd.f: argument %d illegal", -info); } else { if (info > 0) { (*current_liboctave_error_handler) ("dggsvd.f: Jacobi-type procedure failed to converge."); } else { octave_idx_type i, j; if (GSVD::std == gsvd_type) { R.resize(k+l, k+l); int astart = n-k-l; if (m - k - l >= 0) { int astart = n-k-l; /* * R is stored in A(1:K+L,N-K-L+1:N) */ for (i = 0; i < k+l; i++) for (j = 0; j < k+l; j++) R.xelem(i, j) = atmp.xelem(i, astart + j); } else { /* * (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), * ( 0 R22 R23 ) */ for (i = 0; i < m; i++) for (j = 0; j < k+l; j++) R.xelem(i, j) = atmp.xelem(i, astart + j); /* * and R33 is stored in B(M-K+1:L,N+M-K-L+1:N) */ for (i = k+l-1; i >=m; i--) { for (j = 0; j < m; j++) R.xelem(i, j) = 0.0; for (j = m; j < k+l; j++) R.xelem(i, j) = btmp.xelem(i - k, astart + j); } } } /* uncomment this to monitor k and l octave_value tmp; octave_stdout << "dbleGSVD k: "; tmp = k; tmp.print(octave_stdout); octave_stdout << "\n"; octave_stdout << "dbleGSVD l: "; tmp = l; tmp.print(octave_stdout); octave_stdout << "\n"; */ if (m-k-l >= 0) { // Fills in C and S sigmaA.resize (l, l); sigmaB.resize (l, l); for (i = 0; i < l; i++) { sigmaA.dgxelem(i) = alpha.elem(k+i); sigmaB.dgxelem(i) = beta.elem(k+i); } } else { // Fills in C and S sigmaA.resize (m-k, m-k); sigmaB.resize (m-k, m-k); for (i = 0; i < m-k; i++) { sigmaA.dgxelem(i) = alpha.elem(k+i); sigmaB.dgxelem(i) = beta.elem(k+i); } } } } return info; } std::ostream& operator << (std::ostream& os, const GSVD& a) { os << a.left_singular_matrix_A () << "\n"; os << a.left_singular_matrix_B () << "\n"; os << a.singular_values_A () << "\n"; os << a.singular_values_B () << "\n"; os << a.right_singular_matrix () << "\n"; return os; } linear-algebra/src/autogen.sh0000755000175000017500000000132210747712404016055 0ustar juanpijuanpi#! /bin/sh ## Generate ./configure rm -f configure.in echo "dnl --- DO NOT EDIT --- Automatically generated by autogen.sh" > configure.in cat configure.base >> configure.in cat <> configure.in AC_OUTPUT(\$CONFIGURE_OUTPUTS) dnl XXX FIXME XXX chmod is not in autoconf's list of portable functions echo " " echo " \"\\\$prefix\" is \$prefix" echo " \"\\\$exec_prefix\" is \$exec_prefix" AC_MSG_RESULT([\$STATUS_MSG find . -name NOINSTALL -print # shows which toolboxes won't be installed ]) EOF autoconf configure.in > configure.tmp if [ diff configure.tmp configure > /dev/null 2>&1 ]; then rm -f configure.tmp; else mv -f configure.tmp configure chmod 0755 configure fi rm -f configure.in linear-algebra/src/configure.base0000644000175000017500000002206310473652132016673 0ustar juanpijuanpidnl The configure script is generated by autogen.sh from configure.base dnl and the various configure.add files in the source tree. Edit dnl configure.base and reprocess rather than modifying ./configure. dnl autoconf 2.13 certainly doesn't work! What is the minimum requirement? AC_PREREQ(2.2) AC_INIT(configure.base) PACKAGE=octave-forge MAJOR_VERSION=0 MINOR_VERSION=1 PATCH_LEVEL=0 dnl Kill caching --- this ought to be the default define([AC_CACHE_LOAD], )dnl define([AC_CACHE_SAVE], )dnl dnl uncomment to put support files in another directory dnl AC_CONFIG_AUX_DIR(admin) VERSION=$MAJOR_VERSION.$MINOR_VERSION.$PATCH_LEVEL AC_SUBST(PACKAGE) AC_SUBST(VERSION) dnl need to find admin files, so keep track of the top dir. TOPDIR=`pwd` AC_SUBST(TOPDIR) dnl if mkoctfile doesn't work, then we need the following: dnl AC_PROG_CXX dnl AC_PROG_F77 dnl Need C compiler regardless so define it in a way that dnl makes autoconf happy and we can override whatever we dnl need with mkoctfile -p. dnl XXX FIXME XXX should use mkoctfile to get CC and CFLAGS AC_PROG_CC dnl XXX FIXME XXX need tests for -p -c -s in mkoctfile. dnl ******************************************************************* dnl Sort out mkoctfile version number and install paths dnl XXX FIXME XXX latest octave has octave-config so we don't dnl need to discover things here. Doesn't have --exe-site-dir dnl but defines --oct-site-dir and --m-site-dir dnl Check for mkoctfile AC_CHECK_PROG(MKOCTFILE,mkoctfile,mkoctfile) test -z "$MKOCTFILE" && AC_MSG_WARN([no mkoctfile found on path]) AC_SUBST(ver) AC_SUBST(subver) AC_SUBST(mpath) AC_SUBST(opath) AC_SUBST(xpath) AC_SUBST(altpath) AC_SUBST(altmpath) AC_SUBST(altopath) AC_ARG_WITH(path, [ --with-path install path prefix], [ path=$withval ]) AC_ARG_WITH(mpath, [ --with-mpath override path for m-files], [mpath=$withval]) AC_ARG_WITH(opath, [ --with-opath override path for oct-files], [opath=$withval]) AC_ARG_WITH(xpath, [ --with-xpath override path for executables], [xpath=$withval]) AC_ARG_WITH(altpath, [ --with-altpath alternative functions install path prefix], [ altpath=$withval ]) AC_ARG_WITH(altmpath, [ --with-altmpath override path for alternative m-files], [altmpath=$withval]) AC_ARG_WITH(altopath, [ --with-altopath override path for alternative oct-files], [altopath=$withval]) if test -n "$path" ; then test -z "$mpath" && mpath=$path test -z "$opath" && opath=$path/oct test -z "$xpath" && xpath=$path/bin test -z "$altpath" && altpath=$path-alternatives fi if test -n "$altpath" ; then test -z "$altmpath" && altmpath=$altpath test -z "$altopath" && altopath=$altpath/oct fi dnl Don't query if path/ver are given in the configure environment #if test -z "$mpath" || test -z "$opath" || test -z "$xpath" || test -z "$altmpath" || test -z "$altopath" || test -z "$ver" ; then if test -z "$mpath" || test -z "$opath" || test -z "$xpath" || test -z "$ver" ; then dnl Construct program to get mkoctfile version and local install paths cat > conftest.cc < #include #include #define INFOV "\nINFOV=" OCTAVE_VERSION "\n" #define INFOH "\nINFOH=" OCTAVE_CANONICAL_HOST_TYPE "\n" #ifdef OCTAVE_LOCALVERFCNFILEDIR # define INFOM "\nINFOM=" OCTAVE_LOCALVERFCNFILEDIR "\n" #else # define INFOM "\nINFOM=" OCTAVE_LOCALFCNFILEPATH "\n" #endif #ifdef OCTAVE_LOCALVEROCTFILEDIR # define INFOO "\nINFOO=" OCTAVE_LOCALVEROCTFILEDIR "\n" #else # define INFOO "\nINFOO=" OCTAVE_LOCALOCTFILEPATH "\n" #endif #ifdef OCTAVE_LOCALVERARCHLIBDIR # define INFOX "\nINFOX=" OCTAVE_LOCALVERARCHLIBDIR "\n" #else # define INFOX "\nINFOX=" OCTAVE_LOCALARCHLIBDIR "\n" #endif const char *infom = INFOM; const char *infoo = INFOO; const char *infox = INFOX; const char *infoh = INFOH; const char *infov = INFOV; EOF dnl Compile program perhaps with a special version of mkoctfile $MKOCTFILE conftest.cc || AC_MSG_ERROR(Could not run $MKOCTFILE) dnl Strip the config info from the compiled file eval `strings conftest.o | grep "^INFO.=" | sed -e "s,//.*$,,"` rm -rf conftest* dnl set the appropriate variables if they are not already set ver=`echo $INFOV | sed -e "s/\.//" -e "s/\..*$//"` subver=`echo $INFOV | sed -e "[s/^[^.]*[.][^.]*[.]//]"` alt_mbase=`echo $INFOM | sed -e "[s,\/[^\/]*$,,]"` alt_obase=`echo $INFOO | sed -e "[s,/site.*$,/site,]"` test -z "$mpath" && mpath=$INFOM/octave-forge test -z "$opath" && opath=$INFOO/octave-forge test -z "$xpath" && xpath=$INFOX test -z "$altmpath" && altmpath=$alt_mbase/octave-forge-alternatives/m test -z "$altopath" && altopath=$alt_obase/octave-forge-alternatives/oct/$INFOH fi dnl ******************************************************************* dnl XXX FIXME XXX Should we allow the user to override these? dnl Do we even need them? The individual makefiles can call mkoctfile -p dnl themselves, so the only reason to keep them is for configure, and dnl for those things which are not built using mkoctfile (e.g., aurecord) dnl but it is not clear we should be using octave compile flags for those. dnl C compiler and flags AC_MSG_RESULT([retrieving compile and link flags from $MKOCTFILE]) CC=`$MKOCTFILE -p CC` CFLAGS=`$MKOCTFILE -p CFLAGS` CPPFLAGS=`$MKOCTFILE -p CPPFLAGS` CPICFLAG=`$MKOCTFILE -p CPICFLAG` LDFLAGS=`$MKOCTFILE -p LDFLAGS` LIBS=`$MKOCTFILE -p LIBS` AC_SUBST(CC) AC_SUBST(CFLAGS) AC_SUBST(CPPFLAGS) AC_SUBST(CPICFLAG) dnl Fortran compiler and flags F77=`$MKOCTFILE -p F77` FFLAGS=`$MKOCTFILE -p FFLAGS` FPICFLAG=`$MKOCTFILE -p FPICFLAG` AC_SUBST(F77) AC_SUBST(FFLAGS) AC_SUBST(FPICFLAG) dnl C++ compiler and flags CXX=`$MKOCTFILE -p CXX` CXXFLAGS=`$MKOCTFILE -p CXXFLAGS` CXXPICFLAG=`$MKOCTFILE -p CXXPICFLAG` AC_SUBST(CXX) AC_SUBST(CXXFLAGS) AC_SUBST(CXXPICFLAG) dnl ******************************************************************* dnl Check for features of your version of mkoctfile. dnl All checks should be designed so that the default dnl action if the tests are not performed is to do whatever dnl is appropriate for the most recent version of Octave. dnl Define the following macro: dnl OF_CHECK_LIB(lib,fn,true,false,helpers) dnl This is just like AC_CHECK_LIB, but it doesn't update LIBS AC_DEFUN(OF_CHECK_LIB, [save_LIBS="$LIBS" AC_CHECK_LIB($1,$2,$3,$4,$5) LIBS="$save_LIBS" ]) dnl Define the following macro: dnl TRY_MKOCTFILE(msg,program,action_if_true,action_if_false) dnl AC_DEFUN(TRY_MKOCTFILE, [AC_MSG_CHECKING($1) cat > conftest.cc << EOF #include $2 EOF ac_try="$MKOCTFILE -c conftest.cc" if AC_TRY_EVAL(ac_try) ; then AC_MSG_RESULT(yes) $3 else AC_MSG_RESULT(no) $4 fi ]) dnl dnl Check if F77_FUNC works with MKOCTFILE dnl TRY_MKOCTFILE([for F77_FUNC], [int F77_FUNC (hello, HELLO) (const int &n);],, [MKOCTFILE="$MKOCTFILE -DF77_FUNC=F77_FCN"]) dnl ********************************************************** dnl Evaluate an expression in octave dnl dnl OCTAVE_EVAL(expr,var) -> var=expr dnl AC_DEFUN(OCTAVE_EVAL, [AC_MSG_CHECKING([for $1 in Octave]) $2=`echo "disp($1)" | $OCTAVE -qf` AC_MSG_RESULT($$2) AC_SUBST($2) ]) dnl Check status of an octave variable dnl dnl OCTAVE_CHECK_EXIST(variable,action_if_true,action_if_false) dnl AC_DEFUN(OCTAVE_CHECK_EXIST, [AC_MSG_CHECKING([for $1 in Octave]) if test `echo 'disp(exist("$1"))' | $OCTAVE -qf`X != 0X ; then AC_MSG_RESULT(yes) $2 else AC_MSG_RESULT(no) $3 fi ]) dnl should check that $(OCTAVE) --version matches $(MKOCTFILE) --version AC_CHECK_PROG(OCTAVE,octave,octave) OCTAVE_EVAL(OCTAVE_VERSION,OCTAVE_VERSION) dnl grab canonical host type so we can write system specific install stuff OCTAVE_EVAL(octave_config_info('canonical_host_type'),canonical_host_type) dnl grab SHLEXT from octave config OCTAVE_EVAL(octave_config_info('SHLEXT'),SHLEXT) AC_PROG_LN_S AC_PROG_RANLIB dnl Use $(COPY_FLAGS) to set options for cp when installing .oct files. COPY_FLAGS="-Rfp" case "$canonical_host_type" in *-*-linux*) COPY_FLAGS="-fdp" ;; esac AC_SUBST(COPY_FLAGS) dnl Use $(STRIP) in the makefile to strip executables. If not found, dnl STRIP expands to ':', which in the makefile does nothing. dnl Don't need this for .oct files since mkoctfile handles them directly STRIP=${STRIP-strip} AC_CHECK_PROG(STRIP,$STRIP,$STRIP,:) dnl Strip on windows, don't strip on Mac OS/X or IRIX dnl For the rest, you can force strip using MKOCTFILE="mkoctfile -s" dnl or avoid strip using STRIP=: before ./configure case "$canonical_host_type" in powerpc-apple-darwin*|*-sgi-*) STRIP=: ;; *-cygwin-*|*-mingw-*) MKOCTFILE="$MKOCTFILE -s" ;; esac CONFIGURE_OUTPUTS="Makeconf" STATUS_MSG=" octave commands will install into the following directories: m-files: $mpath oct-files: $opath binaries: $xpath alternatives: m-files: $altmpath oct-files: $altopath shell commands will install into the following directories: binaries: $bindir man pages: $mandir libraries: $libdir headers: $includedir octave-forge is configured with octave: $OCTAVE (version $OCTAVE_VERSION) mkoctfile: $MKOCTFILE for Octave $subver" linear-algebra/src/gsvd.cc0000644000175000017500000003442111743761216015336 0ustar juanpijuanpi// Copyright (C) 1996, 1997 John W. Eaton // Copyright (C) 2006, 2010 Pascal Dupuis // // This program 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. // // 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. See the GNU General Public License for more // details. // // You should have received a copy of the GNU General Public License along with // this program; if not, see . #ifdef HAVE_CONFIG_H #include #endif #include "CmplxGSVD.h" #include "dbleGSVD.h" #include "defun-dld.h" #include "error.h" #include "gripes.h" #include "oct-obj.h" #include "pr-output.h" #include "utils.h" DEFUN_DLD (gsvd, args, nargout, "-*- texinfo -*-\n\ @deftypefn {Loadable Function} {@var{s} =} gsvd (@var{a}, @var{b})\n\ @deftypefnx {Loadable Function} {[@var{u}, @var{v}, @var{c}, @var{s}, @var{x} [, @var{r}]] =} gsvd (@var{a}, @var{b})\n\ @cindex generalised singular value decomposition\n\ Compute the generalised singular value decomposition of (@var{a}, @var{b}):\n\ @iftex\n\ @tex\n\ $$\n\ U^H A X = [I 0; 0 C] [0 R]\n\ V^H B X = [0 S; 0 0] [0 R]\n\ C*C + S*S = eye(columns(A))\n\ I and 0 are padding matrices of suitable size\n\ R is upper triangular\n\ $$\n\ @end tex\n\ @end iftex\n\ @ifinfo\n\ \n\ @example\n\ u' * a * x = [I 0; 0 c] * [0 r]\n\ v' * b * x = [0 s; 0 0] * [0 r]\n\ c * c + s * s = eye(columns(a))\n\ I and 0 are padding matrices of suitable size\n\ r is upper triangular\n\ @end example\n\ @end ifinfo\n\ \n\ The function @code{gsvd} normally returns the vector of generalised singular\n\ values\n\ @iftex\n\ @tex\n\ diag(C)./diag(S).\n\ @end tex\n\ @end iftex\n\ @ifinfo\n\ diag(r)./diag(s).\n\ @end ifinfo\n\ If asked for five return values, it computes\n\ @iftex\n\ @tex\n\ $U$, $V$, and $X$.\n\ @end tex\n\ @end iftex\n\ @ifinfo\n\ U, V, and X.\n\ @end ifinfo\n\ With a sixth output argument, it also returns\n\ @iftex\n\ @tex\n\ R,\n\ @end tex\n\ @end iftex\n\ @ifinfo\n\ r,\n\ @end ifinfo\n\ The common upper triangular right term. Other authors, like S. Van Huffel,\n\ define this transformation as the simulatenous diagonalisation of the\n\ input matrices, this can be achieved by multiplying \n\ @iftex\n\ @tex\n\ X\n\ @end tex\n\ @end iftex\n\ @ifinfo\n\ x\n\ @end ifinfo\n\ by the inverse of\n\ @iftex\n\ @tex\n\ [I 0; 0 R].\n\ @end tex\n\ @end iftex\n\ @ifinfo\n\ [I 0; 0 r].\n\ @end ifinfo\n\ \n\ For example,\n\ \n\ @example\n\ gsvd (hilb (3), [1 2 3; 3 2 1])\n\ @end example\n\ \n\ @noindent\n\ returns\n\ \n\ @example\n\ ans =\n\ \n\ 0.1055705\n\ 0.0031759\n\ @end example\n\ \n\ @noindent\n\ and\n\ \n\ @example\n\ [u, v, c, s, x, r] = gsvd (hilb (3), [1 2 3; 3 2 1])\n\ @end example\n\ \n\ @noindent\n\ returns\n\ \n\ @example\n\ u =\n\ \n\ -0.965609 0.240893 0.097825\n\ -0.241402 -0.690927 -0.681429\n\ -0.096561 -0.681609 0.725317\n\ \n\ v =\n\ \n\ -0.41974 0.90765\n\ -0.90765 -0.41974\n\ \n\ c =\n\ \n\ 0.10499 0.00000\n\ 0.00000 0.00318\n\ \n\ s =\n\ 0.99447 0.00000\n\ 0.00000 0.99999\n\ x =\n\ \n\ 0.408248 0.902199 0.139179\n\ -0.816497 0.429063 -0.386314\n\ 0.408248 -0.044073 -0.911806\n\ \n\ r =\n\ -0.14093 -1.24345 0.43737\n\ 0.00000 -3.90043 2.57818\n\ 0.00000 0.00000 -2.52599\n\ \n\ @end example\n\ \n\ The code is a wrapper to the corresponding Lapack dggsvd and zggsvd routines.\n\ \n\ @end deftypefn\n") { octave_value_list retval; int nargin = args.length (); if (nargin < 2 || nargin > 2 || (nargout > 1 && (nargout < 5 || nargout > 6))) { print_usage (); return retval; } octave_value argA = args(0), argB = args(1); octave_idx_type nr = argA.rows (); octave_idx_type nc = argA.columns (); // octave_idx_type nn = argB.rows (); octave_idx_type np = argB.columns (); if (nr == 0 || nc == 0) { if (nargout >= 5) { for (int i = 3; i <= nargout; i++) retval(i) = identity_matrix (nr, nr); retval(2) = Matrix (nr, nc); retval(1) = identity_matrix (nc, nc); retval(0) = identity_matrix (nc, nc); } else retval(0) = Matrix (0, 1); } else { if ((nc != np)) { print_usage (); return retval; } GSVD::type type = ((nargout == 0 || nargout == 1) ? GSVD::sigma_only : (nargout > 5) ? GSVD::std : GSVD::economy ); if (argA.is_real_type () && argB.is_real_type ()) { Matrix tmpA = argA.matrix_value (); Matrix tmpB = argB.matrix_value (); if (! error_state) { if (tmpA.any_element_is_inf_or_nan ()) { error ("gsvd: cannot take GSVD of matrix containing Inf or NaN values"); return retval; } if (tmpB.any_element_is_inf_or_nan ()) { error ("gsvd: cannot take GSVD of matrix containing Inf or NaN values"); return retval; } GSVD result (tmpA, tmpB, type); // DiagMatrix sigma = result.singular_values (); if (nargout == 0 || nargout == 1) { DiagMatrix sigA = result.singular_values_A (); DiagMatrix sigB = result.singular_values_B (); for (int i = sigA.rows() - 1; i >=0; i--) sigA.dgxelem(i) /= sigB.dgxelem(i); retval(0) = sigA.diag(); } else { if (nargout > 5) retval(5) = result.R_matrix (); retval(4) = result.right_singular_matrix (); retval(3) = result.singular_values_B (); retval(2) = result.singular_values_A (); retval(1) = result.left_singular_matrix_B (); retval(0) = result.left_singular_matrix_A (); } } } else if (argA.is_complex_type () || argB.is_complex_type ()) { ComplexMatrix ctmpA = argA.complex_matrix_value (); ComplexMatrix ctmpB = argB.complex_matrix_value (); if (! error_state) { if (ctmpA.any_element_is_inf_or_nan ()) { error ("gsvd: cannot take GSVD of matrix containing Inf or NaN values"); return retval; } if (ctmpB.any_element_is_inf_or_nan ()) { error ("gsvd: cannot take GSVD of matrix containing Inf or NaN values"); return retval; } ComplexGSVD result (ctmpA, ctmpB, type); // DiagMatrix sigma = result.singular_values (); if (nargout == 0 || nargout == 1) { DiagMatrix sigA = result.singular_values_A (); DiagMatrix sigB = result.singular_values_B (); for (int i = sigA.rows() - 1; i >=0; i--) sigA.dgxelem(i) /= sigB.dgxelem(i); retval(0) = sigA.diag(); } else { if (nargout > 5) retval(5) = result.R_matrix (); retval(4) = result.right_singular_matrix (); retval(3) = result.singular_values_B (); retval(2) = result.singular_values_A (); retval(1) = result.left_singular_matrix_B (); retval(0) = result.left_singular_matrix_A (); } } } else { gripe_wrong_type_arg ("gsvd", argA); gripe_wrong_type_arg ("gsvd", argB); return retval; } } return retval; } /* %# a few tests for gsvd.m %!shared A, A0, B, B0, U, V, C, S, X, R, D1, D2 %! A0=randn(5, 3); B0=diag([1 2 4]); %! A = A0; B = B0; %! # disp('Full rank, 5x3 by 3x3 matrices'); %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(5, 3); D1(1:3, 1:3) = C; %! D2 = S; %!assert(norm(diag(C).^2+diag(S).^2 - ones(3, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp('A 5x3 full rank, B 3x3 rank deficient'); %! B(2, 2) = 0; %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(5, 3); D1(1, 1) = 1; D1(2:3, 2:3) = C; %! D2 = [zeros(2, 1) S; zeros(1, 3)]; %!assert(norm(diag(C).^2+diag(S).^2 - ones(2, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp('A 5x3 rank deficient, B 3x3 full rank'); %! B = B0; %! A(:, 3) = 2*A(:, 1) - A(:, 2); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(5, 3); D1(1:3, 1:3) = C; %! D2 = S; %!assert(norm(diag(C).^2+diag(S).^2 - ones(3, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp("A 5x3, B 3x3, [A' B'] rank deficient"); %! B(:, 3) = 2*B(:, 1) - B(:, 2); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(5, 2); D1(1:2, 1:2) = C; %! D2 = [S; zeros(1, 2)]; %!assert(norm(diag(C).^2+diag(S).^2 - ones(2, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*[zeros(2, 1) R]) <= 1e-6) %!assert(norm((V'*B*X)-D2*[zeros(2, 1) R]) <= 1e-6) %! # now, A is 3x5 %! A = A0.'; B0=diag([1 2 4 8 16]); B = B0; %! # disp('Full rank, 3x5 by 5x5 matrices'); %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = [C zeros(3,2)]; %! D2 = [S zeros(3,2); zeros(2, 3) eye(2)]; %!assert(norm(diag(C).^2+diag(S).^2 - ones(3, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp('A 5x3 full rank, B 5x5 rank deficient'); %! B(2, 2) = 0; %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(3, 5); D1(1, 1) = 1; D1(2:3, 2:3) = C; %! D2 = zeros(5, 5); D2(1:2, 2:3) = S; D2(3:4, 4:5) = eye(2); %!assert(norm(diag(C).^2+diag(S).^2 - ones(2, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp('A 3x5 rank deficient, B 5x5 full rank'); %! B = B0; %! A(3, :) = 2*A(1, :) - A(2, :); %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(3, 5); D1(1:3, 1:3) = C; %! D2 = zeros(5, 5); D2(1:3, 1:3) = S; D2(4:5, 4:5) = eye(2); %!assert(norm(diag(C).^2+diag(S).^2 - ones(3, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp("A 5x3, B 5x5, [A' B'] rank deficient"); %! A = A0.'; B = B0.'; %! A(:, 3) = 2*A(:, 1) - A(:, 2); %! B(:, 3) = 2*B(:, 1) - B(:, 2); %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R]=gsvd(A, B); %! D1 = zeros(3, 4); D1(1:3, 1:3) = C; %! D2 = eye(4); D2(1:3, 1:3) = S; D2(5,:) = 0; %!assert(norm(diag(C).^2+diag(S).^2 - ones(3, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*[zeros(4, 1) R]) <= 1e-6) %!assert(norm((V'*B*X)-D2*[zeros(4, 1) R]) <= 1e-6) %! A0 = A0 +j * randn(5, 3); B0 = B0=diag([1 2 4]) + j*diag([4 -2 -1]); %! A = A0; B = B0; %! # disp('Complex: Full rank, 5x3 by 3x3 matrices'); %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(5, 3); D1(1:3, 1:3) = C; %! D2 = S; %!assert(norm(diag(C).^2+diag(S).^2 - ones(3, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp('Complex: A 5x3 full rank, B 3x3 rank deficient'); %! B(2, 2) = 0; %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(5, 3); D1(1, 1) = 1; D1(2:3, 2:3) = C; %! D2 = [zeros(2, 1) S; zeros(1, 3)]; %!assert(norm(diag(C).^2+diag(S).^2 - ones(2, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp('Complex: A 5x3 rank deficient, B 3x3 full rank'); %! B = B0; %! A(:, 3) = 2*A(:, 1) - A(:, 2); %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(5, 3); D1(1:3, 1:3) = C; %! D2 = S; %!assert(norm(diag(C).^2+diag(S).^2 - ones(3, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp("Complex: A 5x3, B 3x3, [A' B'] rank deficient"); %! B(:, 3) = 2*B(:, 1) - B(:, 2); %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(5, 2); D1(1:2, 1:2) = C; %! D2 = [S; zeros(1, 2)]; %!assert(norm(diag(C).^2+diag(S).^2 - ones(2, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*[zeros(2, 1) R]) <= 1e-6) %!assert(norm((V'*B*X)-D2*[zeros(2, 1) R]) <= 1e-6) %! # now, A is 3x5 %! A = A0.'; B0=diag([1 2 4 8 16])+j*diag([-5 4 -3 2 -1]); %! B = B0; %! # disp('Complex: Full rank, 3x5 by 5x5 matrices'); %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = [C zeros(3,2)]; %! D2 = [S zeros(3,2); zeros(2, 3) eye(2)]; %!assert(norm(diag(C).^2+diag(S).^2 - ones(3, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp('Complex: A 5x3 full rank, B 5x5 rank deficient'); %! B(2, 2) = 0; %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(3, 5); D1(1, 1) = 1; D1(2:3, 2:3) = C; %! D2 = zeros(5,5); D2(1:2, 2:3) = S; D2(3:4, 4:5) = eye(2); %!assert(norm(diag(C).^2+diag(S).^2 - ones(2, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp('Complex: A 3x5 rank deficient, B 5x5 full rank'); %! B = B0; %! A(3, :) = 2*A(1, :) - A(2, :); %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R] = gsvd(A, B); %! D1 = zeros(3, 5); D1(1:3, 1:3) = C; %! D2 = zeros(5,5); D2(1:3, 1:3) = S; D2(4:5, 4:5) = eye(2); %!assert(norm(diag(C).^2+diag(S).^2 - ones(3, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*R) <= 1e-6) %!assert(norm((V'*B*X)-D2*R) <= 1e-6) %! # disp("Complex: A 5x3, B 5x5, [A' B'] rank deficient"); %! A = A0.'; B = B0.'; %! A(:, 3) = 2*A(:, 1) - A(:, 2); %! B(:, 3) = 2*B(:, 1) - B(:, 2); %! # disp([rank(A) rank(B) rank([A' B'])]); %! [U, V, C, S, X, R]=gsvd(A, B); %! D1 = zeros(3, 4); D1(1:3, 1:3) = C; %! D2 = eye(4); D2(1:3, 1:3) = S; D2(5,:) = 0; %!assert(norm(diag(C).^2+diag(S).^2 - ones(3, 1)) <= 1e-6) %!assert(norm((U'*A*X)-D1*[zeros(4, 1) R]) <= 1e-6) %!assert(norm((V'*B*X)-D2*[zeros(4, 1) R]) <= 1e-6) */ linear-algebra/src/Makeconf.in0000644000175000017500000000302410731466235016131 0ustar juanpijuanpi ## Makeconf is automatically generated from Makeconf.base and Makeconf.add ## in the various subdirectories. To regenerate, use ./autogen.sh to ## create a new ./Makeconf.in, then use ./configure to generate a new ## Makeconf. OCTAVE_FORGE = 1 SHELL = @SHELL@ canonical_host_type = @canonical_host_type@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ mandir = @mandir@ libdir = @libdir@ datadir = @datadir@ infodir = @infodir@ includedir = @includedir@ datarootdir = @datarootdir@ INSTALL = @INSTALL@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_DATA = @INSTALL_DATA@ INSTALLOCT=octinst.sh DESTDIR = RANLIB = @RANLIB@ STRIP = @STRIP@ LN_S = @LN_S@ AWK = @AWK@ # Most octave programs will be compiled with $(MKOCTFILE). Those which # cannot use mkoctfile directly can request the flags that mkoctfile # would use as follows: # FLAG = $(shell $(MKOCTFILE) -p FLAG) # The following flags are for compiling programs that are independent # of Octave. How confusing. CC = @CC@ CFLAGS = @CFLAGS@ CPPFLAGS = @CPPFLAGS@ CPICFLAG = @CPICFLAG@ CXX = @CXX@ CXXFLAGS = @CXXFLAGS@ CXXPICFLAG = @CXXPICFLAG@ F77 = @F77@ FFLAGS = @FFLAGS@ FPICFLAG = @FPICFLAG@ OCTAVE = @OCTAVE@ OCTAVE_VERSION = @OCTAVE_VERSION@ MKOCTFILE = @MKOCTFILE@ -DHAVE_OCTAVE_$(ver) -v SHLEXT = @SHLEXT@ ver = @ver@ MPATH = @mpath@ OPATH = @opath@ XPATH = @xpath@ ALTMPATH = @altmpath@ ALTOPATH = @altopath@ %.o: %.c ; $(MKOCTFILE) -c $< %.o: %.f ; $(MKOCTFILE) -c $< %.o: %.cc ; $(MKOCTFILE) -c $< %.oct: %.cc ; $(MKOCTFILE) $< linear-algebra/src/Makefile0000644000175000017500000000204311703076260015511 0ustar juanpijuanpisinclude Makeconf ifndef OCTAVE_FORGE MKOCTFILE = mkoctfile endif LAPACK_LIBS := $(shell mkoctfile -p LAPACK_LIBS) DEFINES = -DHAVE_CONFIG_H -Wall GSVD_OBJECTS = gsvd.o dbleGSVD.o CmplxGSVD.o GSVD_TARGET = gsvd.oct GSVD_TEST = gsvd GSVD_DEPENDS = gsvd.d dbleGSVD.d CmplxGSVD.d OBJECTS = $(GSVD_OBJECTS) TARGETS = $(GSVD_TARGET) DEPENDS = $(GSVD_DEPENDS) .PHONY: all test clean count .SUFFIXES: .PRECIOUS: %.d %.o all : $(TARGETS) pgmres.oct $(GSVD_TARGET) : $(GSVD_DEPENDS) $(GSVD_OBJECTS) $(MKOCTFILE) $(DEFINES) $(GSVD_OBJECTS) -o $@ ${LAPACK_LIBS} $(GSVD_TEST) : $(GSVD_TARGET) ifneq (,$(DEPENDS)) sinclude $(DEPENDS) endif %.d:%.cc $(MKOCTFILE) $(DEFINES) -M $< %.o:%.cc %.o:%.cc %.d $(MKOCTFILE) $(DEFINES) -c $< %.o:%.f $(MKOCTFILE) $(DEFINES) -c $< %.oct:%.o $(MKOCTFILE) $(DEFINES) $< -o $@ %.oct: %.cc mkoctfile $(DEFINES) $< -o $@ ${LAPACK_LIBS} .phony: test test: $(GSVD_TEST) for i in $^; do echo "test $$i"; done | octave --silent clean: rm -f $(TARGETS) $(DEPENDS) $(OBJECTS) octave-core count: wc *{.cc,.h,.f} linear-algebra/src/dbleGSVD.h0000644000175000017500000000453611743761216015633 0ustar juanpijuanpi// Copyright (C) 1996, 1997 John W. Eaton // Copyright (C) 2006 Pascal Dupuis // // This program 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. // // 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. See the GNU General Public License for more // details. // // You should have received a copy of the GNU General Public License along with // this program; if not, see . #if !defined (octave_GSVD_h) #define octave_GSVD_h 1 #include #include "dDiagMatrix.h" #include "dMatrix.h" class GSVD { public: enum type { std, economy, sigma_only }; GSVD (void) : sigmaA (), sigmaB (), left_smA (), left_smB (), right_sm () { } GSVD (const Matrix& a, const Matrix& b, type gsvd_type = GSVD::economy) { init (a, b, gsvd_type); } GSVD (const Matrix& a, const Matrix& b, octave_idx_type& info, type gsvd_type = GSVD::economy) { info = init (a, b, gsvd_type); } GSVD (const GSVD& a) : type_computed (a.type_computed), sigmaA (a.sigmaA), sigmaB (a.sigmaB), left_smA (a.left_smA), left_smB (a.left_smB), right_sm (a.right_sm), R(a.R) { } GSVD& operator = (const GSVD& a) { if (this != &a) { type_computed = a.type_computed; sigmaA = a.sigmaA; sigmaB = a.sigmaB; left_smA = a.left_smA; left_smB = a.left_smB; right_sm = a.right_sm; R = a.R; } return *this; } ~GSVD (void) { } DiagMatrix singular_values_A (void) const { return sigmaA; } DiagMatrix singular_values_B (void) const { return sigmaB; } Matrix left_singular_matrix_A (void) const; Matrix left_singular_matrix_B (void) const; Matrix right_singular_matrix (void) const; Matrix R_matrix (void) const; friend std::ostream& operator << (std::ostream& os, const GSVD& a); private: GSVD::type type_computed; DiagMatrix sigmaA, sigmaB; Matrix left_smA, left_smB; Matrix right_sm, R; octave_idx_type init (const Matrix& a, const Matrix& b, type gsvd_type = economy); }; #endif linear-algebra/src/CmplxGSVD.h0000644000175000017500000000475111743761216016007 0ustar juanpijuanpi// Copyright (C) 1996, 1997 John W. Eaton // Copyright (C) 2006 Pascal Dupuis // // This program 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. // // 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. See the GNU General Public License for more // details. // // You should have received a copy of the GNU General Public License along with // this program; if not, see . #if !defined (octave_ComplexGSVD_h) #define octave_ComplexGSVD_h 1 #include #include "dDiagMatrix.h" #include "CMatrix.h" #include "dbleGSVD.h" class ComplexGSVD { public: ComplexGSVD (void) { } ComplexGSVD (const ComplexMatrix& a, const ComplexMatrix& b, GSVD::type gsvd_type = GSVD::economy) { init (a, b, gsvd_type); } ComplexGSVD (const ComplexMatrix& a, const ComplexMatrix& b, octave_idx_type& info, GSVD::type gsvd_type = GSVD::economy) { info = init (a, b, gsvd_type); } ComplexGSVD (const ComplexGSVD& a) : type_computed (a.type_computed), sigmaA (a.sigmaA), sigmaB (a.sigmaB), left_smA (a.left_smA), left_smB (a.left_smB), right_sm (a.right_sm), R(a.R) { } ComplexGSVD& operator = (const ComplexGSVD& a) { if (this != &a) { type_computed = a.type_computed; sigmaA = a.sigmaA; sigmaB = a.sigmaB; left_smA = a.left_smA; left_smB = a.left_smB; right_sm = a.right_sm; R = a.R; } return *this; } ~ComplexGSVD (void) { } DiagMatrix singular_values_A (void) const { return sigmaA; } DiagMatrix singular_values_B (void) const { return sigmaB; } ComplexMatrix left_singular_matrix_A (void) const; ComplexMatrix left_singular_matrix_B (void) const; ComplexMatrix right_singular_matrix (void) const; ComplexMatrix R_matrix (void) const; friend std::ostream& operator << (std::ostream& os, const ComplexGSVD& a); private: GSVD::type type_computed; DiagMatrix sigmaA, sigmaB; ComplexMatrix left_smA, left_smB; ComplexMatrix right_sm, R; octave_idx_type init (const ComplexMatrix& a, const ComplexMatrix& b, GSVD::type gsvd_type = GSVD::economy); }; #endif linear-algebra/src/CmplxGSVD.cc0000644000175000017500000001741611743761216016147 0ustar juanpijuanpi// Copyright (C) 1996, 1997 John W. Eaton // Copyright (C) 2006 Pascal Dupuis // // This program 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. // // 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. See the GNU General Public License for more // details. // // You should have received a copy of the GNU General Public License along with // this program; if not, see . #ifdef HAVE_CONFIG_H #include #endif #include #include "CmplxGSVD.h" #include "f77-fcn.h" #include "lo-error.h" /* uncomment those lines to monitor k and l #include "oct-obj.h" #include "pager.h" */ extern "C" { F77_RET_T F77_FUNC (zggsvd, ZGGSVD) ( F77_CONST_CHAR_ARG_DECL, // JOBU (input) CHARACTER*1 F77_CONST_CHAR_ARG_DECL, // JOBV (input) CHARACTER*1 F77_CONST_CHAR_ARG_DECL, // JOBQ (input) CHARACTER*1 const octave_idx_type&, // M (input) INTEGER const octave_idx_type&, // N (input) INTEGER const octave_idx_type&, // P (input) INTEGER octave_idx_type &, // K (output) INTEGER octave_idx_type &, // L (output) INTEGER Complex*, // A (input/output) COMPLEX*16 array, dimension (LDA,N) const octave_idx_type&, // LDA (input) INTEGER Complex*, // B (input/output) COMPLEX*16 array, dimension (LDB,N) const octave_idx_type&, // LDB (input) INTEGER double*, // ALPHA (output) DOUBLE PRECISION array, dimension (N) double*, // BETA (output) DOUBLE PRECISION array, dimension (N) Complex*, // U (output) COMPLEX*16 array, dimension (LDU,M) const octave_idx_type&, // LDU (input) INTEGER Complex*, // V (output) COMPLEX*16 array, dimension (LDV,P) const octave_idx_type&, // LDV (input) INTEGER Complex*, // Q (output) COMPLEX*16 array, dimension (LDQ,N) const octave_idx_type&, // LDQ (input) INTEGER Complex*, // WORK (workspace) COMPLEX*16 array double*, // RWORK (workspace) DOUBLE PRECISION array int*, // IWORK (workspace/output) INTEGER array, dimension (N) octave_idx_type& // INFO (output)INTEGER F77_CHAR_ARG_LEN_DECL F77_CHAR_ARG_LEN_DECL F77_CHAR_ARG_LEN_DECL ); } ComplexMatrix ComplexGSVD::left_singular_matrix_A (void) const { if (type_computed == GSVD::sigma_only) { (*current_liboctave_error_handler) ("CmplxGSVD: U not computed because type == GSVD::sigma_only"); return ComplexMatrix (); } else return left_smA; } ComplexMatrix ComplexGSVD::left_singular_matrix_B (void) const { if (type_computed == GSVD::sigma_only) { (*current_liboctave_error_handler) ("CmplxGSVD: V not computed because type == GSVD::sigma_only"); return ComplexMatrix (); } else return left_smB; } ComplexMatrix ComplexGSVD::right_singular_matrix (void) const { if (type_computed == GSVD::sigma_only) { (*current_liboctave_error_handler) ("CmplxGSVD: X not computed because type == GSVD::sigma_only"); return ComplexMatrix (); } else return right_sm; } ComplexMatrix ComplexGSVD::R_matrix (void) const { if (type_computed != GSVD::std) { (*current_liboctave_error_handler) ("CmplxGSVD: R not computed because type != GSVD::std"); return ComplexMatrix (); } else return R; } octave_idx_type ComplexGSVD::init (const ComplexMatrix& a, const ComplexMatrix& b, GSVD::type gsvd_type) { octave_idx_type info; octave_idx_type m = a.rows (); octave_idx_type n = a.cols (); octave_idx_type p = b.rows (); ComplexMatrix atmp = a; Complex *tmp_dataA = atmp.fortran_vec (); ComplexMatrix btmp = b; Complex *tmp_dataB = btmp.fortran_vec (); // octave_idx_type min_mn = m < n ? m : n; char jobu = 'U'; char jobv = 'V'; char jobq = 'Q'; octave_idx_type nrow_u = m; octave_idx_type nrow_v = p; octave_idx_type nrow_q = n; octave_idx_type k, l; switch (gsvd_type) { case GSVD::sigma_only: // Note: for this case, both jobu and jobv should be 'N', but // there seems to be a bug in dgesvd from Lapack V2.0. To // demonstrate the bug, set both jobu and jobv to 'N' and find // the singular values of [eye(3), eye(3)]. The result is // [-sqrt(2), -sqrt(2), -sqrt(2)]. // // For Lapack 3.0, this problem seems to be fixed. jobu = 'N'; jobv = 'N'; jobq = 'N'; nrow_u = nrow_v = nrow_q = 1; break; default: break; } type_computed = gsvd_type; if (! (jobu == 'N' || jobu == 'O')) { left_smA.resize (nrow_u, m); } Complex *u = left_smA.fortran_vec (); if (! (jobv == 'N' || jobv == 'O')) { left_smB.resize (nrow_v, p); } Complex *v = left_smB.fortran_vec (); if (! (jobq == 'N' || jobq == 'O')) { right_sm.resize (nrow_q, n); } Complex *q = right_sm.fortran_vec (); octave_idx_type lwork = 3*n; lwork = lwork > m ? lwork : m; lwork = (lwork > p ? lwork : p) + n; Array work (lwork, 1); Array alpha (n, 1); Array beta (n, 1); Array rwork(2*n, 1); Array iwork (n, 1); F77_XFCN (zggsvd, ZGGSVD, (F77_CONST_CHAR_ARG2 (&jobu, 1), F77_CONST_CHAR_ARG2 (&jobv, 1), F77_CONST_CHAR_ARG2 (&jobq, 1), m, n, p, k, l, tmp_dataA, m, tmp_dataB, p, alpha.fortran_vec (), beta.fortran_vec (), u, nrow_u, v, nrow_v, q, nrow_q, work.fortran_vec (), rwork.fortran_vec (), iwork.fortran_vec (), info F77_CHAR_ARG_LEN (1) F77_CHAR_ARG_LEN (1) F77_CHAR_ARG_LEN (1))); if (f77_exception_encountered) (*current_liboctave_error_handler) ("unrecoverable error in zggsvd"); if (info < 0) { (*current_liboctave_error_handler) ("zggsvd.f: argument %d illegal", -info); } else { if (info > 0) { (*current_liboctave_error_handler) ("zggsvd.f: Jacobi-type procedure failed to converge."); } else { octave_idx_type i, j; if (GSVD::std == gsvd_type) { R.resize(k+l, k+l); int astart = n-k-l; if (m - k - l >= 0) { int astart = n-k-l; /* * R is stored in A(1:K+L,N-K-L+1:N) */ for (i = 0; i < k+l; i++) for (j = 0; j < k+l; j++) R.xelem(i, j) = atmp.xelem(i, astart + j); } else { /* * (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), * ( 0 R22 R23 ) */ for (i = 0; i < m; i++) for (j = 0; j < k+l; j++) R.xelem(i, j) = atmp.xelem(i, astart + j); /* * and R33 is stored in B(M-K+1:L,N+M-K-L+1:N) */ for (i = k+l-1; i >=m; i--) { for (j = 0; j < m; j++) R.xelem(i, j) = 0.0; for (j = m; j < k+l; j++) R.xelem(i, j) = btmp.xelem(i - k, astart + j); } } } /* uncomment this to monitor k and l octave_value tmp; octave_stdout << "CmplxGSVD k: "; tmp = k; tmp.print(octave_stdout); octave_stdout << "\n"; octave_stdout << "CmplxGSVD l: "; tmp = l; tmp.print(octave_stdout); octave_stdout << "\n"; */ if (m-k-l >= 0) { // Fills in C and S sigmaA.resize (l, l); sigmaB.resize (l, l); for (i = 0; i < l; i++) { sigmaA.dgxelem(i) = alpha.elem(k+i); sigmaB.dgxelem(i) = beta.elem(k+i); } } else { // Fills in C and S sigmaA.resize (m-k, m-k); sigmaB.resize (m-k, m-k); for (i = 0; i < m-k; i++) { sigmaA.dgxelem(i) = alpha.elem(k+i); sigmaB.dgxelem(i) = beta.elem(k+i); } } } } return info; } linear-algebra/inst/0000755000175000017500000000000011756365433014253 5ustar juanpijuanpilinear-algebra/inst/condeig.m0000644000175000017500000000651711743761216016045 0ustar juanpijuanpi## Copyright (C) 2006, 2007 Arno Onken ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{c} =} condeig (@var{a}) ## @deftypefnx {Function File} {[@var{v}, @var{lambda}, @var{c}] =} condeig (@var{a}) ## Compute condition numbers of the eigenvalues of a matrix. The ## condition numbers are the reciprocals of the cosines of the angles ## between the left and right eigenvectors. ## ## @subheading Arguments ## ## @itemize @bullet ## @item ## @var{a} must be a square numeric matrix. ## @end itemize ## ## @subheading Return values ## ## @itemize @bullet ## @item ## @var{c} is a vector of condition numbers of the eigenvalue of ## @var{a}. ## ## @item ## @var{v} is the matrix of right eigenvectors of @var{a}. The result is ## the same as for @code{[v, lambda] = eig (a)}. ## ## @item ## @var{lambda} is the diagonal matrix of eigenvalues of @var{a}. The ## result is the same as for @code{[v, lambda] = eig (a)}. ## @end itemize ## ## @subheading Example ## ## @example ## @group ## a = [1, 2; 3, 4]; ## c = condeig (a) ## @result{} [1.0150; 1.0150] ## @end group ## @end example ## @end deftypefn function [v, lambda, c] = condeig (a) # Check arguments if (nargin != 1 || nargout > 3) print_usage (); endif if (! isempty (a) && ! ismatrix (a)) error ("condeig: a must be a numeric matrix"); endif if (columns (a) != rows (a)) error ("condeig: a must be a square matrix"); endif if (issparse (a) && (nargout == 0 || nargout == 1) && exist ("svds", "file")) ## Try to use svds to calculate the condition as it will typically be much ## faster than calling eig as only the smallest and largest eigenvalue are ## calculated. try s0 = svds (a, 1, 0); v = svds (a, 1) / s0; catch ## Caught an error as there is a singular value exactly at Zero!! v = Inf; end_try_catch return; endif # Right eigenvectors [v, lambda] = eig (a); if (isempty (a)) c = lambda; else # Corresponding left eigenvectors vl = inv (v)'; # Normalize vectors vl = vl ./ repmat (sqrt (sum (abs (vl .^ 2))), rows (vl), 1); # Condition numbers # cos (angle) = (norm (v1) * norm (v2)) / dot (v1, v2) # Norm of the eigenvectors is 1 => norm (v1) * norm (v2) = 1 c = abs (1 ./ dot (vl, v)'); endif if (nargout == 0 || nargout == 1) v = c; endif endfunction %!test %! a = [1, 2; 3, 4]; %! c = condeig (a); %! expected_c = [1.0150; 1.0150]; %! assert (c, expected_c, 0.001); %!test %! a = [1, 3; 5, 8]; %! [v, lambda, c] = condeig (a); %! [expected_v, expected_lambda] = eig (a); %! expected_c = [1.0182; 1.0182]; %! assert (v, expected_v, 0.001); %! assert (lambda, expected_lambda, 0.001); %! assert (c, expected_c, 0.001); linear-algebra/inst/circulant_eig.m0000644000175000017500000000476111743762567017256 0ustar juanpijuanpi## Copyright (C) 2012 Nir Krakauer ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{lambda} =} circulant_eig (@var{v}) ## @deftypefnx{Function File} {[@var{vs}, @var{lambda}] =} circulant_eig (@var{v}) ## ## Fast, compact calculation of eigenvalues and eigenvectors of a circulant matrix@* ## Given an @var{n}*1 vector @var{v}, return the eigenvalues @var{lambda} and optionally eigenvectors @var{vs} of the @var{n}*@var{n} circulant matrix @var{C} that has @var{v} as its first column ## ## Theoretically same as @code{eig(make_circulant_matrix(v))}, but many fewer computations; does not form @var{C} explicitly ## ## Reference: Robert M. Gray, Toeplitz and Circulant Matrices: A Review, Now Publishers, http://ee.stanford.edu/~gray/toeplitz.pdf, Chapter 3 ## ## @seealso{circulant_make_matrix, circulant_matrix_vector_product, circulant_inv} ## @end deftypefn function [a, b] = circulant_eig (v) ## FIXME when warning for broadcastin is turned off by default, this ## unwind_protect block could be removed ## we are using broadcasting on the code below so we turn off the ## warnings but will restore to previous state at the end bc_warn = warning ("query", "Octave:broadcast"); unwind_protect warning ("off", "Octave:broadcast"); #find the eigenvalues n = numel(v); lambda = ones(n, 1); s = (0:(n-1)); lambda = sum(v .* exp(-2*pi*i*s'*s/n))'; if nargout < 2 a = lambda; return endif #find the eigenvectors (which in fact do not depend on v) a = exp(-2*i*pi*s'*s/n) / sqrt(n); b = diag(lambda); unwind_protect_cleanup ## restore broadcats warning status warning (bc_warn.state, "Octave:broadcast"); end_unwind_protect endfunction %!shared v,C,vs,lambda %! v = [1 2 3]'; %! C = circulant_make_matrix(v); %! [vs lambda] = circulant_eig(v); %!assert (vs*lambda, C*vs, 100*eps); linear-algebra/inst/@blksparse/0000755000175000017500000000000011756365433016341 5ustar juanpijuanpilinear-algebra/inst/@blksparse/size.m0000644000175000017500000000156511403135240017454 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} size (@var{x}) ## Returns the size of the matrix. ## @end deftypefn function siz = size (s) siz = s.bsiz .* s.siz; endfunction linear-algebra/inst/@blksparse/plus.m0000644000175000017500000000266511345411523017475 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . function s = plus (s1, s2) if (isa (s1, "blksparse") && isa (s2, "blksparse")) ## Conformance check. siz1 = s1.siz; bsiz1 = s1.bsiz; siz2 = s2.siz; bsiz2 = s2.bsiz; if (bsiz1(2) != bsiz2(1)) gripe_nonconformant (bsiz1, bsiz2, "block sizes"); elseif (siz1(2) != siz2(1)) gripe_nonconformant (bsiz1.*siz1, bsiz2.*siz2); endif ## Stupid & simple. s = blksparse ([s1.i; s2.i], [s1.j; s2.j], cat (3, s1.sv, s2.sv), siz1(1), siz1(2)); else error ("blksparse: only blksparse + blksparse implemented"); endif endfunction function gripe_nonconformant (s1, s2, what = "arguments") error ("Octave:nonconformant-args", ... "nonconformant %s (op1 is %dx%d, op2 is %dx%d)", what, s1, s2); endfunction linear-algebra/inst/@blksparse/issparse.m0000644000175000017500000000137111355046345020343 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . function yes = issparse (s) yes = true; endfunction linear-algebra/inst/@blksparse/mtimes.m0000644000175000017500000000627011403135240017776 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} mtimes (@var{x}, @var{y}) ## Multiplies a block sparse matrix with a full matrix, or two block sparse ## matrices. Multiplication of block sparse * sparse is not implemented. ## If one of arguments is a scalar, it's a scalar multiply. ## @end deftypefn function c = mtimes (a, b) if (isa (a, "blksparse")) if (isa (b, "blksparse")) c = mtimes_ss (a, b); else c = mtimes_sm (a, b); endif elseif (isa (b, "blksparse")) c = mtimes_ms (a, b); else error ("blksparse: invalid arguments to mtimes"); endif endfunction function y = mtimes_sm (s, x) if (isscalar (x)) y = s; y.sv *= x; return; elseif (issparse (x)) error ("blksparse * sparse not implemented."); endif siz = s.siz; bsiz = s.bsiz; ## Check sizes. [xr, xc] = size (x); if (xr != siz(2)*bsiz(2)) gripe_nonconformant (siz.*bsiz, [xr, xc]); endif ## Form blocks. x = reshape (x, bsiz(2), siz(2), xc); x = permute (x, [1, 3, 2]); ## Scatter. xs = x(:,:,s.j); ## Multiply. ys = blkmm (s.sv, xs); ## Gather. y = accumdim (s.i, ys, 3, siz(1)); y = permute (y, [1, 3, 2]); ## Narrow blocks. y = reshape (y, bsiz(1)*siz(1), xc); endfunction function y = mtimes_ms (x, s) if (isscalar (x)) y = s; y.sv *= x; return; elseif (issparse (x)) error ("sparse * blksparse not implemented."); endif siz = s.siz; bsiz = s.bsiz; ## Check sizes. [xr, xc] = size (x); if (xc != siz(1)*bsiz(1)) gripe_nonconformant ([xr, xc], siz.*bsiz); endif ## Form blocks. x = reshape (x, xr, bsiz(2), siz(2)); ## Scatter. xs = x(:,:,s.i); ## Multiply. ys = blkmm (xs, s.sv); ## Gather. y = accumdim (s.j, ys, 3, siz(2)); ## Narrow blocks. y = reshape (y, xr, bsiz(2)*siz(2)); endfunction function s = mtimes_ss (s1, s2) ## Conformance check. siz1 = s1.siz; bsiz1 = s1.bsiz; siz2 = s2.siz; bsiz2 = s2.bsiz; if (bsiz1(2) != bsiz2(1)) gripe_nonconformant (bsiz1, bsiz2, "block sizes"); elseif (siz1(2) != siz2(1)) gripe_nonconformant (bsiz1.*siz1, bsiz2.*siz2); endif ## Hardcore hacks, man! ss = sparse (s1.i, s1.j, 1:length (s1.i), "unique"); ss = ss(:,s2.i); [i, j, k] = find (ss); sv = blkmm (s1.sv(:,:,k), s2.sv(:,:,j)); j = s2.j(j); s = blksparse (i, j, sv, siz1(1), siz2(2)); endfunction function gripe_nonconformant (s1, s2, what = "arguments") error ("Octave:nonconformant-args", ... "nonconformant %s (op1 is %dx%d, op2 is %dx%d)", what, s1, s2); endfunction linear-algebra/inst/@blksparse/isreal.m0000644000175000017500000000137711355046345017777 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . function is = isreal (s) is = isreal (s.sv); endfunction linear-algebra/inst/@blksparse/transpose.m0000644000175000017500000000201011403135240020502 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} transpose (@var{x}) ## Returns the transpose of a block sparse matrix @var{x}. ## @end deftypefn function y = transpose (x) y.siz = x.siz(2:-1:1); y.bsiz = x.bsiz(2:-1:1); [y.j,idx] = sort (x.i); y.i = x.j(idx); y.sv = permute (x.sv(:,:,idx), [2,1,3]); endfunction linear-algebra/inst/@blksparse/mldivide.m0000644000175000017500000000636111403135240020276 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} mldivide (@var{x}, @var{y}) ## Performs a left division with a block sparse matrix. ## If @var{x} is a block sparse matrix, it must be either diagonal ## or triangular, and @var{y} must be full. ## If @var{x} is built-in sparse or full, @var{y} is converted ## accordingly, then the built-in division is used. ## @end deftypefn function c = mldivide (a, b) if (isa (a, "blksparse")) if (issparse (b)) error ("blksparse: block sparse \\ sparse not implemented"); else c = mldivide_sm (a, b); endif elseif (issparse (a)) c = a \ sparse (b); else c = a \ full (b); endif endfunction function y = mldivide_sm (s, x) siz = s.siz; bsiz = s.bsiz; if (bsiz(1) != bsiz(2) || siz(1) != siz(2)) error ("blksparse: can only divide by square matrices with square blocks"); endif ## Check sizes. [xr, xc] = size (x); if (xr != siz(1)*bsiz(1)) gripe_nonconformant (siz.*bsiz, [xr, xc]); endif if (isempty (s) || isempty (x)) y = x; return; endif ## Form blocks. x = reshape (x, bsiz(1), siz(1), xc); x = permute (x, [1, 3, 2]); sv = s.sv; si = s.i; sj = s.j; ns = size (sv, 3); n = siz(1); nb = bsiz(1); d = find (si == sj); full_diag = length (d) == n; isdiag = full_diag && ns == n; # block diagonal islower = full_diag && all (si >= sj); # block upper triangular isupper = full_diag && all (si <= sj); # block lower triangular if (isdiag) xx = num2cell (x, [1, 2]); ss = num2cell (sv, [1, 2]); yy = cellfun (@mldivide, ss, xx, "uniformoutput", false); y = cat (3, yy{:}); clear xx ss yy; elseif (islower) y = x; ## this is the axpy version for j = 1:n-1 y(:,:,j) = sv(:,:,d(j)) \ y(:,:,j); k = d(j)+1:d(j+1)-1; xy = y(:,:,j*ones (1, length (k))); y(:,:,si(k)) -= blkmm (sv(:,:,k), xy); endfor y(:,:,n) = sv(:,:,ns) \ y(:,:,n); elseif (isupper) y = x; ## this is the axpy version for j = n:-1:2 y(:,:,j) = sv(:,:,d(j)) \ y(:,:,j); k = d(j-1)+1:d(j)-1; xy = y(:,:,j*ones (1, length (k))); y(:,:,si(k)) -= blkmm (sv(:,:,k), xy); endfor y(:,:,1) = sv(:,:,1) \ y(:,:,1); else error ("blksparse: mldivide: matrix must be block triangular or diagonal"); endif ## Narrow blocks. y = permute (y, [1, 3, 2]); y = reshape (y, bsiz(1)*siz(1), xc); endfunction function gripe_nonconformant (s1, s2, what = "arguments") error ("Octave:nonconformant-args", ... "nonconformant %s (op1 is %dx%d, op2 is %dx%d)", what, s1, s2); endfunction linear-algebra/inst/@blksparse/uminus.m0000644000175000017500000000161611403135240020017 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} uminus (@var{x}) ## Returns the negative of a block sparse matrix @var{x}. ## @end deftypefn function y = uminus (x) y = x; y.sv = -x.sv; endfunction linear-algebra/inst/@blksparse/blksparse.m0000644000175000017500000000647411355040171020500 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{s} =} blksparse (@var{i}, @var{j}, @var{sv}) ## @deftypefnx{Function File} {@var{s} =} blksparse (@var{i}, @var{j}, @var{sv}, @var{m}, @var{n}) ## @deftypefnx{Function File} {@var{s} =} blksparse (@dots{}, @var{mode}) ## ## Construct a block sparse matrix. The meaning of arguments is analogous to the ## built-in @code{sparse} function, except that @var{i}, @var{j} are indices of ## blocks rather than elements, and @var{sv} is a 3-dimensional array, the first two ## dimensions determining the block size. Optionally, @var{m} and @var{n} can be ## specified as the true block dimensions; if not, the maximum values of @var{i}, @var{j} ## are taken instead. The resulting sparse matrix has the size ## ## @example ## [@var{m}*@var{p}, @var{n}*@var{q}] ## @end example ## ## where ## ## @example ## @var{p} = size (@var{sv}, 1) ## @var{q} = size (@var{sv}, 2) ## @end example ## ## The blocks are located so that ## ## @example ## @var{s}(@var{i}(k):@var{i}(k)+@var{p}-1, @var{j}(k):@var{j}(K)+@var{q}-1) = @var{sv}(:,:,k) ## @end example ## ## Multiple blocks corresponding to the same pair of indices are summed, unless ## @var{mode} is "unique", in which case the last of them is used. ## @end deftypefn function s = blksparse (i, j, sv, m = 0, n = 0, mode) persistent chkver = check_version (); if (nargin == 0) i = j = zeros (0, 1); sv = zeros (1, 1, 0); s = class (struct ("i", i, "j", j, "sv", sv, "siz", [0, 0], "bsiz", [1, 1]), "blksparse"); return endif if (nargin < 3 || nargin > 6) print_usage (); endif if (! isvector (i) || ! isvector (j)) error ("blksparse: i, j must be vectors"); elseif (ndims (sv) != 3) error ("blksparse: sv must be a 3D array"); endif if (nargin == 4 && ischar (m)) mode = m; m = 0; elseif (nargin < 6) mode = "sum"; endif if (strcmp (mode, "unique")) summation = false; elseif (strcmp (mode, "sum") || strcmp (mode, "summation")) summation = true; else error ("blksparse: invalid mode: %s", mode); endif if (m == 0) m = max (i); endif if (n == 0) n = max (j); endif siz = [m, n]; ji = [j(:), i(:)]; [ji, fidx, ridx] = unique (ji, "rows"); j = ji(:,1); i = ji(:,2); if (summation) sv = accumdim (ridx, sv, 3, rows (ji)); else sv = sv(:,:,fidx); endif s = struct ("i", i, "j", j, "sv", sv, "siz", siz, "bsiz", size (sv)(1:2)); s = class (s, "blksparse"); endfunction function ok = check_version () ok = compare_versions (version, "3.3.51", ">="); if (! ok) error ("blksparse: can only be used with Octave 3.3.51+"); endif endfunction linear-algebra/inst/@blksparse/uplus.m0000644000175000017500000000170711403135240017650 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} uplus (@var{x}) ## Returns the unary plus of a block sparse matrix @var{x}. ## Effectively the matrix itself, except signs of zeros. ## @end deftypefn function y = uplus (x) y = x; y.sv = +x.sv; endfunction linear-algebra/inst/@blksparse/full.m0000644000175000017500000000175211403135240017442 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} full (@var{x}) ## Converts a block sparse matrix to full. ## @end deftypefn function f = full (s) f = zeros ([s.bsiz, s.siz]); f(:,:, sub2ind (s.siz, s.i, s.j)) = s.sv; f = reshape (permute (f, [1, 3, 2, 4]), s.bsiz .* s.siz); endfunction linear-algebra/inst/@blksparse/mrdivide.m0000644000175000017500000000623311403135240020302 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} mrdivide (@var{x}, @var{y}) ## Performs a left division with a block sparse matrix. ## If @var{y} is a block sparse matrix, it must be either diagonal ## or triangular, and @var{x} must be full. ## If @var{y} is built-in sparse or full, @var{x} is converted ## accordingly, then the built-in division is used. ## @end deftypefn function c = mrdivide (a, b) if (isa (b, "blksparse")) if (issparse (a)) error ("blksparse: sparse / block sparse not implemented"); else c = mrdivide_ms (a, b); endif elseif (issparse (b)) c = sparse (a) / b; else c = full (a) / b; endif endfunction function y = mrdivide_ms (x, s) siz = s.siz; bsiz = s.bsiz; if (bsiz(1) != bsiz(2) || siz(1) != siz(2)) error ("blksparse: can only divide by square matrices with square blocks"); endif ## Check sizes. [xr, xc] = size (x); if (xc != siz(2)*bsiz(2)) gripe_nonconformant (siz.*bsiz, [xr, xc]); endif if (isempty (s) || isempty (x)) y = x; return; endif ## Form blocks. x = reshape (x, xr, bsiz(2), siz(2)); sv = s.sv; si = s.i; sj = s.j; ns = size (sv, 3); n = siz(2); nb = bsiz(2); d = find (si == sj); full_diag = length (d) == n; isdiag = full_diag && ns == n; # block diagonal islower = full_diag && all (si >= sj); # block upper triangular isupper = full_diag && all (si <= sj); # block lower triangular if (isdiag) xx = num2cell (x, [1, 2]); ss = num2cell (sv, [1, 2]); yy = cellfun (@mldivide, ss, xx, "uniformoutput", false); y = cat (3, yy{:}); clear xx ss yy; elseif (isupper) y = zeros (size (x)); ## this is the dot version y(:,:,1) = x(:,:,1) / sv(:,:,1); for j = 2:n k = d(j-1)+1:d(j)-1; xy = blkmm (y(:,:,si(k)), sv(:,:,k)); y(:,:,j) = (x(:,:,j) - sum (xy, 3)) / sv(:,:,d(j)); endfor elseif (islower) y = zeros (size (x)); ## this is the dot version y(:,:,n) = x(:,:,n) / sv(:,:,ns); for j = n-1:-1:1 k = d(j)+1:d(j+1)-1; xy = blkmm (y(:,:,si(k)), sv(:,:,k)); y(:,:,j) = (x(:,:,j) - sum (xy, 3)) / sv(:,:,d(j)); endfor else error ("blksparse: mldivide: matrix must be block triangular or diagonal"); endif ## Narrow blocks. y = reshape (y, xr, bsiz(2)*siz(2)); endfunction function gripe_nonconformant (s1, s2, what = "arguments") error ("Octave:nonconformant-args", ... "nonconformant %s (op1 is %dx%d, op2 is %dx%d)", what, s1, s2); endfunction linear-algebra/inst/@blksparse/display.m0000644000175000017500000000245011403135240020141 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} display (@var{x}) ## Displays the block sparse matrix. ## @end deftypefn function display (s) printf ("%s = \n\n", argn); nbl = size (s.sv, 3); header = "Block Sparse Matrix (rows = %d, cols = %d, block = %dx%d, nblocks = %d)\n\n"; printf (header, s.siz .* s.bsiz, s.bsiz, nbl) if (nbl == 0) return; endif rng = [s.i, s.j] * diag (s.bsiz); rng = [rng(:,1) + 1-s.bsiz(1), rng(:,1), rng(:,2) + 1-s.bsiz(2), rng(:,2)]; for k = 1:nbl printf ("(%d:%d, %d:%d) ->\n\n", rng(k,:)); disp (s.sv(:,:,k)); puts ("\n"); endfor endfunction linear-algebra/inst/@blksparse/subsref.m0000644000175000017500000000356411355046345020171 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . function ss = subsref (s, subs) if (length (subs) != 1) error ("blksparse: invalid index chain"); endif if (strcmp (subs(1).type, "()")) ind = subs(1).subs; if (length (ind) == 2) idx = make_block_index (ind{1}, s.bsiz(1)); jdx = make_block_index (ind{2}, s.bsiz(2)); ## Use sparse indexing to solve it all. sn = sparse (s.i, s.j, 1:size (s.sv, 3), s.siz(1), s.siz (2)); sn = sn(idx, jdx); [i, j, k] = find (sn); ss = s; ss.i = i; ss.j = j; ss.sv = s.sv(:,:,k); ss.siz = size (sn); else error ("blksparse: linear indexing is not supported"); endif else error ("blksparse: only supports () indexing"); endif endfunction function bi = make_block_index (i, bs) if (strcmp (i, ':')) bi = i; else if (rem (numel (i), bs) == 0) ba = reshape (i, bs, []); bi = ba(1,:); if (any (rem (bi, bs) != 1) || any ((ba != bsxfun (@plus, bi, [0:bs-1].'))(:))) error ("blksparse: index must preserve block structure"); else bi = ceil (bi / bs); endif else error ("blksparse: index must preserve block structure"); endif endif endfunction linear-algebra/inst/@blksparse/blksize.m0000644000175000017500000000157011403135366020152 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} blksize (@var{x}) ## Returns the block size of the matrix. ## @end deftypefn function siz = blksize (s) siz = s.siz; endfunction linear-algebra/inst/@blksparse/sparse.m0000644000175000017500000000233311403135240017771 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} sparse (@var{x}) ## Converts a block sparse matrix to (built-in) sparse. ## @end deftypefn function sp = sparse (s) bsiz = s.bsiz; i = repmat (shiftdim (s.i, -2), bsiz); j = repmat (shiftdim (s.j, -2), bsiz); [iofs, jofs] = ndgrid (1:bsiz(1), 1:bsiz(2)); k = ones (1, size (s.sv, 3)); i = sub2ind ([bsiz(1), s.siz(1)], iofs(:,:,k), i); j = sub2ind ([bsiz(2), s.siz(2)], jofs(:,:,k), j); sp = sparse (i(:), j(:), s.sv(:), bsiz(1)*s.siz(1), bsiz(2)*s.siz(2)); endfunction linear-algebra/inst/@blksparse/ctranspose.m0000644000175000017500000000203211403135240020651 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} ctranspose (@var{x}) ## Returns the conjugate transpose of a block sparse matrix @var{x}. ## @end deftypefn function y = ctranspose (x) y.siz = x.siz(2:-1:1); y.bsiz = x.bsiz(2:-1:1); [y.j,idx] = sort (x.i); y.i = x.j(idx); y.sv = conj (permute (x.sv(:,:,idx), [2,1,3])); endfunction linear-algebra/inst/@blksparse/minus.m0000644000175000017500000000266711345411523017647 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . function s = minus (s1, s2) if (isa (s1, "blksparse") && isa (s2, "blksparse")) ## Conformance check. siz1 = s1.siz; bsiz1 = s1.bsiz; siz2 = s2.siz; bsiz2 = s2.bsiz; if (bsiz1(2) != bsiz2(1)) gripe_nonconformant (bsiz1, bsiz2, "block sizes"); elseif (siz1(2) != siz2(1)) gripe_nonconformant (bsiz1.*siz1, bsiz2.*siz2); endif ## Stupid & simple. s = blksparse ([s1.i; s2.i], [s1.j; s2.j], cat (3, s1.sv, -s2.sv), siz1(1), siz1(2)); else error ("blksparse: only blksparse - blksparse implemented"); endif endfunction function gripe_nonconformant (s1, s2, what = "arguments") error ("Octave:nonconformant-args", ... "nonconformant %s (op1 is %dx%d, op2 is %dx%d)", what, s1, s2); endfunction linear-algebra/inst/@blksparse/ismatrix.m0000644000175000017500000000137111417554447020360 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. 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 ## . function yes = ismatrix (s) yes = true; endfunction linear-algebra/inst/rotv.m0000644000175000017500000000457611743761216015432 0ustar juanpijuanpi## Copyright (C) 2002 Etienne Grossmann ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{r} = } rotv ( v, ang ) ## @cindex ## The functionrotv calculates a Matrix of rotation about @var{v} w/ angle |v| ## r = rotv(v [,ang]) ## ## Returns the rotation matrix w/ axis v, and angle, in radians, norm(v) or ## ang (if present). ## ## rotv(v) == w'*w + cos(a) * (eye(3)-w'*w) - sin(a) * crossmat(w) ## ## where a = norm (v) and w = v/a. ## ## v and ang may be vertically stacked : If 'v' is 2x3, then ## rotv( v ) == [rotv(v(1,:)); rotv(v(2,:))] ## ## @example ## ## @end example ## @seealso{rotparams, rota, rot} ## @end deftypefn function r = rotv(v ,ang) if nargin > 1 v = v.*((ang(:)./sqrt(sum(v'.^2))')*ones(1,3)); end ## For checking only ## v00 = v ; ## static toto = floor(rand(1)*100) ; ## toto a = sqrt(sum(v'.^2))' ; oka = find(a!=0); if all(size(oka)), v(oka,:) = v(oka,:)./(a(oka)*ones(1,3)) ; end ## ca = cos(a); ## sa = sin(a); N = size(v,1) ; N3 = 3*N ; r = (reshape( v', N3,1 )*ones(1,3)).*kron(v,ones(3,1)) ; r += kron(cos(a),ones(3,3)) .* (kron(ones(N,1),eye(3))-r) ; ## kron(cos(a),ones(3,3)) .* (kron(ones(N,1),eye(3))-r0) ## cos(a) tmp = zeros(N3,3) ; tmp( 2:3:N3,1 ) = v(:,3) ; tmp( 1:3:N3,2 ) = -v(:,3) ; tmp( 3:3:N3,1 ) = -v(:,2) ; tmp( 1:3:N3,3 ) = v(:,2) ; tmp( 2:3:N3,3 ) = -v(:,1) ; tmp( 3:3:N3,2 ) = v(:,1) ; ## keyboard r -= kron(sin(a),ones(3)) .* tmp ; endfunction ## For checking only ## r2 = zeros(N3,3) ; ## for i=1:size(v,1), ## v0 = v00(i,:); ## t = norm(v0); ## if t, v0 = v0/t; end; ## r2(3*i-2:3*i,:) = v0'*v0 + cos(t)*(eye(3)-v0'*v0) + -sin(t)*[0, -v0(3), v0(2);v0(3), 0, -v0(1);-v0(2), v0(1), 0]; ## end ## max(abs(r2(:)-r(:))) linear-algebra/inst/circulant_matrix_vector_product.m0000644000175000017500000000346611743761216023127 0ustar juanpijuanpi## Copyright (C) 2012 Nir Krakauer ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{y} =} circulant_matrix_vector_product (@var{v}, @var{x}) ## ## Fast, compact calculation of the product of a circulant matrix with a vector@* ## Given @var{n}*1 vectors @var{v} and @var{x}, return the matrix-vector product @var{y} = @var{C}@var{x}, where @var{C} is the @var{n}*@var{n} circulant matrix that has @var{v} as its first column ## ## Theoretically the same as @code{make_circulant_matrix(x) * v}, but does not form @var{C} explicitly; uses the discrete Fourier transform ## ## Because of roundoff, the returned @var{y} may have a small imaginary component even if @var{v} and @var{x} are real (use @code{real(y)} to remedy this) ## ## Reference: Gene H. Golub and Charles F. Van Loan, Matrix Computations, 3rd Ed., Section 4.7.7 ## ## @seealso{circulant_make_matrix, circulant_eig, circulant_inv} ## @end deftypefn function y = circulant_matrix_vector_product (v, x) xf = fft(x); vf = fft(v); z = vf .* xf; y = ifft(z); endfunction %!shared v,x %! v = [1 2 3]'; x = [2 5 6]'; %!assert (circulant_matrix_vector_product(v, x), circulant_make_matrix(v)*x, eps); linear-algebra/inst/rotparams.m0000644000175000017500000000407711743761216016444 0ustar juanpijuanpi## Copyright (C) 2002 Etienne Grossmann ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{vstacked}, @var{astacked}] =} rotparams (@var{rstacked}) ## @cindex ## The function w = rotparams (r) - Inverse to rotv(). ## Using, @var{w} = rotparams(@var{r}) is such that ## rotv(w)*r' == eye(3). ## ## If used as, [v,a]=rotparams(r) , idem, with v (1 x 3) s.t. w == a*v. ## ## 0 <= norm(w)==a <= pi ## ## :-O !! Does not check if 'r' is a rotation matrix. ## ## Ignores matrices with zero rows or with NaNs. (returns 0 for them) ## ## @seealso{rotv} ## @end deftypefn function [vstacked, astacked] = rotparams (rstacked) N = size (rstacked,1) / 3; ## ang = 0 ; ## if length(varargin), ## if strcmp(varargin{1},'ang'), ang = 1; end ## end ok = all ( ! isnan (rstacked') ) & any ( rstacked' ); ok = min ( reshape (ok,3,N) ); ok = find (ok) ; ## keyboard vstacked = zeros (N,3); astacked = zeros (N,1); for j = ok, r = rstacked(3*j-2:3*j,:); [v,f] = eig (r); f = diag(f); [m,i] = min (abs (real (f)-1)); v = v(:,i); w = null (v'); u = w(:,1); a = u'*r*u; if a<1, a = real (acos (u'*r*u)); else a = 0; endif ## Check orientation x=r*u; if v'*[0 -u(3) u(2); u(3) 0 -u(1);-u(2) u(1) 0]*x < 0, v=-v; endif if nargout <= 1, v = v*a; endif vstacked(j,:) = -v'; astacked(j) = a; endfor endfunction linear-algebra/inst/@kronprod/0000755000175000017500000000000011756365433016211 5ustar juanpijuanpilinear-algebra/inst/@kronprod/trace.m0000644000175000017500000000267211352553631017463 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} trace (@var{KP}) ## Returns the trace of the Kronecker product @var{KP}. ## ## If @var{KP} is a Kronecker product of two square matrices, the trace is ## computed as the product of the trace of these two matrices. Otherwise the ## trace is computed by forming the full matrix. ## @seealso{@@kronprod/det, @@kronprod/rank, @@kronprod/full} ## @end deftypefn function retval = trace (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("trace: input must be of class 'kronprod'"); endif if (issquare (KP.A) && issquare (KP.B)) retval = trace (KP.A) * trace (KP.B); else ## XXX: Can we do something smarter here? Using 'eig' or 'svd'? retval = trace (full (KP)); endif endfunction linear-algebra/inst/@kronprod/disp.m0000644000175000017500000000221011352553631017310 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} disp (@var{KP}) ## Show the content of the Kronecker product @var{KP}. To avoid evaluating the ## Kronecker product, this function displays the two matrices defining the product. ## To display the actual values of @var{KP}, use @code{disp (full (@var{KP}))}. ## ## This function is equivalent to @code{@@kronprod/display}. ## @seealso{@@kronprod/display, @@kronprod/full} ## @end deftypefn function disp (KP) display (KP); endfunction linear-algebra/inst/@kronprod/columns.m0000644000175000017500000000215511352553631020041 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} columns (@var{KP}) ## Return the number of columns in the Kronecker product @var{KP}. ## @seealso{@@kronprod/rows, @@kronprod/size, @@kronprod/numel} ## @end deftypefn function retval = columns (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("columns: input argument must be of class 'kronprod'"); endif retval = columns (KP.A) * columns (KP.B); endfunction linear-algebra/inst/@kronprod/not_done/0000755000175000017500000000000011756365433020016 5ustar juanpijuanpilinear-algebra/inst/@kronprod/not_done/svd.m0000644000175000017500000000321611377407502020763 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} svd (@var{KP}) ## XXX: Write documentation ## @end deftypefn function [U, S, V] = svd (KP) if (nargin < 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("svd: input must be of class 'kronprod'"); endif ## XXX: I don't think this works properly for non-square A and B if (nargout <= 1) ## Only singular values were requested S_A = svd (KP.A); S_B = svd (KP.B); U = sort (kron (S_A, S_B), "descend"); elseif (nargout == 3) ## The full SVD was requested [U_A, S_A, V_A] = svd (KP.A); [U_B, S_B, V_B] = svd (KP.B); ## Compute and sort singular values [sv, idx] = sort (kron (diag (S_A), diag (S_B)), "descend"); ## Form matrices S = resize (diag (sv), [rows(KP), columns(KP)]); #Pu = eye (rows (KP)) (idx, :); U = kronprod (U_A, U_B, idx); #Pv = eye (columns (KP)) (idx, :); V = kronprod (V_A, V_B, idx); else print_usage (); endif endfunction linear-algebra/inst/@kronprod/not_done/eig.m0000644000175000017500000000454711377407502020743 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{lambda} =} eig (@var{KP}) ## @deftypefnx{Function File} {[var{V}, @var{lambda}] =} eig (@var{KP}) ## XXX: Write help text ## @seealso{eig, @kronprod/svd} ## @end deftypefn function [V, lambda] = eig (KP, A) ## XXX: This implementation provides a different permutation of eigenvalues and ## eigenvectors compared to 'eig (full (KP))' ## Check input if (nargin == 0 || nargin > 2) print_usage (); endif if (!isa (KP, "kronprod")) error ("eig: first input argument must be of class 'kronprod'"); endif if (!issquare (KP)) error ("eig: first input must be a square matrix"); endif ## Take action if (nargin == 1) if (nargout <= 1) ## Only eigenvalues were requested if (issquare (KP.A) && issquare (KP.B)) lambda_A = eig (KP.A); lambda_B = eig (KP.B); V = kronprod (lambda_A, lambda_B); else ## We should be able to do this using SVD error ("eig not implemented (yet) for Kronecker products of non-square matrices"); endif elseif (nargout == 2) ## Both eigenvectors and eigenvalues were requested if (issquare (KP.A) && issquare (KP.B)) [V_A, lambda_A] = eig (KP.A); [V_B, lambda_B] = eig (KP.B); V = kronprod (V_A, V_B); lambda = kronprod (lambda_A, lambda_B); else ## We should be able to do this using SVD error ("eig not implemented (yet) for Kronecker products of non-square matrices"); endif endif elseif (nargin == 2) ## Solve generalised eigenvalue problem ## XXX: Is there a fancy way of doing this? [V, lambda] = eig (full (KP), full (A)); endif endfunction linear-algebra/inst/@kronprod/kronprod.m0000644000175000017500000000307511377407502020223 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} kronprod (@var{A}, @var{B}) ## @deftypefnx{Function File} kronprod (@var{A}, @var{B}, @var{P}) ## Construct a Kronecker product object. ## XXX: Write proper documentation ## ## With two input arguments, the following matrix is represented: kron (A, B); ## ## With three input arguments, the following matrix is represented: P * kron (A, B) * P' ## (P must be a permutation matrix) ## ## @end deftypefn function retval = kronprod (A, B, P) if (nargin == 0) KP.A = KP.B = KP.P = []; elseif (nargin == 2 && ismatrix (A) && ismatrix (B)) KP.A = A; KP.B = B; KP.P = []; elseif (nargin == 3 && ismatrix (A) && ismatrix (B)) # && strcmp (typeinfo (P), "permutation matrix")) ## XXX: Check that the size of P is correct KP.A = A; KP.B = B; KP.P = P; else print_usage (); endif retval = class (KP, "kronprod"); endfunction linear-algebra/inst/@kronprod/size.m0000644000175000017500000000255011352553631017332 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} size (@var{KP}) ## @deftypefnx{Function File} size (@var{KP}, @var{dim}) ## Return the size of the Kronecker product @var{KP} as a vector. ## @seealso{size, @@kronprod/rows, @@kronprod/columns, @@kronprod/numel} ## @end deftypefn function retval = size (KP, dim) if (nargin < 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("size: input must be of class 'kronprod'"); endif if (nargin > 1 && !(isscalar (dim) && dim == round (dim) && dim > 0)) error ("size: optional second input must be a positive integer"); endif retval = size (KP.A) .* size (KP.B); if (nargin > 1) retval = retval (dim); endif endfunction linear-algebra/inst/@kronprod/plus.m0000644000175000017500000000326511352553631017347 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} plus (@var{a}, @var{a}) ## Return the sum of a Kronecker product and another matrix. This is performed ## by forming the full matrix of both inputs and is as such a potential expensive ## operation. ## @seealso{plus, @@kronprod/minus} ## @end deftypefn function retval = plus (M1, M2) if (nargin == 0 || nargin > 2) print_usage (); elseif (nargin == 1) ## This seems to be the behaviour for the built-in types so we copy that retval = M1; return; endif if (!ismatrix (M1) || !ismatrix (M2)) error ("plus: input arguments must be matrics"); endif if (!size_equal (M1, M2)) error ("plus: nonconformant arguments (op1 is %dx%d, op2 is %dx%d)", rows (M1), columns (M1), rows (M2), columns (M2)); endif ## XXX: Can we do something smarter here? if (issparse (M1)) M1 = sparse (M1); else M1 = full (M1); endif if (issparse (M2)) M2 = sparse (M2); else M2 = full (M2); endif retval = M1 + M2; endfunction linear-algebra/inst/@kronprod/issparse.m0000644000175000017500000000215311352553631020210 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} issparse (@var{KP}) ## Return @t{true} if one of the matrices in the Kronecker product @var{KP} ## is sparse. ## @seealso{@@kronprod/sparse} ## @end deftypefn function retval = issparse (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("issparse: input argument must be of class 'kronprod'"); endif retval = (issparse(KP.A) || issparse(KP.B)); endfunction linear-algebra/inst/@kronprod/rank.m0000644000175000017500000000222311352553631017310 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} rank (@var{KP}) ## Return the rank of the Kronecker product @var{KP}. This is computed as the ## product of the ranks of the matrices forming the product. ## @seealso{rank, @@kronprod/det, @@kronprod/trace} ## @end deftypefn function retval = rank (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("rank: input must be of class 'kronprod'"); endif retval = rank (KP.A) * rank (KP.B); endfunction linear-algebra/inst/@kronprod/rows.m0000644000175000017500000000213511352553631017351 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} rows (@var{KP}) ## Return the number of rows in the Kronecker product @var{KP}. ## @seealso{rows, @@kronprod/size, @@kronprod/columns, @@kronprod/numel} ## @end deftypefn function retval = rows (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("rows: input must be of class 'kronprod'"); endif retval = rows (KP.A) * rows (KP.B); endfunction linear-algebra/inst/@kronprod/mtimes.m0000644000175000017500000000605411352553631017661 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} mtimes (@var{KP}) ## XXX: Write documentation ## @end deftypefn function retval = mtimes (M1, M2) ## Check input if (nargin == 0) print_usage (); elseif (nargin == 1) ## This seems to be what happens for full and sparse matrices, so we copy this behaviour retval = M1; return; endif if (!ismatrix (M1) || !ismatrix (M2)) error ("mtimes: input arguments must be matrices"); endif if (columns (M1) != rows (M2)) error ("mtimes: nonconformant arguments (op1 is %dx%d, op2 is %dx%d)", rows (M1), columns (M1), rows (M2), columns (M2)); endif ## Take action depending on input types M1_is_KP = isa (M1, "kronprod"); M2_is_KP = isa (M2, "kronprod"); if (M1_is_KP && M2_is_KP) # Product of Kronecker Products ## Check if the size match such that the result is a Kronecker Product if (columns (M1.A) == rows (M2.A) && columns (M1.B) == rows (M2.B)) retval = kronprod (M1.A * M2.A, M1.B * M2.B); else ## Form the full matrix of the smallest matrix and use that to compute the ## final product ## XXX: Can we do something smarter here? numel1 = numel (M1); numel2 = numel (M2); if (numel1 < numel2) retval = full (M1) * M2; else retval = M1 * full (M2); endif endif elseif (M1_is_KP && isscalar (M2)) # Product of Kronecker Product and scalar if (numel (M1.A) < numel (M1.B)) retval = kronprod (M2 * M1.A, M1.B); else retval = kronprod (M1.A, M2 * M1.B); endif elseif (M1_is_KP && ismatrix (M2)) # Product of Kronecker Product and Matrix retval = zeros (rows (M1), columns (M2)); for n = 1:columns (M2) M = reshape (M2 (:, n), [columns(M1.B), columns(M1.A)]); retval (:, n) = vec (M1.B * M * M1.A'); endfor elseif (isscalar (M1) && M2_is_KP) # Product of scalar and Kronecker Product if (numel (M2.A) < numel (M2.B)) retval = kronprod (M1 * M2.A, M2.B); else retval = kronprod (M2.A, M1 * M2.B); endif elseif (ismatrix (M1) && M2_is_KP) # Product of Matrix and Kronecker Product retval = zeros (rows (M1), columns (M2)); for n = 1:rows (M1) M = reshape (M1 (n, :), [rows(M2.B), rows(M2.A)]); retval (n, :) = vec (M2.B' * M * M2.A); endfor else error ("mtimes: internal error for 'kronprod'"); endif endfunction linear-algebra/inst/@kronprod/isreal.m0000644000175000017500000000216611352553631017642 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} isreal (@var{KP}) ## Return @t{true} if the Kronecker product @var{KP} is real, i.e. has no ## imaginary components. ## @seealso{isreal, @@kronprod/iscomplex} ## @end deftypefn function retval = isreal (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("isreal: input argument must be of class 'kronprod'"); endif retval = (isreal (KP.A) & isreal (KP.B)); endfunction linear-algebra/inst/@kronprod/rdivide.m0000644000175000017500000000341011352553631020002 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} rdivide (@var{a}, @var{b}) ## XXX: Write help text. ## @end deftypefn function retval = rdivide (a, b) ## Check input if (nargin < 2) print_usage (); endif if (!ismatrix (a) || !ismatrix (a)) error ("rdivide: input arguments must be scalars or matrices"); endif if (!size_equal (a, b) || !isscalar (b)) error ("times: nonconformant arguments (op1 is %dx%d, op2 is %dx%d)", rows (a), columns (a), rows (b), columns (b)); endif ## Take action depending on input if (isscalar (a) && isa (b, "kronprod")) retval = kronprod (a ./ b.A, 1 ./ b.B); elseif (isa (a, "kronprod") && isscalar (b)) if (numel (a.A) < numel (a.B)) retval = kronprod (a.A ./ b, a.B); else retval = kronprod (a.A, a.B ./ b); endif elseif (isa (a, "kronprod") && isa (b, "kronprod")) ## XXX: Can we do something smarter here? retval = full (a) ./ full (b); else ## XXX: We should probably handle sparse cases and all sorts of other ## situations better here retval = full (a) ./ full (b); endif endfunction linear-algebra/inst/@kronprod/mpower.m0000644000175000017500000000254211352553631017672 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} mpower (@var{KP}, @var{k}) ## XXX: Write documentation ## @end deftypefn function retval = mpower (KP, k) ## Check input if (nargin != 2) print_usage (); endif if (!ismatrix (KP)) error ("mpower: first input argument must be a matrix"); endif if (!isscalar (k)) error ("mpower: second input argument must be a scalar"); endif ## Do the actual computation if (issquare (KP.A) && issquare (KP.B) && k == round (k)) retval = kronprod (KP.A^k, KP.B^k); elseif (issquare (KP)) ## XXX: Can we do something smarter here? retval = full (KP)^k; else error ("for A^b, A must be square"); endif endfunction linear-algebra/inst/@kronprod/transpose.m0000644000175000017500000000225011352553631020373 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} transpose (@var{KP}) ## Returns the transpose of the Kronecker product @var{KP}. This is equivalent ## to ## ## @example ## @var{KP}.' ## @end example ## @seealso{transpose, @@kronprod/ctranspose} ## @end deftypefn function retval = transpose (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("transpose: input must be of class 'kronprod'"); endif retval = kronprod (transpose (KP.A), transpose (KP.B)); endfunction linear-algebra/inst/@kronprod/det.m0000644000175000017500000000354111352553631017135 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} det (@var{KP}) ## Compute the determinant of a Kronecker product. ## ## If @var{KP} is the Kronecker product of the @var{n}-by-@var{n} matrix @var{A} ## and the @var{q}-by-@var{q} matrix @var{B}, then the determinant is computed ## as ## ## @example ## det (@var{A})^q * det (@var{B})^n ## @end example ## ## If @var{KP} is not a Kronecker product of square matrices the determinant is ## computed by forming the full matrix and then computing the determinant. ## @seealso{det, @@kronprod/trace, @@kronprod/rank, @@kronprod/full} ## @end deftypefn function retval = det (KP) ## Check input if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("det: input argument must be of class 'kronprod'"); endif if (!issquare (KP)) error ("det: argument must be a square matrix"); endif ## Take action [n, m] = size (KP.A); [q, r] = size (KP.B); if (n == m && q == r) # A and B are both square retval = (det (KP.A)^q) * (det (KP.B)^n); elseif (n*q == m*r) # kron (A, B) is square ## XXX: Can we do something smarter here? We should be able to use the SVD... retval = det (full (KP)); endif endfunction linear-algebra/inst/@kronprod/mldivide.m0000644000175000017500000000405011713432443020150 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} mldivide (@var{M1}, @var{M2}) ## XXX: Write documentation ## @end deftypefn function retval = mldivide (M1, M2) ## Check input if (nargin != 2) print_usage (); endif if (!ismatrix (M1) || !ismatrix (M2)) error ("mldivide: both input arguments must be matrices"); endif if (rows (M1) != rows (M2)) error ("mldivide: nonconformant arguments (op1 is %dx%d, op2 is %dx%d)", rows (M1), columns (M1), rows (M2), columns (M2)); endif ## Take action depending on types M1_is_KP = isa (M1, "kronprod"); M2_is_KP = isa (M2, "kronprod"); if (M1_is_KP && M2_is_KP) # Left division of Kronecker Products error ("mldividide: this part not yet implemented as I'm lazy..."); elseif (M1_is_KP) # Left division of Kronecker Product and Matrix ## XXX: Does this give the same minimum-norm solution as when using ## XXX: full (M1) \ M2 ## XXX: ? It is the same when M1 is invertible. retval = zeros (columns (M1), columns (M2)); for n = 1:columns (M2) M = reshape (M2 (:, n), [rows(M1.B), rows(M1.A)]); retval (:, n) = vec ((M1.A \ (M1.B \ M)')'); endfor elseif (M2_is_KP) # Left division of Matrix and Kronecker Product error ("mldividide: this part not yet implemented as I'm lazy..."); else error ("mldivide: internal error for 'kronprod'"); endif endfunction linear-algebra/inst/@kronprod/uminus.m0000644000175000017500000000240011352553631017672 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} uminus (@var{KP}) ## Returns the unary minus operator working on the Kronecker product @var{KP}. ## This corresponds to @code{-@var{KP}} and simply returns the Kronecker ## product with the sign of the smallest matrix in the product reversed. ## @seealso{@@kronprod/uminus} ## @end deftypefn function KP = uplus (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("uplus: input must be of class 'kronprod'"); endif if (numel (KP.A) < numel (KP.B)) KP.A *= -1; else KP.B *= -1; endif endfunction linear-algebra/inst/@kronprod/numel.m0000644000175000017500000000215411352553631017500 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} numel (@var{KP}) ## Return the number of elements in the Kronecker product @var{KP}. ## @seealso{numel, @@kronprod/rows, @@kronprod/columns, @@kronprod/size} ## @end deftypefn function retval = numel (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("numel: input must be of class 'kronprod'"); endif retval = prod (size (KP.A) .* size (KP.B)); endfunction linear-algebra/inst/@kronprod/uplus.m0000644000175000017500000000174711352553631017537 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} uplus (@var{KP}) ## Returns the unary plus operator working on the Kronecker product @var{KP}. ## This corresponds to @code{+@var{KP}} and simply returns the Kronecker ## product unchanged. ## @seealso{@@kronprod/uminus} ## @end deftypefn function KP = uplus (KP) endfunction linear-algebra/inst/@kronprod/full.m0000644000175000017500000000272011403135737017321 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} full (@var{KP}) ## Return the full matrix representation of the Kronecker product @var{KP}. ## ## If @var{KP} is the Kronecker product of an @var{n}-by-@var{m} matrix and a ## @var{q}-by-@var{r} matrix, then the result is a @var{n}@var{q}-by-@var{m}@var{r} ## matrix. Thus, the result can require vast amount of memory, so this function ## should be avoided whenever possible. ## @seealso{full, @@kronprod/sparse} ## @end deftypefn function retval = full (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("full: input argument must be of class 'kronprod'"); endif retval = full (kron (KP.A, KP.B)); if (!isempty (KP.P)) #retval = KP.P * retval * KP.P'; retval = retval (KP.P, KP.P); endif endfunction linear-algebra/inst/@kronprod/times.m0000644000175000017500000000415611355051141017475 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} times (@var{KP}) ## XXX: Write documentation ## @end deftypefn function retval = times (M1, M2) ## Check input if (nargin == 0) print_usage (); elseif (nargin == 1) ## This seems to be what happens for full and sparse matrices, so we copy this behaviour retval = M1; return; endif if (!ismatrix (M1) || !ismatrix (M2)) error ("times: input arguments must be matrices"); endif if (!size_equal (M1, M2)) error ("times: nonconformant arguments (op1 is %dx%d, op2 is %dx%d)", rows (M1), columns (M1), rows (M2), columns (M2)); endif ## Take action depending on input types M1_is_KP = isa (M1, "kronprod"); M2_is_KP = isa (M2, "kronprod"); ## Product of Kronecker Products ## Check if the size match such that the result is a Kronecker Product if (M1_is_KP && M2_is_KP && size_equal (M1.A, M2.A) && size_equal (M1.B, M2.B)) retval = kronprod (M1.A .* M2.A, M1.B .* M2.B); elseif (isscalar (M1) || isscalar (M2)) # Product of Kronecker Product and scalar retval = M1 * M2; ## Forward to mtimes. else # All other cases. ## Form the full matrix or sparse matrix of both matrices ## XXX: Can we do something smarter here? if (issparse (M1)) M1 = sparse (M1); else M1 = full (M1); endif if (issparse (M2)) M2 = sparse (M2); else M2 = full (M2); endif retval = M1 .* M2; endif endfunction linear-algebra/inst/@kronprod/display.m0000644000175000017500000000307211377407502020027 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} display (@var{KP}) ## Show the content of the Kronecker product @var{KP}. To avoid evaluating the ## Kronecker product, this function displays the two matrices defining the product. ## To display the actual values of @var{KP}, use @code{display (full (@var{KP}))}. ## @seealso{@@kronprod/displ, @@kronprod/full} ## @end deftypefn function display (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("display: input argument must be of class 'kronprod'"); endif if (isempty (KP.P)) disp ("Kronecker Product of A and B with"); disp ("A = "); disp (KP.A); disp ("B = "); disp (KP.B); else disp ("Permuted Kronecker Product of A and B (i.e. P * kron (A, B) * P') with"); disp ("A = "); disp (KP.A); disp ("B = "); disp (KP.B); disp ("P = "); disp (KP.P); endif endfunction linear-algebra/inst/@kronprod/size_equal.m0000644000175000017500000000161311355051141020510 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} size_equal (...) ## XXX: Write documentation ## @end deftypefn function iseq = size_equal (varargin) iseq = isequal (cellfun (@size, varargin, "UniformOutput", false){:}); endfunction linear-algebra/inst/@kronprod/issquare.m0000644000175000017500000000212711352553631020214 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} issquare (@var{KP}) ## Return @t{true} if the Kronecker product @var{KP} is a square matrix. ## @seealso{@@kronprod/size} ## @end deftypefn function retval = issquare (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("issquare: input argument must be of class 'kronprod'"); endif s = size (KP); retval = (s (1) == s (2)); endfunction linear-algebra/inst/@kronprod/sparse.m0000644000175000017500000000225211352553631017654 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} sparse (@var{KP}) ## Return the Kronecker product @var{KP} represented as a sparse matrix. ## @seealso{sparse, @@kronprod/issparse, @@kronprod/full} ## @end deftypefn function retval = sparse (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("sparse: input argument must be of class 'kronprod'"); endif ## XXX: Would this be better? kron (sparse (KP.A), sparse (KP.B))) retval = sparse (kron (KP.A, KP.B)); endfunction linear-algebra/inst/@kronprod/ctranspose.m0000644000175000017500000000226211352553631020541 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} ctranspose (@var{KP}) ## The complex conjugate transpose of a Kronecker product. This is equivalent ## to ## ## @example ## @var{KP}' ## @end example ## @seealso{ctranspose, @@kronprod/transpose} ## @end deftypefn function retval = ctranspose (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("ctranspose: input argument must be of class 'kronprod'"); endif retval = kronprod (ctranspose (KP.A), ctranspose (KP.B)); endfunction linear-algebra/inst/@kronprod/minus.m0000644000175000017500000000307211352553631017513 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} minus (@var{a}, @var{a}) ## Return the difference between a Kronecker product and another matrix. This is performed ## by forming the full matrix of both inputs and is as such a potential expensive ## operation. ## @seealso{minus, @@kronprod/plus} ## @end deftypefn function retval = minus (M1, M2) if (nargin != 2) print_usage (); endif if (!ismatrix (M1) || !ismatrix (M2)) error ("minus: both input arguments must be matrices"); endif if (!size_equal (M1, M2)) error ("minus: nonconformant arguments (op1 is %dx%d, op2 is %dx%d)", rows (M1), columns (M1), rows (M2), columns (M2)); endif ## XXX: Can we do something smarter here? if (issparse (M1)) M1 = sparse (M1); else M1 = full (M1); endif if (issparse (M2)) M2 = sparse (M2); else M2 = full (M2); endif retval = M1 - M2; endfunction linear-algebra/inst/@kronprod/inv.m0000644000175000017500000000337511403135737017162 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} inv (@var{KP}) ## Return the inverse of the Kronecker product @var{KP}. ## ## If @var{KP} is the Kronecker product of two square matrices @var{A} and @var{B}, ## the inverse will be computed as the Kronecker product of the inverse of ## @var{A} and @var{B}. ## ## If @var{KP} is square but not a Kronecker product of square matrices, the ## inverse will be computed using the SVD ## @seealso{@@kronprod/sparse} ## @end deftypefn function retval = inv (KP) ## Check input if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("inv: input argument must be of class 'kronprod'"); endif ## Do the computations [n, m] = size (KP.A); [q, r] = size (KP.B); if (n == m && q == r) # A and B are both square retval = kronprod (inv (KP.A), inv (KP.B)); elseif (n*q == m*r) # kron (A, B) is square ## We use the SVD to compute the inverse. ## XXX: Should we use 'eig' instead? [U, S, V] = svd (KP); retval = U * (1./S) * V'; else error ("inv: argument must be a square matrix"); endif endfunction linear-algebra/inst/@kronprod/ismatrix.m0000644000175000017500000000162011352553631020215 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} ismatrix (@var{KP}) ## Return @t{true} to indicate that the Kronecker product @var{KP} always is a ## matrix. ## @end deftypefn function retval = ismatrix (KP) retval = true; endfunction linear-algebra/inst/@kronprod/iscomplex.m0000644000175000017500000000216411403135737020364 0ustar juanpijuanpi## Copyright (C) 2010 Soren Hauberg ## ## This program 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, or (at your option) ## any later version. ## ## 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. See the GNU ## General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this file. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} iscomplex (@var{KP}) ## Return @t{true} if the Kronecker product @var{KP} contains any complex values. ## @seealso{iscomplex, @@kronprod/isreal} ## @end deftypefn function retval = iscomplex (KP) if (nargin != 1) print_usage (); endif if (!isa (KP, "kronprod")) error ("iscomplex: input argument must be of class 'kronprod'"); endif retval = (iscomplex (KP.A) || iscomplex (KP.B); endfunction linear-algebra/inst/thfm.m0000644000175000017500000001010011743761216015352 0ustar juanpijuanpi## Copyright (C) 2001 Rolf Fabian ## Copyright (C) 2001 Paul Kienzle ## Copyright (C) 2011 Philip Nienhuis ## Copyright (C) 2011 Carnë Draug ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{y} =} thfm (@var{x}, @var{mode}) ## Trigonometric/hyperbolic functions of square matrix @var{x}. ## ## @var{mode} must be the name of a function. Valid functions are 'sin', 'cos', ## 'tan', 'sec', 'csc', 'cot' and all their inverses and/or hyperbolic variants, ## and 'sqrt', 'log' and 'exp'. ## ## The code @code{thfm (x, 'cos')} calculates matrix cosinus @emph{even if} input ## matrix @var{x} is @emph{not} diagonalizable. ## ## @emph{Important note}: ## This algorithm does @emph{not} use an eigensystem similarity transformation. It ## maps the @var{mode} functions to functions of @code{expm}, @code{logm} and ## @code{sqrtm}, which are known to be robust with respect to non-diagonalizable ## ('defective') @var{x}. ## ## @seealso{funm} ## @end deftypefn function y = thfm (x,M) ## minimal arg check only if ( nargin != 2 || !ischar (M) || ischar (x) ) print_usage; endif ## look for known functions of sqrt, log, exp I = eye (size (x)); switch (M) case {'cos'} if (isreal(x)) y = real( expm( i*x ) ); else y = ( expm( i*x ) + expm( -i*x ) ) / 2; endif case {'sin'} if (isreal(x)) y = imag( expm( i*x ) ); else y = ( expm( i*x ) - expm( -i*x ) ) / (2*i); endif case {'tan'} if (isreal(x)) t = expm( i*x ); y = imag(t)/real(t); else t = expm( -2*i*x ); y = -i*(I-t)/(I+t); endif case {'cot'} if (isreal(x)) t = expm( i*x ); y = real(t)/imag(t); else t = expm( -2*i*x ); y = i*(I+t)/(I-t); endif case {'sec'} if (isreal(x)) y = inv( real(expm(i*x)) ); else y = inv( expm(i*x)+expm(-i*x) )*2 ; endif case {'csc'} if (isreal(x)) y = inv( imag(expm(i*x)) ); else y = inv( expm(i*x)-expm(-i*x) )*2i; endif case {'log'} y = logm(x); case {'exp'} y = expm(x); case {'cosh'} y = ( expm(x)+expm(-x) )/2; case {'sinh'} y = ( expm(x)-expm(-x) )/2; case {'tanh'} t = expm( -2*x ); y = (I - t)/(I + t); case {'coth'} t = expm( -2*x ); y = (I + t)/(I - t); case {'sech'} y = 2 * inv( expm(x) + expm(-x) ); case {'csch'} y = 2 * inv( expm(x) - expm(-x) ); case {'asin'} y = -i * logm( i*x + sqrtm(I - x*x) ); case {'acos'} y = i * logm( x - i*sqrtm(I - x*x) ); case {'atan'} y = -i/2 * logm( (I + i*x)/(I - i*x) ); case {'acot'} y = i/2 * logm( (I + i*x)/(i*x - I) ); case {'asec'} y = i * logm( ( I - sqrtm(I - x*x) ) / x ); case {'acsc'} y = -i * logm( i*( I + sqrtm(I - x*x) ) / x ); case {'sqrt'} y = sqrtm(x); case {'asinh'} y = logm( x + sqrtm (x*x + I) ); case {'acosh'} y = logm( x + sqrtm (x*x - I) ); case {'atanh'} y = logm( (I + x)/(I - x) ) / 2; case {'acoth'} y = logm( (I + x)/(x - I) ) / 2; case {'asech'} y = logm( (I + sqrtm (I - x*x)) / x ); case {'acsch'} y = logm( (I + sqrtm (I + x*x)) / x ); otherwise error ("thfm doesn't support function %s - try to use funm instead.", M); endswitch endfunction linear-algebra/inst/cod.m0000644000175000017500000000620411743761216015173 0ustar juanpijuanpi## Copyright (C) 2009 VZLU Prague, a.s., Czech Republic ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{q}, @var{r}, @var{z}] =} cod (@var{a}) ## @deftypefnx{Function File} {[@var{q}, @var{r}, @var{z}, @var{p}] =} cod (@var{a}) ## @deftypefnx{Function File} {[@dots{}] =} cod (@var{a}, '0') ## Computes the complete orthogonal decomposition (COD) of the matrix @var{a}: ## @example ## @var{a} = @var{q}*@var{r}*@var{z}' ## @end example ## Let @var{a} be an M-by-N matrix, and let @code{K = min(M, N)}. ## Then @var{q} is M-by-M orthogonal, @var{z} is N-by-N orthogonal, ## and @var{r} is M-by-N such that @code{@var{r}(:,1:K)} is upper ## trapezoidal and @code{@var{r}(:,K+1:N)} is zero. ## The additional @var{p} output argument specifies that pivoting should be used in ## the first step (QR decomposition). In this case, ## @example ## @var{a}*@var{p} = @var{q}*@var{r}*@var{z}' ## @end example ## If a second argument of '0' is given, an economy-sized factorization is returned ## so that @var{r} is K-by-K. ## ## @emph{NOTE}: This is currently implemented by double QR factorization plus some ## tricky manipulations, and is not as efficient as using xRZTZF from LAPACK. ## @seealso{qr} ## @end deftypefn ## Author: Jaroslav Hajek function [q, r, z, p] = cod (a, varargin) if (nargin < 1 || nargin > 2 || nargout > 4 || ! ismatrix (a)) print_usage (); endif [m, n] = size (a); k = min (m, n); economy = nargin == 2; pivoted = nargout == 4; ## Compute the initial QR decomposition if (pivoted) [q, r, p] = qr (a, varargin{:}); else [q, r] = qr (a, varargin{:}); endif if (m >= n) ## In this case, Z is identity, and we're finished. z = eye (n, class (a)); else ## Permutation inverts row order. pr = eye (m) (m:-1:1, :); ## Permutation inverts first m columns order. pc = eye (n) ([m:-1:1, m+1:n], :); ## Make n-by-m matrix, invert first m columns r = (pr * r * pc')'; ## QR factorize again. [z, r] = qr (r, varargin{:}); ## Recover final R and Z if (economy) r = pr * r' * pr'; z = pc * z * pr'; else r = pr * r' * pc'; z = pc * z * pc'; endif endif endfunction %!test %! a = rand (5, 10); %! [q, r, z] = cod (a); %! assert (norm (q*r*z' - a) / norm (a) < 1e-10); %!test %! a = rand (5, 10) + i * rand (5, 10); %! [q, r, z] = cod (a); %! assert (norm (q*r*z' - a) / norm (a) < 1e-10); %!test %! a = rand (5, 10); %! [q, r, z, p] = cod (a); %! assert (norm (q*r*z' - a*p) / norm (a) < 1e-10); linear-algebra/inst/cartprod.m0000644000175000017500000000346711743761216016254 0ustar juanpijuanpi## Copyright (C) 2008 Muthiah Annamalai ## Copyright (C) 2010 VZLU Prague ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} cartprod (@var{varargin}) ## ## Computes the cartesian product of given column vectors ( row vectors ). ## The vector elements are assumend to be numbers. ## ## Alternatively the vectors can be specified by as a matrix, by its columns. ## ## To calculate the cartesian product of vectors, ## P = A x B x C x D ... . Requires A, B, C, D be column vectors. ## The algorithm is iteratively calcualte the products, ## ( ( (A x B ) x C ) x D ) x etc. ## ## @example ## @group ## cartprod(1:2,3:4,0:1) ## ans = 1 3 0 ## 2 3 0 ## 1 4 0 ## 2 4 0 ## 1 3 1 ## 2 3 1 ## 1 4 1 ## 2 4 1 ## @end group ## @end example ## @end deftypefn ## @seealso{kron} function p = cartprod (varargin) if (nargin < 1) print_usage (); elseif (nargin == 1) p = varargin{1}; endif [p{1:nargin}] = ndgrid (varargin{:}); p = cat (nargin+1, p{:}); p = reshape (p, [], nargin); endfunction %!assert(cartprod(1:2,0:1),[1 0; 2 0; 1 1; 2 1]) linear-algebra/inst/circulant_inv.m0000644000175000017500000000373511743761216017274 0ustar juanpijuanpi## Copyright (C) 2012 Nir Krakauer ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{c} =} circulant_inv (@var{v}) ## ## Fast, compact calculation of inverse of a circulant matrix@* ## Given an @var{n}*1 vector @var{v}, return the inverse @var{c} of the @var{n}*@var{n} circulant matrix @var{C} that has @var{v} as its first column ## The returned @var{c} is the first column of the inverse, which is also circulant -- to get the full matrix, use `circulant_make_matrix(c)' ## ## Theoretically same as @code{inv(make_circulant_matrix(v))(:, 1)}, but requires many fewer computations and does not form matrices explicitly ## ## Roundoff may induce a small imaginary component in @var{c} even if @var{v} is real -- use @code{real(c)} to remedy this ## ## Reference: Robert M. Gray, Toeplitz and Circulant Matrices: A Review, Now Publishers, http://ee.stanford.edu/~gray/toeplitz.pdf, Chapter 3 ## ## @seealso{circulant_make_matrix, circulant_matrix_vector_product, circulant_eig} ## @end deftypefn function c = circulant_inv(v) ## Find the eigenvalues and eigenvectors [vs, lambda] = circulant_eig(v); ## Find the first column of the inverse c = vs * diag(1 ./ diag(lambda)) * conj(vs(:, 1)); endfunction %!shared v %! v = [1 2 3]'; %!assert (make_circulant_matrix(circulant_inv(v)), inv(make_circulant_matrix(v)), 10*eps); linear-algebra/inst/nmf_bpas.m0000644000175000017500000006760711756365401016231 0ustar juanpijuanpi## Copyright (c) 2012 by Jingu Kim and Haesun Park ## ## This program 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 ## any later version. ## ## 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. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{W}, @var{H}, @var{iter}, @var{HIS}] = } nmf_bpas (@var{A}, @var{k}) ## Nonnegative Matrix Factorization by Alternating Nonnegativity Constrained Least Squares ## using Block Principal Pivoting/Active Set method. ## ## This function solves one the following problems: given @var{A} and @var{k}, find @var{W} and @var{H} such that ## (1) minimize 1/2 * || @var{A}-@var{W}@var{H} ||_F^2 ## (2) minimize 1/2 * ( || @var{A}-@var{W}@var{H} ||_F^2 + alpha * || @var{W} ||_F^2 + beta * || @var{H} ||_F^2 ) ## (3) minimize 1/2 * ( || @var{A}-@var{W}@var{H} ||_F^2 + alpha * || @var{W} ||_F^2 + beta * (sum_(i=1)^n || @var{H}(:,i) ||_1^2 ) ) ## where @var{W}>=0 and @var{H}>=0 elementwise. ## The input arguments are @var{A} : Input data matrix (m x n) and @var{k} : Target low-rank. ## ## ## @strong{Optional Inputs} ## @table @samp ## @item Type : Default is 'regularized', which is recommended for quick application testing unless 'sparse' or 'plain' is explicitly needed. If sparsity is needed for 'W' factor, then apply this function for the transpose of 'A' with formulation (3). Then, exchange 'W' and 'H' and obtain the transpose of them. Imposing sparsity for both factors is not recommended and thus not included in this software. ## @table @asis ## @item 'plain' to use formulation (1) ## @item 'regularized' to use formulation (2) ## @item 'sparse' to use formulation (3) ## @end table ## ## @item NNLSSolver : Default is 'bp', which is in general faster. ## @table @asis ## item 'bp' to use the algorithm in [1] ## item 'as' to use the algorithm in [2] ## @end table ## ## @item Alpha : Parameter alpha in the formulation (2) or (3). Default is the average of all elements in A. No good justfication for this default value, and you might want to try other values. ## @item Beta : Parameter beta in the formulation (2) or (3). ## Default is the average of all elements in A. No good justfication for this default value, and you might want to try other values. ## @item MaxIter : Maximum number of iterations. Default is 100. ## @item MinIter : Minimum number of iterations. Default is 20. ## @item MaxTime : Maximum amount of time in seconds. Default is 100,000. ## @item Winit : (m x k) initial value for W. ## @item Hinit : (k x n) initial value for H. ## @item Tol : Stopping tolerance. Default is 1e-3. If you want to obtain a more accurate solution, decrease TOL and increase MAX_ITER at the same time. ## @item Verbose : ## @table @asis ## @item 0 (default) - No debugging information is collected.@* ## @item 1 (debugging purpose) - History of computation is returned by 'HIS' variable. ## @item 2 (debugging purpose) - History of computation is additionally printed on screen. ## @end table ## @end table ## ## @strong{Outputs} ## @table @samp ## @item W : Obtained basis matrix (m x k) ## @item H : Obtained coefficients matrix (k x n) ## @item iter : Number of iterations ## @item HIS : (debugging purpose) History of computation ## @end table ## ## Usage Examples: ## @example ## nmf(A,10) ## nmf(A,20,'verbose',2) ## nmf(A,30,'verbose',2,'nnls_solver','as') ## nmf(A,5,'verbose',2,'type','sparse') ## nmf(A,60,'verbose',1,'type','plain','w_init',rand(m,k)) ## nmf(A,70,'verbose',2,'type','sparse','nnls_solver','bp','alpha',1.1,'beta',1.3) ## @end example ## ## References: ## [1] For using this software, please cite:@* ## Jingu Kim and Haesun Park, Toward Faster Nonnegative Matrix Factorization: A New Algorithm and Comparisons,@* ## In Proceedings of the 2008 Eighth IEEE International Conference on Data Mining (ICDM'08), 353-362, 2008@* ## [2] If you use 'nnls_solver'='as' (see below), please cite:@* ## Hyunsoo Kim and Haesun Park, Nonnegative Matrix Factorization Based @* ## on Alternating Nonnegativity Constrained Least Squares and Active Set Method, @* ## SIAM Journal on Matrix Analysis and Applications, 2008, 30, 713-730 ## ## Check original code at @url{http://www.cc.gatech.edu/~jingu} ## ## @seealso{nmf_pg} ## @end deftypefn ## 2012 - Modified and adapted to Octave 3.6.1 by ## Juan Pablo Carbajal # TODO # - Format code. # - Vectorize loops. function [W, H, iter, HIS] = nmf_bpas (A, k , varargin) page_screen_output (0, "local"); [m,n] = size(A); ST_RULE = 1; # --- Parse arguments --- # parser = inputParser (); parser.FunctionName = "nmf_bpas"; parser = addParamValue (parser,'Winit', rand(m,k), @ismatrix); parser = addParamValue (parser,'Hinit', rand(k,n), @ismatrix); parser = addParamValue (parser,'Tol', 1e-3, @(x)x>0); parser = addParamValue (parser,'Alpha', mean (A(:)), @(x)x>=0); parser = addParamValue (parser,'Beta', mean (A(:)), @(x)x>=0); parser = addParamValue (parser,'MaxIter', 100, @(x)x>0); parser = addParamValue (parser,'MaxTime', 1e3, @(x)x>0); parser = addParamValue (parser,'Verbose', false); val_type = @(x,c) ischar (x) && any (strcmpi (x,c)); parser = addParamValue (parser,'Type', 'regularized', ... @(x)val_type (x,{'regularized', 'sparse','plain'})); parser = addParamValue (parser,'NNLSSolver', 'bp', ... @(x)val_type (x,{'bp', 'as'})); parser = parse(parser,varargin{:}); % Default configuration par.m = m; par.n = n; par.type = parser.Results.Type; par.nnls_solver = parser.Results.NNLSSolver; par.alpha = parser.Results.Alpha; par.beta = parser.Results.Beta; par.max_iter = parser.Results.MaxIter; par.min_iter = 20; par.max_time = parser.Results.MaxTime; par.tol = parser.Results.Tol; par.verbose = parser.Results.Verbose; W = parser.Results.Winit; H = parser.Results.Hinit; # TODO check if can be removed argAlpha = par.alpha; argBeta = par.beta; clear parser val_type ### PARSING TYPE # TODO add callbacks here to use during main loop. See [1] % for regularized/sparse case salphaI = sqrt (par.alpha) * eye (k); zerokm = zeros (k,m); if strcmpi (par.type, 'regularized') sbetaI = sqrt (par.beta) * eye (k); zerokn = zeros (k,n); elseif strcmpi (par.type, 'sparse') sbetaE = sqrt (par.beta) * ones (1,k); betaI = par.beta * ones (k,k); zero1n = zeros (1,n); end ### # Verbosity display(par); ### Done till here Sun Mar 25 19:00:26 2012 HIS = 0; if par.verbose % collect information for analysis/debugging [gradW,gradH] = getGradient(A,W,H,par.type,par.alpha,par.beta); initGrNormW = norm(gradW,'fro'); initGrNormH = norm(gradH,'fro'); initNorm = norm(A,'fro'); numSC = 3; initSCs = zeros(numSC,1); for j=1:numSC initSCs(j) = getInitCriterion(j,A,W,H,par.type,par.alpha,par.beta,gradW,gradH); end %---(1)------(2)--------(3)--------(4)--------(5)---------(6)----------(7)------(8)-----(9)-------(10)--------------(11)------- % iter # | elapsed | totalTime | subIterW | subIterH | rel. obj.(%) | NM_GRAD | GRAD | DELTA | W density (%) | H density (%) %------------------------------------------------------------------------------------------------------------------------------ HIS = zeros(1,11); HIS(1,[1:5])=0; ver.initGrNormW = initGrNormW; ver.initGrNormH = initGrNormH; ver.initNorm = initNorm; HIS(1,6) = ver.initNorm; ver.SC1 = initSCs(1); HIS(1,7) = ver.SC1; ver.SC2 = initSCs(2); HIS(1,8) = ver.SC2; ver.SC3 = initSCs(3); HIS(1,9) = ver.SC3; ver.W_density = length(find(W>0))/(m*k); HIS(1,10) = ver.W_density; ver.H_density = length(find(H>0))/(n*k); HIS(1,11) = ver.H_density; if par.verbose == 2 disp (ver); end tPrev = cputime; end tStart = cputime; tTotal = 0; initSC = getInitCriterion(ST_RULE,A,W,H,par.type,par.alpha,par.beta); SCconv = 0; SC_COUNT = 3; #TODO: [1] Replace with callbacks avoid switching each time for iter=1:par.max_iter switch par.type case 'plain' [H,gradHX,subIterH] = nnlsm(W,A,H,par.nnls_solver); [W,gradW,subIterW] = nnlsm(H',A',W',par.nnls_solver);, W=W';, gradW=gradW'; gradH = (W'*W)*H - W'*A; case 'regularized' [H,gradHX,subIterH] = nnlsm([W;sbetaI],[A;zerokn],H,par.nnls_solver); [W,gradW,subIterW] = nnlsm([H';salphaI],[A';zerokm],W',par.nnls_solver);, W=W';, gradW=gradW'; gradH = (W'*W)*H - W'*A + par.beta*H; case 'sparse' [H,gradHX,subIterH] = nnlsm([W;sbetaE],[A;zero1n],H,par.nnls_solver); [W,gradW,subIterW] = nnlsm([H';salphaI],[A';zerokm],W',par.nnls_solver);, W=W';, gradW=gradW'; gradH = (W'*W)*H - W'*A + betaI*H; end if par.verbose % collect information for analysis/debugging elapsed = cputime-tPrev; tTotal = tTotal + elapsed; ver = []; idx = iter+1; %---(1)------(2)--------(3)--------(4)--------(5)---------(6)----------(7)------(8)-----(9)-------(10)--------------(11)------- % iter # | elapsed | totalTime | subIterW | subIterH | rel. obj.(%) | NM_GRAD | GRAD | DELTA | W density (%) | H density (%) %------------------------------------------------------------------------------------------------------------------------------ ver.iter = iter; HIS(idx,1)=iter; ver.elapsed = elapsed; HIS(idx,2)=elapsed; ver.tTotal = tTotal; HIS(idx,3)=tTotal; ver.subIterW = subIterW; HIS(idx,4)=subIterW; ver.subIterH = subIterH; HIS(idx,5)=subIterH; ver.relError = norm(A-W*H,'fro')/initNorm; HIS(idx,6)=ver.relError; ver.SC1 = getStopCriterion(1,A,W,H,par.type,par.alpha,par.beta,gradW,gradH)/initSCs(1); HIS(idx,7)=ver.SC1; ver.SC2 = getStopCriterion(2,A,W,H,par.type,par.alpha,par.beta,gradW,gradH)/initSCs(2); HIS(idx,8)=ver.SC2; ver.SC3 = getStopCriterion(3,A,W,H,par.type,par.alpha,par.beta,gradW,gradH)/initSCs(3); HIS(idx,9)=ver.SC3; ver.W_density = length(find(W>0))/(m*k); HIS(idx,10)=ver.W_density; ver.H_density = length(find(H>0))/(n*k); HIS(idx,11)=ver.H_density; if par.verbose == 2, display(ver);, end tPrev = cputime; end if (iter > par.min_iter) SC = getStopCriterion(ST_RULE,A,W,H,par.type,par.alpha,par.beta,gradW,gradH); if (par.verbose && (tTotal > par.max_time)) || (~par.verbose && ((cputime-tStart)>par.max_time)) break; elseif (SC/initSC <= par.tol) SCconv = SCconv + 1; if (SCconv >= SC_COUNT) break; end else SCconv = 0; end end end [m,n]=size(A); norm2=sqrt(sum(W.^2,1)); toNormalize = norm2>0; W(:,toNormalize) = W(:,toNormalize)./repmat(norm2(toNormalize),m,1); H(toNormalize,:) = H(toNormalize,:).*repmat(norm2(toNormalize)',1,n); final.iterations = iter; if par.verbose final.elapsed_total = tTotal; else final.elapsed_total = cputime-tStart; end final.relative_error = norm(A-W*H,'fro')/norm(A,'fro'); final.W_density = length(find(W>0))/(m*k); final.H_density = length(find(H>0))/(n*k); display(final); endfunction %------------------------------------------------------------------------------------------------------------------------ % Utility Functions %------------------------------------------------------------------------------- function retVal = getInitCriterion(stopRule,A,W,H,type,alpha,beta,gradW,gradH) % STOPPING_RULE : 1 - Normalized proj. gradient % 2 - Proj. gradient % 3 - Delta by H. Kim % 0 - None (want to stop by MAX_ITER or MAX_TIME) if nargin~=9 [gradW,gradH] = getGradient(A,W,H,type,alpha,beta); end [m,k]=size(W);, [k,n]=size(H);, numAll=(m*k)+(k*n); switch stopRule case 1 retVal = norm([gradW; gradH'],'fro')/numAll; case 2 retVal = norm([gradW; gradH'],'fro'); case 3 retVal = getStopCriterion(3,A,W,H,type,alpha,beta,gradW,gradH); case 0 retVal = 1; end endfunction %------------------------------------------------------------------------------- function retVal = getStopCriterion(stopRule,A,W,H,type,alpha,beta,gradW,gradH) % STOPPING_RULE : 1 - Normalized proj. gradient % 2 - Proj. gradient % 3 - Delta by H. Kim % 0 - None (want to stop by MAX_ITER or MAX_TIME) if nargin~=9 [gradW,gradH] = getGradient(A,W,H,type,alpha,beta); end switch stopRule case 1 pGradW = gradW(gradW<0|W>0); pGradH = gradH(gradH<0|H>0); pGrad = [gradW(gradW<0|W>0); gradH(gradH<0|H>0)]; pGradNorm = norm(pGrad); retVal = pGradNorm/length(pGrad); case 2 pGradW = gradW(gradW<0|W>0); pGradH = gradH(gradH<0|H>0); pGrad = [gradW(gradW<0|W>0); gradH(gradH<0|H>0)]; retVal = norm(pGrad); case 3 resmat=min(H,gradH); resvec=resmat(:); resmat=min(W,gradW); resvec=[resvec; resmat(:)]; deltao=norm(resvec,1); %L1-norm num_notconv=length(find(abs(resvec)>0)); retVal=deltao/num_notconv; case 0 retVal = 1e100; end endfunction %------------------------------------------------------------------------------- function [gradW,gradH] = getGradient(A,W,H,type,alpha,beta) switch type case 'plain' gradW = W*(H*H') - A*H'; gradH = (W'*W)*H - W'*A; case 'regularized' gradW = W*(H*H') - A*H' + alpha*W; gradH = (W'*W)*H - W'*A + beta*H; case 'sparse' k=size(W,2); betaI = beta*ones(k,k); gradW = W*(H*H') - A*H' + alpha*W; gradH = (W'*W)*H - W'*A + betaI*H; end endfunction %------------------------------------------------------------------------------------------------------------------------ function [X,grad,iter] = nnlsm(A,B,init,solver) switch solver case 'bp' [X,grad,iter] = nnlsm_blockpivot(A,B,0,init); case 'as' [X,grad,iter] = nnlsm_activeset(A,B,1,0,init); end endfunction %------------------------------------------------------------------------------------------------------------------------ function [ X,Y,iter,success ] = nnlsm_activeset( A, B, overwrite, isInputProd, init) % Nonnegativity Constrained Least Squares with Multiple Righthand Sides % using Active Set method % % This software solves the following problem: given A and B, find X such that % minimize || AX-B ||_F^2 where X>=0 elementwise. % % Reference: % Charles L. Lawson and Richard J. Hanson, Solving Least Squares Problems, % Society for Industrial and Applied Mathematics, 1995 % M. H. Van Benthem and M. R. Keenan, % Fast Algorithm for the Solution of Large-scale Non-negativity-constrained Least Squares Problems, % J. Chemometrics 2004; 18: 441-450 % % Written by Jingu Kim (jingu@cc.gatech.edu) % School of Computational Science and Engineering, % Georgia Institute of Technology % % Last updated Feb-20-2010 % % % A : input matrix (m x n) (by default), or A'*A (n x n) if isInputProd==1 % B : input matrix (m x k) (by default), or A'*B (n x k) if isInputProd==1 % overwrite : (optional, default:0) if turned on, unconstrained least squares solution is computed in the beginning % isInputProd : (optional, default:0) if turned on, use (A'*A,A'*B) as input instead of (A,B) % init : (optional) initial value for X % % X : the solution (n x k) % Y : A'*A*X - A'*B where X is the solution (n x k) % iter : number of iterations % success : 1 for success, 0 for failure. % Failure could only happen on a numericall very ill-conditioned problem. if nargin<3, overwrite=0;, end if nargin<4, isInputProd=0;, end if isInputProd AtA=A;,AtB=B; else AtA=A'*A;, AtB=A'*B; end [n,k]=size(AtB); MAX_ITER = n*5; % set initial feasible solution if overwrite [X,iter] = solveNormalEqComb(AtA,AtB); PassSet = (X > 0); NotOptSet = any(X<0); else if nargin<5 X = zeros(n,k); PassSet = false(n,k); NotOptSet = true(1,k); else X = init; PassSet = (X > 0); NotOptSet = any(X<0); end iter = 0; end Y = zeros(n,k); Y(:,~NotOptSet)=AtA*X(:,~NotOptSet) - AtB(:,~NotOptSet); NotOptCols = find(NotOptSet); bigIter = 0;, success=1; while(~isempty(NotOptCols)) bigIter = bigIter+1; if ((MAX_ITER >0) && (bigIter > MAX_ITER)) % set max_iter for ill-conditioned (numerically unstable) case success = 0;, bigIter, break end % find unconstrained LS solution for the passive set Z = zeros(n,length(NotOptCols)); [ Z,subiter ] = solveNormalEqComb(AtA,AtB(:,NotOptCols),PassSet(:,NotOptCols)); iter = iter + subiter; %Z(abs(Z)<1e-12) = 0; % One can uncomment this line for numerical stability. InfeaSubSet = Z < 0; InfeaSubCols = find(any(InfeaSubSet)); FeaSubCols = find(all(~InfeaSubSet)); if ~isempty(InfeaSubCols) % for infeasible cols ZInfea = Z(:,InfeaSubCols); InfeaCols = NotOptCols(InfeaSubCols); Alpha = zeros(n,length(InfeaSubCols));, Alpha(:,:) = Inf; InfeaSubSet(:,InfeaSubCols); [i,j] = find(InfeaSubSet(:,InfeaSubCols)); InfeaSubIx = sub2ind(size(Alpha),i,j); if length(InfeaCols) == 1 InfeaIx = sub2ind([n,k],i,InfeaCols * ones(length(j),1)); else InfeaIx = sub2ind([n,k],i,InfeaCols(j)'); end Alpha(InfeaSubIx) = X(InfeaIx)./(X(InfeaIx)-ZInfea(InfeaSubIx)); [minVal,minIx] = min(Alpha); Alpha(:,:) = repmat(minVal,n,1); X(:,InfeaCols) = X(:,InfeaCols)+Alpha.*(ZInfea-X(:,InfeaCols)); IxToActive = sub2ind([n,k],minIx,InfeaCols); X(IxToActive) = 0; PassSet(IxToActive) = false; end if ~isempty(FeaSubCols) % for feasible cols FeaCols = NotOptCols(FeaSubCols); X(:,FeaCols) = Z(:,FeaSubCols); Y(:,FeaCols) = AtA * X(:,FeaCols) - AtB(:,FeaCols); %Y( abs(Y)<1e-12 ) = 0; % One can uncomment this line for numerical stability. NotOptSubSet = (Y(:,FeaCols) < 0) & ~PassSet(:,FeaCols); NewOptCols = FeaCols(all(~NotOptSubSet)); UpdateNotOptCols = FeaCols(any(NotOptSubSet)); if ~isempty(UpdateNotOptCols) [minVal,minIx] = min(Y(:,UpdateNotOptCols).*~PassSet(:,UpdateNotOptCols)); PassSet(sub2ind([n,k],minIx,UpdateNotOptCols)) = true; end NotOptSet(NewOptCols) = false; NotOptCols = find(NotOptSet); end end endfunction %------------------------------------------------------------------------------------------------------------------------ function [ X,Y,iter,success ] = nnlsm_blockpivot( A, B, isInputProd, init ) % Nonnegativity Constrained Least Squares with Multiple Righthand Sides % using Block Principal Pivoting method % % This software solves the following problem: given A and B, find X such that % minimize || AX-B ||_F^2 where X>=0 elementwise. % % Reference: % Jingu Kim and Haesun Park, Toward Faster Nonnegative Matrix Factorization: A New Algorithm and Comparisons, % In Proceedings of the 2008 Eighth IEEE International Conference on Data Mining (ICDM'08), 353-362, 2008 % % Written by Jingu Kim (jingu@cc.gatech.edu) % Copyright 2008-2009 by Jingu Kim and Haesun Park, % School of Computational Science and Engineering, % Georgia Institute of Technology % % Check updated code at http://www.cc.gatech.edu/~jingu % Please send bug reports, comments, or questions to Jingu Kim. % This code comes with no guarantee or warranty of any kind. Note that this algorithm assumes that the % input matrix A has full column rank. % % Last modified Feb-20-2009 % % % A : input matrix (m x n) (by default), or A'*A (n x n) if isInputProd==1 % B : input matrix (m x k) (by default), or A'*B (n x k) if isInputProd==1 % isInputProd : (optional, default:0) if turned on, use (A'*A,A'*B) as input instead of (A,B) % init : (optional) initial value for X % % X : the solution (n x k) % Y : A'*A*X - A'*B where X is the solution (n x k) % iter : number of iterations % success : 1 for success, 0 for failure. % Failure could only happen on a numericall very ill-conditioned problem. if nargin<3, isInputProd=0;, end if isInputProd AtA = A;, AtB = B; else AtA = A'*A;, AtB = A'*B; end [n,k]=size(AtB); MAX_ITER = n*5; % set initial feasible solution X = zeros(n,k); if nargin<4 Y = - AtB; PassiveSet = false(n,k); iter = 0; else PassiveSet = (init > 0); [ X,iter ] = solveNormalEqComb(AtA,AtB,PassiveSet); Y = AtA * X - AtB; end % parameters pbar = 3; P = zeros(1,k);, P(:) = pbar; Ninf = zeros(1,k);, Ninf(:) = n+1; iter = 0; NonOptSet = (Y < 0) & ~PassiveSet; InfeaSet = (X < 0) & PassiveSet; NotGood = sum(NonOptSet)+sum(InfeaSet); NotOptCols = NotGood > 0; bigIter = 0;, success=1; while(~isempty(find(NotOptCols))) bigIter = bigIter+1; if ((MAX_ITER >0) && (bigIter > MAX_ITER)) % set max_iter for ill-conditioned (numerically unstable) case success = 0;, break end Cols1 = NotOptCols & (NotGood < Ninf); Cols2 = NotOptCols & (NotGood >= Ninf) & (P >= 1); Cols3Ix = find(NotOptCols & ~Cols1 & ~Cols2); if ~isempty(find(Cols1)) P(Cols1) = pbar;,Ninf(Cols1) = NotGood(Cols1); PassiveSet(NonOptSet & repmat(Cols1,n,1)) = true; PassiveSet(InfeaSet & repmat(Cols1,n,1)) = false; end if ~isempty(find(Cols2)) P(Cols2) = P(Cols2)-1; PassiveSet(NonOptSet & repmat(Cols2,n,1)) = true; PassiveSet(InfeaSet & repmat(Cols2,n,1)) = false; end if ~isempty(Cols3Ix) for i=1:length(Cols3Ix) Ix = Cols3Ix(i); toChange = max(find( NonOptSet(:,Ix)|InfeaSet(:,Ix) )); if PassiveSet(toChange,Ix) PassiveSet(toChange,Ix)=false; else PassiveSet(toChange,Ix)=true; end end end NotOptMask = repmat(NotOptCols,n,1); [ X(:,NotOptCols),subiter ] = solveNormalEqComb(AtA,AtB(:,NotOptCols),PassiveSet(:,NotOptCols)); iter = iter + subiter; X(abs(X)<1e-12) = 0; % for numerical stability Y(:,NotOptCols) = AtA * X(:,NotOptCols) - AtB(:,NotOptCols); Y(abs(Y)<1e-12) = 0; % for numerical stability % check optimality NonOptSet = NotOptMask & (Y < 0) & ~PassiveSet; InfeaSet = NotOptMask & (X < 0) & PassiveSet; NotGood = sum(NonOptSet)+sum(InfeaSet); NotOptCols = NotGood > 0; end endfunction %------------------------------------------------------------------------------------------------------------------------ function [ Z,iter ] = solveNormalEqComb( AtA,AtB,PassSet ) % Solve normal equations using combinatorial grouping. % Although this function was originally adopted from the code of % "M. H. Van Benthem and M. R. Keenan, J. Chemometrics 2004; 18: 441-450", % important modifications were made to fix bugs. % % Modified by Jingu Kim (jingu@cc.gatech.edu) % School of Computational Science and Engineering, % Georgia Institute of Technology % % Last updated Aug-12-2009 iter = 0; if (nargin ==2) || isempty(PassSet) || all(PassSet(:)) Z = AtA\AtB; iter = iter + 1; else Z = zeros(size(AtB)); [n,k1] = size(PassSet); ## Fixed on Aug-12-2009 if k1==1 Z(PassSet)=AtA(PassSet,PassSet)\AtB(PassSet); else ## Fixed on Aug-12-2009 % The following bug was identified by investigating a bug report by Hanseung Lee. [sortedPassSet,sortIx] = sortrows(PassSet'); breaks = any(diff(sortedPassSet)'); breakIx = [0 find(breaks) k1]; % codedPassSet = 2.^(n-1:-1:0)*PassSet; % [sortedPassSet,sortIx] = sort(codedPassSet); % breaks = diff(sortedPassSet); % breakIx = [0 find(breaks) k1]; for k=1:length(breakIx)-1 cols = sortIx(breakIx(k)+1:breakIx(k+1)); vars = PassSet(:,sortIx(breakIx(k)+1)); Z(vars,cols) = AtA(vars,vars)\AtB(vars,cols); iter = iter + 1; end end end endfunction %!shared m, n, k, A %! m = 30; %! n = 20; %! k = 10; %! A = rand(m,n); %!test %! [W,H,iter,HIS]=nmf_bpas(A,k); %!test %! [W,H,iter,HIS]=nmf_bpas(A,k,'verbose',2); %!test %! [W,H,iter,HIS]=nmf_bpas(A,k,'verbose',1,'nnls_solver','as'); %!test %! [W,H,iter,HIS]=nmf_bpas(A,k,'verbose',1,'type','sparse'); %!test %! [W,H,iter,HIS]=nmf_bpas(A,k,'verbose',1,'type','sparse','nnls_solver','bp','alpha',1.1,'beta',1.3); %!test %! [W,H,iter,HIS]=nmf_bpas(A,k,'verbose',2,'type','plain','w_init',rand(m,k)); %!demo %! m = 300; %! n = 200; %! k = 10; %! %! W_org = rand(m,k);, W_org(rand(m,k)>0.5)=0; %! H_org = rand(k,n);, H_org(rand(k,n)>0.5)=0; %! %! % normalize W, since 'nmf' normalizes W before return %! norm2=sqrt(sum(W_org.^2,1)); %! toNormalize = norm2>0; %! W_org(:,toNormalize) = W_org(:,toNormalize)./repmat(norm2(toNormalize),m,1); %! %! A = W_org * H_org; %! %! [W,H,iter,HIS]=nmf_bpas (A,k,'type','plain','tol',1e-4); %! %! % -------------------- column reordering before computing difference %! reorder = zeros(k,1); %! selected = zeros(k,1); %! for i=1:k %! for j=1:k %! if ~selected(j), break, end %! end %! minIx = j; %! %! for j=minIx+1:k %! if ~selected(j) %! d1 = norm(W(:,i)-W_org(:,minIx)); %! d2 = norm(W(:,i)-W_org(:,j)); %! if (d2. ## -*- texinfo -*- ## @deftypefn{Function File} {@var{x} =} smwsolve (@var{a}, @var{u}, @var{v}, @var{b}) ## @deftypefnx{Function File} {} smwsolve (@var{solver}, @var{u}, @var{v}, @var{b}) ## Solves the square system @code{(A + U*V')*X == B}, where @var{u} and @var{v} are ## matrices with several columns, using the Sherman-Morrison-Woodbury formula, ## so that a system with @var{a} as left-hand side is actually solved. This is ## especially advantageous if @var{a} is diagonal, sparse, triangular or ## positive definite. ## @var{a} can be sparse or full, the other matrices are expected to be full. ## Instead of a matrix @var{a}, a user may alternatively provide a function ## @var{solver} that performs the left division operation. ## @end deftypefn ## Author: Jaroslav Hajek function x = smwsolve (a, u, v, b) if (nargin != 4) print_usage (); endif n = columns (u); if (n != columns (v) || rows (a) != rows (u) || columns (a) != rows (v)) error ("smwsolve: dimension mismatch"); elseif (! issquare (a)) error ("smwsolve: need a square matrix"); endif nc = columns (b); n = columns (u); if (ismatrix (a)) xx = a \ [b, u]; elseif (isa (a, "function_handle")) xx = a ([b, u]); if (rows (xx) != rows (a) || columns (xx) != (nc + n)) error ("smwsolve: invalid result from a solver function"); endif else error ("smwsolve: a must be a matrix or function handle"); endif x = xx(:,1:nc); y = xx(:,nc+1:nc+n); vxx = v' * xx; vx = vxx(:,1:nc); vy = vxx(:,nc+1:nc+n); x = x - y * ((eye (n) + vy) \ vx); endfunction %!test %! A = 2.1*eye (10); %! u = rand (10, 2); u /= diag (norm (u, "cols")); %! v = rand (10, 2); v /= diag (norm (v, "cols")); %! b = rand (10, 2); %! x1 = (A + u*v') \ b; %! x2 = smwsolve (A, u, v, b); %! assert (x1, x2, 1e-13); linear-algebra/inst/nmf_pg.m0000644000175000017500000002052111756365401015672 0ustar juanpijuanpi## Copyright (C) 2005-2006 Chih-Jen Lin ## All rights reserved. ## ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions are met: ## ## 1 Redistributions of source code must retain the above copyright notice, ## this list of conditions and the following disclaimer. ## 2 Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ## IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ## ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR ## ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ## DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, ## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ## OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ## ## The views and conclusions contained in the software and documentation are ## those of the authors and should not be interpreted as representing official ## policies, either expressed or implied, of the copyright holders. ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{W}, @var{H}] =} nmf_pg (@var{V}, @var{Winit}, @ ## @var{Hinit}, @var{tol}, @var{timelimit}, @var{maxiter}) ## ## Non-negative matrix factorization by alternative non-negative least squares ## using projected gradients. ## ## The matrix @var{V} is factorized into two possitive matrices @var{W} and ## @var{H} such that @code{V = W*H + U}. Where @var{U} is a matrix of residuals ## that can be negative or positive. When the matrix @var{V} is positive the order ## of the elements in @var{U} is bounded by the optional named argument @var{tol} ## (default value @code{1e-9}). ## ## The factorization is not unique and depends on the inital guess for the matrices ## @var{W} and @var{H}. You can pass this initalizations using the optional ## named arguments @var{Winit} and @var{Hinit}. ## ## timelimit, maxiter: limit of time and iterations ## ## Examples: ## ## @example ## A = rand(10,5); ## [W H] = nmf_pg(A,tol=1e-3); ## U = W*H -A; ## disp(max(abs(U))); ## @end example ## ## @end deftypefn ## 2012 - Modified and adapted to Octave 3.6.1 by ## Juan Pablo Carbajal function [W, H] = nmf_pg (V, varargin) # JuanPi Fri 16 Mar 2012 10:49:11 AM CET # TODO: # - finish docstring # - avoid multiple transpositions # --- Parse arguments --- # parser = inputParser (); parser.FunctionName = "nmf_pg"; parser = addParamValue (parser,'Winit', [], @ismatrix); parser = addParamValue (parser,'Hinit', [], @ismatrix); parser = addParamValue (parser,'Tol', 1e-6, @(x)x>0); parser = addParamValue (parser,'TimeLimit', 10, @(x)x>0); parser = addParamValue (parser,'MaxIter', 100, @(x)x>0); parser = addParamValue (parser,'MaxSubIter', 1e3, @(x)x>0); parser = addParamValue (parser,'Verbose', true); parser = parse(parser,varargin{:}); Winit = parser.Results.Winit; Hinit = parser.Results.Hinit; tol = parser.Results.Tol; timelimit = parser.Results.TimeLimit; maxiter = parser.Results.MaxIter; maxsubiter = parser.Results.MaxSubIter; verbose = parser.Results.Verbose; clear parser # ------ # # --- Initialize matrices --- # [r c] = size (V); Hgiven = !isempty (Hinit); Wgiven = !isempty (Winit); if Wgiven && !Hgiven W = Winit; H = ones (size (W,2),c); elseif !Wgiven && Hgiven H = Hinit; W = ones (r, size(H,2)); elseif !Wgiven && !Hgiven if r == c W = ones (r) H = W else W = ones (r); H = ones (r,c); end else W = Winit; H = Hinit; end [Hr,Hc] = size(H); [Wr,Wc] = size(W); # start tracking time initt = cputime (); gradW = W*(H*H') - V*H'; gradH = (W'*W)*H - W'*V; initgrad = norm([gradW; gradH'],'fro'); # Tolerances for matrices tolW = max(0.001,tol)*initgrad; tolH = tolW; # ------ # # --- Main Loop --- # if verbose fprintf ('--- Factorizing %d-by-%d matrix into %d-by-%d times %d-by-%d\n',... r,c,Wr,Wc,Hr,Hc); fprintf ("Initial gradient norm = %f\n", initgrad); fflush (stdout); text_waitbar(0,'Please wait ...'); end for iter = 1:maxiter # stopping condition projnorm = norm ( [ gradW(gradW<0 | W>0); gradH(gradH<0 | H>0) ] ); stop_cond = [projnorm < tol*initgrad , cputime-initt > timelimit]; if any (stop_cond) if stop_cond(2) warning('mnf_pg:MaxIter',["Time limit exceeded.\n" ... "Could be solved increasing TimeLimit.\n"]); end break end # FIXME: avoid multiple transpositions [W, gradW, iterW] = nlssubprob(V', H', W', tolW, maxsubiter, verbose); W = W'; gradW = gradW'; if iterW == 1, tolW = 0.1 * tolW; end [H, gradH, iterH] = nlssubprob(V, W, H, tolH, maxsubiter, verbose); if iterH == 1, tolH = 0.1 * tolH; end if (iterW == 1 && iterH == 1 && tolH + tolW < tol*initgrad), warning ('nmf_pg:InvalidArgument','Failed to move'); break end if verbose text_waitbar (iter/maxiter); end end if iter == maxiter warning('mnf_pg:MaxIter',["Reached maximum iterations in main loop.\n" ... "Could be solved increasing MaxIter.\n"]); end if verbose fprintf ('\nIterations = %d\nFinal proj-grad norm = %f\n', iter, projnorm); fflush (stdout); end endfunction function [H, grad,iter] = nlssubprob(V,W,Hinit,tol,maxiter,verbose) % H, grad: output solution and gradient % iter: #iterations used % V, W: constant matrices % Hinit: initial solution % tol: stopping tolerance % maxiter: limit of iterations H = Hinit; WtV = W'*V; WtW = W'*W; alpha = 1; beta = 0.1; for iter=1:maxiter grad = WtW*H - WtV; projgrad = norm ( grad(grad < 0 | H >0) ); if projgrad < tol, break end % search step size Hn = max(H - alpha*grad, 0); d = Hn-H; gradd = sum ( sum (grad.*d) ); dQd = sum ( sum ((WtW*d).*d) ); if gradd + 0.5*dQd > 0.01*gradd, % decrease alpha while 1, alpha *= beta; Hn = max (H - alpha*grad, 0); d = Hn-H; gradd = sum (sum (grad.*d) ); dQd = sum (sum ((WtW*d).*d)); if gradd + 0.5*dQd <= 0.01*gradd || alpha < 1e-20 H = Hn; break end endwhile else % increase alpha while 1, Hp = Hn; alpha /= beta; Hn = max (H - alpha*grad, 0); d = Hn-H; gradd = sum ( sum (grad.*d) ); dQd = sum (sum ( (WtW*d).*d ) ); if gradd + 0.5*dQd > 0.01*gradd || Hn == Hp || alpha > 1e10 H = Hp; alpha *= beta; break end endwhile end endfor if iter == maxiter warning('mnf_pg:MaxIter',["Reached maximum iterations in nlssubprob\n" ... "Could be solved increasing MaxSubIter.\n"]); end endfunction %!demo %! t = linspace (0,1,100)'; %! %! ## --- Build hump functions of different frequency %! W_true = arrayfun ( @(f)sin(2*pi*f*t).^2, linspace (0.5,2,4), ... %! 'uniformoutput', false ); %! W_true = cell2mat (W_true); %! ## --- Build combinator vectors %! c = (1:4)'; %! H_true = arrayfun ( @(f)circshift(c,f), linspace (0,3,4), ... %! 'uniformoutput', false ); %! H_true = cell2mat (H_true); %! ## --- Mix them %! V = W_true*H_true; %! ## --- Give good inital guesses %! Winit = W_true + 0.4*randn(size(W_true)); %! Hinit = H_true + 0.2*randn(size(H_true)); %! ## --- Factorize %! [W H] = nmf_pg(V,'Winit',Winit,'Hinit',Hinit,'Tol',1e-6,'MaxIter',1e3); %! disp('True mixer') %! disp(H_true) %! disp('Rounded factorized mixer') %! disp(round(H)) %! ## --- Plot results %! plot(t,W,'o;factorized;') %! hold on %! plot(t,W_true,'-;True;') %! hold off %! axis tight linear-algebra/inst/funm.m0000644000175000017500000000627511743761216015403 0ustar juanpijuanpi## Copyright (C) 2000, 2011 P.R. Nienhuis ## Copyright (C) 2001 Paul Kienzle ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{B} =} funm (@var{A}, @var{F}) ## Compute matrix equivalent of function F; F can be a function name or ## a function handle. ## ## For trigonometric and hyperbolic functions, @code{thfm} is automatically ## invoked as that is based on @code{expm} and diagonalization is avoided. ## For other functions diagonalization is invoked, which implies that ## -depending on the properties of input matrix @var{A}- the results ## can be very inaccurate @emph{without any warning}. For easy diagonizable and ## stable matrices results of funm will be sufficiently accurate. ## ## Note that you should not use funm for 'sqrt', 'log' or 'exp'; instead ## use sqrtm, logm and expm as these are more robust. ## ## Examples: ## ## @example ## B = funm (A, sin); ## (Compute matrix equivalent of sin() ) ## @end example ## ## @example ## function bk1 = besselk1 (x) ## bk1 = besselk(x, 1); ## endfunction ## B = funm (A, besselk1); ## (Compute matrix equivalent of bessel function K1(); a helper function ## is needed here to convey extra args for besselk() ) ## @end example ## ## @seealso{thfm, expm, logm, sqrtm} ## @end deftypefn function B = funm (A, name) persistent thfuncs = {"cos", "sin", "tan", "sec", "csc", "cot", ... "cosh", "sinh", "tanh", "sech", "csch", "coth", ... "acos", "asin", "atan", "asec", "acsc", "acot", ... "acosh", "asinh", "atanh", "asech", "acsch", "acoth", ... } ## Function handle supplied? try ishndl = isstruct (functions (name)); fname = functions (name).function; catch ishdnl = 0; fname = ' ' end_try_catch if (nargin < 2 || (!(ischar (name) || ishndl)) || ischar (A)) usage ("B = funm (A, 'f' where A = square matrix and f = function name"); endif if (~isempty (find (ismember (thfuncs, fname)))) ## Use more robust thfm () if (ishndl); name = fname; endif B = thfm (A, name); else ## Simply invoke eigenvalues. Note: risk for repeated eigenvalues!! ## Modeled after suggestion by N. Higham (based on R. Davis, 2007) ## FIXME Do we need automatic setting of TOL? tol = 1.e-15; [V, D] = eig (A + tol * randn (size(A))); D = diag (feval (name, diag(D))); B = V * D / V; endif endfunction linear-algebra/inst/lobpcg.m0000644000175000017500000012260511743761216015700 0ustar juanpijuanpi## Copyright (C) 2000-2011 A.V. Knyazev ## ## This program is free software; you can redistribute it and/or modify it under ## the terms of the GNU Lesser General Public License as published by the Free ## Software Foundation; either version 3 of the License, or (at your option) any ## later version. ## ## 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. See the GNU Lesser General Public License ## for more details. ## ## You should have received a copy of the GNU Lesser General Public License ## along with this program; if not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{blockVectorX}, @var{lambda}] =} lobpcg (@var{blockVectorX}, @var{operatorA}) ## @deftypefnx {Function File} {[@var{blockVectorX}, @var{lambda}, @var{failureFlag}] =} lobpcg (@var{blockVectorX}, @var{operatorA}) ## @deftypefnx {Function File} {[@var{blockVectorX}, @var{lambda}, @var{failureFlag}, @var{lambdaHistory}, @var{residualNormsHistory}] =} lobpcg (@var{blockVectorX}, @var{operatorA}, @var{operatorB}, @var{operatorT}, @var{blockVectorY}, @var{residualTolerance}, @var{maxIterations}, @var{verbosityLevel}) ## Solves Hermitian partial eigenproblems using preconditioning. ## ## The first form outputs the array of algebraic smallest eigenvalues @var{lambda} and ## corresponding matrix of orthonormalized eigenvectors @var{blockVectorX} of the ## Hermitian (full or sparse) operator @var{operatorA} using input matrix ## @var{blockVectorX} as an initial guess, without preconditioning, somewhat ## similar to: ## ## @example ## # for real symmetric operator operatorA ## opts.issym = 1; opts.isreal = 1; K = size (blockVectorX, 2); ## [blockVectorX, lambda] = eigs (operatorA, K, 'SR', opts); ## ## # for Hermitian operator operatorA ## K = size (blockVectorX, 2); ## [blockVectorX, lambda] = eigs (operatorA, K, 'SR'); ## @end example ## ## The second form returns a convergence flag. If @var{failureFlag} is 0 then ## all the eigenvalues converged; otherwise not all converged. ## ## The third form computes smallest eigenvalues @var{lambda} and corresponding eigenvectors ## @var{blockVectorX} of the generalized eigenproblem Ax=lambda Bx, where ## Hermitian operators @var{operatorA} and @var{operatorB} are given as functions, as ## well as a preconditioner, @var{operatorT}. The operators @var{operatorB} and ## @var{operatorT} must be in addition @emph{positive definite}. To compute the largest ## eigenpairs of @var{operatorA}, simply apply the code to @var{operatorA} multiplied by ## -1. The code does not involve @emph{any} matrix factorizations of @var{operatorA} and ## @var{operatorB}, thus, e.g., it preserves the sparsity and the structure of ## @var{operatorA} and @var{operatorB}. ## ## @var{residualTolerance} and @var{maxIterations} control tolerance and max number of ## steps, and @var{verbosityLevel} = 0, 1, or 2 controls the amount of printed ## info. @var{lambdaHistory} is a matrix with all iterative lambdas, and ## @var{residualNormsHistory} are matrices of the history of 2-norms of residuals ## ## Required input: ## @itemize @bullet ## @item ## @var{blockVectorX} (class numeric) - initial approximation to eigenvectors, ## full or sparse matrix n-by-blockSize. @var{blockVectorX} must be full rank. ## @item ## @var{operatorA} (class numeric, char, or function_handle) - the main operator ## of the eigenproblem, can be a matrix, a function name, or handle ## @end itemize ## ## Optional function input: ## @itemize @bullet ## @item ## @var{operatorB} (class numeric, char, or function_handle) - the second operator, ## if solving a generalized eigenproblem, can be a matrix, a function name, or ## handle; by default if empty, @code{operatorB = I}. ## @item ## @var{operatorT} (class char or function_handle) - the preconditioner, by ## default @code{operatorT(blockVectorX) = blockVectorX}. ## @end itemize ## ## Optional constraints input: ## @itemize @bullet ## @item ## @var{blockVectorY} (class numeric) - a full or sparse n-by-sizeY matrix of ## constraints, where sizeY < n. @var{blockVectorY} must be full rank. The ## iterations will be performed in the (operatorB-) orthogonal complement of the ## column-space of @var{blockVectorY}. ## @end itemize ## ## Optional scalar input parameters: ## @itemize @bullet ## @item ## @var{residualTolerance} (class numeric) - tolerance, by default, @code{residualTolerance = n * sqrt (eps)} ## @item ## @var{maxIterations} - max number of iterations, by default, @code{maxIterations = min (n, 20)} ## @item ## @var{verbosityLevel} - either 0 (no info), 1, or 2 (with pictures); by ## default, @code{verbosityLevel = 0}. ## @end itemize ## ## Required output: ## @itemize @bullet ## @item ## @var{blockVectorX} and @var{lambda} (class numeric) both are computed ## blockSize eigenpairs, where @code{blockSize = size (blockVectorX, 2)} ## for the initial guess @var{blockVectorX} if it is full rank. ## @end itemize ## ## Optional output: ## @itemize @bullet ## @item ## @var{failureFlag} (class integer) as described above. ## @item ## @var{lambdaHistory} (class numeric) as described above. ## @item ## @var{residualNormsHistory} (class numeric) as described above. ## @end itemize ## ## Functions @code{operatorA(blockVectorX)}, @code{operatorB(blockVectorX)} and ## @code{operatorT(blockVectorX)} must support @var{blockVectorX} being a matrix, not ## just a column vector. ## ## Every iteration involves one application of @var{operatorA} and @var{operatorB}, and ## one of @var{operatorT}. ## ## Main memory requirements: 6 (9 if @code{isempty(operatorB)=0}) matrices of the ## same size as @var{blockVectorX}, 2 matrices of the same size as @var{blockVectorY} ## (if present), and two square matrices of the size 3*blockSize. ## ## In all examples below, we use the Laplacian operator in a 20x20 square ## with the mesh size 1 which can be generated in MATLAB by running: ## @example ## A = delsq (numgrid ('S', 21)); ## n = size (A, 1); ## @end example ## ## or in MATLAB and Octave by: ## @example ## [~,~,A] = laplacian ([19, 19]); ## n = size (A, 1); ## @end example ## ## Note that @code{laplacian} is a function of the specfun octave-forge package. ## ## The following Example: ## @example ## [blockVectorX, lambda, failureFlag] = lobpcg (randn (n, 8), A, 1e-5, 50, 2); ## @end example ## ## attempts to compute 8 first eigenpairs without preconditioning, but not all ## eigenpairs converge after 50 steps, so failureFlag=1. ## ## The next Example: ## @example ## blockVectorY = []; ## lambda_all = []; ## for j = 1:4 ## [blockVectorX, lambda] = lobpcg (randn (n, 2), A, blockVectorY, 1e-5, 200, 2); ## blockVectorY = [blockVectorY, blockVectorX]; ## lambda_all = [lambda_all' lambda']'; ## pause; ## end ## @end example ## ## attemps to compute the same 8 eigenpairs by calling the code 4 times with ## blockSize=2 using orthogonalization to the previously founded eigenvectors. ## ## The following Example: ## @example ## R = ichol (A, struct('michol', 'on')); ## precfun = @@(x)R\(R'\x); ## [blockVectorX, lambda, failureFlag] = lobpcg (randn (n, 8), A, [], @@(x)precfun(x), 1e-5, 60, 2); ## @end example ## ## computes the same eigenpairs in less then 25 steps, so that failureFlag=0 ## using the preconditioner function @code{precfun}, defined inline. If @code{precfun} ## is defined as an octave function in a file, the function handle ## @code{@@(x)precfun(x)} can be equivalently replaced by the function name @code{precfun}. Running: ## ## @example ## [blockVectorX, lambda, failureFlag] = lobpcg (randn (n, 8), A, speye (n), @@(x)precfun(x), 1e-5, 50, 2); ## @end example ## ## produces similar answers, but is somewhat slower and needs more memory as ## technically a generalized eigenproblem with B=I is solved here. ## ## The following example for a mostly diagonally dominant sparse matrix A ## demonstrates different types of preconditioning, compared to the standard ## use of the main diagonal of A: ## ## @example ## clear all; close all; ## n = 1000; ## M = spdiags ([1:n]', 0, n, n); ## precfun = @@(x)M\x; ## A = M + sprandsym (n, .1); ## Xini = randn (n, 5); ## maxiter = 15; ## tol = 1e-5; ## [~,~,~,~,rnp] = lobpcg (Xini, A, tol, maxiter, 1); ## [~,~,~,~,r] = lobpcg (Xini, A, [], @@(x)precfun(x), tol, maxiter, 1); ## subplot (2,2,1), semilogy (r'); hold on; ## semilogy (rnp', ':>'); ## title ('No preconditioning (top)'); axis tight; ## M(1,2) = 2; ## precfun = @@(x)M\x; % M is no longer symmetric ## [~,~,~,~,rns] = lobpcg (Xini, A, [], @@(x)precfun(x), tol, maxiter, 1); ## subplot (2,2,2), semilogy (r'); hold on; ## semilogy (rns', '--s'); ## title ('Nonsymmetric preconditioning (square)'); axis tight; ## M(1,2) = 0; ## precfun = @@(x)M\(x+10*sin(x)); % nonlinear preconditioning ## [~,~,~,~,rnl] = lobpcg (Xini, A, [], @@(x)precfun(x), tol, maxiter, 1); ## subplot (2,2,3), semilogy (r'); hold on; ## semilogy (rnl', '-.*'); ## title ('Nonlinear preconditioning (star)'); axis tight; ## M = abs (M - 3.5 * speye (n, n)); ## precfun = @@(x)M\x; ## [~,~,~,~,rs] = lobpcg (Xini, A, [], @@(x)precfun(x), tol, maxiter, 1); ## subplot (2,2,4), semilogy (r'); hold on; ## semilogy (rs', '-d'); ## title ('Selective preconditioning (diamond)'); axis tight; ## @end example ## ## @heading References ## This main function @code{lobpcg} is a version of the preconditioned conjugate ## gradient method (Algorithm 5.1) described in A. V. Knyazev, Toward the Optimal ## Preconditioned Eigensolver: ## Locally Optimal Block Preconditioned Conjugate Gradient Method, ## SIAM Journal on Scientific Computing 23 (2001), no. 2, pp. 517-541. ## @uref{http://dx.doi.org/10.1137/S1064827500366124} ## ## @heading Known bugs/features ## @itemize @bullet ## @item ## an excessively small requested tolerance may result in often restarts and ## instability. The code is not written to produce an eps-level accuracy! Use ## common sense. ## @item ## the code may be very sensitive to the number of eigenpairs computed, ## if there is a cluster of eigenvalues not completely included, cf. ## @example ## operatorA = diag ([1 1.99 2:99]); ## [blockVectorX, lambda] = lobpcg (randn (100, 1),operatorA, 1e-10, 80, 2); ## [blockVectorX, lambda] = lobpcg (randn (100, 2),operatorA, 1e-10, 80, 2); ## [blockVectorX, lambda] = lobpcg (randn (100, 3),operatorA, 1e-10, 80, 2); ## @end example ## @end itemize ## ## @heading Distribution ## The main distribution site: @uref{http://math.ucdenver.edu/~aknyazev/} ## ## A C-version of this code is a part of the @uref{http://code.google.com/p/blopex/} ## package and is directly available, e.g., in PETSc and HYPRE. ## @end deftypefn function [blockVectorX,lambda,varargout] = lobpcg(blockVectorX,operatorA,varargin) %Begin % constants CONVENTIONAL_CONSTRAINTS = 1; SYMMETRIC_CONSTRAINTS = 2; %Initial settings failureFlag = 1; if nargin < 2 error('BLOPEX:lobpcg:NotEnoughInputs',... strcat('There must be at least 2 input agruments: ',... 'blockVectorX and operatorA')); end if nargin > 8 warning('BLOPEX:lobpcg:TooManyInputs',... strcat('There must be at most 8 input agruments ',... 'unless arguments are passed to a function')); end if ~isnumeric(blockVectorX) error('BLOPEX:lobpcg:FirstInputNotNumeric',... 'The first input argument blockVectorX must be numeric'); end [n,blockSize]=size(blockVectorX); if blockSize > n error('BLOPEX:lobpcg:FirstInputFat',... 'The first input argument blockVectorX must be tall, not fat'); end if n < 6 error('BLOPEX:lobpcg:MatrixTooSmall',... 'The code does not work for matrices of small sizes'); end if isa(operatorA,'numeric') nA = size(operatorA,1); if any(size(operatorA) ~= nA) error('BLOPEX:lobpcg:MatrixNotSquare',... 'operatorA must be a square matrix or a string'); end if size(operatorA) ~= n error('BLOPEX:lobpcg:MatrixWrongSize',... ['The size ' int2str(size(operatorA))... ' of operatorA is not the same as ' int2str(n)... ' - the number of rows of blockVectorX']); end end count_string = 0; operatorT = []; operatorB = []; residualTolerance = []; maxIterations = []; verbosityLevel = []; blockVectorY = []; sizeY = 0; for j = 1:nargin-2 if isequal(size(varargin{j}),[n,n]) if isempty(operatorB) operatorB = varargin{j}; else error('BLOPEX:lobpcg:TooManyMatrixInputs',... strcat('Too many matrix input arguments. ',... 'Preconditioner operatorT must be an M-function')); end elseif isequal(size(varargin{j},1),n) && size(varargin{j},2) < n if isempty(blockVectorY) blockVectorY = varargin{j}; sizeY=size(blockVectorY,2); else error('BLOPEX:lobpcg:WrongConstraintsFormat',... 'Something wrong with blockVectorY input argument'); end elseif ischar(varargin{j}) || isa(varargin{j},'function_handle') if count_string == 0 if isempty(operatorB) operatorB = varargin{j}; count_string = count_string + 1; else operatorT = varargin{j}; end elseif count_string == 1 operatorT = varargin{j}; else warning('BLOPEX:lobpcg:TooManyStringFunctionHandleInputs',... 'Too many string or FunctionHandle input arguments'); end elseif isequal(size(varargin{j}),[n,n]) error('BLOPEX:lobpcg:WrongPreconditionerFormat',... 'Preconditioner operatorT must be an M-function'); elseif max(size(varargin{j})) == 1 if isempty(residualTolerance) residualTolerance = varargin{j}; elseif isempty(maxIterations) maxIterations = varargin{j}; elseif isempty(verbosityLevel) verbosityLevel = varargin{j}; else warning('BLOPEX:lobpcg:TooManyScalarInputs',... 'Too many scalar parameters, need only three'); end elseif isempty(varargin{j}) if isempty(operatorB) count_string = count_string + 1; elseif ~isempty(operatorT) count_string = count_string + 1; elseif ~isempty(blockVectorY) error('BLOPEX:lobpcg:UnrecognizedEmptyInput',... ['Unrecognized empty input argument number ' int2str(j+2)]); end else error('BLOPEX:lobpcg:UnrecognizedInput',... ['Input argument number ' int2str(j+2) ' not recognized.']); end end if verbosityLevel if issparse(blockVectorX) fprintf(['The sparse initial guess with %i colunms '... 'and %i raws is detected \n'],n,blockSize); else fprintf(['The full initial guess with %i colunms '... 'and %i raws is detected \n'],n,blockSize); end if ischar(operatorA) fprintf('The main operator is detected as an M-function %s \n',... operatorA); elseif isa(operatorA,'function_handle') fprintf('The main operator is detected as an M-function %s \n',... func2str(operatorA)); elseif issparse(operatorA) fprintf('The main operator is detected as a sparse matrix \n'); else fprintf('The main operator is detected as a full matrix \n'); end if isempty(operatorB) fprintf('Solving standard eigenvalue problem, not generalized \n'); elseif ischar(operatorB) fprintf(['The second operator of the generalized eigenproblem \n'... 'is detected as an M-function %s \n'],operatorB); elseif isa(operatorB,'function_handle') fprintf(['The second operator of the generalized eigenproblem \n'... 'is detected as an M-function %s \n'],func2str(operatorB)); elseif issparse(operatorB) fprintf(strcat('The second operator of the generalized',... 'eigenproblem \n is detected as a sparse matrix \n')); else fprintf(strcat('The second operator of the generalized',... 'eigenproblem \n is detected as a full matrix \n')); end if isempty(operatorT) fprintf('No preconditioner is detected \n'); elseif ischar(operatorT) fprintf('The preconditioner is detected as an M-function %s \n',... operatorT); elseif isa(operatorT,'function_handle') fprintf('The preconditioner is detected as an M-function %s \n',... func2str(operatorT)); end if isempty(blockVectorY) fprintf('No matrix of constraints is detected \n') elseif issparse(blockVectorY) fprintf('The sparse matrix of %i constraints is detected \n',sizeY); else fprintf('The full matrix of %i constraints is detected \n',sizeY); end if issparse(blockVectorY) ~= issparse(blockVectorX) warning('BLOPEX:lobpcg:SparsityInconsistent',... strcat('The sparsity formats of the initial guess and ',... 'the constraints are inconsistent')); end end % Set defaults if isempty(residualTolerance) residualTolerance = sqrt(eps)*n; end if isempty(maxIterations) maxIterations = min(n,20); end if isempty(verbosityLevel) verbosityLevel = 0; end if verbosityLevel fprintf('Tolerance %e and maximum number of iterations %i \n',... residualTolerance,maxIterations) end %constraints preprocessing if isempty(blockVectorY) constraintStyle = 0; else % constraintStyle = SYMMETRIC_CONSTRAINTS; % more accurate? constraintStyle = CONVENTIONAL_CONSTRAINTS; end if constraintStyle == CONVENTIONAL_CONSTRAINTS if isempty(operatorB) gramY = blockVectorY'*blockVectorY; else if isnumeric(operatorB) blockVectorBY = operatorB*blockVectorY; else blockVectorBY = feval(operatorB,blockVectorY); end gramY=blockVectorY'*blockVectorBY; end gramY=(gramY'+gramY)*0.5; if isempty(operatorB) blockVectorX = blockVectorX - ... blockVectorY*(gramY\(blockVectorY'*blockVectorX)); else blockVectorX =blockVectorX - ... blockVectorY*(gramY\(blockVectorBY'*blockVectorX)); end elseif constraintStyle == SYMMETRIC_CONSTRAINTS if ~isempty(operatorB) if isnumeric(operatorB) blockVectorY = operatorB*blockVectorY; else blockVectorY = feval(operatorB,blockVectorY); end end if isempty(operatorT) gramY = blockVectorY'*blockVectorY; else blockVectorTY = feval(operatorT,blockVectorY); gramY = blockVectorY'*blockVectorTY; end gramY=(gramY'+gramY)*0.5; if isempty(operatorT) blockVectorX = blockVectorX - ... blockVectorY*(gramY\(blockVectorY'*blockVectorX)); else blockVectorX = blockVectorX - ... blockVectorTY*(gramY\(blockVectorY'*blockVectorX)); end end %Making the initial vectors (operatorB-) orthonormal if isempty(operatorB) %[blockVectorX,gramXBX] = qr(blockVectorX,0); gramXBX=blockVectorX'*blockVectorX; if ~isreal(gramXBX) gramXBX=(gramXBX+gramXBX')*0.5; end [gramXBX,cholFlag]=chol(gramXBX); if cholFlag ~= 0 error('BLOPEX:lobpcg:ConstraintsTooTight',... 'The initial approximation after constraints is not full rank'); end blockVectorX = blockVectorX/gramXBX; else %[blockVectorX,blockVectorBX] = orth(operatorB,blockVectorX); if isnumeric(operatorB) blockVectorBX = operatorB*blockVectorX; else blockVectorBX = feval(operatorB,blockVectorX); end gramXBX=blockVectorX'*blockVectorBX; if ~isreal(gramXBX) gramXBX=(gramXBX+gramXBX')*0.5; end [gramXBX,cholFlag]=chol(gramXBX); if cholFlag ~= 0 error('BLOPEX:lobpcg:InitialNotFullRank',... sprintf('%s\n%s', ... 'The initial approximation after constraints is not full rank',... 'or/and operatorB is not positive definite')); end blockVectorX = blockVectorX/gramXBX; blockVectorBX = blockVectorBX/gramXBX; end % Checking if the problem is big enough for the algorithm, % i.e. n-sizeY > 5*blockSize % Theoretically, the algorithm should be able to run if % n-sizeY > 3*blockSize, % but the extreme cases might be unstable, so we use 5 instead of 3 here. if n-sizeY < 5*blockSize error('BLOPEX:lobpcg:MatrixTooSmall','%s\n%s', ... 'The problem size is too small, relative to the block size.',... 'Try using eig() or eigs() instead.'); end % Preallocation residualNormsHistory=zeros(blockSize,maxIterations); lambdaHistory=zeros(blockSize,maxIterations+1); condestGhistory=zeros(1,maxIterations+1); blockVectorBR=zeros(n,blockSize); blockVectorAR=zeros(n,blockSize); blockVectorP=zeros(n,blockSize); blockVectorAP=zeros(n,blockSize); blockVectorBP=zeros(n,blockSize); %Initial settings for the loop if isnumeric(operatorA) blockVectorAX = operatorA*blockVectorX; else blockVectorAX = feval(operatorA,blockVectorX); end gramXAX = full(blockVectorX'*blockVectorAX); gramXAX = (gramXAX + gramXAX')*0.5; % eig(...,'chol') uses only the diagonal and upper triangle - % not true in MATLAB % Octave v3.2.3-4, eig() does not support inputting 'chol' [coordX,gramXAX]=eig(gramXAX,eye(blockSize)); lambda=diag(gramXAX); %eig returns non-ordered eigenvalues on the diagonal if issparse(blockVectorX) coordX=sparse(coordX); end blockVectorX = blockVectorX*coordX; blockVectorAX = blockVectorAX*coordX; if ~isempty(operatorB) blockVectorBX = blockVectorBX*coordX; end clear coordX condestGhistory(1)=-log10(eps)/2; %if too small cause unnecessary restarts lambdaHistory(1:blockSize,1)=lambda; activeMask = true(blockSize,1); % currentBlockSize = blockSize; %iterate all % % restart=1;%steepest descent %The main part of the method is the loop of the CG method: begin for iterationNumber=1:maxIterations % %Computing the active residuals % if isempty(operatorB) % if currentBlockSize > 1 % blockVectorR(:,activeMask)=blockVectorAX(:,activeMask) - ... % blockVectorX(:,activeMask)*spdiags(lambda(activeMask),0,currentBlockSize,currentBlockSize); % else % blockVectorR(:,activeMask)=blockVectorAX(:,activeMask) - ... % blockVectorX(:,activeMask)*lambda(activeMask); % %to make blockVectorR full when lambda is just a scalar % end % else % if currentBlockSize > 1 % blockVectorR(:,activeMask)=blockVectorAX(:,activeMask) - ... % blockVectorBX(:,activeMask)*spdiags(lambda(activeMask),0,currentBlockSize,currentBlockSize); % else % blockVectorR(:,activeMask)=blockVectorAX(:,activeMask) - ... % blockVectorBX(:,activeMask)*lambda(activeMask); % %to make blockVectorR full when lambda is just a scalar % end % end %Computing all residuals if isempty(operatorB) if blockSize > 1 blockVectorR = blockVectorAX - ... blockVectorX*spdiags(lambda,0,blockSize,blockSize); else blockVectorR = blockVectorAX - blockVectorX*lambda; %to make blockVectorR full when lambda is just a scalar end else if blockSize > 1 blockVectorR=blockVectorAX - ... blockVectorBX*spdiags(lambda,0,blockSize,blockSize); else blockVectorR = blockVectorAX - blockVectorBX*lambda; %to make blockVectorR full when lambda is just a scalar end end %Satisfying the constraints for the active residulas if constraintStyle == SYMMETRIC_CONSTRAINTS if isempty(operatorT) blockVectorR(:,activeMask) = blockVectorR(:,activeMask) - ... blockVectorY*(gramY\(blockVectorY'*... blockVectorR(:,activeMask))); else blockVectorR(:,activeMask) = blockVectorR(:,activeMask) - ... blockVectorY*(gramY\(blockVectorTY'*... blockVectorR(:,activeMask))); end end residualNorms=full(sqrt(sum(conj(blockVectorR).*blockVectorR)')); residualNormsHistory(1:blockSize,iterationNumber)=residualNorms; %index antifreeze activeMask = full(residualNorms > residualTolerance) & activeMask; %activeMask = full(residualNorms > residualTolerance); %above allows vectors back into active, which causes problems with frosen Ps %activeMask = full(residualNorms > 0); %iterate all, ignore freeze currentBlockSize = sum(activeMask); if currentBlockSize == 0 failureFlag=0; %all eigenpairs converged break end %Applying the preconditioner operatorT to the active residulas if ~isempty(operatorT) blockVectorR(:,activeMask) = ... feval(operatorT,blockVectorR(:,activeMask)); end if constraintStyle == CONVENTIONAL_CONSTRAINTS if isempty(operatorB) blockVectorR(:,activeMask) = blockVectorR(:,activeMask) - ... blockVectorY*(gramY\(blockVectorY'*... blockVectorR(:,activeMask))); else blockVectorR(:,activeMask) = blockVectorR(:,activeMask) - ... blockVectorY*(gramY\(blockVectorBY'*... blockVectorR(:,activeMask))); end end %Making active (preconditioned) residuals orthogonal to blockVectorX if isempty(operatorB) blockVectorR(:,activeMask) = blockVectorR(:,activeMask) - ... blockVectorX*(blockVectorX'*blockVectorR(:,activeMask)); else blockVectorR(:,activeMask) = blockVectorR(:,activeMask) - ... blockVectorX*(blockVectorBX'*blockVectorR(:,activeMask)); end %Making active residuals orthonormal if isempty(operatorB) %[blockVectorR(:,activeMask),gramRBR]=... %qr(blockVectorR(:,activeMask),0); %to increase stability gramRBR=blockVectorR(:,activeMask)'*blockVectorR(:,activeMask); if ~isreal(gramRBR) gramRBR=(gramRBR+gramRBR')*0.5; end [gramRBR,cholFlag]=chol(gramRBR); if cholFlag == 0 blockVectorR(:,activeMask) = blockVectorR(:,activeMask)/gramRBR; else warning('BLOPEX:lobpcg:ResidualNotFullRank',... 'The residual is not full rank.'); break end else if isnumeric(operatorB) blockVectorBR(:,activeMask) = ... operatorB*blockVectorR(:,activeMask); else blockVectorBR(:,activeMask) = ... feval(operatorB,blockVectorR(:,activeMask)); end gramRBR=blockVectorR(:,activeMask)'*blockVectorBR(:,activeMask); if ~isreal(gramRBR) gramRBR=(gramRBR+gramRBR')*0.5; end [gramRBR,cholFlag]=chol(gramRBR); if cholFlag == 0 blockVectorR(:,activeMask) = ... blockVectorR(:,activeMask)/gramRBR; blockVectorBR(:,activeMask) = ... blockVectorBR(:,activeMask)/gramRBR; else warning('BLOPEX:lobpcg:ResidualNotFullRankOrElse',... strcat('The residual is not full rank or/and operatorB ',... 'is not positive definite.')); break end end clear gramRBR; if isnumeric(operatorA) blockVectorAR(:,activeMask) = operatorA*blockVectorR(:,activeMask); else blockVectorAR(:,activeMask) = ... feval(operatorA,blockVectorR(:,activeMask)); end if iterationNumber > 1 %Making active conjugate directions orthonormal if isempty(operatorB) %[blockVectorP(:,activeMask),gramPBP] = qr(blockVectorP(:,activeMask),0); gramPBP=blockVectorP(:,activeMask)'*blockVectorP(:,activeMask); if ~isreal(gramPBP) gramPBP=(gramPBP+gramPBP')*0.5; end [gramPBP,cholFlag]=chol(gramPBP); if cholFlag == 0 blockVectorP(:,activeMask) = ... blockVectorP(:,activeMask)/gramPBP; blockVectorAP(:,activeMask) = ... blockVectorAP(:,activeMask)/gramPBP; else warning('BLOPEX:lobpcg:DirectionNotFullRank',... 'The direction matrix is not full rank.'); break end else gramPBP=blockVectorP(:,activeMask)'*blockVectorBP(:,activeMask); if ~isreal(gramPBP) gramPBP=(gramPBP+gramPBP')*0.5; end [gramPBP,cholFlag]=chol(gramPBP); if cholFlag == 0 blockVectorP(:,activeMask) = ... blockVectorP(:,activeMask)/gramPBP; blockVectorAP(:,activeMask) = ... blockVectorAP(:,activeMask)/gramPBP; blockVectorBP(:,activeMask) = ... blockVectorBP(:,activeMask)/gramPBP; else warning('BLOPEX:lobpcg:DirectionNotFullRank',... strcat('The direction matrix is not full rank ',... 'or/and operatorB is not positive definite.')); break end end clear gramPBP end condestGmean = mean(condestGhistory(max(1,iterationNumber-10-... round(log(currentBlockSize))):iterationNumber)); % restart=1; % The Raileight-Ritz method for [blockVectorX blockVectorR blockVectorP] if residualNorms > eps^0.6 explicitGramFlag = 0; else explicitGramFlag = 1; %suggested by Garrett Moran, private end activeRSize=size(blockVectorR(:,activeMask),2); if iterationNumber == 1 activePSize=0; restart=1; else activePSize=size(blockVectorP(:,activeMask),2); restart=0; end gramXAR=full(blockVectorAX'*blockVectorR(:,activeMask)); gramRAR=full(blockVectorAR(:,activeMask)'*blockVectorR(:,activeMask)); gramRAR=(gramRAR'+gramRAR)*0.5; if explicitGramFlag gramXAX=full(blockVectorAX'*blockVectorX); gramXAX=(gramXAX'+gramXAX)*0.5; if isempty(operatorB) gramXBX=full(blockVectorX'*blockVectorX); gramRBR=full(blockVectorR(:,activeMask)'*... blockVectorR(:,activeMask)); gramXBR=full(blockVectorX'*blockVectorR(:,activeMask)); else gramXBX=full(blockVectorBX'*blockVectorX); gramRBR=full(blockVectorBR(:,activeMask)'*... blockVectorR(:,activeMask)); gramXBR=full(blockVectorBX'*blockVectorR(:,activeMask)); end gramXBX=(gramXBX'+gramXBX)*0.5; gramRBR=(gramRBR'+gramRBR)*0.5; end for cond_try=1:2, %cond_try == 2 when restart if ~restart gramXAP=full(blockVectorAX'*blockVectorP(:,activeMask)); gramRAP=full(blockVectorAR(:,activeMask)'*... blockVectorP(:,activeMask)); gramPAP=full(blockVectorAP(:,activeMask)'*... blockVectorP(:,activeMask)); gramPAP=(gramPAP'+gramPAP)*0.5; if explicitGramFlag gramA = [ gramXAX gramXAR gramXAP gramXAR' gramRAR gramRAP gramXAP' gramRAP' gramPAP ]; else gramA = [ diag(lambda) gramXAR gramXAP gramXAR' gramRAR gramRAP gramXAP' gramRAP' gramPAP ]; end clear gramXAP gramRAP gramPAP if isempty(operatorB) gramXBP=full(blockVectorX'*blockVectorP(:,activeMask)); gramRBP=full(blockVectorR(:,activeMask)'*... blockVectorP(:,activeMask)); else gramXBP=full(blockVectorBX'*blockVectorP(:,activeMask)); gramRBP=full(blockVectorBR(:,activeMask)'*... blockVectorP(:,activeMask)); %or blockVectorR(:,activeMask)'*blockVectorBP(:,activeMask); end if explicitGramFlag if isempty(operatorB) gramPBP=full(blockVectorP(:,activeMask)'*... blockVectorP(:,activeMask)); else gramPBP=full(blockVectorBP(:,activeMask)'*... blockVectorP(:,activeMask)); end gramPBP=(gramPBP'+gramPBP)*0.5; gramB = [ gramXBX gramXBR gramXBP gramXBR' gramRBR gramRBP gramXBP' gramRBP' gramPBP ]; clear gramPBP else gramB=[eye(blockSize) zeros(blockSize,activeRSize) gramXBP zeros(blockSize,activeRSize)' eye(activeRSize) gramRBP gramXBP' gramRBP' eye(activePSize) ]; end clear gramXBP gramRBP; else if explicitGramFlag gramA = [ gramXAX gramXAR gramXAR' gramRAR ]; gramB = [ gramXBX gramXBR gramXBR' eye(activeRSize) ]; clear gramXAX gramXBX gramXBR else gramA = [ diag(lambda) gramXAR gramXAR' gramRAR ]; gramB = eye(blockSize+activeRSize); end clear gramXAR gramRAR; end condestG = log10(cond(gramB))+1; if (condestG/condestGmean > 2 && condestG > 2 )|| condestG > 8 %black magic - need to guess the restart if verbosityLevel fprintf('Restart on step %i as condestG %5.4e \n',... iterationNumber,condestG); end if cond_try == 1 && ~restart restart=1; %steepest descent restart for stability else warning('BLOPEX:lobpcg:IllConditioning',... 'Gramm matrix ill-conditioned: results unpredictable'); end else break end end [gramA,gramB]=eig(gramA,gramB); lambda=diag(gramB(1:blockSize,1:blockSize)); coordX=gramA(:,1:blockSize); clear gramA gramB if issparse(blockVectorX) coordX=sparse(coordX); end if ~restart blockVectorP = blockVectorR(:,activeMask)*... coordX(blockSize+1:blockSize+activeRSize,:) + ... blockVectorP(:,activeMask)*... coordX(blockSize+activeRSize+1:blockSize + ... activeRSize+activePSize,:); blockVectorAP = blockVectorAR(:,activeMask)*... coordX(blockSize+1:blockSize+activeRSize,:) + ... blockVectorAP(:,activeMask)*... coordX(blockSize+activeRSize+1:blockSize + ... activeRSize+activePSize,:); if ~isempty(operatorB) blockVectorBP = blockVectorBR(:,activeMask)*... coordX(blockSize+1:blockSize+activeRSize,:) + ... blockVectorBP(:,activeMask)*... coordX(blockSize+activeRSize+1:blockSize+activeRSize+activePSize,:); end else %use block steepest descent blockVectorP = blockVectorR(:,activeMask)*... coordX(blockSize+1:blockSize+activeRSize,:); blockVectorAP = blockVectorAR(:,activeMask)*... coordX(blockSize+1:blockSize+activeRSize,:); if ~isempty(operatorB) blockVectorBP = blockVectorBR(:,activeMask)*... coordX(blockSize+1:blockSize+activeRSize,:); end end blockVectorX = blockVectorX*coordX(1:blockSize,:) + blockVectorP; blockVectorAX=blockVectorAX*coordX(1:blockSize,:) + blockVectorAP; if ~isempty(operatorB) blockVectorBX=blockVectorBX*coordX(1:blockSize,:) + blockVectorBP; end clear coordX %%end RR lambdaHistory(1:blockSize,iterationNumber+1)=lambda; condestGhistory(iterationNumber+1)=condestG; if verbosityLevel fprintf('Iteration %i current block size %i \n',... iterationNumber,currentBlockSize); fprintf('Eigenvalues lambda %17.16e \n',lambda); fprintf('Residual Norms %e \n',residualNorms'); end end %The main step of the method was the CG cycle: end %Postprocessing %Making sure blockVectorX's "exactly" satisfy the blockVectorY constrains?? %Making sure blockVectorX's are "exactly" othonormalized by final "exact" RR if isempty(operatorB) gramXBX=full(blockVectorX'*blockVectorX); else if isnumeric(operatorB) blockVectorBX = operatorB*blockVectorX; else blockVectorBX = feval(operatorB,blockVectorX); end gramXBX=full(blockVectorX'*blockVectorBX); end gramXBX=(gramXBX'+gramXBX)*0.5; if isnumeric(operatorA) blockVectorAX = operatorA*blockVectorX; else blockVectorAX = feval(operatorA,blockVectorX); end gramXAX = full(blockVectorX'*blockVectorAX); gramXAX = (gramXAX + gramXAX')*0.5; %Raileigh-Ritz for blockVectorX, which is already operatorB-orthonormal [coordX,gramXBX] = eig(gramXAX,gramXBX); lambda=diag(gramXBX); if issparse(blockVectorX) coordX=sparse(coordX); end blockVectorX = blockVectorX*coordX; blockVectorAX = blockVectorAX*coordX; if ~isempty(operatorB) blockVectorBX = blockVectorBX*coordX; end %Computing all residuals if isempty(operatorB) if blockSize > 1 blockVectorR = blockVectorAX - ... blockVectorX*spdiags(lambda,0,blockSize,blockSize); else blockVectorR = blockVectorAX - blockVectorX*lambda; %to make blockVectorR full when lambda is just a scalar end else if blockSize > 1 blockVectorR=blockVectorAX - ... blockVectorBX*spdiags(lambda,0,blockSize,blockSize); else blockVectorR = blockVectorAX - blockVectorBX*lambda; %to make blockVectorR full when lambda is just a scalar end end residualNorms=full(sqrt(sum(conj(blockVectorR).*blockVectorR)')); residualNormsHistory(1:blockSize,iterationNumber)=residualNorms; if verbosityLevel fprintf('Final Eigenvalues lambda %17.16e \n',lambda); fprintf('Final Residual Norms %e \n',residualNorms'); end if verbosityLevel == 2 whos figure(491) semilogy((abs(residualNormsHistory(1:blockSize,1:iterationNumber-1)))'); title('Residuals for Different Eigenpairs','fontsize',16); ylabel('Eucledian norm of residuals','fontsize',16); xlabel('Iteration number','fontsize',16); %axis tight; %axis([0 maxIterations+1 1e-15 1e3]) set(gca,'FontSize',14); figure(492); semilogy(abs((lambdaHistory(1:blockSize,1:iterationNumber)-... repmat(lambda,1,iterationNumber)))'); title('Eigenvalue errors for Different Eigenpairs','fontsize',16); ylabel('Estimated eigenvalue errors','fontsize',16); xlabel('Iteration number','fontsize',16); %axis tight; %axis([0 maxIterations+1 1e-15 1e3]) set(gca,'FontSize',14); drawnow; end varargout(1)={failureFlag}; varargout(2)={lambdaHistory(1:blockSize,1:iterationNumber)}; varargout(3)={residualNormsHistory(1:blockSize,1:iterationNumber-1)}; end linear-algebra/inst/circulant_make_matrix.m0000644000175000017500000000317211743761216020774 0ustar juanpijuanpi## Copyright (C) 2012 Nir Krakauer ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{C} =} circulant_make_matrix (@var{v}) ## ## Produce a full circulant matrix given the first column@* ## Given an @var{n}*1 vector @var{v}, returns the @var{n}*@var{n} circulant matrix @var{C} where @var{v} is the left column and all other columns are downshifted versions of @var{v} ## ## Note: If the first row @var{r} of a circulant matrix is given, the first column @var{v} can be obtained as @code{v = r([1 end:-1:2])} ## ## Reference: Gene H. Golub and Charles F. Van Loan, Matrix Computations, 3rd Ed., Section 4.7.7 ## ## @seealso{circulant_matrix_vector_product, circulant_eig, circulant_inv} ## @end deftypefn function C = circulant_make_matrix(v) n = numel(v); C = ones(n, n); for i = 1:n C(:, i) = v([(end-i+2):end 1:(end-i+1)]); #or circshift(v, i-1) endfor endfunction %!shared v,C %! v = [1 2 3]'; C = [1 3 2; 2 1 3; 3 2 1]; %!assert (circulant_make_matrix(v), C); linear-algebra/inst/ndcovlt.m0000644000175000017500000000566311743761216016107 0ustar juanpijuanpi## Copyright (C) 2010 VZLU Prague, a.s., Czech Republic ## ## This program 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. ## ## 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. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{y} =} ndcovlt (@var{x}, @var{t1}, @var{t2}, @dots{}) ## Computes an n-dimensional covariant linear transform of an n-d tensor, given a ## transformation matrix for each dimension. The number of columns of each transformation ## matrix must match the corresponding extent of @var{x}, and the number of rows determines ## the corresponding extent of @var{y}. For example: ## ## @example ## size (@var{x}, 2) == columns (@var{t2}) ## size (@var{y}, 2) == rows (@var{t2}) ## @end example ## ## The element @code{@var{y}(i1, i2, @dots{})} is defined as a sum of ## ## @example ## @var{x}(j1, j2, @dots{}) * @var{t1}(i1, j1) * @var{t2}(i2, j2) * @dots{} ## @end example ## ## over all j1, j2, @dots{}. For two dimensions, this reduces to ## @example ## @var{y} = @var{t1} * @var{x} * @var{t2}.' ## @end example ## ## [] passed as a transformation matrix is converted to identity matrix for ## the corresponding dimension. ## ## @end deftypefn ## Author: Jaroslav Hajek function y = ndcovlt (x, varargin) nd = max (ndims (x), nargin - 1); varargin = resize (varargin, 1, nd); # check dimensions for i = 1:nd ti = varargin{i}; if (isnumeric (ti) && ndims (ti) == 2) [r, c] = size (ti); if (r + c == 0) varargin{i} = eye (size (x, i)); elseif (c != size (x, i)) error ("ndcovt: dimension mismatch for x-th transformation matrix"); endif else error ("ndcovt: transformation matrices must be numeric 2d matrices"); endif endfor if (isempty (x)) szy = cellfun (@rows, varargin); y = zeros (szy); return endif ldp = [2:nd, 1]; ## First transformation. y = ldtrans (x, varargin{1}); ## Always shift one dimension. for i = 2:nd-1 y = ldtrans (permute (y, ldp), varargin{i}); endfor ## Permute to normal order now to save one permutation. if (nd > 2) y = ipermute (y, [nd-1:nd, 1:nd-2]); endif ## Now multiply from the right. szy = size (y); szy(end+1:nd-1) = 1; m = varargin{nd}; szy(nd) = rows (m); y = reshape (y, [], size (y, nd)); y = reshape (y * m.', szy); endfunction function y = ldtrans (x, m) sz = size (x); sz(1) = rows (m); y = reshape (m * x(:,:), sz); endfunction linear-algebra/INDEX0000644000175000017500000000242011756365401014061 0ustar juanpijuanpimatrix >> Linear Algebra Matrix functions cartprod cod condeig funm lobpcg ndcovlt rotparams rotv smwsolve thfm Matrix factorization gsvd nmf_bpas nmf_pg sparse >> Sparse matrix support Block sparse matrices @blksparse/blksparse @blksparse/blksize @blksparse/ctranspose @blksparse/display @blksparse/full @blksparse/ismatrix @blksparse/isreal @blksparse/issparse @blksparse/minus @blksparse/mldivide @blksparse/mrdivide @blksparse/mtimes @blksparse/plus @blksparse/size @blksparse/sparse @blksparse/subsref @blksparse/transpose @blksparse/uminus @blksparse/uplus Iterative techniques pgmres Kronecker Products @kronprod/kronprod @kronprod/columns @kronprod/ctranspose @kronprod/det @kronprod/disp @kronprod/display @kronprod/full @kronprod/inv @kronprod/iscomplex @kronprod/ismatrix @kronprod/isreal @kronprod/issparse @kronprod/issquare @kronprod/minus @kronprod/mldivide @kronprod/mpower @kronprod/mtimes @kronprod/numel @kronprod/plus @kronprod/rank @kronprod/rdivide @kronprod/rows @kronprod/size @kronprod/size_equal @kronprod/sparse @kronprod/times @kronprod/trace @kronprod/transpose @kronprod/uminus @kronprod/uplus Circulant matrices circulant_make_matrix circulant_matrix_vector_product circulant_eig circulant_inv linear-algebra/COPYING0000644000175000017500000000004211743764400014316 0ustar juanpijuanpiSee individual files for licenses linear-algebra/NEWS0000644000175000017500000000170211756365401013770 0ustar juanpijuanpiSummary of important user-visible changes for linear-algebra 2.2.0: ------------------------------------------------------------------- ** The following functions are new in 2.2.0: circulant_eig circulant_inv circulant_make_matrix circulant_matrix_vector_product nmf_pg nmf_bpas ** Package is now dependent on general (>= 1.3.0) ** Package is no longer automatically loaded. Summary of important user-visible changes for linear-algebra 2.1.0: ------------------------------------------------------------------- ** The following functions are new in 2.1.0: lobpcg ndcovlt ** The following functions were removed since equivalents are now part of GNU octave core: bicg mgorth ** The following functions were deprecated since equivalents are now part of GNU octave core: pgmres ** The function `funm' now also accepts function handles. ** Help text of most functions has been improved. linear-algebra/DESCRIPTION0000644000175000017500000000062611756406345016450 0ustar carandraugcarandraugName: Linear-algebra Version: 2.2.0 Date: 2012-21-05 Author: various authors Maintainer: Octave-Forge community Title: Linear algebra. Description: Additional linear algebra code, including general SVD and matrix functions. Categories: Linear algebra Depends: octave (>= 3.2.3), general (>= 1.3.0) Autoload: no License: GPLv3+, LGPLv3+, FreeBSD Url: http://octave.sf.net