Mercurial > octave-nkf
annotate liboctave/dbleHESS.cc @ 8920:eb63fbe60fab
update copyright notices
| author | John W. Eaton <jwe@octave.org> |
|---|---|
| date | Sat, 07 Mar 2009 10:41:27 -0500 |
| parents | 29980c6b8604 |
| children | 4c0cdbe0acca |
| rev | line source |
|---|---|
| 457 | 1 /* |
| 2 | |
| 8920 | 3 Copyright (C) 1994, 1995, 1996, 1997, 2002, 2003, 2004, 2005, 2007, 2008 |
| 7017 | 4 John W. Eaton |
| 457 | 5 |
| 6 This file is part of Octave. | |
| 7 | |
| 8 Octave is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 7016 | 10 Free Software Foundation; either version 3 of the License, or (at your |
| 11 option) any later version. | |
| 457 | 12 |
| 13 Octave is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 7016 | 19 along with Octave; see the file COPYING. If not, see |
| 20 <http://www.gnu.org/licenses/>. | |
| 457 | 21 |
| 22 */ | |
| 23 | |
| 24 #ifdef HAVE_CONFIG_H | |
| 1192 | 25 #include <config.h> |
| 457 | 26 #endif |
| 27 | |
| 28 #include "dbleHESS.h" | |
| 1847 | 29 #include "f77-fcn.h" |
| 457 | 30 #include "lo-error.h" |
| 31 | |
| 32 extern "C" | |
| 33 { | |
| 4552 | 34 F77_RET_T |
| 35 F77_FUNC (dgebal, DGEBAL) (F77_CONST_CHAR_ARG_DECL, | |
| 5275 | 36 const octave_idx_type&, double*, const octave_idx_type&, octave_idx_type&, |
| 37 octave_idx_type&, double*, octave_idx_type& | |
| 4552 | 38 F77_CHAR_ARG_LEN_DECL); |
| 457 | 39 |
| 4552 | 40 F77_RET_T |
| 5275 | 41 F77_FUNC (dgehrd, DGEHRD) (const octave_idx_type&, const octave_idx_type&, const octave_idx_type&, |
| 42 double*, const octave_idx_type&, double*, double*, | |
| 43 const octave_idx_type&, octave_idx_type&); | |
| 457 | 44 |
| 4552 | 45 F77_RET_T |
| 5275 | 46 F77_FUNC (dorghr, DORGHR) (const octave_idx_type&, const octave_idx_type&, const octave_idx_type&, |
| 47 double*, const octave_idx_type&, double*, double*, | |
| 48 const octave_idx_type&, octave_idx_type&); | |
| 457 | 49 |
| 4552 | 50 F77_RET_T |
| 51 F77_FUNC (dgebak, DGEBAK) (F77_CONST_CHAR_ARG_DECL, | |
| 52 F77_CONST_CHAR_ARG_DECL, | |
| 5275 | 53 const octave_idx_type&, const octave_idx_type&, const octave_idx_type&, double*, |
| 54 const octave_idx_type&, double*, const octave_idx_type&, octave_idx_type& | |
| 4552 | 55 F77_CHAR_ARG_LEN_DECL |
| 56 F77_CHAR_ARG_LEN_DECL); | |
| 457 | 57 } |
| 58 | |
| 5275 | 59 octave_idx_type |
| 457 | 60 HESS::init (const Matrix& a) |
| 61 { | |
| 5275 | 62 octave_idx_type a_nr = a.rows (); |
| 63 octave_idx_type a_nc = a.cols (); | |
| 1932 | 64 |
| 457 | 65 if (a_nr != a_nc) |
| 66 { | |
| 67 (*current_liboctave_error_handler) ("HESS requires square matrix"); | |
| 68 return -1; | |
| 69 } | |
| 70 | |
| 1932 | 71 char job = 'N'; |
| 72 char side = 'R'; | |
| 457 | 73 |
| 5275 | 74 octave_idx_type n = a_nc; |
| 75 octave_idx_type lwork = 32 * n; | |
| 76 octave_idx_type info; | |
| 77 octave_idx_type ilo; | |
| 78 octave_idx_type ihi; | |
| 457 | 79 |
| 1932 | 80 hess_mat = a; |
| 81 double *h = hess_mat.fortran_vec (); | |
| 457 | 82 |
| 1932 | 83 Array<double> scale (n); |
| 84 double *pscale = scale.fortran_vec (); | |
| 85 | |
| 4552 | 86 F77_XFCN (dgebal, DGEBAL, (F77_CONST_CHAR_ARG2 (&job, 1), |
| 87 n, h, n, ilo, ihi, pscale, info | |
| 88 F77_CHAR_ARG_LEN (1))); | |
| 457 | 89 |
|
7482
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
90 Array<double> tau (n-1); |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
91 double *ptau = tau.fortran_vec (); |
| 1932 | 92 |
|
7482
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
93 Array<double> work (lwork); |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
94 double *pwork = work.fortran_vec (); |
| 457 | 95 |
|
7482
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
96 F77_XFCN (dgehrd, DGEHRD, (n, ilo, ihi, h, n, ptau, pwork, |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
97 lwork, info)); |
| 457 | 98 |
|
7482
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
99 unitary_hess_mat = hess_mat; |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
100 double *z = unitary_hess_mat.fortran_vec (); |
| 457 | 101 |
|
7482
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
102 F77_XFCN (dorghr, DORGHR, (n, ilo, ihi, z, n, ptau, pwork, |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
103 lwork, info)); |
| 457 | 104 |
|
7482
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
105 F77_XFCN (dgebak, DGEBAK, (F77_CONST_CHAR_ARG2 (&job, 1), |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
106 F77_CONST_CHAR_ARG2 (&side, 1), |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
107 n, ilo, ihi, pscale, n, z, |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
108 n, info |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
109 F77_CHAR_ARG_LEN (1) |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
110 F77_CHAR_ARG_LEN (1))); |
| 457 | 111 |
|
7482
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
112 // If someone thinks of a more graceful way of doing |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
113 // this (or faster for that matter :-)), please let |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
114 // me know! |
| 457 | 115 |
|
7482
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
116 if (n > 2) |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
117 for (octave_idx_type j = 0; j < a_nc; j++) |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
118 for (octave_idx_type i = j+2; i < a_nr; i++) |
|
29980c6b8604
don't check f77_exception_encountered
John W. Eaton <jwe@octave.org>
parents:
7017
diff
changeset
|
119 hess_mat.elem (i, j) = 0; |
| 457 | 120 |
| 121 return info; | |
| 122 } | |
| 123 | |
| 124 /* | |
| 125 ;;; Local Variables: *** | |
| 126 ;;; mode: C++ *** | |
| 127 ;;; End: *** | |
| 128 */ |