Mercurial > hg > octave-lyh
diff liboctave/Matrix-ext.cc @ 3:9a4c07481e61
[project @ 1993-08-08 01:20:23 by jwe]
Initial revision
author | jwe |
---|---|
date | Sun, 08 Aug 1993 01:21:46 +0000 |
parents | |
children | 2cd2476fb32d |
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/liboctave/Matrix-ext.cc @@ -0,0 +1,751 @@ +// Extra Matrix manipulations. -*- C++ -*- +/* + +Copyright (C) 1992 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#ifdef __GNUG__ +#pragma implementation +#endif + +#include "Matrix.h" +#include "mx-inlines.cc" + +/* + * HESS stuff + */ + +int +HESS::init (const Matrix& a) +{ + if (a.nr != a.nc) + FAIL; + + char jobbal = 'S'; + char side = 'R'; + + int n = a.nc; + int lwork = 32 * n; + int info; + int ilo; + int ihi; + + double *h = dup(a.data, a.len); + + double *tau = new double [n+1]; + double *scale = new double [n]; + double *z = new double [n*n]; + double *work = new double [lwork]; + + F77_FCN (dgebal) (&jobbal, &n, h, &n, &ilo, &ihi, scale, &info, + 1L, 1L); + + F77_FCN (dgehrd) (&n, &ilo, &ihi, h, &n, tau, work, &lwork, &info, + 1L, 1L); + + copy(z,h,n*n); + + F77_FCN (dorghr) (&n, &ilo, &ihi, z, &n, tau, work, &lwork, &info, + 1L, 1L); + + F77_FCN (dgebak) (&jobbal, &side, &n, &ilo, &ihi, scale, &n, z, &n, + &info, 1L, 1L); + +// We need to clear out all of the area below the sub-diagonal which was used +// to store the unitary matrix. + + hess_mat = Matrix(h,n,n); + unitary_hess_mat = Matrix(z,n,n); + +// If someone thinks of a more graceful way of doing this (or faster for +// that matter :-)), please let me know! + + if (n > 2) + for (int j = 0; j < a.nc; j++) + for (int i = j+2; i < a.nr; i++) + hess_mat.elem(i,j) = 0; + + delete [] tau; + delete [] work; + delete [] scale; + + return info; +} + + +int +ComplexHESS::init (const ComplexMatrix& a) +{ + if (a.nr != a.nc) + FAIL; + + char job = 'S'; + char side = 'R'; + + int n = a.nc; + int lwork = 32 * n; + int info; + int ilo; + int ihi; + + Complex *h = dup(a.data,a.len); + + double *scale = new double [n]; + Complex *tau = new Complex [n-1]; + Complex *work = new Complex [lwork]; + Complex *z = new Complex [n*n]; + + F77_FCN (zgebal) (&job, &n, h, &n, &ilo, &ihi, scale, &info, 1L, 1L); + + F77_FCN (zgehrd) (&n, &ilo, &ihi, h, &n, tau, work, &lwork, &info, 1L, + 1L); + + copy(z,h,n*n); + + F77_FCN (zunghr) (&n, &ilo, &ihi, z, &n, tau, work, &lwork, &info, 1L, + 1L); + + F77_FCN (zgebak) (&job, &side, &n, &ilo, &ihi, scale, &n, z, &n, &info, + 1L, 1L); + + hess_mat = ComplexMatrix (h,n,n); + unitary_hess_mat = ComplexMatrix (z,n,n); + +// If someone thinks of a more graceful way of doing this (or faster for +// that matter :-)), please let me know! + + if (n > 2) + for (int j = 0; j < a.nc; j++) + for (int i = j+2; i < a.nr; i++) + hess_mat.elem(i,j) = 0; + + delete [] work; + delete [] tau; + delete [] scale; + + return info; +} + +/* + * SCHUR stuff + */ + +static int +select_ana (double *a, double *b) +{ + return (*a < 0.0); +} + +static int +select_dig (double *a, double *b) +{ + return (hypot (*a, *b) < 1.0); +} + +// GAG. +extern "C" { static int (*dummy_select)(); } + +int +SCHUR::init (const Matrix& a, const char *ord) +{ + if (a.nr != a.nc) + FAIL; + + char jobvs = 'V'; + char sort; + + if (*ord == 'A' || *ord == 'D' || *ord == 'a' || *ord == 'd') + sort = 'S'; + else + sort = 'N'; + + char sense = 'N'; + + int n = a.nc; + int lwork = 8 * n; + int liwork = 1; + int info; + int sdim; + double rconde; + double rcondv; + + double *s = dup(a.data,a.len); + + double *wr = new double [n]; + double *wi = new double [n]; + double *q = new double [n*n]; + double *work = new double [lwork]; + +// These are not referenced for the non-ordered Schur routine. + + int *iwork = (int *) NULL; + int *bwork = (int *) NULL; + if (*ord == 'A' || *ord == 'D' || *ord == 'a' || *ord == 'd') + { + iwork = new int [liwork]; + bwork = new int [n]; + } + + if (*ord == 'A' || *ord == 'a') + { + F77_FCN (dgeesx) (&jobvs, &sort, select_ana, &sense, &n, s, &n, + &sdim, wr, wi, q, &n, &rconde, &rcondv, work, + &lwork, iwork, &liwork, bwork, &info, 1L, 1L); + } + else if (*ord == 'D' || *ord == 'd') + { + F77_FCN (dgeesx) (&jobvs, &sort, select_dig, &sense, &n, s, &n, + &sdim, wr, wi, q, &n, &rconde, &rcondv, work, + &lwork, iwork, &liwork, bwork, &info, 1L, 1L); + + } + else + { + F77_FCN (dgeesx) (&jobvs, &sort, dummy_select, &sense, &n, s, + &n, &sdim, wr, wi, q, &n, &rconde, &rcondv, + work, &lwork, iwork, &liwork, bwork, &info, + 1L, 1L); + } + + + schur_mat = Matrix (s, n, n); + unitary_mat = Matrix (q, n, n); + + delete [] wr; + delete [] wi; + delete [] work; + delete [] iwork; + delete [] bwork; + + return info; +} + +static int +complex_select_ana (Complex *a) +{ + return (real (*a) < 0.0); +} + +static int +complex_select_dig (Complex *a) +{ + return (abs (*a) < 1.0); +} + +int +ComplexSCHUR::init (const ComplexMatrix& a, const char *ord) +{ + if (a.nr != a.nc) + FAIL; + + char jobvs = 'V'; + char sort; + if (*ord == 'A' || *ord == 'D' || *ord == 'a' || *ord == 'd') + sort = 'S'; + else + sort = 'N'; + + char sense = 'N'; + + int n = a.nc; + int lwork = 8 * n; + int info; + int sdim; + double rconde; + double rcondv; + + double *rwork = new double [n]; + +// bwork is not referenced for non-ordered Schur. + + int *bwork = (int *) NULL; + if (*ord == 'A' || *ord == 'D' || *ord == 'a' || *ord == 'd') + bwork = new int [n]; + + Complex *s = dup(a.data,a.len); + + Complex *work = new Complex [lwork]; + Complex *q = new Complex [n*n]; + Complex *w = new Complex [n]; + + if (*ord == 'A' || *ord == 'a') + { + F77_FCN (zgeesx) (&jobvs, &sort, complex_select_ana, &sense, + &n, s, &n, &sdim, w, q, &n, &rconde, &rcondv, + work, &lwork, rwork, bwork, &info, 1L, 1L); + } + else if (*ord == 'D' || *ord == 'd') + { + F77_FCN (zgeesx) (&jobvs, &sort, complex_select_dig, &sense, + &n, s, &n, &sdim, w, q, &n, &rconde, &rcondv, + work, &lwork, rwork, bwork, &info, 1L, 1L); + } + else + { + F77_FCN (zgeesx) (&jobvs, &sort, dummy_select, &sense, &n, s, + &n, &sdim, w, q, &n, &rconde, &rcondv, work, + &lwork, rwork, bwork, &info, 1L, 1L); + } + + schur_mat = ComplexMatrix (s,n,n); + unitary_mat = ComplexMatrix (q,n,n); + + delete [] w; + delete [] work; + delete [] rwork; + delete [] bwork; + + return info; +} + +ostream& +operator << (ostream& os, const SCHUR& a) +{ + os << a.schur_matrix () << "\n"; + os << a.unitary_matrix () << "\n"; + + return os; +} + +/* + * SVD stuff + */ + +int +SVD::init (const Matrix& a) +{ + int info; + + int m = a.nr; + int n = a.nc; + + char jobu = 'A'; + char jobv = 'A'; + + double *tmp_data = dup (a.data, a.len); + + int min_mn = m < n ? m : n; + int max_mn = m > n ? m : n; + + double *u = new double[m*m]; + double *s_vec = new double[min_mn]; + double *vt = new double[n*n]; + + int tmp1 = 3*min_mn + max_mn; + int tmp2 = 5*min_mn - 4; + int lwork = tmp1 > tmp2 ? tmp1 : tmp2; + double *work = new double[lwork]; + + F77_FCN (dgesvd) (&jobu, &jobv, &m, &n, tmp_data, &m, s_vec, u, &m, + vt, &n, work, &lwork, &info, 1L, 1L); + + left_sm = Matrix (u, m, m); + sigma = DiagMatrix (s_vec, m, n); + Matrix vt_m (vt, n, n); + right_sm = Matrix (vt_m.transpose ()); + + delete [] tmp_data; + delete [] work; + + return info; +} + +ostream& +operator << (ostream& os, const SVD& a) +{ + os << a.left_singular_matrix () << "\n"; + os << a.singular_values () << "\n"; + os << a.right_singular_matrix () << "\n"; + + return os; +} + +int +ComplexSVD::init (const ComplexMatrix& a) +{ + int info; + + int m = a.nr; + int n = a.nc; + + char jobu = 'A'; + char jobv = 'A'; + + Complex *tmp_data = dup (a.data, a.len); + + int min_mn = m < n ? m : n; + int max_mn = m > n ? m : n; + + Complex *u = new Complex[m*m]; + double *s_vec = new double[min_mn]; + Complex *vt = new Complex[n*n]; + + int lwork = 2*min_mn + max_mn; + Complex *work = new Complex[lwork]; + + int lrwork = 5*max_mn; + double *rwork = new double[lrwork]; + + F77_FCN (zgesvd) (&jobu, &jobv, &m, &n, tmp_data, &m, s_vec, u, &m, + vt, &n, work, &lwork, rwork, &info, 1L, 1L); + + left_sm = ComplexMatrix (u, m, m); + sigma = DiagMatrix (s_vec, m, n); + ComplexMatrix vt_m (vt, n, n); + right_sm = ComplexMatrix (vt_m.hermitian ()); + + delete [] tmp_data; + delete [] work; + + return info; +} + +/* + * EIG stuff. + */ + +int +EIG::init (const Matrix& a) +{ + if (a.nr != a.nc) + FAIL; + + int n = a.nr; + + int info; + + char jobvl = 'N'; + char jobvr = 'V'; + + double *tmp_data = dup (a.data, a.len); + double *wr = new double[n]; + double *wi = new double[n]; + Matrix vr (n, n); + double *pvr = vr.fortran_vec (); + int lwork = 8*n; + double *work = new double[lwork]; + + double dummy; + int idummy = 1; + + F77_FCN (dgeev) (&jobvl, &jobvr, &n, tmp_data, &n, wr, wi, &dummy, + &idummy, pvr, &n, work, &lwork, &info, 1L, 1L); + + lambda.resize (n); + v.resize (n, n); + + for (int j = 0; j < n; j++) + { + if (wi[j] == 0.0) + { + lambda.elem (j) = Complex (wr[j]); + for (int i = 0; i < n; i++) + v.elem (i, j) = vr.elem (i, j); + } + else + { + if (j+1 >= n) + FAIL; + + for (int i = 0; i < n; i++) + { + lambda.elem (j) = Complex (wr[j], wi[j]); + lambda.elem (j+1) = Complex (wr[j+1], wi[j+1]); + double real_part = vr.elem (i, j); + double imag_part = vr.elem (i, j+1); + v.elem (i, j) = Complex (real_part, imag_part); + v.elem (i, j+1) = Complex (real_part, -imag_part); + } + j++; + } + } + + delete [] tmp_data; + delete [] wr; + delete [] wi; + delete [] work; + + return info; +} + +int +EIG::init (const ComplexMatrix& a) +{ + + if (a.nr != a.nc) + FAIL; + + int n = a.nr; + + int info; + + char jobvl = 'N'; + char jobvr = 'V'; + + lambda.resize (n); + v.resize (n, n); + + Complex *pw = lambda.fortran_vec (); + Complex *pvr = v.fortran_vec (); + + Complex *tmp_data = dup (a.data, a.len); + + int lwork = 8*n; + Complex *work = new Complex[lwork]; + double *rwork = new double[4*n]; + + Complex dummy; + int idummy = 1; + + F77_FCN (zgeev) (&jobvl, &jobvr, &n, tmp_data, &n, pw, &dummy, + &idummy, pvr, &n, work, &lwork, rwork, &info, 1L, + 1L); + + delete [] tmp_data; + delete [] work; + delete [] rwork; + + return info; +} + +/* + * LU stuff. + */ + +LU::LU (const Matrix& a) +{ + if (a.nr == 0 || a.nc == 0 || a.nr != a.nc) + FAIL; + + int n = a.nr; + + int *ipvt = new int [n]; + int *pvt = new int [n]; + double *tmp_data = dup (a.data, a.len); + int info = 0; + int zero = 0; + double b; + + F77_FCN (dgesv) (&n, &zero, tmp_data, &n, ipvt, &b, &n, &info); + + Matrix A_fact (tmp_data, n, n); + + int i; + + for (i = 0; i < n; i++) + { + ipvt[i] -= 1; + pvt[i] = i; + } + + for (i = 0; i < n - 1; i++) + { + int k = ipvt[i]; + if (k != i) + { + int tmp = pvt[k]; + pvt[k] = pvt[i]; + pvt[i] = tmp; + } + } + + l.resize (n, n, 0.0); + u.resize (n, n, 0.0); + p.resize (n, n, 0.0); + + for (i = 0; i < n; i++) + { + p.elem (i, pvt[i]) = 1.0; + + int j; + + l.elem (i, i) = 1.0; + for (j = 0; j < i; j++) + l.elem (i, j) = A_fact.elem (i, j); + + for (j = i; j < n; j++) + u.elem (i, j) = A_fact.elem (i, j); + } + + delete [] ipvt; + delete [] pvt; +} + +ComplexLU::ComplexLU (const ComplexMatrix& a) +{ + if (a.nr == 0 || a.nc == 0 || a.nr != a.nc) + FAIL; + + int n = a.nr; + + int *ipvt = new int [n]; + int *pvt = new int [n]; + Complex *tmp_data = dup (a.data, a.len); + int info = 0; + int zero = 0; + Complex b; + + F77_FCN (zgesv) (&n, &zero, tmp_data, &n, ipvt, &b, &n, &info); + + ComplexMatrix A_fact (tmp_data, n, n); + + int i; + + for (i = 0; i < n; i++) + { + ipvt[i] -= 1; + pvt[i] = i; + } + + for (i = 0; i < n - 1; i++) + { + int k = ipvt[i]; + if (k != i) + { + int tmp = pvt[k]; + pvt[k] = pvt[i]; + pvt[i] = tmp; + } + } + + l.resize (n, n, 0.0); + u.resize (n, n, 0.0); + p.resize (n, n, 0.0); + + for (i = 0; i < n; i++) + { + p.elem (i, pvt[i]) = 1.0; + + int j; + + l.elem (i, i) = 1.0; + for (j = 0; j < i; j++) + l.elem (i, j) = A_fact.elem (i, j); + + for (j = i; j < n; j++) + u.elem (i, j) = A_fact.elem (i, j); + } + + delete [] ipvt; + delete [] pvt; +} + +/* + * QR stuff. + */ + +QR::QR (const Matrix& a) +{ + int m = a.nr; + int n = a.nc; + + if (m == 0 || n == 0) + FAIL; + + double *tmp_data; + int min_mn = m < n ? m : n; + double *tau = new double[min_mn]; + int lwork = 32*n; + double *work = new double[lwork]; + int info = 0; + + if (m > n) + { + tmp_data = new double [m*m]; + copy (tmp_data, a.data, a.len); + } + else + tmp_data = dup (a.data, a.len); + + F77_FCN (dgeqrf) (&m, &n, tmp_data, &m, tau, work, &lwork, &info); + + delete [] work; + + r.resize (m, n, 0.0); + for (int j = 0; j < n; j++) + { + int limit = j < min_mn-1 ? j : min_mn-1; + for (int i = 0; i <= limit; i++) + r.elem (i, j) = tmp_data[m*j+i]; + } + + lwork = 32*m; + work = new double[lwork]; + + F77_FCN (dorgqr) (&m, &m, &min_mn, tmp_data, &m, tau, work, &lwork, &info); + + q = Matrix (tmp_data, m, m); + + delete [] tau; + delete [] work; +} + +ComplexQR::ComplexQR (const ComplexMatrix& a) +{ + int m = a.nr; + int n = a.nc; + + if (m == 0 || n == 0) + FAIL; + + Complex *tmp_data; + int min_mn = m < n ? m : n; + Complex *tau = new Complex[min_mn]; + int lwork = 32*n; + Complex *work = new Complex[lwork]; + int info = 0; + + if (m > n) + { + tmp_data = new Complex [m*m]; + copy (tmp_data, a.data, a.len); + } + else + tmp_data = dup (a.data, a.len); + + F77_FCN (zgeqrf) (&m, &n, tmp_data, &m, tau, work, &lwork, &info); + + delete [] work; + + r.resize (m, n, 0.0); + for (int j = 0; j < n; j++) + { + int limit = j < min_mn-1 ? j : min_mn-1; + for (int i = 0; i <= limit; i++) + r.elem (i, j) = tmp_data[m*j+i]; + } + + lwork = 32*m; + work = new Complex[lwork]; + + F77_FCN (zungqr) (&m, &m, &min_mn, tmp_data, &m, tau, work, &lwork, &info); + + q = ComplexMatrix (tmp_data, m, m); + + delete [] tau; + delete [] work; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; page-delimiter: "^/\\*" *** +;;; End: *** +*/