diff options
Diffstat (limited to 'gsl-1.9/linalg')
30 files changed, 12808 insertions, 0 deletions
diff --git a/gsl-1.9/linalg/ChangeLog b/gsl-1.9/linalg/ChangeLog new file mode 100644 index 0000000..f454b25 --- /dev/null +++ b/gsl-1.9/linalg/ChangeLog @@ -0,0 +1,350 @@ +2006-08-14 Brian Gough <bjg@network-theory.co.uk> + + * balancemat.c: balance a general matrix D^-1 A D for rows and + columns + +2006-04-24 Brian Gough <bjg@network-theory.co.uk> + + * svdstep.c apply_givens.c householder.c: perform linear + operations with level-1 blas when compiled with USE_BLAS. + +2006-02-10 Brian Gough <bjg@network-theory.co.uk> + + * cholesky.c (quiet_sqrt): added a quiet_sqrt to allow checking + for positive definiteness without a runtime error + +2005-08-22 Brian Gough <bjg@network-theory.co.uk> + + * svd.c (gsl_linalg_SV_decomp_jacobi): reorganised convergence + tests to increase robustness in the presence of extended precision + registers. + +2005-06-22 Brian Gough <bjg@network-theory.co.uk> + + * svd.c (gsl_linalg_SV_decomp_jacobi): increased number of sweeps + to MAX(5*N,12) and track numerical errors for better termination + +2005-02-02 Brian Gough <bjg@network-theory.co.uk> + + * svd.c (gsl_linalg_SV_decomp_jacobi): changed M<N test to correct + matrix A instead of Q. + +2004-12-23 Brian Gough <bjg@network-theory.co.uk> + + * qr.c (gsl_linalg_R_svx): added missing function + +2004-09-13 Brian Gough <bjg@network-theory.co.uk> + + * test.c: added tests for LQ, P^TLQ solvers + + * ptlq.c: added support for PA = LQ decompositions + + * lq.c: added support for A = LQ decompositions + +2004-05-30 Brian Gough <bjg@network-theory.co.uk> + + * test.c (test_LU_solve): increase test tolerance to accommodate + gcc-3.3.3 w/ bounds checking + +2004-05-26 Brian Gough <bjg@network-theory.co.uk> + + * householder.c (gsl_linalg_householder_hm): + (gsl_linalg_householder_mh): + (gsl_linalg_householder_hm1): added blas code (but ifdef'd out) + + * test.c (test_SV_decomp_dim): skip NaNs in test + (test_SV_decomp_mod_dim): skip NaNs in test + +2004-04-26 Brian Gough <bjg@network-theory.co.uk> + + * test.c (test_TDN_solve): increased tolerance for tests + (test_TDN_cyc_solve): increased tolerance for tests + +2004-03-15 Brian Gough <bjg@network-theory.co.uk> + + * tridiag.c: (gsl_linalg_solve_symm_tridiag): + (gsl_linalg_solve_tridiag): + (gsl_linalg_solve_symm_cyc_tridiag): + (gsl_linalg_solve_cyc_tridiag): use GSL_ERROR macro to report + errors, make size restrictions tighter (no unused elements allowed + to be passed in). + +2004-03-06 Brian Gough <bjg@network-theory.co.uk> + + * test.c (test_SV_decomp_mod_dim): added tests for SV_decomp_mod + + * svd.c (gsl_linalg_SV_decomp): handle the case N=1 (SVD of a + column vector) + (gsl_linalg_SV_decomp_mod): handle the case N=1 (SVD of a column + vector) + +2004-03-05 Brian Gough <bjg@network-theory.co.uk> + + * test.c (test_SV_decomp): add tests with inf/nan + + * svd.c (gsl_linalg_SV_decomp): handle nans in block reduction + + * balance.c: handle infinity/nan when scaling input matrix + +2003-07-24 Brian Gough <bjg@network-theory.co.uk> + + * tridiag.c (solve_cyc_tridiag_nonsym): fixed declarations of i so + they do not shadow each other + +2003-05-30 Brian Gough <bjg@network-theory.co.uk> + + * householder.c (gsl_linalg_householder_hv): converted to use blas + routines + +2003-05-08 Brian Gough <bjg@network-theory.co.uk> + + * test.c: added tests for QR_QRsolve and QRPT_QRsolve + + * qrpt.c (gsl_linalg_QRPT_QRsolve): fixed dgemv to use CblasTrans + when computing Q^T b + + * qr.c (gsl_linalg_QR_QRsolve): fixed dgemv to use CblasTrans when + computing Q^T b + +Fri Oct 18 17:46:30 2002 Brian Gough <bjg@network-theory.co.uk> + + * householdercomplex.c (gsl_linalg_complex_householder_transform): + return tau = 0 to prevent division by zero for beta_r = 0 + +Mon Aug 12 20:12:55 2002 Brian Gough <bjg@network-theory.co.uk> + + * bidiag.c (gsl_linalg_bidiag_unpack_B): fixed to copy + superdiagonal and not subdiagonal, as was incorrectly done + previously. + +Sun Jun 16 11:57:00 2002 Brian Gough <bjg@network-theory.co.uk> + + * svd.c (gsl_linalg_SV_decomp): keep track of maximum value + correctly when sorting singular values + + * test.c (test_SV_decomp): add 3x3 of SVD + + * svdstep.c (chase_out_intermediate_zero): handle case of dk=0 + (chase_out_trailing_zero): handle case of dn=0 + +Wed Apr 17 20:04:11 2002 Brian Gough <bjg@network-theory.co.uk> + + * tridiag.c (gsl_linalg_solve_tridiag): + (gsl_linalg_solve_cyc_tridiag): added tridiagonal solvers for + non-symmetric case (David Necas <yeti@physics.muni.cz>) + +Mon Apr 15 19:55:40 2002 Brian Gough <bjg@network-theory.co.uk> + + * tridiag.c (solve_cyc_tridiag): corrected typographical error in + Engeln-Mullges Algorithm 4.35, step 1.7 (f_(n-1) should be + alpha_(n-1)) + +Thu Sep 13 12:26:17 2001 Brian Gough <bjg@network-theory.co.uk> + + * test.c (test_SV_decomp): added brute force testing of 2x2 svd + + * svdstep.c (svd2): fixed bug where singular values in 2x2 svd + were not ordered correctly. + +Mon Sep 10 22:35:24 2001 Brian Gough <bjg@network-theory.co.uk> + + * test.c (test_LUc_solve): added a test for complex LU + +Tue Sep 4 17:22:58 2001 Brian Gough <bjg@network-theory.co.uk> + + * luc.c: added LU decomposition for complex matrices + +Wed Aug 29 16:34:50 2001 Brian Gough <bjg@network-theory.co.uk> + + * svd.c (gsl_linalg_SV_decomp_jacobi): make sure all singular + vectors are zero, not just first. + + * svdstep.c (svd2): added explicit calculation of 2x2 svd, fixes + bug that prevents convergence. + +Thu Aug 2 18:19:08 2001 Brian Gough <bjg@network-theory.co.uk> + + * svdstep.c (trailing_eigenvalue): chose better value of mu when + dt=0. + +Sun Jul 8 18:03:05 2001 Brian Gough <bjg@network-theory.co.uk> + + * qrpt.c (gsl_linalg_QRPT_decomp): fix bug where null column + caused division by zero in norm-update calculation + +Sun Jul 1 22:43:22 2001 Brian Gough <bjg@network-theory.co.uk> + + * modified to use new-style vector views, affects most + functions + +Wed Jun 20 13:38:24 2001 Brian Gough <bjg@network-theory.co.uk> + + * svd.c (gsl_linalg_SV_decomp): added error checking + +Tue Jun 19 23:19:49 2001 Brian Gough <bjg@network-theory.co.uk> + + * svd.c (gsl_linalg_SV_decomp): Golub-Reinsch svd, has more + deterministic convergence + (gsl_linalg_SV_decomp_mod): Golub-Reinsch with + Preconditioning, much more efficient for M>>N + + * balance.c (gsl_linalg_balance_columns): balances (or + "equilibrates") the columns of a matrix + +Sun Jun 17 21:49:03 2001 Brian Gough <bjg@network-theory.co.uk> + + * givens.c: split out apply_givens functions into separate file + apply_givens.c + +Wed Jun 13 23:41:34 2001 Brian Gough <bjg@network-theory.co.uk> + + * qr.c (gsl_linalg_QR_decomp): simplified reverse loop + + * bidiag.c: bidiagonalisation of a matrix (needed for + Golub-Reinsch SVD) + +Wed Jun 6 12:36:58 2001 Brian Gough <bjg@network-theory.co.uk> + + * householdercomplex.c: split out complex functions into a + separate file to reduce linking dependencies + + * qrpt.c (gsl_linalg_QRPT_decomp): provide workspace as an + argument, to avoid allocating it on each call + (gsl_linalg_QRPT_decomp2): provide workspace as an argument, to + avoid allocating it on each call + + * qr.c (gsl_linalg_QR_decomp): provide workspace as an argument, + to avoid allocating it on each call + +Thu May 17 17:01:45 2001 Brian Gough <bjg@network-theory.co.uk> + + * qr.c (gsl_linalg_QR_lssolve): added least squares solver + +Sat Apr 28 00:39:53 2001 Brian Gough <bjg@network-theory.co.uk> + + * qr.c (gsl_linalg_QR_update): fixed QR update to work correctly + with rectangular matrices where M > N + +Mon Apr 23 10:29:01 2001 Brian Gough <bjg@network-theory.co.uk> + + * tridiag.c: removed EFAULT test since this should only apply to + non-null invalid pointers + +Fri Apr 13 20:43:38 2001 Brian Gough <bjg@network-theory.co.uk> + + * test.c: replaced uses of matmult by dgemm + +Sun Oct 22 13:56:30 2000 Brian Gough <bjg@network-theory.co.uk> + + * householder.c (gsl_linalg_householder_transform): changed calls + to gsl_hypot() to hypot() so that the system function is used in + preference (the configure script will define hypot to gsl_hypot if + hypot is unavailable) + + * svd.c (gsl_linalg_SV_decomp): changed calls to gsl_hypot() to + hypot() + +Sat Oct 21 15:54:56 2000 Brian Gough <bjg@network-theory.co.uk> + + * tridiag.c (solve_tridiag): prevent out-of-bounds array access + for small N (attempt to access element[N-2] when N is 1). + +Tue Sep 19 21:42:13 2000 Brian Gough <bjg@network-theory.co.uk> + + * qrpt.c (gsl_linalg_QRPT_decomp2): added convenience function to + compute q,r unpacked decomposition directly + +Wed Aug 16 19:50:35 2000 Brian Gough <bjg@network-theory.co.uk> + + * svd.c (gsl_linalg_SV_decomp): take more care with singular + values, set the associated vectors to zero + +Sun Aug 13 16:39:40 2000 Brian Gough <bjg@network-theory.co.uk> + + * qrpt.c (gsl_linalg_QRPT_decomp): fixed obvious bug in selection + of column with max norm + +Wed May 31 19:42:59 2000 Brian Gough <bjg@network-theory.co.uk> + + * test.c (test_QR_update): increased tolerances on results to + allow tests to pass with other compilers + +Wed May 3 21:19:45 2000 Brian Gough <bjg@network-theory.co.uk> + + * cholesky.c: added cholesky decomposition/solve from Thomas + Walter. Modified for GSL. + +Fri Apr 28 17:13:00 2000 Brian Gough <bjg@network-theory.co.uk> + + * renamed all matrices to use upper case variable names, e.g. A + +Thu Apr 27 20:31:46 2000 Brian Gough <bjg@network-theory.co.uk> + + * test.c: tightened up accuracy of the decomp test + + * test_la.c: renamed to test.c for consistency + (test_QR_decomp): added the "moler" matrix as a test for SVD + + * svd.c (gsl_linalg_SV_decomp): improved the convergence criterion + for rank deficient case. + +Wed Apr 26 19:37:46 2000 Brian Gough <bjg@network-theory.co.uk> + + * renamed rhs -> b, and solution -> x throughout for consistency + +Mon Apr 24 17:04:52 2000 Brian Gough <bjg@network-theory.co.uk> + + * test_la.c (main): added tests for MxN matrices + + * test_la.c (main): added tests for SV decomposition and solve. + + * svd.c (gsl_linalg_SV_decomp): made use of vector row/column + functions, tidied up the algorithm a bit. Use a standard tolerance + of 10*GSL_DBL_EPSILON. + (gsl_linalg_SV_solve): added a least squares solver + +Sun Apr 23 21:18:04 2000 Brian Gough <bjg@network-theory.co.uk> + + * gsl_linalg.h, svd.c (gsl_linalg_SV_decomp): changed function + name to new naming convention + + * qr.c (gsl_linalg_QR_unpack): fixed index ranges for rectangular + case when unpacking R + +Sat Apr 22 15:05:21 2000 Brian Gough <bjg@network-theory.co.uk> + + * matrix.c: removed, equivalent functions now in matrix directory + +Sat Mar 11 17:36:33 2000 Brian Gough <bjg@network-theory.co.uk> + + * multiply.c: removed _impl from these functions since all the + errors they can return are fatal. + +Wed Feb 16 12:03:00 2000 Brian Gough <bjg@network-theory.co.uk> + + * multiply.c (gsl_la_matmult_mod_impl): fixed error in transposed + matrix memory access, expressions should always be of the form + M->data[i*M->size2 + j] even when i,j are transposed. + + Safer to replace matrix access by gsl_matrix_set and + gsl_matrix_get, which is what I have done now. Shouldn't be any + cost in the production version of the library where we have + inlines and range checking off. + +Tue Feb 15 17:46:19 2000 Brian Gough <bjg@network-theory.co.uk> + + * tridiag.h (solve_cyc_tridiag): fixed typo in header, was + solve_cyctridiag, missing _. + + * converted all functions to use gsl_permutation instead of + gsl_vector_int + +Fri Oct 1 15:51:02 1999 Brian Gough <bjg@network-theory.co.uk> + + * temporary changes resulting from changes to block/vector/matrix + organization + +Fri Aug 6 14:42:23 1999 Brian Gough <bjg@network-theory.co.uk> + + * linalg_simple.c: include <string.h> to declare memcpy + diff --git a/gsl-1.9/linalg/Makefile.am b/gsl-1.9/linalg/Makefile.am new file mode 100644 index 0000000..8f4a9b3 --- /dev/null +++ b/gsl-1.9/linalg/Makefile.am @@ -0,0 +1,19 @@ +noinst_LTLIBRARIES = libgsllinalg.la + +pkginclude_HEADERS = gsl_linalg.h + +INCLUDES= -I$(top_builddir) + +libgsllinalg_la_SOURCES = multiply.c exponential.c tridiag.c tridiag.h lu.c luc.c hh.c qr.c qrpt.c lq.c ptlq.c svd.c householder.c householdercomplex.c hessenberg.c cholesky.c symmtd.c hermtd.c bidiag.c balance.c balancemat.c + +noinst_HEADERS = givens.c apply_givens.c svdstep.c tridiag.h + +TESTS = $(check_PROGRAMS) + +check_PROGRAMS = test + +test_LDADD = libgsllinalg.la ../blas/libgslblas.la ../cblas/libgslcblas.la ../permutation/libgslpermutation.la ../matrix/libgslmatrix.la ../vector/libgslvector.la ../block/libgslblock.la ../complex/libgslcomplex.la ../ieee-utils/libgslieeeutils.la ../err/libgslerr.la ../test/libgsltest.la ../sys/libgslsys.la ../utils/libutils.la + +test_SOURCES = test.c + + diff --git a/gsl-1.9/linalg/Makefile.in b/gsl-1.9/linalg/Makefile.in new file mode 100644 index 0000000..ff3ea12 --- /dev/null +++ b/gsl-1.9/linalg/Makefile.in @@ -0,0 +1,550 @@ +# Makefile.in generated by automake 1.9.6 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, +# 2003, 2004, 2005 Free Software Foundation, Inc. +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ + + +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +VPATH = @srcdir@ +pkgdatadir = $(datadir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +top_builddir = .. +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +INSTALL = @INSTALL@ +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +check_PROGRAMS = test$(EXEEXT) +subdir = linalg +DIST_COMMON = $(noinst_HEADERS) $(pkginclude_HEADERS) \ + $(srcdir)/Makefile.am $(srcdir)/Makefile.in ChangeLog TODO +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs +CONFIG_HEADER = $(top_builddir)/config.h +CONFIG_CLEAN_FILES = +LTLIBRARIES = $(noinst_LTLIBRARIES) +libgsllinalg_la_LIBADD = +am_libgsllinalg_la_OBJECTS = multiply.lo exponential.lo tridiag.lo \ + lu.lo luc.lo hh.lo qr.lo qrpt.lo lq.lo ptlq.lo svd.lo \ + householder.lo householdercomplex.lo hessenberg.lo cholesky.lo \ + symmtd.lo hermtd.lo bidiag.lo balance.lo balancemat.lo +libgsllinalg_la_OBJECTS = $(am_libgsllinalg_la_OBJECTS) +am_test_OBJECTS = test.$(OBJEXT) +test_OBJECTS = $(am_test_OBJECTS) +test_DEPENDENCIES = libgsllinalg.la ../blas/libgslblas.la \ + ../cblas/libgslcblas.la ../permutation/libgslpermutation.la \ + ../matrix/libgslmatrix.la ../vector/libgslvector.la \ + ../block/libgslblock.la ../complex/libgslcomplex.la \ + ../ieee-utils/libgslieeeutils.la ../err/libgslerr.la \ + ../test/libgsltest.la ../sys/libgslsys.la ../utils/libutils.la +DEFAULT_INCLUDES = -I. -I$(srcdir) -I$(top_builddir) +depcomp = +am__depfiles_maybe = +COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ + $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) +LTCOMPILE = $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) \ + $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ + $(AM_CFLAGS) $(CFLAGS) +CCLD = $(CC) +LINK = $(LIBTOOL) --tag=CC --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ + $(AM_LDFLAGS) $(LDFLAGS) -o $@ +SOURCES = $(libgsllinalg_la_SOURCES) $(test_SOURCES) +DIST_SOURCES = $(libgsllinalg_la_SOURCES) $(test_SOURCES) +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = `echo $$p | sed -e 's|^.*/||'`; +am__installdirs = "$(DESTDIR)$(pkgincludedir)" +pkgincludeHEADERS_INSTALL = $(INSTALL_HEADER) +HEADERS = $(noinst_HEADERS) $(pkginclude_HEADERS) +ETAGS = etags +CTAGS = ctags +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AR = @AR@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +CC = @CC@ +CFLAGS = @CFLAGS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CYGPATH_W = @CYGPATH_W@ +DEFS = @DEFS@ +ECHO = @ECHO@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +EXEEXT = @EXEEXT@ +GSL_CFLAGS = @GSL_CFLAGS@ +GSL_LIBS = @GSL_LIBS@ +GSL_LT_CBLAS_VERSION = @GSL_LT_CBLAS_VERSION@ +GSL_LT_VERSION = @GSL_LT_VERSION@ +HAVE_AIX_IEEE_INTERFACE = @HAVE_AIX_IEEE_INTERFACE@ +HAVE_DARWIN86_IEEE_INTERFACE = @HAVE_DARWIN86_IEEE_INTERFACE@ +HAVE_DARWIN_IEEE_INTERFACE = @HAVE_DARWIN_IEEE_INTERFACE@ +HAVE_EXTENDED_PRECISION_REGISTERS = @HAVE_EXTENDED_PRECISION_REGISTERS@ +HAVE_FREEBSD_IEEE_INTERFACE = @HAVE_FREEBSD_IEEE_INTERFACE@ +HAVE_GNUM68K_IEEE_INTERFACE = @HAVE_GNUM68K_IEEE_INTERFACE@ +HAVE_GNUPPC_IEEE_INTERFACE = @HAVE_GNUPPC_IEEE_INTERFACE@ +HAVE_GNUSPARC_IEEE_INTERFACE = @HAVE_GNUSPARC_IEEE_INTERFACE@ +HAVE_GNUX86_IEEE_INTERFACE = @HAVE_GNUX86_IEEE_INTERFACE@ +HAVE_HPUX11_IEEE_INTERFACE = @HAVE_HPUX11_IEEE_INTERFACE@ +HAVE_HPUX_IEEE_INTERFACE = @HAVE_HPUX_IEEE_INTERFACE@ +HAVE_IEEE_COMPARISONS = @HAVE_IEEE_COMPARISONS@ +HAVE_IEEE_DENORMALS = @HAVE_IEEE_DENORMALS@ +HAVE_INLINE = @HAVE_INLINE@ +HAVE_IRIX_IEEE_INTERFACE = @HAVE_IRIX_IEEE_INTERFACE@ +HAVE_NETBSD_IEEE_INTERFACE = @HAVE_NETBSD_IEEE_INTERFACE@ +HAVE_OPENBSD_IEEE_INTERFACE = @HAVE_OPENBSD_IEEE_INTERFACE@ +HAVE_OS2EMX_IEEE_INTERFACE = @HAVE_OS2EMX_IEEE_INTERFACE@ +HAVE_PRINTF_LONGDOUBLE = @HAVE_PRINTF_LONGDOUBLE@ +HAVE_SOLARIS_IEEE_INTERFACE = @HAVE_SOLARIS_IEEE_INTERFACE@ +HAVE_SUNOS4_IEEE_INTERFACE = @HAVE_SUNOS4_IEEE_INTERFACE@ +HAVE_TRU64_IEEE_INTERFACE = @HAVE_TRU64_IEEE_INTERFACE@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LDFLAGS = @LDFLAGS@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LIBTOOL = @LIBTOOL@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +MAINT = @MAINT@ +MAINTAINER_MODE_FALSE = @MAINTAINER_MODE_FALSE@ +MAINTAINER_MODE_TRUE = @MAINTAINER_MODE_TRUE@ +MAKEINFO = @MAKEINFO@ +OBJEXT = @OBJEXT@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +RANLIB = @RANLIB@ +RELEASED = @RELEASED@ +SET_MAKE = @SET_MAKE@ +SHELL = @SHELL@ +STRIP = @STRIP@ +VERSION = @VERSION@ +ac_ct_AR = @ac_ct_AR@ +ac_ct_CC = @ac_ct_CC@ +ac_ct_RANLIB = @ac_ct_RANLIB@ +ac_ct_STRIP = @ac_ct_STRIP@ +am__leading_dot = @am__leading_dot@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +datadir = @datadir@ +exec_prefix = @exec_prefix@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +noinst_LTLIBRARIES = libgsllinalg.la +pkginclude_HEADERS = gsl_linalg.h +INCLUDES = -I$(top_builddir) +libgsllinalg_la_SOURCES = multiply.c exponential.c tridiag.c tridiag.h lu.c luc.c hh.c qr.c qrpt.c lq.c ptlq.c svd.c householder.c householdercomplex.c hessenberg.c cholesky.c symmtd.c hermtd.c bidiag.c balance.c balancemat.c +noinst_HEADERS = givens.c apply_givens.c svdstep.c tridiag.h +TESTS = $(check_PROGRAMS) +test_LDADD = libgsllinalg.la ../blas/libgslblas.la ../cblas/libgslcblas.la ../permutation/libgslpermutation.la ../matrix/libgslmatrix.la ../vector/libgslvector.la ../block/libgslblock.la ../complex/libgslcomplex.la ../ieee-utils/libgslieeeutils.la ../err/libgslerr.la ../test/libgsltest.la ../sys/libgslsys.la ../utils/libutils.la +test_SOURCES = test.c +all: all-am + +.SUFFIXES: +.SUFFIXES: .c .lo .o .obj +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh \ + && exit 0; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu --ignore-deps linalg/Makefile'; \ + cd $(top_srcdir) && \ + $(AUTOMAKE) --gnu --ignore-deps linalg/Makefile +.PRECIOUS: Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +clean-noinstLTLIBRARIES: + -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES) + @list='$(noinst_LTLIBRARIES)'; for p in $$list; do \ + dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \ + test "$$dir" != "$$p" || dir=.; \ + echo "rm -f \"$${dir}/so_locations\""; \ + rm -f "$${dir}/so_locations"; \ + done +libgsllinalg.la: $(libgsllinalg_la_OBJECTS) $(libgsllinalg_la_DEPENDENCIES) + $(LINK) $(libgsllinalg_la_LDFLAGS) $(libgsllinalg_la_OBJECTS) $(libgsllinalg_la_LIBADD) $(LIBS) + +clean-checkPROGRAMS: + @list='$(check_PROGRAMS)'; for p in $$list; do \ + f=`echo $$p|sed 's/$(EXEEXT)$$//'`; \ + echo " rm -f $$p $$f"; \ + rm -f $$p $$f ; \ + done +test$(EXEEXT): $(test_OBJECTS) $(test_DEPENDENCIES) + @rm -f test$(EXEEXT) + $(LINK) $(test_LDFLAGS) $(test_OBJECTS) $(test_LDADD) $(LIBS) + +mostlyclean-compile: + -rm -f *.$(OBJEXT) + +distclean-compile: + -rm -f *.tab.c + +.c.o: + $(COMPILE) -c $< + +.c.obj: + $(COMPILE) -c `$(CYGPATH_W) '$<'` + +.c.lo: + $(LTCOMPILE) -c -o $@ $< + +mostlyclean-libtool: + -rm -f *.lo + +clean-libtool: + -rm -rf .libs _libs + +distclean-libtool: + -rm -f libtool +uninstall-info-am: +install-pkgincludeHEADERS: $(pkginclude_HEADERS) + @$(NORMAL_INSTALL) + test -z "$(pkgincludedir)" || $(mkdir_p) "$(DESTDIR)$(pkgincludedir)" + @list='$(pkginclude_HEADERS)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + f=$(am__strip_dir) \ + echo " $(pkgincludeHEADERS_INSTALL) '$$d$$p' '$(DESTDIR)$(pkgincludedir)/$$f'"; \ + $(pkgincludeHEADERS_INSTALL) "$$d$$p" "$(DESTDIR)$(pkgincludedir)/$$f"; \ + done + +uninstall-pkgincludeHEADERS: + @$(NORMAL_UNINSTALL) + @list='$(pkginclude_HEADERS)'; for p in $$list; do \ + f=$(am__strip_dir) \ + echo " rm -f '$(DESTDIR)$(pkgincludedir)/$$f'"; \ + rm -f "$(DESTDIR)$(pkgincludedir)/$$f"; \ + done + +ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + mkid -fID $$unique +tags: TAGS + +TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + tags=; \ + here=`pwd`; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$tags $$unique; \ + fi +ctags: CTAGS +CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + tags=; \ + here=`pwd`; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + test -z "$(CTAGS_ARGS)$$tags$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$tags $$unique + +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && cd $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) $$here + +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags + +check-TESTS: $(TESTS) + @failed=0; all=0; xfail=0; xpass=0; skip=0; \ + srcdir=$(srcdir); export srcdir; \ + list='$(TESTS)'; \ + if test -n "$$list"; then \ + for tst in $$list; do \ + if test -f ./$$tst; then dir=./; \ + elif test -f $$tst; then dir=; \ + else dir="$(srcdir)/"; fi; \ + if $(TESTS_ENVIRONMENT) $${dir}$$tst; then \ + all=`expr $$all + 1`; \ + case " $(XFAIL_TESTS) " in \ + *" $$tst "*) \ + xpass=`expr $$xpass + 1`; \ + failed=`expr $$failed + 1`; \ + echo "XPASS: $$tst"; \ + ;; \ + *) \ + echo "PASS: $$tst"; \ + ;; \ + esac; \ + elif test $$? -ne 77; then \ + all=`expr $$all + 1`; \ + case " $(XFAIL_TESTS) " in \ + *" $$tst "*) \ + xfail=`expr $$xfail + 1`; \ + echo "XFAIL: $$tst"; \ + ;; \ + *) \ + failed=`expr $$failed + 1`; \ + echo "FAIL: $$tst"; \ + ;; \ + esac; \ + else \ + skip=`expr $$skip + 1`; \ + echo "SKIP: $$tst"; \ + fi; \ + done; \ + if test "$$failed" -eq 0; then \ + if test "$$xfail" -eq 0; then \ + banner="All $$all tests passed"; \ + else \ + banner="All $$all tests behaved as expected ($$xfail expected failures)"; \ + fi; \ + else \ + if test "$$xpass" -eq 0; then \ + banner="$$failed of $$all tests failed"; \ + else \ + banner="$$failed of $$all tests did not behave as expected ($$xpass unexpected passes)"; \ + fi; \ + fi; \ + dashes="$$banner"; \ + skipped=""; \ + if test "$$skip" -ne 0; then \ + skipped="($$skip tests were not run)"; \ + test `echo "$$skipped" | wc -c` -le `echo "$$banner" | wc -c` || \ + dashes="$$skipped"; \ + fi; \ + report=""; \ + if test "$$failed" -ne 0 && test -n "$(PACKAGE_BUGREPORT)"; then \ + report="Please report to $(PACKAGE_BUGREPORT)"; \ + test `echo "$$report" | wc -c` -le `echo "$$banner" | wc -c` || \ + dashes="$$report"; \ + fi; \ + dashes=`echo "$$dashes" | sed s/./=/g`; \ + echo "$$dashes"; \ + echo "$$banner"; \ + test -z "$$skipped" || echo "$$skipped"; \ + test -z "$$report" || echo "$$report"; \ + echo "$$dashes"; \ + test "$$failed" -eq 0; \ + else :; fi + +distdir: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's|.|.|g'`; \ + list='$(DISTFILES)'; for file in $$list; do \ + case $$file in \ + $(srcdir)/*) file=`echo "$$file" | sed "s|^$$srcdirstrip/||"`;; \ + $(top_srcdir)/*) file=`echo "$$file" | sed "s|^$$topsrcdirstrip/|$(top_builddir)/|"`;; \ + esac; \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + dir=`echo "$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test "$$dir" != "$$file" && test "$$dir" != "."; then \ + dir="/$$dir"; \ + $(mkdir_p) "$(distdir)$$dir"; \ + else \ + dir=''; \ + fi; \ + if test -d $$d/$$file; then \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -pR $(srcdir)/$$file $(distdir)$$dir || exit 1; \ + fi; \ + cp -pR $$d/$$file $(distdir)$$dir || exit 1; \ + else \ + test -f $(distdir)/$$file \ + || cp -p $$d/$$file $(distdir)/$$file \ + || exit 1; \ + fi; \ + done +check-am: all-am + $(MAKE) $(AM_MAKEFLAGS) $(check_PROGRAMS) + $(MAKE) $(AM_MAKEFLAGS) check-TESTS +check: check-am +all-am: Makefile $(LTLIBRARIES) $(HEADERS) +installdirs: + for dir in "$(DESTDIR)$(pkgincludedir)"; do \ + test -z "$$dir" || $(mkdir_p) "$$dir"; \ + done +install: install-am +install-exec: install-exec-am +install-data: install-data-am +uninstall: uninstall-am + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-am +install-strip: + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + `test -z '$(STRIP)' || \ + echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install +mostlyclean-generic: + +clean-generic: + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-am + +clean-am: clean-checkPROGRAMS clean-generic clean-libtool \ + clean-noinstLTLIBRARIES mostlyclean-am + +distclean: distclean-am + -rm -f Makefile +distclean-am: clean-am distclean-compile distclean-generic \ + distclean-libtool distclean-tags + +dvi: dvi-am + +dvi-am: + +html: html-am + +info: info-am + +info-am: + +install-data-am: install-pkgincludeHEADERS + +install-exec-am: + +install-info: install-info-am + +install-man: + +installcheck-am: + +maintainer-clean: maintainer-clean-am + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-am + +mostlyclean-am: mostlyclean-compile mostlyclean-generic \ + mostlyclean-libtool + +pdf: pdf-am + +pdf-am: + +ps: ps-am + +ps-am: + +uninstall-am: uninstall-info-am uninstall-pkgincludeHEADERS + +.PHONY: CTAGS GTAGS all all-am check check-TESTS check-am clean \ + clean-checkPROGRAMS clean-generic clean-libtool \ + clean-noinstLTLIBRARIES ctags distclean distclean-compile \ + distclean-generic distclean-libtool distclean-tags distdir dvi \ + dvi-am html html-am info info-am install install-am \ + install-data install-data-am install-exec install-exec-am \ + install-info install-info-am install-man \ + install-pkgincludeHEADERS install-strip installcheck \ + installcheck-am installdirs maintainer-clean \ + maintainer-clean-generic mostlyclean mostlyclean-compile \ + mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ + tags uninstall uninstall-am uninstall-info-am \ + uninstall-pkgincludeHEADERS + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/gsl-1.9/linalg/TODO b/gsl-1.9/linalg/TODO new file mode 100644 index 0000000..31747ee --- /dev/null +++ b/gsl-1.9/linalg/TODO @@ -0,0 +1,6 @@ +* Provide support for the following special systems: + + Vandermonde, Toeplitz, ... + + + diff --git a/gsl-1.9/linalg/apply_givens.c b/gsl-1.9/linalg/apply_givens.c new file mode 100644 index 0000000..2d4fe55 --- /dev/null +++ b/gsl-1.9/linalg/apply_givens.c @@ -0,0 +1,125 @@ +/* linalg/apply_givens.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Gerard Jungman, Brian Gough + * Copyright (C) 2004 Joerg Wensch, modifications for LQ. + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +inline static void +apply_givens_qr (size_t M, size_t N, gsl_matrix * Q, gsl_matrix * R, + size_t i, size_t j, double c, double s) +{ + size_t k; + + /* Apply rotation to matrix Q, Q' = Q G */ + +#if USE_BLAS + { + gsl_matrix_view Q0M = gsl_matrix_submatrix(Q,0,0,M,j+1); + gsl_vector_view Qi = gsl_matrix_column(&Q0M.matrix,i); + gsl_vector_view Qj = gsl_matrix_column(&Q0M.matrix,j); + gsl_blas_drot(&Qi.vector, &Qj.vector, c, -s); + } +#else + for (k = 0; k < M; k++) + { + double qki = gsl_matrix_get (Q, k, i); + double qkj = gsl_matrix_get (Q, k, j); + gsl_matrix_set (Q, k, i, qki * c - qkj * s); + gsl_matrix_set (Q, k, j, qki * s + qkj * c); + } +#endif + + /* Apply rotation to matrix R, R' = G^T R (note: upper triangular so + zero for column < row) */ + +#if USE_BLAS + { + k = GSL_MIN(i,j); + gsl_matrix_view R0 = gsl_matrix_submatrix(R, 0, k, j+1, N-k); + gsl_vector_view Ri = gsl_matrix_row(&R0.matrix,i); + gsl_vector_view Rj = gsl_matrix_row(&R0.matrix,j); + gsl_blas_drot(&Ri.vector, &Rj.vector, c, -s); + } +#else + for (k = GSL_MIN (i, j); k < N; k++) + { + double rik = gsl_matrix_get (R, i, k); + double rjk = gsl_matrix_get (R, j, k); + gsl_matrix_set (R, i, k, c * rik - s * rjk); + gsl_matrix_set (R, j, k, s * rik + c * rjk); + } +#endif +} + +inline static void +apply_givens_lq (size_t M, size_t N, gsl_matrix * Q, gsl_matrix * L, + size_t i, size_t j, double c, double s) +{ + size_t k; + + /* Apply rotation to matrix Q, Q' = G Q */ + +#if USE_BLAS + { + gsl_matrix_view Q0M = gsl_matrix_submatrix(Q,0,0,j+1,M); + gsl_vector_view Qi = gsl_matrix_row(&Q0M.matrix,i); + gsl_vector_view Qj = gsl_matrix_row(&Q0M.matrix,j); + gsl_blas_drot(&Qi.vector, &Qj.vector, c, -s); + } +#else + for (k = 0; k < M; k++) + { + double qik = gsl_matrix_get (Q, i, k); + double qjk = gsl_matrix_get (Q, j, k); + gsl_matrix_set (Q, i, k, qik * c - qjk * s); + gsl_matrix_set (Q, j, k, qik * s + qjk * c); + } +#endif + + /* Apply rotation to matrix L, L' = L G^T (note: lower triangular so + zero for column > row) */ + +#if USE_BLAS + { + k = GSL_MIN(i,j); + gsl_matrix_view L0 = gsl_matrix_submatrix(L, k, 0, N-k, j+1); + gsl_vector_view Li = gsl_matrix_column(&L0.matrix,i); + gsl_vector_view Lj = gsl_matrix_column(&L0.matrix,j); + gsl_blas_drot(&Li.vector, &Lj.vector, c, -s); + } +#else + for (k = GSL_MIN (i, j); k < N; k++) + { + double lki = gsl_matrix_get (L, k, i); + double lkj = gsl_matrix_get (L, k, j); + gsl_matrix_set (L, k, i, c * lki - s * lkj); + gsl_matrix_set (L, k, j, s * lki + c * lkj); + } +#endif +} + +inline static void +apply_givens_vec (gsl_vector * v, size_t i, size_t j, double c, double s) +{ + /* Apply rotation to vector v' = G^T v */ + + double vi = gsl_vector_get (v, i); + double vj = gsl_vector_get (v, j); + gsl_vector_set (v, i, c * vi - s * vj); + gsl_vector_set (v, j, s * vi + c * vj); +} + diff --git a/gsl-1.9/linalg/balance.c b/gsl-1.9/linalg/balance.c new file mode 100644 index 0000000..a5ebed1 --- /dev/null +++ b/gsl-1.9/linalg/balance.c @@ -0,0 +1,86 @@ +/* linalg/balance.c + * + * Copyright (C) 2001, 2004 Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Balance a general matrix by scaling the columns + * + * B = A D + * + * where D is a diagonal matrix + */ + +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> + +#include <gsl/gsl_linalg.h> + +int +gsl_linalg_balance_columns (gsl_matrix * A, gsl_vector * D) +{ + const size_t N = A->size2; + size_t j; + + if (D->size != A->size2) + { + GSL_ERROR("length of D must match second dimension of A", GSL_EINVAL); + } + + gsl_vector_set_all (D, 1.0); + + for (j = 0; j < N; j++) + { + gsl_vector_view A_j = gsl_matrix_column (A, j); + + double s = gsl_blas_dasum(&A_j.vector); + + double f = 1.0; + + if (s == 0.0 || !gsl_finite(s)) + { + gsl_vector_set (D, j, f); + continue; + } + + /* FIXME: we could use frexp() here */ + + while (s > 1.0) + { + s /= 2.0; + f *= 2.0; + } + + while (s < 0.5) + { + s *= 2.0; + f /= 2.0; + } + + gsl_vector_set (D, j, f); + + if (f != 1.0) + { + gsl_blas_dscal(1.0/f, &A_j.vector); + } + } + + return GSL_SUCCESS; +} diff --git a/gsl-1.9/linalg/balancemat.c b/gsl-1.9/linalg/balancemat.c new file mode 100644 index 0000000..b09cbb9 --- /dev/null +++ b/gsl-1.9/linalg/balancemat.c @@ -0,0 +1,186 @@ +/* linalg/balance.c + * + * Copyright (C) 2006 Patrick Alken + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Balance a general matrix by scaling the rows and columns, so the + * new row and column norms are the same order of magnitude. + * + * B = D^-1 A D + * + * where D is a diagonal matrix + * + * This is necessary for the unsymmetric eigenvalue problem since the + * calculation can become numerically unstable for unbalanced + * matrices. + * + * See Golub & Van Loan, "Matrix Computations" (3rd ed), Section 7.5.7 + * and Wilkinson & Reinsch, "Handbook for Automatic Computation", II/11 p320. + */ + +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> + +#include <gsl/gsl_linalg.h> + +#define FLOAT_RADIX 2.0 +#define FLOAT_RADIX_SQ (FLOAT_RADIX * FLOAT_RADIX) + +int +gsl_linalg_balance_matrix(gsl_matrix * A, gsl_vector * D) +{ + const size_t N = A->size1; + + if (N != D->size) + { + GSL_ERROR ("vector must match matrix size", GSL_EBADLEN); + } + else + { + double row_norm, + col_norm; + int not_converged; + gsl_vector_view v; + + /* initialize D to the identity matrix */ + gsl_vector_set_all(D, 1.0); + + not_converged = 1; + + while (not_converged) + { + size_t i, j; + double g, f, s; + + not_converged = 0; + + for (i = 0; i < N; ++i) + { + row_norm = 0.0; + col_norm = 0.0; + + for (j = 0; j < N; ++j) + { + if (j != i) + { + col_norm += fabs(gsl_matrix_get(A, j, i)); + row_norm += fabs(gsl_matrix_get(A, i, j)); + } + } + + if ((col_norm == 0.0) || (row_norm == 0.0)) + { + continue; + } + + g = row_norm / FLOAT_RADIX; + f = 1.0; + s = col_norm + row_norm; + + /* + * find the integer power of the machine radix which + * comes closest to balancing the matrix + */ + while (col_norm < g) + { + f *= FLOAT_RADIX; + col_norm *= FLOAT_RADIX_SQ; + } + + g = row_norm * FLOAT_RADIX; + + while (col_norm > g) + { + f /= FLOAT_RADIX; + col_norm /= FLOAT_RADIX_SQ; + } + + if ((row_norm + col_norm) < 0.95 * s * f) + { + not_converged = 1; + + g = 1.0 / f; + + /* + * apply similarity transformation D, where + * D_{ij} = f_i * delta_{ij} + */ + + /* multiply by D^{-1} on the left */ + v = gsl_matrix_row(A, i); + gsl_blas_dscal(g, &v.vector); + + /* multiply by D on the right */ + v = gsl_matrix_column(A, i); + gsl_blas_dscal(f, &v.vector); + + /* keep track of transformation */ + gsl_vector_set(D, i, gsl_vector_get(D, i) * f); + } + } + } + + return GSL_SUCCESS; + } +} /* gsl_linalg_balance_matrix() */ + +/* +gsl_linalg_balance_accum() + Accumulate a balancing transformation into a matrix. +This is used during the computation of Schur vectors since the +Schur vectors computed are the vectors for the balanced matrix. +We must at some point accumulate the balancing transformation into +the Schur vector matrix to get the vectors for the original matrix. + +A -> D A + +where D is the diagonal matrix + +Inputs: A - matrix to transform + D - vector containing diagonal elements of D +*/ + +int +gsl_linalg_balance_accum(gsl_matrix *A, gsl_vector *D) +{ + const size_t N = A->size1; + + if (N != D->size) + { + GSL_ERROR ("vector must match matrix size", GSL_EBADLEN); + } + else + { + size_t i; + double s; + gsl_vector_view r; + + for (i = 0; i < N; ++i) + { + s = gsl_vector_get(D, i); + r = gsl_matrix_row(A, i); + + gsl_blas_dscal(s, &r.vector); + } + + return GSL_SUCCESS; + } +} /* gsl_linalg_balance_accum() */ diff --git a/gsl-1.9/linalg/bidiag.c b/gsl-1.9/linalg/bidiag.c new file mode 100644 index 0000000..914ce7e --- /dev/null +++ b/gsl-1.9/linalg/bidiag.c @@ -0,0 +1,364 @@ +/* linalg/bidiag.c + * + * Copyright (C) 2001 Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Factorise a matrix A into + * + * A = U B V^T + * + * where U and V are orthogonal and B is upper bidiagonal. + * + * On exit, B is stored in the diagonal and first superdiagonal of A. + * + * U is stored as a packed set of Householder transformations in the + * lower triangular part of the input matrix below the diagonal. + * + * V is stored as a packed set of Householder transformations in the + * upper triangular part of the input matrix above the first + * superdiagonal. + * + * The full matrix for U can be obtained as the product + * + * U = U_1 U_2 .. U_N + * + * where + * + * U_i = (I - tau_i * u_i * u_i') + * + * and where u_i is a Householder vector + * + * u_i = [0, .. , 0, 1, A(i+1,i), A(i+3,i), .. , A(M,i)] + * + * The full matrix for V can be obtained as the product + * + * V = V_1 V_2 .. V_(N-2) + * + * where + * + * V_i = (I - tau_i * v_i * v_i') + * + * and where v_i is a Householder vector + * + * v_i = [0, .. , 0, 1, A(i,i+2), A(i,i+3), .. , A(i,N)] + * + * See Golub & Van Loan, "Matrix Computations" (3rd ed), Algorithm 5.4.2 + * + * Note: this description uses 1-based indices. The code below uses + * 0-based indices + */ + +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> + +#include <gsl/gsl_linalg.h> + +int +gsl_linalg_bidiag_decomp (gsl_matrix * A, gsl_vector * tau_U, gsl_vector * tau_V) +{ + if (A->size1 < A->size2) + { + GSL_ERROR ("bidiagonal decomposition requires M>=N", GSL_EBADLEN); + } + else if (tau_U->size != A->size2) + { + GSL_ERROR ("size of tau_U must be N", GSL_EBADLEN); + } + else if (tau_V->size + 1 != A->size2) + { + GSL_ERROR ("size of tau_V must be (N - 1)", GSL_EBADLEN); + } + else + { + const size_t M = A->size1; + const size_t N = A->size2; + size_t i; + + for (i = 0 ; i < N; i++) + { + /* Apply Householder transformation to current column */ + + { + gsl_vector_view c = gsl_matrix_column (A, i); + gsl_vector_view v = gsl_vector_subvector (&c.vector, i, M - i); + double tau_i = gsl_linalg_householder_transform (&v.vector); + + /* Apply the transformation to the remaining columns */ + + if (i + 1 < N) + { + gsl_matrix_view m = + gsl_matrix_submatrix (A, i, i + 1, M - i, N - (i + 1)); + gsl_linalg_householder_hm (tau_i, &v.vector, &m.matrix); + } + + gsl_vector_set (tau_U, i, tau_i); + + } + + /* Apply Householder transformation to current row */ + + if (i + 1 < N) + { + gsl_vector_view r = gsl_matrix_row (A, i); + gsl_vector_view v = gsl_vector_subvector (&r.vector, i + 1, N - (i + 1)); + double tau_i = gsl_linalg_householder_transform (&v.vector); + + /* Apply the transformation to the remaining rows */ + + if (i + 1 < M) + { + gsl_matrix_view m = + gsl_matrix_submatrix (A, i+1, i+1, M - (i+1), N - (i+1)); + gsl_linalg_householder_mh (tau_i, &v.vector, &m.matrix); + } + + gsl_vector_set (tau_V, i, tau_i); + } + } + } + + return GSL_SUCCESS; +} + +/* Form the orthogonal matrices U, V, diagonal d and superdiagonal sd + from the packed bidiagonal matrix A */ + +int +gsl_linalg_bidiag_unpack (const gsl_matrix * A, + const gsl_vector * tau_U, + gsl_matrix * U, + const gsl_vector * tau_V, + gsl_matrix * V, + gsl_vector * diag, + gsl_vector * superdiag) +{ + const size_t M = A->size1; + const size_t N = A->size2; + + const size_t K = GSL_MIN(M, N); + + if (M < N) + { + GSL_ERROR ("matrix A must have M >= N", GSL_EBADLEN); + } + else if (tau_U->size != K) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else if (tau_V->size + 1 != K) + { + GSL_ERROR ("size of tau must be MIN(M,N) - 1", GSL_EBADLEN); + } + else if (U->size1 != M || U->size2 != N) + { + GSL_ERROR ("size of U must be M x N", GSL_EBADLEN); + } + else if (V->size1 != N || V->size2 != N) + { + GSL_ERROR ("size of V must be N x N", GSL_EBADLEN); + } + else if (diag->size != K) + { + GSL_ERROR ("size of diagonal must match size of A", GSL_EBADLEN); + } + else if (superdiag->size + 1 != K) + { + GSL_ERROR ("size of subdiagonal must be (diagonal size - 1)", GSL_EBADLEN); + } + else + { + size_t i, j; + + /* Copy diagonal into diag */ + + for (i = 0; i < N; i++) + { + double Aii = gsl_matrix_get (A, i, i); + gsl_vector_set (diag, i, Aii); + } + + /* Copy superdiagonal into superdiag */ + + for (i = 0; i < N - 1; i++) + { + double Aij = gsl_matrix_get (A, i, i+1); + gsl_vector_set (superdiag, i, Aij); + } + + /* Initialize V to the identity */ + + gsl_matrix_set_identity (V); + + for (i = N - 1; i > 0 && i--;) + { + /* Householder row transformation to accumulate V */ + gsl_vector_const_view r = gsl_matrix_const_row (A, i); + gsl_vector_const_view h = + gsl_vector_const_subvector (&r.vector, i + 1, N - (i+1)); + + double ti = gsl_vector_get (tau_V, i); + + gsl_matrix_view m = + gsl_matrix_submatrix (V, i + 1, i + 1, N-(i+1), N-(i+1)); + + gsl_linalg_householder_hm (ti, &h.vector, &m.matrix); + } + + /* Initialize U to the identity */ + + gsl_matrix_set_identity (U); + + for (j = N; j > 0 && j--;) + { + /* Householder column transformation to accumulate U */ + gsl_vector_const_view c = gsl_matrix_const_column (A, j); + gsl_vector_const_view h = gsl_vector_const_subvector (&c.vector, j, M - j); + double tj = gsl_vector_get (tau_U, j); + + gsl_matrix_view m = + gsl_matrix_submatrix (U, j, j, M-j, N-j); + + gsl_linalg_householder_hm (tj, &h.vector, &m.matrix); + } + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_bidiag_unpack2 (gsl_matrix * A, + gsl_vector * tau_U, + gsl_vector * tau_V, + gsl_matrix * V) +{ + const size_t M = A->size1; + const size_t N = A->size2; + + const size_t K = GSL_MIN(M, N); + + if (M < N) + { + GSL_ERROR ("matrix A must have M >= N", GSL_EBADLEN); + } + else if (tau_U->size != K) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else if (tau_V->size + 1 != K) + { + GSL_ERROR ("size of tau must be MIN(M,N) - 1", GSL_EBADLEN); + } + else if (V->size1 != N || V->size2 != N) + { + GSL_ERROR ("size of V must be N x N", GSL_EBADLEN); + } + else + { + size_t i, j; + + /* Initialize V to the identity */ + + gsl_matrix_set_identity (V); + + for (i = N - 1; i > 0 && i--;) + { + /* Householder row transformation to accumulate V */ + gsl_vector_const_view r = gsl_matrix_const_row (A, i); + gsl_vector_const_view h = + gsl_vector_const_subvector (&r.vector, i + 1, N - (i+1)); + + double ti = gsl_vector_get (tau_V, i); + + gsl_matrix_view m = + gsl_matrix_submatrix (V, i + 1, i + 1, N-(i+1), N-(i+1)); + + gsl_linalg_householder_hm (ti, &h.vector, &m.matrix); + } + + /* Copy superdiagonal into tau_v */ + + for (i = 0; i < N - 1; i++) + { + double Aij = gsl_matrix_get (A, i, i+1); + gsl_vector_set (tau_V, i, Aij); + } + + /* Allow U to be unpacked into the same memory as A, copy + diagonal into tau_U */ + + for (j = N; j > 0 && j--;) + { + /* Householder column transformation to accumulate U */ + double tj = gsl_vector_get (tau_U, j); + double Ajj = gsl_matrix_get (A, j, j); + gsl_matrix_view m = gsl_matrix_submatrix (A, j, j, M-j, N-j); + + gsl_vector_set (tau_U, j, Ajj); + gsl_linalg_householder_hm1 (tj, &m.matrix); + } + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_bidiag_unpack_B (const gsl_matrix * A, + gsl_vector * diag, + gsl_vector * superdiag) +{ + const size_t M = A->size1; + const size_t N = A->size2; + + const size_t K = GSL_MIN(M, N); + + if (diag->size != K) + { + GSL_ERROR ("size of diagonal must match size of A", GSL_EBADLEN); + } + else if (superdiag->size + 1 != K) + { + GSL_ERROR ("size of subdiagonal must be (matrix size - 1)", GSL_EBADLEN); + } + else + { + size_t i; + + /* Copy diagonal into diag */ + + for (i = 0; i < K; i++) + { + double Aii = gsl_matrix_get (A, i, i); + gsl_vector_set (diag, i, Aii); + } + + /* Copy superdiagonal into superdiag */ + + for (i = 0; i < K - 1; i++) + { + double Aij = gsl_matrix_get (A, i, i+1); + gsl_vector_set (superdiag, i, Aij); + } + + return GSL_SUCCESS; + } +} diff --git a/gsl-1.9/linalg/cholesky.c b/gsl-1.9/linalg/cholesky.c new file mode 100644 index 0000000..671aa96 --- /dev/null +++ b/gsl-1.9/linalg/cholesky.c @@ -0,0 +1,266 @@ +/* Cholesky Decomposition + * + * Copyright (C) 2000 Thomas Walter + * + * 03 May 2000: Modified for GSL by Brian Gough + * 29 Jul 2005: Additions by Gerard Jungman + * Copyright (C) 2000,2001, 2002, 2003, 2005 Brian Gough, Gerard Jungman + * + * This 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 2, or (at your option) any + * later version. + * + * This source 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. + */ + +/* + * Cholesky decomposition of a symmetrix positive definite matrix. + * This is useful to solve the matrix arising in + * periodic cubic splines + * approximating splines + * + * This algorithm does: + * A = L * L' + * with + * L := lower left triangle matrix + * L' := the transposed form of L. + * + */ + +#include <config.h> + +#include <gsl/gsl_math.h> +#include <gsl/gsl_errno.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> +#include <gsl/gsl_linalg.h> + +static inline +double +quiet_sqrt (double x) + /* avoids runtime error, for checking matrix for positive definiteness */ +{ + return (x >= 0) ? sqrt(x) : GSL_NAN; +} + +int +gsl_linalg_cholesky_decomp (gsl_matrix * A) +{ + const size_t M = A->size1; + const size_t N = A->size2; + + if (M != N) + { + GSL_ERROR("cholesky decomposition requires square matrix", GSL_ENOTSQR); + } + else + { + size_t i,j,k; + int status = 0; + + /* Do the first 2 rows explicitly. It is simple, and faster. And + * one can return if the matrix has only 1 or 2 rows. + */ + + double A_00 = gsl_matrix_get (A, 0, 0); + + double L_00 = quiet_sqrt(A_00); + + if (A_00 <= 0) + { + status = GSL_EDOM ; + } + + gsl_matrix_set (A, 0, 0, L_00); + + if (M > 1) + { + double A_10 = gsl_matrix_get (A, 1, 0); + double A_11 = gsl_matrix_get (A, 1, 1); + + double L_10 = A_10 / L_00; + double diag = A_11 - L_10 * L_10; + double L_11 = quiet_sqrt(diag); + + if (diag <= 0) + { + status = GSL_EDOM; + } + + gsl_matrix_set (A, 1, 0, L_10); + gsl_matrix_set (A, 1, 1, L_11); + } + + for (k = 2; k < M; k++) + { + double A_kk = gsl_matrix_get (A, k, k); + + for (i = 0; i < k; i++) + { + double sum = 0; + + double A_ki = gsl_matrix_get (A, k, i); + double A_ii = gsl_matrix_get (A, i, i); + + gsl_vector_view ci = gsl_matrix_row (A, i); + gsl_vector_view ck = gsl_matrix_row (A, k); + + if (i > 0) { + gsl_vector_view di = gsl_vector_subvector(&ci.vector, 0, i); + gsl_vector_view dk = gsl_vector_subvector(&ck.vector, 0, i); + + gsl_blas_ddot (&di.vector, &dk.vector, &sum); + } + + A_ki = (A_ki - sum) / A_ii; + gsl_matrix_set (A, k, i, A_ki); + } + + { + gsl_vector_view ck = gsl_matrix_row (A, k); + gsl_vector_view dk = gsl_vector_subvector (&ck.vector, 0, k); + + double sum = gsl_blas_dnrm2 (&dk.vector); + double diag = A_kk - sum * sum; + + double L_kk = quiet_sqrt(diag); + + if (diag <= 0) + { + status = GSL_EDOM; + } + + gsl_matrix_set (A, k, k, L_kk); + } + } + + /* Now copy the transposed lower triangle to the upper triangle, + * the diagonal is common. + */ + + for (i = 1; i < M; i++) + { + for (j = 0; j < i; j++) + { + double A_ij = gsl_matrix_get (A, i, j); + gsl_matrix_set (A, j, i, A_ij); + } + } + + if (status == GSL_EDOM) + { + GSL_ERROR ("matrix must be positive definite", GSL_EDOM); + } + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_cholesky_solve (const gsl_matrix * LLT, + const gsl_vector * b, + gsl_vector * x) +{ + if (LLT->size1 != LLT->size2) + { + GSL_ERROR ("cholesky matrix must be square", GSL_ENOTSQR); + } + else if (LLT->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (LLT->size2 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_memcpy (x, b); + + /* Solve for c using forward-substitution, L c = b */ + + gsl_blas_dtrsv (CblasLower, CblasNoTrans, CblasNonUnit, LLT, x); + + /* Perform back-substitution, U x = c */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, LLT, x); + + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_cholesky_svx (const gsl_matrix * LLT, + gsl_vector * x) +{ + if (LLT->size1 != LLT->size2) + { + GSL_ERROR ("cholesky matrix must be square", GSL_ENOTSQR); + } + else if (LLT->size2 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Solve for c using forward-substitution, L c = b */ + + gsl_blas_dtrsv (CblasLower, CblasNoTrans, CblasNonUnit, LLT, x); + + /* Perform back-substitution, U x = c */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, LLT, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_cholesky_decomp_unit(gsl_matrix * A, gsl_vector * D) +{ + const size_t N = A->size1; + size_t i, j; + + /* initial Cholesky */ + int stat_chol = gsl_linalg_cholesky_decomp(A); + + if(stat_chol == GSL_SUCCESS) + { + /* calculate D from diagonal part of initial Cholesky */ + for(i = 0; i < N; ++i) + { + const double C_ii = gsl_matrix_get(A, i, i); + gsl_vector_set(D, i, C_ii*C_ii); + } + + /* multiply initial Cholesky by 1/sqrt(D) on the right */ + for(i = 0; i < N; ++i) + { + for(j = 0; j < N; ++j) + { + gsl_matrix_set(A, i, j, gsl_matrix_get(A, i, j) / sqrt(gsl_vector_get(D, j))); + } + } + + /* Because the initial Cholesky contained both L and transpose(L), + the result of the multiplication is not symmetric anymore; + but the lower triangle _is_ correct. Therefore we reflect + it to the upper triangle and declare victory. + */ + for(i = 0; i < N; ++i) + for(j = i + 1; j < N; ++j) + gsl_matrix_set(A, i, j, gsl_matrix_get(A, j, i)); + } + + return stat_chol; +} diff --git a/gsl-1.9/linalg/exponential.c b/gsl-1.9/linalg/exponential.c new file mode 100644 index 0000000..3d0df25 --- /dev/null +++ b/gsl-1.9/linalg/exponential.c @@ -0,0 +1,187 @@ +/* linalg/exponential.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Author: G. Jungman */ + +/* Calculate the matrix exponential, following + * Moler + Van Loan, SIAM Rev. 20, 801 (1978). + */ + +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_mode.h> +#include <gsl/gsl_errno.h> +#include <gsl/gsl_blas.h> + +#include "gsl_linalg.h" + + +/* store one of the suggested choices for the + * Taylor series / square method from Moler + VanLoan + */ +struct moler_vanloan_optimal_suggestion +{ + int k; + int j; +}; +typedef struct moler_vanloan_optimal_suggestion mvl_suggestion_t; + + +/* table from Moler and Van Loan + * mvl_tab[gsl_mode_t][matrix_norm_group] + */ +static mvl_suggestion_t mvl_tab[3][6] = +{ + /* double precision */ + { + { 5, 1 }, { 5, 4 }, { 7, 5 }, { 9, 7 }, { 10, 10 }, { 8, 14 } + }, + + /* single precision */ + { + { 2, 1 }, { 4, 0 }, { 7, 1 }, { 6, 5 }, { 5, 9 }, { 7, 11 } + }, + + /* approx precision */ + { + { 1, 0 }, { 3, 0 }, { 5, 1 }, { 4, 5 }, { 4, 8 }, { 2, 11 } + } +}; + + +inline +static double +sup_norm(const gsl_matrix * A) +{ + double min, max; + gsl_matrix_minmax(A, &min, &max); + return GSL_MAX_DBL(fabs(min), fabs(max)); +} + + +static +mvl_suggestion_t +obtain_suggestion(const gsl_matrix * A, gsl_mode_t mode) +{ + const unsigned int mode_prec = GSL_MODE_PREC(mode); + const double norm_A = sup_norm(A); + if(norm_A < 0.01) return mvl_tab[mode_prec][0]; + else if(norm_A < 0.1) return mvl_tab[mode_prec][1]; + else if(norm_A < 1.0) return mvl_tab[mode_prec][2]; + else if(norm_A < 10.0) return mvl_tab[mode_prec][3]; + else if(norm_A < 100.0) return mvl_tab[mode_prec][4]; + else if(norm_A < 1000.0) return mvl_tab[mode_prec][5]; + else + { + /* outside the table we simply increase the number + * of squarings, bringing the reduced matrix into + * the range of the table; this is obviously suboptimal, + * but that is the price paid for not having those extra + * table entries + */ + const double extra = log(1.01*norm_A/1000.0) / M_LN2; + const int extra_i = (unsigned int) ceil(extra); + mvl_suggestion_t s = mvl_tab[mode][5]; + s.j += extra_i; + return s; + } +} + + +/* use series representation to calculate matrix exponential; + * this is used for small matrices; we use the sup_norm + * to measure the size of the terms in the expansion + */ +static void +matrix_exp_series( + const gsl_matrix * B, + gsl_matrix * eB, + int number_of_terms + ) +{ + int count; + gsl_matrix * temp = gsl_matrix_calloc(B->size1, B->size2); + + /* init the Horner polynomial evaluation, + * eB = 1 + B/number_of_terms; we use + * eB to collect the partial results + */ + gsl_matrix_memcpy(eB, B); + gsl_matrix_scale(eB, 1.0/number_of_terms); + gsl_matrix_add_diagonal(eB, 1.0); + for(count = number_of_terms-1; count >= 1; --count) + { + /* mult_temp = 1 + B eB / count */ + gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, B, eB, 0.0, temp); + gsl_matrix_scale(temp, 1.0/count); + gsl_matrix_add_diagonal(temp, 1.0); + + /* transfer partial result out of temp */ + gsl_matrix_memcpy(eB, temp); + } + + /* now eB holds the full result; we're done */ + gsl_matrix_free(temp); +} + + +int +gsl_linalg_exponential_ss( + const gsl_matrix * A, + gsl_matrix * eA, + gsl_mode_t mode + ) +{ + if(A->size1 != A->size2) + { + GSL_ERROR("cannot exponentiate a non-square matrix", GSL_ENOTSQR); + } + else if(A->size1 != eA->size1 || A->size2 != eA->size2) + { + GSL_ERROR("exponential of matrix must have same dimension as matrix", GSL_EBADLEN); + } + else + { + int i; + const mvl_suggestion_t sugg = obtain_suggestion(A, mode); + const double divisor = exp(M_LN2 * sugg.j); + + gsl_matrix * reduced_A = gsl_matrix_alloc(A->size1, A->size2); + + /* decrease A by the calculated divisor */ + gsl_matrix_memcpy(reduced_A, A); + gsl_matrix_scale(reduced_A, 1.0/divisor); + + /* calculate exp of reduced matrix; store in eA as temp */ + matrix_exp_series(reduced_A, eA, sugg.k); + + /* square repeatedly; use reduced_A for scratch */ + for(i = 0; i < sugg.j; ++i) + { + gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, eA, eA, 0.0, reduced_A); + gsl_matrix_memcpy(eA, reduced_A); + } + + gsl_matrix_free(reduced_A); + + return GSL_SUCCESS; + } +} + diff --git a/gsl-1.9/linalg/givens.c b/gsl-1.9/linalg/givens.c new file mode 100644 index 0000000..c3875d6 --- /dev/null +++ b/gsl-1.9/linalg/givens.c @@ -0,0 +1,46 @@ +/* linalg/givens.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Generate a Givens rotation (cos,sin) which takes v=(x,y) to (|v|,0) + + From Golub and Van Loan, "Matrix Computations", Section 5.1.8 */ + +inline static void +create_givens (const double a, const double b, double *c, double *s) +{ + if (b == 0) + { + *c = 1; + *s = 0; + } + else if (fabs (b) > fabs (a)) + { + double t = -a / b; + double s1 = 1.0 / sqrt (1 + t * t); + *s = s1; + *c = s1 * t; + } + else + { + double t = -b / a; + double c1 = 1.0 / sqrt (1 + t * t); + *c = c1; + *s = c1 * t; + } +} diff --git a/gsl-1.9/linalg/gsl_linalg.h b/gsl-1.9/linalg/gsl_linalg.h new file mode 100644 index 0000000..94103f1 --- /dev/null +++ b/gsl-1.9/linalg/gsl_linalg.h @@ -0,0 +1,560 @@ +/* linalg/gsl_linalg.h + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +#ifndef __GSL_LINALG_H__ +#define __GSL_LINALG_H__ + +#include <gsl/gsl_mode.h> +#include <gsl/gsl_permutation.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> + +#undef __BEGIN_DECLS +#undef __END_DECLS +#ifdef __cplusplus +#define __BEGIN_DECLS extern "C" { +#define __END_DECLS } +#else +#define __BEGIN_DECLS /* empty */ +#define __END_DECLS /* empty */ +#endif + +__BEGIN_DECLS + +typedef enum + { + GSL_LINALG_MOD_NONE = 0, + GSL_LINALG_MOD_TRANSPOSE = 1, + GSL_LINALG_MOD_CONJUGATE = 2 + } +gsl_linalg_matrix_mod_t; + + +/* Note: You can now use the gsl_blas_dgemm function instead of matmult */ + +/* Simple implementation of matrix multiply. + * Calculates C = A.B + * + * exceptions: GSL_EBADLEN + */ +int gsl_linalg_matmult (const gsl_matrix * A, + const gsl_matrix * B, + gsl_matrix * C); + + +/* Simple implementation of matrix multiply. + * Allows transposition of either matrix, so it + * can compute A.B or Trans(A).B or A.Trans(B) or Trans(A).Trans(B) + * + * exceptions: GSL_EBADLEN + */ +int gsl_linalg_matmult_mod (const gsl_matrix * A, + gsl_linalg_matrix_mod_t modA, + const gsl_matrix * B, + gsl_linalg_matrix_mod_t modB, + gsl_matrix * C); + +/* Calculate the matrix exponential by the scaling and + * squaring method described in Moler + Van Loan, + * SIAM Rev 20, 801 (1978). The mode argument allows + * choosing an optimal strategy, from the table + * given in the paper, for a given precision. + * + * exceptions: GSL_ENOTSQR, GSL_EBADLEN + */ +int gsl_linalg_exponential_ss( + const gsl_matrix * A, + gsl_matrix * eA, + gsl_mode_t mode + ); + + +/* Householder Transformations */ + +double gsl_linalg_householder_transform (gsl_vector * v); +gsl_complex gsl_linalg_complex_householder_transform (gsl_vector_complex * v); + +int gsl_linalg_householder_hm (double tau, + const gsl_vector * v, + gsl_matrix * A); + +int gsl_linalg_householder_mh (double tau, + const gsl_vector * v, + gsl_matrix * A); + +int gsl_linalg_householder_hv (double tau, + const gsl_vector * v, + gsl_vector * w); + +int gsl_linalg_householder_hm1 (double tau, + gsl_matrix * A); + +int gsl_linalg_complex_householder_hm (gsl_complex tau, + const gsl_vector_complex * v, + gsl_matrix_complex * A); + +int gsl_linalg_complex_householder_hv (gsl_complex tau, + const gsl_vector_complex * v, + gsl_vector_complex * w); + +/* Hessenberg reduction */ + +int gsl_linalg_hessenberg(gsl_matrix *A, gsl_vector *tau); +int gsl_linalg_hessenberg_unpack(gsl_matrix * H, gsl_vector * tau, + gsl_matrix * U); +int gsl_linalg_hessenberg_unpack_accum(gsl_matrix * H, gsl_vector * tau, + gsl_matrix * U); +void gsl_linalg_hessenberg_set_zero(gsl_matrix * H); +int gsl_linalg_hessenberg_submatrix(gsl_matrix *M, gsl_matrix *A, + size_t top, gsl_vector *tau); + +/* Singular Value Decomposition + + * exceptions: + */ + +int +gsl_linalg_SV_decomp (gsl_matrix * A, + gsl_matrix * V, + gsl_vector * S, + gsl_vector * work); + +int +gsl_linalg_SV_decomp_mod (gsl_matrix * A, + gsl_matrix * X, + gsl_matrix * V, + gsl_vector * S, + gsl_vector * work); + +int gsl_linalg_SV_decomp_jacobi (gsl_matrix * A, + gsl_matrix * Q, + gsl_vector * S); + +int +gsl_linalg_SV_solve (const gsl_matrix * U, + const gsl_matrix * Q, + const gsl_vector * S, + const gsl_vector * b, + gsl_vector * x); + + +/* LU Decomposition, Gaussian elimination with partial pivoting + */ + +int gsl_linalg_LU_decomp (gsl_matrix * A, gsl_permutation * p, int *signum); + +int gsl_linalg_LU_solve (const gsl_matrix * LU, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_LU_svx (const gsl_matrix * LU, + const gsl_permutation * p, + gsl_vector * x); + +int gsl_linalg_LU_refine (const gsl_matrix * A, + const gsl_matrix * LU, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x, + gsl_vector * residual); + +int gsl_linalg_LU_invert (const gsl_matrix * LU, + const gsl_permutation * p, + gsl_matrix * inverse); + +double gsl_linalg_LU_det (gsl_matrix * LU, int signum); +double gsl_linalg_LU_lndet (gsl_matrix * LU); +int gsl_linalg_LU_sgndet (gsl_matrix * lu, int signum); + +/* Complex LU Decomposition */ + +int gsl_linalg_complex_LU_decomp (gsl_matrix_complex * A, + gsl_permutation * p, + int *signum); + +int gsl_linalg_complex_LU_solve (const gsl_matrix_complex * LU, + const gsl_permutation * p, + const gsl_vector_complex * b, + gsl_vector_complex * x); + +int gsl_linalg_complex_LU_svx (const gsl_matrix_complex * LU, + const gsl_permutation * p, + gsl_vector_complex * x); + +int gsl_linalg_complex_LU_refine (const gsl_matrix_complex * A, + const gsl_matrix_complex * LU, + const gsl_permutation * p, + const gsl_vector_complex * b, + gsl_vector_complex * x, + gsl_vector_complex * residual); + +int gsl_linalg_complex_LU_invert (const gsl_matrix_complex * LU, + const gsl_permutation * p, + gsl_matrix_complex * inverse); + +gsl_complex gsl_linalg_complex_LU_det (gsl_matrix_complex * LU, + int signum); + +double gsl_linalg_complex_LU_lndet (gsl_matrix_complex * LU); + +gsl_complex gsl_linalg_complex_LU_sgndet (gsl_matrix_complex * LU, + int signum); + +/* QR decomposition */ + +int gsl_linalg_QR_decomp (gsl_matrix * A, + gsl_vector * tau); + +int gsl_linalg_QR_solve (const gsl_matrix * QR, + const gsl_vector * tau, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_QR_svx (const gsl_matrix * QR, + const gsl_vector * tau, + gsl_vector * x); + +int gsl_linalg_QR_lssolve (const gsl_matrix * QR, + const gsl_vector * tau, + const gsl_vector * b, + gsl_vector * x, + gsl_vector * residual); + + +int gsl_linalg_QR_QRsolve (gsl_matrix * Q, + gsl_matrix * R, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_QR_Rsolve (const gsl_matrix * QR, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_QR_Rsvx (const gsl_matrix * QR, + gsl_vector * x); + +int gsl_linalg_QR_update (gsl_matrix * Q, + gsl_matrix * R, + gsl_vector * w, + const gsl_vector * v); + +int gsl_linalg_QR_QTvec (const gsl_matrix * QR, + const gsl_vector * tau, + gsl_vector * v); + +int gsl_linalg_QR_Qvec (const gsl_matrix * QR, + const gsl_vector * tau, + gsl_vector * v); + +int gsl_linalg_QR_unpack (const gsl_matrix * QR, + const gsl_vector * tau, + gsl_matrix * Q, + gsl_matrix * R); + +int gsl_linalg_R_solve (const gsl_matrix * R, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_R_svx (const gsl_matrix * R, + gsl_vector * x); + + +/* Q R P^T decomposition */ + +int gsl_linalg_QRPT_decomp (gsl_matrix * A, + gsl_vector * tau, + gsl_permutation * p, + int *signum, + gsl_vector * norm); + +int gsl_linalg_QRPT_decomp2 (const gsl_matrix * A, + gsl_matrix * q, gsl_matrix * r, + gsl_vector * tau, + gsl_permutation * p, + int *signum, + gsl_vector * norm); + +int gsl_linalg_QRPT_solve (const gsl_matrix * QR, + const gsl_vector * tau, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x); + + +int gsl_linalg_QRPT_svx (const gsl_matrix * QR, + const gsl_vector * tau, + const gsl_permutation * p, + gsl_vector * x); + +int gsl_linalg_QRPT_QRsolve (const gsl_matrix * Q, + const gsl_matrix * R, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_QRPT_Rsolve (const gsl_matrix * QR, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_QRPT_Rsvx (const gsl_matrix * QR, + const gsl_permutation * p, + gsl_vector * x); + +int gsl_linalg_QRPT_update (gsl_matrix * Q, + gsl_matrix * R, + const gsl_permutation * p, + gsl_vector * u, + const gsl_vector * v); + +/* LQ decomposition */ + +int gsl_linalg_LQ_decomp (gsl_matrix * A, gsl_vector * tau); + +int gsl_linalg_LQ_solve_T (const gsl_matrix * LQ, const gsl_vector * tau, + const gsl_vector * b, gsl_vector * x); + +int gsl_linalg_LQ_svx_T (const gsl_matrix * LQ, const gsl_vector * tau, + gsl_vector * x); + +int gsl_linalg_LQ_lssolve_T (const gsl_matrix * LQ, const gsl_vector * tau, + const gsl_vector * b, gsl_vector * x, + gsl_vector * residual); + +int gsl_linalg_LQ_Lsolve_T (const gsl_matrix * LQ, const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_LQ_Lsvx_T (const gsl_matrix * LQ, gsl_vector * x); + +int gsl_linalg_L_solve_T (const gsl_matrix * L, const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_LQ_vecQ (const gsl_matrix * LQ, const gsl_vector * tau, + gsl_vector * v); + +int gsl_linalg_LQ_vecQT (const gsl_matrix * LQ, const gsl_vector * tau, + gsl_vector * v); + +int gsl_linalg_LQ_unpack (const gsl_matrix * LQ, const gsl_vector * tau, + gsl_matrix * Q, gsl_matrix * L); + +int gsl_linalg_LQ_update (gsl_matrix * Q, gsl_matrix * R, + const gsl_vector * v, gsl_vector * w); +int gsl_linalg_LQ_LQsolve (gsl_matrix * Q, gsl_matrix * L, + const gsl_vector * b, gsl_vector * x); + +/* P^T L Q decomposition */ + +int gsl_linalg_PTLQ_decomp (gsl_matrix * A, gsl_vector * tau, + gsl_permutation * p, int *signum, + gsl_vector * norm); + +int gsl_linalg_PTLQ_decomp2 (const gsl_matrix * A, gsl_matrix * q, + gsl_matrix * r, gsl_vector * tau, + gsl_permutation * p, int *signum, + gsl_vector * norm); + +int gsl_linalg_PTLQ_solve_T (const gsl_matrix * QR, + const gsl_vector * tau, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_PTLQ_svx_T (const gsl_matrix * LQ, + const gsl_vector * tau, + const gsl_permutation * p, + gsl_vector * x); + +int gsl_linalg_PTLQ_LQsolve_T (const gsl_matrix * Q, const gsl_matrix * L, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_PTLQ_Lsolve_T (const gsl_matrix * LQ, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_PTLQ_Lsvx_T (const gsl_matrix * LQ, + const gsl_permutation * p, + gsl_vector * x); + +int gsl_linalg_PTLQ_update (gsl_matrix * Q, gsl_matrix * L, + const gsl_permutation * p, + const gsl_vector * v, gsl_vector * w); + +/* Cholesky Decomposition */ + +int gsl_linalg_cholesky_decomp (gsl_matrix * A); + +int gsl_linalg_cholesky_solve (const gsl_matrix * cholesky, + const gsl_vector * b, + gsl_vector * x); + +int gsl_linalg_cholesky_svx (const gsl_matrix * cholesky, + gsl_vector * x); + + +/* Cholesky decomposition with unit-diagonal triangular parts. + * A = L D L^T, where diag(L) = (1,1,...,1). + * Upon exit, A contains L and L^T as for Cholesky, and + * the diagonal of A is (1,1,...,1). The vector Dis set + * to the diagonal elements of the diagonal matrix D. + */ +int gsl_linalg_cholesky_decomp_unit(gsl_matrix * A, gsl_vector * D); + + +/* Symmetric to symmetric tridiagonal decomposition */ + +int gsl_linalg_symmtd_decomp (gsl_matrix * A, + gsl_vector * tau); + +int gsl_linalg_symmtd_unpack (const gsl_matrix * A, + const gsl_vector * tau, + gsl_matrix * Q, + gsl_vector * diag, + gsl_vector * subdiag); + +int gsl_linalg_symmtd_unpack_T (const gsl_matrix * A, + gsl_vector * diag, + gsl_vector * subdiag); + +/* Hermitian to symmetric tridiagonal decomposition */ + +int gsl_linalg_hermtd_decomp (gsl_matrix_complex * A, + gsl_vector_complex * tau); + +int gsl_linalg_hermtd_unpack (const gsl_matrix_complex * A, + const gsl_vector_complex * tau, + gsl_matrix_complex * Q, + gsl_vector * diag, + gsl_vector * sudiag); + +int gsl_linalg_hermtd_unpack_T (const gsl_matrix_complex * A, + gsl_vector * diag, + gsl_vector * subdiag); + +/* Linear Solve Using Householder Transformations + + * exceptions: + */ + +int gsl_linalg_HH_solve (gsl_matrix * A, const gsl_vector * b, gsl_vector * x); +int gsl_linalg_HH_svx (gsl_matrix * A, gsl_vector * x); + +/* Linear solve for a symmetric tridiagonal system. + + * The input vectors represent the NxN matrix as follows: + * + * diag[0] offdiag[0] 0 ... + * offdiag[0] diag[1] offdiag[1] ... + * 0 offdiag[1] diag[2] ... + * 0 0 offdiag[2] ... + * ... ... ... ... + */ +int gsl_linalg_solve_symm_tridiag (const gsl_vector * diag, + const gsl_vector * offdiag, + const gsl_vector * b, + gsl_vector * x); + +/* Linear solve for a nonsymmetric tridiagonal system. + + * The input vectors represent the NxN matrix as follows: + * + * diag[0] abovediag[0] 0 ... + * belowdiag[0] diag[1] abovediag[1] ... + * 0 belowdiag[1] diag[2] ... + * 0 0 belowdiag[2] ... + * ... ... ... ... + */ +int gsl_linalg_solve_tridiag (const gsl_vector * diag, + const gsl_vector * abovediag, + const gsl_vector * belowdiag, + const gsl_vector * b, + gsl_vector * x); + + +/* Linear solve for a symmetric cyclic tridiagonal system. + + * The input vectors represent the NxN matrix as follows: + * + * diag[0] offdiag[0] 0 ..... offdiag[N-1] + * offdiag[0] diag[1] offdiag[1] ..... + * 0 offdiag[1] diag[2] ..... + * 0 0 offdiag[2] ..... + * ... ... + * offdiag[N-1] ... + */ +int gsl_linalg_solve_symm_cyc_tridiag (const gsl_vector * diag, + const gsl_vector * offdiag, + const gsl_vector * b, + gsl_vector * x); + +/* Linear solve for a nonsymmetric cyclic tridiagonal system. + + * The input vectors represent the NxN matrix as follows: + * + * diag[0] abovediag[0] 0 ..... belowdiag[N-1] + * belowdiag[0] diag[1] abovediag[1] ..... + * 0 belowdiag[1] diag[2] + * 0 0 belowdiag[2] ..... + * ... ... + * abovediag[N-1] ... + */ +int gsl_linalg_solve_cyc_tridiag (const gsl_vector * diag, + const gsl_vector * abovediag, + const gsl_vector * belowdiag, + const gsl_vector * b, + gsl_vector * x); + + +/* Bidiagonal decomposition */ + +int gsl_linalg_bidiag_decomp (gsl_matrix * A, + gsl_vector * tau_U, + gsl_vector * tau_V); + +int gsl_linalg_bidiag_unpack (const gsl_matrix * A, + const gsl_vector * tau_U, + gsl_matrix * U, + const gsl_vector * tau_V, + gsl_matrix * V, + gsl_vector * diag, + gsl_vector * superdiag); + +int gsl_linalg_bidiag_unpack2 (gsl_matrix * A, + gsl_vector * tau_U, + gsl_vector * tau_V, + gsl_matrix * V); + +int gsl_linalg_bidiag_unpack_B (const gsl_matrix * A, + gsl_vector * diag, + gsl_vector * superdiag); + +/* Balancing */ + +int gsl_linalg_balance_matrix (gsl_matrix * A, gsl_vector * D); +int gsl_linalg_balance_accum (gsl_matrix * A, gsl_vector * D); +int gsl_linalg_balance_columns (gsl_matrix * A, gsl_vector * D); + + +__END_DECLS + +#endif /* __GSL_LINALG_H__ */ diff --git a/gsl-1.9/linalg/hermtd.c b/gsl-1.9/linalg/hermtd.c new file mode 100644 index 0000000..30c8cbb --- /dev/null +++ b/gsl-1.9/linalg/hermtd.c @@ -0,0 +1,240 @@ +/* linalg/hermtd.c + * + * Copyright (C) 2001 Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Factorise a hermitian matrix A into + * + * A = U T U' + * + * where U is unitary and T is real symmetric tridiagonal. Only the + * diagonal and lower triangular part of A is referenced and modified. + * + * On exit, T is stored in the diagonal and first subdiagonal of + * A. Since T is symmetric the upper diagonal is not stored. + * + * U is stored as a packed set of Householder transformations in the + * lower triangular part of the input matrix below the first subdiagonal. + * + * The full matrix for Q can be obtained as the product + * + * Q = Q_N ... Q_2 Q_1 + * + * where + * + * Q_i = (I - tau_i * v_i * v_i') + * + * and where v_i is a Householder vector + * + * v_i = [0, ..., 0, 1, A(i+2,i), A(i+3,i), ... , A(N,i)] + * + * This storage scheme is the same as in LAPACK. See LAPACK's + * chetd2.f for details. + * + * See Golub & Van Loan, "Matrix Computations" (3rd ed), Section 8.3 */ + +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> +#include <gsl/gsl_complex_math.h> + +#include <gsl/gsl_linalg.h> + +int +gsl_linalg_hermtd_decomp (gsl_matrix_complex * A, gsl_vector_complex * tau) +{ + if (A->size1 != A->size2) + { + GSL_ERROR ("hermitian tridiagonal decomposition requires square matrix", + GSL_ENOTSQR); + } + else if (tau->size + 1 != A->size1) + { + GSL_ERROR ("size of tau must be (matrix size - 1)", GSL_EBADLEN); + } + else + { + const size_t N = A->size1; + size_t i; + + const gsl_complex zero = gsl_complex_rect (0.0, 0.0); + const gsl_complex one = gsl_complex_rect (1.0, 0.0); + const gsl_complex neg_one = gsl_complex_rect (-1.0, 0.0); + + for (i = 0 ; i < N - 1; i++) + { + gsl_vector_complex_view c = gsl_matrix_complex_column (A, i); + gsl_vector_complex_view v = gsl_vector_complex_subvector (&c.vector, i + 1, N - (i + 1)); + gsl_complex tau_i = gsl_linalg_complex_householder_transform (&v.vector); + + /* Apply the transformation H^T A H to the remaining columns */ + + if ((i + 1) < (N - 1) + && !(GSL_REAL(tau_i) == 0.0 && GSL_IMAG(tau_i) == 0.0)) + { + gsl_matrix_complex_view m = + gsl_matrix_complex_submatrix (A, i + 1, i + 1, + N - (i+1), N - (i+1)); + gsl_complex ei = gsl_vector_complex_get(&v.vector, 0); + gsl_vector_complex_view x = gsl_vector_complex_subvector (tau, i, N-(i+1)); + gsl_vector_complex_set (&v.vector, 0, one); + + /* x = tau * A * v */ + gsl_blas_zhemv (CblasLower, tau_i, &m.matrix, &v.vector, zero, &x.vector); + + /* w = x - (1/2) tau * (x' * v) * v */ + { + gsl_complex xv, txv, alpha; + gsl_blas_zdotc(&x.vector, &v.vector, &xv); + txv = gsl_complex_mul(tau_i, xv); + alpha = gsl_complex_mul_real(txv, -0.5); + gsl_blas_zaxpy(alpha, &v.vector, &x.vector); + } + + /* apply the transformation A = A - v w' - w v' */ + gsl_blas_zher2(CblasLower, neg_one, &v.vector, &x.vector, &m.matrix); + + gsl_vector_complex_set (&v.vector, 0, ei); + } + + gsl_vector_complex_set (tau, i, tau_i); + } + + return GSL_SUCCESS; + } +} + + +/* Form the orthogonal matrix Q from the packed QR matrix */ + +int +gsl_linalg_hermtd_unpack (const gsl_matrix_complex * A, + const gsl_vector_complex * tau, + gsl_matrix_complex * Q, + gsl_vector * diag, + gsl_vector * sdiag) +{ + if (A->size1 != A->size2) + { + GSL_ERROR ("matrix A must be sqaure", GSL_ENOTSQR); + } + else if (tau->size + 1 != A->size1) + { + GSL_ERROR ("size of tau must be (matrix size - 1)", GSL_EBADLEN); + } + else if (Q->size1 != A->size1 || Q->size2 != A->size1) + { + GSL_ERROR ("size of Q must match size of A", GSL_EBADLEN); + } + else if (diag->size != A->size1) + { + GSL_ERROR ("size of diagonal must match size of A", GSL_EBADLEN); + } + else if (sdiag->size + 1 != A->size1) + { + GSL_ERROR ("size of subdiagonal must be (matrix size - 1)", GSL_EBADLEN); + } + else + { + const size_t N = A->size1; + + size_t i; + + /* Initialize Q to the identity */ + + gsl_matrix_complex_set_identity (Q); + + for (i = N - 1; i > 0 && i--;) + { + gsl_complex ti = gsl_vector_complex_get (tau, i); + + gsl_vector_complex_const_view c = gsl_matrix_complex_const_column (A, i); + + gsl_vector_complex_const_view h = + gsl_vector_complex_const_subvector (&c.vector, i + 1, N - (i+1)); + + gsl_matrix_complex_view m = + gsl_matrix_complex_submatrix (Q, i + 1, i + 1, N-(i+1), N-(i+1)); + + gsl_linalg_complex_householder_hm (ti, &h.vector, &m.matrix); + } + + /* Copy diagonal into diag */ + + for (i = 0; i < N; i++) + { + gsl_complex Aii = gsl_matrix_complex_get (A, i, i); + gsl_vector_set (diag, i, GSL_REAL(Aii)); + } + + /* Copy subdiagonal into sdiag */ + + for (i = 0; i < N - 1; i++) + { + gsl_complex Aji = gsl_matrix_complex_get (A, i+1, i); + gsl_vector_set (sdiag, i, GSL_REAL(Aji)); + } + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_hermtd_unpack_T (const gsl_matrix_complex * A, + gsl_vector * diag, + gsl_vector * sdiag) +{ + if (A->size1 != A->size2) + { + GSL_ERROR ("matrix A must be sqaure", GSL_ENOTSQR); + } + else if (diag->size != A->size1) + { + GSL_ERROR ("size of diagonal must match size of A", GSL_EBADLEN); + } + else if (sdiag->size + 1 != A->size1) + { + GSL_ERROR ("size of subdiagonal must be (matrix size - 1)", GSL_EBADLEN); + } + else + { + const size_t N = A->size1; + + size_t i; + + /* Copy diagonal into diag */ + + for (i = 0; i < N; i++) + { + gsl_complex Aii = gsl_matrix_complex_get (A, i, i); + gsl_vector_set (diag, i, GSL_REAL(Aii)); + } + + /* Copy subdiagonal into sd */ + + for (i = 0; i < N - 1; i++) + { + gsl_complex Aji = gsl_matrix_complex_get (A, i+1, i); + gsl_vector_set (sdiag, i, GSL_REAL(Aji)); + } + + return GSL_SUCCESS; + } +} diff --git a/gsl-1.9/linalg/hessenberg.c b/gsl-1.9/linalg/hessenberg.c new file mode 100644 index 0000000..de9a47a --- /dev/null +++ b/gsl-1.9/linalg/hessenberg.c @@ -0,0 +1,430 @@ +/* linalg/hessenberg.c + * + * Copyright (C) 2006 Patrick Alken + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +#include <config.h> +#include <gsl/gsl_linalg.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_vector.h> + +/* +gsl_linalg_hessenberg() + Compute the Householder reduction to Hessenberg form of a +square N-by-N matrix A. + +H = U^t A U + +See Golub & Van Loan, "Matrix Computations" (3rd ed), algorithm +7.4.2 + +Inputs: A - matrix to reduce + tau - where to store scalar factors in Householder + matrices; this vector must be of length N, + where N is the order of A + +Return: GSL_SUCCESS unless error occurs + +Notes: on output, the upper triangular portion of A (including +the diagaonal and subdiagonal) contains the Hessenberg matrix. +The lower triangular portion (below the subdiagonal) contains +the Householder vectors which can be used to construct +the similarity transform matrix U. + +The matrix U is + +U = U(1) U(2) ... U(n - 2) + +where + +U(i) = I - tau(i) * v(i) * v(i)^t + +and the vector v(i) is stored in column i of the matrix A +underneath the subdiagonal. So the first element of v(i) +is stored in row i + 2, column i, the second element at +row i + 3, column i, and so on. + +Also note that for the purposes of computing U(i), +v(1:i) = 0, v(i + 1) = 1, and v(i+2:n) is what is stored in +column i of A beneath the subdiagonal. +*/ + +int +gsl_linalg_hessenberg(gsl_matrix *A, gsl_vector *tau) +{ + const size_t N = A->size1; + + if (N != A->size2) + { + GSL_ERROR ("Hessenberg reduction requires square matrix", + GSL_ENOTSQR); + } + else if (N != tau->size) + { + GSL_ERROR ("tau vector must match matrix size", GSL_EBADLEN); + } + else if (N < 3) + { + /* nothing to do */ + return GSL_SUCCESS; + } + else + { + size_t i; /* looping */ + gsl_vector_view c, /* matrix column */ + hv; /* householder vector */ + gsl_matrix_view m; + double tau_i; /* beta in algorithm 7.4.2 */ + + for (i = 0; i < N - 2; ++i) + { + /* + * make a copy of A(i + 1:n, i) and store it in the section + * of 'tau' that we haven't stored coefficients in yet + */ + + c = gsl_matrix_column(A, i); + c = gsl_vector_subvector(&c.vector, i + 1, N - (i + 1)); + + hv = gsl_vector_subvector(tau, i + 1, N - (i + 1)); + gsl_vector_memcpy(&hv.vector, &c.vector); + + /* compute householder transformation of A(i+1:n,i) */ + tau_i = gsl_linalg_householder_transform(&hv.vector); + + /* apply left householder matrix (I - tau_i v v') to A */ + m = gsl_matrix_submatrix(A, i + 1, i, N - (i + 1), N - i); + gsl_linalg_householder_hm(tau_i, &hv.vector, &m.matrix); + + /* apply right householder matrix (I - tau_i v v') to A */ + m = gsl_matrix_submatrix(A, 0, i + 1, N, N - (i + 1)); + gsl_linalg_householder_mh(tau_i, &hv.vector, &m.matrix); + + /* save Householder coefficient */ + gsl_vector_set(tau, i, tau_i); + + /* + * store Householder vector below the subdiagonal in column + * i of the matrix. hv(1) does not need to be stored since + * it is always 1. + */ + c = gsl_vector_subvector(&c.vector, 1, c.vector.size - 1); + hv = gsl_vector_subvector(&hv.vector, 1, hv.vector.size - 1); + gsl_vector_memcpy(&c.vector, &hv.vector); + } + + return GSL_SUCCESS; + } +} /* gsl_linalg_hessenberg() */ + +/* +gsl_linalg_hessenberg_unpack() + Construct the matrix U which transforms a matrix A into +its upper Hessenberg form: + +H = U^t A U + +by unpacking the information stored in H from gsl_linalg_hessenberg(). + +U is a product of Householder matrices: + +U = U(1) U(2) ... U(n - 2) + +where + +U(i) = I - tau(i) * v(i) * v(i)^t + +The v(i) are stored in the lower triangular part of H by +gsl_linalg_hessenberg(). The tau(i) are stored in the vector tau. + +Inputs: H - Hessenberg matrix computed from + gsl_linalg_hessenberg() + tau - tau vector computed from gsl_linalg_hessenberg() + U - (output) where to store similarity matrix + +Return: success or error +*/ + +int +gsl_linalg_hessenberg_unpack(gsl_matrix * H, gsl_vector * tau, + gsl_matrix * U) +{ + int s; + + gsl_matrix_set_identity(U); + + s = gsl_linalg_hessenberg_unpack_accum(H, tau, U); + + return s; +} /* gsl_linalg_hessenberg_unpack() */ + +/* +gsl_linalg_hessenberg_unpack_accum() + This routine is the same as gsl_linalg_hessenberg_unpack(), except +instead of storing the similarity matrix in U, it accumulates it, +so that + +U -> U * [ U(1) U(2) ... U(n - 2) ] + +instead of: + +U -> U(1) U(2) ... U(n - 2) + +Inputs: H - Hessenberg matrix computed from + gsl_linalg_hessenberg() + tau - tau vector computed from gsl_linalg_hessenberg() + V - (input/output) where to accumulate similarity matrix + +Return: success or error + +Notes: 1) On input, V needs to be initialized. The Householder matrices + are accumulated into V, so on output, + + V_out = V_in * U(1) * U(2) * ... * U(n - 2) + + so if you just want the product of the Householder matrices, + initialize V to the identity matrix before calling this + function. + + 2) V does not have to be square, but must have the same + number of columns as the order of H +*/ + +int +gsl_linalg_hessenberg_unpack_accum(gsl_matrix * H, gsl_vector * tau, + gsl_matrix * V) +{ + const size_t N = H->size1; + + if (N != H->size2) + { + GSL_ERROR ("Hessenberg reduction requires square matrix", + GSL_ENOTSQR); + } + else if (N != tau->size) + { + GSL_ERROR ("tau vector must match matrix size", GSL_EBADLEN); + } + else if (N != V->size2) + { + GSL_ERROR ("V matrix has wrong dimension", GSL_EBADLEN); + } + else + { + size_t j; /* looping */ + double tau_j; /* householder coefficient */ + gsl_vector_view c, /* matrix column */ + hv; /* householder vector */ + gsl_matrix_view m; + + if (N < 3) + { + /* nothing to do */ + return GSL_SUCCESS; + } + + for (j = 0; j < (N - 2); ++j) + { + c = gsl_matrix_column(H, j); + + tau_j = gsl_vector_get(tau, j); + + /* + * get a view to the householder vector in column j, but + * make sure hv(2) starts at the element below the + * subdiagonal, since hv(1) was never stored and is always + * 1 + */ + hv = gsl_vector_subvector(&c.vector, j + 1, N - (j + 1)); + + /* + * Only operate on part of the matrix since the first + * j + 1 entries of the real householder vector are 0 + * + * V -> V * U(j) + * + * Note here that V->size1 is not necessarily equal to N + */ + m = gsl_matrix_submatrix(V, 0, j + 1, V->size1, N - (j + 1)); + + /* apply right Householder matrix to V */ + gsl_linalg_householder_mh(tau_j, &hv.vector, &m.matrix); + } + + return GSL_SUCCESS; + } +} /* gsl_linalg_hessenberg_unpack_accum() */ + +/* +gsl_linalg_hessenberg_set_zero() + Zero out the lower triangular portion of the Hessenberg matrix H. +This is useful when Householder vectors may be stored in the lower +part of H, but eigenvalue solvers need some scratch space with zeros. +*/ + +void +gsl_linalg_hessenberg_set_zero(gsl_matrix * H) +{ + const int N = (int) H->size1; + int i, j; + + for (j = 0; j < N - 2; ++j) + { + for (i = j + 2; i < N; ++i) + { + gsl_matrix_set(H, i, j, 0.0); + } + } +} /* gsl_linalg_hessenberg_set_zero() */ + +/* +gsl_linalg_hessenberg_submatrix() + + This routine does the same thing as gsl_linalg_hessenberg(), +except that it operates on a submatrix of a larger matrix, but +updates the larger matrix with the Householder transformations. + +For example, suppose + +M = [ M_{11} | M_{12} | M_{13} ] + [ 0 | A | M_{23} ] + [ 0 | 0 | M_{33} ] + +where M_{11} and M_{33} are already in Hessenberg form, and we +just want to reduce A to Hessenberg form. Applying the transformations +to A alone will cause the larger matrix M to lose its similarity +information. So this routine updates M_{12} and M_{23} as A gets +reduced. + +Inputs: M - total matrix + A - (sub)matrix to reduce + top - row index of top of A in M + tau - where to store scalar factors in Householder + matrices; this vector must be of length N, + where N is the order of A + +Return: GSL_SUCCESS unless error occurs + +Notes: on output, the upper triangular portion of A (including +the diagaonal and subdiagonal) contains the Hessenberg matrix. +The lower triangular portion (below the subdiagonal) contains +the Householder vectors which can be used to construct +the similarity transform matrix U. + +The matrix U is + +U = U(1) U(2) ... U(n - 2) + +where + +U(i) = I - tau(i) * v(i) * v(i)^t + +and the vector v(i) is stored in column i of the matrix A +underneath the subdiagonal. So the first element of v(i) +is stored in row i + 2, column i, the second element at +row i + 3, column i, and so on. + +Also note that for the purposes of computing U(i), +v(1:i) = 0, v(i + 1) = 1, and v(i+2:n) is what is stored in +column i of A beneath the subdiagonal. +*/ + +int +gsl_linalg_hessenberg_submatrix(gsl_matrix *M, gsl_matrix *A, size_t top, + gsl_vector *tau) +{ + const size_t N = A->size1; + const size_t N_M = M->size1; + + if (N != A->size2) + { + GSL_ERROR ("Hessenberg reduction requires square matrix", + GSL_ENOTSQR); + } + else if (N != tau->size) + { + GSL_ERROR ("tau vector must match matrix size", GSL_EBADLEN); + } + else if (N < 3) + { + /* nothing to do */ + return GSL_SUCCESS; + } + else + { + size_t i; /* looping */ + gsl_vector_view c, /* matrix column */ + hv; /* householder vector */ + gsl_matrix_view m; + double tau_i; /* beta in algorithm 7.4.2 */ + + for (i = 0; i < N - 2; ++i) + { + /* + * make a copy of A(i + 1:n, i) and store it in the section + * of 'tau' that we haven't stored coefficients in yet + */ + + c = gsl_matrix_column(A, i); + c = gsl_vector_subvector(&c.vector, i + 1, N - (i + 1)); + + hv = gsl_vector_subvector(tau, i + 1, N - (i + 1)); + gsl_vector_memcpy(&hv.vector, &c.vector); + + /* compute householder transformation of A(i+1:n,i) */ + tau_i = gsl_linalg_householder_transform(&hv.vector); + + /* + * apply left householder matrix (I - tau_i v v') to + * [ A | M_{23} ] + */ + m = gsl_matrix_submatrix(M, + top + i + 1, + top + i, + N - (i + 1), + N_M - top - i); + gsl_linalg_householder_hm(tau_i, &hv.vector, &m.matrix); + + /* + * apply right householder matrix (I - tau_i v v') to + * + * [ M_{12} ] + * [ A ] + */ + m = gsl_matrix_submatrix(M, + 0, + top + i + 1, + top + N, + N - (i + 1)); + gsl_linalg_householder_mh(tau_i, &hv.vector, &m.matrix); + + /* save Householder coefficient */ + gsl_vector_set(tau, i, tau_i); + + /* + * store Householder vector below the subdiagonal in column + * i of the matrix. hv(1) does not need to be stored since + * it is always 1. + */ + c = gsl_vector_subvector(&c.vector, 1, c.vector.size - 1); + hv = gsl_vector_subvector(&hv.vector, 1, hv.vector.size - 1); + gsl_vector_memcpy(&c.vector, &hv.vector); + } + + return GSL_SUCCESS; + } +} /* gsl_linalg_hessenberg_submatrix() */ diff --git a/gsl-1.9/linalg/hh.c b/gsl-1.9/linalg/hh.c new file mode 100644 index 0000000..6530c96 --- /dev/null +++ b/gsl-1.9/linalg/hh.c @@ -0,0 +1,179 @@ +/* linalg/hh.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Author: G. Jungman */ + +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_linalg.h> + +#define REAL double + +/* [Engeln-Mullges + Uhlig, Alg. 4.42] + */ + +int +gsl_linalg_HH_solve (gsl_matrix * A, const gsl_vector * b, gsl_vector * x) +{ + if (A->size1 > A->size2) + { + /* System is underdetermined. */ + + GSL_ERROR ("System is underdetermined", GSL_EINVAL); + } + else if (A->size2 != x->size) + { + GSL_ERROR ("matrix and vector sizes must be equal", GSL_EBADLEN); + } + else + { + int status ; + + gsl_vector_memcpy (x, b); + + status = gsl_linalg_HH_svx (A, x); + + return status ; + } +} + +int +gsl_linalg_HH_svx (gsl_matrix * A, gsl_vector * x) +{ + if (A->size1 > A->size2) + { + /* System is underdetermined. */ + + GSL_ERROR ("System is underdetermined", GSL_EINVAL); + } + else if (A->size2 != x->size) + { + GSL_ERROR ("matrix and vector sizes must be equal", GSL_EBADLEN); + } + else + { + const size_t N = A->size1; + const size_t M = A->size2; + size_t i, j, k; + REAL *d = (REAL *) malloc (N * sizeof (REAL)); + + if (d == 0) + { + GSL_ERROR ("could not allocate memory for workspace", GSL_ENOMEM); + } + + /* Perform Householder transformation. */ + + for (i = 0; i < N; i++) + { + const REAL aii = gsl_matrix_get (A, i, i); + REAL alpha; + REAL f; + REAL ak; + REAL max_norm = 0.0; + REAL r = 0.0; + + for (k = i; k < M; k++) + { + REAL aki = gsl_matrix_get (A, k, i); + r += aki * aki; + } + + if (r == 0.0) + { + /* Rank of matrix is less than size1. */ + free (d); + GSL_ERROR ("matrix is rank deficient", GSL_ESING); + } + + alpha = sqrt (r) * GSL_SIGN (aii); + + ak = 1.0 / (r + alpha * aii); + gsl_matrix_set (A, i, i, aii + alpha); + + d[i] = -alpha; + + for (k = i + 1; k < N; k++) + { + REAL norm = 0.0; + f = 0.0; + for (j = i; j < M; j++) + { + REAL ajk = gsl_matrix_get (A, j, k); + REAL aji = gsl_matrix_get (A, j, i); + norm += ajk * ajk; + f += ajk * aji; + } + max_norm = GSL_MAX (max_norm, norm); + + f *= ak; + + for (j = i; j < M; j++) + { + REAL ajk = gsl_matrix_get (A, j, k); + REAL aji = gsl_matrix_get (A, j, i); + gsl_matrix_set (A, j, k, ajk - f * aji); + } + } + + if (fabs (alpha) < 2.0 * GSL_DBL_EPSILON * sqrt (max_norm)) + { + /* Apparent singularity. */ + free (d); + GSL_ERROR("apparent singularity detected", GSL_ESING); + } + + /* Perform update of RHS. */ + + f = 0.0; + for (j = i; j < M; j++) + { + f += gsl_vector_get (x, j) * gsl_matrix_get (A, j, i); + } + f *= ak; + for (j = i; j < M; j++) + { + REAL xj = gsl_vector_get (x, j); + REAL aji = gsl_matrix_get (A, j, i); + gsl_vector_set (x, j, xj - f * aji); + } + } + + /* Perform back-substitution. */ + + for (i = N; i > 0 && i--;) + { + REAL xi = gsl_vector_get (x, i); + REAL sum = 0.0; + for (k = i + 1; k < N; k++) + { + sum += gsl_matrix_get (A, i, k) * gsl_vector_get (x, k); + } + + gsl_vector_set (x, i, (xi - sum) / d[i]); + } + + free (d); + return GSL_SUCCESS; + } +} + diff --git a/gsl-1.9/linalg/householder.c b/gsl-1.9/linalg/householder.c new file mode 100644 index 0000000..d9ab952 --- /dev/null +++ b/gsl-1.9/linalg/householder.c @@ -0,0 +1,326 @@ +/* linalg/householder.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2004 Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> + +#include <gsl/gsl_linalg.h> + +double +gsl_linalg_householder_transform (gsl_vector * v) +{ + /* replace v[0:n-1] with a householder vector (v[0:n-1]) and + coefficient tau that annihilate v[1:n-1] */ + + const size_t n = v->size ; + + if (n == 1) + { + return 0.0; /* tau = 0 */ + } + else + { + double alpha, beta, tau ; + + gsl_vector_view x = gsl_vector_subvector (v, 1, n - 1) ; + + double xnorm = gsl_blas_dnrm2 (&x.vector); + + if (xnorm == 0) + { + return 0.0; /* tau = 0 */ + } + + alpha = gsl_vector_get (v, 0) ; + beta = - (alpha >= 0.0 ? +1.0 : -1.0) * hypot(alpha, xnorm) ; + tau = (beta - alpha) / beta ; + + gsl_blas_dscal (1.0 / (alpha - beta), &x.vector); + gsl_vector_set (v, 0, beta) ; + + return tau; + } +} + +int +gsl_linalg_householder_hm (double tau, const gsl_vector * v, gsl_matrix * A) +{ + /* applies a householder transformation v,tau to matrix m */ + + if (tau == 0.0) + { + return GSL_SUCCESS; + } + +#ifdef USE_BLAS + { + gsl_vector_const_view v1 = gsl_vector_const_subvector (v, 1, v->size - 1); + gsl_matrix_view A1 = gsl_matrix_submatrix (A, 1, 0, A->size1 - 1, A->size2); + size_t j; + + for (j = 0; j < A->size2; j++) + { + double wj = 0.0; + gsl_vector_view A1j = gsl_matrix_column(&A1.matrix, j); + gsl_blas_ddot (&A1j.vector, &v1.vector, &wj); + wj += gsl_matrix_get(A,0,j); + + { + double A0j = gsl_matrix_get (A, 0, j); + gsl_matrix_set (A, 0, j, A0j - tau * wj); + } + + gsl_blas_daxpy (-tau * wj, &v1.vector, &A1j.vector); + } + } +#else + { + size_t i, j; + + for (j = 0; j < A->size2; j++) + { + /* Compute wj = Akj vk */ + + double wj = gsl_matrix_get(A,0,j); + + for (i = 1; i < A->size1; i++) /* note, computed for v(0) = 1 above */ + { + wj += gsl_matrix_get(A,i,j) * gsl_vector_get(v,i); + } + + /* Aij = Aij - tau vi wj */ + + /* i = 0 */ + { + double A0j = gsl_matrix_get (A, 0, j); + gsl_matrix_set (A, 0, j, A0j - tau * wj); + } + + /* i = 1 .. M-1 */ + + for (i = 1; i < A->size1; i++) + { + double Aij = gsl_matrix_get (A, i, j); + double vi = gsl_vector_get (v, i); + gsl_matrix_set (A, i, j, Aij - tau * vi * wj); + } + } + } +#endif + + return GSL_SUCCESS; +} + +int +gsl_linalg_householder_mh (double tau, const gsl_vector * v, gsl_matrix * A) +{ + /* applies a householder transformation v,tau to matrix m from the + right hand side in order to zero out rows */ + + if (tau == 0) + return GSL_SUCCESS; + + /* A = A - tau w v' */ + +#ifdef USE_BLAS + { + gsl_vector_const_view v1 = gsl_vector_const_subvector (v, 1, v->size - 1); + gsl_matrix_view A1 = gsl_matrix_submatrix (A, 0, 1, A->size1, A->size2-1); + size_t i; + + for (i = 0; i < A->size1; i++) + { + double wi = 0.0; + gsl_vector_view A1i = gsl_matrix_row(&A1.matrix, i); + gsl_blas_ddot (&A1i.vector, &v1.vector, &wi); + wi += gsl_matrix_get(A,i,0); + + { + double Ai0 = gsl_matrix_get (A, i, 0); + gsl_matrix_set (A, i, 0, Ai0 - tau * wi); + } + + gsl_blas_daxpy(-tau * wi, &v1.vector, &A1i.vector); + } + } +#else + { + size_t i, j; + + for (i = 0; i < A->size1; i++) + { + double wi = gsl_matrix_get(A,i,0); + + for (j = 1; j < A->size2; j++) /* note, computed for v(0) = 1 above */ + { + wi += gsl_matrix_get(A,i,j) * gsl_vector_get(v,j); + } + + /* j = 0 */ + + { + double Ai0 = gsl_matrix_get (A, i, 0); + gsl_matrix_set (A, i, 0, Ai0 - tau * wi); + } + + /* j = 1 .. N-1 */ + + for (j = 1; j < A->size2; j++) + { + double vj = gsl_vector_get (v, j); + double Aij = gsl_matrix_get (A, i, j); + gsl_matrix_set (A, i, j, Aij - tau * wi * vj); + } + } + } +#endif + + return GSL_SUCCESS; +} + +int +gsl_linalg_householder_hv (double tau, const gsl_vector * v, gsl_vector * w) +{ + /* applies a householder transformation v to vector w */ + const size_t N = v->size; + + if (tau == 0) + return GSL_SUCCESS ; + + { + /* compute d = v'w */ + + double d0 = gsl_vector_get(w,0); + double d1, d; + + gsl_vector_const_view v1 = gsl_vector_const_subvector(v, 1, N-1); + gsl_vector_view w1 = gsl_vector_subvector(w, 1, N-1); + + gsl_blas_ddot (&v1.vector, &w1.vector, &d1); + + d = d0 + d1; + + /* compute w = w - tau (v) (v'w) */ + + { + double w0 = gsl_vector_get (w,0); + gsl_vector_set (w, 0, w0 - tau * d); + } + + gsl_blas_daxpy (-tau * d, &v1.vector, &w1.vector); + } + + return GSL_SUCCESS; +} + + +int +gsl_linalg_householder_hm1 (double tau, gsl_matrix * A) +{ + /* applies a householder transformation v,tau to a matrix being + build up from the identity matrix, using the first column of A as + a householder vector */ + + if (tau == 0) + { + size_t i,j; + + gsl_matrix_set (A, 0, 0, 1.0); + + for (j = 1; j < A->size2; j++) + { + gsl_matrix_set (A, 0, j, 0.0); + } + + for (i = 1; i < A->size1; i++) + { + gsl_matrix_set (A, i, 0, 0.0); + } + + return GSL_SUCCESS; + } + + /* w = A' v */ + +#ifdef USE_BLAS + { + gsl_matrix_view A1 = gsl_matrix_submatrix (A, 1, 0, A->size1 - 1, A->size2); + gsl_vector_view v1 = gsl_matrix_column (&A1.matrix, 0); + size_t j; + + for (j = 1; j < A->size2; j++) + { + double wj = 0.0; /* A0j * v0 */ + + gsl_vector_view A1j = gsl_matrix_column(&A1.matrix, j); + gsl_blas_ddot (&A1j.vector, &v1.vector, &wj); + + /* A = A - tau v w' */ + + gsl_matrix_set (A, 0, j, - tau * wj); + + gsl_blas_daxpy(-tau*wj, &v1.vector, &A1j.vector); + } + + gsl_blas_dscal(-tau, &v1.vector); + + gsl_matrix_set (A, 0, 0, 1.0 - tau); + } +#else + { + size_t i, j; + + for (j = 1; j < A->size2; j++) + { + double wj = 0.0; /* A0j * v0 */ + + for (i = 1; i < A->size1; i++) + { + double vi = gsl_matrix_get(A, i, 0); + wj += gsl_matrix_get(A,i,j) * vi; + } + + /* A = A - tau v w' */ + + gsl_matrix_set (A, 0, j, - tau * wj); + + for (i = 1; i < A->size1; i++) + { + double vi = gsl_matrix_get (A, i, 0); + double Aij = gsl_matrix_get (A, i, j); + gsl_matrix_set (A, i, j, Aij - tau * vi * wj); + } + } + + for (i = 1; i < A->size1; i++) + { + double vi = gsl_matrix_get(A, i, 0); + gsl_matrix_set(A, i, 0, -tau * vi); + } + + gsl_matrix_set (A, 0, 0, 1.0 - tau); + } +#endif + + return GSL_SUCCESS; +} diff --git a/gsl-1.9/linalg/householdercomplex.c b/gsl-1.9/linalg/householdercomplex.c new file mode 100644 index 0000000..bc182a6 --- /dev/null +++ b/gsl-1.9/linalg/householdercomplex.c @@ -0,0 +1,207 @@ +/* linalg/householdercomplex.c + * + * Copyright (C) 2001 Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Computes a householder transformation matrix H such that + * + * H' v = -/+ |v| e_1 + * + * where e_1 is the first unit vector. On exit the matrix H can be + * computed from the return values (tau, v) + * + * H = I - tau * w * w' + * + * where w = (1, v(2), ..., v(N)). The nonzero element of the result + * vector -/+|v| e_1 is stored in v(1). + * + * Note that the matrix H' in the householder transformation is the + * hermitian conjugate of H. To compute H'v, pass the conjugate of + * tau as the first argument to gsl_linalg_householder_hm() rather + * than tau itself. See the LAPACK function CLARFG for details of this + * convention. */ + +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> +#include <gsl/gsl_complex_math.h> + +#include <gsl/gsl_linalg.h> + +gsl_complex +gsl_linalg_complex_householder_transform (gsl_vector_complex * v) +{ + /* replace v[0:n-1] with a householder vector (v[0:n-1]) and + coefficient tau that annihilate v[1:n-1] */ + + const size_t n = v->size ; + + if (n == 1) + { + gsl_complex alpha = gsl_vector_complex_get (v, 0) ; + double absa = gsl_complex_abs (alpha); + double beta_r = - (GSL_REAL(alpha) >= 0 ? +1 : -1) * absa ; + + gsl_complex tau; + + if (beta_r == 0.0) + { + GSL_REAL(tau) = 0.0; + GSL_IMAG(tau) = 0.0; + } + else + { + GSL_REAL(tau) = (beta_r - GSL_REAL(alpha)) / beta_r ; + GSL_IMAG(tau) = - GSL_IMAG(alpha) / beta_r ; + + { + gsl_complex beta = gsl_complex_rect (beta_r, 0.0); + gsl_vector_complex_set (v, 0, beta) ; + } + } + + return tau; + } + else + { + gsl_complex tau ; + double beta_r; + + gsl_vector_complex_view x = gsl_vector_complex_subvector (v, 1, n - 1) ; + gsl_complex alpha = gsl_vector_complex_get (v, 0) ; + double absa = gsl_complex_abs (alpha); + double xnorm = gsl_blas_dznrm2 (&x.vector); + + if (xnorm == 0 && GSL_IMAG(alpha) == 0) + { + gsl_complex zero = gsl_complex_rect(0.0, 0.0); + return zero; /* tau = 0 */ + } + + beta_r = - (GSL_REAL(alpha) >= 0 ? +1 : -1) * hypot(absa, xnorm) ; + + GSL_REAL(tau) = (beta_r - GSL_REAL(alpha)) / beta_r ; + GSL_IMAG(tau) = - GSL_IMAG(alpha) / beta_r ; + + { + gsl_complex amb = gsl_complex_sub_real(alpha, beta_r); + gsl_complex s = gsl_complex_inverse(amb); + gsl_blas_zscal (s, &x.vector); + } + + { + gsl_complex beta = gsl_complex_rect (beta_r, 0.0); + gsl_vector_complex_set (v, 0, beta) ; + } + + return tau; + } +} + +int +gsl_linalg_complex_householder_hm (gsl_complex tau, const gsl_vector_complex * v, gsl_matrix_complex * A) +{ + /* applies a householder transformation v,tau to matrix m */ + + size_t i, j; + + if (GSL_REAL(tau) == 0.0 && GSL_IMAG(tau) == 0.0) + { + return GSL_SUCCESS; + } + + /* w = (v' A)^T */ + + for (j = 0; j < A->size2; j++) + { + gsl_complex tauwj; + gsl_complex wj = gsl_matrix_complex_get(A,0,j); + + for (i = 1; i < A->size1; i++) /* note, computed for v(0) = 1 above */ + { + gsl_complex Aij = gsl_matrix_complex_get(A,i,j); + gsl_complex vi = gsl_vector_complex_get(v,i); + gsl_complex Av = gsl_complex_mul (Aij, gsl_complex_conjugate(vi)); + wj = gsl_complex_add (wj, Av); + } + + tauwj = gsl_complex_mul (tau, wj); + + /* A = A - v w^T */ + + { + gsl_complex A0j = gsl_matrix_complex_get (A, 0, j); + gsl_complex Atw = gsl_complex_sub (A0j, tauwj); + /* store A0j - tau * wj */ + gsl_matrix_complex_set (A, 0, j, Atw); + } + + for (i = 1; i < A->size1; i++) + { + gsl_complex vi = gsl_vector_complex_get (v, i); + gsl_complex tauvw = gsl_complex_mul(vi, tauwj); + gsl_complex Aij = gsl_matrix_complex_get (A, i, j); + gsl_complex Atwv = gsl_complex_sub (Aij, tauvw); + /* store Aij - tau * vi * wj */ + gsl_matrix_complex_set (A, i, j, Atwv); + } + } + + return GSL_SUCCESS; +} + +int +gsl_linalg_complex_householder_hv (gsl_complex tau, const gsl_vector_complex * v, gsl_vector_complex * w) +{ + const size_t N = v->size; + + if (GSL_REAL(tau) == 0.0 && GSL_IMAG(tau) == 0.0) + return GSL_SUCCESS; + + { + /* compute z = v'w */ + + gsl_complex z0 = gsl_vector_complex_get(w,0); + gsl_complex z1, z; + gsl_complex tz, ntz; + + gsl_vector_complex_const_view v1 = gsl_vector_complex_const_subvector(v, 1, N-1); + gsl_vector_complex_view w1 = gsl_vector_complex_subvector(w, 1, N-1); + + gsl_blas_zdotc(&v1.vector, &w1.vector, &z1); + + z = gsl_complex_add (z0, z1); + + tz = gsl_complex_mul(tau, z); + ntz = gsl_complex_negative (tz); + + /* compute w = w - tau * (v'w) * v */ + + { + gsl_complex w0 = gsl_vector_complex_get(w, 0); + gsl_complex w0ntz = gsl_complex_add (w0, ntz); + gsl_vector_complex_set (w, 0, w0ntz); + } + + gsl_blas_zaxpy(ntz, &v1.vector, &w1.vector); + } + + return GSL_SUCCESS; +} diff --git a/gsl-1.9/linalg/lq.c b/gsl-1.9/linalg/lq.c new file mode 100644 index 0000000..a1c768e --- /dev/null +++ b/gsl-1.9/linalg/lq.c @@ -0,0 +1,567 @@ +/* linalg/lq.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman, Brian Gough + * Copyright (C) 2004 Joerg Wensch, modifications for LQ. + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +#include <config.h> +#include <stdlib.h> +#include <string.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> + +#include <gsl/gsl_linalg.h> + +#define REAL double + +#include "givens.c" +#include "apply_givens.c" + +/* Note: The standard in numerical linear algebra is to solve A x = b + * resp. ||A x - b||_2 -> min by QR-decompositions where x, b are + * column vectors. + * + * When the matrix A has a large number of rows it is much more + * efficient to work with the transposed matrix A^T and to solve the + * system x^T A = b^T resp. ||x^T A - b^T||_2 -> min. This is caused + * by the row-oriented format in which GSL stores matrices. Therefore + * the QR-decomposition of A has to be replaced by a LQ decomposition + * of A^T + * + * The purpose of this package is to provide the algorithms to compute + * the LQ-decomposition and to solve the linear equations resp. least + * squares problems. The dimensions N, M of the matrix are switched + * because here A will probably be a transposed matrix. We write x^T, + * b^T,... for vectors the comments to emphasize that they are row + * vectors. + * + * It may even be useful to transpose your matrix explicitly (assumed + * that there are no memory restrictions) because this takes O(M x N) + * computing time where the decompostion takes O(M x N^2) computing + * time. */ + +/* Factorise a general N x M matrix A into + * + * A = L Q + * + * where Q is orthogonal (M x M) and L is lower triangular (N x M). + * + * Q is stored as a packed set of Householder transformations in the + * strict upper triangular part of the input matrix. + * + * R is stored in the diagonal and lower triangle of the input matrix. + * + * The full matrix for Q can be obtained as the product + * + * Q = Q_k .. Q_2 Q_1 + * + * where k = MIN(M,N) and + * + * Q_i = (I - tau_i * v_i * v_i') + * + * and where v_i is a Householder vector + * + * v_i = [1, m(i+1,i), m(i+2,i), ... , m(M,i)] + * + * This storage scheme is the same as in LAPACK. */ + +int +gsl_linalg_LQ_decomp (gsl_matrix * A, gsl_vector * tau) +{ + const size_t N = A->size1; + const size_t M = A->size2; + + if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else + { + size_t i; + + for (i = 0; i < GSL_MIN (M, N); i++) + { + /* Compute the Householder transformation to reduce the j-th + column of the matrix to a multiple of the j-th unit vector */ + + gsl_vector_view c_full = gsl_matrix_row (A, i); + gsl_vector_view c = gsl_vector_subvector (&(c_full.vector), i, M-i); + + double tau_i = gsl_linalg_householder_transform (&(c.vector)); + + gsl_vector_set (tau, i, tau_i); + + /* Apply the transformation to the remaining columns and + update the norms */ + + if (i + 1 < N) + { + gsl_matrix_view m = gsl_matrix_submatrix (A, i + 1, i, N - (i + 1), M - i ); + gsl_linalg_householder_mh (tau_i, &(c.vector), &(m.matrix)); + } + } + + return GSL_SUCCESS; + } +} + +/* Solves the system x^T A = b^T using the LQ factorisation, + + * x^T L = b^T Q^T + * + * to obtain x. Based on SLATEC code. + */ + + +int +gsl_linalg_LQ_solve_T (const gsl_matrix * LQ, const gsl_vector * tau, const gsl_vector * b, gsl_vector * x) +{ + if (LQ->size1 != LQ->size2) + { + GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR); + } + else if (LQ->size2 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (LQ->size1 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_memcpy (x, b); + + /* Solve for x */ + + gsl_linalg_LQ_svx_T (LQ, tau, x); + + return GSL_SUCCESS; + } +} + +/* Solves the system x^T A = b^T in place using the LQ factorisation, + * + * x^T L = b^T Q^T + * + * to obtain x. Based on SLATEC code. + */ + +int +gsl_linalg_LQ_svx_T (const gsl_matrix * LQ, const gsl_vector * tau, gsl_vector * x) +{ + + if (LQ->size1 != LQ->size2) + { + GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR); + } + else if (LQ->size1 != x->size) + { + GSL_ERROR ("matrix size must match x/rhs size", GSL_EBADLEN); + } + else + { + /* compute rhs = Q^T b */ + + gsl_linalg_LQ_vecQT (LQ, tau, x); + + /* Solve R x = rhs, storing x in-place */ + + gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LQ, x); + + return GSL_SUCCESS; + } +} + + +/* Find the least squares solution to the overdetermined system + * + * x^T A = b^T + * + * for M >= N using the LQ factorization A = L Q. + */ + +int +gsl_linalg_LQ_lssolve_T (const gsl_matrix * LQ, const gsl_vector * tau, const gsl_vector * b, gsl_vector * x, gsl_vector * residual) +{ + const size_t N = LQ->size1; + const size_t M = LQ->size2; + + if (M < N) + { + GSL_ERROR ("LQ matrix must have M>=N", GSL_EBADLEN); + } + else if (M != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (N != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else if (M != residual->size) + { + GSL_ERROR ("matrix size must match residual size", GSL_EBADLEN); + } + else + { + gsl_matrix_const_view L = gsl_matrix_const_submatrix (LQ, 0, 0, N, N); + gsl_vector_view c = gsl_vector_subvector(residual, 0, N); + + gsl_vector_memcpy(residual, b); + + /* compute rhs = b^T Q^T */ + + gsl_linalg_LQ_vecQT (LQ, tau, residual); + + /* Solve x^T L = rhs */ + + gsl_vector_memcpy(x, &(c.vector)); + + gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, &(L.matrix), x); + + /* Compute residual = b^T - x^T A = (b^T Q^T - x^T L) Q */ + + gsl_vector_set_zero(&(c.vector)); + + gsl_linalg_LQ_vecQ(LQ, tau, residual); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_LQ_Lsolve_T (const gsl_matrix * LQ, const gsl_vector * b, gsl_vector * x) +{ + if (LQ->size1 != LQ->size2) + { + GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR); + } + else if (LQ->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (LQ->size1 != x->size) + { + GSL_ERROR ("matrix size must match x size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_memcpy (x, b); + + /* Solve R x = b, storing x in-place */ + + gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LQ, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_LQ_Lsvx_T (const gsl_matrix * LQ, gsl_vector * x) +{ + if (LQ->size1 != LQ->size2) + { + GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR); + } + else if (LQ->size2 != x->size) + { + GSL_ERROR ("matrix size must match rhs size", GSL_EBADLEN); + } + else + { + /* Solve x^T L = b^T, storing x in-place */ + + gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LQ, x); + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_L_solve_T (const gsl_matrix * L, const gsl_vector * b, gsl_vector * x) +{ + if (L->size1 != L->size2) + { + GSL_ERROR ("R matrix must be square", GSL_ENOTSQR); + } + else if (L->size2 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (L->size1 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_memcpy (x, b); + + /* Solve R x = b, storing x inplace in b */ + + gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, L, x); + + return GSL_SUCCESS; + } +} + + + + +int +gsl_linalg_LQ_vecQT (const gsl_matrix * LQ, const gsl_vector * tau, gsl_vector * v) +{ + const size_t N = LQ->size1; + const size_t M = LQ->size2; + + if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else if (v->size != M) + { + GSL_ERROR ("vector size must be M", GSL_EBADLEN); + } + else + { + size_t i; + + /* compute v Q^T */ + + for (i = 0; i < GSL_MIN (M, N); i++) + { + gsl_vector_const_view c = gsl_matrix_const_row (LQ, i); + gsl_vector_const_view h = gsl_vector_const_subvector (&(c.vector), + i, M - i); + gsl_vector_view w = gsl_vector_subvector (v, i, M - i); + double ti = gsl_vector_get (tau, i); + gsl_linalg_householder_hv (ti, &(h.vector), &(w.vector)); + } + return GSL_SUCCESS; + } +} + +int +gsl_linalg_LQ_vecQ (const gsl_matrix * LQ, const gsl_vector * tau, gsl_vector * v) +{ + const size_t N = LQ->size1; + const size_t M = LQ->size2; + + if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else if (v->size != M) + { + GSL_ERROR ("vector size must be M", GSL_EBADLEN); + } + else + { + size_t i; + + /* compute v Q^T */ + + for (i = GSL_MIN (M, N); i > 0 && i--;) + { + gsl_vector_const_view c = gsl_matrix_const_row (LQ, i); + gsl_vector_const_view h = gsl_vector_const_subvector (&(c.vector), + i, M - i); + gsl_vector_view w = gsl_vector_subvector (v, i, M - i); + double ti = gsl_vector_get (tau, i); + gsl_linalg_householder_hv (ti, &(h.vector), &(w.vector)); + } + return GSL_SUCCESS; + } +} + + +/* Form the orthogonal matrix Q from the packed LQ matrix */ + +int +gsl_linalg_LQ_unpack (const gsl_matrix * LQ, const gsl_vector * tau, gsl_matrix * Q, gsl_matrix * L) +{ + const size_t N = LQ->size1; + const size_t M = LQ->size2; + + if (Q->size1 != M || Q->size2 != M) + { + GSL_ERROR ("Q matrix must be M x M", GSL_ENOTSQR); + } + else if (L->size1 != N || L->size2 != M) + { + GSL_ERROR ("R matrix must be N x M", GSL_ENOTSQR); + } + else if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else + { + size_t i, j, l_border; + + /* Initialize Q to the identity */ + + gsl_matrix_set_identity (Q); + + for (i = GSL_MIN (M, N); i > 0 && i--;) + { + gsl_vector_const_view c = gsl_matrix_const_row (LQ, i); + gsl_vector_const_view h = gsl_vector_const_subvector (&c.vector, + i, M - i); + gsl_matrix_view m = gsl_matrix_submatrix (Q, i, i, M - i, M - i); + double ti = gsl_vector_get (tau, i); + gsl_linalg_householder_mh (ti, &h.vector, &m.matrix); + } + + /* Form the lower triangular matrix L from a packed LQ matrix */ + + for (i = 0; i < N; i++) + { + l_border=GSL_MIN(i,M-1); + for (j = 0; j <= l_border ; j++) + gsl_matrix_set (L, i, j, gsl_matrix_get (LQ, i, j)); + + for (j = l_border+1; j < M; j++) + gsl_matrix_set (L, i, j, 0.0); + } + + return GSL_SUCCESS; + } +} + + +/* Update a LQ factorisation for A= L Q , A' = A + v u^T, + + * L' Q' = LQ + v u^T + * = (L + v u^T Q^T) Q + * = (L + v w^T) Q + * + * where w = Q u. + * + * Algorithm from Golub and Van Loan, "Matrix Computations", Section + * 12.5 (Updating Matrix Factorizations, Rank-One Changes) + */ + +int +gsl_linalg_LQ_update (gsl_matrix * Q, gsl_matrix * L, + const gsl_vector * v, gsl_vector * w) +{ + const size_t N = L->size1; + const size_t M = L->size2; + + if (Q->size1 != M || Q->size2 != M) + { + GSL_ERROR ("Q matrix must be N x N if L is M x N", GSL_ENOTSQR); + } + else if (w->size != M) + { + GSL_ERROR ("w must be length N if L is M x N", GSL_EBADLEN); + } + else if (v->size != N) + { + GSL_ERROR ("v must be length M if L is M x N", GSL_EBADLEN); + } + else + { + size_t j, k; + double w0; + + /* Apply Given's rotations to reduce w to (|w|, 0, 0, ... , 0) + + J_1^T .... J_(n-1)^T w = +/- |w| e_1 + + simultaneously applied to L, H = J_1^T ... J^T_(n-1) L + so that H is upper Hessenberg. (12.5.2) */ + + for (k = M - 1; k > 0; k--) + { + double c, s; + double wk = gsl_vector_get (w, k); + double wkm1 = gsl_vector_get (w, k - 1); + + create_givens (wkm1, wk, &c, &s); + apply_givens_vec (w, k - 1, k, c, s); + apply_givens_lq (M, N, Q, L, k - 1, k, c, s); + } + + w0 = gsl_vector_get (w, 0); + + /* Add in v w^T (Equation 12.5.3) */ + + for (j = 0; j < N; j++) + { + double lj0 = gsl_matrix_get (L, j, 0); + double vj = gsl_vector_get (v, j); + gsl_matrix_set (L, j, 0, lj0 + w0 * vj); + } + + /* Apply Givens transformations L' = G_(n-1)^T ... G_1^T H + Equation 12.5.4 */ + + for (k = 1; k < GSL_MIN(M,N+1); k++) + { + double c, s; + double diag = gsl_matrix_get (L, k - 1, k - 1); + double offdiag = gsl_matrix_get (L, k - 1 , k); + + create_givens (diag, offdiag, &c, &s); + apply_givens_lq (M, N, Q, L, k - 1, k, c, s); + + gsl_matrix_set (L, k - 1, k, 0.0); /* exact zero of G^T */ + } + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_LQ_LQsolve (gsl_matrix * Q, gsl_matrix * L, const gsl_vector * b, gsl_vector * x) +{ + const size_t N = L->size1; + const size_t M = L->size2; + + if (M != N) + { + return GSL_ENOTSQR; + } + else if (Q->size1 != M || b->size != M || x->size != M) + { + return GSL_EBADLEN; + } + else + { + /* compute sol = b^T Q^T */ + + gsl_blas_dgemv (CblasNoTrans, 1.0, Q, b, 0.0, x); + + /* Solve x^T L = sol, storing x in-place */ + + gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, L, x); + + return GSL_SUCCESS; + } +} diff --git a/gsl-1.9/linalg/lu.c b/gsl-1.9/linalg/lu.c new file mode 100644 index 0000000..f61348e --- /dev/null +++ b/gsl-1.9/linalg/lu.c @@ -0,0 +1,312 @@ +/* linalg/lu.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Author: G. Jungman */ + +#include <config.h> +#include <stdlib.h> +#include <string.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_permute_vector.h> +#include <gsl/gsl_blas.h> + +#include <gsl/gsl_linalg.h> + +#define REAL double + +/* Factorise a general N x N matrix A into, + * + * P A = L U + * + * where P is a permutation matrix, L is unit lower triangular and U + * is upper triangular. + * + * L is stored in the strict lower triangular part of the input + * matrix. The diagonal elements of L are unity and are not stored. + * + * U is stored in the diagonal and upper triangular part of the + * input matrix. + * + * P is stored in the permutation p. Column j of P is column k of the + * identity matrix, where k = permutation->data[j] + * + * signum gives the sign of the permutation, (-1)^n, where n is the + * number of interchanges in the permutation. + * + * See Golub & Van Loan, Matrix Computations, Algorithm 3.4.1 (Gauss + * Elimination with Partial Pivoting). + */ + +int +gsl_linalg_LU_decomp (gsl_matrix * A, gsl_permutation * p, int *signum) +{ + if (A->size1 != A->size2) + { + GSL_ERROR ("LU decomposition requires square matrix", GSL_ENOTSQR); + } + else if (p->size != A->size1) + { + GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN); + } + else + { + const size_t N = A->size1; + size_t i, j, k; + + *signum = 1; + gsl_permutation_init (p); + + for (j = 0; j < N - 1; j++) + { + /* Find maximum in the j-th column */ + + REAL ajj, max = fabs (gsl_matrix_get (A, j, j)); + size_t i_pivot = j; + + for (i = j + 1; i < N; i++) + { + REAL aij = fabs (gsl_matrix_get (A, i, j)); + + if (aij > max) + { + max = aij; + i_pivot = i; + } + } + + if (i_pivot != j) + { + gsl_matrix_swap_rows (A, j, i_pivot); + gsl_permutation_swap (p, j, i_pivot); + *signum = -(*signum); + } + + ajj = gsl_matrix_get (A, j, j); + + if (ajj != 0.0) + { + for (i = j + 1; i < N; i++) + { + REAL aij = gsl_matrix_get (A, i, j) / ajj; + gsl_matrix_set (A, i, j, aij); + + for (k = j + 1; k < N; k++) + { + REAL aik = gsl_matrix_get (A, i, k); + REAL ajk = gsl_matrix_get (A, j, k); + gsl_matrix_set (A, i, k, aik - aij * ajk); + } + } + } + } + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_LU_solve (const gsl_matrix * LU, const gsl_permutation * p, const gsl_vector * b, gsl_vector * x) +{ + if (LU->size1 != LU->size2) + { + GSL_ERROR ("LU matrix must be square", GSL_ENOTSQR); + } + else if (LU->size1 != p->size) + { + GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN); + } + else if (LU->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (LU->size2 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_memcpy (x, b); + + /* Solve for x */ + + gsl_linalg_LU_svx (LU, p, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_LU_svx (const gsl_matrix * LU, const gsl_permutation * p, gsl_vector * x) +{ + if (LU->size1 != LU->size2) + { + GSL_ERROR ("LU matrix must be square", GSL_ENOTSQR); + } + else if (LU->size1 != p->size) + { + GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN); + } + else if (LU->size1 != x->size) + { + GSL_ERROR ("matrix size must match solution/rhs size", GSL_EBADLEN); + } + else + { + /* Apply permutation to RHS */ + + gsl_permute_vector (p, x); + + /* Solve for c using forward-substitution, L c = P b */ + + gsl_blas_dtrsv (CblasLower, CblasNoTrans, CblasUnit, LU, x); + + /* Perform back-substitution, U x = c */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, LU, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_LU_refine (const gsl_matrix * A, const gsl_matrix * LU, const gsl_permutation * p, const gsl_vector * b, gsl_vector * x, gsl_vector * residual) +{ + if (A->size1 != A->size2) + { + GSL_ERROR ("matrix a must be square", GSL_ENOTSQR); + } + if (LU->size1 != LU->size2) + { + GSL_ERROR ("LU matrix must be square", GSL_ENOTSQR); + } + else if (A->size1 != LU->size2) + { + GSL_ERROR ("LU matrix must be decomposition of a", GSL_ENOTSQR); + } + else if (LU->size1 != p->size) + { + GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN); + } + else if (LU->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (LU->size1 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Compute residual, residual = (A * x - b) */ + + gsl_vector_memcpy (residual, b); + gsl_blas_dgemv (CblasNoTrans, 1.0, A, x, -1.0, residual); + + /* Find correction, delta = - (A^-1) * residual, and apply it */ + + gsl_linalg_LU_svx (LU, p, residual); + gsl_blas_daxpy (-1.0, residual, x); + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_LU_invert (const gsl_matrix * LU, const gsl_permutation * p, gsl_matrix * inverse) +{ + size_t i, n = LU->size1; + + int status = GSL_SUCCESS; + + gsl_matrix_set_identity (inverse); + + for (i = 0; i < n; i++) + { + gsl_vector_view c = gsl_matrix_column (inverse, i); + int status_i = gsl_linalg_LU_svx (LU, p, &(c.vector)); + + if (status_i) + status = status_i; + } + + return status; +} + +double +gsl_linalg_LU_det (gsl_matrix * LU, int signum) +{ + size_t i, n = LU->size1; + + double det = (double) signum; + + for (i = 0; i < n; i++) + { + det *= gsl_matrix_get (LU, i, i); + } + + return det; +} + + +double +gsl_linalg_LU_lndet (gsl_matrix * LU) +{ + size_t i, n = LU->size1; + + double lndet = 0.0; + + for (i = 0; i < n; i++) + { + lndet += log (fabs (gsl_matrix_get (LU, i, i))); + } + + return lndet; +} + + +int +gsl_linalg_LU_sgndet (gsl_matrix * LU, int signum) +{ + size_t i, n = LU->size1; + + int s = signum; + + for (i = 0; i < n; i++) + { + double u = gsl_matrix_get (LU, i, i); + + if (u < 0) + { + s *= -1; + } + else if (u == 0) + { + s = 0; + break; + } + } + + return s; +} diff --git a/gsl-1.9/linalg/luc.c b/gsl-1.9/linalg/luc.c new file mode 100644 index 0000000..5360679 --- /dev/null +++ b/gsl-1.9/linalg/luc.c @@ -0,0 +1,334 @@ +/* linalg/luc.c + * + * Copyright (C) 2001 Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +#include <config.h> +#include <stdlib.h> +#include <string.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_complex.h> +#include <gsl/gsl_complex_math.h> +#include <gsl/gsl_permute_vector.h> +#include <gsl/gsl_blas.h> +#include <gsl/gsl_complex_math.h> + +#include <gsl/gsl_linalg.h> + +/* Factorise a general N x N complex matrix A into, + * + * P A = L U + * + * where P is a permutation matrix, L is unit lower triangular and U + * is upper triangular. + * + * L is stored in the strict lower triangular part of the input + * matrix. The diagonal elements of L are unity and are not stored. + * + * U is stored in the diagonal and upper triangular part of the + * input matrix. + * + * P is stored in the permutation p. Column j of P is column k of the + * identity matrix, where k = permutation->data[j] + * + * signum gives the sign of the permutation, (-1)^n, where n is the + * number of interchanges in the permutation. + * + * See Golub & Van Loan, Matrix Computations, Algorithm 3.4.1 (Gauss + * Elimination with Partial Pivoting). + */ + +int +gsl_linalg_complex_LU_decomp (gsl_matrix_complex * A, gsl_permutation * p, int *signum) +{ + if (A->size1 != A->size2) + { + GSL_ERROR ("LU decomposition requires square matrix", GSL_ENOTSQR); + } + else if (p->size != A->size1) + { + GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN); + } + else + { + const size_t N = A->size1; + size_t i, j, k; + + *signum = 1; + gsl_permutation_init (p); + + for (j = 0; j < N - 1; j++) + { + /* Find maximum in the j-th column */ + + gsl_complex ajj = gsl_matrix_complex_get (A, j, j); + double max = gsl_complex_abs (ajj); + size_t i_pivot = j; + + for (i = j + 1; i < N; i++) + { + gsl_complex aij = gsl_matrix_complex_get (A, i, j); + double ai = gsl_complex_abs (aij); + + if (ai > max) + { + max = ai; + i_pivot = i; + } + } + + if (i_pivot != j) + { + gsl_matrix_complex_swap_rows (A, j, i_pivot); + gsl_permutation_swap (p, j, i_pivot); + *signum = -(*signum); + } + + ajj = gsl_matrix_complex_get (A, j, j); + + if (!(GSL_REAL(ajj) == 0.0 && GSL_IMAG(ajj) == 0.0)) + { + for (i = j + 1; i < N; i++) + { + gsl_complex aij_orig = gsl_matrix_complex_get (A, i, j); + gsl_complex aij = gsl_complex_div (aij_orig, ajj); + gsl_matrix_complex_set (A, i, j, aij); + + for (k = j + 1; k < N; k++) + { + gsl_complex aik = gsl_matrix_complex_get (A, i, k); + gsl_complex ajk = gsl_matrix_complex_get (A, j, k); + + /* aik = aik - aij * ajk */ + + gsl_complex aijajk = gsl_complex_mul (aij, ajk); + gsl_complex aik_new = gsl_complex_sub (aik, aijajk); + + gsl_matrix_complex_set (A, i, k, aik_new); + } + } + } + } + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_complex_LU_solve (const gsl_matrix_complex * LU, const gsl_permutation * p, const gsl_vector_complex * b, gsl_vector_complex * x) +{ + if (LU->size1 != LU->size2) + { + GSL_ERROR ("LU matrix must be square", GSL_ENOTSQR); + } + else if (LU->size1 != p->size) + { + GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN); + } + else if (LU->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (LU->size2 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_complex_memcpy (x, b); + + /* Solve for x */ + + gsl_linalg_complex_LU_svx (LU, p, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_complex_LU_svx (const gsl_matrix_complex * LU, const gsl_permutation * p, gsl_vector_complex * x) +{ + if (LU->size1 != LU->size2) + { + GSL_ERROR ("LU matrix must be square", GSL_ENOTSQR); + } + else if (LU->size1 != p->size) + { + GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN); + } + else if (LU->size1 != x->size) + { + GSL_ERROR ("matrix size must match solution/rhs size", GSL_EBADLEN); + } + else + { + /* Apply permutation to RHS */ + + gsl_permute_vector_complex (p, x); + + /* Solve for c using forward-substitution, L c = P b */ + + gsl_blas_ztrsv (CblasLower, CblasNoTrans, CblasUnit, LU, x); + + /* Perform back-substitution, U x = c */ + + gsl_blas_ztrsv (CblasUpper, CblasNoTrans, CblasNonUnit, LU, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_complex_LU_refine (const gsl_matrix_complex * A, const gsl_matrix_complex * LU, const gsl_permutation * p, const gsl_vector_complex * b, gsl_vector_complex * x, gsl_vector_complex * residual) +{ + if (A->size1 != A->size2) + { + GSL_ERROR ("matrix a must be square", GSL_ENOTSQR); + } + if (LU->size1 != LU->size2) + { + GSL_ERROR ("LU matrix must be square", GSL_ENOTSQR); + } + else if (A->size1 != LU->size2) + { + GSL_ERROR ("LU matrix must be decomposition of a", GSL_ENOTSQR); + } + else if (LU->size1 != p->size) + { + GSL_ERROR ("permutation length must match matrix size", GSL_EBADLEN); + } + else if (LU->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (LU->size1 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Compute residual, residual = (A * x - b) */ + + gsl_vector_complex_memcpy (residual, b); + + { + gsl_complex one = GSL_COMPLEX_ONE; + gsl_complex negone = GSL_COMPLEX_NEGONE; + gsl_blas_zgemv (CblasNoTrans, one, A, x, negone, residual); + } + + /* Find correction, delta = - (A^-1) * residual, and apply it */ + + gsl_linalg_complex_LU_svx (LU, p, residual); + + { + gsl_complex negone= GSL_COMPLEX_NEGONE; + gsl_blas_zaxpy (negone, residual, x); + } + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_complex_LU_invert (const gsl_matrix_complex * LU, const gsl_permutation * p, gsl_matrix_complex * inverse) +{ + size_t i, n = LU->size1; + + int status = GSL_SUCCESS; + + gsl_matrix_complex_set_identity (inverse); + + for (i = 0; i < n; i++) + { + gsl_vector_complex_view c = gsl_matrix_complex_column (inverse, i); + int status_i = gsl_linalg_complex_LU_svx (LU, p, &(c.vector)); + + if (status_i) + status = status_i; + } + + return status; +} + +gsl_complex +gsl_linalg_complex_LU_det (gsl_matrix_complex * LU, int signum) +{ + size_t i, n = LU->size1; + + gsl_complex det = gsl_complex_rect((double) signum, 0.0); + + for (i = 0; i < n; i++) + { + gsl_complex zi = gsl_matrix_complex_get (LU, i, i); + det = gsl_complex_mul (det, zi); + } + + return det; +} + + +double +gsl_linalg_complex_LU_lndet (gsl_matrix_complex * LU) +{ + size_t i, n = LU->size1; + + double lndet = 0.0; + + for (i = 0; i < n; i++) + { + gsl_complex z = gsl_matrix_complex_get (LU, i, i); + lndet += log (gsl_complex_abs (z)); + } + + return lndet; +} + + +gsl_complex +gsl_linalg_complex_LU_sgndet (gsl_matrix_complex * LU, int signum) +{ + size_t i, n = LU->size1; + + gsl_complex phase = gsl_complex_rect((double) signum, 0.0); + + for (i = 0; i < n; i++) + { + gsl_complex z = gsl_matrix_complex_get (LU, i, i); + + double r = gsl_complex_abs(z); + + if (r == 0) + { + phase = gsl_complex_rect(0.0, 0.0); + break; + } + else + { + z = gsl_complex_div_real(z, r); + phase = gsl_complex_mul(phase, z); + } + } + + return phase; +} diff --git a/gsl-1.9/linalg/multiply.c b/gsl-1.9/linalg/multiply.c new file mode 100644 index 0000000..0522cdd --- /dev/null +++ b/gsl-1.9/linalg/multiply.c @@ -0,0 +1,137 @@ +/* linalg/multiply.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Author: G. Jungman */ + +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_linalg.h> + +#define SWAP_SIZE_T(a, b) do { size_t swap_tmp = a; a = b; b = swap_tmp; } while(0) + +int +gsl_linalg_matmult (const gsl_matrix * A, const gsl_matrix * B, gsl_matrix * C) +{ + if (A->size2 != B->size1 || A->size1 != C->size1 || B->size2 != C->size2) + { + GSL_ERROR ("matrix sizes are not conformant", GSL_EBADLEN); + } + else + { + double a, b; + double temp; + size_t i, j, k; + + for (i = 0; i < C->size1; i++) + { + for (j = 0; j < C->size2; j++) + { + a = gsl_matrix_get (A, i, 0); + b = gsl_matrix_get (B, 0, j); + temp = a * b; + for (k = 1; k < A->size2; k++) + { + a = gsl_matrix_get (A, i, k); + b = gsl_matrix_get (B, k, j); + temp += a * b; + } + gsl_matrix_set (C, i, j, temp); + } + } + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_matmult_mod (const gsl_matrix * A, gsl_linalg_matrix_mod_t modA, + const gsl_matrix * B, gsl_linalg_matrix_mod_t modB, + gsl_matrix * C) +{ + if (modA == GSL_LINALG_MOD_NONE && modB == GSL_LINALG_MOD_NONE) + { + return gsl_linalg_matmult (A, B, C); + } + else + { + size_t dim1_A = A->size1; + size_t dim2_A = A->size2; + size_t dim1_B = B->size1; + size_t dim2_B = B->size2; + size_t dim1_C = C->size1; + size_t dim2_C = C->size2; + + if (modA & GSL_LINALG_MOD_TRANSPOSE) + SWAP_SIZE_T (dim1_A, dim2_A); + if (modB & GSL_LINALG_MOD_TRANSPOSE) + SWAP_SIZE_T (dim1_B, dim2_B); + + if (dim2_A != dim1_B || dim1_A != dim1_C || dim2_B != dim2_C) + { + GSL_ERROR ("matrix sizes are not conformant", GSL_EBADLEN); + } + else + { + double a, b; + double temp; + size_t i, j, k; + size_t a1, a2, b1, b2; + + for (i = 0; i < dim1_C; i++) + { + for (j = 0; j < dim2_C; j++) + { + a1 = i; + a2 = 0; + b1 = 0; + b2 = j; + if (modA & GSL_LINALG_MOD_TRANSPOSE) + SWAP_SIZE_T (a1, a2); + if (modB & GSL_LINALG_MOD_TRANSPOSE) + SWAP_SIZE_T (b1, b2); + + a = gsl_matrix_get (A, a1, a2); + b = gsl_matrix_get (B, b1, b2); + temp = a * b; + + for (k = 1; k < dim2_A; k++) + { + a1 = i; + a2 = k; + b1 = k; + b2 = j; + if (modA & GSL_LINALG_MOD_TRANSPOSE) + SWAP_SIZE_T (a1, a2); + if (modB & GSL_LINALG_MOD_TRANSPOSE) + SWAP_SIZE_T (b1, b2); + a = gsl_matrix_get (A, a1, a2); + b = gsl_matrix_get (B, b1, b2); + temp += a * b; + } + + gsl_matrix_set (C, i, j, temp); + } + } + + return GSL_SUCCESS; + } + } +} diff --git a/gsl-1.9/linalg/ptlq.c b/gsl-1.9/linalg/ptlq.c new file mode 100644 index 0000000..f6368f0 --- /dev/null +++ b/gsl-1.9/linalg/ptlq.c @@ -0,0 +1,493 @@ +/* linalg/ptlq.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman, Brian Gough + * Copyright (C) 2004 Joerg Wensch, modifications for LQ. + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +#include <config.h> +#include <stdlib.h> +#include <string.h> +#include <gsl/gsl_blas.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_permute_vector.h> +#include <gsl/gsl_linalg.h> + +#include "givens.c" +#include "apply_givens.c" + +/* The purpose of this package is to speed up QR-decomposition for + large matrices. Because QR-decomposition is column oriented, but + GSL uses a row-oriented matrix format, there can considerable + speedup obtained by computing the LQ-decomposition of the + transposed matrix instead. This package provides LQ-decomposition + and related algorithms. */ + +/* Factorise a general N x M matrix A into + * + * P A = L Q + * + * where Q is orthogonal (M x M) and L is lower triangular (N x M). + * When A is rank deficient, r = rank(A) < n, then the permutation is + * used to ensure that the lower n - r columns of L are zero and the first + * l rows of Q form an orthonormal basis for the rows of A. + * + * Q is stored as a packed set of Householder transformations in the + * strict upper triangular part of the input matrix. + * + * L is stored in the diagonal and lower triangle of the input matrix. + * + * P: column j of P is column k of the identity matrix, where k = + * permutation->data[j] + * + * The full matrix for Q can be obtained as the product + * + * Q = Q_k .. Q_2 Q_1 + * + * where k = MIN(M,N) and + * + * Q_i = (I - tau_i * v_i * v_i') + * + * and where v_i is a Householder vector + * + * v_i = [1, m(i,i+1), m(i,i+2), ... , m(i,M)] + * + * This storage scheme is the same as in LAPACK. See LAPACK's + * dgeqpf.f for details. + * + */ + +int +gsl_linalg_PTLQ_decomp (gsl_matrix * A, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm) +{ + const size_t N = A->size1; + const size_t M = A->size2; + + if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else if (p->size != N) + { + GSL_ERROR ("permutation size must be N", GSL_EBADLEN); + } + else if (norm->size != N) + { + GSL_ERROR ("norm size must be N", GSL_EBADLEN); + } + else + { + size_t i; + + *signum = 1; + + gsl_permutation_init (p); /* set to identity */ + + /* Compute column norms and store in workspace */ + + for (i = 0; i < N; i++) + { + gsl_vector_view c = gsl_matrix_row (A, i); + double x = gsl_blas_dnrm2 (&c.vector); + gsl_vector_set (norm, i, x); + } + + for (i = 0; i < GSL_MIN (M, N); i++) + { + /* Bring the column of largest norm into the pivot position */ + + double max_norm = gsl_vector_get(norm, i); + size_t j, kmax = i; + + for (j = i + 1; j < N; j++) + { + double x = gsl_vector_get (norm, j); + + if (x > max_norm) + { + max_norm = x; + kmax = j; + } + } + + if (kmax != i) + { + gsl_matrix_swap_rows (A, i, kmax); + gsl_permutation_swap (p, i, kmax); + gsl_vector_swap_elements(norm,i,kmax); + + (*signum) = -(*signum); + } + + /* Compute the Householder transformation to reduce the j-th + column of the matrix to a multiple of the j-th unit vector */ + + { + gsl_vector_view c_full = gsl_matrix_row (A, i); + gsl_vector_view c = gsl_vector_subvector (&c_full.vector, + i, M - i); + double tau_i = gsl_linalg_householder_transform (&c.vector); + + gsl_vector_set (tau, i, tau_i); + + /* Apply the transformation to the remaining columns */ + + if (i + 1 < N) + { + gsl_matrix_view m = gsl_matrix_submatrix (A, i +1, i, N - (i+1), M - i); + + gsl_linalg_householder_mh (tau_i, &c.vector, &m.matrix); + } + } + + /* Update the norms of the remaining columns too */ + + if (i + 1 < M) + { + for (j = i + 1; j < N; j++) + { + double x = gsl_vector_get (norm, j); + + if (x > 0.0) + { + double y = 0; + double temp= gsl_matrix_get (A, j, i) / x; + + if (fabs (temp) >= 1) + y = 0.0; + else + y = x * sqrt (1 - temp * temp); + + /* recompute norm to prevent loss of accuracy */ + + if (fabs (y / x) < sqrt (20.0) * GSL_SQRT_DBL_EPSILON) + { + gsl_vector_view c_full = gsl_matrix_row (A, j); + gsl_vector_view c = + gsl_vector_subvector(&c_full.vector, + i+1, M - (i+1)); + y = gsl_blas_dnrm2 (&c.vector); + } + + gsl_vector_set (norm, j, y); + } + } + } + } + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_PTLQ_decomp2 (const gsl_matrix * A, gsl_matrix * q, gsl_matrix * r, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm) +{ + const size_t N = A->size1; + const size_t M = A->size2; + + if (q->size1 != M || q->size2 !=M) + { + GSL_ERROR ("q must be M x M", GSL_EBADLEN); + } + else if (r->size1 != N || r->size2 !=M) + { + GSL_ERROR ("r must be N x M", GSL_EBADLEN); + } + else if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else if (p->size != N) + { + GSL_ERROR ("permutation size must be N", GSL_EBADLEN); + } + else if (norm->size != N) + { + GSL_ERROR ("norm size must be N", GSL_EBADLEN); + } + + gsl_matrix_memcpy (r, A); + + gsl_linalg_PTLQ_decomp (r, tau, p, signum, norm); + + /* FIXME: aliased arguments depends on behavior of unpack routine! */ + + gsl_linalg_LQ_unpack (r, tau, q, r); + + return GSL_SUCCESS; +} + + +/* Solves the system x^T A = b^T using the P^T L Q factorisation, + + z^T L = b^T Q^T + + x = P z; + + to obtain x. Based on SLATEC code. */ + +int +gsl_linalg_PTLQ_solve_T (const gsl_matrix * QR, + const gsl_vector * tau, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x) +{ + if (QR->size1 != QR->size2) + { + GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR); + } + else if (QR->size2 != p->size) + { + GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN); + } + else if (QR->size2 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (QR->size1 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + gsl_vector_memcpy (x, b); + + gsl_linalg_PTLQ_svx_T (QR, tau, p, x); + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_PTLQ_svx_T (const gsl_matrix * LQ, + const gsl_vector * tau, + const gsl_permutation * p, + gsl_vector * x) +{ + if (LQ->size1 != LQ->size2) + { + GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR); + } + else if (LQ->size2 != p->size) + { + GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN); + } + else if (LQ->size1 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* compute sol = b^T Q^T */ + + gsl_linalg_LQ_vecQT (LQ, tau, x); + + /* Solve L^T x = sol, storing x inplace in sol */ + + gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LQ, x); + + gsl_permute_vector_inverse (p, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_PTLQ_LQsolve_T (const gsl_matrix * Q, const gsl_matrix * L, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x) +{ + if (Q->size1 != Q->size2 || L->size1 != L->size2) + { + return GSL_ENOTSQR; + } + else if (Q->size1 != p->size || Q->size1 != L->size1 + || Q->size1 != b->size) + { + return GSL_EBADLEN; + } + else + { + /* compute b' = Q b */ + + gsl_blas_dgemv (CblasNoTrans, 1.0, Q, b, 0.0, x); + + /* Solve L^T x = b', storing x inplace */ + + gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, L, x); + + /* Apply permutation to solution in place */ + + gsl_permute_vector_inverse (p, x); + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_PTLQ_Lsolve_T (const gsl_matrix * LQ, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x) +{ + if (LQ->size1 != LQ->size2) + { + GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR); + } + else if (LQ->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (LQ->size2 != x->size) + { + GSL_ERROR ("matrix size must match x size", GSL_EBADLEN); + } + else if (p->size != x->size) + { + GSL_ERROR ("permutation size must match x size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_memcpy (x, b); + + /* Solve L^T x = b, storing x inplace */ + + gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LQ, x); + + gsl_permute_vector_inverse (p, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_PTLQ_Lsvx_T (const gsl_matrix * LQ, + const gsl_permutation * p, + gsl_vector * x) +{ + if (LQ->size1 != LQ->size2) + { + GSL_ERROR ("LQ matrix must be square", GSL_ENOTSQR); + } + else if (LQ->size2 != x->size) + { + GSL_ERROR ("matrix size must match x size", GSL_EBADLEN); + } + else if (p->size != x->size) + { + GSL_ERROR ("permutation size must match x size", GSL_EBADLEN); + } + else + { + /* Solve L^T x = b, storing x inplace */ + + gsl_blas_dtrsv (CblasLower, CblasTrans, CblasNonUnit, LQ, x); + + gsl_permute_vector_inverse (p, x); + + return GSL_SUCCESS; + } +} + + + +/* Update a P^T L Q factorisation for P A= L Q , A' = A + v u^T, + PA' = PA + Pv u^T + + * P^T L' Q' = P^T LQ + v u^T + * = P^T (L + (P v) u^T Q^T) Q + * = P^T (L + (P v) w^T) Q + * + * where w = Q^T u. + * + * Algorithm from Golub and Van Loan, "Matrix Computations", Section + * 12.5 (Updating Matrix Factorizations, Rank-One Changes) + */ + +int +gsl_linalg_PTLQ_update (gsl_matrix * Q, gsl_matrix * L, + const gsl_permutation * p, + const gsl_vector * v, gsl_vector * w) +{ + if (Q->size1 != Q->size2 || L->size1 != L->size2) + { + return GSL_ENOTSQR; + } + else if (L->size1 != Q->size2 || v->size != Q->size2 || w->size != Q->size2) + { + return GSL_EBADLEN; + } + else + { + size_t j, k; + const size_t N = Q->size1; + const size_t M = Q->size2; + double w0; + + /* Apply Given's rotations to reduce w to (|w|, 0, 0, ... , 0) + + J_1^T .... J_(n-1)^T w = +/- |w| e_1 + + simultaneously applied to L, H = J_1^T ... J^T_(n-1) L + so that H is upper Hessenberg. (12.5.2) */ + + for (k = M - 1; k > 0; k--) + { + double c, s; + double wk = gsl_vector_get (w, k); + double wkm1 = gsl_vector_get (w, k - 1); + + create_givens (wkm1, wk, &c, &s); + apply_givens_vec (w, k - 1, k, c, s); + apply_givens_lq (M, N, Q, L, k - 1, k, c, s); + } + + w0 = gsl_vector_get (w, 0); + + /* Add in v w^T (Equation 12.5.3) */ + + for (j = 0; j < N; j++) + { + double lj0 = gsl_matrix_get (L, j, 0); + size_t p_j = gsl_permutation_get (p, j); + double vj = gsl_vector_get (v, p_j); + gsl_matrix_set (L, j, 0, lj0 + w0 * vj); + } + + /* Apply Givens transformations L' = G_(n-1)^T ... G_1^T H + Equation 12.5.4 */ + + for (k = 1; k < N; k++) + { + double c, s; + double diag = gsl_matrix_get (L, k - 1, k - 1); + double offdiag = gsl_matrix_get (L, k - 1, k ); + + create_givens (diag, offdiag, &c, &s); + apply_givens_lq (M, N, Q, L, k - 1, k, c, s); + } + + return GSL_SUCCESS; + } +} diff --git a/gsl-1.9/linalg/qr.c b/gsl-1.9/linalg/qr.c new file mode 100644 index 0000000..f3526e6 --- /dev/null +++ b/gsl-1.9/linalg/qr.c @@ -0,0 +1,566 @@ +/* linalg/qr.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Author: G. Jungman */ + +#include <config.h> +#include <stdlib.h> +#include <string.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> + +#include <gsl/gsl_linalg.h> + +#define REAL double + +#include "givens.c" +#include "apply_givens.c" + +/* Factorise a general M x N matrix A into + * + * A = Q R + * + * where Q is orthogonal (M x M) and R is upper triangular (M x N). + * + * Q is stored as a packed set of Householder transformations in the + * strict lower triangular part of the input matrix. + * + * R is stored in the diagonal and upper triangle of the input matrix. + * + * The full matrix for Q can be obtained as the product + * + * Q = Q_k .. Q_2 Q_1 + * + * where k = MIN(M,N) and + * + * Q_i = (I - tau_i * v_i * v_i') + * + * and where v_i is a Householder vector + * + * v_i = [1, m(i+1,i), m(i+2,i), ... , m(M,i)] + * + * This storage scheme is the same as in LAPACK. */ + +int +gsl_linalg_QR_decomp (gsl_matrix * A, gsl_vector * tau) +{ + const size_t M = A->size1; + const size_t N = A->size2; + + if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else + { + size_t i; + + for (i = 0; i < GSL_MIN (M, N); i++) + { + /* Compute the Householder transformation to reduce the j-th + column of the matrix to a multiple of the j-th unit vector */ + + gsl_vector_view c_full = gsl_matrix_column (A, i); + gsl_vector_view c = gsl_vector_subvector (&(c_full.vector), i, M-i); + + double tau_i = gsl_linalg_householder_transform (&(c.vector)); + + gsl_vector_set (tau, i, tau_i); + + /* Apply the transformation to the remaining columns and + update the norms */ + + if (i + 1 < N) + { + gsl_matrix_view m = gsl_matrix_submatrix (A, i, i + 1, M - i, N - (i + 1)); + gsl_linalg_householder_hm (tau_i, &(c.vector), &(m.matrix)); + } + } + + return GSL_SUCCESS; + } +} + +/* Solves the system A x = b using the QR factorisation, + + * R x = Q^T b + * + * to obtain x. Based on SLATEC code. + */ + +int +gsl_linalg_QR_solve (const gsl_matrix * QR, const gsl_vector * tau, const gsl_vector * b, gsl_vector * x) +{ + if (QR->size1 != QR->size2) + { + GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR); + } + else if (QR->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (QR->size2 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_memcpy (x, b); + + /* Solve for x */ + + gsl_linalg_QR_svx (QR, tau, x); + + return GSL_SUCCESS; + } +} + +/* Solves the system A x = b in place using the QR factorisation, + + * R x = Q^T b + * + * to obtain x. Based on SLATEC code. + */ + +int +gsl_linalg_QR_svx (const gsl_matrix * QR, const gsl_vector * tau, gsl_vector * x) +{ + + if (QR->size1 != QR->size2) + { + GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR); + } + else if (QR->size1 != x->size) + { + GSL_ERROR ("matrix size must match x/rhs size", GSL_EBADLEN); + } + else + { + /* compute rhs = Q^T b */ + + gsl_linalg_QR_QTvec (QR, tau, x); + + /* Solve R x = rhs, storing x in-place */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x); + + return GSL_SUCCESS; + } +} + + +/* Find the least squares solution to the overdetermined system + * + * A x = b + * + * for M >= N using the QR factorization A = Q R. + */ + +int +gsl_linalg_QR_lssolve (const gsl_matrix * QR, const gsl_vector * tau, const gsl_vector * b, gsl_vector * x, gsl_vector * residual) +{ + const size_t M = QR->size1; + const size_t N = QR->size2; + + if (M < N) + { + GSL_ERROR ("QR matrix must have M>=N", GSL_EBADLEN); + } + else if (M != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (N != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else if (M != residual->size) + { + GSL_ERROR ("matrix size must match residual size", GSL_EBADLEN); + } + else + { + gsl_matrix_const_view R = gsl_matrix_const_submatrix (QR, 0, 0, N, N); + gsl_vector_view c = gsl_vector_subvector(residual, 0, N); + + gsl_vector_memcpy(residual, b); + + /* compute rhs = Q^T b */ + + gsl_linalg_QR_QTvec (QR, tau, residual); + + /* Solve R x = rhs */ + + gsl_vector_memcpy(x, &(c.vector)); + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, &(R.matrix), x); + + /* Compute residual = b - A x = Q (Q^T b - R x) */ + + gsl_vector_set_zero(&(c.vector)); + + gsl_linalg_QR_Qvec(QR, tau, residual); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_QR_Rsolve (const gsl_matrix * QR, const gsl_vector * b, gsl_vector * x) +{ + if (QR->size1 != QR->size2) + { + GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR); + } + else if (QR->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (QR->size2 != x->size) + { + GSL_ERROR ("matrix size must match x size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_memcpy (x, b); + + /* Solve R x = b, storing x in-place */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_QR_Rsvx (const gsl_matrix * QR, gsl_vector * x) +{ + if (QR->size1 != QR->size2) + { + GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR); + } + else if (QR->size1 != x->size) + { + GSL_ERROR ("matrix size must match rhs size", GSL_EBADLEN); + } + else + { + /* Solve R x = b, storing x in-place */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x); + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_R_solve (const gsl_matrix * R, const gsl_vector * b, gsl_vector * x) +{ + if (R->size1 != R->size2) + { + GSL_ERROR ("R matrix must be square", GSL_ENOTSQR); + } + else if (R->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (R->size2 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_memcpy (x, b); + + /* Solve R x = b, storing x inplace in b */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x); + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_R_svx (const gsl_matrix * R, gsl_vector * x) +{ + if (R->size1 != R->size2) + { + GSL_ERROR ("R matrix must be square", GSL_ENOTSQR); + } + else if (R->size2 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* Solve R x = b, storing x inplace in b */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x); + + return GSL_SUCCESS; + } +} + + + +/* Form the product Q^T v from a QR factorized matrix + */ + +int +gsl_linalg_QR_QTvec (const gsl_matrix * QR, const gsl_vector * tau, gsl_vector * v) +{ + const size_t M = QR->size1; + const size_t N = QR->size2; + + if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else if (v->size != M) + { + GSL_ERROR ("vector size must be N", GSL_EBADLEN); + } + else + { + size_t i; + + /* compute Q^T v */ + + for (i = 0; i < GSL_MIN (M, N); i++) + { + gsl_vector_const_view c = gsl_matrix_const_column (QR, i); + gsl_vector_const_view h = gsl_vector_const_subvector (&(c.vector), i, M - i); + gsl_vector_view w = gsl_vector_subvector (v, i, M - i); + double ti = gsl_vector_get (tau, i); + gsl_linalg_householder_hv (ti, &(h.vector), &(w.vector)); + } + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_QR_Qvec (const gsl_matrix * QR, const gsl_vector * tau, gsl_vector * v) +{ + const size_t M = QR->size1; + const size_t N = QR->size2; + + if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else if (v->size != M) + { + GSL_ERROR ("vector size must be N", GSL_EBADLEN); + } + else + { + size_t i; + + /* compute Q^T v */ + + for (i = GSL_MIN (M, N); i > 0 && i--;) + { + gsl_vector_const_view c = gsl_matrix_const_column (QR, i); + gsl_vector_const_view h = gsl_vector_const_subvector (&(c.vector), + i, M - i); + gsl_vector_view w = gsl_vector_subvector (v, i, M - i); + double ti = gsl_vector_get (tau, i); + gsl_linalg_householder_hv (ti, &h.vector, &w.vector); + } + return GSL_SUCCESS; + } +} + + +/* Form the orthogonal matrix Q from the packed QR matrix */ + +int +gsl_linalg_QR_unpack (const gsl_matrix * QR, const gsl_vector * tau, gsl_matrix * Q, gsl_matrix * R) +{ + const size_t M = QR->size1; + const size_t N = QR->size2; + + if (Q->size1 != M || Q->size2 != M) + { + GSL_ERROR ("Q matrix must be M x M", GSL_ENOTSQR); + } + else if (R->size1 != M || R->size2 != N) + { + GSL_ERROR ("R matrix must be M x N", GSL_ENOTSQR); + } + else if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else + { + size_t i, j; + + /* Initialize Q to the identity */ + + gsl_matrix_set_identity (Q); + + for (i = GSL_MIN (M, N); i > 0 && i--;) + { + gsl_vector_const_view c = gsl_matrix_const_column (QR, i); + gsl_vector_const_view h = gsl_vector_const_subvector (&c.vector, + i, M - i); + gsl_matrix_view m = gsl_matrix_submatrix (Q, i, i, M - i, M - i); + double ti = gsl_vector_get (tau, i); + gsl_linalg_householder_hm (ti, &h.vector, &m.matrix); + } + + /* Form the right triangular matrix R from a packed QR matrix */ + + for (i = 0; i < M; i++) + { + for (j = 0; j < i && j < N; j++) + gsl_matrix_set (R, i, j, 0.0); + + for (j = i; j < N; j++) + gsl_matrix_set (R, i, j, gsl_matrix_get (QR, i, j)); + } + + return GSL_SUCCESS; + } +} + + +/* Update a QR factorisation for A= Q R , A' = A + u v^T, + + * Q' R' = QR + u v^T + * = Q (R + Q^T u v^T) + * = Q (R + w v^T) + * + * where w = Q^T u. + * + * Algorithm from Golub and Van Loan, "Matrix Computations", Section + * 12.5 (Updating Matrix Factorizations, Rank-One Changes) + */ + +int +gsl_linalg_QR_update (gsl_matrix * Q, gsl_matrix * R, + gsl_vector * w, const gsl_vector * v) +{ + const size_t M = R->size1; + const size_t N = R->size2; + + if (Q->size1 != M || Q->size2 != M) + { + GSL_ERROR ("Q matrix must be M x M if R is M x N", GSL_ENOTSQR); + } + else if (w->size != M) + { + GSL_ERROR ("w must be length M if R is M x N", GSL_EBADLEN); + } + else if (v->size != N) + { + GSL_ERROR ("v must be length N if R is M x N", GSL_EBADLEN); + } + else + { + size_t j, k; + double w0; + + /* Apply Given's rotations to reduce w to (|w|, 0, 0, ... , 0) + + J_1^T .... J_(n-1)^T w = +/- |w| e_1 + + simultaneously applied to R, H = J_1^T ... J^T_(n-1) R + so that H is upper Hessenberg. (12.5.2) */ + + for (k = M - 1; k > 0; k--) + { + double c, s; + double wk = gsl_vector_get (w, k); + double wkm1 = gsl_vector_get (w, k - 1); + + create_givens (wkm1, wk, &c, &s); + apply_givens_vec (w, k - 1, k, c, s); + apply_givens_qr (M, N, Q, R, k - 1, k, c, s); + } + + w0 = gsl_vector_get (w, 0); + + /* Add in w v^T (Equation 12.5.3) */ + + for (j = 0; j < N; j++) + { + double r0j = gsl_matrix_get (R, 0, j); + double vj = gsl_vector_get (v, j); + gsl_matrix_set (R, 0, j, r0j + w0 * vj); + } + + /* Apply Givens transformations R' = G_(n-1)^T ... G_1^T H + Equation 12.5.4 */ + + for (k = 1; k < GSL_MIN(M,N+1); k++) + { + double c, s; + double diag = gsl_matrix_get (R, k - 1, k - 1); + double offdiag = gsl_matrix_get (R, k, k - 1); + + create_givens (diag, offdiag, &c, &s); + apply_givens_qr (M, N, Q, R, k - 1, k, c, s); + + gsl_matrix_set (R, k, k - 1, 0.0); /* exact zero of G^T */ + } + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_QR_QRsolve (gsl_matrix * Q, gsl_matrix * R, const gsl_vector * b, gsl_vector * x) +{ + const size_t M = R->size1; + const size_t N = R->size2; + + if (M != N) + { + return GSL_ENOTSQR; + } + else if (Q->size1 != M || b->size != M || x->size != M) + { + return GSL_EBADLEN; + } + else + { + /* compute sol = Q^T b */ + + gsl_blas_dgemv (CblasTrans, 1.0, Q, b, 0.0, x); + + /* Solve R x = sol, storing x in-place */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x); + + return GSL_SUCCESS; + } +} diff --git a/gsl-1.9/linalg/qrpt.c b/gsl-1.9/linalg/qrpt.c new file mode 100644 index 0000000..ac38547 --- /dev/null +++ b/gsl-1.9/linalg/qrpt.c @@ -0,0 +1,486 @@ +/* linalg/qrpt.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +#include <config.h> +#include <stdlib.h> +#include <string.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_permute_vector.h> +#include <gsl/gsl_blas.h> + +#include <gsl/gsl_linalg.h> + +#define REAL double + +#include "givens.c" +#include "apply_givens.c" + +/* Factorise a general M x N matrix A into + * + * A P = Q R + * + * where Q is orthogonal (M x M) and R is upper triangular (M x N). + * When A is rank deficient, r = rank(A) < n, then the permutation is + * used to ensure that the lower n - r rows of R are zero and the first + * r columns of Q form an orthonormal basis for A. + * + * Q is stored as a packed set of Householder transformations in the + * strict lower triangular part of the input matrix. + * + * R is stored in the diagonal and upper triangle of the input matrix. + * + * P: column j of P is column k of the identity matrix, where k = + * permutation->data[j] + * + * The full matrix for Q can be obtained as the product + * + * Q = Q_k .. Q_2 Q_1 + * + * where k = MIN(M,N) and + * + * Q_i = (I - tau_i * v_i * v_i') + * + * and where v_i is a Householder vector + * + * v_i = [1, m(i+1,i), m(i+2,i), ... , m(M,i)] + * + * This storage scheme is the same as in LAPACK. See LAPACK's + * dgeqpf.f for details. + * + */ + +int +gsl_linalg_QRPT_decomp (gsl_matrix * A, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm) +{ + const size_t M = A->size1; + const size_t N = A->size2; + + if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else if (p->size != N) + { + GSL_ERROR ("permutation size must be N", GSL_EBADLEN); + } + else if (norm->size != N) + { + GSL_ERROR ("norm size must be N", GSL_EBADLEN); + } + else + { + size_t i; + + *signum = 1; + + gsl_permutation_init (p); /* set to identity */ + + /* Compute column norms and store in workspace */ + + for (i = 0; i < N; i++) + { + gsl_vector_view c = gsl_matrix_column (A, i); + double x = gsl_blas_dnrm2 (&c.vector); + gsl_vector_set (norm, i, x); + } + + for (i = 0; i < GSL_MIN (M, N); i++) + { + /* Bring the column of largest norm into the pivot position */ + + double max_norm = gsl_vector_get(norm, i); + size_t j, kmax = i; + + for (j = i + 1; j < N; j++) + { + double x = gsl_vector_get (norm, j); + + if (x > max_norm) + { + max_norm = x; + kmax = j; + } + } + + if (kmax != i) + { + gsl_matrix_swap_columns (A, i, kmax); + gsl_permutation_swap (p, i, kmax); + gsl_vector_swap_elements(norm,i,kmax); + + (*signum) = -(*signum); + } + + /* Compute the Householder transformation to reduce the j-th + column of the matrix to a multiple of the j-th unit vector */ + + { + gsl_vector_view c_full = gsl_matrix_column (A, i); + gsl_vector_view c = gsl_vector_subvector (&c_full.vector, + i, M - i); + double tau_i = gsl_linalg_householder_transform (&c.vector); + + gsl_vector_set (tau, i, tau_i); + + /* Apply the transformation to the remaining columns */ + + if (i + 1 < N) + { + gsl_matrix_view m = gsl_matrix_submatrix (A, i, i + 1, M - i, N - (i+1)); + + gsl_linalg_householder_hm (tau_i, &c.vector, &m.matrix); + } + } + + /* Update the norms of the remaining columns too */ + + if (i + 1 < M) + { + for (j = i + 1; j < N; j++) + { + double x = gsl_vector_get (norm, j); + + if (x > 0.0) + { + double y = 0; + double temp= gsl_matrix_get (A, i, j) / x; + + if (fabs (temp) >= 1) + y = 0.0; + else + y = x * sqrt (1 - temp * temp); + + /* recompute norm to prevent loss of accuracy */ + + if (fabs (y / x) < sqrt (20.0) * GSL_SQRT_DBL_EPSILON) + { + gsl_vector_view c_full = gsl_matrix_column (A, j); + gsl_vector_view c = + gsl_vector_subvector(&c_full.vector, + i+1, M - (i+1)); + y = gsl_blas_dnrm2 (&c.vector); + } + + gsl_vector_set (norm, j, y); + } + } + } + } + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_QRPT_decomp2 (const gsl_matrix * A, gsl_matrix * q, gsl_matrix * r, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm) +{ + const size_t M = A->size1; + const size_t N = A->size2; + + if (q->size1 != M || q->size2 !=M) + { + GSL_ERROR ("q must be M x M", GSL_EBADLEN); + } + else if (r->size1 != M || r->size2 !=N) + { + GSL_ERROR ("r must be M x N", GSL_EBADLEN); + } + else if (tau->size != GSL_MIN (M, N)) + { + GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN); + } + else if (p->size != N) + { + GSL_ERROR ("permutation size must be N", GSL_EBADLEN); + } + else if (norm->size != N) + { + GSL_ERROR ("norm size must be N", GSL_EBADLEN); + } + + gsl_matrix_memcpy (r, A); + + gsl_linalg_QRPT_decomp (r, tau, p, signum, norm); + + /* FIXME: aliased arguments depends on behavior of unpack routine! */ + + gsl_linalg_QR_unpack (r, tau, q, r); + + return GSL_SUCCESS; +} + + +/* Solves the system A x = b using the Q R P^T factorisation, + + R z = Q^T b + + x = P z; + + to obtain x. Based on SLATEC code. */ + +int +gsl_linalg_QRPT_solve (const gsl_matrix * QR, + const gsl_vector * tau, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x) +{ + if (QR->size1 != QR->size2) + { + GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR); + } + else if (QR->size1 != p->size) + { + GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN); + } + else if (QR->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (QR->size2 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + gsl_vector_memcpy (x, b); + + gsl_linalg_QRPT_svx (QR, tau, p, x); + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_QRPT_svx (const gsl_matrix * QR, + const gsl_vector * tau, + const gsl_permutation * p, + gsl_vector * x) +{ + if (QR->size1 != QR->size2) + { + GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR); + } + else if (QR->size1 != p->size) + { + GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN); + } + else if (QR->size2 != x->size) + { + GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN); + } + else + { + /* compute sol = Q^T b */ + + gsl_linalg_QR_QTvec (QR, tau, x); + + /* Solve R x = sol, storing x inplace in sol */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x); + + gsl_permute_vector_inverse (p, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_QRPT_QRsolve (const gsl_matrix * Q, const gsl_matrix * R, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x) +{ + if (Q->size1 != Q->size2 || R->size1 != R->size2) + { + return GSL_ENOTSQR; + } + else if (Q->size1 != p->size || Q->size1 != R->size1 + || Q->size1 != b->size) + { + return GSL_EBADLEN; + } + else + { + /* compute b' = Q^T b */ + + gsl_blas_dgemv (CblasTrans, 1.0, Q, b, 0.0, x); + + /* Solve R x = b', storing x inplace */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x); + + /* Apply permutation to solution in place */ + + gsl_permute_vector_inverse (p, x); + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_QRPT_Rsolve (const gsl_matrix * QR, + const gsl_permutation * p, + const gsl_vector * b, + gsl_vector * x) +{ + if (QR->size1 != QR->size2) + { + GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR); + } + else if (QR->size1 != b->size) + { + GSL_ERROR ("matrix size must match b size", GSL_EBADLEN); + } + else if (QR->size2 != x->size) + { + GSL_ERROR ("matrix size must match x size", GSL_EBADLEN); + } + else if (p->size != x->size) + { + GSL_ERROR ("permutation size must match x size", GSL_EBADLEN); + } + else + { + /* Copy x <- b */ + + gsl_vector_memcpy (x, b); + + /* Solve R x = b, storing x inplace */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x); + + gsl_permute_vector_inverse (p, x); + + return GSL_SUCCESS; + } +} + + +int +gsl_linalg_QRPT_Rsvx (const gsl_matrix * QR, + const gsl_permutation * p, + gsl_vector * x) +{ + if (QR->size1 != QR->size2) + { + GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR); + } + else if (QR->size2 != x->size) + { + GSL_ERROR ("matrix size must match x size", GSL_EBADLEN); + } + else if (p->size != x->size) + { + GSL_ERROR ("permutation size must match x size", GSL_EBADLEN); + } + else + { + /* Solve R x = b, storing x inplace */ + + gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x); + + gsl_permute_vector_inverse (p, x); + + return GSL_SUCCESS; + } +} + + + +/* Update a Q R P^T factorisation for A P= Q R , A' = A + u v^T, + + Q' R' P^-1 = QR P^-1 + u v^T + = Q (R + Q^T u v^T P ) P^-1 + = Q (R + w v^T P) P^-1 + + where w = Q^T u. + + Algorithm from Golub and Van Loan, "Matrix Computations", Section + 12.5 (Updating Matrix Factorizations, Rank-One Changes) */ + +int +gsl_linalg_QRPT_update (gsl_matrix * Q, gsl_matrix * R, + const gsl_permutation * p, + gsl_vector * w, const gsl_vector * v) +{ + if (Q->size1 != Q->size2 || R->size1 != R->size2) + { + return GSL_ENOTSQR; + } + else if (R->size1 != Q->size2 || v->size != Q->size2 || w->size != Q->size2) + { + return GSL_EBADLEN; + } + else + { + size_t j, k; + const size_t M = Q->size1; + const size_t N = Q->size2; + double w0; + + /* Apply Given's rotations to reduce w to (|w|, 0, 0, ... , 0) + + J_1^T .... J_(n-1)^T w = +/- |w| e_1 + + simultaneously applied to R, H = J_1^T ... J^T_(n-1) R + so that H is upper Hessenberg. (12.5.2) */ + + for (k = N - 1; k > 0; k--) + { + double c, s; + double wk = gsl_vector_get (w, k); + double wkm1 = gsl_vector_get (w, k - 1); + + create_givens (wkm1, wk, &c, &s); + apply_givens_vec (w, k - 1, k, c, s); + apply_givens_qr (M, N, Q, R, k - 1, k, c, s); + } + + w0 = gsl_vector_get (w, 0); + + /* Add in w v^T (Equation 12.5.3) */ + + for (j = 0; j < N; j++) + { + double r0j = gsl_matrix_get (R, 0, j); + size_t p_j = gsl_permutation_get (p, j); + double vj = gsl_vector_get (v, p_j); + gsl_matrix_set (R, 0, j, r0j + w0 * vj); + } + + /* Apply Givens transformations R' = G_(n-1)^T ... G_1^T H + Equation 12.5.4 */ + + for (k = 1; k < N; k++) + { + double c, s; + double diag = gsl_matrix_get (R, k - 1, k - 1); + double offdiag = gsl_matrix_get (R, k, k - 1); + + create_givens (diag, offdiag, &c, &s); + apply_givens_qr (M, N, Q, R, k - 1, k, c, s); + } + + return GSL_SUCCESS; + } +} diff --git a/gsl-1.9/linalg/svd.c b/gsl-1.9/linalg/svd.c new file mode 100644 index 0000000..cd5588a --- /dev/null +++ b/gsl-1.9/linalg/svd.c @@ -0,0 +1,620 @@ +/* linalg/svd.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2004 Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +#include <config.h> +#include <stdlib.h> +#include <string.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> + +#include <gsl/gsl_linalg.h> + +#include "givens.c" +#include "svdstep.c" + +/* Factorise a general M x N matrix A into, + * + * A = U D V^T + * + * where U is a column-orthogonal M x N matrix (U^T U = I), + * D is a diagonal N x N matrix, + * and V is an N x N orthogonal matrix (V^T V = V V^T = I) + * + * U is stored in the original matrix A, which has the same size + * + * V is stored as a separate matrix (not V^T). You must take the + * transpose to form the product above. + * + * The diagonal matrix D is stored in the vector S, D_ii = S_i + */ + +int +gsl_linalg_SV_decomp (gsl_matrix * A, gsl_matrix * V, gsl_vector * S, + gsl_vector * work) +{ + size_t a, b, i, j; + + const size_t M = A->size1; + const size_t N = A->size2; + const size_t K = GSL_MIN (M, N); + + if (M < N) + { + GSL_ERROR ("svd of MxN matrix, M<N, is not implemented", GSL_EUNIMPL); + } + else if (V->size1 != N) + { + GSL_ERROR ("square matrix V must match second dimension of matrix A", + GSL_EBADLEN); + } + else if (V->size1 != V->size2) + { + GSL_ERROR ("matrix V must be square", GSL_ENOTSQR); + } + else if (S->size != N) + { + GSL_ERROR ("length of vector S must match second dimension of matrix A", + GSL_EBADLEN); + } + else if (work->size != N) + { + GSL_ERROR ("length of workspace must match second dimension of matrix A", + GSL_EBADLEN); + } + + /* Handle the case of N = 1 (SVD of a column vector) */ + + if (N == 1) + { + gsl_vector_view column = gsl_matrix_column (A, 0); + double norm = gsl_blas_dnrm2 (&column.vector); + + gsl_vector_set (S, 0, norm); + gsl_matrix_set (V, 0, 0, 1.0); + + if (norm != 0.0) + { + gsl_blas_dscal (1.0/norm, &column.vector); + } + + return GSL_SUCCESS; + } + + { + gsl_vector_view f = gsl_vector_subvector (work, 0, K - 1); + + /* bidiagonalize matrix A, unpack A into U S V */ + + gsl_linalg_bidiag_decomp (A, S, &f.vector); + gsl_linalg_bidiag_unpack2 (A, S, &f.vector, V); + + /* apply reduction steps to B=(S,Sd) */ + + chop_small_elements (S, &f.vector); + + /* Progressively reduce the matrix until it is diagonal */ + + b = N - 1; + + while (b > 0) + { + double fbm1 = gsl_vector_get (&f.vector, b - 1); + + if (fbm1 == 0.0 || gsl_isnan (fbm1)) + { + b--; + continue; + } + + /* Find the largest unreduced block (a,b) starting from b + and working backwards */ + + a = b - 1; + + while (a > 0) + { + double fam1 = gsl_vector_get (&f.vector, a - 1); + + if (fam1 == 0.0 || gsl_isnan (fam1)) + { + break; + } + + a--; + } + + { + const size_t n_block = b - a + 1; + gsl_vector_view S_block = gsl_vector_subvector (S, a, n_block); + gsl_vector_view f_block = gsl_vector_subvector (&f.vector, a, n_block - 1); + + gsl_matrix_view U_block = + gsl_matrix_submatrix (A, 0, a, A->size1, n_block); + gsl_matrix_view V_block = + gsl_matrix_submatrix (V, 0, a, V->size1, n_block); + + qrstep (&S_block.vector, &f_block.vector, &U_block.matrix, &V_block.matrix); + + /* remove any small off-diagonal elements */ + + chop_small_elements (&S_block.vector, &f_block.vector); + } + } + } + /* Make singular values positive by reflections if necessary */ + + for (j = 0; j < K; j++) + { + double Sj = gsl_vector_get (S, j); + + if (Sj < 0.0) + { + for (i = 0; i < N; i++) + { + double Vij = gsl_matrix_get (V, i, j); + gsl_matrix_set (V, i, j, -Vij); + } + + gsl_vector_set (S, j, -Sj); + } + } + + /* Sort singular values into decreasing order */ + + for (i = 0; i < K; i++) + { + double S_max = gsl_vector_get (S, i); + size_t i_max = i; + + for (j = i + 1; j < K; j++) + { + double Sj = gsl_vector_get (S, j); + + if (Sj > S_max) + { + S_max = Sj; + i_max = j; + } + } + + if (i_max != i) + { + /* swap eigenvalues */ + gsl_vector_swap_elements (S, i, i_max); + + /* swap eigenvectors */ + gsl_matrix_swap_columns (A, i, i_max); + gsl_matrix_swap_columns (V, i, i_max); + } + } + + return GSL_SUCCESS; +} + + +/* Modified algorithm which is better for M>>N */ + +int +gsl_linalg_SV_decomp_mod (gsl_matrix * A, + gsl_matrix * X, + gsl_matrix * V, gsl_vector * S, gsl_vector * work) +{ + size_t i, j; + + const size_t M = A->size1; + const size_t N = A->size2; + + if (M < N) + { + GSL_ERROR ("svd of MxN matrix, M<N, is not implemented", GSL_EUNIMPL); + } + else if (V->size1 != N) + { + GSL_ERROR ("square matrix V must match second dimension of matrix A", + GSL_EBADLEN); + } + else if (V->size1 != V->size2) + { + GSL_ERROR ("matrix V must be square", GSL_ENOTSQR); + } + else if (X->size1 != N) + { + GSL_ERROR ("square matrix X must match second dimension of matrix A", + GSL_EBADLEN); + } + else if (X->size1 != X->size2) + { + GSL_ERROR ("matrix X must be square", GSL_ENOTSQR); + } + else if (S->size != N) + { + GSL_ERROR ("length of vector S must match second dimension of matrix A", + GSL_EBADLEN); + } + else if (work->size != N) + { + GSL_ERROR ("length of workspace must match second dimension of matrix A", + GSL_EBADLEN); + } + + if (N == 1) + { + gsl_vector_view column = gsl_matrix_column (A, 0); + double norm = gsl_blas_dnrm2 (&column.vector); + + gsl_vector_set (S, 0, norm); + gsl_matrix_set (V, 0, 0, 1.0); + + if (norm != 0.0) + { + gsl_blas_dscal (1.0/norm, &column.vector); + } + + return GSL_SUCCESS; + } + + /* Convert A into an upper triangular matrix R */ + + for (i = 0; i < N; i++) + { + gsl_vector_view c = gsl_matrix_column (A, i); + gsl_vector_view v = gsl_vector_subvector (&c.vector, i, M - i); + double tau_i = gsl_linalg_householder_transform (&v.vector); + + /* Apply the transformation to the remaining columns */ + + if (i + 1 < N) + { + gsl_matrix_view m = + gsl_matrix_submatrix (A, i, i + 1, M - i, N - (i + 1)); + gsl_linalg_householder_hm (tau_i, &v.vector, &m.matrix); + } + + gsl_vector_set (S, i, tau_i); + } + + /* Copy the upper triangular part of A into X */ + + for (i = 0; i < N; i++) + { + for (j = 0; j < i; j++) + { + gsl_matrix_set (X, i, j, 0.0); + } + + { + double Aii = gsl_matrix_get (A, i, i); + gsl_matrix_set (X, i, i, Aii); + } + + for (j = i + 1; j < N; j++) + { + double Aij = gsl_matrix_get (A, i, j); + gsl_matrix_set (X, i, j, Aij); + } + } + + /* Convert A into an orthogonal matrix L */ + + for (j = N; j > 0 && j--;) + { + /* Householder column transformation to accumulate L */ + double tj = gsl_vector_get (S, j); + gsl_matrix_view m = gsl_matrix_submatrix (A, j, j, M - j, N - j); + gsl_linalg_householder_hm1 (tj, &m.matrix); + } + + /* unpack R into X V S */ + + gsl_linalg_SV_decomp (X, V, S, work); + + /* Multiply L by X, to obtain U = L X, stored in U */ + + { + gsl_vector_view sum = gsl_vector_subvector (work, 0, N); + + for (i = 0; i < M; i++) + { + gsl_vector_view L_i = gsl_matrix_row (A, i); + gsl_vector_set_zero (&sum.vector); + + for (j = 0; j < N; j++) + { + double Lij = gsl_vector_get (&L_i.vector, j); + gsl_vector_view X_j = gsl_matrix_row (X, j); + gsl_blas_daxpy (Lij, &X_j.vector, &sum.vector); + } + + gsl_vector_memcpy (&L_i.vector, &sum.vector); + } + } + + return GSL_SUCCESS; +} + + +/* Solves the system A x = b using the SVD factorization + * + * A = U S V^T + * + * to obtain x. For M x N systems it finds the solution in the least + * squares sense. + */ + +int +gsl_linalg_SV_solve (const gsl_matrix * U, + const gsl_matrix * V, + const gsl_vector * S, + const gsl_vector * b, gsl_vector * x) +{ + if (U->size1 != b->size) + { + GSL_ERROR ("first dimension of matrix U must size of vector b", + GSL_EBADLEN); + } + else if (U->size2 != S->size) + { + GSL_ERROR ("length of vector S must match second dimension of matrix U", + GSL_EBADLEN); + } + else if (V->size1 != V->size2) + { + GSL_ERROR ("matrix V must be square", GSL_ENOTSQR); + } + else if (S->size != V->size1) + { + GSL_ERROR ("length of vector S must match size of matrix V", + GSL_EBADLEN); + } + else if (V->size2 != x->size) + { + GSL_ERROR ("size of matrix V must match size of vector x", GSL_EBADLEN); + } + else + { + const size_t N = U->size2; + size_t i; + + gsl_vector *w = gsl_vector_calloc (N); + + gsl_blas_dgemv (CblasTrans, 1.0, U, b, 0.0, w); + + for (i = 0; i < N; i++) + { + double wi = gsl_vector_get (w, i); + double alpha = gsl_vector_get (S, i); + if (alpha != 0) + alpha = 1.0 / alpha; + gsl_vector_set (w, i, alpha * wi); + } + + gsl_blas_dgemv (CblasNoTrans, 1.0, V, w, 0.0, x); + + gsl_vector_free (w); + + return GSL_SUCCESS; + } +} + +/* This is a the jacobi version */ +/* Author: G. Jungman */ + +/* + * Algorithm due to J.C. Nash, Compact Numerical Methods for + * Computers (New York: Wiley and Sons, 1979), chapter 3. + * See also Algorithm 4.1 in + * James Demmel, Kresimir Veselic, "Jacobi's Method is more + * accurate than QR", Lapack Working Note 15 (LAWN15), October 1989. + * Available from netlib. + * + * Based on code by Arthur Kosowsky, Rutgers University + * kosowsky@physics.rutgers.edu + * + * Another relevant paper is, P.P.M. De Rijk, "A One-Sided Jacobi + * Algorithm for computing the singular value decomposition on a + * vector computer", SIAM Journal of Scientific and Statistical + * Computing, Vol 10, No 2, pp 359-371, March 1989. + * + */ + +int +gsl_linalg_SV_decomp_jacobi (gsl_matrix * A, gsl_matrix * Q, gsl_vector * S) +{ + if (A->size1 < A->size2) + { + /* FIXME: only implemented M>=N case so far */ + + GSL_ERROR ("svd of MxN matrix, M<N, is not implemented", GSL_EUNIMPL); + } + else if (Q->size1 != A->size2) + { + GSL_ERROR ("square matrix Q must match second dimension of matrix A", + GSL_EBADLEN); + } + else if (Q->size1 != Q->size2) + { + GSL_ERROR ("matrix Q must be square", GSL_ENOTSQR); + } + else if (S->size != A->size2) + { + GSL_ERROR ("length of vector S must match second dimension of matrix A", + GSL_EBADLEN); + } + else + { + const size_t M = A->size1; + const size_t N = A->size2; + size_t i, j, k; + + /* Initialize the rotation counter and the sweep counter. */ + int count = 1; + int sweep = 0; + int sweepmax = 5*N; + + double tolerance = 10 * M * GSL_DBL_EPSILON; + + /* Always do at least 12 sweeps. */ + sweepmax = GSL_MAX (sweepmax, 12); + + /* Set Q to the identity matrix. */ + gsl_matrix_set_identity (Q); + + /* Store the column error estimates in S, for use during the + orthogonalization */ + + for (j = 0; j < N; j++) + { + gsl_vector_view cj = gsl_matrix_column (A, j); + double sj = gsl_blas_dnrm2 (&cj.vector); + gsl_vector_set(S, j, GSL_DBL_EPSILON * sj); + } + + /* Orthogonalize A by plane rotations. */ + + while (count > 0 && sweep <= sweepmax) + { + /* Initialize rotation counter. */ + count = N * (N - 1) / 2; + + for (j = 0; j < N - 1; j++) + { + for (k = j + 1; k < N; k++) + { + double a = 0.0; + double b = 0.0; + double p = 0.0; + double q = 0.0; + double cosine, sine; + double v; + double abserr_a, abserr_b; + int sorted, orthog, noisya, noisyb; + + gsl_vector_view cj = gsl_matrix_column (A, j); + gsl_vector_view ck = gsl_matrix_column (A, k); + + gsl_blas_ddot (&cj.vector, &ck.vector, &p); + p *= 2.0 ; /* equation 9a: p = 2 x.y */ + + a = gsl_blas_dnrm2 (&cj.vector); + b = gsl_blas_dnrm2 (&ck.vector); + + q = a * a - b * b; + v = hypot(p, q); + + /* test for columns j,k orthogonal, or dominant errors */ + + abserr_a = gsl_vector_get(S,j); + abserr_b = gsl_vector_get(S,k); + + sorted = (gsl_coerce_double(a) >= gsl_coerce_double(b)); + orthog = (fabs (p) <= tolerance * gsl_coerce_double(a * b)); + noisya = (a < abserr_a); + noisyb = (b < abserr_b); + + if (sorted && (orthog || noisya || noisyb)) + { + count--; + continue; + } + + /* calculate rotation angles */ + if (v == 0 || !sorted) + { + cosine = 0.0; + sine = 1.0; + } + else + { + cosine = sqrt((v + q) / (2.0 * v)); + sine = p / (2.0 * v * cosine); + } + + /* apply rotation to A */ + for (i = 0; i < M; i++) + { + const double Aik = gsl_matrix_get (A, i, k); + const double Aij = gsl_matrix_get (A, i, j); + gsl_matrix_set (A, i, j, Aij * cosine + Aik * sine); + gsl_matrix_set (A, i, k, -Aij * sine + Aik * cosine); + } + + gsl_vector_set(S, j, fabs(cosine) * abserr_a + fabs(sine) * abserr_b); + gsl_vector_set(S, k, fabs(sine) * abserr_a + fabs(cosine) * abserr_b); + + /* apply rotation to Q */ + for (i = 0; i < N; i++) + { + const double Qij = gsl_matrix_get (Q, i, j); + const double Qik = gsl_matrix_get (Q, i, k); + gsl_matrix_set (Q, i, j, Qij * cosine + Qik * sine); + gsl_matrix_set (Q, i, k, -Qij * sine + Qik * cosine); + } + } + } + + /* Sweep completed. */ + sweep++; + } + + /* + * Orthogonalization complete. Compute singular values. + */ + + { + double prev_norm = -1.0; + + for (j = 0; j < N; j++) + { + gsl_vector_view column = gsl_matrix_column (A, j); + double norm = gsl_blas_dnrm2 (&column.vector); + + /* Determine if singular value is zero, according to the + criteria used in the main loop above (i.e. comparison + with norm of previous column). */ + + if (norm == 0.0 || prev_norm == 0.0 + || (j > 0 && norm <= tolerance * prev_norm)) + { + gsl_vector_set (S, j, 0.0); /* singular */ + gsl_vector_set_zero (&column.vector); /* annihilate column */ + + prev_norm = 0.0; + } + else + { + gsl_vector_set (S, j, norm); /* non-singular */ + gsl_vector_scale (&column.vector, 1.0 / norm); /* normalize column */ + + prev_norm = norm; + } + } + } + + if (count > 0) + { + /* reached sweep limit */ + GSL_ERROR ("Jacobi iterations did not reach desired tolerance", + GSL_ETOL); + } + + return GSL_SUCCESS; + } +} diff --git a/gsl-1.9/linalg/svdstep.c b/gsl-1.9/linalg/svdstep.c new file mode 100644 index 0000000..a47c741 --- /dev/null +++ b/gsl-1.9/linalg/svdstep.c @@ -0,0 +1,519 @@ +static void +chop_small_elements (gsl_vector * d, gsl_vector * f) +{ + const size_t N = d->size; + double d_i = gsl_vector_get (d, 0); + + size_t i; + + for (i = 0; i < N - 1; i++) + { + double f_i = gsl_vector_get (f, i); + double d_ip1 = gsl_vector_get (d, i + 1); + + if (fabs (f_i) < GSL_DBL_EPSILON * (fabs (d_i) + fabs (d_ip1))) + { + gsl_vector_set (f, i, 0.0); + } + d_i = d_ip1; + } + +} + +static double +trailing_eigenvalue (const gsl_vector * d, const gsl_vector * f) +{ + const size_t n = d->size; + + double da = gsl_vector_get (d, n - 2); + double db = gsl_vector_get (d, n - 1); + double fa = (n > 2) ? gsl_vector_get (f, n - 3) : 0.0; + double fb = gsl_vector_get (f, n - 2); + + double ta = da * da + fa * fa; + double tb = db * db + fb * fb; + double tab = da * fb; + + double dt = (ta - tb) / 2.0; + + double mu; + + if (dt >= 0) + { + mu = tb - (tab * tab) / (dt + hypot (dt, tab)); + } + else + { + mu = tb + (tab * tab) / ((-dt) + hypot (dt, tab)); + } + + return mu; +} + +static void +create_schur (double d0, double f0, double d1, double * c, double * s) +{ + double apq = 2.0 * d0 * f0; + + if (apq != 0.0) + { + double t; + double tau = (f0*f0 + (d1 + d0)*(d1 - d0)) / apq; + + if (tau >= 0.0) + { + t = 1.0/(tau + hypot(1.0, tau)); + } + else + { + t = -1.0/(-tau + hypot(1.0, tau)); + } + + *c = 1.0 / hypot(1.0, t); + *s = t * (*c); + } + else + { + *c = 1.0; + *s = 0.0; + } +} + +static void +svd2 (gsl_vector * d, gsl_vector * f, gsl_matrix * U, gsl_matrix * V) +{ + size_t i; + double c, s, a11, a12, a21, a22; + + const size_t M = U->size1; + const size_t N = V->size1; + + double d0 = gsl_vector_get (d, 0); + double f0 = gsl_vector_get (f, 0); + + double d1 = gsl_vector_get (d, 1); + + if (d0 == 0.0) + { + /* Eliminate off-diagonal element in [0,f0;0,d1] to make [d,0;0,0] */ + + create_givens (f0, d1, &c, &s); + + /* compute B <= G^T B X, where X = [0,1;1,0] */ + + gsl_vector_set (d, 0, c * f0 - s * d1); + gsl_vector_set (f, 0, s * f0 + c * d1); + gsl_vector_set (d, 1, 0.0); + + /* Compute U <= U G */ + + for (i = 0; i < M; i++) + { + double Uip = gsl_matrix_get (U, i, 0); + double Uiq = gsl_matrix_get (U, i, 1); + gsl_matrix_set (U, i, 0, c * Uip - s * Uiq); + gsl_matrix_set (U, i, 1, s * Uip + c * Uiq); + } + + /* Compute V <= V X */ + + gsl_matrix_swap_columns (V, 0, 1); + + return; + } + else if (d1 == 0.0) + { + /* Eliminate off-diagonal element in [d0,f0;0,0] */ + + create_givens (d0, f0, &c, &s); + + /* compute B <= B G */ + + gsl_vector_set (d, 0, d0 * c - f0 * s); + gsl_vector_set (f, 0, 0.0); + + /* Compute V <= V G */ + + for (i = 0; i < N; i++) + { + double Vip = gsl_matrix_get (V, i, 0); + double Viq = gsl_matrix_get (V, i, 1); + gsl_matrix_set (V, i, 0, c * Vip - s * Viq); + gsl_matrix_set (V, i, 1, s * Vip + c * Viq); + } + + return; + } + else + { + /* Make columns orthogonal, A = [d0, f0; 0, d1] * G */ + + create_schur (d0, f0, d1, &c, &s); + + /* compute B <= B G */ + + a11 = c * d0 - s * f0; + a21 = - s * d1; + + a12 = s * d0 + c * f0; + a22 = c * d1; + + /* Compute V <= V G */ + + for (i = 0; i < N; i++) + { + double Vip = gsl_matrix_get (V, i, 0); + double Viq = gsl_matrix_get (V, i, 1); + gsl_matrix_set (V, i, 0, c * Vip - s * Viq); + gsl_matrix_set (V, i, 1, s * Vip + c * Viq); + } + + /* Eliminate off-diagonal elements, bring column with largest + norm to first column */ + + if (hypot(a11, a21) < hypot(a12,a22)) + { + double t1, t2; + + /* B <= B X */ + + t1 = a11; a11 = a12; a12 = t1; + t2 = a21; a21 = a22; a22 = t2; + + /* V <= V X */ + + gsl_matrix_swap_columns(V, 0, 1); + } + + create_givens (a11, a21, &c, &s); + + /* compute B <= G^T B */ + + gsl_vector_set (d, 0, c * a11 - s * a21); + gsl_vector_set (f, 0, c * a12 - s * a22); + gsl_vector_set (d, 1, s * a12 + c * a22); + + /* Compute U <= U G */ + + for (i = 0; i < M; i++) + { + double Uip = gsl_matrix_get (U, i, 0); + double Uiq = gsl_matrix_get (U, i, 1); + gsl_matrix_set (U, i, 0, c * Uip - s * Uiq); + gsl_matrix_set (U, i, 1, s * Uip + c * Uiq); + } + + return; + } +} + + +static void +chase_out_intermediate_zero (gsl_vector * d, gsl_vector * f, gsl_matrix * U, size_t k0) +{ +#if !USE_BLAS + const size_t M = U->size1; +#endif + const size_t n = d->size; + double c, s; + double x, y; + size_t k; + + x = gsl_vector_get (f, k0); + y = gsl_vector_get (d, k0+1); + + for (k = k0; k < n - 1; k++) + { + create_givens (y, -x, &c, &s); + + /* Compute U <= U G */ + +#ifdef USE_BLAS + { + gsl_vector_view Uk0 = gsl_matrix_column(U,k0); + gsl_vector_view Ukp1 = gsl_matrix_column(U,k+1); + gsl_blas_drot(&Uk0.vector, &Ukp1.vector, c, -s); + } +#else + { + size_t i; + + for (i = 0; i < M; i++) + { + double Uip = gsl_matrix_get (U, i, k0); + double Uiq = gsl_matrix_get (U, i, k + 1); + gsl_matrix_set (U, i, k0, c * Uip - s * Uiq); + gsl_matrix_set (U, i, k + 1, s * Uip + c * Uiq); + } + } +#endif + + /* compute B <= G^T B */ + + gsl_vector_set (d, k + 1, s * x + c * y); + + if (k == k0) + gsl_vector_set (f, k, c * x - s * y ); + + if (k < n - 2) + { + double z = gsl_vector_get (f, k + 1); + gsl_vector_set (f, k + 1, c * z); + + x = -s * z ; + y = gsl_vector_get (d, k + 2); + } + } +} + +static void +chase_out_trailing_zero (gsl_vector * d, gsl_vector * f, gsl_matrix * V) +{ +#if !USE_BLAS + const size_t N = V->size1; +#endif + const size_t n = d->size; + double c, s; + double x, y; + size_t k; + + x = gsl_vector_get (d, n - 2); + y = gsl_vector_get (f, n - 2); + + for (k = n - 1; k > 0 && k--;) + { + create_givens (x, y, &c, &s); + + /* Compute V <= V G where G = [c, s ; -s, c] */ + +#ifdef USE_BLAS + { + gsl_vector_view Vp = gsl_matrix_column(V,k); + gsl_vector_view Vq = gsl_matrix_column(V,n-1); + gsl_blas_drot(&Vp.vector, &Vq.vector, c, -s); + } +#else + { + size_t i; + + for (i = 0; i < N; i++) + { + double Vip = gsl_matrix_get (V, i, k); + double Viq = gsl_matrix_get (V, i, n - 1); + gsl_matrix_set (V, i, k, c * Vip - s * Viq); + gsl_matrix_set (V, i, n - 1, s * Vip + c * Viq); + } + } +#endif + + /* compute B <= B G */ + + gsl_vector_set (d, k, c * x - s * y); + + if (k == n - 2) + gsl_vector_set (f, k, s * x + c * y ); + + if (k > 0) + { + double z = gsl_vector_get (f, k - 1); + gsl_vector_set (f, k - 1, c * z); + + x = gsl_vector_get (d, k - 1); + y = s * z ; + } + } +} + +static void +qrstep (gsl_vector * d, gsl_vector * f, gsl_matrix * U, gsl_matrix * V) +{ +#if !USE_BLAS + const size_t M = U->size1; + const size_t N = V->size1; +#endif + const size_t n = d->size; + double y, z; + double ak, bk, zk, ap, bp, aq, bq; + size_t i, k; + + if (n == 1) + return; /* shouldn't happen */ + + /* Compute 2x2 svd directly */ + + if (n == 2) + { + svd2 (d, f, U, V); + return; + } + + /* Chase out any zeroes on the diagonal */ + + for (i = 0; i < n - 1; i++) + { + double d_i = gsl_vector_get (d, i); + + if (d_i == 0.0) + { + chase_out_intermediate_zero (d, f, U, i); + return; + } + } + + /* Chase out any zero at the end of the diagonal */ + + { + double d_nm1 = gsl_vector_get (d, n - 1); + + if (d_nm1 == 0.0) + { + chase_out_trailing_zero (d, f, V); + return; + } + } + + + /* Apply QR reduction steps to the diagonal and offdiagonal */ + + { + double d0 = gsl_vector_get (d, 0); + double f0 = gsl_vector_get (f, 0); + + double d1 = gsl_vector_get (d, 1); + double f1 = gsl_vector_get (f, 1); + + { + double mu = trailing_eigenvalue (d, f); + + y = d0 * d0 - mu; + z = d0 * f0; + } + + /* Set up the recurrence for Givens rotations on a bidiagonal matrix */ + + ak = 0; + bk = 0; + + ap = d0; + bp = f0; + + aq = d1; + bq = f1; + } + + for (k = 0; k < n - 1; k++) + { + double c, s; + create_givens (y, z, &c, &s); + + /* Compute V <= V G */ + +#ifdef USE_BLAS + { + gsl_vector_view Vk = gsl_matrix_column(V,k); + gsl_vector_view Vkp1 = gsl_matrix_column(V,k+1); + gsl_blas_drot(&Vk.vector, &Vkp1.vector, c, -s); + } +#else + for (i = 0; i < N; i++) + { + double Vip = gsl_matrix_get (V, i, k); + double Viq = gsl_matrix_get (V, i, k + 1); + gsl_matrix_set (V, i, k, c * Vip - s * Viq); + gsl_matrix_set (V, i, k + 1, s * Vip + c * Viq); + } +#endif + + /* compute B <= B G */ + + { + double bk1 = c * bk - s * z; + + double ap1 = c * ap - s * bp; + double bp1 = s * ap + c * bp; + double zp1 = -s * aq; + + double aq1 = c * aq; + + if (k > 0) + { + gsl_vector_set (f, k - 1, bk1); + } + + ak = ap1; + bk = bp1; + zk = zp1; + + ap = aq1; + + if (k < n - 2) + { + bp = gsl_vector_get (f, k + 1); + } + else + { + bp = 0.0; + } + + y = ak; + z = zk; + } + + create_givens (y, z, &c, &s); + + /* Compute U <= U G */ + +#ifdef USE_BLAS + { + gsl_vector_view Uk = gsl_matrix_column(U,k); + gsl_vector_view Ukp1 = gsl_matrix_column(U,k+1); + gsl_blas_drot(&Uk.vector, &Ukp1.vector, c, -s); + } +#else + for (i = 0; i < M; i++) + { + double Uip = gsl_matrix_get (U, i, k); + double Uiq = gsl_matrix_get (U, i, k + 1); + gsl_matrix_set (U, i, k, c * Uip - s * Uiq); + gsl_matrix_set (U, i, k + 1, s * Uip + c * Uiq); + } +#endif + + /* compute B <= G^T B */ + + { + double ak1 = c * ak - s * zk; + double bk1 = c * bk - s * ap; + double zk1 = -s * bp; + + double ap1 = s * bk + c * ap; + double bp1 = c * bp; + + gsl_vector_set (d, k, ak1); + + ak = ak1; + bk = bk1; + zk = zk1; + + ap = ap1; + bp = bp1; + + if (k < n - 2) + { + aq = gsl_vector_get (d, k + 2); + } + else + { + aq = 0.0; + } + + y = bk; + z = zk; + } + } + + gsl_vector_set (f, n - 2, bk); + gsl_vector_set (d, n - 1, ap); +} + + diff --git a/gsl-1.9/linalg/symmtd.c b/gsl-1.9/linalg/symmtd.c new file mode 100644 index 0000000..77356b9 --- /dev/null +++ b/gsl-1.9/linalg/symmtd.c @@ -0,0 +1,232 @@ +/* linalg/sytd.c + * + * Copyright (C) 2001 Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Factorise a symmetric matrix A into + * + * A = Q T Q' + * + * where Q is orthogonal and T is symmetric tridiagonal. Only the + * diagonal and lower triangular part of A is referenced and modified. + * + * On exit, T is stored in the diagonal and first subdiagonal of + * A. Since T is symmetric the upper diagonal is not stored. + * + * Q is stored as a packed set of Householder transformations in the + * lower triangular part of the input matrix below the first subdiagonal. + * + * The full matrix for Q can be obtained as the product + * + * Q = Q_1 Q_2 ... Q_(N-2) + * + * where + * + * Q_i = (I - tau_i * v_i * v_i') + * + * and where v_i is a Householder vector + * + * v_i = [0, ... , 0, 1, A(i+1,i), A(i+2,i), ... , A(N,i)] + * + * This storage scheme is the same as in LAPACK. See LAPACK's + * ssytd2.f for details. + * + * See Golub & Van Loan, "Matrix Computations" (3rd ed), Section 8.3 + * + * Note: this description uses 1-based indices. The code below uses + * 0-based indices + */ + +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_vector.h> +#include <gsl/gsl_matrix.h> +#include <gsl/gsl_blas.h> + +#include <gsl/gsl_linalg.h> + +int +gsl_linalg_symmtd_decomp (gsl_matrix * A, gsl_vector * tau) +{ + if (A->size1 != A->size2) + { + GSL_ERROR ("symmetric tridiagonal decomposition requires square matrix", + GSL_ENOTSQR); + } + else if (tau->size + 1 != A->size1) + { + GSL_ERROR ("size of tau must be (matrix size - 1)", GSL_EBADLEN); + } + else + { + const size_t N = A->size1; + size_t i; + + for (i = 0 ; i < N - 2; i++) + { + gsl_vector_view c = gsl_matrix_column (A, i); + gsl_vector_view v = gsl_vector_subvector (&c.vector, i + 1, N - (i + 1)); + double tau_i = gsl_linalg_householder_transform (&v.vector); + + /* Apply the transformation H^T A H to the remaining columns */ + + if (tau_i != 0.0) + { + gsl_matrix_view m = gsl_matrix_submatrix (A, i + 1, i + 1, + N - (i+1), N - (i+1)); + double ei = gsl_vector_get(&v.vector, 0); + gsl_vector_view x = gsl_vector_subvector (tau, i, N-(i+1)); + gsl_vector_set (&v.vector, 0, 1.0); + + /* x = tau * A * v */ + gsl_blas_dsymv (CblasLower, tau_i, &m.matrix, &v.vector, 0.0, &x.vector); + + /* w = x - (1/2) tau * (x' * v) * v */ + { + double xv, alpha; + gsl_blas_ddot(&x.vector, &v.vector, &xv); + alpha = - (tau_i / 2.0) * xv; + gsl_blas_daxpy(alpha, &v.vector, &x.vector); + } + + /* apply the transformation A = A - v w' - w v' */ + gsl_blas_dsyr2(CblasLower, -1.0, &v.vector, &x.vector, &m.matrix); + + gsl_vector_set (&v.vector, 0, ei); + } + + gsl_vector_set (tau, i, tau_i); + } + + return GSL_SUCCESS; + } +} + + +/* Form the orthogonal matrix Q from the packed QR matrix */ + +int +gsl_linalg_symmtd_unpack (const gsl_matrix * A, + const gsl_vector * tau, + gsl_matrix * Q, + gsl_vector * diag, + gsl_vector * sdiag) +{ + if (A->size1 != A->size2) + { + GSL_ERROR ("matrix A must be square", GSL_ENOTSQR); + } + else if (tau->size + 1 != A->size1) + { + GSL_ERROR ("size of tau must be (matrix size - 1)", GSL_EBADLEN); + } + else if (Q->size1 != A->size1 || Q->size2 != A->size1) + { + GSL_ERROR ("size of Q must match size of A", GSL_EBADLEN); + } + else if (diag->size != A->size1) + { + GSL_ERROR ("size of diagonal must match size of A", GSL_EBADLEN); + } + else if (sdiag->size + 1 != A->size1) + { + GSL_ERROR ("size of subdiagonal must be (matrix size - 1)", GSL_EBADLEN); + } + else + { + const size_t N = A->size1; + + size_t i; + + /* Initialize Q to the identity */ + + gsl_matrix_set_identity (Q); + + for (i = N - 2; i > 0 && i--;) + { + gsl_vector_const_view c = gsl_matrix_const_column (A, i); + gsl_vector_const_view h = gsl_vector_const_subvector (&c.vector, i + 1, N - (i+1)); + double ti = gsl_vector_get (tau, i); + + gsl_matrix_view m = gsl_matrix_submatrix (Q, i + 1, i + 1, N-(i+1), N-(i+1)); + + gsl_linalg_householder_hm (ti, &h.vector, &m.matrix); + } + + /* Copy diagonal into diag */ + + for (i = 0; i < N; i++) + { + double Aii = gsl_matrix_get (A, i, i); + gsl_vector_set (diag, i, Aii); + } + + /* Copy subdiagonal into sd */ + + for (i = 0; i < N - 1; i++) + { + double Aji = gsl_matrix_get (A, i+1, i); + gsl_vector_set (sdiag, i, Aji); + } + + return GSL_SUCCESS; + } +} + +int +gsl_linalg_symmtd_unpack_T (const gsl_matrix * A, + gsl_vector * diag, + gsl_vector * sdiag) +{ + if (A->size1 != A->size2) + { + GSL_ERROR ("matrix A must be square", GSL_ENOTSQR); + } + else if (diag->size != A->size1) + { + GSL_ERROR ("size of diagonal must match size of A", GSL_EBADLEN); + } + else if (sdiag->size + 1 != A->size1) + { + GSL_ERROR ("size of subdiagonal must be (matrix size - 1)", GSL_EBADLEN); + } + else + { + const size_t N = A->size1; + + size_t i; + + /* Copy diagonal into diag */ + + for (i = 0; i < N; i++) + { + double Aii = gsl_matrix_get (A, i, i); + gsl_vector_set (diag, i, Aii); + } + + /* Copy subdiagonal into sdiag */ + + for (i = 0; i < N - 1; i++) + { + double Aij = gsl_matrix_get (A, i+1, i); + gsl_vector_set (sdiag, i, Aij); + } + + return GSL_SUCCESS; + } +} diff --git a/gsl-1.9/linalg/test.c b/gsl-1.9/linalg/test.c new file mode 100644 index 0000000..4736243 --- /dev/null +++ b/gsl-1.9/linalg/test.c @@ -0,0 +1,3790 @@ +/* linalg/test.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2004, 2005 + * Gerard Jungman, Brian Gough + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Author: G. Jungman + */ +#include <config.h> +#include <stdlib.h> +#include <gsl/gsl_test.h> +#include <gsl/gsl_math.h> +#include <gsl/gsl_ieee_utils.h> +#include <gsl/gsl_permute_vector.h> +#include <gsl/gsl_blas.h> +#include <gsl/gsl_complex_math.h> +#include <gsl/gsl_linalg.h> + +#define TEST_SVD_4X4 1 + +int check (double x, double actual, double eps); +gsl_matrix * create_hilbert_matrix(unsigned long size); +gsl_matrix * create_general_matrix(unsigned long size1, unsigned long size2); +gsl_matrix * create_vandermonde_matrix(unsigned long size); +gsl_matrix * create_moler_matrix(unsigned long size); +gsl_matrix * create_row_matrix(unsigned long size1, unsigned long size2); +gsl_matrix * create_2x2_matrix(double a11, double a12, double a21, double a22); +gsl_matrix * create_diagonal_matrix(double a[], unsigned long size); + +int test_matmult(void); +int test_matmult_mod(void); +int test_LU_solve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_LU_solve(void); +int test_LUc_solve_dim(const gsl_matrix_complex * m, const double * actual, double eps); +int test_LUc_solve(void); +int test_QR_solve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_QR_solve(void); +int test_QR_QRsolve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_QR_QRsolve(void); +int test_QR_lssolve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_QR_lssolve(void); +int test_QR_decomp_dim(const gsl_matrix * m, double eps); +int test_QR_decomp(void); +int test_QRPT_solve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_QRPT_solve(void); +int test_QRPT_QRsolve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_QRPT_QRsolve(void); +int test_QRPT_decomp_dim(const gsl_matrix * m, double eps); +int test_QRPT_decomp(void); +int test_QR_update_dim(const gsl_matrix * m, double eps); +int test_QR_update(void); + +int test_LQ_solve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_LQ_solve(void); +int test_LQ_LQsolve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_LQ_LQsolve(void); +int test_LQ_lssolve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_LQ_lssolve(void); +int test_LQ_decomp_dim(const gsl_matrix * m, double eps); +int test_LQ_decomp(void); +int test_PTLQ_solve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_PTLQ_solve(void); +int test_PTLQ_LQsolve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_PTLQ_LQsolve(void); +int test_PTLQ_decomp_dim(const gsl_matrix * m, double eps); +int test_PTLQ_decomp(void); +int test_LQ_update_dim(const gsl_matrix * m, double eps); +int test_LQ_update(void); + +int test_SV_solve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_SV_solve(void); +int test_SV_decomp_dim(const gsl_matrix * m, double eps); +int test_SV_decomp(void); +int test_SV_decomp_mod_dim(const gsl_matrix * m, double eps); +int test_SV_decomp_mod(void); +int test_SV_decomp_jacobi_dim(const gsl_matrix * m, double eps); +int test_SV_decomp_jacobi(void); +int test_cholesky_solve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_cholesky_solve(void); +int test_cholesky_decomp_dim(const gsl_matrix * m, double eps); +int test_cholesky_decomp(void); +int test_HH_solve_dim(const gsl_matrix * m, const double * actual, double eps); +int test_HH_solve(void); +int test_TDS_solve_dim(unsigned long dim, double d, double od, const double * actual, double eps); +int test_TDS_solve(void); +int test_TDN_solve_dim(unsigned long dim, double d, double a, double b, const double * actual, double eps); +int test_TDN_solve(void); +int test_TDS_cyc_solve_one(const unsigned long dim, const double * d, const double * od, const double * r, + const double * actual, double eps); +int test_TDS_cyc_solve(void); +int test_TDN_cyc_solve_dim(unsigned long dim, double d, double a, double b, const double * actual, double eps); +int test_TDN_cyc_solve(void); +int test_bidiag_decomp_dim(const gsl_matrix * m, double eps); +int test_bidiag_decomp(void); + +int +check (double x, double actual, double eps) +{ + if (x == actual) + { + return 0; + } + else if (actual == 0) + { + return fabs(x) > eps; + } + else + { + return (fabs(x - actual)/fabs(actual)) > eps; + } +} + +gsl_matrix * +create_hilbert_matrix(unsigned long size) +{ + unsigned long i, j; + gsl_matrix * m = gsl_matrix_alloc(size, size); + for(i=0; i<size; i++) { + for(j=0; j<size; j++) { + gsl_matrix_set(m, i, j, 1.0/(i+j+1.0)); + } + } + return m; +} + +gsl_matrix * +create_general_matrix(unsigned long size1, unsigned long size2) +{ + unsigned long i, j; + gsl_matrix * m = gsl_matrix_alloc(size1, size2); + for(i=0; i<size1; i++) { + for(j=0; j<size2; j++) { + gsl_matrix_set(m, i, j, 1.0/(i+j+1.0)); + } + } + return m; +} + +gsl_matrix * +create_singular_matrix(unsigned long size1, unsigned long size2) +{ + unsigned long i, j; + gsl_matrix * m = gsl_matrix_alloc(size1, size2); + for(i=0; i<size1; i++) { + for(j=0; j<size2; j++) { + gsl_matrix_set(m, i, j, 1.0/(i+j+1.0)); + } + } + + /* zero the first column */ + for(j = 0; j <size2; j++) + gsl_matrix_set(m,0,j,0.0); + + return m; +} + + +gsl_matrix * +create_vandermonde_matrix(unsigned long size) +{ + unsigned long i, j; + gsl_matrix * m = gsl_matrix_alloc(size, size); + for(i=0; i<size; i++) { + for(j=0; j<size; j++) { + gsl_matrix_set(m, i, j, pow(i + 1.0, size - j - 1.0)); + } + } + return m; +} + +gsl_matrix * +create_moler_matrix(unsigned long size) +{ + unsigned long i, j; + gsl_matrix * m = gsl_matrix_alloc(size, size); + for(i=0; i<size; i++) { + for(j=0; j<size; j++) { + gsl_matrix_set(m, i, j, GSL_MIN(i+1,j+1)-2.0); + } + } + return m; +} + +gsl_matrix_complex * +create_complex_matrix(unsigned long size) +{ + unsigned long i, j; + gsl_matrix_complex * m = gsl_matrix_complex_alloc(size, size); + for(i=0; i<size; i++) { + for(j=0; j<size; j++) { + gsl_complex z = gsl_complex_rect(1.0/(i+j+1.0), 1/(i*i+j*j+0.5)); + gsl_matrix_complex_set(m, i, j, z); + } + } + return m; +} + +gsl_matrix * +create_row_matrix(unsigned long size1, unsigned long size2) +{ + unsigned long i; + gsl_matrix * m = gsl_matrix_calloc(size1, size2); + for(i=0; i<size1; i++) { + gsl_matrix_set(m, i, 0, 1.0/(i+1.0)); + } + + return m; +} + +gsl_matrix * +create_2x2_matrix(double a11, double a12, double a21, double a22) +{ + gsl_matrix * m = gsl_matrix_alloc(2, 2); + gsl_matrix_set(m, 0, 0, a11); + gsl_matrix_set(m, 0, 1, a12); + gsl_matrix_set(m, 1, 0, a21); + gsl_matrix_set(m, 1, 1, a22); + return m; +} + +gsl_matrix * +create_diagonal_matrix(double a[], unsigned long size) +{ + unsigned long i; + gsl_matrix * m = gsl_matrix_calloc(size, size); + for(i=0; i<size; i++) { + gsl_matrix_set(m, i, i, a[i]); + } + + return m; +} + +gsl_matrix * m11; +gsl_matrix * m51; + +gsl_matrix * m35; +gsl_matrix * m53; +gsl_matrix * m97; + +gsl_matrix * s35; +gsl_matrix * s53; + +gsl_matrix * hilb2; +gsl_matrix * hilb3; +gsl_matrix * hilb4; +gsl_matrix * hilb12; + +gsl_matrix * row3; +gsl_matrix * row5; +gsl_matrix * row12; + +gsl_matrix * A22; +gsl_matrix * A33; +gsl_matrix * A44; +gsl_matrix * A55; + +gsl_matrix_complex * c7; + +gsl_matrix * inf5; double inf5_data[] = {1.0, 0.0, -3.0, 0.0, -5.0}; +gsl_matrix * nan5; + +double m53_lssolution[] = {52.5992295702070, -337.7263113752073, + 351.8823436427604}; +double hilb2_solution[] = {-8.0, 18.0} ; +double hilb3_solution[] = {27.0, -192.0, 210.0}; +double hilb4_solution[] = {-64.0, 900.0, -2520.0, 1820.0}; +double hilb12_solution[] = {-1728.0, 245388.0, -8528520.0, + 127026900.0, -1009008000.0, 4768571808.0, + -14202796608.0, 27336497760.0, -33921201600.0, + 26189163000.0, -11437874448.0, 2157916488.0 }; + +double c7_solution[] = { 2.40717272023734e+01, -9.84612797621247e+00, + -2.69338853034031e+02, 8.75455232472528e+01, + 2.96661356736296e+03, -1.02624473923993e+03, + -1.82073812124749e+04, 5.67384473042410e+03, + 5.57693879019068e+04, -1.61540963210502e+04, + -7.88941207561151e+04, 1.95053812987858e+04, + 3.95548551241728e+04, -7.76593696255317e+03 }; + +gsl_matrix * vander2; +gsl_matrix * vander3; +gsl_matrix * vander4; +gsl_matrix * vander12; + +double vander2_solution[] = {1.0, 0.0}; +double vander3_solution[] = {0.0, 1.0, 0.0}; +double vander4_solution[] = {0.0, 0.0, 1.0, 0.0}; +double vander12_solution[] = {0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 1.0, 0.0}; + +gsl_matrix * moler10; + +/* matmult now obsolete */ +#ifdef MATMULT +int +test_matmult(void) +{ + int s = 0; + + gsl_matrix * A = gsl_matrix_calloc(2, 2); + gsl_matrix * B = gsl_matrix_calloc(2, 3); + gsl_matrix * C = gsl_matrix_calloc(2, 3); + + gsl_matrix_set(A, 0, 0, 10.0); + gsl_matrix_set(A, 0, 1, 5.0); + gsl_matrix_set(A, 1, 0, 1.0); + gsl_matrix_set(A, 1, 1, 20.0); + + gsl_matrix_set(B, 0, 0, 10.0); + gsl_matrix_set(B, 0, 1, 5.0); + gsl_matrix_set(B, 0, 2, 2.0); + gsl_matrix_set(B, 1, 0, 1.0); + gsl_matrix_set(B, 1, 1, 3.0); + gsl_matrix_set(B, 1, 2, 2.0); + + gsl_linalg_matmult(A, B, C); + + s += ( fabs(gsl_matrix_get(C, 0, 0) - 105.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 1) - 65.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 2) - 30.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 0) - 30.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 1) - 65.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 2) - 42.0) > GSL_DBL_EPSILON ); + + gsl_matrix_free(A); + gsl_matrix_free(B); + gsl_matrix_free(C); + + return s; +} + + +int +test_matmult_mod(void) +{ + int s = 0; + + gsl_matrix * A = gsl_matrix_calloc(3, 3); + gsl_matrix * B = gsl_matrix_calloc(3, 3); + gsl_matrix * C = gsl_matrix_calloc(3, 3); + gsl_matrix * D = gsl_matrix_calloc(2, 3); + gsl_matrix * E = gsl_matrix_calloc(2, 3); + gsl_matrix * F = gsl_matrix_calloc(2, 2); + + gsl_matrix_set(A, 0, 0, 10.0); + gsl_matrix_set(A, 0, 1, 5.0); + gsl_matrix_set(A, 0, 2, 1.0); + gsl_matrix_set(A, 1, 0, 1.0); + gsl_matrix_set(A, 1, 1, 20.0); + gsl_matrix_set(A, 1, 2, 5.0); + gsl_matrix_set(A, 2, 0, 1.0); + gsl_matrix_set(A, 2, 1, 3.0); + gsl_matrix_set(A, 2, 2, 7.0); + + gsl_matrix_set(B, 0, 0, 10.0); + gsl_matrix_set(B, 0, 1, 5.0); + gsl_matrix_set(B, 0, 2, 2.0); + gsl_matrix_set(B, 1, 0, 1.0); + gsl_matrix_set(B, 1, 1, 3.0); + gsl_matrix_set(B, 1, 2, 2.0); + gsl_matrix_set(B, 2, 0, 1.0); + gsl_matrix_set(B, 2, 1, 3.0); + gsl_matrix_set(B, 2, 2, 2.0); + + gsl_matrix_set(D, 0, 0, 10.0); + gsl_matrix_set(D, 0, 1, 5.0); + gsl_matrix_set(D, 0, 2, 1.0); + gsl_matrix_set(D, 1, 0, 1.0); + gsl_matrix_set(D, 1, 1, 20.0); + gsl_matrix_set(D, 1, 2, 5.0); + + gsl_matrix_set(E, 0, 0, 10.0); + gsl_matrix_set(E, 0, 1, 5.0); + gsl_matrix_set(E, 0, 2, 2.0); + gsl_matrix_set(E, 1, 0, 1.0); + gsl_matrix_set(E, 1, 1, 3.0); + gsl_matrix_set(E, 1, 2, 2.0); + + gsl_linalg_matmult_mod(A, GSL_LINALG_MOD_NONE, B, GSL_LINALG_MOD_NONE, C); + s += ( fabs(gsl_matrix_get(C, 0, 0) - 106.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 1) - 68.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 2) - 32.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 0) - 35.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 1) - 80.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 2) - 52.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 0) - 20.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 1) - 35.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 2) - 22.0) > GSL_DBL_EPSILON ); + + gsl_linalg_matmult_mod(A, GSL_LINALG_MOD_TRANSPOSE, B, GSL_LINALG_MOD_NONE, C); + s += ( fabs(gsl_matrix_get(C, 0, 0) - 102.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 1) - 56.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 2) - 24.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 0) - 73.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 1) - 94.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 2) - 56.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 0) - 22.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 1) - 41.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 2) - 26.0) > GSL_DBL_EPSILON ); + + gsl_linalg_matmult_mod(A, GSL_LINALG_MOD_NONE, B, GSL_LINALG_MOD_TRANSPOSE, C); + s += ( fabs(gsl_matrix_get(C, 0, 0) - 127.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 1) - 27.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 2) - 27.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 0) - 120.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 1) - 71.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 2) - 71.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 0) - 39.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 1) - 24.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 2) - 24.0) > GSL_DBL_EPSILON ); + + gsl_linalg_matmult_mod(A, GSL_LINALG_MOD_TRANSPOSE, B, GSL_LINALG_MOD_TRANSPOSE, C); + s += ( fabs(gsl_matrix_get(C, 0, 0) - 107.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 1) - 15.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 2) - 15.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 0) - 156.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 1) - 71.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 2) - 71.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 0) - 49.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 1) - 30.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 2) - 30.0) > GSL_DBL_EPSILON ); + + /* now try for non-symmetric matrices */ + gsl_linalg_matmult_mod(D, GSL_LINALG_MOD_TRANSPOSE, E, GSL_LINALG_MOD_NONE, C); + s += ( fabs(gsl_matrix_get(C, 0, 0) - 101.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 1) - 53.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 0, 2) - 22.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 0) - 70.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 1) - 85.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 1, 2) - 50.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 0) - 15.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 1) - 20.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(C, 2, 2) - 12.0) > GSL_DBL_EPSILON ); + + + gsl_linalg_matmult_mod(D, GSL_LINALG_MOD_NONE, E, GSL_LINALG_MOD_TRANSPOSE, F); + s += ( fabs(gsl_matrix_get(F, 0, 0) - 127.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(F, 0, 1) - 27.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(F, 1, 0) - 120.0) > GSL_DBL_EPSILON ); + s += ( fabs(gsl_matrix_get(F, 1, 1) - 71.0) > GSL_DBL_EPSILON ); + + + gsl_matrix_free(A); + gsl_matrix_free(B); + gsl_matrix_free(C); + gsl_matrix_free(D); + gsl_matrix_free(E); + gsl_matrix_free(F); + + return s; +} +#endif + +int +test_LU_solve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + int signum; + unsigned long i, dim = m->size1; + + gsl_permutation * perm = gsl_permutation_alloc(dim); + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * lu = gsl_matrix_alloc(dim,dim); + gsl_vector * x = gsl_vector_alloc(dim); + gsl_vector * residual = gsl_vector_alloc(dim); + gsl_matrix_memcpy(lu,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_LU_decomp(lu, perm, &signum); + s += gsl_linalg_LU_solve(lu, perm, rhs, x); + + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i),actual[i],eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + s += gsl_linalg_LU_refine(m, lu, perm, rhs, x, residual); + + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i),actual[i],eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g (improved)\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(residual); + gsl_vector_free(x); + gsl_matrix_free(lu); + gsl_vector_free(rhs); + gsl_permutation_free(perm); + + return s; +} + + +int test_LU_solve(void) +{ + int f; + int s = 0; + + f = test_LU_solve_dim(hilb2, hilb2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LU_solve hilbert(2)"); + s += f; + + f = test_LU_solve_dim(hilb3, hilb3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LU_solve hilbert(3)"); + s += f; + + f = test_LU_solve_dim(hilb4, hilb4_solution, 2048.0 * GSL_DBL_EPSILON); + gsl_test(f, " LU_solve hilbert(4)"); + s += f; + + f = test_LU_solve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " LU_solve hilbert(12)"); + s += f; + + f = test_LU_solve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LU_solve vander(2)"); + s += f; + + f = test_LU_solve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LU_solve vander(3)"); + s += f; + + f = test_LU_solve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LU_solve vander(4)"); + s += f; + + f = test_LU_solve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " LU_solve vander(12)"); + s += f; + + return s; +} + + +int +test_LUc_solve_dim(const gsl_matrix_complex * m, const double * actual, double eps) +{ + int s = 0; + int signum; + unsigned long i, dim = m->size1; + + gsl_permutation * perm = gsl_permutation_alloc(dim); + gsl_vector_complex * rhs = gsl_vector_complex_alloc(dim); + gsl_matrix_complex * lu = gsl_matrix_complex_alloc(dim,dim); + gsl_vector_complex * x = gsl_vector_complex_alloc(dim); + gsl_vector_complex * residual = gsl_vector_complex_alloc(dim); + gsl_matrix_complex_memcpy(lu,m); + for(i=0; i<dim; i++) + { + gsl_complex z = gsl_complex_rect (2.0*i+1.0, 2.0*i+2.0); + gsl_vector_complex_set(rhs, i, z); + } + s += gsl_linalg_complex_LU_decomp(lu, perm, &signum); + s += gsl_linalg_complex_LU_solve(lu, perm, rhs, x); + + for(i=0; i<dim; i++) { + gsl_complex z = gsl_vector_complex_get(x, i); + int foo_r = check(GSL_REAL(z),actual[2*i],eps); + int foo_i = check(GSL_IMAG(z),actual[2*i+1],eps); + if(foo_r || foo_i) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, GSL_REAL(z), actual[2*i]); + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, GSL_IMAG(z), actual[2*i+1]); + } + s += foo_r + foo_i; + } + + s += gsl_linalg_complex_LU_refine(m, lu, perm, rhs, x, residual); + + for(i=0; i<dim; i++) { + gsl_complex z = gsl_vector_complex_get(x, i); + int foo_r = check(GSL_REAL(z),actual[2*i],eps); + int foo_i = check(GSL_IMAG(z),actual[2*i+1],eps); + if(foo_r || foo_i) { + printf("%3lu[%lu]: %22.18g %22.18g (improved)\n", dim, i, GSL_REAL(z), actual[2*i]); + printf("%3lu[%lu]: %22.18g %22.18g (improved)\n", dim, i, GSL_IMAG(z), actual[2*i+1]); + } + s += foo_r + foo_i; + } + + gsl_vector_complex_free(residual); + gsl_vector_complex_free(x); + gsl_matrix_complex_free(lu); + gsl_vector_complex_free(rhs); + gsl_permutation_free(perm); + + return s; +} + + +int test_LUc_solve(void) +{ + int f; + int s = 0; + + f = test_LUc_solve_dim(c7, c7_solution, 1024.0 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " complex_LU_solve complex(7)"); + s += f; + + return s; +} + + +int +test_QR_solve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + unsigned long i, dim = m->size1; + + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * qr = gsl_matrix_alloc(dim,dim); + gsl_vector * d = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + + gsl_matrix_memcpy(qr,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_QR_decomp(qr, d); + s += gsl_linalg_QR_solve(qr, d, rhs, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(qr); + gsl_vector_free(rhs); + + return s; +} + +int test_QR_solve(void) +{ + int f; + int s = 0; + + f = test_QR_solve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_solve hilbert(2)"); + s += f; + + f = test_QR_solve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_solve hilbert(3)"); + s += f; + + f = test_QR_solve_dim(hilb4, hilb4_solution, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_solve hilbert(4)"); + s += f; + + f = test_QR_solve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " QR_solve hilbert(12)"); + s += f; + + f = test_QR_solve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_solve vander(2)"); + s += f; + + f = test_QR_solve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_solve vander(3)"); + s += f; + + f = test_QR_solve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_solve vander(4)"); + s += f; + + f = test_QR_solve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " QR_solve vander(12)"); + s += f; + + return s; +} + + +int +test_QR_QRsolve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + unsigned long i, dim = m->size1; + + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * qr = gsl_matrix_alloc(dim,dim); + gsl_matrix * q = gsl_matrix_alloc(dim,dim); + gsl_matrix * r = gsl_matrix_alloc(dim,dim); + gsl_vector * d = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + + gsl_matrix_memcpy(qr,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_QR_decomp(qr, d); + s += gsl_linalg_QR_unpack(qr, d, q, r); + s += gsl_linalg_QR_QRsolve(q, r, rhs, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(qr); + gsl_matrix_free(q); + gsl_matrix_free(r); + gsl_vector_free(rhs); + return s; +} + +int test_QR_QRsolve(void) +{ + int f; + int s = 0; + + f = test_QR_QRsolve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_QRsolve hilbert(2)"); + s += f; + + f = test_QR_QRsolve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_QRsolve hilbert(3)"); + s += f; + + f = test_QR_QRsolve_dim(hilb4, hilb4_solution, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_QRsolve hilbert(4)"); + s += f; + + f = test_QR_QRsolve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " QR_QRsolve hilbert(12)"); + s += f; + + f = test_QR_QRsolve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_QRsolve vander(2)"); + s += f; + + f = test_QR_QRsolve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_QRsolve vander(3)"); + s += f; + + f = test_QR_QRsolve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_QRsolve vander(4)"); + s += f; + + f = test_QR_QRsolve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " QR_QRsolve vander(12)"); + s += f; + + return s; +} + + +int +test_QR_lssolve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + unsigned long i, M = m->size1, N = m->size2; + + gsl_vector * rhs = gsl_vector_alloc(M); + gsl_matrix * qr = gsl_matrix_alloc(M,N); + gsl_vector * d = gsl_vector_alloc(N); + gsl_vector * x = gsl_vector_alloc(N); + gsl_vector * r = gsl_vector_alloc(M); + gsl_vector * res = gsl_vector_alloc(M); + + gsl_matrix_memcpy(qr,m); + for(i=0; i<M; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_QR_decomp(qr, d); + s += gsl_linalg_QR_lssolve(qr, d, rhs, x, res); + + for(i=0; i<N; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("(%3lu,%3lu)[%lu]: %22.18g %22.18g\n", M, N, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + /* compute residual r = b - m x */ + if (M == N) { + gsl_vector_set_zero(r); + } else { + gsl_vector_memcpy(r, rhs); + gsl_blas_dgemv(CblasNoTrans, -1.0, m, x, 1.0, r); + }; + + for(i=0; i<N; i++) { + int foo = check(gsl_vector_get(res, i), gsl_vector_get(r,i), sqrt(eps)); + if(foo) { + printf("(%3lu,%3lu)[%lu]: %22.18g %22.18g\n", M, N, i, gsl_vector_get(res, i), gsl_vector_get(r,i)); + } + s += foo; + } + + gsl_vector_free(r); + gsl_vector_free(res); + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(qr); + gsl_vector_free(rhs); + + return s; +} + +int test_QR_lssolve(void) +{ + int f; + int s = 0; + + f = test_QR_lssolve_dim(m53, m53_lssolution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_lssolve m(5,3)"); + s += f; + + f = test_QR_lssolve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_lssolve hilbert(2)"); + s += f; + + f = test_QR_lssolve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_lssolve hilbert(3)"); + s += f; + + f = test_QR_lssolve_dim(hilb4, hilb4_solution, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_lssolve hilbert(4)"); + s += f; + + f = test_QR_lssolve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " QR_lssolve hilbert(12)"); + s += f; + + f = test_QR_lssolve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_lssolve vander(2)"); + s += f; + + f = test_QR_lssolve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_lssolve vander(3)"); + s += f; + + f = test_QR_lssolve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_lssolve vander(4)"); + s += f; + + f = test_QR_lssolve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " QR_lssolve vander(12)"); + s += f; + + return s; +} + + +int +test_QR_decomp_dim(const gsl_matrix * m, double eps) +{ + int s = 0; + unsigned long i,j, M = m->size1, N = m->size2; + + gsl_matrix * qr = gsl_matrix_alloc(M,N); + gsl_matrix * a = gsl_matrix_alloc(M,N); + gsl_matrix * q = gsl_matrix_alloc(M,M); + gsl_matrix * r = gsl_matrix_alloc(M,N); + gsl_vector * d = gsl_vector_alloc(GSL_MIN(M,N)); + + gsl_matrix_memcpy(qr,m); + + s += gsl_linalg_QR_decomp(qr, d); + s += gsl_linalg_QR_unpack(qr, d, q, r); + + /* compute a = q r */ + gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, q, r, 0.0, a); + + for(i=0; i<M; i++) { + for(j=0; j<N; j++) { + double aij = gsl_matrix_get(a, i, j); + double mij = gsl_matrix_get(m, i, j); + int foo = check(aij, mij, eps); + if(foo) { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, aij, mij); + } + s += foo; + } + } + + gsl_vector_free(d); + gsl_matrix_free(qr); + gsl_matrix_free(a); + gsl_matrix_free(q); + gsl_matrix_free(r); + + return s; +} + +int test_QR_decomp(void) +{ + int f; + int s = 0; + + f = test_QR_decomp_dim(m35, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_decomp m(3,5)"); + s += f; + + f = test_QR_decomp_dim(m53, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_decomp m(5,3)"); + s += f; + + f = test_QR_decomp_dim(hilb2, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_decomp hilbert(2)"); + s += f; + + f = test_QR_decomp_dim(hilb3, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_decomp hilbert(3)"); + s += f; + + f = test_QR_decomp_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_decomp hilbert(4)"); + s += f; + + f = test_QR_decomp_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_decomp hilbert(12)"); + s += f; + + f = test_QR_decomp_dim(vander2, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_decomp vander(2)"); + s += f; + + f = test_QR_decomp_dim(vander3, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_decomp vander(3)"); + s += f; + + f = test_QR_decomp_dim(vander4, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_decomp vander(4)"); + s += f; + + f = test_QR_decomp_dim(vander12, 0.0005); /* FIXME: bad accuracy */ + gsl_test(f, " QR_decomp vander(12)"); + s += f; + + return s; +} + +int +test_QRPT_solve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + int signum; + unsigned long i, dim = m->size1; + + gsl_permutation * perm = gsl_permutation_alloc(dim); + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * qr = gsl_matrix_alloc(dim,dim); + gsl_vector * d = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + gsl_vector * norm = gsl_vector_alloc(dim); + + gsl_matrix_memcpy(qr,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_QRPT_decomp(qr, d, perm, &signum, norm); + s += gsl_linalg_QRPT_solve(qr, d, perm, rhs, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(norm); + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(qr); + gsl_vector_free(rhs); + gsl_permutation_free(perm); + + return s; +} + +int test_QRPT_solve(void) +{ + int f; + int s = 0; + + f = test_QRPT_solve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_solve hilbert(2)"); + s += f; + + f = test_QRPT_solve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_solve hilbert(3)"); + s += f; + + f = test_QRPT_solve_dim(hilb4, hilb4_solution, 2 * 2048.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_solve hilbert(4)"); + s += f; + + f = test_QRPT_solve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " QRPT_solve hilbert(12)"); + s += f; + + f = test_QRPT_solve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_solve vander(2)"); + s += f; + + f = test_QRPT_solve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_solve vander(3)"); + s += f; + + f = test_QRPT_solve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_solve vander(4)"); + s += f; + + f = test_QRPT_solve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " QRPT_solve vander(12)"); + s += f; + + return s; +} + +int +test_QRPT_QRsolve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + int signum; + unsigned long i, dim = m->size1; + + gsl_permutation * perm = gsl_permutation_alloc(dim); + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * qr = gsl_matrix_alloc(dim,dim); + gsl_matrix * q = gsl_matrix_alloc(dim,dim); + gsl_matrix * r = gsl_matrix_alloc(dim,dim); + gsl_vector * d = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + gsl_vector * norm = gsl_vector_alloc(dim); + + gsl_matrix_memcpy(qr,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_QRPT_decomp2(qr, q, r, d, perm, &signum, norm); + s += gsl_linalg_QRPT_QRsolve(q, r, perm, rhs, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(norm); + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(qr); + gsl_matrix_free(q); + gsl_matrix_free(r); + gsl_vector_free(rhs); + gsl_permutation_free(perm); + + return s; +} + +int test_QRPT_QRsolve(void) +{ + int f; + int s = 0; + + f = test_QRPT_QRsolve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_QRsolve hilbert(2)"); + s += f; + + f = test_QRPT_QRsolve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_QRsolve hilbert(3)"); + s += f; + + f = test_QRPT_QRsolve_dim(hilb4, hilb4_solution, 2 * 2048.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_QRsolve hilbert(4)"); + s += f; + + f = test_QRPT_QRsolve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " QRPT_QRsolve hilbert(12)"); + s += f; + + f = test_QRPT_QRsolve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_QRsolve vander(2)"); + s += f; + + f = test_QRPT_QRsolve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_QRsolve vander(3)"); + s += f; + + f = test_QRPT_QRsolve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_QRsolve vander(4)"); + s += f; + + f = test_QRPT_QRsolve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " QRPT_QRsolve vander(12)"); + s += f; + + return s; +} + +int +test_QRPT_decomp_dim(const gsl_matrix * m, double eps) +{ + int s = 0, signum; + unsigned long i,j, M = m->size1, N = m->size2; + + gsl_matrix * qr = gsl_matrix_alloc(M,N); + gsl_matrix * a = gsl_matrix_alloc(M,N); + gsl_matrix * q = gsl_matrix_alloc(M,M); + gsl_matrix * r = gsl_matrix_alloc(M,N); + gsl_vector * d = gsl_vector_alloc(GSL_MIN(M,N)); + gsl_vector * norm = gsl_vector_alloc(N); + + gsl_permutation * perm = gsl_permutation_alloc(N); + + gsl_matrix_memcpy(qr,m); + + s += gsl_linalg_QRPT_decomp(qr, d, perm, &signum, norm); + s += gsl_linalg_QR_unpack(qr, d, q, r); + + /* compute a = q r */ + gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, q, r, 0.0, a); + + + /* Compute QR P^T by permuting the elements of the rows of QR */ + + for (i = 0; i < M; i++) { + gsl_vector_view row = gsl_matrix_row (a, i); + gsl_permute_vector_inverse (perm, &row.vector); + } + + for(i=0; i<M; i++) { + for(j=0; j<N; j++) { + double aij = gsl_matrix_get(a, i, j); + double mij = gsl_matrix_get(m, i, j); + int foo = check(aij, mij, eps); + if(foo) { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, aij, mij); + } + s += foo; + } + } + + gsl_permutation_free (perm); + gsl_vector_free(norm); + gsl_vector_free(d); + gsl_matrix_free(qr); + gsl_matrix_free(a); + gsl_matrix_free(q); + gsl_matrix_free(r); + + return s; +} + +int test_QRPT_decomp(void) +{ + int f; + int s = 0; + + f = test_QRPT_decomp_dim(m35, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp m(3,5)"); + s += f; + + f = test_QRPT_decomp_dim(m53, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp m(5,3)"); + s += f; + + f = test_QRPT_decomp_dim(s35, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp s(3,5)"); + s += f; + + f = test_QRPT_decomp_dim(s53, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp s(5,3)"); + s += f; + + f = test_QRPT_decomp_dim(hilb2, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp hilbert(2)"); + s += f; + + f = test_QRPT_decomp_dim(hilb3, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp hilbert(3)"); + s += f; + + f = test_QRPT_decomp_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp hilbert(4)"); + s += f; + + f = test_QRPT_decomp_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp hilbert(12)"); + s += f; + + f = test_QRPT_decomp_dim(vander2, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp vander(2)"); + s += f; + + f = test_QRPT_decomp_dim(vander3, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp vander(3)"); + s += f; + + f = test_QRPT_decomp_dim(vander4, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QRPT_decomp vander(4)"); + s += f; + + f = test_QRPT_decomp_dim(vander12, 0.0005); /* FIXME: bad accuracy */ + gsl_test(f, " QRPT_decomp vander(12)"); + s += f; + + return s; +} + + +int +test_QR_update_dim(const gsl_matrix * m, double eps) +{ + int s = 0; + unsigned long i,j,k, M = m->size1, N = m->size2; + + gsl_vector * rhs = gsl_vector_alloc(N); + gsl_matrix * qr1 = gsl_matrix_alloc(M,N); + gsl_matrix * qr2 = gsl_matrix_alloc(M,N); + gsl_matrix * q1 = gsl_matrix_alloc(M,M); + gsl_matrix * r1 = gsl_matrix_alloc(M,N); + gsl_matrix * q2 = gsl_matrix_alloc(M,M); + gsl_matrix * r2 = gsl_matrix_alloc(M,N); + gsl_vector * d = gsl_vector_alloc(GSL_MIN(M,N)); + gsl_vector * solution1 = gsl_vector_alloc(N); + gsl_vector * solution2 = gsl_vector_alloc(N); + gsl_vector * u = gsl_vector_alloc(M); + gsl_vector * v = gsl_vector_alloc(N); + gsl_vector * w = gsl_vector_alloc(M); + + gsl_matrix_memcpy(qr1,m); + gsl_matrix_memcpy(qr2,m); + for(i=0; i<N; i++) gsl_vector_set(rhs, i, i+1.0); + for(i=0; i<M; i++) gsl_vector_set(u, i, sin(i+1.0)); + for(i=0; i<N; i++) gsl_vector_set(v, i, cos(i+2.0) + sin(i*i+3.0)); + + for(i=0; i<M; i++) + { + double ui = gsl_vector_get(u, i); + for(j=0; j<N; j++) + { + double vj = gsl_vector_get(v, j); + double qij = gsl_matrix_get(qr1, i, j); + gsl_matrix_set(qr1, i, j, qij + ui * vj); + } + } + + s += gsl_linalg_QR_decomp(qr2, d); + s += gsl_linalg_QR_unpack(qr2, d, q2, r2); + + /* compute w = Q^T u */ + + for (j = 0; j < M; j++) + { + double sum = 0; + for (i = 0; i < M; i++) + sum += gsl_matrix_get (q2, i, j) * gsl_vector_get (u, i); + gsl_vector_set (w, j, sum); + } + + s += gsl_linalg_QR_update(q2, r2, w, v); + + /* compute qr2 = q2 * r2 */ + + for (i = 0; i < M; i++) + { + for (j = 0; j< N; j++) + { + double sum = 0; + for (k = 0; k <= GSL_MIN(j,M-1); k++) + { + double qik = gsl_matrix_get(q2, i, k); + double rkj = gsl_matrix_get(r2, k, j); + sum += qik * rkj ; + } + gsl_matrix_set (qr2, i, j, sum); + } + } + + for(i=0; i<M; i++) { + for(j=0; j<N; j++) { + double s1 = gsl_matrix_get(qr1, i, j); + double s2 = gsl_matrix_get(qr2, i, j); + + int foo = check(s1, s2, eps); + if(foo) { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, s1, s2); + } + s += foo; + } + } + + gsl_vector_free(solution1); + gsl_vector_free(solution2); + gsl_vector_free(d); + gsl_vector_free(u); + gsl_vector_free(v); + gsl_vector_free(w); + gsl_matrix_free(qr1); + gsl_matrix_free(qr2); + gsl_matrix_free(q1); + gsl_matrix_free(r1); + gsl_matrix_free(q2); + gsl_matrix_free(r2); + gsl_vector_free(rhs); + + return s; +} + +int test_QR_update(void) +{ + int f; + int s = 0; + + f = test_QR_update_dim(m35, 2 * 512.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_update m(3,5)"); + s += f; + + f = test_QR_update_dim(m53, 2 * 512.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_update m(5,3)"); + s += f; + + f = test_QR_update_dim(hilb2, 2 * 512.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_update hilbert(2)"); + s += f; + + f = test_QR_update_dim(hilb3, 2 * 512.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_update hilbert(3)"); + s += f; + + f = test_QR_update_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_update hilbert(4)"); + s += f; + + f = test_QR_update_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_update hilbert(12)"); + s += f; + + f = test_QR_update_dim(vander2, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_update vander(2)"); + s += f; + + f = test_QR_update_dim(vander3, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_update vander(3)"); + s += f; + + f = test_QR_update_dim(vander4, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " QR_update vander(4)"); + s += f; + + f = test_QR_update_dim(vander12, 0.0005); /* FIXME: bad accuracy */ + gsl_test(f, " QR_update vander(12)"); + s += f; + + return s; +} + +int +test_LQ_solve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + unsigned long i, dim = m->size1; + + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * lq = gsl_matrix_alloc(dim,dim); + gsl_vector * d = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + + gsl_matrix_transpose_memcpy(lq,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_LQ_decomp(lq, d); + s += gsl_linalg_LQ_solve_T(lq, d, rhs, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(lq); + gsl_vector_free(rhs); + + return s; +} + +int test_LQ_solve(void) +{ + int f; + int s = 0; + + f = test_LQ_solve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_solve hilbert(2)"); + s += f; + + f = test_LQ_solve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_solve hilbert(3)"); + s += f; + + f = test_LQ_solve_dim(hilb4, hilb4_solution, 4 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_solve hilbert(4)"); + s += f; + + f = test_LQ_solve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " LQ_solve hilbert(12)"); + s += f; + + f = test_LQ_solve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_solve vander(2)"); + s += f; + + f = test_LQ_solve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_solve vander(3)"); + s += f; + + f = test_LQ_solve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_solve vander(4)"); + s += f; + + f = test_LQ_solve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " LQ_solve vander(12)"); + s += f; + + return s; +} + + + + +int +test_LQ_LQsolve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + unsigned long i, dim = m->size1; + + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * lq = gsl_matrix_alloc(dim,dim); + gsl_matrix * q = gsl_matrix_alloc(dim,dim); + gsl_matrix * l = gsl_matrix_alloc(dim,dim); + gsl_vector * d = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + + gsl_matrix_transpose_memcpy(lq,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_LQ_decomp(lq, d); + s += gsl_linalg_LQ_unpack(lq, d, q, l); + s += gsl_linalg_LQ_LQsolve(q, l, rhs, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(lq); + gsl_matrix_free(q); + gsl_matrix_free(l); + gsl_vector_free(rhs); + + return s; +} + +int test_LQ_LQsolve(void) +{ + int f; + int s = 0; + + f = test_LQ_LQsolve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_LQsolve hilbert(2)"); + s += f; + + f = test_LQ_LQsolve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_LQsolve hilbert(3)"); + s += f; + + f = test_LQ_LQsolve_dim(hilb4, hilb4_solution, 4 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_LQsolve hilbert(4)"); + s += f; + + f = test_LQ_LQsolve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " LQ_LQsolve hilbert(12)"); + s += f; + + f = test_LQ_LQsolve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_LQsolve vander(2)"); + s += f; + + f = test_LQ_LQsolve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_LQsolve vander(3)"); + s += f; + + f = test_LQ_LQsolve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_LQsolve vander(4)"); + s += f; + + f = test_LQ_LQsolve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " LQ_LQsolve vander(12)"); + s += f; + + return s; +} + + +int +test_LQ_lssolve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + unsigned long i, M = m->size1, N = m->size2; + + gsl_vector * rhs = gsl_vector_alloc(M); + gsl_matrix * lq = gsl_matrix_alloc(N,M); + gsl_vector * d = gsl_vector_alloc(N); + gsl_vector * x = gsl_vector_alloc(N); + gsl_vector * r = gsl_vector_alloc(M); + gsl_vector * res = gsl_vector_alloc(M); + + gsl_matrix_transpose_memcpy(lq,m); + for(i=0; i<M; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_LQ_decomp(lq, d); + s += gsl_linalg_LQ_lssolve_T(lq, d, rhs, x, res); + + for(i=0; i<N; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("(%3lu,%3lu)[%lu]: %22.18g %22.18g\n", M, N, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + + /* compute residual r = b - m x */ + if (M == N) { + gsl_vector_set_zero(r); + } else { + gsl_vector_memcpy(r, rhs); + gsl_blas_dgemv(CblasNoTrans, -1.0, m, x, 1.0, r); + }; + + for(i=0; i<N; i++) { + int foo = check(gsl_vector_get(res, i), gsl_vector_get(r,i), sqrt(eps)); + if(foo) { + printf("(%3lu,%3lu)[%lu]: %22.18g %22.18g\n", M, N, i, gsl_vector_get(res, i), gsl_vector_get(r,i)); + } + s += foo; + } + + gsl_vector_free(r); + gsl_vector_free(res); + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(lq); + gsl_vector_free(rhs); + + return s; +} + +int test_LQ_lssolve(void) +{ + int f; + int s = 0; + + f = test_LQ_lssolve_dim(m53, m53_lssolution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_lssolve m(5,3)"); + s += f; + + f = test_LQ_lssolve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_lssolve hilbert(2)"); + s += f; + + f = test_LQ_lssolve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_lssolve hilbert(3)"); + s += f; + + f = test_LQ_lssolve_dim(hilb4, hilb4_solution, 4 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_lssolve hilbert(4)"); + s += f; + + f = test_LQ_lssolve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " LQ_lssolve hilbert(12)"); + s += f; + + f = test_LQ_lssolve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_lssolve vander(2)"); + s += f; + + f = test_LQ_lssolve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_lssolve vander(3)"); + s += f; + + f = test_LQ_lssolve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_lssolve vander(4)"); + s += f; + + f = test_LQ_lssolve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " LQ_lssolve vander(12)"); + s += f; + + return s; +} + + + + + + + + +int +test_LQ_decomp_dim(const gsl_matrix * m, double eps) +{ + int s = 0; + unsigned long i,j, M = m->size1, N = m->size2; + + gsl_matrix * lq = gsl_matrix_alloc(M,N); + gsl_matrix * a = gsl_matrix_alloc(M,N); + gsl_matrix * q = gsl_matrix_alloc(N,N); + gsl_matrix * l = gsl_matrix_alloc(M,N); + gsl_vector * d = gsl_vector_alloc(GSL_MIN(M,N)); + + gsl_matrix_memcpy(lq,m); + + s += gsl_linalg_LQ_decomp(lq, d); + s += gsl_linalg_LQ_unpack(lq, d, q, l); + + /* compute a = q r */ + gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, l, q, 0.0, a); + + for(i=0; i<M; i++) { + for(j=0; j<N; j++) { + double aij = gsl_matrix_get(a, i, j); + double mij = gsl_matrix_get(m, i, j); + int foo = check(aij, mij, eps); + if(foo) { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, aij, mij); + } + s += foo; + } + } + + gsl_vector_free(d); + gsl_matrix_free(lq); + gsl_matrix_free(a); + gsl_matrix_free(q); + gsl_matrix_free(l); + + return s; +} + +int test_LQ_decomp(void) +{ + int f; + int s = 0; + + f = test_LQ_decomp_dim(m35, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_decomp m(3,5)"); + s += f; + + f = test_LQ_decomp_dim(m53, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_decomp m(5,3)"); + s += f; + + f = test_LQ_decomp_dim(hilb2, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_decomp hilbert(2)"); + s += f; + + f = test_LQ_decomp_dim(hilb3, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_decomp hilbert(3)"); + s += f; + + f = test_LQ_decomp_dim(hilb4, 4 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_decomp hilbert(4)"); + s += f; + + f = test_LQ_decomp_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_decomp hilbert(12)"); + s += f; + + f = test_LQ_decomp_dim(vander2, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_decomp vander(2)"); + s += f; + + f = test_LQ_decomp_dim(vander3, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_decomp vander(3)"); + s += f; + + f = test_LQ_decomp_dim(vander4, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_decomp vander(4)"); + s += f; + + f = test_LQ_decomp_dim(vander12, 0.0005); /* FIXME: bad accuracy */ + gsl_test(f, " LQ_decomp vander(12)"); + s += f; + + return s; +} + + + + +int +test_PTLQ_solve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + int signum; + unsigned long i, dim = m->size1; + + gsl_permutation * perm = gsl_permutation_alloc(dim); + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * lq = gsl_matrix_alloc(dim,dim); + gsl_vector * d = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + gsl_vector * norm = gsl_vector_alloc(dim); + + gsl_matrix_transpose_memcpy(lq,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_PTLQ_decomp(lq, d, perm, &signum, norm); + s += gsl_linalg_PTLQ_solve_T(lq, d, perm, rhs, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(norm); + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(lq); + gsl_vector_free(rhs); + gsl_permutation_free(perm); + + return s; +} + +int test_PTLQ_solve(void) +{ + int f; + int s = 0; + + f = test_PTLQ_solve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_solve hilbert(2)"); + s += f; + + f = test_PTLQ_solve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_solve hilbert(3)"); + s += f; + + f = test_PTLQ_solve_dim(hilb4, hilb4_solution, 2 * 2048.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_solve hilbert(4)"); + s += f; + + f = test_PTLQ_solve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " PTLQ_solve hilbert(12)"); + s += f; + + f = test_PTLQ_solve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_solve vander(2)"); + s += f; + + f = test_PTLQ_solve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_solve vander(3)"); + s += f; + + f = test_PTLQ_solve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_solve vander(4)"); + s += f; + + f = test_PTLQ_solve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " PTLQ_solve vander(12)"); + s += f; + + return s; +} + + +int +test_PTLQ_LQsolve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + int signum; + unsigned long i, dim = m->size1; + + gsl_permutation * perm = gsl_permutation_alloc(dim); + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * lq = gsl_matrix_alloc(dim,dim); + gsl_matrix * q = gsl_matrix_alloc(dim,dim); + gsl_matrix * l = gsl_matrix_alloc(dim,dim); + gsl_vector * d = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + gsl_vector * norm = gsl_vector_alloc(dim); + + gsl_matrix_transpose_memcpy(lq,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_PTLQ_decomp2(lq, q, l, d, perm, &signum, norm); + s += gsl_linalg_PTLQ_LQsolve_T(q, l, perm, rhs, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(norm); + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(lq); + gsl_vector_free(rhs); + gsl_permutation_free(perm); + + return s; +} + +int test_PTLQ_LQsolve(void) +{ + int f; + int s = 0; + + f = test_PTLQ_LQsolve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_LQsolve hilbert(2)"); + s += f; + + f = test_PTLQ_LQsolve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_LQsolve hilbert(3)"); + s += f; + + f = test_PTLQ_LQsolve_dim(hilb4, hilb4_solution, 2 * 2048.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_LQsolve hilbert(4)"); + s += f; + + f = test_PTLQ_LQsolve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " PTLQ_LQsolve hilbert(12)"); + s += f; + + f = test_PTLQ_LQsolve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_LQsolve vander(2)"); + s += f; + + f = test_PTLQ_LQsolve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_LQsolve vander(3)"); + s += f; + + f = test_PTLQ_LQsolve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_LQsolve vander(4)"); + s += f; + + f = test_PTLQ_LQsolve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " PTLQ_LQsolve vander(12)"); + s += f; + + return s; +} + + +int +test_PTLQ_decomp_dim(const gsl_matrix * m, double eps) +{ + int s = 0, signum; + unsigned long i,j, M = m->size1, N = m->size2; + + gsl_matrix * lq = gsl_matrix_alloc(N,M); + gsl_matrix * a = gsl_matrix_alloc(N,M); + gsl_matrix * q = gsl_matrix_alloc(M,M); + gsl_matrix * l = gsl_matrix_alloc(N,M); + gsl_vector * d = gsl_vector_alloc(GSL_MIN(M,N)); + gsl_vector * norm = gsl_vector_alloc(N); + + gsl_permutation * perm = gsl_permutation_alloc(N); + + gsl_matrix_transpose_memcpy(lq,m); + + s += gsl_linalg_PTLQ_decomp(lq, d, perm, &signum, norm); + s += gsl_linalg_LQ_unpack(lq, d, q, l); + + /* compute a = l q */ + gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, l, q, 0.0, a); + + + /* Compute P LQ by permuting the rows of LQ */ + + for (i = 0; i < M; i++) { + gsl_vector_view col = gsl_matrix_column (a, i); + gsl_permute_vector_inverse (perm, &col.vector); + } + + for(i=0; i<M; i++) { + for(j=0; j<N; j++) { + double aij = gsl_matrix_get(a, j, i); + double mij = gsl_matrix_get(m, i, j); + int foo = check(aij, mij, eps); + if(foo) { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, aij, mij); + } + s += foo; + } + } + + gsl_permutation_free (perm); + gsl_vector_free(norm); + gsl_vector_free(d); + gsl_matrix_free(lq); + gsl_matrix_free(a); + gsl_matrix_free(q); + gsl_matrix_free(l); + + return s; +} + +int test_PTLQ_decomp(void) +{ + int f; + int s = 0; + + f = test_PTLQ_decomp_dim(m35, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp m(3,5)"); + s += f; + + f = test_PTLQ_decomp_dim(m53, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp m(5,3)"); + s += f; + + f = test_PTLQ_decomp_dim(s35, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp s(3,5)"); + s += f; + + f = test_PTLQ_decomp_dim(s53, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp s(5,3)"); + s += f; + + f = test_PTLQ_decomp_dim(hilb2, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp hilbert(2)"); + s += f; + + f = test_PTLQ_decomp_dim(hilb3, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp hilbert(3)"); + s += f; + + f = test_PTLQ_decomp_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp hilbert(4)"); + s += f; + + f = test_PTLQ_decomp_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp hilbert(12)"); + s += f; + + f = test_PTLQ_decomp_dim(vander2, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp vander(2)"); + s += f; + + f = test_PTLQ_decomp_dim(vander3, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp vander(3)"); + s += f; + + f = test_PTLQ_decomp_dim(vander4, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " PTLQ_decomp vander(4)"); + s += f; + + f = test_PTLQ_decomp_dim(vander12, 0.0005); /* FIXME: bad accuracy */ + gsl_test(f, " PTLQ_decomp vander(12)"); + s += f; + + return s; +} + + +int +test_LQ_update_dim(const gsl_matrix * m, double eps) +{ + int s = 0; + unsigned long i,j, M = m->size1, N = m->size2; + + gsl_matrix * lq1 = gsl_matrix_alloc(N,M); + gsl_matrix * lq2 = gsl_matrix_alloc(N,M); + gsl_matrix * q1 = gsl_matrix_alloc(M,M); + gsl_matrix * l1 = gsl_matrix_alloc(N,M); + gsl_matrix * q2 = gsl_matrix_alloc(M,M); + gsl_matrix * l2 = gsl_matrix_alloc(N,M); + gsl_vector * d2 = gsl_vector_alloc(GSL_MIN(M,N)); + gsl_vector * u = gsl_vector_alloc(M); + gsl_vector * v = gsl_vector_alloc(N); + gsl_vector * w = gsl_vector_alloc(M); + + gsl_matrix_transpose_memcpy(lq1,m); + gsl_matrix_transpose_memcpy(lq2,m); + for(i=0; i<M; i++) gsl_vector_set(u, i, sin(i+1.0)); + for(i=0; i<N; i++) gsl_vector_set(v, i, cos(i+2.0) + sin(i*i+3.0)); + + /* lq1 is updated */ + + gsl_blas_dger(1.0, v, u, lq1); + + /* lq2 is first decomposed, updated later */ + + s += gsl_linalg_LQ_decomp(lq2, d2); + s += gsl_linalg_LQ_unpack(lq2, d2, q2, l2); + + /* compute w = Q^T u */ + + gsl_blas_dgemv(CblasNoTrans, 1.0, q2, u, 0.0, w); + + /* now lq2 is updated */ + + s += gsl_linalg_LQ_update(q2, l2, v, w); + + /* multiply q2*l2 */ + + gsl_blas_dgemm(CblasNoTrans,CblasNoTrans,1.0,l2,q2,0.0,lq2); + + /* check lq1==lq2 */ + + for(i=0; i<N; i++) { + for(j=0; j<M; j++) { + double s1 = gsl_matrix_get(lq1, i, j); + double s2 = gsl_matrix_get(lq2, i, j); + + int foo = check(s1, s2, eps); +#if 0 + if(foo) { + printf("LQ:(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, s1, s2); + } +#endif + s += foo; + } + } + + gsl_vector_free(d2); + gsl_vector_free(u); + gsl_vector_free(v); + gsl_vector_free(w); + gsl_matrix_free(lq1); + gsl_matrix_free(lq2); + gsl_matrix_free(q1); + gsl_matrix_free(l1); + gsl_matrix_free(q2); + gsl_matrix_free(l2); + + return s; +} + +int test_LQ_update(void) +{ + int f; + int s = 0; + + f = test_LQ_update_dim(m35, 2 * 512.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_update m(3,5)"); + s += f; + + f = test_LQ_update_dim(m53, 2 * 512.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_update m(5,3)"); + s += f; + + f = test_LQ_update_dim(hilb2, 2 * 512.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_update hilbert(2)"); + s += f; + + f = test_LQ_update_dim(hilb3, 2 * 512.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_update hilbert(3)"); + s += f; + + f = test_LQ_update_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_update hilbert(4)"); + s += f; + + f = test_LQ_update_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_update hilbert(12)"); + s += f; + + f = test_LQ_update_dim(vander2, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_update vander(2)"); + s += f; + + f = test_LQ_update_dim(vander3, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_update vander(3)"); + s += f; + + f = test_LQ_update_dim(vander4, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " LQ_update vander(4)"); + s += f; + + f = test_LQ_update_dim(vander12, 0.0005); /* FIXME: bad accuracy */ + gsl_test(f, " LQ_update vander(12)"); + s += f; + + return s; +} + +int +test_SV_solve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + unsigned long i, dim = m->size1; + + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * u = gsl_matrix_alloc(dim,dim); + gsl_matrix * q = gsl_matrix_alloc(dim,dim); + gsl_vector * d = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_calloc(dim); + gsl_matrix_memcpy(u,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_SV_decomp(u, q, d, x); + s += gsl_linalg_SV_solve(u, q, d, rhs, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(u); + gsl_matrix_free(q); + gsl_vector_free(rhs); + + return s; +} + +int test_SV_solve(void) +{ + int f; + int s = 0; + + f = test_SV_solve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_solve hilbert(2)"); + s += f; + + f = test_SV_solve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_solve hilbert(3)"); + s += f; + + f = test_SV_solve_dim(hilb4, hilb4_solution, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_solve hilbert(4)"); + s += f; + + f = test_SV_solve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " SV_solve hilbert(12)"); + s += f; + + f = test_SV_solve_dim(vander2, vander2_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_solve vander(2)"); + s += f; + + f = test_SV_solve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_solve vander(3)"); + s += f; + + f = test_SV_solve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_solve vander(4)"); + s += f; + + f = test_SV_solve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " SV_solve vander(12)"); + s += f; + + return s; +} + +int +test_SV_decomp_dim(const gsl_matrix * m, double eps) +{ + int s = 0; + double di1; + unsigned long i,j, M = m->size1, N = m->size2; + + gsl_matrix * v = gsl_matrix_alloc(M,N); + gsl_matrix * a = gsl_matrix_alloc(M,N); + gsl_matrix * q = gsl_matrix_alloc(N,N); + gsl_matrix * dqt = gsl_matrix_alloc(N,N); + gsl_vector * d = gsl_vector_alloc(N); + gsl_vector * w = gsl_vector_alloc(N); + + gsl_matrix_memcpy(v,m); + + s += gsl_linalg_SV_decomp(v, q, d, w); + + /* Check that singular values are non-negative and in non-decreasing + order */ + + di1 = 0.0; + + for (i = 0; i < N; i++) + { + double di = gsl_vector_get (d, i); + + if (gsl_isnan (di)) + { + continue; /* skip NaNs */ + } + + if (di < 0) { + s++; + printf("singular value %lu = %22.18g < 0\n", i, di); + } + + if(i > 0 && di > di1) { + s++; + printf("singular value %lu = %22.18g vs previous %22.18g\n", i, di, di1); + } + + di1 = di; + } + + /* Scale dqt = D Q^T */ + + for (i = 0; i < N ; i++) + { + double di = gsl_vector_get (d, i); + + for (j = 0; j < N; j++) + { + double qji = gsl_matrix_get(q, j, i); + gsl_matrix_set (dqt, i, j, qji * di); + } + } + + /* compute a = v dqt */ + gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, v, dqt, 0.0, a); + + for(i=0; i<M; i++) { + for(j=0; j<N; j++) { + double aij = gsl_matrix_get(a, i, j); + double mij = gsl_matrix_get(m, i, j); + int foo = check(aij, mij, eps); + if(foo) { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, aij, mij); + } + s += foo; + } + } + gsl_vector_free(w); + gsl_vector_free(d); + gsl_matrix_free(v); + gsl_matrix_free(a); + gsl_matrix_free(q); + gsl_matrix_free(dqt); + + return s; +} + +int test_SV_decomp(void) +{ + int f; + int s = 0; + + f = test_SV_decomp_dim(m11, 2 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp m(1,1)"); + s += f; + + f = test_SV_decomp_dim(m51, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp m(5,1)"); + s += f; + + /* M<N not implemented yet */ +#if 0 + f = test_SV_decomp_dim(m35, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp m(3,5)"); + s += f; +#endif + f = test_SV_decomp_dim(m53, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp m(5,3)"); + s += f; + + f = test_SV_decomp_dim(moler10, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp moler(10)"); + s += f; + + f = test_SV_decomp_dim(hilb2, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp hilbert(2)"); + s += f; + + f = test_SV_decomp_dim(hilb3, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp hilbert(3)"); + s += f; + + f = test_SV_decomp_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp hilbert(4)"); + s += f; + + f = test_SV_decomp_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp hilbert(12)"); + s += f; + + f = test_SV_decomp_dim(vander2, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp vander(2)"); + s += f; + + f = test_SV_decomp_dim(vander3, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp vander(3)"); + s += f; + + f = test_SV_decomp_dim(vander4, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp vander(4)"); + s += f; + + f = test_SV_decomp_dim(vander12, 1e-4); + gsl_test(f, " SV_decomp vander(12)"); + s += f; + + f = test_SV_decomp_dim(row3, 10 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp row3"); + s += f; + + f = test_SV_decomp_dim(row5, 128 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp row5"); + s += f; + + f = test_SV_decomp_dim(row12, 1024 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp row12"); + s += f; + + f = test_SV_decomp_dim(inf5, 1024 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp inf5"); + s += f; + + f = test_SV_decomp_dim(nan5, 1024 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp nan5"); + s += f; + + + { + double i1, i2, i3, i4; + double lower = -2, upper = 2; + + for (i1 = lower; i1 <= upper; i1++) + { + for (i2 = lower; i2 <= upper; i2++) + { + for (i3 = lower; i3 <= upper; i3++) + { + for (i4 = lower; i4 <= upper; i4++) + { + gsl_matrix_set (A22, 0,0, i1); + gsl_matrix_set (A22, 0,1, i2); + gsl_matrix_set (A22, 1,0, i3); + gsl_matrix_set (A22, 1,1, i4); + + f = test_SV_decomp_dim(A22, 16 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp (2x2) A=[%g, %g; %g, %g]", i1,i2,i3,i4); + s += f; + } + } + } + } + } + + { + int i; + double carry = 0, lower = 0, upper = 1; + double *a = A33->data; + + for (i=0; i<9; i++) { + a[i] = lower; + } + + while (carry == 0.0) { + f = test_SV_decomp_dim(A33, 64 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp (3x3) A=[ %g, %g, %g; %g, %g, %g; %g, %g, %g]", + a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8]); + + /* increment */ + carry=1.0; + for (i=9; carry > 0.0 && i>0 && i--;) + { + double v=a[i]+carry; + carry = (v>upper) ? 1.0 : 0.0; + a[i] = (v>upper) ? lower : v; + } + } + } + +#ifdef TEST_SVD_4X4 + { + int i; + double carry = 0, lower = 0, upper = 1; + double *a = A44->data; + + for (i=0; i<16; i++) { + a[i] = lower; + } + + while (carry == 0.0) { + f = test_SV_decomp_dim(A44, 64 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp (4x4) A=[ %g, %g, %g, %g; %g, %g, %g, %g; %g, %g, %g, %g; %g, %g, %g, %g]", + a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9], + a[10], a[11], a[12], a[13], a[14], a[15]); + + /* increment */ + carry=1.0; + for (i=16; carry > 0.0 && i>0 && i--;) + { + double v=a[i]+carry; + carry = (v>upper) ? 1.0 : 0.0; + a[i] = (v>upper) ? lower : v; + } + } + } +#endif + + return s; +} + + +int +test_SV_decomp_mod_dim(const gsl_matrix * m, double eps) +{ + int s = 0; + double di1; + unsigned long i,j, M = m->size1, N = m->size2; + + gsl_matrix * v = gsl_matrix_alloc(M,N); + gsl_matrix * a = gsl_matrix_alloc(M,N); + gsl_matrix * q = gsl_matrix_alloc(N,N); + gsl_matrix * x = gsl_matrix_alloc(N,N); + gsl_matrix * dqt = gsl_matrix_alloc(N,N); + gsl_vector * d = gsl_vector_alloc(N); + gsl_vector * w = gsl_vector_alloc(N); + + gsl_matrix_memcpy(v,m); + + s += gsl_linalg_SV_decomp_mod(v, x, q, d, w); + + /* Check that singular values are non-negative and in non-decreasing + order */ + + di1 = 0.0; + + for (i = 0; i < N; i++) + { + double di = gsl_vector_get (d, i); + + if (gsl_isnan (di)) + { + continue; /* skip NaNs */ + } + + if (di < 0) { + s++; + printf("singular value %lu = %22.18g < 0\n", i, di); + } + + if(i > 0 && di > di1) { + s++; + printf("singular value %lu = %22.18g vs previous %22.18g\n", i, di, di1); + } + + di1 = di; + } + + /* Scale dqt = D Q^T */ + + for (i = 0; i < N ; i++) + { + double di = gsl_vector_get (d, i); + + for (j = 0; j < N; j++) + { + double qji = gsl_matrix_get(q, j, i); + gsl_matrix_set (dqt, i, j, qji * di); + } + } + + /* compute a = v dqt */ + gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, v, dqt, 0.0, a); + + for(i=0; i<M; i++) { + for(j=0; j<N; j++) { + double aij = gsl_matrix_get(a, i, j); + double mij = gsl_matrix_get(m, i, j); + int foo = check(aij, mij, eps); + if(foo) { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, aij, mij); + } + s += foo; + } + } + gsl_vector_free(w); + gsl_vector_free(d); + gsl_matrix_free(v); + gsl_matrix_free(a); + gsl_matrix_free(q); + gsl_matrix_free(dqt); + gsl_matrix_free (x); + + return s; +} + +int test_SV_decomp_mod(void) +{ + int f; + int s = 0; + + f = test_SV_decomp_mod_dim(m11, 2 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod m(1,1)"); + s += f; + + f = test_SV_decomp_mod_dim(m51, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod m(5,1)"); + s += f; + + /* M<N not implemented yet */ +#if 0 + f = test_SV_decomp_mod_dim(m35, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod m(3,5)"); + s += f; +#endif + f = test_SV_decomp_mod_dim(m53, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod m(5,3)"); + s += f; + + f = test_SV_decomp_mod_dim(moler10, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod moler(10)"); + s += f; + + f = test_SV_decomp_mod_dim(hilb2, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod hilbert(2)"); + s += f; + + f = test_SV_decomp_mod_dim(hilb3, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod hilbert(3)"); + s += f; + + f = test_SV_decomp_mod_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod hilbert(4)"); + s += f; + + f = test_SV_decomp_mod_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod hilbert(12)"); + s += f; + + f = test_SV_decomp_mod_dim(vander2, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod vander(2)"); + s += f; + + f = test_SV_decomp_mod_dim(vander3, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod vander(3)"); + s += f; + + f = test_SV_decomp_mod_dim(vander4, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod vander(4)"); + s += f; + + f = test_SV_decomp_mod_dim(vander12, 1e-4); + gsl_test(f, " SV_decomp_mod vander(12)"); + s += f; + + f = test_SV_decomp_mod_dim(row3, 10 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod row3"); + s += f; + + f = test_SV_decomp_mod_dim(row5, 128 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod row5"); + s += f; + + f = test_SV_decomp_mod_dim(row12, 1024 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod row12"); + s += f; + + f = test_SV_decomp_mod_dim(inf5, 1024 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod inf5"); + s += f; + + f = test_SV_decomp_mod_dim(nan5, 1024 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod nan5"); + s += f; + + + { + double i1, i2, i3, i4; + double lower = -2, upper = 2; + + for (i1 = lower; i1 <= upper; i1++) + { + for (i2 = lower; i2 <= upper; i2++) + { + for (i3 = lower; i3 <= upper; i3++) + { + for (i4 = lower; i4 <= upper; i4++) + { + gsl_matrix_set (A22, 0,0, i1); + gsl_matrix_set (A22, 0,1, i2); + gsl_matrix_set (A22, 1,0, i3); + gsl_matrix_set (A22, 1,1, i4); + + f = test_SV_decomp_mod_dim(A22, 16 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod (2x2) A=[%g, %g; %g, %g]", i1,i2,i3,i4); + s += f; + } + } + } + } + } + + { + int i; + double carry = 0, lower = 0, upper = 1; + double *a = A33->data; + + for (i=0; i<9; i++) { + a[i] = lower; + } + + while (carry == 0.0) { + f = test_SV_decomp_mod_dim(A33, 64 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod (3x3) A=[ %g, %g, %g; %g, %g, %g; %g, %g, %g]", + a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8]); + + /* increment */ + carry=1.0; + for (i=9; carry > 0.0 && i>0 && i--;) + { + double v=a[i]+carry; + carry = (v>upper) ? 1.0 : 0.0; + a[i] = (v>upper) ? lower : v; + } + } + } + +#ifdef TEST_SVD_4X4 + { + int i; + double carry = 0, lower = 0, upper = 1; + double *a = A44->data; + + for (i=0; i<16; i++) { + a[i] = lower; + } + + while (carry == 0.0) { + f = test_SV_decomp_mod_dim(A44, 64 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_mod (4x4) A=[ %g, %g, %g, %g; %g, %g, %g, %g; %g, %g, %g, %g; %g, %g, %g, %g]", + a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9], + a[10], a[11], a[12], a[13], a[14], a[15]); + + /* increment */ + carry=1.0; + for (i=16; carry>0.0 && i>0 && i--;) + { + double v=a[i]+carry; + carry = (v>upper) ? 1.0 : 0.0; + a[i] = (v>upper) ? lower : v; + } + } + } +#endif + + return s; +} + + +int +test_SV_decomp_jacobi_dim(const gsl_matrix * m, double eps) +{ + int s = 0; + double di1; + unsigned long i,j, M = m->size1, N = m->size2; + + gsl_matrix * v = gsl_matrix_alloc(M,N); + gsl_matrix * a = gsl_matrix_alloc(M,N); + gsl_matrix * q = gsl_matrix_alloc(N,N); + gsl_matrix * dqt = gsl_matrix_alloc(N,N); + gsl_vector * d = gsl_vector_alloc(N); + + gsl_matrix_memcpy(v,m); + + s += gsl_linalg_SV_decomp_jacobi(v, q, d); + if (s) + printf("call returned status = %d\n", s); + + /* Check that singular values are non-negative and in non-decreasing + order */ + + di1 = 0.0; + + for (i = 0; i < N; i++) + { + double di = gsl_vector_get (d, i); + + if (gsl_isnan (di)) + { + continue; /* skip NaNs */ + } + + if (di < 0) { + s++; + printf("singular value %lu = %22.18g < 0\n", i, di); + } + + if(i > 0 && di > di1) { + s++; + printf("singular value %lu = %22.18g vs previous %22.18g\n", i, di, di1); + } + + di1 = di; + } + + /* Scale dqt = D Q^T */ + + for (i = 0; i < N ; i++) + { + double di = gsl_vector_get (d, i); + + for (j = 0; j < N; j++) + { + double qji = gsl_matrix_get(q, j, i); + gsl_matrix_set (dqt, i, j, qji * di); + } + } + + /* compute a = v dqt */ + gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, v, dqt, 0.0, a); + + for(i=0; i<M; i++) { + for(j=0; j<N; j++) { + double aij = gsl_matrix_get(a, i, j); + double mij = gsl_matrix_get(m, i, j); + int foo = check(aij, mij, eps); + if(foo) { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, aij, mij); + } + s += foo; + } + } + gsl_vector_free(d); + gsl_matrix_free(v); + gsl_matrix_free(a); + gsl_matrix_free(q); + gsl_matrix_free(dqt); + + return s; +} + +int test_SV_decomp_jacobi(void) +{ + int f; + int s = 0; + + f = test_SV_decomp_jacobi_dim(m11, 2 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi m(1,1)"); + s += f; + + f = test_SV_decomp_jacobi_dim(m51, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi m(5,1)"); + s += f; + + /* M<N not implemented yet */ +#if 0 + f = test_SV_decomp_jacobi_dim(m35, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi m(3,5)"); + s += f; +#endif + f = test_SV_decomp_jacobi_dim(m53, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi m(5,3)"); + s += f; + + f = test_SV_decomp_jacobi_dim(moler10, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi moler(10)"); + s += f; + + f = test_SV_decomp_jacobi_dim(hilb2, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi hilbert(2)"); + s += f; + + f = test_SV_decomp_jacobi_dim(hilb3, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi hilbert(3)"); + s += f; + + f = test_SV_decomp_jacobi_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi hilbert(4)"); + s += f; + + f = test_SV_decomp_jacobi_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi hilbert(12)"); + s += f; + + f = test_SV_decomp_jacobi_dim(vander2, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi vander(2)"); + s += f; + + f = test_SV_decomp_jacobi_dim(vander3, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi vander(3)"); + s += f; + + f = test_SV_decomp_jacobi_dim(vander4, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi vander(4)"); + s += f; + + f = test_SV_decomp_jacobi_dim(vander12, 1e-4); + gsl_test(f, " SV_decomp_jacobi vander(12)"); + s += f; + + f = test_SV_decomp_jacobi_dim(row3, 10 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi row3"); + s += f; + + f = test_SV_decomp_jacobi_dim(row5, 128 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi row5"); + s += f; + + f = test_SV_decomp_jacobi_dim(row12, 1024 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi row12"); + s += f; + + +#ifdef TEST_JACOBI_INF + f = test_SV_decomp_jacobi_dim(inf5, 1024 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi inf5"); + s += f; + + f = test_SV_decomp_jacobi_dim(nan5, 1024 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi nan5"); + s += f; +#endif + + { + double i1, i2, i3, i4; + double lower = -2, upper = 2; + + for (i1 = lower; i1 <= upper; i1++) + { + for (i2 = lower; i2 <= upper; i2++) + { + for (i3 = lower; i3 <= upper; i3++) + { + for (i4 = lower; i4 <= upper; i4++) + { + gsl_matrix_set (A22, 0,0, i1); + gsl_matrix_set (A22, 0,1, i2); + gsl_matrix_set (A22, 1,0, i3); + gsl_matrix_set (A22, 1,1, i4); + + f = test_SV_decomp_jacobi_dim(A22, 16 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi (2x2) A=[%g, %g; %g, %g]", i1,i2,i3,i4); + s += f; + } + } + } + } + } + + { + int i; + double carry = 0, lower = 0, upper = 1; + double *a = A33->data; + + for (i=0; i<9; i++) { + a[i] = lower; + } + + while (carry == 0.0) { + f = test_SV_decomp_jacobi_dim(A33, 64 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi (3x3) A=[ %g, %g, %g; %g, %g, %g; %g, %g, %g]", + a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8]); + + /* increment */ + carry=1.0; + for (i=9; carry > 0.0 && i>0 && i--;) + { + double v=a[i]+carry; + carry = (v>upper) ? 1.0 : 0.0; + a[i] = (v>upper) ? lower : v; + } + } + } + +#ifdef TEST_SVD_4X4 + { + int i; + unsigned long k = 0; + double carry = 0, lower = 0, upper = 1; + double *a = A44->data; + + for (i=0; i<16; i++) { + a[i] = lower; + } + + while (carry == 0.0) { + k++; + f = test_SV_decomp_jacobi_dim(A44, 64 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi (4x4) A=[ %g, %g, %g, %g; %g, %g, %g, %g; %g, %g, %g, %g; %g, %g, %g, %g] %lu", + a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9], + a[10], a[11], a[12], a[13], a[14], a[15], k); + /* increment */ + carry=1.0; + for (i=16; carry > 0.0 && i>0 && i--;) + { + double v=a[i]+carry; + carry = (v>upper) ? 1.0 : 0.0; + a[i] = (v>upper) ? lower : v; + } + } + } +#endif + + { + int i; + unsigned long k = 0; + double carry = 0, lower = 0, upper = 1; + double *a = A55->data; + + for (i=0; i<25; i++) { + a[i] = lower; + } + + while (carry == 0.0) { + k++; + + if (k % 1001 == 0) + { + f = test_SV_decomp_jacobi_dim(A55, 64 * GSL_DBL_EPSILON); + gsl_test(f, " SV_decomp_jacobi (5x5) case=%lu",k); + } + + /* increment */ + carry=1.0; + for (i=25; carry >0.0 && i>0 && i--;) + { + double v=a[i]+carry; + carry = (v>upper) ? 1.0 : 0.0; + a[i] = (v>upper) ? lower : v; + } + } + } + + + return s; +} + + +int +test_cholesky_solve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + unsigned long i, dim = m->size1; + + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_matrix * u = gsl_matrix_alloc(dim,dim); + gsl_vector * x = gsl_vector_calloc(dim); + gsl_matrix_memcpy(u,m); + for(i=0; i<dim; i++) gsl_vector_set(rhs, i, i+1.0); + s += gsl_linalg_cholesky_decomp(u); + s += gsl_linalg_cholesky_solve(u, rhs, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i), actual[i], eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + gsl_vector_free(x); + gsl_matrix_free(u); + gsl_vector_free(rhs); + + return s; +} + +int test_cholesky_solve(void) +{ + int f; + int s = 0; + + f = test_cholesky_solve_dim(hilb2, hilb2_solution, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_solve hilbert(2)"); + s += f; + + f = test_cholesky_solve_dim(hilb3, hilb3_solution, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_solve hilbert(3)"); + s += f; + + f = test_cholesky_solve_dim(hilb4, hilb4_solution, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_solve hilbert(4)"); + s += f; + + f = test_cholesky_solve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " cholesky_solve hilbert(12)"); + s += f; + + return s; +} + + +int +test_cholesky_decomp_dim(const gsl_matrix * m, double eps) +{ + int s = 0; + unsigned long i,j, M = m->size1, N = m->size2; + + gsl_matrix * v = gsl_matrix_alloc(M,N); + gsl_matrix * a = gsl_matrix_alloc(M,N); + gsl_matrix * l = gsl_matrix_alloc(M,N); + gsl_matrix * lt = gsl_matrix_alloc(N,N); + + gsl_matrix_memcpy(v,m); + + s += gsl_linalg_cholesky_decomp(v); + + /* Compute L LT */ + + for (i = 0; i < N ; i++) + { + for (j = 0; j < N; j++) + { + double vij = gsl_matrix_get(v, i, j); + gsl_matrix_set (l, i, j, i>=j ? vij : 0); + gsl_matrix_set (lt, i, j, i<=j ? vij : 0); + } + } + + /* compute a = l lt */ + gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, l, lt, 0.0, a); + + for(i=0; i<M; i++) { + for(j=0; j<N; j++) { + double aij = gsl_matrix_get(a, i, j); + double mij = gsl_matrix_get(m, i, j); + int foo = check(aij, mij, eps); + if(foo) { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, aij, mij); + } + s += foo; + } + } + + gsl_matrix_free(v); + gsl_matrix_free(a); + gsl_matrix_free(l); + gsl_matrix_free(lt); + + return s; +} + +int test_cholesky_decomp(void) +{ + int f; + int s = 0; + + f = test_cholesky_decomp_dim(hilb2, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_decomp hilbert(2)"); + s += f; + + f = test_cholesky_decomp_dim(hilb3, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_decomp hilbert(3)"); + s += f; + + f = test_cholesky_decomp_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_decomp hilbert(4)"); + s += f; + + f = test_cholesky_decomp_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_decomp hilbert(12)"); + s += f; + + return s; +} + + +int +test_cholesky_decomp_unit_dim(const gsl_matrix * m, double eps) +{ + int s = 0; + const unsigned long M = m->size1; + const unsigned long N = m->size2; + unsigned long i,j; + + gsl_matrix * v = gsl_matrix_alloc(M,N); + gsl_matrix * a = gsl_matrix_alloc(M,N); + gsl_matrix * l = gsl_matrix_alloc(M,N); + gsl_matrix * lt = gsl_matrix_alloc(N,N); + gsl_matrix * dm = gsl_matrix_alloc(M,N); + gsl_vector * dv = gsl_vector_alloc(M); + + gsl_matrix_memcpy(v,m); + + s += gsl_linalg_cholesky_decomp_unit(v, dv); + + /* + for(i = 0; i < M; i++) + { + for(j = 0; j < N; j++) + { + printf("v[%lu,%lu]: %22.18e\n", i,j, gsl_matrix_get(v, i, j)); + } + } + + + for(i = 0; i < M; i++) + { + printf("d[%lu]: %22.18e\n", i, gsl_vector_get(dv, i)); + } + */ + + /* put L and transpose(L) into separate matrices */ + + for(i = 0; i < N ; i++) + { + for(j = 0; j < N; j++) + { + const double vij = gsl_matrix_get(v, i, j); + gsl_matrix_set (l, i, j, i>=j ? vij : 0); + gsl_matrix_set (lt, i, j, i<=j ? vij : 0); + } + } + + /* put D into its own matrix */ + + gsl_matrix_set_zero(dm); + for(i = 0; i < M; ++i) gsl_matrix_set(dm, i, i, gsl_vector_get(dv, i)); + + /* compute a = L * D * transpose(L); uses v for temp space */ + + gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, dm, lt, 0.0, v); + gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, l, v, 0.0, a); + + for(i = 0; i < M; i++) + { + for(j = 0; j < N; j++) + { + const double aij = gsl_matrix_get(a, i, j); + const double mij = gsl_matrix_get(m, i, j); + int foo = check(aij, mij, eps); + if(foo) + { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, aij, mij); + } + s += foo; + } + } + + gsl_vector_free(dv); + gsl_matrix_free(dm); + gsl_matrix_free(lt); + gsl_matrix_free(l); + gsl_matrix_free(v); + gsl_matrix_free(a); + + return s; +} + +int test_cholesky_decomp_unit(void) +{ + int f; + int s = 0; + + f = test_cholesky_decomp_unit_dim(hilb2, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_decomp_unit hilbert(2)"); + s += f; + + f = test_cholesky_decomp_unit_dim(hilb3, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_decomp_unit hilbert(3)"); + s += f; + + f = test_cholesky_decomp_unit_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_decomp_unit hilbert(4)"); + s += f; + + f = test_cholesky_decomp_unit_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " cholesky_decomp_unit hilbert(12)"); + s += f; + + return s; +} + + +int +test_HH_solve_dim(const gsl_matrix * m, const double * actual, double eps) +{ + int s = 0; + unsigned long i, dim = m->size1; + + gsl_permutation * perm = gsl_permutation_alloc(dim); + gsl_matrix * hh = gsl_matrix_alloc(dim,dim); + gsl_vector * d = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + gsl_matrix_memcpy(hh,m); + for(i=0; i<dim; i++) gsl_vector_set(x, i, i+1.0); + s += gsl_linalg_HH_svx(hh, x); + for(i=0; i<dim; i++) { + int foo = check(gsl_vector_get(x, i),actual[i],eps); + if( foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + gsl_vector_free(x); + gsl_vector_free(d); + gsl_matrix_free(hh); + gsl_permutation_free(perm); + + return s; +} + +int test_HH_solve(void) +{ + int f; + int s = 0; + + f = test_HH_solve_dim(hilb2, hilb2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " HH_solve hilbert(2)"); + s += f; + + f = test_HH_solve_dim(hilb3, hilb3_solution, 128.0 * GSL_DBL_EPSILON); + gsl_test(f, " HH_solve hilbert(3)"); + s += f; + + f = test_HH_solve_dim(hilb4, hilb4_solution, 2.0 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " HH_solve hilbert(4)"); + s += f; + + f = test_HH_solve_dim(hilb12, hilb12_solution, 0.5); + gsl_test(f, " HH_solve hilbert(12)"); + s += f; + + f = test_HH_solve_dim(vander2, vander2_solution, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " HH_solve vander(2)"); + s += f; + + f = test_HH_solve_dim(vander3, vander3_solution, 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " HH_solve vander(3)"); + s += f; + + f = test_HH_solve_dim(vander4, vander4_solution, 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " HH_solve vander(4)"); + s += f; + + f = test_HH_solve_dim(vander12, vander12_solution, 0.05); + gsl_test(f, " HH_solve vander(12)"); + s += f; + + return s; +} + + +int +test_TDS_solve_dim(unsigned long dim, double d, double od, const double * actual, double eps) +{ + int s = 0; + unsigned long i; + + gsl_vector * offdiag = gsl_vector_alloc(dim-1); + gsl_vector * diag = gsl_vector_alloc(dim); + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + + for(i=0; i<dim; i++) { + gsl_vector_set(diag, i, d); + gsl_vector_set(rhs, i, i + 1.0); + } + for(i=0; i<dim-1; i++) { + gsl_vector_set(offdiag, i, od); + } + + s += gsl_linalg_solve_symm_tridiag(diag, offdiag, rhs, x); + + for(i=0; i<dim; i++) { + double si = gsl_vector_get(x, i); + double ai = actual[i]; + int foo = check(si, ai, eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(x); + gsl_vector_free(rhs); + gsl_vector_free(diag); + gsl_vector_free(offdiag); + + return s; +} + + +int test_TDS_solve(void) +{ + int f; + int s = 0; + + { + double actual[] = {0.0, 2.0}; + f = test_TDS_solve_dim(2, 1.0, 0.5, actual, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDS dim=2 A"); + s += f; + } + + { + double actual[] = {3.0/8.0, 15.0/8.0}; + f = test_TDS_solve_dim(2, 1.0, 1.0/3.0, actual, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDS dim=2 B"); + s += f; + } + + { + double actual[] = {5.0/8.0, 9.0/8.0, 2.0, 15.0/8.0, 35.0/8.0}; + f = test_TDS_solve_dim(5, 1.0, 1.0/3.0, actual, 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDS dim=5"); + s += f; + } + + return s; +} + +int +test_TDS_cyc_solve_one(const unsigned long dim, const double * d, const double * od, + const double * r, const double * actual, double eps) +{ + int s = 0; + unsigned long i; + + gsl_vector * offdiag = gsl_vector_alloc(dim); + gsl_vector * diag = gsl_vector_alloc(dim); + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + + for(i=0; i<dim; i++) { + gsl_vector_set(diag, i, d[i]); + gsl_vector_set(rhs, i, r[i]); + gsl_vector_set(offdiag, i, od[i]); + } + + s += gsl_linalg_solve_symm_cyc_tridiag(diag, offdiag, rhs, x); + + for(i=0; i<dim; i++) { + double si = gsl_vector_get(x, i); + double ai = actual[i]; + int foo = check(si, ai, eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(x); + gsl_vector_free(rhs); + gsl_vector_free(diag); + gsl_vector_free(offdiag); + + return s; +} + +int test_TDS_cyc_solve(void) +{ + int f; + int s = 0; + +#ifdef SUPPORT_UNDERSIZE_CYC + { + unsigned long dim = 1; + double diag[] = { 2 }; + double offdiag[] = { 3 }; + double rhs[] = { 7 }; + double actual[] = { 3.5 }; + + f = test_TDS_cyc_solve_one(dim, diag, offdiag, rhs, actual, 28.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDS_cyc dim=%lu A", dim); + s += f; + } + + { + unsigned long dim = 2; + double diag[] = { 1, 2 }; + double offdiag[] = { 3, 4 }; + double rhs[] = { 7, -7 }; + double actual[] = { -5, 4 }; + + f = test_TDS_cyc_solve_one(dim, diag, offdiag, rhs, actual, 28.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDS_cyc dim=%lu A", dim); + s += f; + } +#endif + + { + unsigned long dim = 3; + double diag[] = { 1, 1, 1 }; + double offdiag[] = { 3, 3, 3 }; + double rhs[] = { 7, -7, 7 }; + double actual[] = { -2, 5, -2 }; + + f = test_TDS_cyc_solve_one(dim, diag, offdiag, rhs, actual, 28.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDS_cyc dim=%lu A", dim); + s += f; + } + + { + unsigned long dim = 5; + double diag[] = { 4, 2, 1, 2, 4 }; + double offdiag[] = { 1, 1, 1, 1, 1 }; + double rhs[] = { 30, -24, 3, 21, -30 }; + double actual[] = { 12, 3, -42, 42, -21 }; + + /* f = test_TDS_cyc_solve_one(dim, diag, offdiag, rhs, actual, 7.0 * GSL_DBL_EPSILON); + FIXME: bad accuracy */ + f = test_TDS_cyc_solve_one(dim, diag, offdiag, rhs, actual, 35.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDS_cyc dim=%lu B", dim); + s += f; + } + + return s; +} + +int +test_TDN_solve_dim(unsigned long dim, double d, double a, double b, const double * actual, double eps) +{ + int s = 0; + unsigned long i; + + gsl_vector * abovediag = gsl_vector_alloc(dim-1); + gsl_vector * belowdiag = gsl_vector_alloc(dim-1); + gsl_vector * diag = gsl_vector_alloc(dim); + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + + for(i=0; i<dim; i++) { + gsl_vector_set(diag, i, d); + gsl_vector_set(rhs, i, i + 1.0); + } + for(i=0; i<dim-1; i++) { + gsl_vector_set(abovediag, i, a); + gsl_vector_set(belowdiag, i, b); + } + + s += gsl_linalg_solve_tridiag(diag, abovediag, belowdiag, rhs, x); + + for(i=0; i<dim; i++) { + double si = gsl_vector_get(x, i); + double ai = actual[i]; + int foo = check(si, ai, eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(x); + gsl_vector_free(rhs); + gsl_vector_free(diag); + gsl_vector_free(abovediag); + gsl_vector_free(belowdiag); + + return s; +} + + +int test_TDN_solve(void) +{ + int f; + int s = 0; + double actual[16]; + + actual[0] = -7.0/3.0; + actual[1] = 5.0/3.0; + actual[2] = 4.0/3.0; + f = test_TDN_solve_dim(3, 1.0, 2.0, 1.0, actual, 2.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDN dim=2 A"); + s += f; + + actual[0] = 0.75; + actual[1] = 0.75; + actual[2] = 2.625; + f = test_TDN_solve_dim(3, 1.0, 1.0/3.0, 1.0/2.0, actual, 2.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDN dim=2 B"); + s += f; + + actual[0] = 99.0/140.0; + actual[1] = 41.0/35.0; + actual[2] = 19.0/10.0; + actual[3] = 72.0/35.0; + actual[4] = 139.0/35.0; + f = test_TDN_solve_dim(5, 1.0, 1.0/4.0, 1.0/2.0, actual, 35.0/8.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDN dim=5"); + s += f; + + return s; +} + +int +test_TDN_cyc_solve_dim(unsigned long dim, double d, double a, double b, const double * actual, double eps) +{ + int s = 0; + unsigned long i; + + gsl_vector * abovediag = gsl_vector_alloc(dim); + gsl_vector * belowdiag = gsl_vector_alloc(dim); + gsl_vector * diag = gsl_vector_alloc(dim); + gsl_vector * rhs = gsl_vector_alloc(dim); + gsl_vector * x = gsl_vector_alloc(dim); + + for(i=0; i<dim; i++) { + gsl_vector_set(diag, i, d); + gsl_vector_set(rhs, i, i + 1.0); + } + for(i=0; i<dim; i++) { + gsl_vector_set(abovediag, i, a); + gsl_vector_set(belowdiag, i, b); + } + + s += gsl_linalg_solve_cyc_tridiag(diag, abovediag, belowdiag, rhs, x); + + for(i=0; i<dim; i++) { + double si = gsl_vector_get(x, i); + double ai = actual[i]; + int foo = check(si, ai, eps); + if(foo) { + printf("%3lu[%lu]: %22.18g %22.18g\n", dim, i, gsl_vector_get(x, i), actual[i]); + } + s += foo; + } + + gsl_vector_free(x); + gsl_vector_free(rhs); + gsl_vector_free(diag); + gsl_vector_free(abovediag); + gsl_vector_free(belowdiag); + + return s; +} + + +int test_TDN_cyc_solve(void) +{ + int f; + int s = 0; + double actual[16]; + + actual[0] = 3.0/2.0; + actual[1] = -1.0/2.0; + actual[2] = 1.0/2.0; + f = test_TDN_cyc_solve_dim(3, 1.0, 2.0, 1.0, actual, 32.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDN_cyc dim=2 A"); + s += f; + + actual[0] = -5.0/22.0; + actual[1] = -3.0/22.0; + actual[2] = 29.0/22.0; + actual[3] = -9.0/22.0; + actual[4] = 43.0/22.0; + f = test_TDN_cyc_solve_dim(5, 3.0, 2.0, 1.0, actual, 66.0 * GSL_DBL_EPSILON); + gsl_test(f, " solve_TDN_cyc dim=5"); + s += f; + + return s; +} + +int +test_bidiag_decomp_dim(const gsl_matrix * m, double eps) +{ + int s = 0; + unsigned long i,j,k,r, M = m->size1, N = m->size2; + + gsl_matrix * A = gsl_matrix_alloc(M,N); + gsl_matrix * a = gsl_matrix_alloc(M,N); + gsl_matrix * b = gsl_matrix_alloc(N,N); + + gsl_matrix * u = gsl_matrix_alloc(M,N); + gsl_matrix * v = gsl_matrix_alloc(N,N); + + gsl_vector * tau1 = gsl_vector_alloc(N); + gsl_vector * tau2 = gsl_vector_alloc(N-1); + gsl_vector * d = gsl_vector_alloc(N); + gsl_vector * sd = gsl_vector_alloc(N-1); + + gsl_matrix_memcpy(A,m); + + s += gsl_linalg_bidiag_decomp(A, tau1, tau2); + s += gsl_linalg_bidiag_unpack(A, tau1, u, tau2, v, d, sd); + + gsl_matrix_set_zero(b); + for (i = 0; i < N; i++) gsl_matrix_set(b, i,i, gsl_vector_get(d,i)); + for (i = 0; i < N-1; i++) gsl_matrix_set(b, i,i+1, gsl_vector_get(sd,i)); + + /* Compute A = U B V^T */ + + for (i = 0; i < M ; i++) + { + for (j = 0; j < N; j++) + { + double sum = 0; + + for (k = 0; k < N; k++) + { + for (r = 0; r < N; r++) + { + sum += gsl_matrix_get(u, i, k) * gsl_matrix_get (b, k, r) + * gsl_matrix_get(v, j, r); + } + } + gsl_matrix_set (a, i, j, sum); + } + } + + for(i=0; i<M; i++) { + for(j=0; j<N; j++) { + double aij = gsl_matrix_get(a, i, j); + double mij = gsl_matrix_get(m, i, j); + int foo = check(aij, mij, eps); + if(foo) { + printf("(%3lu,%3lu)[%lu,%lu]: %22.18g %22.18g\n", M, N, i,j, aij, mij); + } + s += foo; + } + } + + gsl_matrix_free(A); + gsl_matrix_free(a); + gsl_matrix_free(u); + gsl_matrix_free(v); + gsl_matrix_free(b); + gsl_vector_free(tau1); + gsl_vector_free(tau2); + gsl_vector_free(d); + gsl_vector_free(sd); + + return s; +} + +int test_bidiag_decomp(void) +{ + int f; + int s = 0; + + f = test_bidiag_decomp_dim(m53, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " bidiag_decomp m(5,3)"); + s += f; + + f = test_bidiag_decomp_dim(m97, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " bidiag_decomp m(9,7)"); + s += f; + + f = test_bidiag_decomp_dim(hilb2, 2 * 8.0 * GSL_DBL_EPSILON); + gsl_test(f, " bidiag_decomp hilbert(2)"); + s += f; + + f = test_bidiag_decomp_dim(hilb3, 2 * 64.0 * GSL_DBL_EPSILON); + gsl_test(f, " bidiag_decomp hilbert(3)"); + s += f; + + f = test_bidiag_decomp_dim(hilb4, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " bidiag_decomp hilbert(4)"); + s += f; + + f = test_bidiag_decomp_dim(hilb12, 2 * 1024.0 * GSL_DBL_EPSILON); + gsl_test(f, " bidiag_decomp hilbert(12)"); + s += f; + + return s; +} + +void +my_error_handler (const char *reason, const char *file, int line, int err) +{ + if (0) printf ("(caught [%s:%d: %s (%d)])\n", file, line, reason, err) ; +} + +int main(void) +{ + gsl_ieee_env_setup (); + gsl_set_error_handler (&my_error_handler); + + m11 = create_general_matrix(1,1); + m51 = create_general_matrix(5,1); + + m35 = create_general_matrix(3,5); + m53 = create_general_matrix(5,3); + m97 = create_general_matrix(9,7); + + s35 = create_singular_matrix(3,5); + s53 = create_singular_matrix(5,3); + + hilb2 = create_hilbert_matrix(2); + hilb3 = create_hilbert_matrix(3); + hilb4 = create_hilbert_matrix(4); + hilb12 = create_hilbert_matrix(12); + + vander2 = create_vandermonde_matrix(2); + vander3 = create_vandermonde_matrix(3); + vander4 = create_vandermonde_matrix(4); + vander12 = create_vandermonde_matrix(12); + + moler10 = create_moler_matrix(10); + + c7 = create_complex_matrix(7); + + row3 = create_row_matrix(3,3); + row5 = create_row_matrix(5,5); + row12 = create_row_matrix(12,12); + + A22 = create_2x2_matrix (0.0, 0.0, 0.0, 0.0); + A33 = gsl_matrix_alloc(3,3); + A44 = gsl_matrix_alloc(4,4); + A55 = gsl_matrix_alloc(5,5); + + inf5 = create_diagonal_matrix (inf5_data, 5); + gsl_matrix_set(inf5, 3, 3, GSL_POSINF); + + nan5 = create_diagonal_matrix (inf5_data, 5); + gsl_matrix_set(nan5, 3, 3, GSL_NAN); + + + /* Matmult now obsolete */ +#ifdef MATMULT + gsl_test(test_matmult(), "Matrix Multiply"); + gsl_test(test_matmult_mod(), "Matrix Multiply with Modification"); +#endif + gsl_test(test_bidiag_decomp(), "Bidiagonal Decomposition"); + gsl_test(test_LU_solve(), "LU Decomposition and Solve"); + gsl_test(test_LUc_solve(), "Complex LU Decomposition and Solve"); + gsl_test(test_QR_decomp(), "QR Decomposition"); + gsl_test(test_QR_solve(), "QR Solve"); + gsl_test(test_LQ_solve(), "LQ Solve"); + gsl_test(test_PTLQ_solve(), "PTLQ Solve"); + + gsl_test(test_LQ_decomp(), "LQ Decomposition"); + gsl_test(test_LQ_LQsolve(), "LQ LQ Solve"); + gsl_test(test_LQ_lssolve(), "LQ LS Solve"); + gsl_test(test_LQ_update(), "LQ Rank-1 Update"); + gsl_test(test_QRPT_decomp(), "PTLQ Decomposition"); + gsl_test(test_PTLQ_solve(), "PTLQ Solve"); + + gsl_test(test_QR_QRsolve(), "QR QR Solve"); + gsl_test(test_QR_lssolve(), "QR LS Solve"); + gsl_test(test_QR_update(), "QR Rank-1 Update"); + gsl_test(test_QRPT_decomp(), "QRPT Decomposition"); + gsl_test(test_QRPT_solve(), "QRPT Solve"); + gsl_test(test_QRPT_QRsolve(), "QRPT QR Solve"); + gsl_test(test_SV_decomp(), "Singular Value Decomposition"); + gsl_test(test_SV_decomp_jacobi(), "Singular Value Decomposition (Jacobi)"); + gsl_test(test_SV_decomp_mod(), "Singular Value Decomposition (Mod)"); + gsl_test(test_SV_solve(), "SVD Solve"); + gsl_test(test_cholesky_decomp(), "Cholesky Decomposition"); + gsl_test(test_cholesky_decomp_unit(), "Cholesky Decomposition [unit triangular]"); + gsl_test(test_cholesky_solve(), "Cholesky Solve"); + gsl_test(test_HH_solve(), "Householder solve"); + gsl_test(test_TDS_solve(), "Tridiagonal symmetric solve"); + gsl_test(test_TDS_cyc_solve(), "Tridiagonal symmetric cyclic solve"); + gsl_test(test_TDN_solve(), "Tridiagonal nonsymmetric solve"); + gsl_test(test_TDN_cyc_solve(), "Tridiagonal nonsymmetric cyclic solve"); + + gsl_matrix_free(m11); + gsl_matrix_free(m35); + gsl_matrix_free(m51); + gsl_matrix_free(m53); + gsl_matrix_free(m97); + gsl_matrix_free(s35); + gsl_matrix_free(s53); + + gsl_matrix_free(hilb2); + gsl_matrix_free(hilb3); + gsl_matrix_free(hilb4); + gsl_matrix_free(hilb12); + + gsl_matrix_free(vander2); + gsl_matrix_free(vander3); + gsl_matrix_free(vander4); + gsl_matrix_free(vander12); + + gsl_matrix_free(moler10); + + gsl_matrix_complex_free(c7); + gsl_matrix_free(row3); + gsl_matrix_free(row5); + gsl_matrix_free(row12); + + gsl_matrix_free(A22); + gsl_matrix_free(A33); + gsl_matrix_free(A44); + gsl_matrix_free(A55); + + gsl_matrix_free (inf5); + gsl_matrix_free (nan5); + + exit (gsl_test_summary()); +} diff --git a/gsl-1.9/linalg/tridiag.c b/gsl-1.9/linalg/tridiag.c new file mode 100644 index 0000000..485fdcb --- /dev/null +++ b/gsl-1.9/linalg/tridiag.c @@ -0,0 +1,558 @@ +/* linalg/tridiag.c + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2002, 2004 Gerard Jungman, + * Brian Gough, David Necas + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Author: G. Jungman */ + +#include <config.h> +#include <stdlib.h> +#include <math.h> +#include <gsl/gsl_errno.h> +#include "tridiag.h" +#include <gsl/gsl_linalg.h> + +/* for description of method see [Engeln-Mullges + Uhlig, p. 92] + * + * diag[0] offdiag[0] 0 ..... + * offdiag[0] diag[1] offdiag[1] ..... + * 0 offdiag[1] diag[2] + * 0 0 offdiag[2] ..... + */ +static +int +solve_tridiag( + const double diag[], size_t d_stride, + const double offdiag[], size_t o_stride, + const double b[], size_t b_stride, + double x[], size_t x_stride, + size_t N) +{ + int status; + double *gamma = (double *) malloc (N * sizeof (double)); + double *alpha = (double *) malloc (N * sizeof (double)); + double *c = (double *) malloc (N * sizeof (double)); + double *z = (double *) malloc (N * sizeof (double)); + + if (gamma == 0 || alpha == 0 || c == 0 || z == 0) + { + status = GSL_ENOMEM; + } + else + { + size_t i, j; + + /* Cholesky decomposition + A = L.D.L^t + lower_diag(L) = gamma + diag(D) = alpha + */ + alpha[0] = diag[0]; + gamma[0] = offdiag[0] / alpha[0]; + + for (i = 1; i < N - 1; i++) + { + alpha[i] = diag[d_stride * i] - offdiag[o_stride*(i - 1)] * gamma[i - 1]; + gamma[i] = offdiag[o_stride * i] / alpha[i]; + } + + if (N > 1) + { + alpha[N - 1] = diag[d_stride * (N - 1)] - offdiag[o_stride*(N - 2)] * gamma[N - 2]; + } + + /* update RHS */ + z[0] = b[0]; + for (i = 1; i < N; i++) + { + z[i] = b[b_stride * i] - gamma[i - 1] * z[i - 1]; + } + for (i = 0; i < N; i++) + { + c[i] = z[i] / alpha[i]; + } + + /* backsubstitution */ + x[x_stride * (N - 1)] = c[N - 1]; + if (N >= 2) + { + for (i = N - 2, j = 0; j <= N - 2; j++, i--) + { + x[x_stride * i] = c[i] - gamma[i] * x[x_stride * (i + 1)]; + } + } + + status = GSL_SUCCESS; + } + + if (z != 0) + free (z); + if (c != 0) + free (c); + if (alpha != 0) + free (alpha); + if (gamma != 0) + free (gamma); + + return status; +} + +/* plain gauss elimination, only not bothering with the zeroes + * + * diag[0] abovediag[0] 0 ..... + * belowdiag[0] diag[1] abovediag[1] ..... + * 0 belowdiag[1] diag[2] + * 0 0 belowdiag[2] ..... + */ +static +int +solve_tridiag_nonsym( + const double diag[], size_t d_stride, + const double abovediag[], size_t a_stride, + const double belowdiag[], size_t b_stride, + const double rhs[], size_t r_stride, + double x[], size_t x_stride, + size_t N) +{ + int status; + double *alpha = (double *) malloc (N * sizeof (double)); + double *z = (double *) malloc (N * sizeof (double)); + + if (alpha == 0 || z == 0) + { + status = GSL_ENOMEM; + } + else + { + size_t i, j; + + /* Bidiagonalization (eliminating belowdiag) + & rhs update + diag' = alpha + rhs' = z + */ + alpha[0] = diag[0]; + z[0] = rhs[0]; + + for (i = 1; i < N; i++) + { + const double t = belowdiag[b_stride*(i - 1)]/alpha[i-1]; + alpha[i] = diag[d_stride*i] - t*abovediag[a_stride*(i - 1)]; + z[i] = rhs[r_stride*i] - t*z[i-1]; + /* FIXME!!! */ + if (alpha[i] == 0) { + status = GSL_EZERODIV; + goto solve_tridiag_nonsym_END; + } + } + + /* backsubstitution */ + x[x_stride * (N - 1)] = z[N - 1]/alpha[N - 1]; + if (N >= 2) + { + for (i = N - 2, j = 0; j <= N - 2; j++, i--) + { + x[x_stride * i] = (z[i] - abovediag[a_stride*i] * x[x_stride * (i + 1)])/alpha[i]; + } + } + + status = GSL_SUCCESS; + } + +solve_tridiag_nonsym_END: + if (z != 0) + free (z); + if (alpha != 0) + free (alpha); + + return status; +} + +/* for description of method see [Engeln-Mullges + Uhlig, p. 96] + * + * diag[0] offdiag[0] 0 ..... offdiag[N-1] + * offdiag[0] diag[1] offdiag[1] ..... + * 0 offdiag[1] diag[2] + * 0 0 offdiag[2] ..... + * ... ... + * offdiag[N-1] ... + * + */ +static +int +solve_cyc_tridiag( + const double diag[], size_t d_stride, + const double offdiag[], size_t o_stride, + const double b[], size_t b_stride, + double x[], size_t x_stride, + size_t N) +{ + int status; + double * delta = (double *) malloc (N * sizeof (double)); + double * gamma = (double *) malloc (N * sizeof (double)); + double * alpha = (double *) malloc (N * sizeof (double)); + double * c = (double *) malloc (N * sizeof (double)); + double * z = (double *) malloc (N * sizeof (double)); + + if (delta == 0 || gamma == 0 || alpha == 0 || c == 0 || z == 0) + { + status = GSL_ENOMEM; + } + else + { + size_t i, j; + double sum = 0.0; + + /* factor */ + + if (N == 1) + { + x[0] = b[0] / diag[0]; + return GSL_SUCCESS; + } + + alpha[0] = diag[0]; + gamma[0] = offdiag[0] / alpha[0]; + delta[0] = offdiag[o_stride * (N-1)] / alpha[0]; + + for (i = 1; i < N - 2; i++) + { + alpha[i] = diag[d_stride * i] - offdiag[o_stride * (i-1)] * gamma[i - 1]; + gamma[i] = offdiag[o_stride * i] / alpha[i]; + delta[i] = -delta[i - 1] * offdiag[o_stride * (i-1)] / alpha[i]; + } + + for (i = 0; i < N - 2; i++) + { + sum += alpha[i] * delta[i] * delta[i]; + } + + alpha[N - 2] = diag[d_stride * (N - 2)] - offdiag[o_stride * (N - 3)] * gamma[N - 3]; + + gamma[N - 2] = (offdiag[o_stride * (N - 2)] - offdiag[o_stride * (N - 3)] * delta[N - 3]) / alpha[N - 2]; + + alpha[N - 1] = diag[d_stride * (N - 1)] - sum - alpha[(N - 2)] * gamma[N - 2] * gamma[N - 2]; + + /* update */ + z[0] = b[0]; + for (i = 1; i < N - 1; i++) + { + z[i] = b[b_stride * i] - z[i - 1] * gamma[i - 1]; + } + sum = 0.0; + for (i = 0; i < N - 2; i++) + { + sum += delta[i] * z[i]; + } + z[N - 1] = b[b_stride * (N - 1)] - sum - gamma[N - 2] * z[N - 2]; + for (i = 0; i < N; i++) + { + c[i] = z[i] / alpha[i]; + } + + /* backsubstitution */ + x[x_stride * (N - 1)] = c[N - 1]; + x[x_stride * (N - 2)] = c[N - 2] - gamma[N - 2] * x[x_stride * (N - 1)]; + if (N >= 3) + { + for (i = N - 3, j = 0; j <= N - 3; j++, i--) + { + x[x_stride * i] = c[i] - gamma[i] * x[x_stride * (i + 1)] - delta[i] * x[x_stride * (N - 1)]; + } + } + + status = GSL_SUCCESS; + } + + if (z != 0) + free (z); + if (c != 0) + free (c); + if (alpha != 0) + free (alpha); + if (gamma != 0) + free (gamma); + if (delta != 0) + free (delta); + + return status; +} + +/* solve following system w/o the corner elements and then use + * Sherman-Morrison formula to compensate for them + * + * diag[0] abovediag[0] 0 ..... belowdiag[N-1] + * belowdiag[0] diag[1] abovediag[1] ..... + * 0 belowdiag[1] diag[2] + * 0 0 belowdiag[2] ..... + * ... ... + * abovediag[N-1] ... + */ +static +int solve_cyc_tridiag_nonsym( + const double diag[], size_t d_stride, + const double abovediag[], size_t a_stride, + const double belowdiag[], size_t b_stride, + const double rhs[], size_t r_stride, + double x[], size_t x_stride, + size_t N) +{ + int status; + double *alpha = (double *) malloc (N * sizeof (double)); + double *zb = (double *) malloc (N * sizeof (double)); + double *zu = (double *) malloc (N * sizeof (double)); + double *w = (double *) malloc (N * sizeof (double)); + double beta; + + if (alpha == 0 || zb == 0 || zu == 0 || w == 0) + { + status = GSL_ENOMEM; + } + else + { + /* Bidiagonalization (eliminating belowdiag) + & rhs update + diag' = alpha + rhs' = zb + rhs' for Aq=u is zu + */ + zb[0] = rhs[0]; + if (diag[0] != 0) beta = -diag[0]; else beta = 1; + { + const double q = 1 - abovediag[0]*belowdiag[0]/(diag[0]*diag[d_stride]); + if (fabs(q/beta) > 0.5 && fabs(q/beta) < 2) { + beta *= (fabs(q/beta) < 1) ? 0.5 : 2; + } + } + zu[0] = beta; + alpha[0] = diag[0] - beta; + + + { + size_t i; + for (i = 1; i+1 < N; i++) + { + const double t = belowdiag[b_stride*(i - 1)]/alpha[i-1]; + alpha[i] = diag[d_stride*i] - t*abovediag[a_stride*(i - 1)]; + zb[i] = rhs[r_stride*i] - t*zb[i-1]; + zu[i] = -t*zu[i-1]; + /* FIXME!!! */ + if (alpha[i] == 0) { + status = GSL_EZERODIV; + goto solve_cyc_tridiag_nonsym_END; + } + } + } + + { + const size_t i = N-1; + const double t = belowdiag[b_stride*(i - 1)]/alpha[i-1]; + alpha[i] = diag[d_stride*i] + - abovediag[a_stride*i]*belowdiag[b_stride*i]/beta + - t*abovediag[a_stride*(i - 1)]; + zb[i] = rhs[r_stride*i] - t*zb[i-1]; + zu[i] = abovediag[a_stride*i] - t*zu[i-1]; + /* FIXME!!! */ + if (alpha[i] == 0) { + status = GSL_EZERODIV; + goto solve_cyc_tridiag_nonsym_END; + } + } + + + /* backsubstitution */ + { + size_t i, j; + w[N-1] = zu[N-1]/alpha[N-1]; + x[N-1] = zb[N-1]/alpha[N-1]; + for (i = N - 2, j = 0; j <= N - 2; j++, i--) + { + w[i] = (zu[i] - abovediag[a_stride*i] * w[i+1])/alpha[i]; + x[i*x_stride] = (zb[i] - abovediag[a_stride*i] * x[x_stride*(i + 1)])/alpha[i]; + } + } + + /* Sherman-Morrison */ + { + const double vw = w[0] + belowdiag[b_stride*(N - 1)]/beta * w[N-1]; + const double vx = x[0] + belowdiag[b_stride*(N - 1)]/beta * x[x_stride*(N - 1)]; + /* FIXME!!! */ + if (vw + 1 == 0) { + status = GSL_EZERODIV; + goto solve_cyc_tridiag_nonsym_END; + } + + { + size_t i; + for (i = 0; i < N; i++) + x[i] -= vx/(1 + vw)*w[i]; + } + } + + status = GSL_SUCCESS; + } + +solve_cyc_tridiag_nonsym_END: + if (zb != 0) + free (zb); + if (zu != 0) + free (zu); + if (w != 0) + free (w); + if (alpha != 0) + free (alpha); + + return status; +} + +int +gsl_linalg_solve_symm_tridiag( + const gsl_vector * diag, + const gsl_vector * offdiag, + const gsl_vector * rhs, + gsl_vector * solution) +{ + if(diag->size != rhs->size) + { + GSL_ERROR ("size of diag must match rhs", GSL_EBADLEN); + } + else if (offdiag->size != rhs->size-1) + { + GSL_ERROR ("size of offdiag must match rhs-1", GSL_EBADLEN); + } + else if (solution->size != rhs->size) + { + GSL_ERROR ("size of solution must match rhs", GSL_EBADLEN); + } + else + { + return solve_tridiag(diag->data, diag->stride, + offdiag->data, offdiag->stride, + rhs->data, rhs->stride, + solution->data, solution->stride, + diag->size); + } +} + +int +gsl_linalg_solve_tridiag( + const gsl_vector * diag, + const gsl_vector * abovediag, + const gsl_vector * belowdiag, + const gsl_vector * rhs, + gsl_vector * solution) +{ + if(diag->size != rhs->size) + { + GSL_ERROR ("size of diag must match rhs", GSL_EBADLEN); + } + else if (abovediag->size != rhs->size-1) + { + GSL_ERROR ("size of abovediag must match rhs-1", GSL_EBADLEN); + } + else if (belowdiag->size != rhs->size-1) + { + GSL_ERROR ("size of belowdiag must match rhs-1", GSL_EBADLEN); + } + else if (solution->size != rhs->size) + { + GSL_ERROR ("size of solution must match rhs", GSL_EBADLEN); + } + else + { + return solve_tridiag_nonsym(diag->data, diag->stride, + abovediag->data, abovediag->stride, + belowdiag->data, belowdiag->stride, + rhs->data, rhs->stride, + solution->data, solution->stride, + diag->size); + } +} + + +int +gsl_linalg_solve_symm_cyc_tridiag( + const gsl_vector * diag, + const gsl_vector * offdiag, + const gsl_vector * rhs, + gsl_vector * solution) +{ + if(diag->size != rhs->size) + { + GSL_ERROR ("size of diag must match rhs", GSL_EBADLEN); + } + else if (offdiag->size != rhs->size) + { + GSL_ERROR ("size of offdiag must match rhs", GSL_EBADLEN); + } + else if (solution->size != rhs->size) + { + GSL_ERROR ("size of solution must match rhs", GSL_EBADLEN); + } + else if (diag->size < 3) + { + GSL_ERROR ("size of cyclic system must be 3 or more", GSL_EBADLEN); + } + else + { + return solve_cyc_tridiag(diag->data, diag->stride, + offdiag->data, offdiag->stride, + rhs->data, rhs->stride, + solution->data, solution->stride, + diag->size); + } +} + +int +gsl_linalg_solve_cyc_tridiag( + const gsl_vector * diag, + const gsl_vector * abovediag, + const gsl_vector * belowdiag, + const gsl_vector * rhs, + gsl_vector * solution) +{ + if(diag->size != rhs->size) + { + GSL_ERROR ("size of diag must match rhs", GSL_EBADLEN); + } + else if (abovediag->size != rhs->size) + { + GSL_ERROR ("size of abovediag must match rhs", GSL_EBADLEN); + } + else if (belowdiag->size != rhs->size) + { + GSL_ERROR ("size of belowdiag must match rhs", GSL_EBADLEN); + } + else if (solution->size != rhs->size) + { + GSL_ERROR ("size of solution must match rhs", GSL_EBADLEN); + } + else if (diag->size < 3) + { + GSL_ERROR ("size of cyclic system must be 3 or more", GSL_EBADLEN); + } + else + { + return solve_cyc_tridiag_nonsym(diag->data, diag->stride, + abovediag->data, abovediag->stride, + belowdiag->data, belowdiag->stride, + rhs->data, rhs->stride, + solution->data, solution->stride, + diag->size); + } +} diff --git a/gsl-1.9/linalg/tridiag.h b/gsl-1.9/linalg/tridiag.h new file mode 100644 index 0000000..f52f2f2 --- /dev/null +++ b/gsl-1.9/linalg/tridiag.h @@ -0,0 +1,67 @@ +/* linalg/tridiag.h + * + * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2002 Gerard Jungman, + * Brian Gough, David Necas + * + * 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 2 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + */ + +/* Author: G. Jungman + */ +/* Low level tridiagonal solvers. + * Used internally in other areas of GSL. + */ +#ifndef __GSL_TRIDIAG_H__ +#define __GSL_TRIDIAG_H__ + +#include <stdlib.h> + +static +int solve_tridiag_nonsym( + const double diag[], size_t d_stride, + const double abovediag[], size_t a_stride, + const double belowdiag[], size_t b_stride, + const double rhs[], size_t r_stride, + double x[], size_t x_stride, + size_t N + ); + +static +int solve_tridiag( + const double diag[], size_t d_stride, + const double offdiag[], size_t o_stride, + const double b[], size_t b_stride, + double x[], size_t x_stride, + size_t N); + +static +int solve_cyc_tridiag( + const double diag[], size_t d_stride, + const double offdiag[], size_t o_stride, + const double b[], size_t b_stride, + double x[], size_t x_stride, + size_t N + ); + +static +int solve_cyc_tridiag_nonsym( + const double diag[], size_t d_stride, + const double abovediag[], size_t a_stride, + const double belowdiag[], size_t b_stride, + const double rhs[], size_t r_stride, + double x[], size_t x_stride, + size_t N); + +#endif /* __GSL_TRIDIAG_H__ */ |